frama-c-Phosphorus-20170501/0000755000175000017500000000000013113745012014364 5ustar mehdimehdiframa-c-Phosphorus-20170501/INSTALL.md0000644000175000017500000002611113113744733016026 0ustar mehdimehdi# Installing Frama-C ## Table of Contents - [Recommended mode: OPAM](#recommended-mode-opam) - [Frama-C Requirements](#frama-c-requirements) - [Installing OPAM](#installing-opam) - [Installing Frama-C from OPAM](#installing-frama-c-from-opam) - [Installing Custom Versions of Frama-C via OPAM](#installing-custom-versions-of-frama-c-via-opam) - [Installing Frama-C on Windows (via Cygwin + OPAM)](#installing-frama-c-on-windows-via-cygwin--opam) - [Installing Frama-C on Mac OS X](#installing-frama-c-on-mac-os-x) - [Installing Frama-C via your Linux distribution (Debian/Ubuntu/Fedora)](#installing-frama-c-via-your-linux-distribution-debianubuntufedora) - [Debian/Ubuntu](#debianubuntu) - [Fedora](#fedora) - [Compiling from source](#compiling-from-source) - [Quick Start](#quick-start) - [Full Compilation Guide](#full-compilation-guide) - [Available resources](#available-resources) - [Installing Additional Plugins](#installing-additional-plugins) ## Recommended mode: OPAM The preferred method of installation for Frama-C is using [OPAM](http://opam.ocaml.org/) (v1.2 or newer). First you need to install OPAM, then you may install Frama-C using OPAM: opam install frama-c **Note:** make sure your OPAM version is >= 1.2. Also, it is highly recommended that you install an external solver for OPAM, such as `aspcud`, otherwise unexpected dependency errors may occur during installation. ### Installing OPAM Several Linux distributions already include an `opam` package. OSX has OPAM through Homebrew. A Windows OPAM is currently being developed, but it is not yet stable. **Note**: Some distributions include an old version of OPAM (<= 1.1). It cannot be used to reliably install Frama-C due to conflicts between dependencies. If your system does not have an OPAM package, you can compile it from source, or use the provided OPAM binaries available at: http://opam.ocaml.org/doc/Install.html ### Installing Frama-C from OPAM There are two Frama-C packages in OPAM: - `frama-c-base`: minimal Frama-C installation, without GUI; few dependencies - `frama-c`: includes all GUI-related dependencies, plus other recommended packages. The `frama-c` package recommends the installation of optional packages, e.g. external provers for WP, such as `why3` and `coq`. To install `frama-c`, you may need to install Gtk, GtkSourceView and GnomeCanvas separately. These are C libraries with OCaml bindings used by the GUI. On many systems, OPAM can take care of these external dependencies through its `depext` plug-in: issuing the two commands opam install depext opam depext frama-c will install the appropriate system packages (this of course requires to have administrator rights on the system). ### Installing Custom Versions of Frama-C via OPAM If you have a **non-standard** version of Frama-C available (with proprietary extensions, custom plugins, etc.), you can use OPAM to install Frama-C's dependencies and compile your own sources directly: # optional: remove the standard frama-c package if it was installed opam remove --force frama-c frama-c-base # install Frama-C's dependencies opam install depext opam depext frama-c opam install --deps-only frama-c # install custom version of frama-c opam pin add frama-c-base where `` is the root of your unpacked Frama-C archive. If your extensions require other libraries than the ones already used by Frama-C, they must of course be installed as well. ### Installing Frama-C on Windows (via Cygwin + OPAM) Windows is not officially supported by the Frama-C team (as in, we may not have the time to fix all issues), but Frama-C has been succesfully compiled in Windows with the following tools: - Cygwin (for shell and installation support only; the compiled binaries do not depend on Cygwin) - OPAM for Windows (currently experimental) - OCaml MinGW-based compiler Installation instructions are described (and updated continuously) on the Frama-C wiki: https://bts.frama-c.com/dokuwiki/doku.php?id=mantis:frama-c:compiling_from_source Frama-C Windows releases are periodically made available on the non-official OPAM MinGW repository: https://github.com/fdopen/opam-repository-mingw ### Installing Frama-C on Mac OS X OPAM works perfectly on Mac OS via Homebrew. Recommended installation: General Mac OS tools for OCaml: xcode-select --install open http://brew.sh brew install git autoconf meld opam gmp Graphical User Interface: brew install gtk+ --with-jasper brew install gtksourceview libgnomecanvas graphviz opam install lablgtk ocamlgraph Required for Frama-C: opam install zarith Necessary for Frama-C/WP: opam install alt-ergo Also recommended for Frama-C/WP: opam install altgr-ergo coq coqide why3 ## Installing Frama-C via your Linux distribution (Debian/Ubuntu/Fedora) **NOTE**: Distribution packages are not as up-to-date as OPAM packages. We recommend using OPAM if possible. ### Debian/Ubuntu 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 If you are using Fedora >= 13 then a Frama-C package is provided: yum install frama-c ## Compiling from source **Note**: These instructions are no longer required in the vast majority of cases. They are kept here mostly for historical reference. ### Quick Start 1. Install OCaml, OCamlfind, OCamlGraph and Zarith if not already installed. Note that OCaml >= 4.02.3 is needed in order to compile Frama-C. 2. (Optional) For the GUI, also install Gtk, GtkSourceView, GnomeCanvas and Lablgtk2 if not already installed. See section 'REQUIREMENTS' below for indications on the names of the packages to install, or use 'opam depext' as explained in section 'Opam' above. 3. On Linux-like distributions: ./configure && make && sudo make install See section *Configuration* below for options. 4. On Windows+Cygwin or Windows+MinGW+msys: ./configure --prefix C:/windows/path/with/direct/slash/no/space && make && make install 5. The binary `frama-c` (and `frama-c-gui` if you have lablgtk2) is now installed. 6. 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 ### Full Compilation Guide #### Requirements - GNU make version >= 3.81 - OCaml >= 4.02.3 - a C compiler with standard C and POSIX headers and libraries - [OCamlGraph][OCamlGraph] >= 1.8.5 - [findlib][findlib] >= 1.6.1 - [Zarith][Zarith] The Frama-C GUI also requires: - Gtk (>= 2.4) - GtkSourceView 2.x - GnomeCanvas 2.x - LablGtk >= 2.18.2 Plugins may have their own requirements. Consult their specific documentations for details. [OCamlGraph]: http://ocamlgraph.lri.fr [findlib]: http://projects.camlcity.org/projects/findlib.html [Zarith]: http://forge.ocamlcore.org/projects/zarith ##### Ubuntu If you are using Ubuntu >= Precise Pangolin 12.04 then an optimal list of packages is installed by: sudo apt-get install ocaml ocaml-native-compilers graphviz \ libzarith-ocaml-dev libfindlib-ocaml-dev \ liblablgtksourceview2-ocaml-dev liblablgtk2-gnome-ocaml-dev ##### Fedora If you are using a recent Fedora, an optimal list of packages can be installed through (replace `dnf` by `yum` in older versions of Fedora): sudo dnf install ocaml graphviz \ ocaml-zarith-devel ocaml-findlib ocaml \ ocaml-lablgtk-devel gtksourceview2-devel libgnomecanvas-devel ##### Other Linux systems Some other Linux systems provide packages for the required tools and libraries. Please send us patches to update this section for your favorite distro. #### 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 plugin can be enabled by `--enable-plugin` and disabled by `--disable-plugin`. By default, all distributed plugins 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 plugins, 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. - `oracles` sets up the Frama-C test suite oracles for your own configuration. - `tests` performs Frama-C's own tests ##### Under Cygwin or MinGW Use: `make FRAMAC_ROOT_SRCDIR="$(cygpath -a -m $PWD)"` #### Installation Type `make install` (depending on the installation directory, this may require superuser privileges. The installation directory is chosen through `--prefix`). #### 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) #### API Documentation For plugin developers, the API documentation of the Frama-C kernel and distributed plugins 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 plugins. (Depending on the installation directory, this may require superuser privileges.) ## Available resources Once Frama-C is installed, the following resources should be installed and available: ### Executables: (in `/INSTALL_DIR/bin`) - `frama-c` - `frama-c-gui` if available - `frama-c-config` displays Frama-C configuration paths - `frama-c.byte` bytecode version of frama-c - `frama-c-gui.byte` bytecode version of frama-c-gui, if available - `ptests.opt` testing tool for Frama-c - `frama-c.toplevel` if 'make top' previously done ### Shared files: (in `/INSTALL_DIR/share/frama-c` and subdirectories) - some `.h` and `.c` files used as preludes by Frama-C - some `Makefiles` used to compile dynamic plugins - some `.rc` files used to configure Frama-C - some image files used by the Frama-C GUI ### Documentation files: (in `/INSTALL_DIR/share/frama-c/doc`) - files used to generate dynamic plugin documentation ### Object files: (in `/INSTALL_DIR/lib/frama-c`) - object files used to compile dynamic plugins ### Plugin files: (in `/INSTALL_DIR/lib/frama-c/plugins`) - object files of available dynamic plugins ### Man files: (in `/INSTALL_DIR/man/man1`) - `man` files for `frama-c` (and `frama-c-gui` if available) ## Installing Additional Plugins Plugins may be released independently of Frama-C. The standard way for installing them should be: ./configure && make && sudo make install Plugins may have their own custom installation procedures. Consult their specific documentations for details. ## HAVE FUN WITH FRAMA-C! frama-c-Phosphorus-20170501/README.md0000644000175000017500000001032513113744733015655 0ustar mehdimehdi![Frama-C](share/frama-c.png?raw=true) [Frama-C](http://frama-c.com) is a platform dedicated to the analysis of source code written in C. ## A Collaborative Platform Frama-C gathers several analysis techniques in a single collaborative platform, consisting of a **kernel** providing a core set of features (e.g., a normalized AST for C programs) plus a set of analyzers, called **plug-ins**. Plug-ins can build upon results computed by other plug-ins in the platform. Thanks to this approach, Frama-C provides sophisticated tools, including: - an analyzer based on abstract interpretation, aimed at verifying the absence of run-time errors (**EVA**); - a program proof framework based on weakest precondition calculus (**WP**); - a program slicer (**Slicing**); - a tool for verification of temporal (LTL) properties (**Aoraï**); - several tools for code base exploration and dependency analysis (**From**, **Impact**, **Metrics**, **Occurrence**, **Scope**, etc.). These plug-ins share a common language and can exchange information via **[ACSL](http://frama-c.com/acsl.html)** (*ANSI/ISO C Specification Language*) properties. Plug-ins can also collaborate via their APIs. ## Installation For more detailed information about installing OPAM/Frama-C, see [INSTALL.md](INSTALL.md). Frama-C is available through [OPAM](http://opam.ocaml.org/), the OCaml Package Manager. This is the preferred installation method. Be sure to install opam v1.2 or higher. Then the following sequence of commands should install frama-c and its gui: opam init opam install depext opam depext frama-c opam install frama-c Frama-C is developed mainly in Linux, often tested in Mac OSX (via Homebrew), and occasionally tested on Windows (with Cygwin + MinGW). ## Usage Frama-C can be run from the command-line, or via its graphical interface. #### Simple usage The recommended usage for simple files is one of the following lines: frama-c file.c - [options] frama-c-gui file.c Where `-` is one of the several Frama-C plug-ins, e.g. `-val`, or `-wp`, or `-metrics`, etc. Plug-ins can also be run directly from the GUI. To list all plug-ins, run: frama-c -plugins Each plug-in has a help command (`--help` or `--h`) that describes its several options. Finally, the list of options governing the behavior of Frama-C's kernel itself is available through frama-c -kernel-help #### Complex scenarios For more complex usage scenarios (lots of files and directories, with several preprocessing directives), we recommend splitting Frama-C's usage in two parts: 1. Parsing the input files and saving the result to a file; 2. Loading the parsing results and then running the analyses or the GUI. Parsing typically involves giving extra arguments to the C preprocessor, so the `-cpp-extra-args` option is often useful, as in the example below: frama-c *.c *.h -cpp-extra-args="-D -I" -save parsed.sav The results are then loaded into Frama-C for further analyses or for inspection via the GUI: frama-c -load parsed.sav - [options] frama-c-gui -load parsed.sav - [options] ## Further reference - Links to user and developer manuals, Frama-C archives, and plug-in manuals are available at
http://frama-c.com/download.html - [StackOverflow](http://stackoverflow.com/questions/tagged/frama-c) has several questions with the `frama-c` tag, which is monitored by several members of the Frama-C community. - The [Frama-c-discuss mailing list](http://lists.gforge.inria.fr/cgi-bin/mailman/listinfo/frama-c-discuss) is used for announcements and general discussions. - The [official bug tracking system](http://bts.frama-c.com/) can be used for bug reports. - The [Frama-C wiki](https://bts.frama-c.com/dokuwiki/doku.php?id=mantis:frama-c:start) has some useful information, although it is not entirely up-to-date. - The [Frama-C blog](http://blog.frama-c.com/) has several posts about new developments of Frama-C, as well as general discussions about the C language, undefined behavior, floating-point computations, etc. - The [Github snapshot repository](https://github.com/Frama-C/Frama-C-snapshot) contains the .tar.gz archives of stable Frama-C releases, ready to be cloned. frama-c-Phosphorus-20170501/.make-clean-stamp0000644000175000017500000000000213113744733017505 0ustar mehdimehdi7 frama-c-Phosphorus-20170501/opam/0000755000175000017500000000000013113744777015341 5ustar mehdimehdiframa-c-Phosphorus-20170501/opam/opam0000644000175000017500000000553513113744734016221 0ustar mehdimehdiopam-version: "1.2" name: "frama-c-base" version: "20170501" maintainer: "francois.bobot@cea.fr" authors: [ "Michele Alberti" "Gergö Barany" "Patrick Baudin" "François Bobot" "Richard Bonichon" "David Bühler" "Loïc Correnson" "Julien Crétin" "Pascal Cuoq" "Zaynah Dargaye" "Jean-Christophe Filliâtre" "Philippe Herrmann" "Florent Kirchner" "Tristan Le Gall" "Jean-Christophe Léchenet" "Matthieu Lemerre" "David Maison" "Claude Marché" "André Maroneze" "Benjamin Monate" "Yannick Moy" "Anne Pacalet" "Valentin Perrelle" "Guillaume Petiot" "Virgile Prevosto" "Armand Puccetti" "Muriel Roger" "Julien Signoles" "Kostyantyn Vorobyov" "Boris Yakobowski" ] homepage: "http://frama-c.com/" license: "GNU Lesser General Public License version 2.1" dev-repo: "https://github.com/Frama-C/Frama-C-snapshot.git" doc: ["http://frama-c.com/download/user-manual-Phosphorus-20170501.pdf"] bug-reports: "https://bts.frama-c.com/" tags: [ "deductive" "program verification" "formal specification" "automated theorem prover" "interactive theorem prover" "C" "plugins" "abstract interpretation" "slicing" "weakest precondition" "ACSL" "dataflow analysis" ] build: [ ["sh" "-eux" "./run_autoconf_if_needed.sh"] # when used in pinned mode, # the configure *cannot* yet be # generated ["./configure" "--prefix" prefix "--disable-gui" { !conf-gtksourceview:installed | !conf-gnomecanvas:installed } ] [make "-j%{jobs}%"] ] install: [ [make "install"] ] remove: [ ["sh" "-eux" "./run_autoconf_if_needed.sh"] # when used in pinned mode, # the configure *cannot* yet be # generated ["./configure" "--prefix" prefix "--disable-gui" { !conf-gtksourceview:installed | !conf-gnomecanvas:installed } ] [make "uninstall"] ["rm" "-rf" frama-c-base:doc] ] build-doc: [ [make "-C" "doc" "download"] [make "-C" "doc" "FRAMAC_DOCDIR=%{frama-c-base:doc}%" "install"] ] build-test: [ [make "-j%{jobs}%" "PTESTS_OPTS=-error-code" "tests"] ] depends: [ "ocamlgraph" { >= "1.8.5" & < "1.9~" } "ocamlfind" "zarith" ] depopts: [ "lablgtk" "conf-gtksourceview" "conf-gnomecanvas" "coq" { build } "why3" { build } ] messages: [ "Why3 can be used by the WP plug-in for running additional automatic solvers" { !why3:installed } "Coq can be used with the WP plug-in for proving interactively proof obligations" { !coq:installed } ] conflicts: [ "why3-base" { < "0.86" } #for WP plug-in "coq" { < "8.4.6" } #for WP plug-in "lablgtk" { < "2.18.2" } #for ocaml >= 4.02.1 ] available: [ ocaml-version >= "4.02.3" ] frama-c-Phosphorus-20170501/opam/frama-c/0000755000175000017500000000000013113744777016647 5ustar mehdimehdiframa-c-Phosphorus-20170501/opam/frama-c/opam0000644000175000017500000000303413113744734017517 0ustar mehdimehdiopam-version: "1.2" name: "frama-c" version: "20170501" maintainer: "francois.bobot@cea.fr" authors: [ "Michele Alberti" "Gergö Barany" "Patrick Baudin" "François Bobot" "Richard Bonichon" "David Bühler" "Loïc Correnson" "Julien Crétin" "Pascal Cuoq" "Zaynah Dargaye" "Jean-Christophe Filliâtre" "Philippe Herrmann" "Florent Kirchner" "Tristan Le Gall" "Jean-Christophe Léchenet" "Matthieu Lemerre" "David Maison" "Claude Marché" "André Maroneze" "Benjamin Monate" "Yannick Moy" "Anne Pacalet" "Valentin Perrelle" "Guillaume Petiot" "Virgile Prevosto" "Armand Puccetti" "Muriel Roger" "Julien Signoles" "Kostyantyn Vorobyov" "Boris Yakobowski" ] homepage: "http://frama-c.com/" license: "GNU Lesser General Public License version 2.1" dev-repo: "https://github.com/Frama-C/Frama-C-snapshot.git" doc: ["http://frama-c.com/download/user-manual-Phosphorus-20170501.pdf"] bug-reports: "https://bts.frama-c.com/" tags: [ "deductive" "program verification" "formal specification" "automated theorem prover" "interactive theorem prover" "C" "plugins" "abstract interpretation" "slicing" "weakest precondition" "ACSL" "dataflow analysis" ] depends: [ "frama-c-base" { = "20170501" } "lablgtk" { >= "2.18.2" } #for ocaml >= 4.02.1 "conf-gtksourceview" "conf-gnomecanvas" "alt-ergo" ] depopts: [ "altgr-ergo" { build } ] messages: [ "Alt-Ergo Graphical Interface can be used by the WP plug-in" { !altgr-ergo:installed } ] available: [ ocaml-version >= "4.02.3" ] frama-c-Phosphorus-20170501/opam/frama-c/descr0000644000175000017500000000162413113744734017666 0ustar mehdimehdiPlatform dedicated to the analysis of source code written in C. Frama-C gathers several analysis techniques in a single collaborative framework, based on analyzers (called "plug-ins") that can build upon the results computed by other analyzers in the framework. Thanks to this approach, Frama-C provides sophisticated tools, including: - an analyzer based on abstract interpretation (EVA plug-in); - a program proof framework based on weakest precondition calculus (WP plug-in); - a program slicer (Slicing plug-in); - a tool for verification of temporal (LTL) properties (Aoraï plug-in); - several tools for code base exploration and dependency analysis (plug-ins From, Impact, Metrics, Occurrence, Scope, etc.). These plug-ins communicate between each other via the Frama-C API and via ACSL (ANSI/ISO C Specification Language) properties. This virtual package forces the installation of frama-C with its IDE. frama-c-Phosphorus-20170501/opam/files/0000755000175000017500000000000013113744777016443 5ustar mehdimehdiframa-c-Phosphorus-20170501/opam/files/run_autoconf_if_needed.sh0000644000175000017500000000007413113744734023455 0ustar mehdimehdi#!/bin/sh -eux if [ ! -f "configure" ]; then autoconf fi frama-c-Phosphorus-20170501/opam/descr0000644000175000017500000000151513113744734016357 0ustar mehdimehdiPlatform dedicated to the analysis of source code written in C. Frama-C gathers several analysis techniques in a single collaborative framework, based on analyzers (called "plug-ins") that can build upon the results computed by other analyzers in the framework. Thanks to this approach, Frama-C provides sophisticated tools, including: - an analyzer based on abstract interpretation (EVA plug-in); - a program proof framework based on weakest precondition calculus (WP plug-in); - a program slicer (Slicing plug-in); - a tool for verification of temporal (LTL) properties (Aoraï plug-in); - several tools for code base exploration and dependency analysis (plug-ins From, Impact, Metrics, Occurrence, Scope, etc.). These plug-ins communicate between each other via the Frama-C API and via ACSL (ANSI/ISO C Specification Language) properties. frama-c-Phosphorus-20170501/doc/0000755000175000017500000000000013113745006015134 5ustar mehdimehdiframa-c-Phosphorus-20170501/doc/README0000644000175000017500000000116113113744733016021 0ustar mehdimehdiThe main source of documentation for the Frama-C distribution can be downloaded by running `make` in the directory of this README. Then the manuals directory will contain 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-Phosphorus-20170501/doc/Makefile0000644000175000017500000000544013113745006016577 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2017 # # CEA (Commissariat à l'énergie atomique et aux énergies # # alternatives) # # # # you can redistribute it and/or modify it under the terms of the GNU # # Lesser General Public License as published by the Free Software # # Foundation, version 2.1. # # # # It is distributed in the hope that it will be useful, # # but WITHOUT ANY WARRANTY; without even the implied warranty of # # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # # GNU Lesser General Public 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 just download the manuals in the released version all:download FRAMAC_SRC=.. MAKECONFIG_DIR=$(FRAMAC_SRC)/share include $(FRAMAC_SRC)/share/Makefile.common DOCDIR ?= "$(DESTDIR)${prefix}/share/doc" FRAMAC_DOCDIR ?= $(DOCDIR)/frama-c ################### # Frama-C Version # ################### VERSION=$(shell $(SED) -e 's/\\(.*\\)/\\1/' $(FRAMAC_SRC)/VERSION) ifeq ($(findstring +dev,$(VERSION)),+dev) DEVELOPMENT=yes else DEVELOPMENT=no endif ### .PHONY: force MANUALS=acsl #MANUALS that depend on the frama-c version VERSIONED_MANUALS=acsl-implementation aorai-manual rte-manual \ wp-manual metrics-manual user-manual \ plugin-development-guide value-analysis FILES= $(addprefix manuals/, \ $(addsuffix -$(VERSION).pdf, $(VERSIONED_MANUALS)) \ $(addsuffix .pdf, $(MANUALS)) \ ) ifeq ($(DEVELOPMENT),yes) download: force @echo "You can't download the manuals in this way for the development version" else download: force $(MKDIR) manuals wget -nv -N -P manuals \ $(addprefix http://frama-c.com/download/,$(addsuffix -$(VERSION).pdf, $(VERSIONED_MANUALS))) \ $(addprefix http://frama-c.com/download/,$(addsuffix .pdf, $(MANUALS))) endif install: $(MKDIR) $(FRAMAC_DOCDIR) $(CP) $(FILES) $(FRAMAC_DOCDIR) frama-c-Phosphorus-20170501/doc/code/0000755000175000017500000000000013113745012016043 5ustar mehdimehdiframa-c-Phosphorus-20170501/doc/code/intro_pdg.txt0000644000175000017500000001204413113745010020570 0ustar mehdimehdi#*************************************************************************# #* # #* This file is part of Frama-C. # #* # #* Copyright (C) 2007-2017 # #* CEA (Commissariat à l'énergie atomique et aux énergies # #* alternatives) # #* # #* you can redistribute it and/or modify it under the terms of the GNU # #* Lesser General Public License as published by the Free Software # #* Foundation, version 2.1. # #* # #* It is distributed in the hope that it will be useful, # #* but WITHOUT ANY WARRANTY; without even the implied warranty of # #* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # #* GNU Lesser General Public 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 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-Phosphorus-20170501/doc/code/intro_plugin_D_and_S.txt0000644000175000017500000000445513113745006022677 0ustar mehdimehdi#*************************************************************************# #* # #* This file is part of Frama-C. # #* # #* Copyright (C) 2007-2017 # #* CEA (Commissariat à l'énergie atomique et aux énergies # #* alternatives) # #* # #* you can redistribute it and/or modify it under the terms of the GNU # #* Lesser General Public License as published by the Free Software # #* Foundation, version 2.1. # #* # #* It is distributed in the hope that it will be useful, # #* but WITHOUT ANY WARRANTY; without even the implied warranty of # #* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # #* GNU Lesser General Public 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 Dynamic Entry Points} 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 Structure} - {{: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-Phosphorus-20170501/doc/code/intro_sparecode.txt0000644000175000017500000000535713113745012021776 0ustar mehdimehdi#*************************************************************************# #* # #* This file is part of Frama-C. # #* # #* Copyright (C) 2007-2017 # #* CEA (Commissariat à l'énergie atomique et aux énergies # #* alternatives) # #* # #* you can redistribute it and/or modify it under the terms of the GNU # #* Lesser General Public License as published by the Free Software # #* Foundation, version 2.1. # #* # #* It is distributed in the hope that it will be useful, # #* but WITHOUT ANY WARRANTY; without even the implied warranty of # #* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # #* GNU Lesser General Public 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 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-Phosphorus-20170501/doc/code/toc_head.htm0000644000175000017500000000375413113745003020334 0ustar mehdimehdi Frama-C API

Frama-C API Documentation

  • Frama-C Kernel
    • frama-c-Phosphorus-20170501/doc/code/style.css0000644000175000017500000001256213113745007017727 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/doc/code/intro_kernel_plugin.txt0000644000175000017500000000402113113745006022655 0ustar mehdimehdi#*************************************************************************# #* # #* This file is part of Frama-C. # #* # #* Copyright (C) 2007-2017 # #* CEA (Commissariat à l'énergie atomique et aux énergies # #* alternatives) # #* # #* you can redistribute it and/or modify it under the terms of the GNU # #* Lesser General Public License as published by the Free Software # #* Foundation, version 2.1. # #* # #* It is distributed in the hope that it will be useful, # #* but WITHOUT ANY WARRANTY; without even the implied warranty of # #* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # #* GNU Lesser General Public 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 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-Phosphorus-20170501/doc/code/intro_scope.txt0000644000175000017500000000377013113745003021137 0ustar mehdimehdi#*************************************************************************# #* # #* This file is part of Frama-C. # #* # #* Copyright (C) 2007-2017 # #* CEA (Commissariat à l'énergie atomique et aux énergies # #* alternatives) # #* # #* you can redistribute it and/or modify it under the terms of the GNU # #* Lesser General Public License as published by the Free Software # #* Foundation, version 2.1. # #* # #* It is distributed in the hope that it will be useful, # #* but WITHOUT ANY WARRANTY; without even the implied warranty of # #* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # #* GNU Lesser General Public 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 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-Phosphorus-20170501/doc/code/intro_plugin.txt0000644000175000017500000000425513113745005021325 0ustar mehdimehdi#*************************************************************************# #* # #* This file is part of Frama-C. # #* # #* Copyright (C) 2007-2017 # #* CEA (Commissariat à l'énergie atomique et aux énergies # #* alternatives) # #* # #* you can redistribute it and/or modify it under the terms of the GNU # #* Lesser General Public License as published by the Free Software # #* Foundation, version 2.1. # #* # #* It is distributed in the hope that it will be useful, # #* but WITHOUT ANY WARRANTY; without even the implied warranty of # #* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # #* GNU Lesser General Public 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 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-Phosphorus-20170501/doc/code/intro_slicing.txt0000644000175000017500000001062513113745006021456 0ustar mehdimehdi#*************************************************************************# #* # #* This file is part of Frama-C. # #* # #* Copyright (C) 2007-2017 # #* CEA (Commissariat à l'énergie atomique et aux énergies # #* alternatives) # #* # #* you can redistribute it and/or modify it under the terms of the GNU # #* Lesser General Public License as published by the Free Software # #* Foundation, version 2.1. # #* # #* It is distributed in the hope that it will be useful, # #* but WITHOUT ANY WARRANTY; without even the implied warranty of # #* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # #* GNU Lesser General Public 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 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-Phosphorus-20170501/doc/code/intro_plugin_default.txt0000644000175000017500000000414213113745011023021 0ustar mehdimehdi#*************************************************************************# #* # #* This file is part of Frama-C. # #* # #* Copyright (C) 2007-2017 # #* CEA (Commissariat à l'énergie atomique et aux énergies # #* alternatives) # #* # #* you can redistribute it and/or modify it under the terms of the GNU # #* Lesser General Public License as published by the Free Software # #* Foundation, version 2.1. # #* # #* It is distributed in the hope that it will be useful, # #* but WITHOUT ANY WARRANTY; without even the implied warranty of # #* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # #* GNU Lesser General Public 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 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-Phosphorus-20170501/doc/code/toc_tail.htm0000644000175000017500000000342413113745004020357 0ustar mehdimehdi
frama-c.com
© 2007-2012 CEA-LIST
frama-c-Phosphorus-20170501/doc/code/docgen.ml0000644000175000017500000003467213113745001017646 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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(1,"Kernel Services","src/kernel_services"), chop "kernel_services/" f with Not_found -> try Chapter(2,"Libraries","src/libraries"), chop "libraries/" f with Not_found -> try Chapter(3,"Kernel Internals","src/kernel_internals"), chop "kernel_internals/" 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-Phosphorus-20170501/doc/code/intro_occurrence.txt0000644000175000017500000000420013113745007022147 0ustar mehdimehdi#*************************************************************************# #* # #* This file is part of Frama-C. # #* # #* Copyright (C) 2007-2017 # #* CEA (Commissariat à l'énergie atomique et aux énergies # #* alternatives) # #* # #* you can redistribute it and/or modify it under the terms of the GNU # #* Lesser General Public License as published by the Free Software # #* Foundation, version 2.1. # #* # #* It is distributed in the hope that it will be useful, # #* but WITHOUT ANY WARRANTY; without even the implied warranty of # #* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # #* GNU Lesser General Public 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 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-Phosphorus-20170501/share/0000755000175000017500000000000013113745012015466 5ustar mehdimehdiframa-c-Phosphorus-20170501/share/unmark.png0000644000175000017500000000172413113744734017507 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-Phosphorus-20170501/share/builtin.h0000644000175000017500000000317713113745006017320 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public License for more details. */ /* */ /* See the GNU Lesser General Public License version 2.1 */ /* for more details (enclosed in the file licenses/LGPLv2.1). */ /* */ /**************************************************************************/ #error "Use share/__fc_builtin.h instead" frama-c-Phosphorus-20170501/share/Makefile.generic0000644000175000017500000001010313113745012020534 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2017 # # CEA (Commissariat à l'énergie atomique et aux énergies # # alternatives) # # # # you can redistribute it and/or modify it under the terms of the GNU # # Lesser General Public License as published by the Free Software # # Foundation, version 2.1. # # # # It is distributed in the hope that it will be useful, # # but WITHOUT ANY WARRANTY; without even the implied warranty of # # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # # GNU Lesser General Public 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_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 $@ $< %.pdf: %.dot $(PRINT_DOT) $@ $(DOT) -Tpdf -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 # the two rules below are used for .cmi. The first one will be preferred # by make when a .mli exists (see GNU Make manual 10.5.4), the second is a # fallback for mli-less (boo) source files. %.cmi: %.mli $(PRINT_OCAMLC) $@ $(OCAMLC) -c $(BFLAGS) $< %.cmi: %.cmo $(TOUCH) $@ %.cmo: %.ml $(PRINT_OCAMLC) $@ $(OCAMLC) -c $(BFLAGS) $< %.inferred.mli: %.ml $(PRINT_INFERRING) $@ $(OCAMLC) -i $(BFLAGS) $< > $@ # Using the technique of intf-suffix given by Alain Frisch in # http://caml.inria.fr/mantis/view.php?id=4991 # forces ocamlopt to not create a new cmi. %.cmx: %.ml %.cmi $(PRINT_OCAMLOPT) $@ $(OCAMLOPT) -intf-suffix .cmi -c $(OFLAGS) $< # So we can define specific variables that are not inherited # Cf. GNU Make manual, Section 6.12 Pattern-specific Variable Values %.cmx: OFLAGS:=$(OFLAGS) # .o are generated together with .cmx, but %.o %.cmx: %.ml only confuses # make when computing dependencies... %.o: %.cmx $(TOUCH) $@ %.cmxs: %.cmx $(PRINT_PACKING) $@ $(OCAMLOPT) -shared -o $@ $(OFLAGS) $< .mll.ml: $(PRINT_OCAMLLEX) $@ $(RM) $@ $(OCAMLLEX) $< $(CHMOD_RO) $@ %.mli %.ml: %.mly $(PRINT_OCAMLYACC) $@ $(RM) $(<:.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 ########################################################################## # Local Variables: # mode: makefile # End: frama-c-Phosphorus-20170501/share/autocomplete_frama-c0000644000175000017500000000600613113745011021501 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2017 # # CEA (Commissariat à l'énergie atomique et aux énergies # # alternatives) # # # # you can redistribute it and/or modify it under the terms of the GNU # # Lesser General Public License as published by the Free Software # # Foundation, version 2.1. # # # # It is distributed in the hope that it will be useful, # # but WITHOUT ANY WARRANTY; without even the implied warranty of # # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # # GNU Lesser General Public 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: autocomplete_frama-c # bash completion for Frama-C # ========================== # # Installation # ============ # # To enable system-wide completion, put this file in /etc/bash_completion.d # If you want to enable Frama-C completion only for your account, append # this file to ~/.bash_completion. # # Assuming frama-c is in your PATH, # you can also put the following line into your .bashrc: # # source $(frama-c -print-share-path)/autocomplete_frama-c || true # # ----------------------------------------------------------------------------- _frama-c () { local cur local basic_options local sub_options COMPREPLY=() # Array variable storing the possible completions. local sub_comp_line="${COMP_LINE[@]:0:(${COMP_POINT})}" local sub_comp_set=( $sub_comp_line ) if [[ ${sub_comp_line: -1} == ' ' ]] ; then cur="" else cur="${sub_comp_set[@]: -1}" fi # Generate the completion matches and load them into $COMPREPLY array. case "$cur" in -*-*) sub_option="$(frama-c -autocomplete | grep -E -o " $cur[^*]+" |sort |uniq)"; COMPREPLY=( $( compgen -W "${sub_option}" -- $cur ) );; -*) basic_options="$(frama-c -autocomplete | grep -E -o " \-[^-]+-?" |sort |uniq)" COMPREPLY=( $( compgen -W "${basic_options}" -- $cur ) );; esac return 0 } complete -o nospace -f -F _frama-c filename frama-c complete -o nospace -f -F _frama-c filename frama-c-gui # Local Variables: # mode: sh # sh-shell: bash # End: frama-c-Phosphorus-20170501/share/switch-off.png0000644000175000017500000000652413113744734020266 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-Phosphorus-20170501/share/configure.ac0000644000175000017500000004701413113745003017762 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2017 # # CEA (Commissariat à l'énergie atomique et aux énergies # # alternatives) # # # # you can redistribute it and/or modify it under the terms of the GNU # # Lesser General Public License as published by the Free Software # # Foundation, version 2.1. # # # # It is distributed in the hope that it will be useful, # # but WITHOUT ANY WARRANTY; without even the implied warranty of # # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # # GNU Lesser General Public 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 -plugins | \ sed -e '/\[kernel\]/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`]) 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]) ]) # Usage: plugin_disable([plugin],[reason]) define([plugin_disable], [m4_define([PLUGIN_NAME],$1) m4_define([MSG],$2) m4_define([UP],[tovarname(PLUGIN_NAME)]) if test "[FORCE_]UP" = "yes"; then AC_MSG_ERROR([PLUGIN_NAME requested but MSG]); else AC_MSG_WARN([PLUGIN_NAME disabled because MSG]); [ENABLE_]UP=no; [INFO_]UP=", MSG" fi]) define([has_pushed],0) define([after_plugin_dependencies],[ define([has_pushed],1) m4_divert_push(frama_c_configure_tool)]) define([end_after_plugin_dependencies],[ m4_if(has_pushed,1, [m4_divert_pop(frama_c_configure_tool)] m4_define([has_pushed],0) )]) # 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 requires 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], [after_plugin_dependencies], [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], [end_after_plugin_dependencies] if test "$[ENABLE_]tovarname(PLUGIN_NAME)" != "no"; then [EXTERNAL_PLUGINS="${EXTERNAL_PLUGINS} plugin_prefix"]; fi, [ write_plugin_summary AC_OUTPUT() ]) ]) frama-c-Phosphorus-20170501/share/switch-on.png0000644000175000017500000000637213113744734020131 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-Phosphorus-20170501/share/frama-c.png0000644000175000017500000001407213113744734017520 0ustar mehdimehdiPNG  IHDRlPLTEe!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#V9YQʛU܂^WV^.g`EgApftwGX=iC;E=G(G|BoaCz"'wX$kaKUED4=kH;Dcs"w%Wb?$ALz _c lK¢@'3,^&lm7A @ZIbXi3X@䧤XQ $OdOC4K4%֭1Õ?M蓉y-xcZ"m:|M۟@猱/ w_ OKώ޿+3k2IP^}4@ՇL75[ oOs=Tj1yll ᜱf/pO$Y''gC$r'|_,Q\l=|jѦ0ߞb5I'Zc ~T-X r4k@M%c b3]lg誐TA)N;a<ק~ܴnX<@3xvDBFnO/ ໱5G+]3##8 I9dz3)cWENc @̙_ 5UEE?[:Q$~0$y$|bA-=OM#ɨNBFxꁴO0HD|_xuy׋N U(<]tČ3j(f6c26 J/YSa L&dg27YLL$yO rg 6] 6i(OUR3|{P$kgEQteAwR$JP2I[ţ.g˟@,zy+ݎ0Z e$"N\%dž̆5 Pw(VAr y4o$X  h4N0ei:c2s t70h2"dhT½O Xa>64b8QwF3ڟG z|40Fxb[pw1 k\=} @F!,vl_R8n7B!&H f@VJ3Cq.7a+!,)I 3xC*ZtM]*.SER7XA9x<p@"x[~vIiŅcD u@$Au'ێA8x*f$# /X /XhW,^nZ?i/(TWT=ZQQ~xc}/Y?00y%psG.vc{woBz~:Zݩ]#@Wxx#D9rSh("(|oj@V8c)Ѝ-{օҊ>~~?o`8`w6X5@]0HqZdPNz"M h`j;Eژ(@|쟡 D944!`eU(#׀u"E rpWv9::q]/|Wܼ83.3b JL9ahuBNʅ J p#A"ŇS#8z{\ꗽf;A?y?R (p7|\$n2t&B i<@-`3Ά!r%0' ?zp<3U5"0YOMWmc1E_o,2:W U#R$BV:b D…+yٗ~L`  Q229>37/2#-% 9]9Hgg($ Th QT? p Ě`~]&K`M-P~~ҙ<ʶe dxax>03bELPycFJ"(l ٩I$ q>Ùn*`gb@|t@1̤TjpnPEi @. 3ar<'ڡV>%A鸗gh0 $ xUS"(>]$P\EΆ"(ZbXl ^\i*A/~_^q9 l,]Q*5^3`oo7$yQ~hE3D}x &^F#ر=**2"OMీ(5W+S s*.(ڐs3'j:O7zF'ͻ#2!D \ :]}y[9^;慧y"77GG'77w/e\鯙IҲ5%%eexTѹ/ussFNJxhM$899n}Aa~g$Fq\zƁX*)>@zRool/c3"fF ̟^ݴ 0˚bzR\frm⅒ߕ _ǿxziWL'~ĵ“̾ĄxZn$3K8 ~fߜז$x14EO.t,> x9v)?L5d2eu"]=ŬHĪF&B>pak@/&ᓳ乾"I0T~K9q>HM ~Y%%f_&BդFͰ|'O )@ԢMQ.F1K0O! i4xY@nZ< P*PqXd:OB_ypͯJ8`QA.Ⓣ=dJل"$0@Ko|y@nz>$qH[ڲ(zĜ51ܝ赫?.1-%WKUِQxA3{)f]b_Ɗ^iCI)xJИb 9^$|ݜRB@%?XӍ ~ ij0Lgnk?ϼ ؽ9ݪvڃ.s[i kMh{kx``|޲!wM :!.[s ՚6ȁ#Xdhw;@5x\gy4϶v!hof?o't1xi`֖AmBdYϸ|k=[ k0|.mV yNxmط4Kp|[mVfn.5x Bno@PL[Z?PvaM]#|ckgmZ --0`e\o؀ɤŮi:y]cI#7SnolaР蜇JlPk`ܚ='f jku=kxȤhlT' 5fg V td^w3[_1==n7蜽L̡MڍA`x4^oVp@>5tNY_= (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-Phosphorus-20170501/share/emacs/frama-c-init.el0000644000175000017500000000616313113745010021353 0ustar mehdimehdi;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ; This file is part of Frama-C. ; ; ; ; Copyright (C) 2007-2017 ; ; CEA (Commissariat à l'énergie atomique et aux énergies ; ; alternatives) ; ; ; ; you can redistribute it and/or modify it under the terms of the GNU ; ; Lesser General Public License as published by the Free Software ; ; Foundation, version 2.1. ; ; ; ; It is distributed in the hope that it will be useful, ; ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; ; GNU Lesser General Public 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 definitions for Frama-C Emacs files *** ;; ;; This file is automatically included by both 'frama-c-dev.el' and ;; 'frama-c-recommended.el'. You do not need to do anything here. ;; ;; Macro to avoid crashing if the required file does not exist (defmacro safe-require (symbol &rest body) `(condition-case nil (progn (require ',symbol) ,@body) (error (message (format "Require NOT available: %s" ',symbol)) nil))) ;; Macro to avoid crashing if the library to load does not exist (defun safe-load-library (path) (condition-case nil (load-library path) (error (message (format "Library NOT available: %s" path)) nil))) ;; Add opam emacs directory to the load-path (condition-case nil (progn nil (setq opam-share (substring (shell-command-to-string "opam config var share 2> /dev/null") 0 -1)) (add-to-list 'load-path (concat opam-share "/emacs/site-lisp"))) (error (message "Error configuring OPAM, check your installation.") nil)) ;; Setup environment variables using OPAM ;; This helps when compiling OCaml installed via OPAM directly from Emacs (condition-case nil (dolist (var (car (read-from-string (shell-command-to-string "opam config env --sexp")))) (setenv (car var) (cadr var))) (error (message "Error configuring OPAM sexp, check your installation.") nil)) ;; One of the `opam config env` variables is PATH. Update `exec-path` to that. (setq exec-path (split-string (getenv "PATH") path-separator)) frama-c-Phosphorus-20170501/share/emacs/frama-c-dev.el0000644000175000017500000000761413113745004021173 0ustar mehdimehdi;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ; This file is part of Frama-C. ; ; ; ; Copyright (C) 2007-2017 ; ; CEA (Commissariat à l'énergie atomique et aux énergies ; ; alternatives) ; ; ; ; you can redistribute it and/or modify it under the terms of the GNU ; ; Lesser General Public License as published by the Free Software ; ; Foundation, version 2.1. ; ; ; ; It is distributed in the hope that it will be useful, ; ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; ; GNU Lesser General Public License for more details. ; ; ; ; See the GNU Lesser General Public License version 2.1 ; ; for more details (enclosed in the file licenses/LGPLv2.1). ; ; ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; *** Mandatory Emacs settings for Frama-C developers *** ;; ;; If you are using 'frama-c-recommended.el', ignore these instructions ;; (this file is already included by frama-c-recommended.el). ;; ;; Otherwise, do the following: ;; 1. Include the directory containing this file in your Emacs load path; ;; 2. Load this file as a library. ;; ;; You can do so by adding these lines in the beginning of your ~/.emacs file: ;; ;; (add-to-list 'load-path "path/to/this/file/") ;; (load-library "frama-c-dev") ;; ;; tuareg and ocp-indent must be installed (e.g. via their OPAM packages). ;; ;; Note: 'frama-c-init.el' must also be in the load path. (load-library "frama-c-init") ;; ocp-indent should always be used (safe-require ocp-indent (add-hook 'tuareg-mode-hook (lambda () (setq indent-line-function 'ocp-indent-line))) ) ;; Never indent Caml files using tabs (defun no-tabs-hook () (setq indent-tabs-mode nil)) (add-hook 'tuareg-mode-hook 'no-tabs-hook) (add-hook 'caml-mode-hook 'no-tabs-hook) ;; Load Merlin (IDE features for OCaml, such as type info and code navigation) (safe-require merlin ;; Start merlin on ocaml files (add-hook 'tuareg-mode-hook 'merlin-mode t) (add-hook 'caml-mode-hook 'merlin-mode t) ;; Enable auto-completion: definitions for company-mode (set (make-local-variable 'company-backends) '(company-predictive)) (global-set-key (kbd "") 'company-complete-common) (add-to-list 'company-backends 'merlin-company-backend) ;; Enable company on merlin managed buffers (add-hook 'merlin-mode-hook 'company-mode) ;; Or enable it globally: ;(add-hook 'after-init-hook 'global-company-mode) ;; If you do not want to use company-mode, you can use auto-complete mode ;; (setq merlin-use-auto-complete-mode 'easy) ;; This hook avoids accidents with merlin's "C-c C-x", which often quits ;; Emacs without confirmation when the user presses "C-x C-c" by accident. ;; This hook is local to merlin-mode: Emacs will quit normally in non-ML ;; files. It is also only displayed when the keyboard shortcut is used, ;; but not when the user clicks the Close button on Emacs' window. (defun confirm-before-save-kill-emacs () (interactive) (let ((confirm-kill-emacs 'y-or-n-p)) (save-buffers-kill-emacs))) (add-hook 'merlin-mode-hook (lambda () (local-set-key (kbd "C-x C-c") 'confirm-before-save-kill-emacs))) ) frama-c-Phosphorus-20170501/share/emacs/frama-c-recommended.el0000644000175000017500000001230113113745004022664 0ustar mehdimehdi;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ; This file is part of Frama-C. ; ; ; ; Copyright (C) 2007-2017 ; ; CEA (Commissariat à l'énergie atomique et aux énergies ; ; alternatives) ; ; ; ; you can redistribute it and/or modify it under the terms of the GNU ; ; Lesser General Public License as published by the Free Software ; ; Foundation, version 2.1. ; ; ; ; It is distributed in the hope that it will be useful, ; ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; ; GNU Lesser General Public License for more details. ; ; ; ; See the GNU Lesser General Public License version 2.1 ; ; for more details (enclosed in the file licenses/LGPLv2.1). ; ; ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; *** Recommended Emacs settings for Frama-C developers *** ;; ;; This file should be loaded in the beginning of your .emacs file. ;; ;; 1. Include the directory containing this file in your Emacs load path; ;; 2. Load this file as a library. ;; ;; You can do so by adding these lines in the beginning of your ~/.emacs file: ;; ;; (add-to-list 'load-path "path/to/this/file/") ;; (load-library "frama-c-recommended") ;; ;; Note: 'frama-c-init.el' and 'frama-c-dev.el' must also be in the load path. ;; ***** Initialization and configuration settings ***** (load-library "frama-c-init") (load-library "frama-c-dev") ;; MELPA helps with the installation of several Emacs packages (safe-require package (add-to-list 'package-archives '("melpa-stable" . "https://stable.melpa.org/packages/")) ) ;; ***** OCaml settings ***** ;; ;; Load Tuareg (OCaml mode for Emacs) if installed (safe-load-library "tuareg-site-file") ;; ***** End of OCaml settings ***** ;; ***** Miscellaneous settings ***** ;; ;; fill-column-indicator adds a vertical line to help enforce the ;; 80-characters-per-line rule ;; Note: in some specific configurations (e.g. KDE, maximized window), ;; this library may interfere with window redrawing when using e.g. some ;; merlin functions. Try deactivating this extension if you have problems. (safe-require fill-column-indicator (setq-default fill-column 80) (setq fci-rule-color "#8f8f8f") (add-hook 'tuareg-mode-hook 'fci-mode t) ) ;; Disable insertion of tabs for indentation everywhere but in Makefiles ;; (Emacs always inserts tabs in Makefiles, regardless of this option) (setq-default indent-tabs-mode nil) ;; Disable overwrite mode, which is rarely used nowadays and can be annoying ;; when enabled accidentally (global-unset-key [insert]) ;; redo+ (needs to be installed via ELPA) enables a somewhat "standard" ;; undo/redo mechanism, similar to most modern applications; ;; these key settings bind Ctrl+Z and Ctrl+Shift+Z to undo/redo, respectively (safe-require redo+ (global-set-key (kbd "C-z") 'undo-only) (global-set-key (kbd "C-S-z") 'redo) ; Avoid accidental minimization when pressing pressing C-z just after a 'C-x' (global-unset-key (kbd "C-x C-z")) ) ;; This hook removes trailing whitespace, which should always be avoided ;; Note that, if applied to an existing file with trailing whitespace, this ;; will remove it in *every* line. This can generate large diffs and is not ;; always ideal. For new files, however, this should be on by default. ;(add-hook 'before-save-hook 'delete-trailing-whitespace) ;; Require a final newline in a file in order to avoid confusing some tools ;; (also helps 'git diff') (setq require-final-newline t) ;; whitespace-mode, when activated, displays several kinds of possibly ;; undesirable whitespace. ;; The settings below enable display of tabs, empty lines at the end of ;; the file, and the most important one: trailing spaces ;; It is also possible to use whitespace-mode to highlight long lines ;; (over 80 characters, or the width that you prefer), but they are ;; not activated in these settings. (global-whitespace-mode 1) (setq whitespace-style '(face empty tabs trailing)) ;; Terminal Settings ;; (related to colors in compilation mode; see MR frama-c/frama-c!300) (safe-require ansi-color (defun my-colorize-compilation-buffer () (ansi-color-apply-on-region (point-min) (point-max)) (goto-char (point-min)) (while (search-forward "\x0d" nil t) (delete-region (line-beginning-position) (point))) (goto-char (point-min)) (while (search-forward "\x1b[K" nil t) (replace-match "")) (goto-char (point-min)) ) (add-hook 'compilation-filter-hook 'my-colorize-compilation-buffer) ) frama-c-Phosphorus-20170501/share/frama-c.Unix.rc0000644000175000017500000000451213113745012020246 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2017 # # CEA (Commissariat à l'énergie atomique et aux énergies # # alternatives) # # # # you can redistribute it and/or modify it under the terms of the GNU # # Lesser General Public License as published by the Free Software # # Foundation, version 2.1. # # # # It is distributed in the hope that it will be useful, # # but WITHOUT ANY WARRANTY; without even the implied warranty of # # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # # GNU Lesser General Public 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-Phosphorus-20170501/share/Makefile.dynamic_config.external0000644000175000017500000000422613113745005023725 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2017 # # CEA (Commissariat à l'énergie atomique et aux énergies # # alternatives) # # # # you can redistribute it and/or modify it under the terms of the GNU # # Lesser General Public License as published by the Free Software # # Foundation, version 2.1. # # # # It is distributed in the hope that it will be useful, # # but WITHOUT ANY WARRANTY; without even the implied warranty of # # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # # GNU Lesser General Public 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_OPT=$(BINDIR)/frama-c$(EXE) export FRAMAC_BYTE=$(BINDIR)/frama-c.byte$(EXE) export FRAMAC_INCLUDES=-I "$(FRAMAC_LIBDIR)" export PTESTS=$(BINDIR)/ptests.$(PTESTSBEST)$(EXE) export FRAMAC_LIB="$(FRAMAC_LIBDIR)" export DOC_DIR=$(FRAMAC_SHARE)/doc/code export PLUGIN_LIB_DIR=$(PLUGIN_DIR) export FRAMAC_COMPILED_PLUGINDIR=$(FRAMAC_LIBDIR)/plugins # fake target corresponding to the clean-install of Frama-C's Makefile .PHONY: clean-install clean-install: ; ########################################################################## # Local Variables: # mode: makefile # End: frama-c-Phosphorus-20170501/share/Makefile.dynamic_config.internal0000644000175000017500000000430313113745002023710 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2017 # # CEA (Commissariat à l'énergie atomique et aux énergies # # alternatives) # # # # you can redistribute it and/or modify it under the terms of the GNU # # Lesser General Public License as published by the Free Software # # Foundation, version 2.1. # # # # It is distributed in the hope that it will be useful, # # but WITHOUT ANY WARRANTY; without even the implied warranty of # # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # # GNU Lesser General Public 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_OPT=$(FRAMAC_ROOT_SRCDIR)/bin/toplevel.opt$(EXE) export FRAMAC_BYTE=$(FRAMAC_ROOT_SRCDIR)/bin/toplevel.byte$(EXE) export FRAMAC_INCLUDES=$(addprefix -I $(call winpath,$(FRAMAC_ROOT_SRCDIR))/,$(FRAMAC_SRC_DIRS) lib) export PTESTS=$(FRAMAC_ROOT_SRCDIR)/bin/ptests.$(PTESTSBEST)$(EXE) export FRAMAC_LIB=$(FRAMAC_ROOT_SRCDIR)/lib/fc export DOC_DIR=$(FRAMAC_ROOT_SRCDIR)/doc/code export PLUGIN_LIB_DIR=$(FRAMAC_ROOT_SRCDIR)/lib/plugins export FRAMAC_COMPILED_PLUGINDIR=$(FRAMAC_ROOT_SRCDIR)/lib/plugins ########################################################################## # Local Variables: # mode: makefile # End: frama-c-Phosphorus-20170501/share/Makefile.config.in0000644000175000017500000001547113113745003021007 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2017 # # CEA (Commissariat à l'énergie atomique et aux énergies # # alternatives) # # # # you can redistribute it and/or modify it under the terms of the GNU # # Lesser General Public License as published by the Free Software # # Foundation, version 2.1. # # # # It is distributed in the hope that it will be useful, # # but WITHOUT ANY WARRANTY; without even the implied warranty of # # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # # GNU Lesser General Public 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. # # # ########################################################################## ###################### # Installation paths # ###################### CYGPATH ?=@CYGPATH@ 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@ FRAMAC_DEFAULT_CPP_ARGS ?= @FRAMAC_DEFAULT_CPP_ARGS@ FRAMAC_GNU_CPP ?=@FRAMAC_GNU_CPP@ DEFAULT_CPP_KEEP_COMMENTS?=@DEFAULT_CPP_KEEP_COMMENTS@ DEFAULT_CPP_SUPPORTED_ARCH_OPTS?=@DEFAULT_CPP_SUPPORTED_ARCH_OPTS@ CC =@CC@ ############### # 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_THREADS ?=@HAS_NATIVE_THREADS@ OCAMLWIN32 ?=@OCAMLWIN32@ PTESTSBEST ?=@PTESTSBEST@ DEVELOPMENT ?=@DEVELOPMENT@ ############# # Libraries # ############# # 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@ # apron HAS_APRON ?=@HAS_APRON@ # landmarks HAS_LANDMARKS ?=@HAS_LANDMARKS@ ########################## # 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_CALLGRAPH ?=@ENABLE_CALLGRAPH@ ENABLE_CONSTANT_PROPAGATION ?=@ENABLE_SEMANTIC_CONSTANT_FOLDING@ 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_RTEGEN ?=@ENABLE_RTEGEN@ ENABLE_SCOPE ?=@ENABLE_SCOPE@ ENABLE_SLICING ?=@ENABLE_SLICING@ ENABLE_SPARECODE ?=@ENABLE_SPARECODE@ ENABLE_USERS ?=@ENABLE_USERS@ ENABLE_VALUE_ANALYSIS ?=@ENABLE_VALUE_ANALYSIS@ DYNAMIC_CALLGRAPH ?=@DYNAMIC_CALLGRAPH@ DYNAMIC_CONSTANT_PROPAGATION ?=@DYNAMIC_SEMANTIC_CONSTANT_FOLDING@ DYNAMIC_FROM_ANALYSIS ?=@DYNAMIC_FROM_ANALYSIS@ #DYNAMIC_GUI: never dynamic DYNAMIC_IMPACT ?=@DYNAMIC_IMPACT@ DYNAMIC_INOUT ?=@DYNAMIC_INOUT@ DYNAMIC_METRICS ?=@DYNAMIC_METRICS@ DYNAMIC_OCCURRENCE ?=@DYNAMIC_OCCURRENCE@ DYNAMIC_PDG ?=@DYNAMIC_PDG@ DYNAMIC_POSTDOMINATORS ?=@DYNAMIC_POSTDOMINATORS@ DYNAMIC_RTEGEN ?=@DYNAMIC_RTEGEN@ DYNAMIC_SCOPE ?=@DYNAMIC_SCOPE@ DYNAMIC_SLICING ?=@DYNAMIC_SLICING@ DYNAMIC_SPARECODE ?=@DYNAMIC_SPARECODE@ DYNAMIC_USERS ?=@DYNAMIC_USERS@ DYNAMIC_VALUE_ANALYSIS ?=@DYNAMIC_VALUE_ANALYSIS@ #bytes is part of the stdlib, but is used as a transitional package. LIBRARY_NAMES := findlib ocamlgraph num unix str dynlink bytes zarith ifeq ($(HAS_LANDMARKS),yes) LIBRARY_NAMES += landmarks landmarks.ppx endif ifneq ($(ENABLE_GUI),no) LIBRARY_NAMES_GUI = lablgtk2 lablgtk2.gnomecanvas lablgtk2.sourceview2 else LIBRARY_NAMES_GUI = endif ####################### # Working directories # ####################### ifeq ($(OCAMLWIN32),yes) ifneq ($(CYGPATH),no) # Note: using quotes in the line below leads to weird garbled characters # in some versions of Cygwin. winpath=$(shell $(CYGPATH) -m $(1)) else winpath=$(1) endif #CYGPATH else winpath=$(1) endif #OCAMLWIN32 FRAMAC_ROOT_SRCDIR ?= $(call winpath,@abs_top_srcdir@) ########################################################################## # Local Variables: # mode: makefile # End: frama-c-Phosphorus-20170501/share/Makefile.plugin.template0000644000175000017500000010734013113745005022244 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2017 # # CEA (Commissariat à l'énergie atomique et aux énergies # # alternatives) # # # # you can redistribute it and/or modify it under the terms of the GNU # # Lesser General Public License as published by the Free Software # # Foundation, version 2.1. # # # # It is distributed in the hope that it will be useful, # # but WITHOUT ANY WARRANTY; without even the implied warranty of # # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # # GNU Lesser General Public 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: # # Warning: You should not use these variables inside of your Makefile, # use the namespaced version (@PLUGIN_NAME@_*) at the end of this list. # # Usual information # ----------------- ifndef PLUGIN_NAME # The ML module name of the plugin $(error PLUGIN_NAME is not set) endif ifndef PLUGIN_DIR # The directory containing the source files $(error PLUGIN_DIR is not set) endif PLUGIN_DIR?= PLUGIN_ENABLE?= # Whether the plugin is enabled PLUGIN_DEPENDS?= # Deprecated (static plug-in dependencies, Frama-C only) PLUGIN_DYNAMIC?= # Set it to yes if the plugin is only # dynamically linked with Frama-C. # META file # --------- # The META for the plug-in is automatically generated, unless variable # PLUGIN_HAS_META is set to "yes". The following optional variables can # be set accordingly: # PLUGIN_HAS_META?= # defaults to empty # When setting PLUGIN_HAS_META to "yes", the next variables are not taken into # account. Instead, your are responsible for providing a full featured META # file in the PLUGIN_DIR source directory, which will be copied and installed # with the plug-in object files. PLUGIN_DESCRIPTION?= # if empty then defaults to "Frama-C NAME plug-in" PLUGIN_VERSION?= # if empty then defaults to current Frama-C version PLUGIN_REQUIRES?= # package(s) the plug-in depends on (defaults to empty) PLUGIN_DEPENDENCIES?= # plugins(s) the plug-in depends on (defaults to empty) # Remarks: # - the package name for "MyPlugin" is defined to be "frama-c-myplugin" # - PLUGIN_DEPENDENCIES is a shortcut for PLUGIN_REQUIRES # - the makefile adds a proper "directory" directive to both provided or # generated META files # 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_CMI?= # The .cmi files for the GUI # (only if there is no corresponding .cmi) PLUGIN_GUI_CMO?= # The .cmo files to be linked with the graphical interface PLUGIN_GENERATED?= # source files generated by the plugins, typically parsers # 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_EXTRA_DIRS?= # Additional directories (relative to the root of the # plugin) containing some of the source files of the # plugin 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 # 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 source (.ml) files used by tests. 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 recommended 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?=yes # Set it to no in order to NOT reset plug-in variable. # Except for their initialisation, all these variables should not be used # outside of this Makefile. # # Instead, you can safely use the corresponding following variables. # Warning: # - They contain the extensions and the plugin path unlike the originals # - except @PLUGIN_NAME@_DIR, they are undefined before # Makefile.plugin.generated is created # # @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. # ############################################################################### # Where the other plug-ins to load are already installed ifeq ($(FRAMAC_INTERNAL),yes) INSTALLED_PLUGIN_DIR:=$(FRAMAC_ROOT_SRCDIR)/lib/plugins else INSTALLED_PLUGIN_DIR:=$(PLUGIN_INSTALL_DIR) endif # 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))))) PLUGIN_DEPENDS:=$(PLUGIN_DEPENDS) $(PLUGIN_DEPENDENCIES) ################ # ml sources # ################ PLUGIN_SRC:= $(PLUGIN_DIR)/@PLUGIN_NAME@.mli \ $(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) # 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' ` ifneq ("$(PLUGIN_DISTRIB_BIN)","no") 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 ifneq ("$(PLUGIN_ENABLE)","no") # The .cm* files list PLUGIN_CMO:= $(patsubst %,$(PLUGIN_DIR)/%.cmo,$(PLUGIN_CMO)) PLUGIN_CMX:= $(PLUGIN_CMO:.cmo=.cmx) PLUGIN_CMI_ONLY:=$(patsubst %,$(PLUGIN_DIR)/%.cmi,$(PLUGIN_CMI)) PLUGIN_CMI:= $(PLUGIN_CMI_ONLY) $(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_ONLY:=$(PLUGIN_CMI_ONLY) @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_ONLY:=$(PLUGIN_CMI_ONLY) $(PLUGIN_GUI_CMI) PLUGIN_GUI_CMI:= $(PLUGIN_CMI_ONLY) $(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) # Interface for the the packed plugins TARGET_MLI:= $(PLUGIN_LIB_DIR)/@PLUGIN_NAME@.mli TARGET_CMI:= $(TARGET_MLI:.mli=.cmi) # The packed files for toplevel mode (in directory 'top') TARGET_TOP_MLI:= $(PLUGIN_LIB_DIR)/top/@PLUGIN_NAME@.mli TARGET_TOP_CMI:= $(TARGET_TOP_MLI:.mli=.cmi) TARGET_TOP_CMO:= $(TARGET_TOP_MLI:.mli=.cmo) ifdef PLUGIN_EXTRA_BYTE TARGET_TOP_CMA:= $(TARGET_TOP_CMO:.cmo=.cma) else TARGET_TOP_CMA:= endif TARGET_TOP_CMX:= $(TARGET_TOP_CMO:.cmo=.cmx) ifdef PLUGIN_EXTRA_OPT TARGET_TOP_CMXA:= $(TARGET_TOP_CMO:.cmo=.cmxa) else TARGET_TOP_CMXA:= endif ifeq ("$(PLUGIN_DYNAMIC)","yes") TARGET_TOP_CMXS:= $(TARGET_TOP_CMX:.cmx=.cmxs) else TARGET_TOP_CMXS:= endif # The packed files for GUI mode (in directory 'gui') ifeq ($(HAS_GUI),yes) TARGET_GUI_MLI:=$(PLUGIN_LIB_DIR)/gui/@PLUGIN_NAME@.mli TARGET_GUI_CMO:= $(PLUGIN_LIB_DIR)/gui/@PLUGIN_NAME@.cmo TARGET_GUI_CMI:= $(TARGET_GUI_CMO:.cmo=.cmi) 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 ("$(PLUGIN_DYNAMIC)","yes") TARGET_GUI_CMXS:= $(TARGET_GUI_CMO:.cmo=.cmxs) else TARGET_GUI_CMXS:= endif else TARGET_GUI_MLI:= TARGET_GUI_CMO:= TARGET_GUI_CMI:= TARGET_GUI_CMX:= TARGET_GUI_CMA:= TARGET_GUI_CMXA:= endif # Meta-variables for the targets: @PLUGIN_NAME@_TARGET_MLI:=$(TARGET_MLI) @PLUGIN_NAME@_TARGET_CMI:=$(TARGET_CMI) @PLUGIN_NAME@_TARGET_TOP_MLI:=$(TARGET_TOP_MLI) @PLUGIN_NAME@_TARGET_TOP_CMI:=$(TARGET_TOP_CMI) @PLUGIN_NAME@_TARGET_TOP_CMO:=$(TARGET_TOP_CMO) @PLUGIN_NAME@_TARGET_TOP_CMA:=$(TARGET_TOP_CMA) @PLUGIN_NAME@_TARGET_TOP_CMX:=$(TARGET_TOP_CMX) @PLUGIN_NAME@_TARGET_TOP_CMXA:=$(TARGET_TOP_CMXA) @PLUGIN_NAME@_TARGET_TOP_CMXS:=$(TARGET_TOP_CMXS) @PLUGIN_NAME@_TARGET_GUI_MLI:=$(TARGET_GUI_CMI) @PLUGIN_NAME@_TARGET_GUI_CMI:=$(TARGET_GUI_CMI) @PLUGIN_NAME@_TARGET_GUI_CMO:=$(TARGET_GUI_CMO) @PLUGIN_NAME@_TARGET_GUI_CMA:=$(TARGET_GUI_CMA) @PLUGIN_NAME@_TARGET_GUI_CMX:=$(TARGET_GUI_CMX) @PLUGIN_NAME@_TARGET_GUI_CMXA:=$(TARGET_GUI_CMXA) @PLUGIN_NAME@_TARGET_GUI_CMXS:=$(TARGET_GUI_CMXS) # 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) @PLUGIN_NAME@_EXTRA_DIRS:=$(PLUGIN_EXTRA_DIRS) 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_CMI_ONLY:=$(PLUGIN_GUI_CMI_ONLY) @PLUGIN_NAME@_GUI_TARGET_BFLAGS:=$(PLUGIN_LINK_GUI_BFLAGS) @PLUGIN_NAME@_GUI_TARGET_OFLAGS:=$(PLUGIN_LINK_GUI_OFLAGS) endif PLUGIN_EXTRA_DIRS_INC:=$(patsubst %,-I $(PLUGIN_DIR)/% ,$(PLUGIN_EXTRA_DIRS)) # Set the compilation flags for the plugin INCLUDE_FLAGS:=-I $(PLUGIN_DIR) -I $(INSTALLED_PLUGIN_DIR) \ $(PLUGIN_EXTRA_DIRS_INC) \ $(addprefix -package ,$(PLUGIN_REQUIRES) $(LIBRARY_NAMES)) $(NAME_BFLAGS):=$(BFLAGS) $(INCLUDE_FLAGS) $(PLUGIN_BFLAGS) $(NAME_OFLAGS):=$(OFLAGS) $(INCLUDE_FLAGS) $(PLUGIN_OFLAGS) $(TARGET_BFLAGS):= $(PLUGIN_LINK_BFLAGS) $(TARGET_OFLAGS):= $(PLUGIN_LINK_OFLAGS) $(NAME_DOCFLAGS):= $(DOC_FLAGS) $(PLUGIN_DOCFLAGS) \ -I $(PLUGIN_DIR) \ $(PLUGIN_EXTRA_DIRS_INC) \ -I $(PLUGIN_LIB_DIR) \ $(addprefix -package ,$(PLUGIN_REQUIRES) $(LIBRARY_NAMES)) ifeq ($(HAS_GUI),yes) $(NAME_GUI_BFLAGS):=$($(NAME_BFLAGS)) $(addprefix -package ,$(LIBRARY_NAMES_GUI)) $(NAME_GUI_OFLAGS):=$($(NAME_OFLAGS)) $(addprefix -package ,$(LIBRARY_NAMES_GUI)) $(TARGET_GUI_BFLAGS):= $(PLUGIN_LINK_GUI_BFLAGS) $(TARGET_GUI_OFLAGS):= $(PLUGIN_LINK_GUI_OFLAGS) $(NAME_DOCFLAGS) := $($(NAME_DOCFLAGS)) $(addprefix -package ,$(LIBRARY_NAMES_GUI)) endif $(NAME_DEPFLAGS):= -I $(PLUGIN_DIR) $(PLUGIN_DEPFLAGS) $(PLUGIN_EXTRA_DIRS_INC) # 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 # META file PLUGIN_PKG :=$(shell echo frama-c-@PLUGIN_NAME@ | tr '[:upper:]' '[:lower:]') DEPEND_PKG :=$(shell echo $(PLUGIN_DEPENDENCIES) | tr '[:upper:]' '[:lower:]') PLUGIN_REQUIRES += $(addprefix frama-c-,$(DEPEND_PKG)) TARGET_META :=$(PLUGIN_LIB_DIR)/META.$(PLUGIN_PKG) ifneq ($(PLUGIN_HAS_META),yes) # generated META ifeq ($(PLUGIN_DESCRIPTION),) PLUGIN_DESCRIPTION :="Frama-C @PLUGIN_NAME@ plug-in" endif ifeq ($(PLUGIN_VERSION),) ifeq ($(FRAMAC_INTERNAL),yes) PLUGIN_VERSION :=$(shell cat VERSION) else PLUGIN_VERSION :=$(shell frama-c -print-version) endif endif # registering package description for later use META.$(PLUGIN_PKG).DESCRIPTION :=$(PLUGIN_DESCRIPTION) META.$(PLUGIN_PKG).VERSION :=$(PLUGIN_VERSION) META.$(PLUGIN_PKG).REQUIRES :=$(PLUGIN_REQUIRES) ifdef PLUGIN_EXTRA_BYTE META.$(PLUGIN_PKG).BYTE :=@PLUGIN_NAME@.cma else META.$(PLUGIN_PKG).BYTE :=@PLUGIN_NAME@.cmo endif ifdef PLUGIN_EXTRA_OPT META.$(PLUGIN_PKG).NATIVE :=@PLUGIN_NAME@.cmxa else META.$(PLUGIN_PKG).NATIVE :=@PLUGIN_NAME@.cmx endif ifeq ("$(PLUGIN_DYNAMIC)","yes") META.$(PLUGIN_PKG).PLUGIN :=@PLUGIN_NAME@.cmxs endif ifeq ($(FRAMAC_INTERNAL),yes) # In internal mode, we depend on the main Makefile for plugins that do not # have their own Makefile. To detect that, we check whether there is a # plugin-specific Makefile in the include stack. ifeq ($(filter $(PLUGIN_DIR)/Makefile,$(MAKEFILE_LIST)),) $(TARGET_META): Makefile else $(TARGET_META): $(PLUGIN_DIR)/Makefile endif # PLUGIN_DIR/Makefile else $(TARGET_META): $(PLUGIN_DIR)/Makefile endif # FRAMAC_INTERNAL $(TARGET_META): $(PRINT_MAKING) $(notdir $@) $(RM) $@ $(ECHO) "description = \"$($(notdir $@).DESCRIPTION)\"" >> $@ $(ECHO) "version = \"$($(notdir $@).VERSION)\"" >> $@ $(ECHO) "requires = \"$($(notdir $@).REQUIRES)\"" >> $@ $(ECHO) "archive(byte) = \"top/$($(notdir $@).BYTE)\"" >> $@ $(ECHO) "archive(native) = \"top/$($(notdir $@).NATIVE)\"" >> $@ $(ECHO) "plugin(native) = \"top/$($(notdir $@).PLUGIN)\"" >> $@ $(ECHO) "plugin(byte) = \"top/$($(notdir $@).BYTE)\"" >> $@ ifeq ($(HAS_GUI),yes) $(ECHO) "archive(byte,gui) = \"gui/$($(notdir $@).BYTE)\"" >> $@ $(ECHO) "archive(native,gui) = \"gui/$($(notdir $@).NATIVE)\"" >> $@ $(ECHO) "plugin(native,gui) = \"gui/$($(notdir $@).PLUGIN)\"" >> $@ $(ECHO) "plugin(byte,gui) = \"gui/$($(notdir $@).BYTE)\"" >> $@ endif $(ECHO) "directory = \"\"" >> $@ else # PLUGIN_HAS_META # user-defined META $(TARGET_META): $(PLUGIN_DIR)/META $(PRINT_CP) $(notdir $@) $(CP) $< $@ $(ECHO) "directory = \"\"" >> $@ endif # PLUGIN_HAS_META # Now build the targets ####################### @PLUGIN_NAME@_PLUGIN_MLI:= $(PLUGIN_DIR)/@PLUGIN_NAME@.mli @PLUGIN_NAME@_CHECK_PLUGIN_MLI:=$(PLUGIN_DIR)/@PLUGIN_NAME@.check_mli_exists # Prevents warning 58 in OCaml 4.03 for our plugins. ifeq ($(HAS_OCAML403),yes) $(TARGET_CMI): BFLAGS:=$($(NAME_BFLAGS)) -opaque else $(TARGET_CMI): BFLAGS:=$($(NAME_BFLAGS)) endif $(TARGET_CMI): $(PLUGIN_CMO) ifneq ($(TARGET_MLI),$(@PLUGIN_NAME@_PLUGIN_MLI)) # Copy the plugin interface in the plugins directory $(TARGET_MLI): $(@PLUGIN_NAME@_CHECK_PLUGIN_MLI) $(PRINT_MAKING) $@ $(MKDIR) $(PLUGIN_LIB_DIR) $(RM) $@ $(ECHO) "(* This module was generated automatically by code in Makefile and $(@PLUGIN_NAME@_PLUGIN_MLI) *)" > $@ $(ECHO) "#1 \"$(@PLUGIN_NAME@_PLUGIN_MLI)\"" >> $@ $(CAT) $(@PLUGIN_NAME@_PLUGIN_MLI) >> $@ $(CHMOD_RO) $@ $(INSTALLED_PLUGIN_DIR)/.placeholders_ready: $(TARGET_MLI) PLUGIN_GENERATED+= $(TARGET_MLI) endif $(TARGET_TOP_MLI): $(@PLUGIN_NAME@_CHECK_PLUGIN_MLI) $(TARGET_MLI) $(PRINT_MAKING) $@ $(MKDIR) $(PLUGIN_LIB_DIR)/top $(RM) $@ $(CP) $(@PLUGIN_NAME@_TARGET_MLI) $@ PLUGIN_GENERATED+= $(TARGET_TOP_MLI) @PLUGIN_NAME@_MLI:=$(TARGET_MLI) $(TARGET_TOP_CMI): $(TARGET_CMI) $(PRINT_MAKING) $@ $(MKDIR) $(PLUGIN_LIB_DIR)/top $(RM) $@ $(CP) $< $@ $(TARGET_TOP_CMO): $(PLUGIN_CMO) \ $(TARGET_CMI) $(TARGET_TOP_CMI) $(PRINT_PACKING) $@ $(OCAMLC) -o $(call winpath,$@) $(@PLUGIN_NAME@_BFLAGS) -pack \ $(@PLUGIN_NAME@_TARGET_BFLAGS) \ $(@PLUGIN_NAME@_CMI_ONLY) $(@PLUGIN_NAME@_CMO) $(TARGET_TOP_CMX): $(PLUGIN_CMX) \ $(TARGET_CMI) $(TARGET_TOP_CMI) $(PRINT_PACKING) $@ $(OCAMLOPT) -o $(call winpath,$@) $(@PLUGIN_NAME@_OFLAGS) -pack \ $(@PLUGIN_NAME@_TARGET_OFLAGS) \ $(@PLUGIN_NAME@_CMI_ONLY) $(@PLUGIN_NAME@_CMX) ifeq ("$(PLUGIN_DYNAMIC)","yes") $(TARGET_TOP_CMXS): $(TARGET_TOP_CMX) $(PLUGIN_EXTRA_OPT) $(PRINT_PACKING) $@ $(OCAMLOPT) -o $(call winpath,$@) -shared \ $(@PLUGIN_NAME@_OFLAGS) \ $(@PLUGIN_NAME@_EXTRA_OPT) \ $(@:.cmxs=.cmx) endif ifdef PLUGIN_EXTRA_BYTE $(TARGET_TOP_CMA): $(PLUGIN_EXTRA_BYTE) $(TARGET_TOP_CMO) $(PRINT_PACKING) $@ $(OCAMLC) -o $(call winpath,$@) $(@PLUGIN_NAME@_BFLAGS) \ $(@PLUGIN_NAME@_TARGET_BFLAGS) \ -a $(@PLUGIN_NAME@_EXTRA_BYTE) $(@:.cma=.cmo) endif ifdef PLUGIN_EXTRA_OPT $(TARGET_TOP_CMXA): $(PLUGIN_EXTRA_OPT) $(TARGET_TOP_CMX) $(PRINT_PACKING) $@ $(OCAMLOPT) -o $(call winpath,$@) -a $(@PLUGIN_NAME@_EXTRA_OPT) \ $(@:.cmxa=.cmx) endif ifeq ($(HAS_GUI),yes) # packing gui files ################### $(TARGET_GUI_CMI): $(TARGET_CMI) $(PRINT_MAKING) $@ $(MKDIR) $(PLUGIN_LIB_DIR)/gui $(RM) $@ $(CP) $< $@ PLUGIN_GENERATED+= $(TARGET_GUI_MLI) $(TARGET_GUI_MLI): $(@PLUGIN_NAME@_CHECK_PLUGIN_MLI) $(TARGET_MLI) $(PRINT_MAKING) $@ $(MKDIR) $(PLUGIN_LIB_DIR)/gui $(RM) $@ $(CP) $(@PLUGIN_NAME@_TARGET_MLI) $@ $(TARGET_GUI_CMO): $(PLUGIN_GUI_CMO) $(TARGET_CMI) $(TARGET_GUI_CMI) $(PRINT_PACKING) $@ $(MKDIR) $(PLUGIN_LIB_DIR)/gui $(OCAMLC) -o $(call winpath,$@) $(@PLUGIN_NAME@_GUI_BFLAGS) -pack \ $(@PLUGIN_NAME@_GUI_TARGET_BFLAGS) \ $(@PLUGIN_NAME@_GUI_CMI_ONLY) \ $(@PLUGIN_NAME@_GUI_CMO) $(TARGET_GUI_CMX): $(PLUGIN_GUI_CMX) $(TARGET_CMI) $(TARGET_GUI_CMI) $(PRINT_PACKING) $@ $(MKDIR) $(PLUGIN_LIB_DIR)/gui $(OCAMLOPT) -o $(call winpath,$@) $(@PLUGIN_NAME@_GUI_OFLAGS) -pack \ $(@PLUGIN_NAME@_GUI_TARGET_OFLAGS) \ $(@PLUGIN_NAME@_GUI_CMI_ONLY) \ $(@PLUGIN_NAME@_GUI_CMX) ifeq ("$(PLUGIN_DYNAMIC)","yes") $(TARGET_GUI_CMXS): $(TARGET_GUI_CMX) $(PRINT_PACKING) $@ $(MKDIR) $(PLUGIN_LIB_DIR)/gui $(OCAMLOPT) -o $(call winpath,$@) -shared \ $(@PLUGIN_NAME@_GUI_OFLAGS) \ $(@PLUGIN_NAME@_GUI_TARGET_OFLAGS) \ $(@PLUGIN_NAME@_EXTRA_OPT) \ $^ endif ifdef PLUGIN_EXTRA_BYTE $(TARGET_GUI_CMA): $(PLUGIN_EXTRA_BYTE) $(TARGET_GUI_CMO) $(PRINT_PACKING) $@ $(OCAMLC) -o $(call winpath,$@) $(@PLUGIN_NAME@_GUI_BFLAGS) \ $(@PLUGIN_NAME@_GUI_TARGET_BFLAGS) \ -a $(@PLUGIN_NAME@_EXTRA_BYTE) $(@:.cma=.cmo) endif ifdef PLUGIN_EXTRA_OPT $(TARGET_GUI_CMXA): $(PLUGIN_EXTRA_OPT) $(TARGET_GUI_CMX) $(PRINT_PACKING) $@ $(OCAMLOPT) -o $(call winpath,$@) -a $(@PLUGIN_NAME@_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:= cp -f $(PLUGIN_INTRO) $(PLUGIN_DOC_DIR)/@PLUGIN_NAME@.txt PLUGIN_DIST_EXTERNAL_LIST+= $(PLUGIN_INTRO) else @PLUGIN_NAME@_CAT_INTRO:= echo "" > $(PLUGIN_DOC_DIR)/@PLUGIN_NAME@.txt endif ifeq ($(FRAMAC_INTERNAL),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 $@) $(@PLUGIN_NAME@_CAT_INTRO) if [ -f "$(DOC_DIR)/html/Db.@PLUGIN_NAME@.html" ] ; then \ if [ -f "$(DOC_DIR)/dynamic_plugins/Dynamic_plugins.@PLUGIN_NAME@.html" ] ; then \ cat $(DOC_DIR)/intro_plugin_D_and_S.txt >> $@ ; \ else \ cat $(DOC_DIR)/intro_kernel_plugin.txt >> $@ ; \ fi ; \ elif [ -f "$(DOC_DIR)/dynamic_plugins/Dynamic_plugins.@PLUGIN_NAME@.html" ] ; then \ cat $(DOC_DIR)/intro_plugin.txt >> $@ ; \ else \ cat $(DOC_DIR)/intro_plugin_default.txt >> $@ ; \ fi $(ISED) -e "s/_PluginName_/@PLUGIN_NAME@/g" \ -e "/^#*/d" $@ ifeq ($(FRAMAC_INTERNAL),yes) OCAMLDOC_GEN:=$(DOC_PLUGIN) ifneq ($(FRAMAC_INTERNAL),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 $(call winpath,$(DOC_DIR))/docgen.ml $(DOC_DIR)/docgen.cmxs: $(DOC_DIR)/docgen.ml $(PRINT_PACKING) $@ $(OCAMLOPT) -o $(call winpath,$@) -shared -I +ocamldoc \ $(call winpath,$(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) @PLUGIN_NAME@ $(MKDIR) $(@PLUGIN_NAME@_DOC_DIR) $(RM) $(@PLUGIN_NAME@_DOC_DIR)/*.html # Only generate toc for kernel's documentation if we are in Frama-C's main # Makefile ifeq ($(FRAMAC_INTERNAL),yes) $(ECHO) '
  • $(subst _, ,@PLUGIN_NAME@)
    • ' > $(DOC_DIR)/@PLUGIN_NAME@.toc endif $(OCAMLDOC) $(@PLUGIN_NAME@_DOCFLAGS) \ -t "@PLUGIN_NAME@ plugin" \ -css-style ../style.css \ -d $(@PLUGIN_NAME@_DOC_DIR) -g $(DOC_PLUGIN) -passopt -docpath $(DOC_DIR)/html \ $(addprefix -load ,$(wildcard $(DOC_DIR)/kernel-doc.ocamldoc)) \ $(wildcard $(@PLUGIN_NAME@_DOC_SRC)) # [rb+js] 20090619 # pwd is required to avoid "bad directory" message on OpenBSD # don't know why cd `pwd`/$(@PLUGIN_NAME@_DOC_DIR); \ for f in $(foreach f,$(@PLUGIN_NAME@_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@_TESTS_LIB_DIR:=$(sort $(dir $(PLUGIN_TESTS_LIB))) @PLUGIN_NAME@_TESTS_LIB_DIR_INCLUDE:=$(foreach d,$(@PLUGIN_NAME@_TESTS_LIB_DIR),-I $d ) @PLUGIN_NAME@_EXTRA_DIRS:=$(@PLUGIN_NAME@_EXTRA_DIRS) $(@PLUGIN_NAME@_TESTS_LIB_DIR) @PLUGIN_NAME@_TESTS_LIB_OPT:=$(PLUGIN_TESTS_LIB:%.ml=%.cmx) @PLUGIN_NAME@_TESTS_LIB_OPT_DYN:=$(PLUGIN_TESTS_LIB:%.ml=%.cmxs) @PLUGIN_NAME@_TESTS_LIB_BYTE:=$(PLUGIN_TESTS_LIB:%.ml=%.cmo) $(@PLUGIN_NAME@_TESTS_LIB_OPT): OFLAGS:=$($(NAME_OFLAGS)) $(@PLUGIN_NAME@_TESTS_LIB_DIR_INCLUDE) $(@PLUGIN_NAME@_TESTS_LIB_OPT_DYN): OFLAGS:=$($(NAME_OFLAGS)) $(@PLUGIN_NAME@_TESTS_LIB_DIR_INCLUDE) $(@PLUGIN_NAME@_TESTS_LIB_BYTE): BFLAGS:=$($(NAME_BFLAGS)) $(@PLUGIN_NAME@_TESTS_LIB_DIR_INCLUDE) # [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_OPT) \ $(@PLUGIN_NAME@_TESTS_LIB_OPT_DYN) \ $(@PLUGIN_NAME@_TESTS_LIB_BYTE) \ $(@PLUGIN_NAME@_TESTS_LIB_BYTE:%.cmo=%.cmi) 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" it is # $(PLUGIN_DIR)/@PLUGIN_NAME@_DEP_REDO. it forces the computation of # dependencies. Otherwise usual dependency for $(PLUGIN_DIR)/.depend. .PHONY: $(@PLUGIN_NAME@_DIR)/@PLUGIN_NAME@_DEP_REDO $(@PLUGIN_NAME@_DIR)/@PLUGIN_NAME@_DEP_REDO $(@PLUGIN_NAME@_DIR)/.depend: \ $(PLUGIN_GENERATED) $(TARGET_MLI) $(TARGET_GUI_MLI) $(PRINT_DEP) $(@PLUGIN_NAME@_DIR)/.depend $(RM) $(@PLUGIN_NAME@_DIR)/.depend $(OCAMLDEP) $(INCLUDES) \ $(@PLUGIN_NAME@_DEPFLAGS) \ $(patsubst ./%,%,\ $(@PLUGIN_NAME@_ML_SRC) \ $(@PLUGIN_NAME@_MLI) \ $(@PLUGIN_NAME@_GUI_MLI)) \ $(foreach d,$(@PLUGIN_NAME@_TESTS_LIB_DIR),\ -I $d $d*.ml $d*.mli) \ > $(@PLUGIN_NAME@_DIR)/.depend $(CHMOD_RO) $(@PLUGIN_NAME@_DIR)/.depend depend:: $(@PLUGIN_NAME@_DIR)/@PLUGIN_NAME@_DEP_REDO #Just for backward compatibility (19/10/2015) $(@PLUGIN_NAME@_DIR)/@PLUGIN_NAME@_DEP: $(@PLUGIN_NAME@_DIR)/.depend $(TOUCH) $@ #In internal mode wait for lib/plugins to be populated by .mli. ifeq ($(FRAMAC_INTERNAL),yes) $(@PLUGIN_NAME@_DIR)/@PLUGIN_NAME@_DEP_REDO $(@PLUGIN_NAME@_DIR)/.depend: $(INSTALLED_PLUGIN_DIR)/.placeholders_ready endif # MAKECMDGOALS contains the targets passed to make. We set it to non-empty # (if needed) to silence warnings about undefined variables. MAKECMDGOALS ?= ifneq ($(MAKECMDGOALS),clean) ifneq ($(MAKECMDGOALS),distclean) ifneq ($(MAKECMDGOALS),smartclean) sinclude $(PLUGIN_DIR)/.depend endif endif endif ############ # Cleaning # ############ .PHONY: $(PLUGIN_DIR)/@PLUGIN_NAME@_CLEAN $(PLUGIN_DIR)/@PLUGIN_NAME@_CLEAN: $(PRINT_RM) $(patsubst %_CLEAN,%,$(notdir $@)) if test "$(FRAMAC_INTERNAL)" = "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) $(foreach d,$(@:%CLEAN=%TESTS_LIB_OPT),\ $(foreach f,$($(notdir $d)),\ $f $(f:.cmx=.cmo) $(f:.cmx=.opt) $(f:.cmx=.byte) $(f:.cmx=.o))) $(RM) -f $(@PLUGIN_NAME@_CHECK_PLUGIN_MLI) .PHONY: $(PLUGIN_DIR)/@PLUGIN_NAME@_DIST_CLEAN $(PLUGIN_DIR)/@PLUGIN_NAME@_DIST_CLEAN: $(RM) $(dir $@)/tests/ptests_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 PLUGIN_GENERATED_LIST += $(PLUGIN_GENERATED) ifeq ($(PLUGIN_DYNAMIC),yes) #dynamic plugin PLUGIN_META_LIST += $(TARGET_META) PLUGIN_DYN_EXISTS:=yes PLUGIN_DYN_LIST += $(PLUGIN_DIR)/@PLUGIN_NAME@ PLUGIN_DYN_CMI_LIST += $(TARGET_CMI) ifdef PLUGIN_EXTRA_BYTE .PRECIOUS: $(TARGET_TOP_CMO) PLUGIN_DYN_CMO_LIST += $(TARGET_TOP_CMA) else PLUGIN_DYN_CMO_LIST += $(TARGET_TOP_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 PLUGIN_DYN_DEP_GUI_CMX_LIST += $(PLUGIN_GUI_CMX) PLUGIN_DYN_CMX_LIST += $(TARGET_TOP_CMXS) $(TARGET_TOP_CMX) # If P1 depends on P2, then dynamically link P1.cmxs requires to have # compiled P1's sources wrt the P2's .cmx. ifdef PLUGIN_EXTRA_OPT PLUGIN_DYN_CMX_LIST += $(TARGET_TOP_CMXA) endif #EXTRA_OPT ifeq ($(HAS_GUI),yes) PLUGIN_DYN_GUI_CMX_LIST += $(TARGET_GUI_CMXS) endif # HAS_GUI else # Normal plugin PLUGIN_LIST += $(PLUGIN_DIR)/@PLUGIN_NAME@ ifdef PLUGIN_EXTRA_BYTE .PRECIOUS: $(TARGET_TOP_CMO) $(TARGET_GUI_CMO) PLUGIN_CMO_LIST += $(TARGET_TOP_CMA) PLUGIN_GUI_CMO_LIST += $(TARGET_GUI_CMA) else PLUGIN_CMO_LIST += $(TARGET_TOP_CMO) PLUGIN_GUI_CMO_LIST += $(TARGET_GUI_CMO) endif ifdef PLUGIN_EXTRA_OPT .PRECIOUS: $(TARGET_TOP_CMX) $(TARGET_GUI_CMX) PLUGIN_CMX_LIST += $(TARGET_TOP_CMXA) PLUGIN_GUI_CMX_LIST += $(TARGET_GUI_CMXA) DEP_CMXS=$(TARGET_TOP_CMXA) else PLUGIN_CMX_LIST += $(TARGET_TOP_CMX) PLUGIN_GUI_CMX_LIST += $(TARGET_GUI_CMX) DEP_CMXS=$(TARGET_TOP_CMX) 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:= PLUGIN_DIR:= PLUGIN_DESCRIPTION:= PLUGIN_VERSION:= PLUGIN_REQUIRES:= PLUGIN_HAS_META:= PLUGIN_CMI:= PLUGIN_CMO:= PLUGIN_BFLAGS:= PLUGIN_OFLAGS:= PLUGIN_DEPFLAGS:= PLUGIN_DOCFLAGS:= PLUGIN_GENERATED:= PLUGIN_DYNAMIC:= PLUGIN_TYPES_CMO:= PLUGIN_GUI_CMO:= PLUGIN_GUI_CMX:= PLUGIN_GUI_CMI:= PLUGIN_GUI_MLI:= PLUGIN_UNDOC:= PLUGIN_TYPES_TODOC:= PLUGIN_INTRO:= PLUGIN_ENABLE:= PLUGIN_NO_TEST:= PLUGIN_TESTS_LIB:= PLUGIN_TESTS_DIRS:= PLUGIN_DEPENDS:= PLUGIN_DEPENDENCIES:= 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_EXTRA_DIRS:= PLUGIN_INTERNAL_TEST:= PLUGIN_DOC_DIR:= endif ############################################################################### # Local Variables: # mode: makefile # End: frama-c-Phosphorus-20170501/share/libc/0000755000175000017500000000000013113745013016400 5ustar mehdimehdiframa-c-Phosphorus-20170501/share/libc/__fc_define_sigset_t.h0000644000175000017500000000341013113745004022650 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB __BEGIN_DECLS typedef unsigned long sigset_t; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/grp.h0000644000175000017500000000441413113745003017343 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_define_uid_and_gid.h" #include "__fc_define_size_t.h" __BEGIN_DECLS struct group { char *gr_name; gid_t gr_gid; char **gr_mem; }; extern struct group *getgrgid(gid_t); extern struct group *getgrnam(const char *); extern int getgrgid_r(gid_t, struct group *, char *, size_t, struct group **); extern int getgrnam_r(const char *, struct group *, char *, size_t , struct group **); extern struct group *getgrent(void); extern void endgrent(void); extern void setgrent(void); /* BSD function */ extern int initgroups (const char *user, gid_t group); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/stddef.h0000644000175000017500000000374613113745001020031 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_machdep.h" __BEGIN_DECLS typedef __PTRDIFF_T ptrdiff_t; __END_DECLS #include "__fc_define_size_t.h" #ifdef __GNU_C__ #include "__fc_define_ssize_t.h" #endif #include "__fc_define_wchar_t.h" #include "__fc_define_null.h" #define offsetof(type, member) __builtin_offsetof(type,member) __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/sys/0000755000175000017500000000000013113745011017214 5ustar mehdimehdiframa-c-Phosphorus-20170501/share/libc/sys/un.h0000644000175000017500000000353013113745004020012 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "../features.h" #include "../__fc_define_sa_family_t.h" __BEGIN_DECLS struct sockaddr_un { sa_family_t sun_family; char sun_path[__FC_SOCKADDR_SUN_SUN_PATH]; /* Path name. */ }; __END_DECLS #endif frama-c-Phosphorus-20170501/share/libc/sys/times.h0000644000175000017500000000370313113745004020513 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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_TIMES_H__ #define __FC_SYS_TIMES_H__ #include "../features.h" __PUSH_FC_STDLIB #include "../time.h" struct tms { clock_t tms_utime; clock_t tms_stime; clock_t tms_cutime; clock_t tms_cstime; }; /*@ requires \valid(buffer); assigns \result, *buffer \from __fc_time; */ extern clock_t times (struct tms *buffer); __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/sys/sysctl.h0000644000175000017500000000312513113745003020710 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/sys/types.h0000644000175000017500000000443313113745011020535 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "../features.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" __BEGIN_DECLS typedef unsigned int u_int; typedef unsigned char u_char; extern dev_t makedev(int maj, int min); __END_DECLS #endif frama-c-Phosphorus-20170501/share/libc/sys/param.h0000644000175000017500000000337413113745007020501 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/sys/select.h0000644000175000017500000000325713113745011020653 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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_select.h" #endif frama-c-Phosphorus-20170501/share/libc/sys/socket.h0000644000175000017500000003436113113745005020667 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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" #include "../features.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_INET6 18 /* IP version 6 */ #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_INET6 AF_INET6 #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_SNDBUF 0x1001 /* send buffer size */ #define SO_RCVBUF 0x1002 /* receive buffer size */ #define SO_SNDLOWAT 0x1003 /* send low-water mark */ #define SO_RCVLOWAT 0x1004 /* receive low-water mark */ #define SO_SNDTIMEO 0x1005 /* send timeout */ #define SO_RCVTIMEO 0x1006 /* receive timeout */ #define SO_ERROR 0x1007 /* get error status and clear */ #define SO_TYPE 0x1008 /* get socket type */ #define SOMAXCONN 0xFF enum { SHUT_RD, SHUT_WR, SHUT_RDWR }; // POSIX requires these SHUT_* constants to be defined as macros #define SHUT_RD SHUT_RD #define SHUT_WR SHUT_WR #define SHUT_RDWR SHUT_RDWR #ifndef __FC_MAX_OPEN_SOCKETS // arbitrary number #define __FC_MAX_OPEN_SOCKETS 1024 #endif // Allows different implementations for internal socket structures #ifndef __FC_INTERNAL_SOCKFDS_PROVIDED struct __fc_sockfds_type { int x; }; #endif //@ ghost struct __fc_sockfds_type __fc_sockfds[__FC_MAX_OPEN_SOCKETS]; /* Represents the creation of new file descriptors for sockets. */ //@ ghost extern int __fc_socket_counter __attribute__((__FRAMA_C_MODEL__)); // __fc_sockfds represents the state of open socket descriptors. //@ ghost volatile int __fc_open_sock_fds; // TODO: Model the state of some functions more precisely. /*@ requires 0 <= sockfd < __FC_MAX_OPEN_SOCKETS; assigns \result, *(((char *)addr)+(0 .. *addrlen-1)), __fc_sockfds[sockfd] \from *addr, *addrlen, __fc_sockfds[sockfd]; ensures 0 <= \result < __FC_MAX_OPEN_SOCKETS || \result == -1; behavior addr_null: assumes addr == \null; requires addrlen == \null; assigns \result, __fc_sockfds[sockfd] \from __fc_sockfds[sockfd]; behavior addr_not_null: assumes addr != \null; requires \valid(addrlen); requires \valid(((char *)addr)+(0 .. *addrlen-1)); ensures \initialized(((char *)addr)+(0..*addrlen-1)); disjoint behaviors; // TODO: check what to do when the buffer addr is too small */ extern int accept(int sockfd, struct sockaddr *addr, socklen_t *addrlen); /*@ requires 0 <= sockfd < __FC_MAX_OPEN_SOCKETS; requires \valid_read(((char*)addr)+(0..addrlen-1)); assigns \result, __fc_sockfds[sockfd] \from sockfd, *addr, addrlen, __fc_sockfds[sockfd]; ensures \result == 0 || \result == -1; */ extern int bind(int sockfd, const struct sockaddr *addr, socklen_t addrlen); /*@ // ideally, we should check whether addrlen is compatible with the kind of // socket of [sockfd] (created by calling socket()). requires 0 <= sockfd < __FC_MAX_OPEN_SOCKETS; requires \valid_read(((char*)addr)+(0 .. addrlen-1)); assigns __fc_sockfds[sockfd] \from __fc_sockfds[sockfd], indirect:sockfd, indirect:addr, indirect:*addr, indirect:addrlen; assigns \result \from indirect:__fc_sockfds[sockfd], indirect:sockfd, indirect:addr, indirect:*addr, indirect:addrlen; ensures \result == 0 || \result == -1; */ extern int connect(int sockfd, const struct sockaddr *addr, socklen_t addrlen); extern int getpeername(int, struct sockaddr *, socklen_t *); extern int getsockname(int, struct sockaddr *, socklen_t *); // getsockopt is incrementally specified: options which are used more often // are gradually refined; the rest are handled by behavior "other_options". // Note: this specification may be more restrictive than what the manpage says, // to allow for a more precise analysis. It should however correspond to // expected usage. /*@ requires 0 <= sockfd < __FC_MAX_OPEN_SOCKETS; requires \valid(optlen); assigns ((char*)optval)[0..], \result \from indirect:sockfd, indirect:level, indirect:optname, indirect:*optlen, indirect:optval, indirect:__fc_sockfds[sockfd]; assigns *optlen \from indirect:sockfd, indirect:level, indirect:optname, *optlen, indirect:optval, indirect:__fc_sockfds[sockfd]; ensures \result == 0 || \result == -1; behavior so_error: assumes level == SOL_SOCKET && optname == SO_ERROR; requires \valid(optlen); requires *optlen == sizeof(int); requires \valid((int*)optval); assigns *(int*)optval, \result \from indirect:sockfd, indirect:optlen, indirect:__fc_sockfds[sockfd]; behavior other_options: assumes !(level == SOL_SOCKET && optname == SO_ERROR); requires optval == \null || \valid(((char*)optval)+(0..)); assigns ((char*)optval)[0..], \result \from indirect:sockfd, indirect:level, indirect:optname, indirect:*optlen, indirect:optval, indirect:__fc_sockfds[sockfd]; assigns *optlen \from indirect:sockfd, indirect:level, indirect:optname, *optlen, indirect:optval, indirect:__fc_sockfds[sockfd]; disjoint behaviors; complete behaviors; */ extern int getsockopt(int sockfd, int level, int optname, void *optval, socklen_t *optlen); /*@ requires 0 <= sockfd < __FC_MAX_OPEN_SOCKETS; assigns \result \from sockfd, __fc_sockfds[sockfd]; assigns __fc_sockfds[sockfd] \from sockfd, backlog, __fc_sockfds[sockfd]; ensures \result == 0 || \result == -1; */ extern int listen(int sockfd, int backlog); /* Flags for passing to recv() and others */ #define MSG_OOB 1 #define MSG_PEEK 2 #define MSG_DONTROUTE 4 #define MSG_DONTWAIT 64 /*@ requires 0 <= sockfd < __FC_MAX_OPEN_SOCKETS; requires \valid((char *)buf+(0 .. len-1)); assigns *((char *)buf+(0 .. len-1)), __fc_sockfds[sockfd], \result \from sockfd, len, flags, __fc_sockfds[sockfd]; ensures 0 <= \result <= len || \result == -1; ensures \initialized(((char *)buf+(0 .. \result-1))); */ extern ssize_t recv(int sockfd, void * buf, size_t len, int flags); extern ssize_t recvfrom(int, void *, size_t, int, struct sockaddr *, socklen_t *); /*@ requires 0 <= sockfd < __FC_MAX_OPEN_SOCKETS; @ requires \valid(&((char *)hdr->msg_control)[0..hdr->msg_controllen-1]); @ requires \valid(&(hdr->msg_iov[0..hdr->msg_iovlen-1])); @ requires hdr->msg_name == 0 || \valid(&((char *)hdr->msg_name)[0..hdr->msg_namelen-1]); @ assigns ((char *) hdr->msg_name)[0..hdr->msg_namelen-1] \from __fc_sockfds[sockfd]; @ assigns hdr->msg_namelen \from __fc_sockfds[sockfd]; @ assigns ((char *) hdr->msg_iov[0..hdr->msg_iovlen-1].iov_base)[0..] \from __fc_sockfds[sockfd]; @ assigns ((char *) hdr->msg_control)[0..hdr->msg_controllen-1] \from __fc_sockfds[sockfd]; @ assigns \result \from __fc_sockfds[sockfd]; @ assigns hdr->msg_controllen \from __fc_sockfds[sockfd]; @ assigns hdr->msg_flags \from __fc_sockfds[sockfd]; @ assigns __fc_sockfds[sockfd] \from __fc_sockfds[sockfd]; @ ensures \result <= hdr->msg_iovlen; */ extern ssize_t recvmsg(int sockfd, struct msghdr *hdr, int flags); extern ssize_t send(int, const void *, size_t, int); extern ssize_t sendmsg(int, const struct msghdr *, int); extern ssize_t sendto(int, const void *, size_t, int, const struct sockaddr *, socklen_t); /*@ requires 0 <= sockfd < __FC_MAX_OPEN_SOCKETS; requires optval == \null || \valid_read(((char *)optval)+(0..optlen-1)); assigns \result, __fc_sockfds[sockfd] \from __fc_sockfds[sockfd], level, optname, ((char *)optval)[0..optlen-1], optlen; ensures \result == 0 || \result == -1; */ extern int setsockopt(int sockfd, int level, int optname, const void *optval, socklen_t optlen); /*@ requires 0 <= sockfd < __FC_MAX_OPEN_SOCKETS; assigns \result, __fc_sockfds[sockfd] \from how, __fc_sockfds[sockfd]; ensures \result == 0 || \result == -1; */ extern int shutdown(int sockfd, int how); extern int sockatmark(int); /*@ assigns \result \from indirect:domain, indirect:type, indirect:protocol, indirect:__fc_socket_counter; assigns __fc_socket_counter \from indirect:domain, indirect:type, indirect:protocol, __fc_socket_counter; ensures 0 <= \result < __FC_MAX_OPEN_SOCKETS || \result == -1; */ extern int socket(int domain, int type, int protocol); extern int sockatmark(int); /*@ requires \valid(&socket_vector[0..1]); @ assigns \result, __fc_socket_counter, socket_vector[0..1] \from __fc_socket_counter; @ ensures \initialized(&socket_vector[0..1]); @ ensures \result == 0 || \result == -1; @ ensures 0 <= socket_vector[0] < __FC_MAX_OPEN_SOCKETS; @ ensures 0 <= socket_vector[1] < __FC_MAX_OPEN_SOCKETS; @*/ extern int socketpair(int domain, int type, int protocol, int socket_vector[2]); #endif frama-c-Phosphorus-20170501/share/libc/sys/time.h0000644000175000017500000001607513113745006020340 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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. */ //@ ghost volatile unsigned int __fc_time __attribute__((FRAMA_C_MODEL)); //@ ghost extern int __fc_tz __attribute__((FRAMA_C_MODEL)); /*@ assigns \result \from path[0..],times[0..1]; */ extern 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->tv_sec) && \initialized(&tv->tv_usec); @ @ behavior tz_not_null: @ assumes tv == \null && tz != \null; @ assigns *tz \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 \from __fc_tz; @ ensures \initialized(&tv->tv_sec) && \initialized(&tv->tv_usec); @ ensures \initialized(&tz); @ @ complete behaviors; @ disjoint behaviors; @*/ extern 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; @*/ extern int settimeofday(const struct timeval *tv, const struct timezone *tz); #if (defined _POSIX_C_SOURCE && (_POSIX_C_SOURCE) >= 200112L) || \ (defined _XOPEN_SOURCE && (_XOPEN_SOURCE) >= 600) #define ITIMER_REAL 0 #define ITIMER_VIRTUAL 1 #define ITIMER_PROF 2 struct itimerval { struct timeval it_interval; /* timer interval */ struct timeval it_value; /* current value */ }; /* Abstract representation of interval timers. */ //@ ghost volatile struct itimerval __fc_itimer_real __attribute__((FRAMA_C_MODEL)); //@ ghost volatile struct itimerval __fc_itimer_virtual __attribute__((FRAMA_C_MODEL)); //@ ghost volatile struct itimerval __fc_itimer_prof __attribute__((FRAMA_C_MODEL)); // NOTE: for functions setitimer/getitimer, we do not currently model // the signals generated by the timers when they reach zero. /*@ requires \valid(curr_value); assigns \result \from indirect:which; assigns *curr_value \from __fc_itimer_real, __fc_itimer_virtual, __fc_itimer_prof; ensures \initialized(curr_value); behavior real: assumes which == ITIMER_REAL; assigns \result \from \nothing; assigns *curr_value \from __fc_itimer_real; ensures \result == 0; behavior virtual: assumes which == ITIMER_VIRTUAL; assigns \result \from \nothing; assigns *curr_value \from __fc_itimer_virtual; ensures \result == 0; behavior prof: assumes which == ITIMER_PROF; assigns \result \from \nothing; assigns *curr_value \from __fc_itimer_prof; ensures \result == 0; behavior invalid: assumes which != ITIMER_REAL && which != ITIMER_VIRTUAL && which != ITIMER_PROF; assigns \result \from \nothing; ensures \result == -1; complete behaviors; disjoint behaviors; */ extern int getitimer(int which, struct itimerval *curr_value); // TODO: replace with a predicate, when Value will be able to evalute it // precisely #define __VALID_ITIMERVAL(tv) (0 <= (tv)->it_value.tv_usec <= 999999 && \ 0 <= (tv)->it_interval.tv_usec <= 999999) // Note: this specification is more strict than POSIX, since we forbid new_value // from being NULL. // Note: old_value depends on new_value because e.g. if new_value contains // an invalid tv_usec field, the function may fail. /*@ requires \valid_read(new_value); requires old_value == \null || \valid(old_value); assigns old_value != \null ? *old_value : \empty \from indirect:which, indirect:old_value, indirect:new_value, __fc_itimer_real, __fc_itimer_virtual, __fc_itimer_prof; assigns \result \from indirect:which, indirect:new_value, indirect:*new_value; ensures \result == 0 || \result == -1; behavior real: assumes which == ITIMER_REAL && __VALID_ITIMERVAL(new_value); assigns \result \from \nothing; assigns old_value != \null ? *old_value : \empty \from __fc_itimer_real; assigns __fc_itimer_real \from *new_value; ensures \result == 0; ensures \initialized(old_value); behavior virtual: assumes which == ITIMER_VIRTUAL && __VALID_ITIMERVAL(new_value); assigns \result \from \nothing; assigns old_value != \null ? *old_value : \empty \from __fc_itimer_virtual; ensures \result == 0; ensures \initialized(old_value); behavior prof: assumes which == ITIMER_PROF && __VALID_ITIMERVAL(new_value); assigns \result \from \nothing; assigns old_value != \null ? *old_value : \empty \from __fc_itimer_prof; ensures \result == 0; ensures \initialized(old_value); behavior invalid: assumes (which != ITIMER_REAL && which != ITIMER_VIRTUAL && which != ITIMER_PROF) || !__VALID_ITIMERVAL(new_value); assigns \result \from \nothing; ensures \result == -1; disjoint behaviors; */ extern int setitimer (int which, const struct itimerval *restrict new_value, struct itimerval *restrict old_value); #endif #endif frama-c-Phosphorus-20170501/share/libc/sys/ioctl.h0000644000175000017500000001206013113745002020476 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/sys/uio.h0000644000175000017500000000435613113745004020173 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "../features.h" __PUSH_FC_STDLIB #include "../__fc_define_ssize_t.h" #include "../__fc_define_size_t.h" #include "../__fc_define_iovec.h" __BEGIN_DECLS /*@ requires \valid_read( &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..]; */ extern ssize_t readv(int fd, const struct iovec *iov, int iovcnt); extern ssize_t writev(int fd, const struct iovec *iov, int iovcnt); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/sys/resource.h0000644000175000017500000000566513113745006021234 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "../features.h" __PUSH_FC_STDLIB #include "time.h" #include "../__fc_define_id_t.h" #define PRIO_PROCESS 0 #define PRIO_PGRP 1 #define PRIO_USER 2 __BEGIN_DECLS 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; */ extern int getpriority(int which, id_t who); /*@ assigns \result \from which,who,prio; */ extern 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; */ extern int getrlimit(int r, struct rlimit *rl); /*@ assigns \result \from r; @ assigns ru->ru_utime \from r; @ assigns ru->ru_stime \from r; */ extern int getrusage(int r, struct rusage *ru); /*@ assigns \result \from r,rl->rlim_cur,rl->rlim_max; */ extern int setrlimit(int r, const struct rlimit * rl); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/sys/stat.h0000644000175000017500000000406013113745011020340 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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" extern int chmod(const char *, mode_t); extern int fchmod(int, mode_t); extern int fstat(int, struct stat *); extern int lstat(const char *, struct stat *); extern int mkdir(const char *, mode_t); extern int mkfifo(const char *, mode_t); extern int mknod(const char *, mode_t, dev_t); extern int stat(const char *, struct stat *); extern mode_t umask(mode_t); #endif frama-c-Phosphorus-20170501/share/libc/sys/wait.h0000644000175000017500000000430313113745003020332 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "../features.h" #include "../__fc_define_pid_t.h" #include "../__fc_define_uid_and_gid.h" #include "../signal.h" #include "resource.h" __BEGIN_DECLS typedef enum __FC_IDTYPE_T { P_ALL, P_PID, P_PGID } idtype_t; extern pid_t wait(int *stat_loc); extern pid_t wait3(int *, int, struct rusage *); extern int waitid(idtype_t idt, id_t id, siginfo_t * sig, int options); extern pid_t waitpid(pid_t pid, int *stat_loc, int options); __END_DECLS #endif frama-c-Phosphorus-20170501/share/libc/stdlib.c0000644000175000017500000000635013113745003020030 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 */ #include "stdlib.h" #include "__fc_builtin.h" #include "ctype.h" int abs (int i) { if (i < 0) return -i; return i; } 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); } /* This file defines 2 different implementation of malloc: you should define one of FRAMA_C_MALLOC_STACK or FRAMA_C_MALLOC_INDIVIDUAL to select the proper one. */ #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. */ extern void *Frama_C_malloc_fresh(size_t size); void *malloc(size_t size) { return Frama_C_malloc_fresh(size); } #else #ifdef FRAMA_C_MALLOC_STACK extern void * Frama_C_malloc_by_stack(size_t size); void *malloc(size_t size) { return Frama_C_malloc_by_stack(size); } #else #error Please define one of: FRAMA_C_MALLOC_STACK FRAMA_C_MALLOC_INDIVIDUAL #endif #endif extern void Frama_C_free(void*base); void free(void *p) { if (p) Frama_C_free(p); } void *calloc(size_t nmemb, size_t size) { size_t l = nmemb * size; // test overflow, and fail if detected if (size != 0 && l / size != nmemb) { return 0; } char *p = malloc(l); if (p) Frama_C_memset(p, 0, l); return p; } frama-c-Phosphorus-20170501/share/libc/libgen.h0000644000175000017500000000312513113745004020012 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/syslog.h0000644000175000017500000001265213113745005020100 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_define_null.h" __BEGIN_DECLS 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 ; */ extern void closelog(void); /*@ assigns \nothing ; */ extern void openlog(const char *, int, int); /*@ assigns \nothing ; */ extern int setlogmask(int); /*@ assigns \nothing ; */ extern void syslog(int, const char *, ...); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/__fc_define_pid_t.h0000644000175000017500000000337713113745005022143 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB __BEGIN_DECLS typedef unsigned int pid_t ; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/__fc_define_size_t.h0000644000175000017500000000342613113745012022332 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_machdep.h" __BEGIN_DECLS typedef __SIZE_T size_t; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/linux/0000755000175000017500000000000013113745013017537 5ustar mehdimehdiframa-c-Phosphorus-20170501/share/libc/linux/netlink.h0000644000175000017500000000323113113745011021351 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/linux/rtnetlink.h0000644000175000017500000000323513113745004021725 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/linux/fs.h0000644000175000017500000000323113113745013020317 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/linux/if_netlink.h0000644000175000017500000000322713113745010022033 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/linux/if_addr.h0000644000175000017500000000322713113745012021303 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/__fc_define_sa_family_t.h0000644000175000017500000000345513113745004023327 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB #include "__fc_machdep.h" __BEGIN_DECLS typedef __UINT_LEAST16_T sa_family_t; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/__fc_define_nlink_t.h0000644000175000017500000000340413113745003022467 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB __BEGIN_DECLS typedef unsigned int nlink_t; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/__fc_builtin.c0000644000175000017500000000527413113745007021173 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "__fc_builtin.h" /* Those builtins implementations could probably be removed entirely for Value, as the spec is informative enough. There remains a slight difference with Frama_C_float/double_interval and +0./-0., because the specification is not sufficient to to exclude -0. when requiring >= +0. */ int volatile Frama_C_entropy_source; //@ assigns Frama_C_entropy_source \from Frama_C_entropy_source; extern 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; } frama-c-Phosphorus-20170501/share/libc/getopt.c0000644000175000017500000000317213113745006020053 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "getopt.h" int optind = 1; frama-c-Phosphorus-20170501/share/libc/__fc_define_iovec.h0000644000175000017500000000347313113745013022145 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_define_size_t.h" __BEGIN_DECLS struct iovec { void *iov_base; size_t iov_len; }; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/wchar.c0000644000175000017500000000562113113745011017652 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 */ #include "wchar.h" wchar_t* wmemcpy(wchar_t * region1, const wchar_t * region2, size_t n) { const wchar_t* first = (const wchar_t*)region2; const wchar_t* last = ((const wchar_t*)region2) + n; wchar_t* result = (wchar_t*)region1; wchar_t* dest = result; while (first != last) *dest++ = *first++; return result; } wchar_t * wmemset(wchar_t *dest, wchar_t val, size_t len) { wchar_t *ptr = dest; while (len-- > 0) *ptr++ = val; return dest; } wchar_t* wcscpy(wchar_t * s1, const wchar_t * s2) { wchar_t *os1 = s1; while (*s1++ = *s2++) ; return (os1); } size_t wcslen(const wchar_t * str) { const wchar_t *s =str; for (s = str; *s; ++s); return(s - str); } wchar_t * wcsncpy(wchar_t * s1, const wchar_t * s2, size_t n) { wchar_t *os1 = s1; n++; while ((--n != 0) && ((*s1++ = *s2++) != L'\0')) ; if (n != 0) while (--n != 0) *s1++ = L'\0'; return (os1); } wchar_t * wcscat(wchar_t * s1, const wchar_t * s2) { wchar_t *os1 = s1; while (*s1++) ; --s1; while (*s1++ = *s2++) ; return (os1); } wchar_t* wcsncat(wchar_t *dest, const wchar_t *src, size_t n) { size_t dest_len = wcslen(dest); size_t i; for (i = 0 ; i < n && src[i] != L'\0' ; i++) dest[dest_len + i] = src[i]; dest[dest_len + i] = L'\0'; return dest; } frama-c-Phosphorus-20170501/share/libc/inttypes.c0000644000175000017500000000346513113745006020435 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "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-Phosphorus-20170501/share/libc/inttypes.h0000644000175000017500000002073413113745012020435 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB /* ISO C: 7.8 */ #include "stdint.h" #include "errno.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" __BEGIN_DECLS #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 ; */ extern intmax_t imaxabs(intmax_t c); /*@ requires denom != 0; assigns \result \from numer, denom ; ensures \result.quot == numer / denom; ensures \result.rem == numer % denom; */ extern 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 ; */ extern intmax_t strtoimax(const char * restrict nptr, char ** restrict endptr, int base); extern uintmax_t strtoumax(const char * restrict nptr, char ** restrict endptr, int base); extern intmax_t wcstoimax(const wchar_t * restrict nptr, wchar_t ** restrict endptr, int base); extern uintmax_t wcstoumax(const wchar_t * restrict nptr, wchar_t ** restrict endptr, int base); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/math.c0000644000175000017500000000446213113745006017505 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 */ #include "math.h" /*@ assigns \result \from x; */ extern double Frama_C_exp(double x); /*@ assigns \result \from x; */ double exp(double x){ return Frama_C_exp(x); } /*@ assigns \result \from x; */ extern double Frama_C_cos(double x); /*@ assigns \result \from x; */ double cos(double x){ return Frama_C_cos(x); } /*@ assigns \result \from x; */ extern double Frama_C_sin(double x); /*@ assigns \result \from x; */ double sin(double x){ return Frama_C_sin(x); } /*@ assigns \result \from x; */ extern double Frama_C_sqrt(double x); /*@ assigns \result \from x; */ double sqrt(double x) { return Frama_C_sqrt(x); } double fabs(double x){ if(x==0.0) return 0.0; if (x>0.0) return x; return -x; } frama-c-Phosphorus-20170501/share/libc/__fc_define_suseconds_t.h0000644000175000017500000000341513113745005023366 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB __BEGIN_DECLS typedef signed int suseconds_t; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/strings.h0000644000175000017500000000440613113745010020243 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_define_size_t.h" __BEGIN_DECLS extern int bcmp(const void *, const void *, size_t); extern void bcopy(const void *, void *, size_t); /*@ requires \valid (((char*) s)+(0 .. n-1)); assigns ((char*) s)[0 .. n-1] \from \nothing; ensures \subset(((char*) s)[0 .. n-1], {0}); */ extern void bzero(void *s, size_t n); extern int ffs(int); extern char *index(const char *, int); extern char *rindex(const char *, int); extern int strcasecmp(const char *, const char *); extern int strncasecmp(const char *, const char *, size_t); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/string.h0000644000175000017500000003003313113745004020056 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_string_axiomatic.h" #include "stddef.h" #include "limits.h" __BEGIN_DECLS // Query memory /*@ requires \valid_read(((char*)s1)+(0..n - 1)); @ requires \valid_read(((char*)s2)+(0..n - 1)); @ assigns \result \from ((char*)s1)[0.. n-1], ((char*)s2)[0.. n-1]; @ ensures \result == memcmp{Pre,Pre}((char*)s1,(char*)s2,n); @*/ extern int memcmp (const void *s1, const void *s2, size_t n); /*@ requires \valid_read(((unsigned char*)s)+(0..n - 1)); @ assigns \result \from s, c, ((unsigned char*)s)[0..n-1]; @ behavior found: @ assumes memchr((char*)s,c,n); @ ensures \base_addr(\result) == \base_addr(s); @ ensures *(char*)\result == c; @ ensures \forall integer i; @ 0 <= i < n ==> *((unsigned char*)s+i) == c @ ==> \result <= s+i; @ 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_dst: \valid(((char*)dest)+(0..n - 1)); @ requires valid_src: \valid_read(((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{Post,Pre}((char*)dest,(char*)src,n) == 0; @ ensures \result == dest; @*/ extern void *memcpy(void *restrict dest, const void *restrict src, size_t n); /*@ requires valid_dst: \valid(((char*)dest)+(0..n - 1)); @ requires valid_src: \valid_read(((char*)src)+(0..n - 1)); @ assigns ((char*)dest)[0..n - 1] \from ((char*)src)[0..n-1]; @ assigns \result \from dest; @ ensures memcmp{Post,Pre}((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_src: valid_read_string(s); @ assigns \result \from s[0..]; @ ensures \result == strlen(s); @*/ extern size_t strlen (const char *s); /*@ requires valid_string_src: valid_read_string(s); // over-strong @ assigns \result \from s[0..]; @ ensures \result == strlen(s) || \result == n; @*/ extern size_t strnlen (const char *s, size_t n); /*@ requires valid_string_s1: valid_read_string(s1); @ requires valid_string_s2: valid_read_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: valid_read_string(s1); // over-strong @ requires valid_string_s2: valid_read_string(s2); // over-strong @ 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_read_string(s1); // over-strong @ requires valid_string_s2: valid_read_string(s2); // over-strong @ assigns \result \from s1[0..], s2[0..]; @*/ extern int strcoll (const char *s1, const char *s2); /*@ requires valid_string_src: valid_read_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_read_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_src: valid_read_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_read_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_src: valid_read_string(s); @ requires valid_string_reject: valid_read_string(reject); @ assigns \result \from s[0..], reject[0..]; @ ensures 0 <= \result <= strlen(s); @*/ extern size_t strcspn(const char *s, const char *reject); /*@ requires valid_string_src: valid_read_string(s); @ requires valid_string_accept: valid_read_string(accept); @ assigns \result \from s[0..], accept[0..]; @ ensures 0 <= \result <= strlen(s); @*/ extern size_t strspn(const char *s, const char *accept); /*@ requires valid_string_src: valid_read_string(s); @ requires valid_string_accept: valid_read_string(accept); @ assigns \result \from s, s[0..], accept[0..]; @ ensures \result == 0 || \base_addr(\result) == \base_addr(s); @*/ extern char *strpbrk(const char *s, const char *accept); /*@ requires valid_string_haystack: valid_read_string(haystack); @ requires valid_string_needle: valid_read_string(needle); @ assigns \result \from haystack, indirect:haystack[0..], @ indirect:needle[0..]; @ ensures \result == 0 @ || (\subset(\result, haystack+(0..)) && \valid_read(\result) @ && memcmp{Pre,Pre}(\result,needle,strlen(needle)) == 0); @*/ extern char *strstr(const char *haystack, const char *needle); #ifdef __USE_GNU /*@ requires valid_string_haystack: valid_read_string(haystack); @ requires valid_string_needle: valid_read_string(needle); @ assigns \result \from haystack, indirect:haystack[0..], @ indirect:needle[0..]; @ ensures \result == 0 @ || (\subset(\result, haystack+(0..)) && \valid_read(\result)); @*/ extern char *strcasestr (const char *haystack, const char *needle); #endif /*@ requires valid_string_src: valid_string_or_null(s); @ requires valid_string_delim: valid_read_string(delim); @ assigns \result \from s, s[0..], delim[0..]; @ ensures \result == \null || \base_addr(\result) == \base_addr(s); @*/ extern char *strtok(char *restrict s, const char *restrict delim); /*@ requires valid_string_src: \valid(stringp) && valid_string(*stringp); @ requires valid_string_delim: valid_read_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_read_string(\result); @*/ extern char *strerror(int errnum); // Copy strings /*@ requires valid_string_src: valid_read_string(src); @ requires room_string: \valid(dest+(0..strlen(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_string_src: valid_read_string(src); @ requires room_nstring: \valid(dest+(0 .. n-1)); @ assigns dest[0..n - 1] \from src[0..n-1]; @ assigns \result \from dest; @ ensures \result == dest; @ ensures \initialized(dest+(0 .. n-1)); @ behavior complete: @ assumes strlen(src) < n; @ ensures strcmp(dest,src) == 0; @ behavior partial: @ assumes n <= strlen(src); @ ensures memcmp{Post,Post}(dest,src,n) == 0; @*/ extern char *strncpy(char *restrict dest, const char *restrict src, size_t n); // stpcpy is POSIX.1-2008 #ifdef _POSIX_C_SOURCE # if _POSIX_C_SOURCE >= 200809L /*@ requires valid_string_src: valid_read_string(src); @ requires room_string: \valid(dest+(0..strlen(src))); @ assigns dest[0..strlen(src)] \from src[0..strlen(src)]; @ assigns \result \from dest; @ ensures strcmp(dest,src) == 0; @ ensures \result == dest + strlen(dest); @*/ extern char *stpcpy(char *restrict dest, const char *restrict src); # endif #endif /*@ // missing: separation @ requires valid_string_src: valid_read_string(src); @ requires valid_string_dst: valid_string(dest); @ requires room_string: \valid(dest+(0..strlen(dest) + strlen(src))); @ 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); /*@ // missing: separation @ requires valid_string_src: valid_read_string(src) || \valid_read(src+(0..n-1)); @ requires valid_string_dst: valid_string(dest); @ requires room_string: \valid(dest + (strlen(dest) .. strlen(dest) + n)) ; @ assigns dest[strlen(dest) .. strlen(dest) + n] \from src[0..n]; @ assigns \result \from dest; @ ensures \result == dest; @ behavior complete: @ assumes valid_read_string(src) && strlen(src) <= n; @ assigns dest[strlen(dest)..strlen(dest) + strlen(src)] @ \from src[0..strlen(src)]; @ assigns \result \from dest; @ ensures strlen(dest) == \old(strlen(dest) + strlen(src)); @ behavior partial: @ assumes ! (valid_read_string(src) && strlen(src) <= n); @ assigns dest[strlen(dest)..strlen(dest) + n] @ \from src[0..strlen(src)]; @ assigns \result \from dest; @ ensures strlen(dest) == \old(strlen(dest)) + n; @*/ extern char *strncat(char *restrict dest, const char *restrict src, size_t n); /*@ requires valid_dest: \valid(dest+(0..n - 1)); @ requires valid_string_src: valid_read_string(src); @ assigns dest[0..n - 1] \from src[0..], n; @ assigns \result \from dest; @*/ extern size_t strxfrm (char *restrict dest, const char *restrict src, size_t n); // Allocate strings /*@ requires valid_string_src: valid_read_string(s); @ assigns \result; // FIXME @ ensures \valid(\result+(0..strlen(s))) && strcmp(\result,s) == 0; @*/ extern char *strdup (const char *s); /*@ requires valid_string_src: valid_read_string(s); // FIXME @ assigns \result; // FIXME @ 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); __END_DECLS /* Include strings.h: this is what BSD does, and glibc does something equivalent (having copied prototypes to string.h). */ #include __POP_FC_STDLIB #endif /* _STRING_H_ */ frama-c-Phosphorus-20170501/share/libc/__fc_define_seek_macros.h0000644000175000017500000000355613113745007023340 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/complex.h0000644000175000017500000000333413113745011020221 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/features.h0000644000175000017500000000763413113745005020402 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 // *** Definitions to improve compatibility with GCC-specific built-ins // and GNU-based code *** # define __LEAF # define __LEAF_ATTR #ifdef __FRAMAC__ #define __PUSH_FC_STDLIB #pragma fc_stdlib(push,__FILE__) #define __POP_FC_STDLIB #pragma fc_stdlib(pop) #else #define __PUSH_FC_STDLIB #define __POP_FC_STDLIB #endif #ifdef __cplusplus # define __BEGIN_DECLS extern "C" { # define __END_DECLS } #else # define __BEGIN_DECLS # define __END_DECLS #endif #if defined __cplusplus # define __THROW throw () # define __THROWNL throw () # define __NTH(fct) __LEAF_ATTR fct throw () #else # define __THROW # define __THROWNL # define __NTH(fct) fct #endif // Frama-C does not support GCC's __builtin_object_size. // To improve compatibility with some codebases, // we define it anyway, but it always returns -1, as if // the compiler were unable to statically determine // the object size (we only consider the cases where type // is either 0 or 1). #define __builtin_object_size (ptr, type) ((size_t)-1) #define __bos(ptr) __builtin_object_size (ptr, 0) #define __bos0(ptr) __builtin_object_size (ptr, 0) #define __warndecl(name, msg) extern void name (void) #define __warnattr(msg) #define __errordecl(name, msg) extern void name (void) // Protection against pre-processor built-ins #if defined __nonnull # undef __nonnull #endif #define __nonnull(args...) #ifndef __attribute_deprecated__ # define __attribute_deprecated__ __attribute__((__deprecated__)) #endif #ifndef __attribute_format_arg__ # define __attribute_format_arg__(x) __attribute__((__format_arg__(x))) #endif #ifndef __attribute_const__ # define __attribute_const__ __attribute__((__const__)) #endif #ifndef __attribute_malloc__ # define __attribute_malloc__ __attribute__((__malloc__)) #endif #ifndef __attribute_artificial__ # define __attribute_artificial__ /* Ignore */ #endif #define __attribute_warn_unused_result__ /* empty */ #ifndef __wur # define __wur /* Ignore */ #endif #ifndef __STDC_VERSION__ #define restrict #else #define __restrict__ #define __restrict # if __STDC_VERSION__ >= 199901L && defined (FRAMA_C_C99) #define restrict restrict #define __restrict__ restrict #define __restrict restrict # else #define restrict #define __restrict__ #define __restrict # endif #endif #define __USE_ISOC99 1 /* end __FC_FEATURES_H */ #endif frama-c-Phosphorus-20170501/share/libc/stdio.c0000644000175000017500000000356613113745012017677 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "stdio.h" FILE __fc_initial_stdout = {.__fc_FILE_id=1}; FILE * __fc_stdout = &__fc_initial_stdout; FILE __fc_initial_stderr = {.__fc_FILE_id=2}; FILE * __fc_stderr = &__fc_initial_stderr; FILE __fc_initial_stdin = {.__fc_FILE_id=0}; FILE * __fc_stdin = &__fc_initial_stdin; frama-c-Phosphorus-20170501/share/libc/pwd.h0000644000175000017500000000445213113745005017351 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_define_uid_and_gid.h" // for size_t #include "stddef.h" __BEGIN_DECLS struct passwd { char *pw_name; uid_t pw_uid; gid_t pw_gid; char *pw_dir; char *pw_shell; }; extern struct passwd *getpwnam(const char *); extern struct passwd *getpwuid(uid_t); extern int getpwnam_r(const char *, struct passwd *, char *, size_t, struct passwd **); extern int getpwuid_r(uid_t, struct passwd *, char *, size_t, struct passwd **); extern void endpwent(void); extern struct passwd *getpwent(void); extern void setpwent(void); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/fenv.h0000644000175000017500000000325013113745007017512 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/__fc_define_timespec.h0000644000175000017500000000344113113745010022641 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB __BEGIN_DECLS struct timespec { long tv_sec; long tv_nsec; }; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/stdarg.h0000644000175000017500000000374113113745007020045 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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.15 */ #ifndef __FC_STDARG #define __FC_STDARG #include "features.h" __PUSH_FC_STDLIB #include "__fc_machdep.h" // for __FC_VA_LIST_T __BEGIN_DECLS typedef __FC_VA_LIST_T va_list; __END_DECLS #define va_arg(a,b) __builtin_va_arg(a,b) #define va_copy(a,b) __builtin_va_copy(a,b) #define va_end(a) __builtin_va_end(a) #define va_start(a,b) __builtin_va_start(a,b) __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/__fc_builtin_for_normalization.i0000644000175000017500000000503613113745003025005 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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; */ extern 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]; */ extern void Frama_C_copy_block(unsigned char* dest, unsigned long size, unsigned long n) __attribute__((FC_BUILTIN)) ; frama-c-Phosphorus-20170501/share/libc/__fc_define_intptr_t.h0000644000175000017500000000347413113745005022705 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_machdep.h" __BEGIN_DECLS #ifdef __INTPTR_T typedef __INTPTR_T intptr_t; #endif __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/locale.c0000644000175000017500000000417313113745004020010 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "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-Phosphorus-20170501/share/libc/__fc_define_off_t.h0000644000175000017500000000345713113745004022137 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB #include "__fc_machdep.h" __BEGIN_DECLS typedef long int off_t; typedef __INT64_T off64_t; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/errno.c0000644000175000017500000000317513113745010017674 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "errno.h" int __fc_errno = 0; frama-c-Phosphorus-20170501/share/libc/__fc_define_blkcnt_t.h0000644000175000017500000000326713113745007022644 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/__fc_define_useconds_t.h0000644000175000017500000000341513113745001023177 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB __BEGIN_DECLS typedef unsigned int useconds_t; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/__fc_select.h0000644000175000017500000000447713113745002021010 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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_SELECT__ #define __FC_SELECT__ #include "features.h" __PUSH_FC_STDLIB #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 "sys/time.h" __BEGIN_DECLS /* assigns \result \from nfds, *readfds, *writefds,*errorfds,*timeout,*sigmask; */ extern 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 ;*/ extern int select(int nfds, fd_set * readfds, fd_set * writefds, fd_set * errorfds, struct timeval * timeout); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/wctype.h0000644000175000017500000000462013113745010020063 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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_WCTYPE_H #define __FC_WCTYPE_H #include "features.h" __PUSH_FC_STDLIB #include "__fc_define_wint_t.h" __BEGIN_DECLS extern int iswalnum(wint_t wc); extern int iswalpha(wint_t wc); extern int iswascii(wint_t wc); extern int iswblank(wint_t wc); extern int iswcntrl(wint_t wc); extern int iswdigit(wint_t wc); extern int iswgraph(wint_t wc); extern int iswhexnumber(wint_t wc); extern int iswideogram(wint_t wc); extern int iswlower(wint_t wc); extern int iswnumber(wint_t wc); extern int iswphonogram(wint_t wc); extern int iswprint(wint_t wc); extern int iswpunct(wint_t wc); extern int iswrune(wint_t wc); extern int iswspace(wint_t wc); extern int iswspecial(wint_t wc); extern int iswupper(wint_t wc); extern int iswxdigit(wint_t wc); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/__fc_define_wint_t.h0000644000175000017500000000342613113745007022345 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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_WINT_T #define __FC_DEFINE_WINT_T #include "features.h" __PUSH_FC_STDLIB #include "__fc_machdep.h" __BEGIN_DECLS typedef __WINT_T wint_t; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/errno.h0000644000175000017500000001275613113745002017707 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #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 __BEGIN_DECLS extern int __fc_errno; #define errno __fc_errno /* _GNU_SOURCE */ extern char *program_invocation_name; extern char *program_invocation_short_name; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/unistd.h0000644000175000017500000007556213113745003020075 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_string_axiomatic.h" #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" #include "__fc_select.h" #include extern int Frama_C_entropy_source; /* 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" __BEGIN_DECLS /* 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 }; // arbitrary number #define __FC_MAX_OPEN_FILES 1024 // __fc_fds represents the state of open file descriptors. //@ ghost int __fc_fds[__FC_MAX_OPEN_FILES]; // TODO: Model the state of some functions more precisely. // TODO: define __fc_fds as volatile. extern int access(const char *, int); extern unsigned int alarm(unsigned int); extern int brk(void *); extern int chdir(const char *path); extern int chroot(const char *path); extern int chown(const char *, uid_t, gid_t); /*@ requires 0 <= fd < __FC_MAX_OPEN_FILES; assigns \result, __fc_fds[fd] \from fd, __fc_fds[fd]; ensures \result == 0 || \result == -1; */ extern int close(int fd); extern size_t confstr(int, char *, size_t); extern char *crypt(const char *, const char *); extern char *ctermid(char *); extern char *cuserid(char *s); extern int dup(int); extern int dup2(int, int); extern void encrypt(char[64], int); /*@ requires arg != \null; requires valid_read_string(path); requires valid_read_string(arg); assigns \result \from path[0..], arg[0..]; */ extern int execl(const char *path, const char *arg, ...); /*@ requires arg != \null; requires valid_read_string(path); requires valid_read_string(arg); assigns \result \from path[0..], arg[0..]; */ extern int execle(const char *path, const char *arg, ...); /*@ requires arg != \null; requires valid_read_string(path); requires valid_read_string(arg); assigns \result \from path[0..], arg[0..]; */ extern int execlp(const char *path, const char *arg, ...); /*@ requires argv[0] != \null; requires valid_read_string(path); requires valid_read_string(argv[0]); assigns \result \from path[0..], argv[0..]; */ extern int execv(const char *path, char *const argv[]); /*@ requires argv[0] != \null; requires valid_read_string(path); requires valid_read_string(argv[0]); assigns \result \from path[0..], argv[0..]; */ extern int execve(const char *path, char *const argv[], char *const env[]); /*@ requires argv[0] != \null; requires valid_read_string(path); requires valid_read_string(argv[0]); assigns \result \from path[0..], argv[0..]; */ extern int execvp(const char *path, char *const argv[]); extern void _exit(int) __attribute__ ((__noreturn__)); extern int fchown(int, uid_t, gid_t); extern int fchdir(int); extern int fdatasync(int); extern pid_t fork(void); extern long int fpathconf(int, int); extern int fsync(int); extern int ftruncate(int, off_t); extern char *getcwd(char *, size_t); extern int getdtablesize(void); extern gid_t getegid(void); extern uid_t geteuid(void); extern gid_t getgid(void); extern int getgroups(int, gid_t []); extern long gethostid(void); extern int gethostname(char *, size_t); extern char *getlogin(void); extern int getlogin_r(char *, size_t); extern int getpagesize(void); extern char *getpass(const char *); extern pid_t getpgid(pid_t); extern pid_t getpgrp(void); extern pid_t getpid(void); extern pid_t getppid(void); extern pid_t getsid(pid_t); /*@ assigns \result \from \nothing; */ extern uid_t getuid(void); extern char *getwd(char *); extern int isatty(int); extern int lchown(const char *, uid_t, gid_t); extern int link(const char *, const char *); extern int lockf(int, int, off_t); extern off_t lseek(int, off_t, int); extern int nice(int); extern long int pathconf(const char *, int); extern int pause(void); extern int pipe(int [2]); extern ssize_t pread(int, void *, size_t, off_t); extern int pthread_atfork(void (*)(void), void (*)(void), void(*)(void)); extern ssize_t pwrite(int, const void *, size_t, off_t); /*@ requires 0 <= fd < __FC_MAX_OPEN_FILES; requires \valid((char *)buf+(0..count-1)); assigns \result, *((char *)buf+(0..count-1)), __fc_fds[fd] \from __fc_fds[fd], count; ensures 0 <= \result <= count || \result == -1; ensures \initialized(((char*)buf)+(0..\result-1)); */ extern ssize_t read(int fd, void *buf, size_t count); extern int readlink(const char *, char *, size_t); extern int rmdir(const char *); extern void *sbrk(intptr_t); extern int setegid(gid_t gid); extern int seteuid(uid_t uid); extern int setgid(gid_t); extern int setpgid(pid_t, pid_t); extern pid_t setpgrp(void); extern int setregid(gid_t, gid_t); extern int setreuid(uid_t, uid_t); extern pid_t setsid(void); extern int setuid(uid_t uid); extern unsigned int sleep(unsigned int); extern void swab(const void *, void *, ssize_t); extern int symlink(const char *, const char *); extern void sync(void); extern long int sysconf(int); extern pid_t tcgetpgrp(int); extern int tcsetpgrp(int, pid_t); extern int truncate(const char *, off_t); extern char *ttyname(int); extern int ttyname_r(int, char *, size_t); extern useconds_t ualarm(useconds_t, useconds_t); extern int unlink(const char *); // usleep is not POSIX anymore since 200809 #if (_XOPEN_SOURCE >= 500) && ! (_POSIX_C_SOURCE >= 200809L) \ || /* Glibc since 2.19: */ defined _DEFAULT_SOURCE \ || /* Glibc versions <= 2.19: */ defined _BSD_SOURCE /*@ assigns \result \from indirect:usec, indirect:Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures \result == 0 || \result == -1; */ extern int usleep(useconds_t usec); #endif extern pid_t vfork(void); /*@ requires 0 <= fd < __FC_MAX_OPEN_FILES; requires \valid_read(((char *)buf)+(0..count-1)); assigns \result, __fc_fds[fd] \from fd, count, __fc_fds[fd]; ensures -1 <= \result <= count; */ extern ssize_t write(int fd, const void *buf, size_t count); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/fcntl.h0000644000175000017500000001467213113745010017666 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #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 */ __BEGIN_DECLS 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 ; */ extern int creat(const char *filename, mode_t mode); /*@ assigns \result \from fd, cmd ; */ extern int fcntl(int fd, int cmd, ...); /*@ assigns \result \from filename[0..], flags ; */ extern int open(const char *filename, int flags, ...); /*@ assigns \result \from dirfd, filename[0..], flags ; */ extern int openat(int dirfd, const char *filename, int flags, ...); /* The following functions are "fixed-argument" versions of open/fcntl. They are used when the translation of variadic function to fixed-adic is enabled */ /*@ requires valid_cmd: cmd == F_GETFD || cmd == F_GETFL || cmd == F_GETOWN ; assigns \result \from fd, cmd ; */ extern int __va_fcntl_void(int fd, int cmd); /*@ requires valid_cmd: cmd == F_DUPFD || cmd == F_SETFD || cmd == F_SETFL || cmd == F_SETOWN ; assigns \result \from fd, cmd, arg ;*/ extern int __va_fcntl_int(int fd, int cmd, int arg); /*@ requires valid_cmd: cmd == F_GETLK || cmd == F_SETLK || cmd == F_SETLKW ; requires valid_arg: \valid(arg) ; assigns \result, *arg \from fd, cmd, *arg ; */ extern int __va_fcntl_flock(int fd, int cmd, struct flock *arg); /*@ requires valid_flag: !(flags & O_CREAT) ; assigns \result \from filename[0..], flags ; */ extern int __va_open_void(const char *filename, int flags); /*@ assigns \result \from filename[0..], flags, mode ; */ extern int __va_open_mode_t(const char *filename, int flags, mode_t mode); /*@ requires valid_flag: !(flags & O_CREAT) ; assigns \result \from dirfd, filename[0..], flags ; */ extern int __va_openat_void(int dirfd, const char *filename, int flags); /*@ assigns \result \from dirfd, filename[0..], flags, mode ; */ extern int __va_openat_mode_t(int dirfd, const char *filename, int flags, mode_t mode); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/wchar.h0000644000175000017500000001462313113745010017660 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB #include "__fc_define_wchar_t.h" #include "__fc_define_size_t.h" #include "__fc_define_file.h" __BEGIN_DECLS /*@ assigns \result \from s, indirect:s[0 .. n-1], indirect:c, indirect:n; ensures \result == \null || \subset (\result, s+(0 .. n-1)); */ extern wchar_t * wmemchr(const wchar_t *s, wchar_t c, size_t n); /*@ assigns \result \from indirect:s1[0 .. n-1], indirect:s2[0 .. n-1], indirect:n; */ extern int wmemcmp(const wchar_t *s1, const wchar_t *s2, size_t n); /*@ requires \separated(dest+(0 .. n-1), src+(0 .. n-1)); assigns dest[0 .. n-1] \from src[0 .. n-1], indirect:src, indirect:n; assigns \result \from dest; ensures \result == dest; */ extern wchar_t * wmemcpy(wchar_t *restrict dest, const wchar_t *restrict src, size_t n); /*@ assigns dest[0 .. n-1] \from src[0 .. n-1], indirect:src, indirect:n; assigns \result \from dest; ensures \result == dest; */ extern wchar_t * wmemmove(wchar_t *dest, const wchar_t *src, size_t n); /*@ assigns wcs[0 .. n-1] \from wc, indirect:n; assigns \result \from wcs; ensures \result == wcs; */ extern wchar_t * wmemset(wchar_t *wcs, wchar_t wc, size_t n); /*@ assigns dest[0 .. ] \from dest[0 .. ], indirect:dest, src[0 .. ], indirect:src; assigns \result \from dest; ensures \result == dest; */ extern wchar_t * wcscat(wchar_t *restrict dest, const wchar_t *restrict src); /*@ assigns \result \from wcs, indirect:wc; ensures \result == \null || \subset (\result, wcs+(0 .. )); */ extern wchar_t * wcschr(const wchar_t *wcs, wchar_t wc); /*@ assigns \result \from indirect:s1[0 .. ], indirect:s2[0 .. ]; */ extern int wcscmp(const wchar_t *s1, const wchar_t *s2); /*@ assigns dest[0 .. ] \from src[0 .. ], indirect:src, dest[0 .. ], indirect:dest; assigns \result \from dest; ensures \result == dest; */ extern wchar_t * wcscpy(wchar_t *restrict dest, const wchar_t *restrict src); /*@ assigns \result \from indirect:wcs[0 .. ], indirect:accept[0 .. ]; */ extern size_t wcscspn(const wchar_t *wcs, const wchar_t *accept); // wcslcat is a BSD extension (non-C99, non-POSIX) /*@ assigns dest[0 .. ] \from dest[0 .. ], indirect:dest, src[0 .. n-1], indirect:src, indirect:n; assigns \result \from indirect:dest[0 .. ], indirect:src[0 .. n-1], indirect:n; */ extern size_t wcslcat(wchar_t *restrict dest, const wchar_t *restrict src, size_t n); // wcslcpy is a BSD extension (non-C99, non-POSIX) /*@ requires \separated(dest+(0 .. n-1), src+(0 .. n-1)); assigns dest[0 .. n-1] \from src[0 .. n-1], indirect:src, indirect:n; assigns \result \from indirect:dest[0 .. n-1], indirect:dest, indirect:src[0 .. n-1], indirect:src, indirect:n; */ extern size_t wcslcpy(wchar_t *dest, const wchar_t *src, size_t n); /*@ assigns \result \from indirect:s[0 .. ]; */ extern size_t wcslen(const wchar_t *s); /*@ assigns dest[0 .. ] \from dest[0 .. ], indirect:dest, src[0 .. n-1], indirect:src, indirect:n; assigns \result \from dest; ensures \result == dest; */ extern wchar_t * wcsncat(wchar_t *restrict dest, const wchar_t *restrict src, size_t n); /*@ assigns \result \from indirect:s1[0 .. n-1], indirect:s2[0 .. n-1], indirect:n; */ extern int wcsncmp(const wchar_t *s1, const wchar_t *s2, size_t n); /*@ requires \separated(dest+(0 .. n-1), src+(0 .. n-1)); assigns dest[0 .. n-1] \from src[0 .. n-1], indirect:src, indirect:n; assigns \result \from dest; ensures \result == dest; */ extern wchar_t * wcsncpy(wchar_t *restrict dest, const wchar_t *restrict src, size_t n); /*@ assigns \result \from wcs, indirect:wcs[0 .. ], indirect:accept[0 .. ]; ensures \result == \null || \subset (\result, wcs+(0 .. )); */ extern wchar_t * wcspbrk(const wchar_t *wcs, const wchar_t *accept); /*@ assigns \result \from wcs, indirect:wcs[0 .. ], indirect:wc; ensures \result == \null || \subset (\result, wcs+(0 .. )); */ extern wchar_t * wcsrchr(const wchar_t *wcs, wchar_t wc); /*@ assigns \result \from indirect:wcs[0 .. ], indirect:accept[0 .. ]; */ extern size_t wcsspn(const wchar_t *wcs, const wchar_t *accept); /*@ assigns \result \from haystack, indirect:haystack[0 .. ], indirect:needle[0 .. ]; ensures \result == \null || \subset (\result, haystack+(0 .. )); */ extern wchar_t * wcsstr(const wchar_t *haystack, const wchar_t *needle); /* It is unclear whether these are more often in wchar.h or stdio.h */ extern int fwprintf(FILE * stream, const wchar_t * format, ...); extern int swprintf(wchar_t * ws, size_t n, const wchar_t * format, ...); extern int wprintf(const wchar_t * format, ...); extern int wscanf(const wchar_t * format, ...); extern int fwscanf(FILE * stream, const wchar_t * format, ...); extern int swscanf(const wchar_t * str, const wchar_t * format, ...); typedef struct { int __count; char __value[4]; } mbstate_t; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/__fc_define_file.h0000644000175000017500000000362113113745006021754 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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_FILE #define __FC_DEFINE_FILE #include "features.h" __PUSH_FC_STDLIB #include "__fc_define_stat.h" #include "__fc_define_fpos_t.h" __BEGIN_DECLS struct __fc_FILE { unsigned int __fc_FILE_id; unsigned int __fc_FILE_data; }; typedef struct __fc_FILE FILE; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/limits.h0000644000175000017500000000644013113745002020054 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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.10 and 5.2.4.2.1 */ #ifndef __FC_LIMITS #define __FC_LIMITS #include "__fc_machdep.h" /* Number of bits in a `char'. */ #define CHAR_BIT __CHAR_BIT /* Minimum and maximum values a `signed char' can hold. */ # define SCHAR_MIN __FC_SCHAR_MIN # define SCHAR_MAX __FC_SCHAR_MAX /* Maximum value an `unsigned char' can hold. (Minimum is 0.) */ # define UCHAR_MAX __FC_UCHAR_MAX /* Minimum and maximum values a `char' can hold. */ # ifdef __CHAR_UNSIGNED__ # define CHAR_MIN 0 # define CHAR_MAX UCHAR_MAX # else # define CHAR_MIN SCHAR_MIN # define CHAR_MAX SCHAR_MAX # endif #define MB_LEN_MAX 16 /* Minimum and maximum values a `signed short int' can hold. */ # define SHRT_MIN __FC_SHRT_MIN # define SHRT_MAX __FC_SHRT_MAX /* Maximum value an `unsigned short int' can hold. (Minimum is 0.) */ # define USHRT_MAX __FC_USHRT_MAX /* Minimum and maximum values a `signed int' can hold. */ # define INT_MIN __FC_INT_MIN # define INT_MAX __FC_INT_MAX /* Maximum value an `unsigned int' can hold. (Minimum is 0.) */ # define UINT_MAX __FC_UINT_MAX /* Minimum and maximum values a `signed long int' can hold. */ # define LONG_MAX __FC_LONG_MAX # define LONG_MIN __FC_LONG_MIN /* Maximum value an `unsigned long int' can hold. (Minimum is 0.) */ #define ULONG_MAX __FC_ULONG_MAX /* Minimum and maximum values a `signed long long int' can hold. */ # define LLONG_MAX __FC_LLONG_MAX # define LLONG_MIN __FC_LLONG_MIN /* Maximum value an `unsigned long long int' can hold. (Minimum is 0.) */ # define ULLONG_MAX __FC_ULLONG_MAX /* Maximum number of bytes in a pathname, including the terminating null character. (Minimum is 256.) */ #define PATH_MAX __FC_PATH_MAX #endif frama-c-Phosphorus-20170501/share/libc/stdio.h0000644000175000017500000002426113113745012017677 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_machdep.h" #include "__fc_string_axiomatic.h" #include "stdarg.h" #include "stddef.h" #include "errno.h" #include "__fc_define_stat.h" #include "__fc_define_fpos_t.h" #include "__fc_define_file.h" #include "__fc_define_null.h" #include "__fc_define_eof.h" #define _IOFBF 0 #define _IOLBF 1 #define _IONBF 2 #define BUFSIZ __FC_BUFSIZ #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 __BEGIN_DECLS extern FILE * __fc_stderr; #define stderr (__fc_stderr) extern FILE * __fc_stdin; #define stdin (__fc_stdin) extern FILE * __fc_stdout; #define stdout (__fc_stdout) /* Note: currently some functions only consider the __fc_FILE_id field of FILE. This models the fact that operations on different files are considered non-interferent between them. */ /*@ assigns \nothing; */ extern int remove(const char *filename); /*@ assigns \nothing; */ extern int rename(const char *old_name, const char *new_name); /*@ assigns \nothing; ensures \result==\null || (\valid(\result) && \fresh(\result,sizeof(FILE))) ; */ extern FILE *tmpfile(void); /*@ assigns \result \from s[..]; assigns s[..] \from \nothing; // TODO: more precise behaviors from ISO C 7.19.4.4 */ extern char *tmpnam(char *s); /*@ requires \valid(stream); assigns \result \from stream, stream->__fc_FILE_id; ensures \result == 0 || \result == EOF; // TODO: more precise behaviors from ISO C 7.19.4.1 */ extern int fclose(FILE *stream); /*@ requires stream == \null || \valid_read(stream); assigns \result \from stream, stream->__fc_FILE_id; ensures \result == 0 || \result == EOF; // TODO: more precise behaviors from ISO C 7.19.5.2 */ extern int fflush(FILE *stream); FILE __fc_fopen[__FC_FOPEN_MAX]; FILE* const __fc_p_fopen = __fc_fopen; /*@ assigns \result \from filename[..],mode[..], __fc_p_fopen; ensures \result==\null || (\subset(\result,&__fc_fopen[0 .. __FC_FOPEN_MAX-1])) ; */ extern FILE *fopen(const char * restrict filename, const char * restrict mode); /*@ assigns \result \from fildes,mode[..]; ensures \result==\null || (\valid(\result) && \fresh(\result,sizeof(FILE))); */ extern FILE *fdopen(int fildes, const char *mode); /*@ assigns *stream; ensures \result==\null || \result==stream ; */ extern FILE *freopen(const char * restrict filename, const char * restrict mode, FILE * restrict stream); /*@ assigns *stream \from buf; */ extern void setbuf(FILE * restrict stream, char * restrict buf); /*@ assigns *stream \from buf,mode,size; */ extern int setvbuf(FILE * restrict stream, char * restrict buf, int mode, size_t size); // Direct specifications for variadic functions are unsupported; // use the Variadic plug-in instead. extern int fprintf(FILE * restrict stream, const char * restrict format, ...); extern int fscanf(FILE * restrict stream, const char * restrict format, ...); extern int printf(const char * restrict format, ...); extern int scanf(const char * restrict format, ...); extern int snprintf(char * restrict s, size_t n, const char * restrict format, ...); extern int sprintf(char * restrict s, const char * restrict format, ...); extern int sscanf(const char * restrict s, const char * restrict format, ...); /*@ assigns *stream \from format[..], arg; */ extern int vfprintf(FILE * restrict stream, const char * restrict format, va_list arg); /*@ assigns *stream \from format[..], *stream; // TODO: assign arg too. */ extern int vfscanf(FILE * restrict stream, const char * restrict format, va_list arg); /*@ assigns *__fc_stdout \from arg; */ extern int vprintf(const char * restrict format, va_list arg); /*@ assigns *__fc_stdin \from format[..]; // TODO: assign arg too. */ extern int vscanf(const char * restrict format, va_list arg); /*@ assigns s[0..n-1] \from format[..], arg; */ extern int vsnprintf(char * restrict s, size_t n, const char * restrict format, va_list arg); /*@ assigns s[0..] \from format[..], arg; */ extern int vsprintf(char * restrict s, const char * restrict format, va_list arg); /* TODO: assigns arg ; */ extern int vsscanf(const char * restrict s, const char * restrict format, va_list arg); /*@ assigns *stream; */ extern int fgetc(FILE *stream); /*@ assigns s[0..n-1],*stream \from *stream; assigns \result \from s,n,*stream; ensures \result == \null || \result==s; */ extern char *fgets(char * restrict s, int n, FILE * restrict stream); /*@ assigns *stream ; */ extern int fputc(int c, FILE *stream); /*@ assigns *stream \from s[..]; */ extern int fputs(const char * restrict s, FILE * restrict stream); /*@ assigns \result,*stream \from *stream; */ extern int getc(FILE *stream); /*@ assigns \result \from *__fc_stdin ; */ extern int getchar(void); /*@ assigns s[..] \from *__fc_stdin ; assigns \result \from s, __fc_stdin; ensures \result == s || \result == \null; */ extern char *gets(char *s); /*@ assigns *stream \from c; */ extern int putc(int c, FILE *stream); /*@ assigns *__fc_stdout \from c; */ extern int putchar(int c); /*@ assigns *__fc_stdout \from s[..]; */ extern int puts(const char *s); /*@ assigns *stream \from c; */ extern int ungetc(int c, FILE *stream); /*@ requires \valid(((char*)ptr)+(0..(nmemb*size)-1)); requires \valid(stream); assigns *(((char*)ptr)+(0..(nmemb*size)-1)) \from size, nmemb, *stream; assigns \result \from size, *stream; ensures \result <= nmemb; ensures \initialized(((char*)ptr)+(0..(\result*size)-1)); //TODO: specify precise fields from struct FILE */ extern size_t fread(void * restrict ptr, size_t size, size_t nmemb, FILE * restrict stream); /*@ requires \valid_read(((char*)ptr)+(0..(nmemb*size)-1)); requires \valid(stream); assigns *stream, \result \from *(((char*)ptr)+(0..(nmemb*size)-1)); ensures \result <= nmemb; //TODO: specify precise fields from struct FILE */ extern size_t fwrite(const void * restrict ptr, size_t size, size_t nmemb, FILE * restrict stream); /*@ assigns *pos \from *stream ; */ extern int fgetpos(FILE * restrict stream, fpos_t * restrict pos); /*@ requires \valid(stream); requires whence == SEEK_SET || whence == SEEK_CUR || whence == SEEK_END; assigns *stream \from *stream, indirect:offset, indirect:whence; assigns \result, __fc_errno \from indirect:*stream, indirect:offset, indirect:whence; */ extern int fseek(FILE *stream, long int offset, int whence); /*@ assigns *stream \from *pos; */ extern int fsetpos(FILE *stream, const fpos_t *pos); /*@ assigns \result, __fc_errno \from *stream ;*/ extern long int ftell(FILE *stream); /*@ assigns *stream \from \nothing; */ extern void rewind(FILE *stream); /*@ assigns *stream \from \nothing; */ extern void clearerr(FILE *stream); /*@ assigns \result \from *stream ;*/ extern int feof(FILE *stream); /*@ assigns \result \from *stream ;*/ extern int fileno(FILE *stream); /*@ assigns *stream \from \nothing ;*/ extern void flockfile(FILE *stream); /*@ assigns *stream \from \nothing ;*/ extern void funlockfile(FILE *stream); /*@ assigns \result,*stream \from \nothing ;*/ extern int ftrylockfile(FILE *stream); /*@ assigns \result \from *stream ;*/ extern int ferror(FILE *stream); /*@ assigns __fc_stdout \from __fc_errno, s[..]; */ extern void perror(const char *s); /*@ assigns \result,*stream \from *stream; */ extern int getc_unlocked(FILE *stream); /*@ assigns \result \from *__fc_stdin ; */ extern int getchar_unlocked(void); /*@ assigns *stream \from c; */ extern int putc_unlocked(int c, FILE *stream); /*@ assigns *__fc_stdout \from c; */ extern int putchar_unlocked(int c); /*@ assigns *stream \from \nothing; */ extern void clearerr_unlocked(FILE *stream); /*@ assigns \result \from *stream ;*/ extern int feof_unlocked(FILE *stream); /*@ assigns \result \from *stream ;*/ extern int ferror_unlocked(FILE *stream); /*@ assigns \result \from *stream ;*/ extern int fileno_unlocked(FILE *stream); extern int fflush_unlocked(FILE *stream); extern int fgetc_unlocked(FILE *stream); extern int fputc_unlocked(int c, FILE *stream); extern size_t fread_unlocked(void *ptr, size_t size, size_t n, FILE *stream); extern size_t fwrite_unlocked(const void *ptr, size_t size, size_t n, FILE *stream); extern char *fgets_unlocked(char *s, int n, FILE *stream); extern int fputs_unlocked(const char *s, FILE *stream); __END_DECLS #define IOV_MAX 1024 __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/__fc_define_id_t.h0000644000175000017500000000337313113745002021754 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB __BEGIN_DECLS typedef unsigned int id_t; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/endian.h0000644000175000017500000000513513113745002020011 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 _ENDIAN_H #define _ENDIAN_H 1 #define __LITTLE_ENDIAN 1234 #define __BIG_ENDIAN 4321 #include "__fc_machdep.h" #define __BYTE_ORDER __FC_BYTE_ORDER #endif /* endian.h */ frama-c-Phosphorus-20170501/share/libc/__fc_define_fd_set_t.h0000644000175000017500000000412313113745012022617 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB __BEGIN_DECLS typedef struct {char __fc_fd_set;} fd_set; //@ assigns *fdset \from *fdset, fd; extern void FD_CLR(int fd, fd_set *fdset); //@ assigns \nothing ; extern int FD_ISSET(int fd, fd_set *fdset); //@ assigns *fdset \from *fdset, fd; extern void FD_SET(int fd, fd_set *fdset); //@ assigns *fdset \from \nothing; extern void FD_ZERO(fd_set *fdset); __END_DECLS #define FD_SETSIZE 255 __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/__fc_define_stat.h0000644000175000017500000000522713113745001022007 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #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 __BEGIN_DECLS 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; }; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/__fc_define_ino_t.h0000644000175000017500000000337613113745005022153 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB __BEGIN_DECLS typedef unsigned int ino_t; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/setjmp.h0000644000175000017500000000450513113745006020061 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB __BEGIN_DECLS /* Note: setjmp/longjmp/sigsetjmp/siglongjmp are currently unsupported by Frama-C and should not be used. */ typedef int jmp_buf[5]; // arbitrary size /*@ assigns env[0..4]; // unsound - should "assigns \anything" */ extern int setjmp(jmp_buf env); /*@ assigns \nothing; ensures \false; // never terminates */ extern void longjmp(jmp_buf env, int val); #include "__fc_define_sigset_t.h" typedef struct {jmp_buf buf; sigset_t sigs;} sigjmp_buf; extern int sigsetjmp(sigjmp_buf env, int savesigs); /*@ assigns \nothing; ensures \false; // never terminates */ extern void siglongjmp(sigjmp_buf env, int val); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/ctype.h0000644000175000017500000001745713113745007017716 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB #include "__fc_define_eof.h" /* ISO C : 7.4.1 */ __BEGIN_DECLS /* Functions which have no complete behaviors are either due to locale-dependent characters, or under-specification by the C standard. */ /* Note: most functions use '\result < 0 || \result > 0' instead of of '\result != 0' for better precision if there is enough slevel. */ /*@ requires 0 <= c <= 255 || c == EOF; assigns \result \from c; behavior definitely_not_match: assumes c == EOF || 0 <= c <= 47 || 58 <= c <= 64 || 91 <= c <= 96 || 123 <= c <= 127; ensures \result == 0; behavior definitely_match: assumes 'A' <= c <= 'Z' || 'a' <= c <= 'z' || '0' <= c <= '9'; ensures \result < 0 || \result > 0; disjoint behaviors definitely_match, definitely_not_match; */ extern int isalnum(int c); /*@ requires 0 <= c <= 255 || c == EOF; assigns \result \from c; behavior definitely_not_match: assumes c == EOF || 0 <= c <= 64 || 91 <= c <= 96 || 123 <= c <= 127; ensures \result == 0; behavior definitely_match: assumes 'A' <= c <= 'Z' || 'a' <= c <= 'z'; ensures \result < 0 || \result > 0; disjoint behaviors definitely_match, definitely_not_match; */ extern int isalpha(int c); /*@ requires 0 <= c <= 255 || c == EOF; assigns \result \from c; behavior match: assumes c == ' ' || c == '\t'; ensures \result < 0 || \result > 0; behavior no_match: assumes c != ' ' && c != '\t'; ensures \result == 0; disjoint behaviors match, no_match; complete behaviors match, no_match; */ extern int isblank(int c); /*@ requires 0 <= c <= 255 || c == EOF; assigns \result \from c; behavior definitely_match: assumes 0 <= c <= 31 || c == 127; ensures \result < 0 || \result > 0; behavior definitely_not_match: assumes c == EOF || 32 <= c <= 126; ensures \result == 0; disjoint behaviors definitely_match, definitely_not_match; */ extern int iscntrl(int c); /*@ requires 0 <= c <= 255 || c == EOF; assigns \result \from c; behavior match: assumes '0' <= c <= '9'; ensures \result < 0 || \result > 0; behavior no_match: assumes c < '0' || c > '9'; ensures \result == 0; disjoint behaviors match, no_match; complete behaviors match, no_match; */ extern int isdigit(int c); /*@ requires 0 <= c <= 255 || c == EOF; assigns \result \from c; behavior definitely_match: assumes 33 <= c <= 126; ensures \result < 0 || \result > 0; behavior definitely_not_match: assumes c == EOF || 0 <= c <= 32 || c == 127; ensures \result == 0; disjoint behaviors definitely_match, definitely_not_match; */ extern int isgraph(int c); /*@ requires 0 <= c <= 255 || c == EOF; assigns \result \from c; behavior definitely_match: assumes 'a' <= c <= 'z'; ensures \result < 0 || \result > 0; behavior definitely_not_match: assumes c == EOF || 0 <= c < 'a' || 'z' < c < 127; ensures \result == 0; disjoint behaviors definitely_match, definitely_not_match; */ extern int islower(int c); /*@ requires 0 <= c <= 255 || c == EOF; assigns \result \from c; behavior definitely_match: assumes 32 <= c <= 126; ensures \result < 0 || \result > 0; behavior definitely_not_match: assumes c == EOF || 0 <= c <= 31 || c == 127; ensures \result == 0; disjoint behaviors definitely_match, definitely_not_match; */ extern int isprint(int c); /*@ requires 0 <= c <= 255 || c == EOF; assigns \result \from c; behavior definitely_match: assumes 33 <= c <= 47 || 58 <= c <= 64 || 91 <= c <= 96 || 123 <= c <= 126; ensures \result < 0 || \result > 0; behavior definitely_not_match: assumes c == EOF || 0 <= c <= 32 || 48 <= c <= 57 || 65 <= c <= 90 || 97 <= c <= 122 || c == 127; ensures \result == 0; disjoint behaviors definitely_match, definitely_not_match; */ extern int ispunct(int c); /*@ requires 0 <= c <= 255 || c == EOF; assigns \result \from c; behavior definitely_match: assumes 9 <= c <= 13 || c == ' '; ensures \result < 0 || \result > 0; behavior definitely_not_match: assumes c == EOF || 0 <= c <= 8 || 14 <= c < ' ' || ' ' < c <= 127; ensures \result == 0; disjoint behaviors definitely_match, definitely_not_match; */ extern int isspace(int c); /*@ requires 0 <= c <= 255 || c == EOF; assigns \result \from c; behavior definitely_match: assumes 'A' <= c <= 'Z'; ensures \result < 0 || \result > 0; behavior definitely_not_match: assumes c == EOF || 0 <= c < 'A' || 'Z' < c <= 127; ensures \result == 0; disjoint behaviors definitely_match, definitely_not_match; */ extern int isupper(int c); /*@ requires 0 <= c <= 255 || c == EOF; assigns \result \from c; behavior match: assumes '0' <= c <= '9' || 'A' <= c <= 'F' || 'a' <= c <= 'f'; ensures \result < 0 || \result > 0; behavior no_match: assumes !('0' <= c <= '9' || 'A' <= c <= 'F' || 'a' <= c <= 'f'); ensures \result == 0; disjoint behaviors match, no_match; complete behaviors match, no_match; */ extern int isxdigit(int c); /* ISO C : 7.4.2 */ /*@ requires 0 <= c <= 255 || c == EOF; assigns \result \from c; ensures 0 <= \result <= 255 || \result == EOF; behavior definitely_changed: assumes 'A' <= c <= 'Z'; ensures \result == c + 32; behavior definitely_not_changed: assumes c == EOF || 0 <= c < 'A' || 'Z' < c <= 127; ensures \result == c; disjoint behaviors definitely_changed, definitely_not_changed; */ extern int tolower(int c); /*@ requires 0 <= c <= 255 || c == EOF; assigns \result \from c; ensures 0 <= \result <= 255 || \result == EOF; behavior definitely_changed: assumes 'a' <= c <= 'z'; ensures \result == c - 32; behavior definitely_not_changed: assumes c == EOF || 0 <= c < 'a' || 'z' < c <= 127; ensures \result == c; disjoint behaviors definitely_changed, definitely_not_changed; */ extern int toupper(int c); /* POSIX */ /*@ requires 0 <= c <= 255 || c == EOF; assigns \result \from c; behavior match: assumes 0 <= c <= 127; ensures \result < 0 || \result > 0; behavior no_match: assumes !(0 <= c <= 127); ensures \result == 0; disjoint behaviors match, no_match; complete behaviors match, no_match; */ extern int isascii(int c); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/__fc_define_blksize_t.h0000644000175000017500000000341213113745012023016 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB __BEGIN_DECLS typedef unsigned int blksize_t; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/uchar.h0000644000175000017500000000322513113745012017654 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/__fc_machdep_linux_gcc_shared.h0000644000175000017500000001640313113745010024502 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "Frama-C: This file shall not be directly included" #endif /* This file contains common machine specific values between Linux/GCC x86 32-bit, AMD64 and x86 16-bit.*/ #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 /* 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_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_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 #define __FC_PATH_MAX 256 /* for stdarg.h */ #define __FC_VA_LIST_T __builtin_va_list /* 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_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 // 7.25 mandates that WINT_T can handle at least one character in addition // to those that are in the extended character set (to account for EOF) #define __WINT_T long long int /* 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 #define __FC_EOWNERDEAD 165 #define __FC_ENOTRECOVERABLE 166 /* sys/un.h */ #define __FC_SOCKADDR_SUN_SUN_PATH 108 /* time.h */ #define __FC_TIME_T long #endif frama-c-Phosphorus-20170501/share/libc/stdlib.h0000644000175000017500000004304713113745010020037 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_define_size_t.h" #include "__fc_define_wchar_t.h" __BEGIN_DECLS 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 /*@ requires \valid_read(nptr); // cannot be precise, valid_read_string too strong assigns \result \from indirect:nptr, indirect:nptr[0 ..]; */ extern double atof(const char *nptr); /*@ requires \valid_read(nptr); // cannot be precise, valid_read_string too strong assigns \result \from indirect:nptr, indirect:nptr[0 ..]; */ extern int atoi(const char *nptr); /*@ requires \valid_read(nptr); // cannot be precise, valid_read_string too strong assigns \result \from indirect:nptr, indirect:nptr[0 ..]; */ extern long int atol(const char *nptr); /*@ requires \valid_read(nptr); // cannot be precise, valid_read_string too strong assigns \result \from indirect:nptr, indirect:nptr[0 ..]; */ extern long long int atoll(const char *nptr); /* See ISO C: 7.20.1.3 to complete these specifications */ /*@ requires \valid_read(nptr); // cannot be precise, valid_read_string too strong requires \separated(nptr, endptr); assigns \result \from indirect:nptr, indirect:nptr[0 ..]; assigns *endptr \from nptr, indirect:nptr[0 ..], indirect:endptr; behavior null_endptr: assumes endptr == \null; assigns \result \from indirect:nptr, indirect:nptr[0 ..]; behavior nonnull_endptr: assumes endptr != \null; requires \valid(endptr); assigns \result \from indirect:nptr, indirect:nptr[0 ..]; assigns *endptr \from nptr, indirect:nptr[0 ..], indirect:endptr; ensures \initialized(endptr); ensures \subset(*endptr, nptr + (0 ..)); complete behaviors; disjoint behaviors; */ extern double strtod(const char * restrict nptr, char ** restrict endptr); /*@ requires \valid_read(nptr); // cannot be precise, valid_read_string too strong requires \separated(nptr, endptr); assigns \result \from indirect:nptr, indirect:nptr[0 ..]; assigns *endptr \from nptr, indirect:nptr[0 ..], indirect:endptr; behavior null_endptr: assumes endptr == \null; assigns \result \from indirect:nptr, indirect:nptr[0 ..]; behavior nonnull_endptr: assumes endptr != \null; requires \valid(endptr); assigns \result \from indirect:nptr, indirect:nptr[0 ..]; assigns *endptr \from nptr, indirect:nptr[0 ..], indirect:endptr; ensures \initialized(endptr); ensures \valid_read(endptr); ensures \subset(*endptr, nptr + (0 ..)); complete behaviors; disjoint behaviors; */ extern float strtof(const char * restrict nptr, char ** restrict endptr); /*@ requires \valid_read(nptr); // cannot be precise, valid_read_string too strong requires \separated(nptr, endptr); assigns \result \from indirect:nptr, indirect:nptr[0 ..]; assigns *endptr \from nptr, indirect:nptr[0 ..], indirect:endptr; behavior null_endptr: assumes endptr == \null; assigns \result \from indirect:nptr, indirect:nptr[0 ..]; behavior nonnull_endptr: assumes endptr != \null; requires \valid(endptr); assigns \result \from indirect:nptr, indirect:nptr[0 ..]; assigns *endptr \from nptr, indirect:nptr[0 ..], indirect:endptr; ensures \initialized(endptr); ensures \valid_read(endptr); ensures \subset(*endptr, nptr + (0 ..)); complete behaviors; disjoint behaviors; */ extern long double strtold(const char * restrict nptr, char ** restrict endptr); /* TODO: See ISO C 7.20.1.4 to complete these specifications */ /*@ requires \valid_read(nptr); // cannot be precise, valid_read_string too strong requires \separated(nptr, endptr); requires base == 0 || 2 <= base <= 36; assigns \result \from indirect:nptr, indirect:nptr[0 ..], indirect:base; assigns *endptr \from nptr, indirect:nptr[0 ..], indirect:endptr, indirect:base; behavior null_endptr: assumes endptr == \null; assigns \result \from indirect:nptr, indirect:nptr[0 ..], indirect:base; behavior nonnull_endptr: assumes endptr != \null; requires \valid(endptr); assigns \result \from indirect:nptr, indirect:nptr[0 ..], indirect:base; assigns *endptr \from nptr, indirect:nptr[0 ..], indirect:endptr, indirect:base; ensures \initialized(endptr); ensures \valid_read(endptr); ensures \subset(*endptr, nptr + (0 ..)); complete behaviors; disjoint behaviors; */ extern long int strtol( const char * restrict nptr, char ** restrict endptr, int base); /*@ requires \valid_read(nptr); // cannot be precise, valid_read_string too strong requires \separated(nptr, endptr); requires base == 0 || 2 <= base <= 36; assigns \result \from indirect:nptr, indirect:nptr[0 ..], indirect:base; assigns *endptr \from nptr, indirect:nptr[0 ..], indirect:endptr, indirect:base; behavior null_endptr: assumes endptr == \null; assigns \result \from indirect:nptr, indirect:nptr[0 ..], indirect:base; behavior nonnull_endptr: assumes endptr != \null; requires \valid(endptr); assigns \result \from indirect:nptr, indirect:nptr[0 ..], indirect:base; assigns *endptr \from nptr, indirect:nptr[0 ..], indirect:endptr, indirect:base; ensures \initialized(endptr); ensures \valid_read(endptr); ensures \subset(*endptr, nptr + (0 ..)); complete behaviors; disjoint behaviors; */ extern long long int strtoll( const char * restrict nptr, char ** restrict endptr, int base); /*@ requires \valid_read(nptr); // cannot be precise, valid_read_string too strong requires \separated(nptr, endptr); requires base == 0 || 2 <= base <= 36; assigns \result \from indirect:nptr, indirect:nptr[0 ..], indirect:base; assigns *endptr \from nptr, indirect:nptr[0 ..], indirect:endptr, indirect:base; behavior null_endptr: assumes endptr == \null; assigns \result \from indirect:nptr, indirect:nptr[0 ..], indirect:base; behavior nonnull_endptr: assumes endptr != \null; requires \valid(endptr); assigns \result \from indirect:nptr, indirect:nptr[0 ..], indirect:base; assigns *endptr \from nptr, indirect:nptr[0 ..], indirect:endptr, indirect:base; ensures \initialized(endptr); ensures \valid_read(endptr); ensures \subset(*endptr, nptr + (0 ..)); complete behaviors; disjoint behaviors; */ extern unsigned long int strtoul( const char * restrict nptr, char ** restrict endptr, int base); /*@ requires \valid_read(nptr); // cannot be precise, valid_read_string too strong requires \separated(nptr, endptr); requires base == 0 || 2 <= base <= 36; assigns \result \from indirect:nptr, indirect:nptr[0 ..], indirect:base; assigns *endptr \from nptr, indirect:nptr[0 ..], indirect:endptr, indirect:base; behavior null_endptr: assumes endptr == \null; assigns \result \from indirect:nptr, indirect:nptr[0 ..], indirect:base; behavior nonnull_endptr: assumes endptr != \null; requires \valid(endptr); assigns \result \from indirect:nptr, indirect:nptr[0 ..], indirect:base; assigns *endptr \from nptr, indirect:nptr[0 ..], indirect:endptr, indirect:base; ensures \initialized(endptr); ensures \valid_read(endptr); ensures \subset(*endptr, nptr + (0 ..)); complete behaviors; disjoint behaviors; */ extern unsigned long long int strtoull( const char * restrict nptr, char ** restrict endptr, int base); //@ ghost int __fc_random_counter __attribute__((unused)) __attribute__((FRAMA_C_MODEL)); const unsigned long __fc_rand_max = __FC_RAND_MAX; /* ISO C: 7.20.2 */ /*@ assigns \result \from __fc_random_counter ; @ assigns __fc_random_counter \from __fc_random_counter ; @ ensures 0 <= \result <= __fc_rand_max ; */ extern int rand(void); #ifdef _POSIX_C_SOURCE # if _POSIX_C_SOURCE >= 200112L /*@ assigns \result \from __fc_random_counter ; @ assigns __fc_random_counter \from __fc_random_counter ; @ ensures 0 <= \result < 2147483648 ; */ extern long int lrand48 (void); /*@ assigns __fc_random_counter \from seed ; */ extern void srand48 (long int seed); # endif #endif /*@ assigns __fc_random_counter \from seed ; */ extern void srand(unsigned int seed); /*@ ghost extern int __fc_heap_status __attribute__((FRAMA_C_MODEL)); */ /*@ axiomatic dynamic_allocation { @ predicate is_allocable{L}(integer n) // Can a block of n bytes be allocated? @ reads __fc_heap_status; @ // The logic label L is not used, but it must be present because the @ // predicate depends on the memory state @ axiom never_allocable{L}: @ \forall integer i; @ i < 0 || i > __FC_SIZE_MAX ==> !is_allocable(i); @ } */ /* ISO C: 7.20.3.1 */ /*@ allocates \result; assigns __fc_heap_status \from indirect:nmemb, indirect:size, __fc_heap_status; assigns \result \from indirect:nmemb, indirect:size, indirect:__fc_heap_status; behavior allocation: assumes is_allocable(nmemb * size); ensures \fresh(\result, nmemb * size); ensures \initialized(((char *)\result)+(0..nmemb*size-1)); ensures \subset(((char *)\result)[0..nmemb*size-1], {0}); behavior no_allocation: assumes !is_allocable(nmemb * size); assigns \result \from \nothing; allocates \nothing; ensures \result == \null; complete behaviors; disjoint behaviors; */ extern void *calloc(size_t nmemb, size_t size); /*@ allocates \result; @ assigns __fc_heap_status \from size, __fc_heap_status; @ assigns \result \from indirect:size, indirect:__fc_heap_status; @ behavior allocation: @ assumes is_allocable(size); @ assigns __fc_heap_status \from size, __fc_heap_status; @ assigns \result \from indirect:size, indirect:__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; @*/ extern void *malloc(size_t size); /*@ frees p; @ assigns __fc_heap_status \from __fc_heap_status; @ behavior deallocation: @ assumes p!=\null; @ requires freeable:\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; @*/ extern void free(void *p); /*@ requires ptr == \null || \freeable(ptr); allocates \result; frees ptr; assigns __fc_heap_status \from __fc_heap_status; assigns \result \from size, ptr, __fc_heap_status; behavior alloc: assumes is_allocable(size); allocates \result; assigns \result \from size, __fc_heap_status; ensures \fresh(\result,size); behavior dealloc: assumes ptr != \null; assumes is_allocable(size); requires \freeable(ptr); frees ptr; ensures \allocable(ptr); ensures \result == \null || \freeable(\result); behavior fail: assumes !is_allocable(size); allocates \nothing; frees \nothing; assigns \result \from size, __fc_heap_status; ensures \result == \null; complete behaviors; disjoint behaviors alloc, fail; disjoint behaviors dealloc, fail; */ extern void *realloc(void *ptr, size_t size); /* ISO C: 7.20.4 */ /*@ assigns \nothing; @ ensures \false; */ extern void abort(void); /*@ assigns \result \from \nothing ;*/ extern int atexit(void (*func)(void)); /*@ assigns \result \from \nothing ;*/ extern int at_quick_exit(void (*func)(void)); /*@ assigns \nothing; ensures \false; */ extern void exit(int status) __attribute__ ((noreturn)); /*@ assigns \nothing; ensures \false; */ extern void _Exit(int status) __attribute__ ((__noreturn__)); /*@ requires \valid_read(name); assigns \result \from indirect:name, name[0 ..]; ensures \result == \null || \valid(\result); */ extern char *getenv(const char *name); extern int putenv(char *string); extern int setenv(const char *name, const char *value, int overwrite); extern int unsetenv(const char *name); /*@ assigns \nothing; ensures \false; */ extern void quick_exit(int status) __attribute__ ((__noreturn__)); /*@ requires \valid_read(command); assigns \result \from indirect:command, indirect:command[0 ..]; */ extern int system(const char *command); /* ISO C: 7.20.5 */ /* TODO: use one of the well known specification with high order compare :-) */ // NOTE: the assigns of function [compar] are not currently taken into account // by ACSL. If [compar] is not purely functional, the result may be unsound. /*@ requires \valid_function(compar); assigns ((char*)\result)[0 ..] \from indirect:key, ((char*)key)[0 ..], indirect:base, ((char*)base)[0 ..], indirect:nmemb, indirect:size, indirect:compar, indirect:*compar; */ extern void *bsearch(const void *key, const void *base, size_t nmemb, size_t size, int (*compar)(const void *, const void *)); // NOTE: the assigns of function [compar] are not currently taken into account // by ACSL. If [compar] is not purely functional, the result may be unsound. /*@ requires \valid_function(compar); assigns ((char*)base)[0 ..] \from indirect:base, ((char*)base)[0 ..], indirect:nmemb, indirect:size, indirect:compar, indirect:*compar; */ extern void qsort(void *base, size_t nmemb, size_t size, int (*compar)(const void *, const void *)); /* ISO C: 7.20.6 */ /*@ requires abs_representable:(int)(-j) == -j ; assigns \result \from j ; */ extern int abs(int j); /*@ requires abs_representable:(long)(-j) == -j ; assigns \result \from j ; */ extern long int labs(long int j); /*@ requires abs_representable:(long long)(-j) == -j ; assigns \result \from j ; */ extern long long int llabs(long long int j); /*@ assigns \result \from numer,denom ; */ extern div_t div(int numer, int denom); /*@ assigns \result \from numer,denom ; */ extern ldiv_t ldiv(long int numer, long int denom); /*@ assigns \result \from numer,denom ; */ extern lldiv_t lldiv(long long int numer, long long int denom); /* ISO C: 7.20.7 */ //@ ghost int __fc_mblen_state; /*@ assigns \result, __fc_mblen_state \from indirect:s, indirect:s[0 ..], indirect:n, __fc_mblen_state; */ extern int mblen(const char *s, size_t n); //@ ghost int __fc_mbtowc_state; /*@ requires \separated(pwc, s); assigns \result \from indirect:s, indirect:s[0 .. n-1], indirect:n, __fc_mbtowc_state; assigns pwc[0 .. \result-1], __fc_mbtowc_state \from indirect:s, s[0 .. n-1], indirect:n, __fc_mbtowc_state; ensures \result <= n; */ extern int mbtowc(wchar_t * restrict pwc, const char * restrict s, size_t n); //@ ghost int __fc_wctomb_state; /*@ assigns \result \from indirect:wc, __fc_wctomb_state; assigns s[0 ..], __fc_wctomb_state \from wc, __fc_wctomb_state; */ extern int wctomb(char *s, wchar_t wc); /* ISO C: 7.20.8 */ /*@ requires \separated(pwcs, s); assigns \result \from indirect:s, indirect:s[0 .. n-1], indirect:n; assigns pwcs[0 .. n-1] \from indirect:s, s[0 .. n-1], indirect:n; */ extern size_t mbstowcs(wchar_t * restrict pwcs, const char * restrict s, size_t n); /*@ requires \separated(s, pwcs); assigns \result \from indirect:pwcs, indirect:pwcs[0 .. n-1], indirect:n; assigns s[0 .. n-1] \from indirect:pwcs, pwcs[0 .. n-1], indirect:n; */ extern size_t wcstombs(char * restrict s, const wchar_t * restrict pwcs, size_t n); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/string.c0000644000175000017500000001623413113745012020057 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include // for uintptr_t #include // for malloc() __PUSH_FC_STDLIB void* memcpy(void* restrict dest, const void* restrict src, size_t n) { char* res = (char*)dest; for (size_t i = 0; i < n; i++) { ((char*)dest)[i] = ((char*)src)[i]; } return res; } // memoverlap: auxiliary function that returns // 0 if p[0..n-1] and q[0..n-1] do not overlap; // -1/+1 otherwise, according to whether p is before or after q in the memory /*@ assigns \result \from indirect:p, indirect:q, indirect:n; behavior separated: assumes \separated(p + (0 .. n-1), q + (0 .. n-1)); ensures \result == 0; behavior not_separated_lt: assumes !\separated(p + (0 .. n-1), q + (0 .. n-1)); assumes p <= q < p + n; ensures \result == -1; behavior not_separated_gt: assumes !\separated(p + (0 .. n-1), q + (0 .. n-1)); assumes q < p <= q + n; ensures \result == 1; complete behaviors; disjoint behaviors; */ static int memoverlap(char const *p, char const *q, size_t n); void* memmove(void* dest, const void* src, size_t n) { if (n == 0) return dest; char *s = (char*)src; if (memoverlap(dest, src, n) <= 0) { /* default: copy up (use memcpy) */ return memcpy(dest, src, n); } else { // beginning of dest overlaps with src: copy down char *d = (char*)dest; // to avoid unsigned overflow in the loop below, the '0' case is // done outside the loop (note: n == 0 has already been tested) for (size_t i = n-1; i > 0; i--) d[i] = s[i]; d[0] = s[0]; return dest; } } size_t strlen(const char *s) { size_t i; for (i = 0; s[i] != 0; i++); return i; } void* memset (void* s, int c, size_t n) { unsigned char *p = (unsigned char*)s; for (size_t i = 0; i < n; i++) { p[i] = c; } return s; } int strcmp(const char *s1, const char *s2) { size_t i; for (i = 0; s1[i] == s2[i]; i++) { if (s1[i] == 0) return 0; } return (((unsigned char *)s1)[i] - ((unsigned char *)s2)[i]); } int strncmp(const char *s1, const char *s2, size_t n) { for (size_t i = 0; i < n; i++) { if (s1[i] != s2[i]) return ((unsigned char *)s1)[i] - ((unsigned char *)s2)[i]; /* stop comparison when strings end */ if (s1[i] == 0) return 0; } return 0; } int memcmp(const void *s1, const void *s2, size_t n) { const unsigned char *p1, *p2; p1 = (const unsigned char *)s1; p2 = (const unsigned char *)s2; for (size_t i = 0; i < n; i++) if (p1[i] != p2[i]) return p1[i] - p2[i]; return 0; } // NOTE: strcasecmp is in POSIX's strings.h but not in C99 // auxiliary function for strcasecmp static int char_equal_ignore_case(char c1, char c2) { if (c1 >= 'A' && c1 <= 'Z') c1 -= ('A' - 'a'); if (c2 >= 'A' && c2 <= 'Z') c2 -= ('A' - 'a'); if (c1 == c2) return 0; else return (int) ((unsigned char)c2 - (unsigned char)c1); } int strcasecmp(const char *s1, const char *s2) { size_t i; for (i = 0; s1[i] != 0 && s2[i] != 0; i++) { int res = char_equal_ignore_case(s1[i], s2[i]); if (res != 0) return res; } if (s1[i] == 0 && s2[i] == 0) return 0; else if (s1[i] == 0) return -1; else return 1; } char* strcat(char *dest, const char *src) { size_t i; size_t n = strlen(dest); for (i = 0; src[i] != 0; i++) { dest[n+i] = src[i]; } dest[n+i] = 0; return dest; } /* From the strncat man page */ char* strncat(char *dest, const char *src, size_t n) { size_t dest_len = strlen(dest); size_t i; for (i = 0; i < n; i++) { if (src[i] == 0) break; dest[dest_len + i] = src[i]; } dest[dest_len + i] = 0; return dest; } char* strcpy(char *dest, const char *src) { size_t i; for (i = 0; src[i] != 0; i++) dest[i] = src[i]; dest[i] = 0; return dest; } char *strncpy(char *dest, const char *src, size_t n) { size_t i; for (i = 0; i < n; i++) { dest[i] = src[i]; if (src[i] == 0) break; } for (; i < n; i++) dest[i] = 0; return dest; } char *strchr(const char *s, int c) { const char ch = c; size_t i; for (i = 0; s[i] != ch; i++) if (s[i] == 0) return NULL; return (char*)&s[i]; } char *strrchr(const char *s, int c) { const char ch = c; for (size_t i = strlen(s)+1; i > 0; i--) if (s[i-1] == ch) return (char *)&s[i-1]; return NULL; } void *memchr(const void *s, int c, size_t n) { const unsigned char ch = c; const unsigned char *ss = (const unsigned char *)s; for (size_t i = 0; i < n; i++) if (ss[i] == ch) return (void *)&ss[i]; return NULL; } void *memrchr(const void *s, int c, size_t n) { const unsigned char ch = c; const unsigned char *ss = (const unsigned char *)s; for (size_t i = n; i > 0; i--) if (ss[i-1] == ch) return (void *)&ss[i-1]; return NULL; } char *strstr(const char *haystack, const char *needle) { // special case: empty string starts everywhere if (needle[0] == 0) return (char*)haystack; for (size_t i = 0; haystack[i] != 0; i++) { size_t j; for (j = 0; haystack[i+j] != 0; j++) { if (haystack[i+j] != needle[j]) break; } if (needle[j] == 0) return (char*)&haystack[i]; } return NULL; } char *strerror(int errnum) { return "strerror message by Frama-C"; } /* Warning: read considerations about malloc() in Frama-C */ char *strdup(const char *s) { size_t l = strlen(s) + 1; char *p = malloc(l); memcpy(p, s, l); return p; } /* Warning: read considerations about malloc() in Frama-C */ char *strndup(const char *s, size_t n) { /* find length up to n bytes */ size_t l; for (l = 0; l < n; l++) { if (s[l] == 0) break; } char *p = malloc(l+1); /* include terminating '\0' */ memcpy(p, s, l); p[l] = 0; return p; } __POP_FC_STDLIB frama-c-Phosphorus-20170501/share/libc/stdbool.h0000644000175000017500000000334013113745007020222 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/netdb.h0000644000175000017500000001352213113745006017652 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "netinet/in.h" #include "sys/socket.h" #include "inttypes.h" __BEGIN_DECLS 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. */ extern void endhostent(void); extern void endnetent(void); extern void endprotoent(void); extern void endservent(void); extern void freeaddrinfo(struct addrinfo *); extern const char *gai_strerror(int); extern int getaddrinfo(const char *restrict, const char *restrict, const struct addrinfo *restrict, struct addrinfo **restrict); extern struct hostent *gethostbyaddr(const void *, socklen_t, int); extern struct hostent *gethostbyname(const char *); extern struct hostent *gethostent(void); extern int getnameinfo(const struct sockaddr *restrict, socklen_t, char *restrict, socklen_t, char *restrict, socklen_t, int); extern struct netent *getnetbyaddr(uint32_t, int); extern struct netent *getnetbyname(const char *); extern struct netent *getnetent(void); extern struct protoent *getprotobyname(const char *); extern struct protoent *getprotobynumber(int); extern struct protoent *getprotoent(void); extern struct servent *getservbyname(const char *, const char *); extern struct servent *getservbyport(int, const char *); extern struct servent *getservent(void); extern void sethostent(int); extern void setnetent(int); extern void setprotoent(int); extern void setservent(int); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/__fc_define_sockaddr.h0000644000175000017500000000362213113745005022627 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_define_sa_family_t.h" __BEGIN_DECLS struct sockaddr { sa_family_t sa_family; /* address family, AF_xxx */ char sa_data[14]; /* 14 bytes of protocol address */ }; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/__fc_define_ssize_t.h0000644000175000017500000000343313113745002022512 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_machdep.h" __BEGIN_DECLS typedef __SSIZE_T ssize_t; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/termios.h0000644000175000017500000001422313113745010020232 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_define_pid_t.h" extern int Frama_C_entropy_source; #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 __BEGIN_DECLS typedef unsigned int tcflag_t; typedef unsigned char cc_t; typedef unsigned int speed_t; __END_DECLS // 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 __BEGIN_DECLS 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 */ }; extern speed_t cfgetispeed(const struct termios *); extern speed_t cfgetospeed(const struct termios *); extern int cfsetispeed(struct termios *, speed_t); extern int cfsetospeed(struct termios *, speed_t); extern int tcdrain(int); extern int tcflow(int, int); extern int tcflush(int, int); /*@ requires \valid(termios_p); assigns \result, *termios_p \from indirect:fd, indirect:Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; behavior ok: assumes Frama_C_entropy_source == 0; // arbitrary condition ensures \initialized(termios_p); ensures \result == 0; behavior error: assumes Frama_C_entropy_source != 0; // arbitrary condition ensures \result == -1; disjoint behaviors ok, error; complete behaviors ok, error; */ extern int tcgetattr(int fd, struct termios *termios_p); extern pid_t tcgetsid(int); extern int tcsendbreak(int, int); /*@ requires \valid(termios_p); assigns *termios_p \from indirect:fd, indirect:optional_actions, indirect:Frama_C_entropy_source, *termios_p; assigns Frama_C_entropy_source \from Frama_C_entropy_source; assigns \result \from indirect:fd, indirect:optional_actions, indirect:Frama_C_entropy_source, indirect:*termios_p; ensures \result == 0 || \result == -1; */ extern int tcsetattr(int fd, int optional_actions, struct termios *termios_p); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/__fc_define_eof.h0000644000175000017500000000341413113745003021603 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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_EOF #define __FC_DEFINE_EOF #include "features.h" __PUSH_FC_STDLIB #include "__fc_machdep.h" __BEGIN_DECLS #define EOF __FC_EOF __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/fc_runtime.c0000644000175000017500000000354113113745012020701 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "__fc_builtin.h" #include "assert.c" #include "ctype.c" #include "errno.c" #include "getopt.c" #include "inttypes.c" #include "locale.c" #include "math.c" #include "stdio.c" #include "stdlib.c" #include "string.c" #include "wchar.c" #include "__fc_builtin.c" frama-c-Phosphorus-20170501/share/libc/__fc_define_uid_and_gid.h0000644000175000017500000000344613113745003023265 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB __BEGIN_DECLS typedef unsigned int gid_t; typedef unsigned int uid_t; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/dirent.h0000644000175000017500000001107713113745013020044 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB #include "errno.h" #include "__fc_define_ino_t.h" #include "__fc_define_off_t.h" __BEGIN_DECLS 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 */ }; typedef struct DIR { unsigned int __fc_dir_id; unsigned int __fc_dir_position; struct stat* __fc_dir_inode; struct dirent ** __fc_dir_entries; } DIR; DIR __fc_opendir[__FC_FOPEN_MAX]; DIR* const __fc_p_opendir = __fc_opendir; extern int alphasort(const struct dirent **, const struct dirent **); /*@ requires \subset(dirp,&__fc_opendir[0 .. __FC_FOPEN_MAX-1]); assigns \result \from dirp, *dirp, __fc_p_opendir; assigns __fc_errno \from dirp, *dirp, __fc_p_opendir; assigns *dirp \from dirp, *dirp, __fc_p_opendir; ensures (\result == 0 && dirp->__fc_dir_inode == \null) || \result == -1; */ extern int closedir(DIR *dirp); extern int dirfd(DIR *); extern DIR *fdopendir(int); /*@ assigns \result \from path[0..], __fc_p_opendir; assigns __fc_errno \from path[0..], __fc_p_opendir; ensures \result == \null || \valid(\result); ensures \result != \null ==> \result == &__fc_opendir[\result->__fc_dir_id]; ensures \result != \null ==> \result->__fc_dir_inode != \null; */ extern DIR *opendir(const char *path); /*@ requires \subset(dirp, &__fc_opendir[0 .. __FC_FOPEN_MAX-1]); assigns \result \from *dirp, __fc_p_opendir; assigns dirp->__fc_dir_position \from dirp->__fc_dir_position; assigns __fc_errno \from dirp, *dirp, __fc_p_opendir; ensures \result == \null || \valid(\result); */ extern struct dirent *readdir(DIR *dirp); extern int readdir_r(DIR * dirp, struct dirent * entry, struct dirent ** result); extern void rewinddir(DIR *); extern int scandir(const char *, struct dirent ***, int (*)(const struct dirent *), int (*)(const struct dirent **, const struct dirent **)); extern void seekdir(DIR *, long); extern 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) __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/__fc_define_dev_t.h0000644000175000017500000000337613113745010022140 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB __BEGIN_DECLS typedef unsigned int dev_t; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/dlfcn.h0000644000175000017500000000367213113745005017650 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB #define RTLD_LAZY 1 #define RTLD_NOW 2 #define RTLD_GLOBAL 3 #define RTLD_LOCAL 4 __BEGIN_DECLS extern void *dlopen(const char *, int); extern void *dlsym(void *, const char *); extern int dlclose(void *); extern char *dlerror(void); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/time.h0000644000175000017500000001030013113745011017477 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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_TIME_H #define __FC_TIME_H #include "features.h" __PUSH_FC_STDLIB #include "__fc_define_null.h" #include "__fc_define_size_t.h" /* * Names of the interval timers, and structure * defining a timer setting: */ #define ITIMER_REAL 0 #define ITIMER_VIRTUAL 1 #define ITIMER_PROF 2 __BEGIN_DECLS typedef unsigned int clock_t; #include "__fc_define_time_t.h" #define CLOCKS_PER_SEC ((time_t)16000) struct tm { int tm_sec; // seconds after the minute [0, 60] int tm_min; // minutes after the hour [0, 59] int tm_hour; // hours since midnight [0, 23] int tm_mday; // day of the month [1, 31] int tm_mon; // months since January [0, 11] int tm_year; // years since 1900 int tm_wday; // days since Sunday [0, 6] int tm_yday; // days since January 1 [0, 365] int tm_isdst; // Daylight Saving Time flag }; #include "__fc_define_timespec.h" struct itimerspec { struct timespec it_interval; struct timespec it_value; }; #define CLOCK_REALTIME 666 #define CLOCK_MONOTONIC 1 #define TIMER_ABSTIME 0 //@ ghost volatile unsigned int __fc_time __attribute__((FRAMA_C_MODEL)); /*@ assigns \result \from __fc_time; */ extern clock_t clock(void); /*@ assigns \result \from time1, time0; */ extern double difftime(time_t time1, time_t time0); /*@ assigns *timeptr, \result \from *timeptr; */ extern time_t mktime(struct tm *timeptr); /*@ assigns *timer, \result \from __fc_time; behavior null: assumes timer == \null; assigns \result \from __fc_time; behavior not_null: assumes timer != \null; requires \valid(timer); assigns *timer, \result \from __fc_time; ensures \initialized(timer); complete behaviors; disjoint behaviors; */ extern time_t time(time_t *timer); extern char *asctime(const struct tm *timeptr); extern char *ctime(const time_t *timer); struct tm __fc_time_tm; struct tm * const __fc_p_time_tm = &__fc_time_tm; /*@ assigns \result \from __fc_p_time_tm; assigns __fc_time_tm \from *timer; ensures \result == &__fc_time_tm || \result == \null ; */ extern struct tm *gmtime(const time_t *timer); /*@ assigns \result \from __fc_p_time_tm; assigns __fc_time_tm \from *timer; ensures \result == &__fc_time_tm || \result == \null; */ extern struct tm *localtime(const time_t *timer); extern size_t strftime(char * restrict s, size_t maxsize, const char * restrict format, const struct tm * restrict timeptr); /* POSIX */ extern int nanosleep(const struct timespec *, struct timespec *); extern int daylight; extern long timezone; extern char *tzname[2]; /* assigns tzname[0..1][0..] \from \nothing ;*/ extern void tzset(void); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/__fc_string_axiomatic.h0000644000175000017500000002170613113745005023072 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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: jessie_machine_prolog.h,v 1.8 2008-12-09 10:17:25 uid525 Exp $ */ #ifndef __FC_STRING_AXIOMATIC #define __FC_STRING_AXIOMATIC #include "features.h" __PUSH_FC_STDLIB #include "__fc_define_null.h" #include "__fc_define_wchar_t.h" __BEGIN_DECLS /*@ axiomatic MemCmp { @ logic ℤ memcmp{L1,L2}(char *s1, char *s2, ℤ n) @ reads \at(s1[0..n - 1],L1), \at(s2[0..n - 1],L2); @ @ axiom memcmp_zero{L1,L2}: @ \forall char *s1, *s2; \forall ℤ n; @ memcmp{L1,L2}(s1,s2,n) == 0 @ <==> \forall ℤ i; 0 <= i < n ==> \at(s1[i],L1) == \at(s2[i],L2); @ @ } @*/ /*@ 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{L,L}(s1,s2,n) == 0 && strlen(s1) < n ==> strlen(s1) == strlen(s2); @ @ axiom memcmp_strlen_right{L}: @ \forall char *s1, *s2; \forall ℤ n; @ memcmp{L,L}(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{L,L}(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{L,L}(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_read_string{L}(char *s) = @ 0 <= strlen(s) && \valid_read(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); @*/ __END_DECLS #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) __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/stdint.h0000644000175000017500000001004613113745002020055 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_machdep.h" __BEGIN_DECLS /* 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) __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/__fc_builtin.h0000644000175000017500000001605213113745007021174 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_define_size_t.h" __BEGIN_DECLS extern volatile int Frama_C_entropy_source __attribute__((unused)) __attribute__((FRAMA_C_MODEL)); /*@ requires \valid(p + (0 .. l-1)); assigns p[0 .. l-1] \from Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures \initialized(p + (0 .. l-1)); */ extern void Frama_C_make_unknown(char *p, size_t l); /*@ assigns \result \from a, b, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures \result == a || \result == b ; */ extern 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 ; */ extern void *Frama_C_nondet_ptr(void *a, void *b); /*@ requires min <= max; assigns \result \from min, max, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures min <= \result <= max ; */ extern int Frama_C_interval(int min, int max); /*@ requires min <= max; assigns \result \from min, max, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures min <= \result <= max ; */ extern int Frama_C_interval_split(int min, int max); /*@ requires min <= max; assigns \result \from min, max, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures min <= \result <= max ; */ extern unsigned char Frama_C_unsigned_char_interval (unsigned char min, unsigned char max); /*@ requires min <= max; assigns \result \from min, max, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures min <= \result <= max ; */ extern char Frama_C_char_interval(char min, char max); /*@ requires min <= max; assigns \result \from min, max, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures min <= \result <= max ; */ extern unsigned short Frama_C_unsigned_short_interval(unsigned short min, unsigned short max); /*@ requires min <= max; assigns \result \from min, max, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures min <= \result <= max ; */ extern short Frama_C_short_interval(short min, short max); /*@ requires min <= max; assigns \result \from min, max, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures min <= \result <= max ; */ extern unsigned int Frama_C_unsigned_int_interval(unsigned int min, unsigned int max); /*@ requires min <= max; assigns \result \from min, max, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures min <= \result <= max ; */ extern int Frama_C_int_interval(int min, int max); /*@ requires min <= max; assigns \result \from min, max, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures min <= \result <= max ; */ extern unsigned long Frama_C_unsigned_long_interval (unsigned long min, unsigned long max); /*@ requires min <= max; assigns \result \from min, max, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures min <= \result <= max ; */ extern long Frama_C_long_interval(long min, long max); /*@ requires min <= max; assigns \result \from min, max, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures min <= \result <= max ; */ extern unsigned long long Frama_C_unsigned_long_long_interval (unsigned long long min, unsigned long long max); /*@ requires min <= max; assigns \result \from min, max, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures min <= \result <= max ; */ extern long long Frama_C_long_long_interval(long long min, long long max); /*@ requires min <= max; assigns \result \from min, max, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures min <= \result <= max ; */ extern size_t Frama_C_size_t_interval(size_t min, size_t max); /*@ requires \is_finite(min) && \is_finite(max); requires min <= max; assigns \result \from min, max, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures \is_finite(\result) && min <= \result <= max ; */ extern float Frama_C_float_interval(float min, float max); /*@ requires \is_finite(min) && \is_finite(max); requires min <= max; assigns \result \from min, max, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures \is_finite(\result) && min <= \result <= max ; */ extern 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; */ extern void* Frama_C_memcpy(void *dest, const void *src, size_t n); /*@ assigns ((char*)p)[0 .. s-1] \from c ; assigns \result \from p; */ extern void* Frama_C_memset(void *p, int c, size_t s); /*@ // Signals an error; requires \false; assigns \nothing; */ extern void Frama_C_abort(void) __attribute__ ((noreturn)); /*@ assigns \result \from p; */ extern size_t Frama_C_offset(const void* p); extern void *Frama_C_malloc_fresh(size_t size); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/iso646.h0000644000175000017500000000353113113745010017602 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/__fc_define_null.h0000644000175000017500000000334213113745007022010 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #ifdef __cplusplus #define NULL 0 #else #define NULL ((void*)0) #endif #endif frama-c-Phosphorus-20170501/share/libc/nl_types.h0000644000175000017500000000372013113745005020411 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB __BEGIN_DECLS typedef unsigned long nl_catd; typedef unsigned long nl_item; #define NL_SETD 0 #define NL_CAT_LOCALE 1 extern int catclose(nl_catd); extern char *catgets(nl_catd, int, int, const char *); extern nl_catd catopen(const char *, int); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/byteswap.h0000644000175000017500000001252013113745004020407 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/assert.h0000644000175000017500000000375713113745011020064 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB __BEGIN_DECLS /*@ requires \false; terminates \false; assigns \nothing; */ extern void __FC_assert(const char* file,int line,const char*expr); __END_DECLS __POP_FC_STDLIB #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-Phosphorus-20170501/share/libc/getopt.h0000644000175000017500000000532713113745006020064 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB __BEGIN_DECLS extern char *optarg; extern int optind, opterr, optopt; /*@ assigns \result, *optarg, optind, opterr, optopt \from argc, argv[0..argc-1], optstring[0..]; */ extern int getopt(int argc, char * const argv[], const char *optstring); /* GNU specific */ struct option { const char *name; int has_arg; int *flag; int val; }; # define no_argument 0 # define required_argument 1 # define optional_argument 2 /*@ assigns \result, *optarg, optind, opterr, optopt, *(longopts[0..].flag) \from argc, argv[0..argc-1], shortopts[0..], longopts[0..]; */ extern int getopt_long (int argc, char *const argv[], const char *shortopts, const struct option *longopts, int *longind); /*@ assigns \result, *optarg, optind, opterr, optopt, *(longopts[0..].flag) \from argc, argv[0..argc-1], shortopts[0..], longopts[0..]; */ extern int getopt_long_only (int argc, char *const argv[], const char *shortopts, const struct option *longopts, int *longind); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/assert.c0000644000175000017500000000353313113745005020052 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "__fc_builtin.h" #include "assert.h" //@ assigns \nothing; extern void Frama_C_show_each_warning(); 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-Phosphorus-20170501/share/libc/__fc_define_time_t.h0000644000175000017500000000343113113745002022311 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB #include "__fc_machdep.h" __BEGIN_DECLS typedef __FC_TIME_T time_t; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/ifaddrs.h0000644000175000017500000000442013113745003020164 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_define_sockaddr.h" __BEGIN_DECLS /* 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; }; extern int getifaddrs(struct ifaddrs **); extern void freeifaddrs(struct ifaddrs *); extern int getifmaddrs(struct ifmaddrs **); extern void freeifmaddrs(struct ifmaddrs *); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/regex.h0000644000175000017500000000516713113745012017673 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 _REGEX_H #define _REGEX_H 1 #include "features.h" __PUSH_FC_STDLIB #include "__fc_define_size_t.h" __BEGIN_DECLS struct re_pattern_buffer { size_t re_nsub; }; typedef struct re_pattern_buffer regex_t; #define REG_EXTENDED 1 #define REG_ICASE 2 #define REG_NEWLINE 4 #define REG_NOSUB 8 /* Eflags */ #define REG_NOTBOL 1 #define REG_NOTEOL 2 /* Error codes */ typedef enum { REG_NOERROR = 0, REG_NOMATCH, REG_BADPAT, REG_ECOLLATE, REG_ECTYPE, REG_EESCAPE, REG_ESUBREG, REG_EBRACK, REG_EPAREN, REG_EBRACE, REG_BADBR, REG_ERANGE, REG_ESPACE, REG_BADRPT, REG_EEND, REG_ESIZE, REG_ERPAREN } reg_errcode_t; typedef int regoff_t; typedef struct { regoff_t rm_so; regoff_t rm_eo; } regmatch_t; extern int regcomp(regex_t *, const char *, int); extern int regexec(const regex_t *, const char *, size_t, regmatch_t[], int); extern size_t regerror(int, const regex_t *, char *, size_t); extern void regfree(regex_t *); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/glob.h0000644000175000017500000000646313113745011017503 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #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. */ __BEGIN_DECLS 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; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/net/0000755000175000017500000000000013113745006017170 5ustar mehdimehdiframa-c-Phosphorus-20170501/share/libc/net/if.h0000644000175000017500000001530513113745006017743 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "../features.h" #include "sys/socket.h" __BEGIN_DECLS struct if_nameidx {unsigned if_index; char *if_name;}; #define IF_NAMESIZE 255 extern unsigned if_nametoindex(const char * name); extern char *if_indextoname(unsigned index, char *name); extern struct if_nameindex *if_nameindex(void); extern 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) struct ifconf { int ifc_len; /* Size of buffer. */ union { char *ifcu_buf; struct ifreq *ifcu_req; } ifc_ifcu; }; # define ifc_buf ifc_ifcu.ifcu_buf /* Buffer address. */ # define ifc_req ifc_ifcu.ifcu_req /* Array of structures. */ __END_DECLS #endif frama-c-Phosphorus-20170501/share/libc/__fc_machdep.h0000644000175000017500000002142513113745007021127 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #ifdef __FC_MACHDEP_X86_32 #define __FC_FORCE_INCLUDE_MACHDEP__ #include "__fc_machdep_linux_gcc_shared.h" #undef __FC_FORCE_INCLUDE_MACHDEP__ #define __FC_BYTE_ORDER __LITTLE_ENDIAN /* 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 __PTRDIFF_T int #define __SIZE_T unsigned int #define __FC_LONG_MAX 2147483647L #define __FC_ULONG_MAX 4294967295UL #define __FC_SIZE_MAX __FC_UINT_MAX /* Optional */ #define __INTPTR_T signed int #define __UINTPTR_T unsigned int #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_LEAST32_T signed int #define __UINT_LEAST32_T unsigned int #define __INT_FAST32_T signed int #define __UINT_FAST32_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__ #define __FC_BYTE_ORDER __LITTLE_ENDIAN /* 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 __PTRDIFF_T long #define __SIZE_T unsigned long #define __FC_LONG_MAX 9223372036854775807L #define __FC_ULONG_MAX 18446744073709551615UL #define __FC_SIZE_MAX __FC_ULONG_MAX /* Optional */ #define __INTPTR_T signed long #define __UINTPTR_T unsigned long #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_LEAST32_T signed int #define __UINT_LEAST32_T unsigned int #define __INT_FAST32_T signed int #define __UINT_FAST32_T unsigned int /* POSIX */ #define __SSIZE_T signed long /* stdint.h */ #define __FC_PTRDIFF_MIN __FC_LONG_MIN #define __FC_PTRDIFF_MAX __FC_LONG_MAX #else #ifdef __FC_MACHDEP_X86_16 #define __FC_FORCE_INCLUDE_MACHDEP__ #include "__fc_machdep_linux_gcc_shared.h" #undef __FC_FORCE_INCLUDE_MACHDEP__ #define __FC_BYTE_ORDER __LITTLE_ENDIAN /* Required */ #undef __CHAR_UNSIGNED__ #define __WORDSIZE 16 #define __SIZEOF_SHORT 2 #define __SIZEOF_INT 2 #define __SIZEOF_LONG 4 #define __SIZEOF_LONGLONG 8 #define __CHAR_BIT 8 #define __PTRDIFF_T long #define __SIZE_T unsigned long #define __FC_LONG_MAX 2147483647L #define __FC_ULONG_MAX 4294967295UL #define __FC_SIZE_MAX __FC_ULONG_MAX /* Optional */ #define __INTPTR_T signed long #define __UINTPTR_T unsigned long #define __INT32_T signed long #define __UINT32_T unsigned long #define __INT64_T signed long long #define __UINT64_T unsigned long long /* Required */ #define __INT_LEAST32_T signed long #define __UINT_LEAST32_T unsigned long #define __INT_FAST32_T signed long #define __UINT_FAST32_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 #ifdef __FC_MACHDEP_PPC_32 #define __FC_FORCE_INCLUDE_MACHDEP__ #include "__fc_machdep_linux_gcc_shared.h" #undef __FC_FORCE_INCLUDE_MACHDEP__ #define __FC_BYTE_ORDER __BIG_ENDIAN /* 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 __PTRDIFF_T int #define __SIZE_T unsigned int #define __FC_LONG_MAX 2147483647L #define __FC_ULONG_MAX 4294967295UL #define __FC_SIZE_MAX __FC_UINT_MAX /* Optional */ #define __INTPTR_T signed int #define __UINTPTR_T unsigned int #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_LEAST32_T signed int #define __UINT_LEAST32_T unsigned int #define __INT_FAST32_T signed int #define __UINT_FAST32_T unsigned int /* POSIX */ #define __SSIZE_T int /* stdint.h */ #define __FC_PTRDIFF_MIN __FC_INT_MIN #define __FC_PTRDIFF_MAX __FC_INT_MAX /* time.h */ #define __FC_TIME_T long #else #ifdef __FC_MACHDEP_MSVC_X86_64 #define __FC_BYTE_ORDER __LITTLE_ENDIAN /* Required */ #undef __CHAR_UNSIGNED__ #define __WORDSIZE 64 #define __SIZEOF_SHORT 2 #define __SIZEOF_INT 4 #define __SIZEOF_LONG 4 #define __SIZEOF_LONGLONG 8 #define __CHAR_BIT 8 #define __PTRDIFF_T long long #define __SIZE_T unsigned long long #define __FC_EOF (-1) #define __FC_FOPEN_MAX 20 #define __FC_RAND_MAX 32767 #define __WCHAR_T unsigned short /* 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_LONG_MAX 2147483647L #define __FC_ULONG_MAX 4294967295UL #define __FC_LLONG_MIN (-LLONG_MAX -1LL) #define __FC_LLONG_MAX 9223372036854775807LL #define __FC_ULLONG_MAX 18446744073709551615ULL #define __FC_PATH_MAX 256 #define __FC_SIZE_MAX __FC_ULLONG_MAX /* Optional */ #define __INT8_T signed char #define __UINT8_T unsigned char #define __INT16_T signed short #define __UINT16_T unsigned short #define __INTPTR_T signed long long #define __UINTPTR_T unsigned long long #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 #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 /* POSIX */ #define __SSIZE_T signed long long /* stdint.h */ #define __FC_PTRDIFF_MIN __FC_LLONG_MIN #define __FC_PTRDIFF_MAX __FC_LLONG_MAX /* time.h */ #define __FC_TIME_T __int64 /* for stdarg.h */ #define __FC_VA_LIST_T char* /* The following macros are defined to correspond to the version of MSVC used during the definition of some MSVC-specific features: Visual Studio 2010. They also help detecting, in some tests, whether we are in MSVC mode. */ #define _MSC_FULL_VER 160040219 #define _MSC_VER 1600 // __ptr64 is MSVC-specific and needs to be undefined for us to parse it #undef __ptr64 #define __ptr64 #else #error Must define __FC_MACHDEP_, where is one of the \ following: X86_32, X86_64, X86_16, PPC_32, MSVC_X86_64. \ If you are using a custom machdep, you must include your machdep \ header file defining __FC_MACHDEP to avoid inclusion of this file. #endif #endif #endif #endif #endif #endif frama-c-Phosphorus-20170501/share/libc/__fc_define_wchar_t.h0000644000175000017500000000351413113745001022460 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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" #if !defined(__cplusplus) /* wchar_t is a keyword in C++ and shall not be a typedef. */ typedef __WCHAR_T wchar_t; #else typedef __WCHAR_T fc_wchar_t; #endif #endif frama-c-Phosphorus-20170501/share/libc/math.h0000644000175000017500000003262513113745011017510 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_string_axiomatic.h" #include "errno.h" __BEGIN_DECLS typedef float float_t; typedef double double_t; #define MATH_ERRNO 1 #define MATH_ERREXCEPT 2 #define HUGE_VAL 0x1.0p2047 #define HUGE_VALF 0x1.0p255f #define HUGE_VALL 0x1.0p32767L /* The constants below are not part of C99/C11 but they are defined in POSIX */ #ifdef _XOPEN_SOURCE # define M_E 0x1.5bf0a8b145769p1 /* e */ # define M_LOG2E 0x1.71547652b82fep0 /* log_2 e */ # define M_LOG10E 0x1.bcb7b1526e50ep-2 /* log_10 e */ # define M_LN2 0x1.62e42fefa39efp-1 /* log_e 2 */ # define M_LN10 0x1.26bb1bbb55516p1 /* log_e 10 */ # define M_PI 0x1.921fb54442d18p1 /* pi */ # define M_PI_2 0x1.921fb54442d18p0 /* pi/2 */ # define M_PI_4 0x1.921fb54442d18p-1 /* pi/4 */ # define M_1_PI 0x1.45f306dc9c883p-2 /* 1/pi */ # define M_2_PI 0x1.45f306dc9c883p-1 /* 2/pi */ # define M_2_SQRTPI 0x1.20dd750429b6dp0 /* 2/sqrt(pi) */ # define M_SQRT2 0x1.6a09e667f3bcdp0 /* sqrt(2) */ # define M_SQRT1_2 0x1.6a09e667f3bcdp-1 /* 1/sqrt(2) */ #endif /* 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; */ extern 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; */ extern 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; */ extern 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; */ extern 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; */ extern 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; */ extern long double asinl(long double x); extern float atanf(float x); extern double atan(double x); extern long double atanl(long double x); /*@ assigns \result \from y, x; */ extern double atan2(double y, double x); extern float atan2f(float y, float x); extern long double atan2l(long double y, long double x); /*@ assigns \result \from x; */ extern double cos(double x); extern float cosf(float x); extern long double cosl(long double x); /*@ assigns \result \from x; */ extern double sin(double x); extern float sinf(float x); extern long double sinl(long double x); extern double tan(double x); extern float tanf(float x); extern 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; */ extern 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; */ extern 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; */ extern long double acoshl(long double x); extern double asinh(double x); extern float asinhf(float x); extern long double asinhl(long double x); extern double atanh(double x); extern float atanhf(float x); extern long double atanhl(long double x); extern double cosh(double x); extern float coshf(float x); extern long double coshl(long double x); extern double sinh(double x); extern float sinhf(float x); extern long double sinhl(long double x); extern double tanh(double x); extern float tanhf(float x); extern long double tanhl(long double x); /*@ assigns \result \from x; */ extern double exp(double x); /*@ assigns \result \from x; */ extern float expf(float x); extern long double expl(long double x); extern double exp2(double x); extern float exp2f(float x); extern long double exp2l(long double x); extern double expm1(double x); extern float expm1f(float x); extern long double expm1l(long double x); extern double frexp(double value, int *exp); extern float frexpf(float value, int *exp); extern long double frexpl(long double value, int *exp); extern int ilogb(double x); extern int ilogbf(float x); extern int ilogbl(long double x); extern double ldexp(double x, int exp); extern float ldexpf(float x, int exp); extern long double ldexpl(long double x, int exp); /*@ assigns \result \from x; */ extern double log(double x); /*@ assigns \result \from x; */ extern float logf(float x); extern long double logl(long double x); /*@ assigns \result \from x; */ extern double log10(double x); /*@ assigns \result \from x; */ extern float log10f(float x); extern long double log10l(long double x); extern double log1p(double x); extern float log1pf(float x); extern long double log1pl(long double x); extern double log2(double x); extern float log2f(float x); extern long double log2l(long double x); extern double logb(double x); extern float logbf(float x); extern long double logbl(long double x); extern double modf(double value, double *iptr); extern float modff(float value, float *iptr); extern long double modfl(long double value, long double *iptr); extern double scalbn(double x, int n); extern float scalbnf(float x, int n); extern long double scalbnl(long double x, int n); extern double scalbln(double x, long int n); extern float scalblnf(float x, long int n); extern long double scalblnl(long double x, long int n); extern double cbrt(double x); extern float cbrtf(float x); extern long double cbrtl(long double x); extern double fabs(double x); extern float fabsf(float x); extern long double fabsl(long double x); extern double hypot(double x, double y); extern float hypotf(float x, float y); extern long double hypotl(long double x, long double y); /*@ assigns \result \from x, y; */ extern double pow(double x, double y); /*@ assigns \result \from x, y; */ extern float powf(float x, float y); extern long double powl(long double x, long double y); /*@ assigns \result \from x; */ extern double sqrt(double x); /*@ assigns \result \from x; */ extern float sqrtf(float x); extern long double sqrtl(long double x); extern double erf(double x); extern float erff(float x); extern long double erfl(long double x); extern double erfc(double x); extern float erfcf(float x); extern long double erfcl(long double x); extern double lgamma(double x); extern float lgammaf(float x); extern long double lgammal(long double x); extern double tgamma(double x); extern float tgammaf(float x); extern long double tgammal(long double x); /*@ assigns \result \from x; */ extern double ceil(double x); /*@ assigns \result \from x; */ extern float ceilf(float x); extern long double ceill(long double x); /*@ assigns \result \from x; */ extern double floor(double x); /*@ assigns \result \from x; */ extern float floorf(float x); extern long double floorl(long double x); extern double nearbyint(double x); extern float nearbyintf(float x); extern long double nearbyintl(long double x); extern double rint(double x); extern float rintf(float x); extern long double rintl(long double x); extern long int lrint(double x); extern long int lrintf(float x); extern long int lrintl(long double x); extern long long int llrint(double x); extern long long int llrintf(float x); extern long long int llrintl(long double x); /*@ assigns \result \from x; */ extern double round(double x); /*@ assigns \result \from x; */ extern float roundf(float x); extern long double roundl(long double x); extern long int lround(double x); extern long int lroundf(float x); extern long int lroundl(long double x); extern long long int llround(double x); extern long long int llroundf(float x); extern long long int llroundl(long double x); /*@ assigns \result \from x; */ extern double trunc(double x); /*@ assigns \result \from x; */ extern float truncf(float x); extern long double truncl(long double x); /*@ assigns \result \from x, y; */ extern double fmod(double x, double y); extern float fmodf(float x, float y); extern long double fmodl(long double x, long double y); extern double remainder(double x, double y); extern float remainderf(float x, float y); extern long double remainderl(long double x, long double y); extern double remquo(double x, double y, int *quo); extern float remquof(float x, float y, int *quo); extern long double remquol(long double x, long double y, int *quo); extern double copysign(double x, double y); extern float copysignf(float x, float y); extern long double copysignl(long double x, long double y); /*@ requires valid_read_string(tagp); assigns \nothing; ensures \is_NaN(\result); */ extern double nan(const char *tagp); /*@ requires valid_read_string(tagp); assigns \nothing; ensures \is_NaN(\result); */ extern float nanf(const char *tagp); /*@ requires valid_read_string(tagp); assigns \nothing; ensures \is_NaN(\result); */ extern long double nanl(const char *tagp); extern double nextafter(double x, double y); extern float nextafterf(float x, float y); extern long double nextafterl(long double x, long double y); extern double nexttoward(double x, long double y); extern float nexttowardf(float x, long double y); extern long double nexttowardl(long double x, long double y); extern double fdim(double x, double y); extern float fdimf(float x, float y); extern long double fdiml(long double x, long double y); extern double fmax(double x, double y); extern float fmaxf(float x, float y); extern long double fmaxl(long double x, long double y); extern double fmin(double x, double y); extern float fminf(float x, float y); extern long double fminl(long double x, long double y); extern double fma(double x, double y, double z); extern float fmaf(float x, float y, float z); extern long double fmal(long double x, long double y, long double z); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/__fc_define_mode_t.h0000644000175000017500000000547413113745012022311 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB __BEGIN_DECLS typedef unsigned int mode_t; __END_DECLS #define S_IFMT 0170000 #define S_IFBLK 0060000 #define S_IFCHR 0020000 #define S_IFIFO 0010000 #define S_IFREG 0100000 #define S_IFDIR 0040000 #define S_IFLNK 0120000 #define S_IFSOCK 0140000 #define S_IRUSR 00400 #define S_IWUSR 00200 #define S_IXUSR 00100 #define S_IRWXU (S_IRUSR | S_IWUSR | S_IXUSR) #define S_IRGRP 00040 #define S_IWGRP 00020 #define S_IXGRP 00010 #define S_IRWXG (S_IRGRP | S_IWGRP | S_IXGRP) #define S_IROTH 00004 #define S_IWOTH 00002 #define S_IXOTH 00001 #define S_IRWXO (S_IROTH | S_IWOTH | S_IXOTH) #define S_ISUID 0004000 #define S_ISGID 0002000 #define S_ISVTX 0001000 #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) #define S_ISSOCK(m) (((m) & S_IFMT) == S_IFSOCK) __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/float.h0000644000175000017500000000522313113745006017662 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/ctype.c0000644000175000017500000000617613113745007017705 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "ctype.h" #include "__fc_builtin.h" // This file assumes a simple, C-like locale, with no extra characters // or special cases. #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) { if ((c >= 'A') && (c <= 'Z')) return c + 0x20; return c; } int toupper (int c) { if ((c >= 'a') && (c <= 'z')) return c - 0x20; return c; } frama-c-Phosphorus-20170501/share/libc/locale.h0000644000175000017500000001547113113745010020015 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 #include "features.h" __PUSH_FC_STDLIB __BEGIN_DECLS /* 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" #include "__fc_string_axiomatic.h" #define LC_CTYPE 0 #define LC_NUMERIC 1 #define LC_TIME 2 #define LC_COLLATE 3 #define LC_MONETARY 4 #define LC_MESSAGES 5 #define LC_ALL 6 #define LC_PAPER 7 #define LC_NAME 8 #define LC_ADDRESS 9 #define LC_TELEPHONE 10 #define LC_MEASUREMENT 11 #define LC_IDENTIFICATION 12 # define LC_CTYPE_MASK (1 << LC_CTYPE) # define LC_NUMERIC_MASK (1 << LC_NUMERIC) # define LC_TIME_MASK (1 << LC_TIME) # define LC_COLLATE_MASK (1 << LC_COLLATE) # define LC_MONETARY_MASK (1 << LC_MONETARY) # define LC_MESSAGES_MASK (1 << LC_MESSAGES) # define LC_PAPER_MASK (1 << LC_PAPER) # define LC_NAME_MASK (1 << LC_NAME) # define LC_ADDRESS_MASK (1 << LC_ADDRESS) # define LC_TELEPHONE_MASK (1 << LC_TELEPHONE) # define LC_MEASUREMENT_MASK (1 << LC_MEASUREMENT) # define LC_IDENTIFICATION_MASK (1 << LC_IDENTIFICATION) # define LC_ALL_MASK (LC_CTYPE_MASK \ | LC_NUMERIC_MASK \ | LC_TIME_MASK \ | LC_COLLATE_MASK \ | LC_MONETARY_MASK \ | LC_MESSAGES_MASK \ | LC_PAPER_MASK \ | LC_NAME_MASK \ | LC_ADDRESS_MASK \ | LC_TELEPHONE_MASK \ | LC_MEASUREMENT_MASK \ | LC_IDENTIFICATION_MASK \ ) extern struct lconv* __frama_c_locale; extern char*__frama_c_locale_names[]; /*@ requires locale == \null || valid_read_string(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); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/libintl.h0000644000175000017500000000321313113745003020204 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/arpa/0000755000175000017500000000000013113745010017320 5ustar mehdimehdiframa-c-Phosphorus-20170501/share/libc/arpa/inet.h0000644000175000017500000000524013113745010020431 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "../features.h" __PUSH_FC_STDLIB #include "../inttypes.h" #include "../netinet/in.h" #include "__fc_string_axiomatic.h" __BEGIN_DECLS /*@ assigns \result \from arg ; */ extern uint32_t htonl(uint32_t arg); /*@ assigns \result \from arg ; */ extern uint16_t htons(uint16_t arg); /*@ assigns \result \from arg ; */ extern uint32_t ntohl(uint32_t arg); /*@ assigns \result \from arg ; */ extern uint16_t ntohs(uint16_t arg); /*@ requires valid_read_string(arg); assigns \result \from indirect:arg[0..]; */ extern in_addr_t inet_addr(const char * arg); /*@ assigns \result \from arg ; */ extern char *inet_ntoa(struct in_addr arg); /*@ assigns \result \from dst,af,((char*)src)[0..]; assigns dst[0..size-1] \from af,((char*)src)[0..] ; */ extern 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..] ; */ extern int inet_pton(int af, const char *src, void *dst); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/signal.h0000644000175000017500000001043513113745006020033 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_define_pid_t.h" #include "__fc_define_uid_and_gid.h" __BEGIN_DECLS /* TODO: put sig_atomic_t in machdep */ typedef volatile int sig_atomic_t; typedef void (*__fc_sighandler_t) (int); /* for BSD 4.4 */ #ifdef __USE_MISC typedef __fc_sighandler_t sig_t; #endif #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; */ extern void (*signal(int sig, void (*func)(int)))(int); /*@ assigns \nothing; ensures \false; */ extern 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; }; extern int sigemptyset(sigset_t *set); extern int sigfillset(sigset_t *set); extern int sigaddset(sigset_t *set, int signum); extern int sigdelset(sigset_t *set, int signum); extern int sigismember(const sigset_t *set, int signum); extern int sigaction(int signum, const struct sigaction *act, struct sigaction *oldact); extern int sigprocmask(int how, const sigset_t *set, sigset_t *oldset); extern int kill(pid_t pid, int sig); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/iconv.h0000644000175000017500000000444513113745003017675 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "features.h" __PUSH_FC_STDLIB #include "__fc_define_size_t.h" __BEGIN_DECLS typedef void * iconv_t; extern int __fc_errno; /*@ assigns *outbuf[0 .. *outbytesleft-1] \from *inbuf[0 .. *inbytesleft-1]; assigns __fc_errno ; */ extern 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 ; */ extern int iconv_close(iconv_t); /*@ assigns \result \from tocode[..],fromcode[..]; assigns __fc_errno; */ extern iconv_t iconv_open(const char *tocode, const char *fromcode); __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/netinet/0000755000175000017500000000000013113745011020044 5ustar mehdimehdiframa-c-Phosphorus-20170501/share/libc/netinet/in_systm.h0000644000175000017500000000322713113745006022072 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/netinet/ip.h0000644000175000017500000000322113113745001020622 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/netinet/ip_icmp.h0000644000175000017500000000323413113745011021637 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/libc/netinet/tcp.h0000644000175000017500000002520413113745003021007 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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) 1982, 1986, 1993 * The Regents of the University of California. 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. * 4. Neither the name of the University 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 THE REGENTS 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 REGENTS 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. * * @(#)tcp.h 8.1 (Berkeley) 6/10/93 */ #ifndef _NETINET_TCP_H #define _NETINET_TCP_H 1 #include __PUSH_FC_STDLIB /* * User-settable options (used with setsockopt). */ #define TCP_NODELAY 1 /* Don't delay send to coalesce packets */ #define TCP_MAXSEG 2 /* Set maximum segment size */ #define TCP_CORK 3 /* Control sending of partial frames */ #define TCP_KEEPIDLE 4 /* Start keeplives after this period */ #define TCP_KEEPINTVL 5 /* Interval between keepalives */ #define TCP_KEEPCNT 6 /* Number of keepalives before death */ #define TCP_SYNCNT 7 /* Number of SYN retransmits */ #define TCP_LINGER2 8 /* Life time of orphaned FIN-WAIT-2 state */ #define TCP_DEFER_ACCEPT 9 /* Wake up listener only when data arrive */ #define TCP_WINDOW_CLAMP 10 /* Bound advertised window */ #define TCP_INFO 11 /* Information about this connection. */ #define TCP_QUICKACK 12 /* Bock/reenable quick ACKs. */ #define TCP_CONGESTION 13 /* Congestion control algorithm. */ #define TCP_MD5SIG 14 /* TCP MD5 Signature (RFC2385) */ #define TCP_COOKIE_TRANSACTIONS 15 /* TCP Cookie Transactions */ #define TCP_THIN_LINEAR_TIMEOUTS 16 /* Use linear timeouts for thin streams*/ #define TCP_THIN_DUPACK 17 /* Fast retrans. after 1 dupack */ #define TCP_USER_TIMEOUT 18 /* How long for loss retry before timeout */ #define TCP_REPAIR 19 /* TCP sock is under repair right now */ #define TCP_REPAIR_QUEUE 20 /* Set TCP queue to repair */ #define TCP_QUEUE_SEQ 21 /* Set sequence number of repaired queue. */ #define TCP_REPAIR_OPTIONS 22 /* Repair TCP connection options */ #define TCP_FASTOPEN 23 /* Enable FastOpen on listeners */ #define TCP_TIMESTAMP 24 /* TCP time stamp */ #define TCP_NOTSENT_LOWAT 25 /* Limit number of unsent bytes in write queue. */ #define TCP_CC_INFO 26 /* Get Congestion Control (optional) info. */ #define TCP_SAVE_SYN 27 /* Record SYN headers for new connections. */ #define TCP_SAVED_SYN 28 /* Get SYN headers recorded for connection. */ #ifdef __USE_MISC # include # include typedef u_int32_t tcp_seq; /* * TCP header. * Per RFC 793, September, 1981. */ struct tcphdr { __extension__ union { struct { u_int16_t th_sport; /* source port */ u_int16_t th_dport; /* destination port */ tcp_seq th_seq; /* sequence number */ tcp_seq th_ack; /* acknowledgement number */ # if __BYTE_ORDER == __LITTLE_ENDIAN u_int8_t th_x2:4; /* (unused) */ u_int8_t th_off:4; /* data offset */ # endif # if __BYTE_ORDER == __BIG_ENDIAN u_int8_t th_off:4; /* data offset */ u_int8_t th_x2:4; /* (unused) */ # endif u_int8_t th_flags; # define TH_FIN 0x01 # define TH_SYN 0x02 # define TH_RST 0x04 # define TH_PUSH 0x08 # define TH_ACK 0x10 # define TH_URG 0x20 u_int16_t th_win; /* window */ u_int16_t th_sum; /* checksum */ u_int16_t th_urp; /* urgent pointer */ }; struct { u_int16_t source; u_int16_t dest; u_int32_t seq; u_int32_t ack_seq; # if __BYTE_ORDER == __LITTLE_ENDIAN u_int16_t res1:4; u_int16_t doff:4; u_int16_t fin:1; u_int16_t syn:1; u_int16_t rst:1; u_int16_t psh:1; u_int16_t ack:1; u_int16_t urg:1; u_int16_t res2:2; # elif __BYTE_ORDER == __BIG_ENDIAN u_int16_t doff:4; u_int16_t res1:4; u_int16_t res2:2; u_int16_t urg:1; u_int16_t ack:1; u_int16_t psh:1; u_int16_t rst:1; u_int16_t syn:1; u_int16_t fin:1; # else # error "Adjust your defines" # endif u_int16_t window; u_int16_t check; u_int16_t urg_ptr; }; }; }; enum { TCP_ESTABLISHED = 1, TCP_SYN_SENT, TCP_SYN_RECV, TCP_FIN_WAIT1, TCP_FIN_WAIT2, TCP_TIME_WAIT, TCP_CLOSE, TCP_CLOSE_WAIT, TCP_LAST_ACK, TCP_LISTEN, TCP_CLOSING /* now a valid state */ }; # define TCPOPT_EOL 0 # define TCPOPT_NOP 1 # define TCPOPT_MAXSEG 2 # define TCPOLEN_MAXSEG 4 # define TCPOPT_WINDOW 3 # define TCPOLEN_WINDOW 3 # define TCPOPT_SACK_PERMITTED 4 /* Experimental */ # define TCPOLEN_SACK_PERMITTED 2 # define TCPOPT_SACK 5 /* Experimental */ # define TCPOPT_TIMESTAMP 8 # define TCPOLEN_TIMESTAMP 10 # define TCPOLEN_TSTAMP_APPA (TCPOLEN_TIMESTAMP+2) /* appendix A */ # define TCPOPT_TSTAMP_HDR \ (TCPOPT_NOP<<24|TCPOPT_NOP<<16|TCPOPT_TIMESTAMP<<8|TCPOLEN_TIMESTAMP) /* * Default maximum segment size for TCP. * With an IP MSS of 576, this is 536, * but 512 is probably more convenient. * This should be defined as MIN(512, IP_MSS - sizeof (struct tcpiphdr)). */ # define TCP_MSS 512 # define TCP_MAXWIN 65535 /* largest value for (unscaled) window */ # define TCP_MAX_WINSHIFT 14 /* maximum window shift */ # define SOL_TCP 6 /* TCP level */ # define TCPI_OPT_TIMESTAMPS 1 # define TCPI_OPT_SACK 2 # define TCPI_OPT_WSCALE 4 # define TCPI_OPT_ECN 8 /* ECN was negociated at TCP session init */ # define TCPI_OPT_ECN_SEEN 16 /* we received at least one packet with ECT */ # define TCPI_OPT_SYN_DATA 32 /* SYN-ACK acked data in SYN sent or rcvd */ /* Values for tcpi_state. */ enum tcp_ca_state { TCP_CA_Open = 0, TCP_CA_Disorder = 1, TCP_CA_CWR = 2, TCP_CA_Recovery = 3, TCP_CA_Loss = 4 }; struct tcp_info { u_int8_t tcpi_state; u_int8_t tcpi_ca_state; u_int8_t tcpi_retransmits; u_int8_t tcpi_probes; u_int8_t tcpi_backoff; u_int8_t tcpi_options; u_int8_t tcpi_snd_wscale : 4, tcpi_rcv_wscale : 4; u_int32_t tcpi_rto; u_int32_t tcpi_ato; u_int32_t tcpi_snd_mss; u_int32_t tcpi_rcv_mss; u_int32_t tcpi_unacked; u_int32_t tcpi_sacked; u_int32_t tcpi_lost; u_int32_t tcpi_retrans; u_int32_t tcpi_fackets; /* Times. */ u_int32_t tcpi_last_data_sent; u_int32_t tcpi_last_ack_sent; /* Not remembered, sorry. */ u_int32_t tcpi_last_data_recv; u_int32_t tcpi_last_ack_recv; /* Metrics. */ u_int32_t tcpi_pmtu; u_int32_t tcpi_rcv_ssthresh; u_int32_t tcpi_rtt; u_int32_t tcpi_rttvar; u_int32_t tcpi_snd_ssthresh; u_int32_t tcpi_snd_cwnd; u_int32_t tcpi_advmss; u_int32_t tcpi_reordering; u_int32_t tcpi_rcv_rtt; u_int32_t tcpi_rcv_space; u_int32_t tcpi_total_retrans; }; /* For TCP_MD5SIG socket option. */ #define TCP_MD5SIG_MAXKEYLEN 80 struct tcp_md5sig { struct sockaddr_storage tcpm_addr; /* Address associated. */ u_int16_t __tcpm_pad1; /* Zero. */ u_int16_t tcpm_keylen; /* Key length. */ u_int32_t __tcpm_pad2; /* Zero. */ u_int8_t tcpm_key[TCP_MD5SIG_MAXKEYLEN]; /* Key (binary). */ }; /* For socket repair options. */ struct tcp_repair_opt { u_int32_t opt_code; u_int32_t opt_val; }; /* Queue to repair, for TCP_REPAIR_QUEUE. */ enum { TCP_NO_QUEUE, TCP_RECV_QUEUE, TCP_SEND_QUEUE, TCP_QUEUES_NR, }; /* For cookie transactions socket options. */ #define TCP_COOKIE_MIN 8 /* 64-bits */ #define TCP_COOKIE_MAX 16 /* 128-bits */ #define TCP_COOKIE_PAIR_SIZE (2*TCP_COOKIE_MAX) /* Flags for both getsockopt and setsockopt */ #define TCP_COOKIE_IN_ALWAYS (1 << 0) /* Discard SYN without cookie */ #define TCP_COOKIE_OUT_NEVER (1 << 1) /* Prohibit outgoing cookies, * supercedes everything. */ /* Flags for getsockopt */ #define TCP_S_DATA_IN (1 << 2) /* Was data received? */ #define TCP_S_DATA_OUT (1 << 3) /* Was data sent? */ #define TCP_MSS_DEFAULT 536U /* IPv4 (RFC1122, RFC2581) */ #define TCP_MSS_DESIRED 1220U /* IPv6 (tunneled), EDNS0 (RFC3226) */ struct tcp_cookie_transactions { u_int16_t tcpct_flags; u_int8_t __tcpct_pad1; u_int8_t tcpct_cookie_desired; u_int16_t tcpct_s_data_desired; u_int16_t tcpct_used; u_int8_t tcpct_value[TCP_MSS_DEFAULT]; }; #endif /* Misc. */ __POP_FC_STDLIB #endif /* netinet/tcp.h */ frama-c-Phosphorus-20170501/share/libc/netinet/in.h0000644000175000017500000002653213113745006020637 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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 "../features.h" #include "inttypes.h" #include "sys/socket.h" __BEGIN_DECLS 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; }; struct in6_pktinfo { struct in6_addr ipi6_addr; int ipi6_ifindex; }; /* 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 }; /*** originally 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. */ __END_DECLS #endif frama-c-Phosphorus-20170501/share/libc/__fc_define_fpos_t.h0000644000175000017500000000350613113745004022327 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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_FPOS_T_H #define __FC_DEFINE_FPOS_T_H #include "features.h" __PUSH_FC_STDLIB __BEGIN_DECLS struct __fc_pos_t { unsigned long __fc_stdio_position; }; typedef struct __fc_pos_t fpos_t; __END_DECLS __POP_FC_STDLIB #endif frama-c-Phosphorus-20170501/share/libc/tgmath.h0000644000175000017500000000325313113745003020037 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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-Phosphorus-20170501/share/Makefile.dynamic0000644000175000017500000002410513113745005020555 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2017 # # CEA (Commissariat à l'énergie atomique et aux énergies # # alternatives) # # # # you can redistribute it and/or modify it under the terms of the GNU # # Lesser General Public License as published by the Free Software # # Foundation, version 2.1. # # # # It is distributed in the hope that it will be useful, # # but WITHOUT ANY WARRANTY; without even the implied warranty of # # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # # GNU Lesser General Public License for more details. # # # # See the GNU Lesser General Public License version 2.1 # # for more details (enclosed in the file licenses/LGPLv2.1). # # # ########################################################################## $(eval $(call assert_defined,PLUGIN_NAME)) PLUGIN_ENABLE ?=yes PLUGIN_DIR ?=. FRAMAC_SRC ?=$(PLUGIN_DIR)/../../.. FRAMAC_INTERNAL ?=no ifndef MAKECONFIG_DIR MAKECONFIG_DIR :=$(FRAMAC_SHARE) endif ifndef PLUGIN_DYNAMIC PLUGIN_DYNAMIC :=yes endif #Do not generate documentation for this. PLUGIN_UNDOC:=$(PLUGIN_UNDOC) ifeq ($(FRAMAC_INTERNAL),yes) ## The plugin is not compiled from an installed frama-c, ie ## internal plugin (in src/plugins or added during ## ./configure with --enable-external) PLUGIN_RESET :=yes else # The plugin is compiled from an installed frama-c PLUGIN_RESET :=no include $(MAKECONFIG_DIR)/Makefile.common include $(MAKECONFIG_DIR)/Makefile.dynamic_config tests:: external_tests 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_INTERNAL),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_INTERNAL),yes) install-doc-code:: $(PLUGIN_NAME)_INSTALL_DOC endif $(PLUGIN_NAME)_INSTALL_DOC: plugin-doc/$(PLUGIN_NAME) $(PRINT_CP) $(patsubst %_INSTALL_DOC,%,$@) Documentation $(MKDIR) $(DOC_DIR)/$(@:%_INSTALL_DOC=%) $(CP) $(patsubst %,"%",\ $(wildcard $($(@:%_INSTALL_DOC=%_DOC_DIR))/*.css \ $($(@:%_INSTALL_DOC=%_DOC_DIR))/*.html \ $($(@:%_INSTALL_DOC=%_DOC_DIR))/*.png)) \ $(DOC_DIR)/$(@:%_INSTALL_DOC=%) endif #PLUGIN_ENABLE endif #FRAMAC_INTERNAL #Must be defined before section TESTS, because function call in make #replace not only $(1) but all the other $(..) PLUGIN_LIB_DIR ?= $(PLUGIN_DIR) PLUGIN_GUI_LIB_DIR ?= $(PLUGIN_DIR)/gui PLUGIN_INSTALL_DIR ?=$(DESTDIR)$(FRAMAC_PLUGINDIR) ######################## TESTS ################# .PHONY: $(PLUGIN_NAME)_TESTS plugins_ptests_config $(eval $(call assert_defined,PLUGIN_LIB_DIR)) $(eval $(call assert_defined,FRAMAC_SHARE)) $(eval $(call assert_defined,FRAMAC_LIB)) # Do not generate tests-related rules when PLUGIN_NO_TEST is set to 'no' but # there is no 'tests' directory. Typically useful for plugins released without # their tests. HAS_TESTS_DIR:=$(shell if test \! -d $(PLUGIN_DIR)/tests; then echo KO; fi) ifneq (,$(HAS_TESTS_DIR)$(PLUGIN_INTERNAL_TEST)$(PLUGIN_NO_TEST)) $(PLUGIN_NAME)_TESTS: else PTESTS_DEP:=$(PLUGIN_DIR)/Makefile $(FRAMAC_SHARE)/Makefile.dynamic plugins_ptests_config: $(PLUGIN_DIR)/tests/ptests_config define TESTS_template $(PLUGIN_DIR)/tests/ptests_config: $(PTESTS_DEP) $(PRINT_MAKING) $$@ $(MKDIR) tests $(RM) $$@ $(ECHO) "DEFAULT_SUITES=" $(PLUGIN_TESTS_DIRS) > $$@ $(ECHO) "TOPLEVEL_PATH=$(FRAMAC_OPT)" >> $$@; $(ECHO) "FRAMAC_SHARE=$(FRAMAC_SHARE)" >> $$@ $(ECHO) "FRAMAC_LIB=$(FRAMAC_LIB)" >> $$@ if test "$(FRAMAC_INTERNAL)" = "no"; then \ $(ECHO) "FRAMAC_PLUGIN=$(PLUGIN_LIB_DIR):$(PLUGIN_INSTALL_DIR)" >> $$@; \ $(ECHO) "FRAMAC_PLUGIN_GUI=$(PLUGIN_GUI_LIB_DIR):$(PLUGIN_INSTALL_DIR)/gui" >> $$@; \ $(ECHO) "OCAMLFIND_IGNORE_DUPS_IN=$(PLUGIN_INSTALL_DIR)" >> $$@; \ else \ $(ECHO) "FRAMAC_PLUGIN=$(PLUGIN_LIB_DIR)" >> $$@; \ $(ECHO) "FRAMAC_PLUGIN_GUI=$(PLUGIN_GUI_LIB_DIR)" >> $$@; \ fi $(ECHO) "OCAMLRUNPARAM=" >> $$@ $(CHMOD_RO) $$@ # OCAMLFIND_IGNORE_DUPS_IN in external mode allows to ignore a previous # installation of the currently tested plugin. # $(PLUGIN_NAME)_DEFAULT_TESTS allows plugins to define rules that at # the same time depend on $(PLUGIN_NAME)_DEFAULT_TESTS and # $(PLUGIN_NAME)_TESTS depend on them .PHONY: $(PLUGIN_NAME)_DEFAULT_TESTS $(PLUGIN_NAME)_DEFAULT_TESTS: $$(TARGETS) $$(TARGETS_TOP) $$(TARGETS_GUI) $(PLUGIN_DIR)/tests/ptests_config $(PRINT) TESTING PLUG-IN $(PLUGIN_NAME) cd $(PLUGIN_DIR) && \ time -p $(PTESTS) $$(PTESTS_OPTS) $(PLUGIN_PTESTS_OPTS) $(PLUGIN_NAME)_TESTS: $(PLUGIN_NAME)_DEFAULT_TESTS endef $(eval $(call TESTS_template)) external_tests: $(PLUGIN_NAME)_TESTS endif ################################################ PLUGIN_FLAGS:=$(FLAGS) $(DEBUG) $(FRAMAC_INCLUDES) PLUGIN_BFLAGS:=$(PLUGIN_FLAGS) $(PLUGIN_BFLAGS) PLUGIN_OFLAGS:=$(PLUGIN_FLAGS) $(PLUGIN_OFLAGS) ifeq ($(FRAMAC_INTERNAL),yes) PLUGIN_DEPFLAGS:=$(PLUGIN_DEPFLAGS) else PLUGIN_DEPFLAGS:=$(FRAMAC_INCLUDES) $(PLUGIN_DEPFLAGS) PLUGIN_DOC_DIR:=$(PLUGIN_DIR)/doc/code endif # For plugins that depends on the API of other ones, we need to add the # directory where the plugins' .cmi are compiled PLUGIN_DOCFLAGS:=\ $(FRAMAC_INCLUDES) -I $(FRAMAC_COMPILED_PLUGINDIR) $(PLUGIN_DOCFLAGS) $(eval $(call include_generic_plugin_Makefile,$(PLUGIN_NAME))) TARGETS := $(TARGET_META) $(TARGET_CMI) TARGETS_TOP := $(TARGET_TOP_CMO) $(TARGET_TOP_CMX) \ $(TARGET_TOP_CMA) $(TARGET_TOP_CMXS) TARGETS_GUI := $(TARGET_GUI_CMI) $(TARGET_GUI_CMO) \ $(TARGET_GUI_CMX) $(TARGET_GUI_CMXS) TARGETS_BYTE:= $(TARGET_META) $(TARGET_CMI) $(TARGET_TOP_CMO) $(TARGET_TOP_CMA) TARGETS_OPT:= $(TARGET_META) $(TARGET_CMI) $(TARGET_TOP_CMX) $(TARGET_TOP_CMXS) byte:: $(TARGETS_BYTE) opt:: $(TARGETS_OPT) gui:: $(TARGETS_GUI) # do not define additional targets if you come from the Frama-C Makefile ifneq ($(FRAMAC_INTERNAL),yes) ################## # Static Linking # ################## include $(MAKECONFIG_DIR)/Makefile.kernel $(PLUGIN_DIR)/frama-c-$(PLUGIN_NAME).byte$(EXE): $(TARGET_TOP_CMO) $(PRINT_LINKING) $@ $(OCAMLC) $(PLUGIN_LINK_BFLAGS) $(DYN_BLINKFLAGS) \ -o $@ $(DYN_BYTE_LIBS) $(DYN_GEN_BYTE_LIBS) \ $(patsubst %boot.cmo,\ $(PLUGIN_EXTRA_BYTE) $(TARGET_TOP_CMO) %boot.cmo,\ $(DYN_ALL_BATCH_CMO)) $(PLUGIN_DIR)/frama-c-$(PLUGIN_NAME).opt$(EXE): $(TARGET_TOP_CMX) $(PRINT_LINKING) $@ $(OCAMLOPT) $(PLUGIN_LINK_OFLAGS) $(DYN_OLINKFLAGS) \ -o $@ $(DYN_OPT_LIBS) $(DYN_GEN_OPT_LIBS) \ $(patsubst %boot.cmx,\ $(PLUGIN_EXTRA_OPT) $(TARGET_TOP_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) ################### # Clean & Install # ################### .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,$@))/tests/ptests_config $(RM) frama-c-$($(patsubst %_CLEAN_DYNAMIC,,$@)) \ frama-c-$($(patsubst %_CLEAN_DYNAMIC,,$@)).byte dist-clean distclean: $(PLUGIN_DIR)/$(PLUGIN_NAME)_DIST_CLEAN STATIC= all:: $(PLUGIN_DIR)/.depend byte $(OCAMLBEST) gui $(STATIC) plugins_ptests_config ifneq ($(PLUGIN_ENABLE),no) install:: $(PRINT_CP) $(PLUGIN_INSTALL_DIR) $(MKDIR) $(PLUGIN_INSTALL_DIR)/top $(CP) $(TARGETS) $(PLUGIN_INSTALL_DIR) $(CP) $(TARGETS_TOP) $(PLUGIN_INSTALL_DIR)/top $(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) $(RM) $(PLUGIN_INSTALL_DIR)/META.$(PLUGIN_PKG) $(RM) $(PLUGIN_INSTALL_DIR)/$(PLUGIN_NAME).* $(RM) $(BINDIR)/frama-c-$(PLUGIN_NAME).* ifeq ($(HAS_GUI),yes) $(RM) $(PLUGIN_INSTALL_DIR)/gui/$(PLUGIN_NAME).* endif endif # PLUGIN_ENABLE <> no ########## # Merlin # ########## .PHONY: merlin_plugin merlin_plugin:: echo "B $(FRAMAC_LIBDIR)" > .merlin echo "B $(FRAMAC_LIBDIR)/plugins" >> .merlin echo "B $(FRAMAC_LIBDIR)/plugins/gui" >> .merlin echo "PKG ocamlgraph" >> .merlin echo "PKG zarith" >> .merlin echo "PKG lablgtk2" >> .merlin ############ # Cleaning # ############ clean:: $(PLUGIN_DIR)/$(PLUGIN_NAME)_CLEAN; ################ # Generic part # ################ include $(MAKECONFIG_DIR)/Makefile.generic endif # FRAMAC_INTERNAL <> yes PLUGIN_PTESTS_OPTS:= ############################################################################### # Local Variables: # mode: makefile # End: frama-c-Phosphorus-20170501/share/machdep.c0000644000175000017500000002545413113745010017243 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). */ /****************************************************************************/ #include "../config.h" #include #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_WCHAR_H #include #endif #define COMPILER "other" #ifdef __TURBOC__ #define LONGLONG long long #define CONST_STRING_LITERALS "false" #define VERSION __TURBOC__ #define VERSION_MAJOR 0 #define VERSION_MINOR 0 #endif #ifdef __GNUC__ #define LONGLONG long long #define CONST_STRING_LITERALS "true" #define VERSION __VERSION__ #define VERSION_MAJOR __GNUC__ #define VERSION_MINOR __GNUC_MINOR__ #undef COMPILER #define COMPILER "gcc" #endif #ifdef _MSVC #define LONGLONG __int64 #define CONST_STRING_LITERALS "false" #define VERSION "Microsoft C" #define VERSION_MAJOR (_MSC_VER / 100) #define VERSION_MINOR (_MSC_VER % 100) #undef COMPILER #define COMPILER "msvc" #endif #ifndef __TURBOC__ #ifndef __GNUC__ #ifndef _MSVC #error "Please define one of __TURBOC__ __GNUC__ _MSVC." #endif #endif #endif /* The type for the machine dependency structure is generated from the Makefile */ int main() { fprintf(stderr, "Generating machine dependency information for CIL\n"); printf("(* Generated by code in %s *)\n", __FILE__); printf("open Cil_types\n"); printf("let mach = {\n"); // printf("\t version_major = %d;\n", VERSION_MAJOR); // printf("\t version_minor = %d;\n", VERSION_MINOR); #ifdef __TURBOC__ printf("\t version = \"%d\";\n", VERSION); #else printf("\t version = \"%s\";\n", VERSION); #endif // Size of certain types printf("\t sizeof_short = %lu;\n", sizeof(short)); printf("\t sizeof_int = %lu;\n", sizeof(int)); printf("\t sizeof_long = %lu;\n", sizeof(long)); printf("\t sizeof_longlong = %lu;\n", sizeof(LONGLONG)); printf("\t sizeof_ptr = %lu;\n", sizeof(int *)); printf("\t sizeof_float = %lu;\n", sizeof(float)); printf("\t sizeof_double = %lu;\n", sizeof(double)); printf("\t sizeof_longdouble = %lu;\n", sizeof(long double)); printf("\t sizeof_void = %lu;\n", #ifdef __TURBOC__ 0 #else sizeof(void) #endif ); printf("\t sizeof_fun = %lu;\n", #ifdef __GNUC__ sizeof(main) #else 0 #endif ); // definition of size_t { printf("\t size_t = \"%s\";\n", TYPE_SIZE_T); printf("\t wchar_t = \"%s\";\n", TYPE_WCHAR_T); printf("\t ptrdiff_t = \"%s\";\n", TYPE_PTRDIFF_T); } // The alignment of a short { struct shortstruct { char c; short s; }; printf("\t alignof_short = %z;\n", (size_t)(&((struct shortstruct*)0)->s)); } // The alignment of an int { struct intstruct { char c; int i; }; printf("\t alignof_int = %z;\n", (size_t)(&((struct intstruct*)0)->i)); } // The alignment of a long { struct longstruct { char c; long l; }; printf("\t alignof_long = %z;\n", (size_t)(&((struct longstruct*)0)->l)); } // The alignment of long long { struct longlong { char c; LONGLONG ll; }; printf("\t alignof_longlong = %z;\n", (size_t)(&((struct longlong*)0)->ll)); } // The alignment of a ptr { struct ptrstruct { char c; int * p; }; printf("\t alignof_ptr = %z;\n", (size_t)(&((struct ptrstruct*)0)->p)); } // Unnamed members { struct S0 { int; // If you are reading this, it's probably because your C compiler // rejected the above. Good for you! It is not allowed by C99. // See discussion thread at: // http://lists.cs.uiuc.edu/pipermail/c-semantics/2011-August/thread.html // You can comment out this block. int f1; }; if (sizeof(struct S0) != 2*sizeof(int)) { printf("(* WARNING: This compiler handles unnamed struct members\n"); printf(" differently from Frama-C.\n"); printf(" To be analyzed correctly, your programs must *NOT* use\n"); printf(" this language extension. *)\n"); } } // long long bit-fields { struct LLS { long long int f:2; // If you are reading this, it's probably because your C compiler // rejected the above. Good for you! It is only allowed by C99 // as an extension. // You can comment out this block. } lls; if (sizeof(1 + lls.f) != sizeof(int)) { printf("(* WARNING: This compiler handles long long bit-fields\n"); printf(" differently from Frama-C.\n"); printf(" To be analyzed correctly, your programs must *NOT* use\n"); printf(" this language extension. *)\n"); } } // The alignment of a float { struct floatstruct { char c; float f; }; printf("\t alignof_float = %z;\n", (size_t)(&((struct floatstruct*)0)->f)); } // The alignment of double { struct s1 { char c; double d; }; printf("\t alignof_double = %z;\n", (size_t)(&((struct s1*)0)->d)); } // The alignment of long double { struct s1 { char c; long double ld; }; printf("\t alignof_longdouble = %z;\n", (size_t)(&((struct s1*)0)->ld)); } printf("\t alignof_str = %lu;\n", #ifdef __GNUC__ __alignof("a string") #else 0 #endif ); printf("\t alignof_fun = %lu;\n", #ifdef __GNUC__ __alignof(main) #else 0 #endif ); // The alignment of char array { struct s1 { char c; char ca[2]; }; // printf("\t alignof_char_array = %lu;\n", // (int)(&((struct s1*)0)->ca)); } /* The alignment of an __aligned__ type */ { #ifdef __TURBOC__ printf("\t alignof_aligned = 8;\n"); #else char __attribute__((aligned)) c; long double __attribute__((aligned)) ld; if (__alignof(c) != __alignof(ld)) { printf("(*__attribute__((aligned)) has a different effect \ on different types. alignments may be computed \ incorrectly.*)\n"); }; printf("\t alignof_aligned = %lu;\n",__alignof(c)); #endif } // Whether char is unsigned printf("\t char_is_unsigned = %s;\n", ((char)0xff) > 0 ? "true" : "false"); // Whether int bit-field is unsigned { union { signed int init ; struct { int width8 : 8; } sign ; } bitfield; bitfield.init=-1; printf("\t (* int_bitfield_is_unsigned = %s; *)\n", (bitfield.sign.width8 > 0 ? "true" : "false")); if (bitfield.sign.width8 > 0) { // 'int width8 : 8' is an unsigned bit-field. printf("(* WARNING: This compiler handles int bit-fields\n"); printf(" differently from Frama-C.\n"); printf(" To be analyzed correctly, your programs must *NOT* use\n"); printf(" 'int' bit-fields, but 'unsigned int' bit-fields. *)\n"); } } // Whether string literals contain constant characters puts("\t const_string_literals = " CONST_STRING_LITERALS ";"); // endianity { int e = 0x11223344; printf("\t little_endian = %s;\n", (0x44 == *(char*)&e) ? "true" : ((0x11 == *(char*)&e) ? "false" : (exit(1), "false"))); } // __builtin_val_list { #ifdef HAVE_BUILTIN_VA_LIST printf("\t has__builtin_va_list = true;\n"); #else printf("\t has__builtin_va_list = false;\n"); #endif } // __thread_is_keyword { #ifdef THREAD_IS_KEYWORD printf("\t __thread_is_keyword = true;\n"); #else printf("\t __thread_is_keyword = false;\n"); #endif } // underscore_name { #ifdef UNDERSCORE_NAME printf("\t underscore_name = true;\n"); #else printf("\t underscore_name = false;\n"); #endif } // compiler { printf("\t compiler = \"" COMPILER "\""); } printf("}\n"); exit(0); } frama-c-Phosphorus-20170501/share/theme/0000755000175000017500000000000013113744777016611 5ustar mehdimehdiframa-c-Phosphorus-20170501/share/theme/colorblind/0000755000175000017500000000000013113744777020740 5ustar mehdimehdiframa-c-Phosphorus-20170501/share/theme/colorblind/valid_under_hyp.png0000644000175000017500000000034413113744734024614 0ustar mehdimehdiPNG  IHDRh6 pHYs  tIME %otEXtCommentCreated with GIMPW^IDAT(ϝA 1M9{JQmNL`f4 җCw'΄]-LKw٥_tpΕtLr=6j-r'.yFIENDB`frama-c-Phosphorus-20170501/share/theme/colorblind/valid_but_dead.png0000644000175000017500000000034613113744734024370 0ustar mehdimehdiPNG  IHDRh6 pHYs  tIME'mȎtEXtCommentCreated with GIMPW`IDAT(ϝQA02m C$ uo0ӥw~8TfXcIo޸џ>jC0J亼,7 6 oRIENDB`frama-c-Phosphorus-20170501/share/theme/colorblind/considered_valid.png0000644000175000017500000000034713113744734024741 0ustar mehdimehdiPNG  IHDRh6 pHYs  tIME8nXtEXtCommentCreated with GIMPWaIDAT(ϝRA dd!('%--0 \@Ht=[*-vvD<'p'աhx5Y '.aLIENDB`frama-c-Phosphorus-20170501/share/theme/colorblind/surely_valid.png0000644000175000017500000000034013113744734024136 0ustar mehdimehdiPNG  IHDRh6 pHYs  tIME 箌tEXtCommentCreated with GIMPWZIDAT(ϕA![6A%6)qAdL;Y+j ΃|zOz 9E_s]٠X}g0$ IENDB`frama-c-Phosphorus-20170501/share/theme/colorblind/invalid_under_hyp.png0000644000175000017500000000034213113744734025141 0ustar mehdimehdiPNG  IHDRh6 pHYs  tIME F4wtEXtCommentCreated with GIMPW\IDAT(ϽPA0i/- qD]6uO-=StI>/^}07ϰHΗ_~fMϞ\菽5^C!2xIENDB`frama-c-Phosphorus-20170501/share/theme/colorblind/never_tried.png0000644000175000017500000000025113113744734023743 0ustar mehdimehdiPNG  IHDRh6 pHYs  tIME &"tEXtCommentCreated with GIMPW#IDAT(c` 0200XՌL0aT4 JܐyIENDB`frama-c-Phosphorus-20170501/share/theme/colorblind/invalid_but_dead.png0000644000175000017500000000035113113744734024713 0ustar mehdimehdiPNG  IHDRh6 pHYs  tIME#-tEXtCommentCreated with GIMPWcIDAT(ϝR[ *d2X8K6jv$!)QG]_N{;'ñCe)3+uˈsYeCW8.)3nV9!IENDB`frama-c-Phosphorus-20170501/share/theme/colorblind/unknown_but_dead.png0000644000175000017500000000034413113744734024766 0ustar mehdimehdiPNG  IHDRh6 pHYs  tIME&g'tEXtCommentCreated with GIMPW^IDAT(ϭP[ kra f| >EH. I :HNMOڑ?s8 mtzYV-2PV;sIENDB`frama-c-Phosphorus-20170501/share/theme/colorblind/surely_invalid.png0000644000175000017500000000035013113744734024466 0ustar mehdimehdiPNG  IHDRh6 pHYs  tIME }T7tEXtCommentCreated with GIMPWbIDAT(ϕQ Cg~m>"⯛TH_*o *ri8zK*#}y&}Bݘܸ32nj<~|[xf6&ECIENDB`frama-c-Phosphorus-20170501/share/theme/colorblind/inconsistent.png0000644000175000017500000000022613113744734024157 0ustar mehdimehdiPNG  IHDRh6 pHYs  tIME ,CtEXtCommentCreated with GIMPWIDAT(c``hmIENDB`frama-c-Phosphorus-20170501/share/theme/colorblind/unknown.png0000644000175000017500000000033313113744734023135 0ustar mehdimehdiPNG  IHDRh6 pHYs  tIME 7[tEXtCommentCreated with GIMPWUIDAT(ϕRA0+/mIv%-bU^84Sc)HB|f l|[Re*{K4@/,IENDB`frama-c-Phosphorus-20170501/share/theme/default/0000755000175000017500000000000013113744777020235 5ustar mehdimehdiframa-c-Phosphorus-20170501/share/theme/default/valid_under_hyp.png0000644000175000017500000000314313113744734024111 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`Ҳ䍐.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-Phosphorus-20170501/share/theme/default/valid_but_dead.png0000644000175000017500000000307213113744734023664 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-Phosphorus-20170501/share/theme/default/considered_valid.png0000644000175000017500000000312213113744734024230 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`Ҳ䍐.Њ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-Phosphorus-20170501/share/theme/default/never_tried.png0000644000175000017500000000276413113744734023253 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`Ҳ䍐.: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`Ҳ䍐.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-Phosphorus-20170501/share/theme/default/surely_invalid.png0000644000175000017500000000302313113744734023763 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-Phosphorus-20170501/share/theme/default/inconsistent.png0000644000175000017500000000276413113744734023465 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`Ҳ䍐.9<<P$`?5@I* 4H\\\=@H$b06 VEp\[ZE;/b*= 0,H_IENDB`frama-c-Phosphorus-20170501/share/theme/default/unknown.png0000644000175000017500000000303013113744734022427 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`Ҳ䍐.{CpJM+Na"9>/SoӰ9DvY3؍GH˱ %Z^TlyIENDB`frama-c-Phosphorus-20170501/share/frama-c.ico0000644000175000017500000026024613113744734017514 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-Phosphorus-20170501/share/Makefile.common0000644000175000017500000002412213113745003020416 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2017 # # CEA (Commissariat à l'énergie atomique et aux énergies # # alternatives) # # # # you can redistribute it and/or modify it under the terms of the GNU # # Lesser General Public License as published by the Free Software # # Foundation, version 2.1. # # # # It is distributed in the hope that it will be useful, # # but WITHOUT ANY WARRANTY; without even the implied warranty of # # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # # GNU Lesser General Public 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 FRAMAC_SRC_DIRS= plugins/slicing_types plugins/pdg_types plugins/value_types \ libraries/stdlib libraries/utils \ libraries/project libraries/datatype \ kernel_internals/parsing \ kernel_internals/typing \ kernel_internals/runtime \ kernel_services/parsetree \ kernel_services/ast_data \ kernel_services/ast_queries \ kernel_services/ast_printing \ kernel_services/cmdline_parameters \ kernel_services/plugin_entry_points \ kernel_services/abstract_interp \ kernel_services/visitors \ kernel_services/analysis \ kernel_services/ast_transformations \ plugins/gui FRAMAC_SRC_DIRS:= $(addprefix src/, $(FRAMAC_SRC_DIRS)) ################# # OCaml version # ################# # Cumulative semantics: HAS_OCAMLnnn should be set if OCaml version is mmm # with mmm >= nnn # findstring returns an empty string if it does not match, and the value it # searches if it matches. Hence we compare with the empty string HAS_OCAML403=no ifeq ($(findstring 4.02,$(OCAMLVERSION)),) HAS_OCAML403 = yes endif ################## # Flags # ################## # Flags to be used by ocamlc and ocamlopt when compiling Frama-C # itself. For development versions, we add -warn-error for most # warnings -warn-error has effect only for warnings that are # explicitly set using '-w'. ifeq ($(DEVELOPMENT),yes) # Most warnings are activated by default. Those settings are inherited # in the compilation of external plugins. # - 4 (fragile pattern-matching) only make sense when adding a node to a type. # OCaml GPR #1071 will make it usable # - 6 (omit label in application) would make code clearer, but requires # refactoring before being enabled. # - 9 (missing field in record pattern) is much too heavy. Most of the time # not all fields are relevant in patter-matching Frama-C's AST. # - 41 (ambiguous constructor or label name) prevents type-based # disambiguation, a feature which is seen as a good thing by many developers # - 44 (open shadows an identifier) # - 45 (open shadows a label or constructor): While the use of open directives # is supposed to stay small, it should still be possible to open modules # that share common names, barring some mechanism to open only parts of a # module. # - 48 (implicit elimination of optional arguments): makes use of functions # with optional arguments heavier in higher-order context WARNINGS ?= -w +a-4-6-9-41-44-45-48-50 # - 3 (deprecated feature) cannot always be avoided for OCaml stdlib when # supporting several OCaml versions # - 4 (fragile pattern matching) will be activated when adding a node (see # above), in order to let the developer decide whether a case should be # added on relevant fragile pattern or not: a matching might very well stay # fragile without triggering an error. # - 3x (various categories of unused identifiers) it is sometimes useful to # let code compile despite such warnings when in the middle of a development. # On the other hand, a completed feature should not trigger such warnings. # - 58 (missing cmx) is triggered by some versions of external libraries. # Situation should probably improve as these libraries get updated, leading # to treat this warning as error. WARN_ERROR ?= -warn-error +a-3-4-32-33-34-35-36-37-38-39-58 else WARNINGS ?= -w -a endif #DEVELOPMENT FLAGS = $(WARNINGS) $(WARN_ERROR) $(OCAML_ANNOT_OPTION) -strict-sequence \ -safe-string 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 ################## # 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 CP_IF_DIFF = sh -c \ 'if cmp -s $$1 $$2; \ then touch -r $$2 $$1; \ else echo "Generating $$2"; install $$1 $$2; fi' cpifdiff #follow symbolic link CP_L = cp -fL 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 GIT = git ################## # Make commands # ################## map=$(foreach a,$(2),$(call $(1),$(a))) define assert_defined ifndef $(1) $$(error Undefined variable $(1) please report.) endif endef ########################### # 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_CC =$(PRINT) 'CC '# 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 # ######### ################# # Documentation # ################# NATIVE_OCAMLDOC:=$(shell ocamlfind ocamldoc -v | grep -o ocamldoc.opt) ifeq ("$(NATIVE_OCAMLDOC)","ocamldoc.opt") DOC_PLUGIN=$(DOC_DIR)/docgen.cmxs else DOC_PLUGIN=$(DOC_DIR)/docgen.cmo endif ########################## # Plugin File Generation # ########################## #take the name of the plugin as argument $(1) define include_generic_plugin_Makefile $(call assert_defined,PLUGIN_DIR) $(PLUGIN_DIR)/.Makefile.plugin.generated: $(MAKECONFIG_DIR)/Makefile.plugin.template $(PRINT_MAKING) $$@ $(SED) -e "s/@PLUGIN_NAME@/$(1)/g" $$< > $$@ # We still clean the old Makefile.plugin.generated (without the dot) temporarily clean:: rm -rf $(PLUGIN_DIR)/.Makefile.plugin.generated rm -rf $(PLUGIN_DIR)/Makefile.plugin.generated #We always define this variable because it can't wait the generation #of the Makefile.plugin.generated since the targets of rules defined in the #Makefile of the plugins could use this variable $(1)_DIR:=$(PLUGIN_DIR) sinclude $(PLUGIN_DIR)/.Makefile.plugin.generated endef %.check_mli_exists: %.mli touch $@ .PHONY:common_force_rule %.check_mli_exists: common_force_rule $(error "The file '$*.mli' must be provided. The simplest workaround is 'touch $*.mli') ########################################################################## # Local Variables: # compile-command: "make" # mode: makefile # End: frama-c-Phosphorus-20170501/share/frama-c.WIN32.rc0000644000175000017500000000347213113745006020134 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2017 # # CEA (Commissariat à l'énergie atomique et aux énergies # # alternatives) # # # # you can redistribute it and/or modify it under the terms of the GNU # # Lesser General Public License as published by the Free Software # # Foundation, version 2.1. # # # # It is distributed in the hope that it will be useful, # # but WITHOUT ANY WARRANTY; without even the implied warranty of # # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # # GNU Lesser General Public 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-Phosphorus-20170501/Makefile0000644000175000017500000021000713113745003016024 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2017 # # CEA (Commissariat à l'énergie atomique et aux énergies # # alternatives) # # # # you can redistribute it and/or modify it under the terms of the GNU # # Lesser General Public License as published by the Free Software # # Foundation, version 2.1. # # # # It is distributed in the hope that it will be useful, # # but WITHOUT ANY WARRANTY; without even the implied warranty of # # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # # GNU Lesser General Public 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 include share/Makefile.dynamic_config.internal #Check share/Makefile.config available ifndef FRAMAC_ROOT_SRCDIR $(error "You should run ./configure first (or autoconf if there is no configure)") endif ################### # Frama-C Version # ################### VERSION:=$(shell $(SED) -e 's/\(\.*\)/\1/' VERSION) VERSION_PREFIX = $(shell $(SED) -e 's/\([a-zA-Z]\+-[0-9]\+\).*/\1/' VERSION) ########################### # Global plugin variables # ########################### # the directory where compiled plugin non-GUI files are stored PLUGIN_TOP_LIB_DIR= $(PLUGIN_LIB_DIR)/top # the directory where compiled plugin GUI files are stored PLUGIN_GUI_LIB_DIR= $(PLUGIN_LIB_DIR)/gui # the directory where the other Makefiles are FRAMAC_SHARE = share # 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_GENERATED_LIST:= PLUGIN_DYN_EXISTS:="no" PLUGIN_DYN_LIST := PLUGIN_CMO_LIST := PLUGIN_CMX_LIST := PLUGIN_META_LIST := PLUGIN_DYN_CMI_LIST := PLUGIN_DYN_CMO_LIST := PLUGIN_DYN_CMX_LIST := PLUGIN_INTERNAL_CMO_LIST:= PLUGIN_INTERNAL_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:= ############################### # Additional global variables # ############################### # put here any config option for the binary distribution outside of # plugins CONFIG_DISTRIB_BIN:= # Directories containing some source code SRC_DIRS= ptests $(PLUGIN_LIB_DIR) $(FRAMAC_SRC_DIRS) # Directory containing source code documentation DOC_DIR = doc/code # Source files to document MODULES_TODOC= # Directories to include when compiling INCLUDES=$(addprefix -I ,$(FRAMAC_SRC_DIRS)) -I $(PLUGIN_LIB_DIR) ifneq ($(ENABLE_GUI),no) GUI_INCLUDES = $(addprefix -package ,$(LIBRARY_NAMES_GUI)) else GUI_INCLUDES = endif # Files for which dependencies must be computed computed. # Other files are added later in this Makefile. FILES_FOR_OCAMLDEP+=$(PLUGIN_LIB_DIR)/*.mli BFLAGS = $(PACKAGES) $(FLAGS) $(DEBUG) $(INCLUDES) \ $(FRAMAC_USER_FLAGS) OFLAGS = $(PACKAGES) $(FLAGS) $(DEBUG) $(INCLUDES) -compact \ $(FRAMAC_USER_FLAGS) BLINKFLAGS += -linkpkg $(BFLAGS) -linkall -custom OLINKFLAGS += -linkpkg $(OFLAGS) -linkall DOC_FLAGS= -colorize-code -stars -m A -hide-warnings $(PACKAGES) $(INCLUDES) $(GUI_INCLUDES) # Files that depend on external libraries -namely Zarith- whose interface # has not been explicitely declared -opaque, hence would trigger warning 58. # This can't be solve by Frama-C itself, we can only wait for an update of # said library. NON_OPAQUE_DEPS:= # Libraries generated by Frama-C GEN_BYTE_LIBS= GEN_OPT_LIBS= # Libraries used in Frama-C EXTRA_OPT_LIBS:= PACKAGES = $(addprefix -package ,$(LIBRARY_NAMES)) BYTE_LIBS = $(GEN_BYTE_LIBS) OPT_LIBS = $(EXTRA_OPT_LIBS) OPT_LIBS+= $(GEN_OPT_LIBS) ICONS:= $(addprefix share/,\ frama-c.ico frama-c.png unmark.png \ switch-on.png switch-off.png ) FEEDBACK_ICONS_NAMES:= \ 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 FEEDBACK_ICONS_DEFAULT:= \ $(addprefix share/theme/default/,$(FEEDBACK_ICONS_NAMES)) FEEDBACK_ICONS_COLORBLIND:= \ $(addprefix share/theme/colorblind/,$(FEEDBACK_ICONS_NAMES)) ROOT_LIBC_DIR:= share/libc LIBC_SUBDIRS:= sys netinet linux net arpa LIBC_DIR:= $(ROOT_LIBC_DIR) $(addprefix $(ROOT_LIBC_DIR)/,$(LIBC_SUBDIRS)) LIBC_FILES:= \ $(wildcard share/*.h share/*.c) \ $(wildcard $(addsuffix /*.h,$(LIBC_DIR))) \ $(wildcard $(addsuffix /*.c,$(LIBC_DIR))) \ $(ROOT_LIBC_DIR)/__fc_builtin_for_normalization.i # Checks that all .h can be included multiple times. ALL_LIBC_HEADERS:=$(wildcard share/*.h $(addsuffix /*.h,$(LIBC_DIR))) check-libc: bin/toplevel.$(OCAMLBEST)$(EXE) @echo "checking libc..."; \ EXIT_VALUE=0; \ for file in $(filter-out share/builtin.h,$(ALL_LIBC_HEADERS)); do \ echo "#include \"$$file\"" > check-libc.c; \ echo "#include \"$$file\"" >> check-libc.c; \ FRAMAC_SHARE=share bin/toplevel.$(OCAMLBEST)$(EXE) \ -cpp-extra-args="-Ishare/libc -nostdinc" check-libc.c \ > $$(basename $$file .h).log 2>&1; \ if test $$? -ne 0; then \ if grep -q -e '#error "Frama-C:' $$file; then : ; \ else \ echo "$$file cannot be included twice. \ Output is in $$(basename $$file .h).log"; \ EXIT_VALUE=1; \ fi; \ else \ rm $$(basename $$file .h).log; \ fi; \ done; \ rm check-libc.c; \ exit $$EXIT_VALUE clean-check-libc: $(RM) *.log # 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:=\ $(wildcard bin/*2*.sh) bin/local_export.sh \ bin/frama-c bin/frama-c.byte bin/frama-c-gui bin/frama-c-gui.byte \ share/frama-c.WIN32.rc share/frama-c.Unix.rc \ $(ICONS) $(FEEDBACK_ICONS_DEFAULT) $(FEEDBACK_ICONS_COLORBLIND) \ man/frama-c.1 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/toc_head.htm \ doc/code/toc_tail.htm \ doc/Makefile \ $(filter-out ptests/ptests_config.ml,$(wildcard ptests/*.ml*)) \ configure.in Makefile Makefile.generating \ Changelog config.h.in \ VERSION $(wildcard licenses/*) \ $(LIBC_FILES) \ $(wildcard share/emacs/*.el) share/autocomplete_frama-c \ share/configure.ac \ share/Makefile.config.in share/Makefile.common \ share/Makefile.generic \ share/Makefile.plugin.template share/Makefile.dynamic \ share/Makefile.dynamic_config.external \ share/Makefile.dynamic_config.internal \ $(filter-out src/kernel_internals/runtime/config.ml, \ $(wildcard src/kernel_internals/runtime/*.ml*)) \ $(wildcard src/kernel_services/abstract_interp/*.ml*) \ $(wildcard src/plugins/gui/*.ml*) \ $(wildcard src/libraries/stdlib/*.ml*) \ $(wildcard src/libraries/utils/*.ml*) \ $(wildcard src/libraries/utils/*.c) \ $(wildcard src/libraries/project/*.ml*) \ $(filter-out src/kernel_internals/parsing/check_logic_parser.ml, \ $(wildcard src/kernel_internals/parsing/*.ml*)) \ $(wildcard src/kernel_internals/typing/*.ml*) \ $(wildcard src/kernel_services/ast_data/*.ml*) \ $(wildcard src/kernel_services/ast_queries/*.ml*) \ $(wildcard src/kernel_services/ast_printing/*.ml*) \ $(wildcard src/kernel_services/cmdline_parameters/*.ml*) \ $(wildcard src/kernel_services/analysis/*.ml*) \ $(wildcard src/kernel_services/ast_transformations/*.ml*) \ $(wildcard src/kernel_services/plugin_entry_points/*.ml*) \ $(wildcard src/kernel_services/visitors/*.ml*) \ $(wildcard src/kernel_services/parsetree/*.ml*) \ $(wildcard src/libraries/datatype/*.ml*) \ bin/sed_get_make_major bin/sed_get_make_minor \ INSTALL.md README.md .make-clean \ .make-clean-stamp .force-reconfigure \ opam/opam opam/descr opam/frama-c/opam opam/frama-c/descr \ opam/files/run_autoconf_if_needed.sh DISTRIB_TESTS=$(filter-out tests/non-free/%,$(shell git ls-files tests src/plugins/aorai/tests src/plugins/report/tests src/plugins/wp/tests)) # 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 # ################ # additional compilation targets for 'make all'. # cannot be delayed after 'make all' EXTRAS = ptests bin/frama-c-config$(EXE) ifneq ($(ENABLE_GUI),no) ifeq ($(HAS_LABLGTK),yes) EXTRAS += gui endif endif all:: byte $(OCAMLBEST) $(EXTRAS) plugins_ptests_config .PHONY: top opt byte dist bdist rebuild rebuild-branch dist: clean $(QUIET_MAKE) all clean-rebuild: clean $(QUIET_MAKE) all rebuild: config.status $(MAKE) smartclean $(MAKE) depend $(FRAMAC_PARALLEL) $(MAKE) all $(FRAMAC_PARALLEL) || \ (touch .force-reconfigure; \ $(MAKE) config.status && \ $(MAKE) depend $(FRAMAC_PARALLEL) && \ $(MAKE) all $(FRAMAC_PARALLEL)) sinclude .Makefile.user # Should defines FRAMAC_PARALLEL and FRAMAC_USER_FLAGS #Create link in share for local execution if .PHONY:create_share_link create_share_link: share/.gitignore share/.gitignore: share/Makefile.config if test -f $@; then \ for link in $$(cat $@); do rm -f share$$link; done; \ fi $(RM) $@.tmp touch $@.tmp $(foreach dir,$(EXTERNAL_PLUGINS),\ if test -d $(dir)/share; then \ echo "Sharing $(dir)/link"; \ ln -s $(realpath $(dir)/share) share/$(notdir $(dir)); \ echo /$(notdir $(dir)) >> $@.tmp; \ fi; ) mv $@.tmp $@ ifeq ("$(DEVELOPMENT)","yes") all:: share/.gitignore endif clean:: if test -f share/.gitignore; then \ for link in $$(cat share/.gitignore); do rm -f share$$link; done; \ rm share/.gitignore; \ fi ############## # Ocamlgraph # ############## # dgraph (included in ocamlgraph) #[LC] Cf https://github.com/backtracking/ocamlgraph/pull/32 ifeq ($(HAS_GNOMECANVAS),yes) ifneq ($(ENABLE_GUI),no) GRAPH_GUICMO= dgraph.cmo GRAPH_GUICMX= dgraph.cmx GRAPH_GUIO= dgraph.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 ################## # Frama-C Kernel # ################## # Libraries which could be compiled fully independently ####################################################### VERY_FIRST_CMO = src/kernel_internals/runtime/frama_c_init.cmo CMO += $(VERY_FIRST_CMO) LIB_CMO =\ src/libraries/stdlib/transitioning \ src/libraries/stdlib/FCSet \ src/libraries/stdlib/FCMap \ src/libraries/stdlib/FCBuffer \ src/libraries/stdlib/FCHashtbl \ src/libraries/stdlib/extlib \ src/libraries/datatype/unmarshal \ src/libraries/datatype/unmarshal_z \ src/libraries/datatype/structural_descr \ src/libraries/datatype/type \ src/libraries/datatype/descr \ src/libraries/utils/pretty_utils \ src/libraries/utils/hook \ src/libraries/utils/bag \ src/libraries/utils/wto \ src/libraries/utils/vector \ src/libraries/utils/indexer \ src/libraries/utils/rgmap \ src/libraries/utils/bitvector \ src/libraries/utils/qstack \ src/libraries/utils/leftistheap \ src/libraries/stdlib/integer \ src/libraries/utils/filepath \ src/libraries/utils/json GENERATED+= src/libraries/utils/json.ml NON_OPAQUE_DEPS+=\ src/libraries/datatype/unmarshal_z \ src/libraries/stdlib/integer LIB_CMO:= $(addsuffix .cmo,$(LIB_CMO)) CMO += $(LIB_CMO) # Very first files to be linked (most modules use them) ############################### FIRST_CMO= src/kernel_internals/runtime/config \ src/kernel_internals/runtime/gui_init \ src/kernel_services/plugin_entry_points/log \ src/kernel_services/cmdline_parameters/cmdline \ src/libraries/project/project_skeleton \ src/libraries/datatype/datatype \ src/kernel_services/plugin_entry_points/journal # 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 \ state_dependency_graph \ state_topological \ state_selection \ project \ state_builder PROJECT_CMO:= $(patsubst %,src/libraries/project/%.cmo,$(PROJECT_CMO)) CMO += $(PROJECT_CMO) # kernel ######## KERNEL_CMO=\ src/libraries/utils/utf8_logic.cmo \ src/libraries/utils/binary_cache.cmo \ src/libraries/utils/hptmap.cmo \ src/libraries/utils/hptset.cmo \ src/libraries/utils/escape.cmo \ src/kernel_services/ast_queries/cil_datatype.cmo \ src/kernel_services/cmdline_parameters/typed_parameter.cmo \ src/kernel_services/plugin_entry_points/dynamic.cmo \ src/kernel_services/cmdline_parameters/parameter_category.cmo \ src/kernel_services/cmdline_parameters/parameter_customize.cmo \ src/kernel_services/cmdline_parameters/parameter_state.cmo \ src/kernel_services/cmdline_parameters/parameter_builder.cmo \ src/kernel_services/plugin_entry_points/plugin.cmo \ src/kernel_services/plugin_entry_points/kernel.cmo \ src/libraries/utils/unicode.cmo \ src/kernel_services/plugin_entry_points/emitter.cmo \ src/libraries/utils/floating_point.cmo \ src/libraries/utils/rangemap.cmo \ src/kernel_services/ast_printing/cil_types_debug.cmo \ src/kernel_services/ast_printing/printer_builder.cmo \ src/libraries/utils/cilconfig.cmo \ src/kernel_internals/typing/alpha.cmo \ src/kernel_services/ast_queries/cil_state_builder.cmo \ src/kernel_internals/runtime/machdeps.cmo \ src/kernel_services/ast_queries/cil_const.cmo \ src/kernel_services/ast_queries/logic_env.cmo \ src/kernel_services/ast_queries/logic_const.cmo \ src/kernel_services/ast_queries/cil.cmo \ src/kernel_internals/parsing/errorloc.cmo \ src/kernel_services/ast_printing/cil_printer.cmo \ src/kernel_services/ast_printing/cil_descriptive_printer.cmo \ src/kernel_services/parsetree/cabs.cmo \ src/kernel_services/parsetree/cabshelper.cmo \ src/kernel_services/ast_printing/logic_print.cmo \ src/kernel_services/ast_queries/logic_utils.cmo \ src/kernel_internals/parsing/logic_parser.cmo \ src/kernel_internals/parsing/logic_lexer.cmo \ src/kernel_services/ast_queries/logic_typing.cmo \ src/kernel_services/ast_queries/ast_info.cmo \ src/kernel_services/ast_data/ast.cmo \ src/kernel_services/ast_data/globals.cmo \ src/kernel_services/ast_printing/cprint.cmo \ src/kernel_services/visitors/cabsvisit.cmo \ src/kernel_internals/typing/cabs2cil.cmo \ src/kernel_internals/typing/cfg.cmo \ src/kernel_services/ast_data/kernel_function.cmo \ src/kernel_services/ast_data/property.cmo \ src/kernel_services/ast_data/property_status.cmo \ src/kernel_services/ast_data/annotations.cmo \ src/kernel_services/ast_printing/printer.cmo \ src/kernel_internals/typing/logic_builtin.cmo \ src/kernel_services/ast_printing/cabs_debug.cmo \ src/kernel_internals/parsing/lexerhack.cmo \ src/kernel_internals/parsing/clexer.cmo \ src/kernel_internals/parsing/cparser.cmo \ src/kernel_internals/parsing/logic_preprocess.cmo \ src/kernel_internals/typing/mergecil.cmo \ src/kernel_internals/typing/rmtmps.cmo \ src/kernel_internals/typing/oneret.cmo \ src/kernel_internals/typing/frontc.cmo \ src/kernel_services/ast_data/statuses_by_call.cmo \ src/kernel_services/analysis/dataflow.cmo \ src/kernel_services/analysis/ordered_stmt.cmo \ src/kernel_services/analysis/wto_statement.cmo \ src/kernel_services/analysis/dataflows.cmo \ src/kernel_services/analysis/dataflow2.cmo \ src/kernel_services/analysis/stmts_graph.cmo \ src/kernel_services/analysis/dominators.cmo \ src/kernel_services/analysis/service_graph.cmo \ src/kernel_services/analysis/undefined_sequence.cmo \ src/kernel_services/ast_printing/description.cmo \ src/kernel_services/ast_data/alarms.cmo \ src/kernel_services/abstract_interp/lattice_messages.cmo \ src/kernel_services/abstract_interp/abstract_interp.cmo \ src/kernel_services/abstract_interp/bottom.cmo \ src/kernel_services/abstract_interp/int_Base.cmo \ src/kernel_services/analysis/bit_utils.cmo \ src/kernel_services/abstract_interp/fval.cmo \ src/kernel_services/abstract_interp/ival.cmo \ src/kernel_services/abstract_interp/base.cmo \ src/kernel_services/abstract_interp/origin.cmo \ src/kernel_services/abstract_interp/map_Lattice.cmo \ src/kernel_services/abstract_interp/tr_offset.cmo \ src/kernel_services/abstract_interp/offsetmap.cmo \ src/kernel_services/abstract_interp/int_Intervals.cmo \ src/kernel_services/abstract_interp/locations.cmo \ src/kernel_services/abstract_interp/lmap.cmo \ src/kernel_services/abstract_interp/lmap_bitwise.cmo \ src/kernel_services/visitors/visitor.cmo \ $(PLUGIN_TYPES_CMO_LIST) \ src/kernel_services/plugin_entry_points/db.cmo \ src/libraries/utils/command.cmo \ src/libraries/utils/task.cmo \ src/kernel_services/ast_queries/filecheck.cmo \ src/kernel_services/ast_queries/file.cmo \ src/kernel_internals/typing/translate_lightweight.cmo \ src/kernel_internals/typing/allocates.cmo \ src/kernel_internals/typing/unroll_loops.cmo \ src/kernel_internals/typing/asm_contracts.cmo \ src/kernel_services/analysis/loop.cmo \ src/kernel_services/analysis/exn_flow.cmo \ src/kernel_services/analysis/destructors.cmo \ src/kernel_services/analysis/logic_interp.cmo \ src/kernel_internals/typing/infer_annotations.cmo \ src/kernel_services/ast_transformations/clone.cmo \ src/kernel_services/ast_transformations/filter.cmo \ src/kernel_internals/runtime/special_hooks.cmo \ src/kernel_internals/runtime/messages.cmo CMO += $(KERNEL_CMO) MLI_ONLY+=\ src/libraries/utils/hptmap_sig.mli \ src/kernel_services/cmdline_parameters/parameter_sig.mli \ src/kernel_services/ast_data/cil_types.mli \ src/kernel_services/parsetree/logic_ptree.mli \ src/kernel_services/ast_printing/printer_api.mli \ src/kernel_services/abstract_interp/lattice_type.mli \ src/kernel_services/abstract_interp/int_Intervals_sig.mli \ src/kernel_services/abstract_interp/offsetmap_lattice_with_isotropy.mli \ src/kernel_services/abstract_interp/offsetmap_sig.mli \ src/kernel_services/abstract_interp/lmap_sig.mli \ src/kernel_services/abstract_interp/offsetmap_bitwise_sig.mli NO_MLI+= src/kernel_services/abstract_interp/map_Lattice.mli \ src/kernel_services/parsetree/cabs.mli \ src/kernel_internals/runtime/machdep_ppc_32.mli \ src/kernel_internals/runtime/machdep_x86_16.mli \ src/kernel_internals/runtime/machdep_x86_32.mli \ src/kernel_internals/runtime/machdep_x86_64.mli \ src/kernel_services/ast_printing/cabs_debug.mli \ src/kernel_internals/parsing/logic_lexer.mli \ src/kernel_internals/parsing/lexerhack.mli \ MODULES_NODOC+= src/kernel_internals/runtime/machdep_ppc_32.ml \ src/kernel_internals/runtime/machdep_x86_16.ml \ src/kernel_internals/runtime/machdep_x86_32.ml \ src/kernel_internals/runtime/machdep_x86_64.ml \ external/unmarshal_z.mli GENERATED += $(addprefix src/kernel_internals/parsing/,\ clexer.ml cparser.ml cparser.mli \ logic_lexer.ml logic_parser.ml \ logic_parser.mli logic_preprocess.ml) .PHONY: check-logic-parser-wildcard check-logic-parser-wildcard: cd src/kernel_internals/parsing && ocaml check_logic_parser.ml NON_OPAQUE_DEPS+= src/kernel_services/plugin_entry_points/dynamic # C Bindings ############ GEN_C_BINDINGS=src/libraries/utils/c_bindings.o GEN_C_BINDINGS_FLAGS= -fPIC GEN_BYTE_LIBS+= $(GEN_C_BINDINGS) GEN_OPT_LIBS+= $(GEN_C_BINDINGS) src/libraries/utils/c_bindings.o: src/libraries/utils/c_bindings.c $(PRINT_CC) $@ $(CC) $(GEN_C_BINDINGS_FLAGS) -c -I$(call winpath,$(OCAMLLIB)) -O3 -Wall -o $@ $< # Common startup module # All link command should add it as last linked module and depend on it. ######################################################################## STARTUP_CMO=src/kernel_internals/runtime/boot.cmo STARTUP_CMX=$(STARTUP_CMO:.cmo=.cmx) # GUI modules # See below for GUI compilation ############################################################################## WTOOLKIT= \ wutil widget wbox wfile wpane wpalette wtext wtable SINGLE_GUI_CMO:= \ $(WTOOLKIT) \ gui_parameters \ gtk_helper gtk_form \ source_viewer pretty_source source_manager book_manager \ warning_manager \ filetree \ launcher \ menu_manager \ history \ gui_printers \ design \ analyses_manager file_manager project_manager debug_manager \ help_manager \ property_navigator SINGLE_GUI_CMO:= $(patsubst %,src/plugins/gui/%.cmo,$(SINGLE_GUI_CMO)) ############################################################################### # # #################### # # Plug-in sections # # #################### # # # # For 'internal' developers: # # you can add your own plug-in here, # # but it is better to have your own separated Makefile # ############################################################################### ########### # Metrics # ########### PLUGIN_ENABLE:=$(ENABLE_METRICS) PLUGIN_DYNAMIC:=$(DYNAMIC_METRICS) PLUGIN_NAME:=Metrics PLUGIN_DISTRIBUTED:=yes PLUGIN_DIR:=src/plugins/metrics PLUGIN_CMO:= metrics_parameters css_html metrics_base metrics_acsl \ metrics_cabs metrics_cilast metrics_coverage \ register PLUGIN_GUI_CMO:= metrics_gui register_gui PLUGIN_DEPENDENCIES:=Value PLUGIN_INTERNAL_TEST:=yes $(eval $(call include_generic_plugin_Makefile,$(PLUGIN_NAME))) ############# # Callgraph # ############# PLUGIN_ENABLE:=$(ENABLE_CALLGRAPH) PLUGIN_DYNAMIC:=$(DYNAMIC_CALLGRAPH) PLUGIN_NAME:=Callgraph PLUGIN_DISTRIBUTED:=yes PLUGIN_DIR:=src/plugins/callgraph PLUGIN_CMO:= options journalize cg services uses register PLUGIN_GUI_CMO:=cg_viewer PLUGIN_CMI:= callgraph_api PLUGIN_INTERNAL_TEST:=yes PLUGIN_TESTS_DIRS:=callgraph $(eval $(call include_generic_plugin_Makefile,$(PLUGIN_NAME))) ################## # Value analysis # ################## PLUGIN_ENABLE:=$(ENABLE_VALUE_ANALYSIS) PLUGIN_DYNAMIC:=$(DYNAMIC_VALUE_ANALYSIS) PLUGIN_NAME:=Value PLUGIN_DIR:=src/plugins/value PLUGIN_EXTRA_DIRS:=engine values domains domains/cvalue domains/apron \ domains/gauges domains/equality legacy slevel utils gui_files # General rules for ordering files within PLUGIN_CMO: # - try to keep the legacy Value before Eva PLUGIN_CMO:= slevel/split_strategy value_parameters \ slevel/stop_at_nth \ utils/value_perf utils/value_util \ utils/mark_noresults slevel/separate \ utils/widen_hints_ext utils/widen \ engine/split_return \ slevel/per_stmt_slevel \ utils/library_functions \ utils/eval_typ utils/backward_formals \ alarmset legacy/warn \ eval utils/structure \ values/value_product values/location_lift \ values/cvalue_forward values/cvalue_backward \ values/main_values values/main_locations values/offsm_value \ legacy/eval_op legacy/function_args \ domains/domain_store domains/domain_builder \ domains/domain_product domains/domain_lift domains/unit_domain \ domains/gauges/gauges_domain \ domains/apron/apron_domain \ domains/hcexprs \ domains/equality/equality domains/equality/equality_domain \ domains/offsm_domain \ domains/symbolic_locs\ domains/cvalue/locals_scoping \ domains/cvalue/builtins domains/cvalue/builtins_malloc \ domains/cvalue/builtins_string domains/cvalue/builtins_misc \ $(sort $(patsubst src/plugins/value/%.ml,%,\ $(wildcard src/plugins/value/domains/cvalue/builtins_nonfree*.ml))) \ domains/cvalue/builtins_float \ utils/value_results utils/state_import \ legacy/eval_terms legacy/eval_annots \ domains/powerset engine/transfer_logic \ domains/cvalue/cvalue_transfer domains/cvalue/cvalue_init \ domains/cvalue/cvalue_specification \ domains/cvalue/cvalue_domain \ engine/evaluation engine/non_linear_evaluation \ engine/recursion engine/transfer_stmt \ engine/partitioning engine/mem_exec engine/partitioned_dataflow \ engine/initialization engine/abstractions \ engine/compute_functions engine/analysis register PLUGIN_CMI:= values/abstract_value values/abstract_location domains/abstract_domain \ domains/equality/equality_sig PLUGIN_DEPENDENCIES:=Callgraph LoopAnalysis RteGen ifeq ($(HAS_APRON),yes) PLUGIN_REQUIRES:= apron.octMPQ apron.boxMPQ apron.polkaMPQ apron.apron gmp src/plugins/value/domains/apron/apron_domain.ml: \ src/plugins/value/domains/apron/apron_domain.ok.ml share/Makefile.config $(CP_IF_DIFF) $< $@ $(CHMOD_RO) $@ else PLUGIN_REQUIRES:= src/plugins/value/domains/apron/apron_domain.ml: \ src/plugins/value/domains/apron/apron_domain.ko.ml share/Makefile.config $(CP_IF_DIFF) $< $@ $(CHMOD_RO) $@ endif GENERATED += src/plugins/value/domains/apron/apron_domain.ml PLUGIN_DISTRIB_EXTERNAL:=domains/apron/apron_domain.ok.ml domains/apron/apron_domain.ko.ml # These files are used by the GUI, but do not depend on Lablgtk VALUE_GUI_AUX:=gui_files/gui_types gui_files/gui_eval gui_files/gui_callstacks_filters PLUGIN_GUI_CMO:=$(VALUE_GUI_AUX) gui_files/register_gui PLUGIN_NO_TEST:=yes PLUGIN_DISTRIBUTED:=yes VALUE_TYPES:=$(addprefix src/plugins/value_types/,\ cilE cvalue precise_locs value_types widen_type) PLUGIN_TYPES_CMO:=$(VALUE_TYPES) PLUGIN_TYPES_TODOC:=$(addsuffix .mli,$(VALUE_TYPES)) $(eval $(call include_generic_plugin_Makefile,$(PLUGIN_NAME))) ################## # Occurrence # ################## PLUGIN_ENABLE:=$(ENABLE_OCCURRENCE) PLUGIN_DYNAMIC:=$(DYNAMIC_OCCURRENCE) PLUGIN_NAME:=Occurrence PLUGIN_DISTRIBUTED:=yes PLUGIN_DIR:=src/plugins/occurrence PLUGIN_CMO:= options register PLUGIN_GUI_CMO:=register_gui PLUGIN_INTRO:=doc/code/intro_occurrence.txt PLUGIN_INTERNAL_TEST:=yes PLUGIN_DEPENDENCIES:=Value $(eval $(call include_generic_plugin_Makefile,$(PLUGIN_NAME))) ################################################ # Runtime Error Annotation Generation analysis # ################################################ PLUGIN_ENABLE:=$(ENABLE_RTEGEN) PLUGIN_DYNAMIC:=$(DYNAMIC_RTEGEN) PLUGIN_NAME:=RteGen PLUGIN_DIR:=src/plugins/rte PLUGIN_CMO:= options generator rte visit register PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes PLUGIN_TESTS_DIRS:=rte rte_manual $(eval $(call include_generic_plugin_Makefile,$(PLUGIN_NAME))) ################# # From analysis # ################# PLUGIN_ENABLE:=$(ENABLE_FROM_ANALYSIS) PLUGIN_DYNAMIC:=$(DYNAMIC_FROM_ANALYSIS) PLUGIN_NAME:=From PLUGIN_DIR:=src/plugins/from PLUGIN_CMO:= from_parameters from_compute \ functionwise callwise from_register PLUGIN_GUI_CMO:=from_register_gui PLUGIN_TESTS_DIRS:=idct test float PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes FROM_TYPES:=src/plugins/value_types/function_Froms PLUGIN_TYPES_CMO:=$(FROM_TYPES) PLUGIN_TYPES_TODOC:=$(addsuffix .mli,$(FROM_TYPES)) PLUGIN_DEPENDENCIES:=Callgraph Value Postdominators $(eval $(call include_generic_plugin_Makefile,$(PLUGIN_NAME))) ################## # Users analysis # ################## PLUGIN_ENABLE:=$(ENABLE_USERS) PLUGIN_DYNAMIC:=$(DYNAMIC_USERS) PLUGIN_NAME:=Users PLUGIN_DIR:=src/plugins/users PLUGIN_CMO:= users_register PLUGIN_NO_TEST:=yes PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes PLUGIN_DEPENDENCIES:=Callgraph Value $(eval $(call include_generic_plugin_Makefile,$(PLUGIN_NAME))) ######################## # Constant propagation # ######################## PLUGIN_ENABLE:=$(ENABLE_CONSTANT_PROPAGATION) PLUGIN_DYNAMIC:=$(DYNAMIC_CONSTANT_PROPAGATION) PLUGIN_NAME:=Constant_Propagation PLUGIN_DIR:=src/plugins/constant_propagation PLUGIN_CMO:= propagationParameters \ register PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes PLUGIN_DEPENDENCIES:=Value $(eval $(call include_generic_plugin_Makefile,$(PLUGIN_NAME))) ################### # Post-dominators # ################### PLUGIN_ENABLE:=$(ENABLE_POSTDOMINATORS) PLUGIN_DYNAMIC:=$(DYNAMIC_POSTDOMINATORS) PLUGIN_NAME:=Postdominators PLUGIN_DIR:=src/plugins/postdominators PLUGIN_CMO:= postdominators_parameters print compute PLUGIN_NO_TEST:=yes PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes $(eval $(call include_generic_plugin_Makefile,$(PLUGIN_NAME))) ######### # inout # ######### PLUGIN_ENABLE:=$(ENABLE_INOUT) PLUGIN_DYNAMIC:=$(DYNAMIC_INOUT) PLUGIN_NAME:=Inout PLUGIN_DIR:=src/plugins/inout PLUGIN_CMO:= inout_parameters cumulative_analysis \ operational_inputs outputs inputs derefs register PLUGIN_NO_TEST:=yes PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes INOUT_TYPES:=src/plugins/value_types/inout_type PLUGIN_TYPES_CMO:=$(INOUT_TYPES) PLUGIN_TYPES_TODOC:=$(addsuffix .mli,$(INOUT_TYPES)) PLUGIN_DEPENDENCIES:=Callgraph Value From $(eval $(call include_generic_plugin_Makefile,$(PLUGIN_NAME))) ################### # Impact analysis # ################### PLUGIN_ENABLE:=$(ENABLE_IMPACT) PLUGIN_DYNAMIC:=$(DYNAMIC_IMPACT) PLUGIN_NAME:=Impact PLUGIN_DIR:=src/plugins/impact PLUGIN_CMO:= options pdg_aux reason_graph compute_impact register PLUGIN_GUI_CMO:= register_gui PLUGIN_DISTRIBUTED:=yes # PLUGIN_UNDOC:=impact_gui.ml PLUGIN_INTERNAL_TEST:=yes PLUGIN_DEPENDENCIES:=Inout Value Pdg $(eval $(call include_generic_plugin_Makefile,$(PLUGIN_NAME))) ################################## # PDG : program dependence graph # ################################## PLUGIN_ENABLE:=$(ENABLE_PDG) PLUGIN_DYNAMIC:=$(DYNAMIC_PDG) PLUGIN_NAME:=Pdg PLUGIN_DIR:=src/plugins/pdg PLUGIN_CMO:= pdg_parameters \ ctrlDpds \ pdg_state \ build \ sets \ annot \ marks \ register PDG_TYPES:=pdgIndex pdgTypes pdgMarks PDG_TYPES:=$(addprefix src/plugins/pdg_types/,$(PDG_TYPES)) PLUGIN_TYPES_CMO:=$(PDG_TYPES) PLUGIN_INTRO:=doc/code/intro_pdg.txt PLUGIN_TYPES_TODOC:=$(addsuffix .mli,$(PDG_TYPES)) PLUGIN_DEPENDENCIES:=Callgraph Value From PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes $(eval $(call include_generic_plugin_Makefile,$(PLUGIN_NAME))) ################################################ # Scope : show different kinds of dependencies # ################################################ PLUGIN_ENABLE:=$(ENABLE_SCOPE) PLUGIN_DYNAMIC:=$(DYNAMIC_SCOPE) PLUGIN_NAME:=Scope PLUGIN_DIR:=src/plugins/scope PLUGIN_CMO:= datascope zones defs PLUGIN_GUI_CMO:=dpds_gui PLUGIN_DEPENDENCIES:=Value Inout PLUGIN_INTRO:=doc/code/intro_scope.txt PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes $(eval $(call include_generic_plugin_Makefile,$(PLUGIN_NAME))) ##################################### # Sparecode : unused code detection # ##################################### PLUGIN_ENABLE:=$(ENABLE_SPARECODE) PLUGIN_DYNAMIC:=$(DYNAMIC_SPARECODE) PLUGIN_NAME:=Sparecode PLUGIN_DIR:=src/plugins/sparecode PLUGIN_CMO:= sparecode_params globs spare_marks transform register PLUGIN_INTRO:=doc/code/intro_sparecode.txt PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes PLUGIN_DEPENDENCIES:=Pdg Value $(eval $(call include_generic_plugin_Makefile,$(PLUGIN_NAME))) ########### # Slicing # ########### PLUGIN_ENABLE:=$(ENABLE_SLICING) PLUGIN_DYNAMIC:=$(DYNAMIC_SLICING) PLUGIN_NAME:=Slicing PLUGIN_DIR:=src/plugins/slicing PLUGIN_CMO:= slicingParameters \ slicingState \ slicingMacros \ slicingMarks \ slicingActions \ fct_slice \ printSlice \ slicingProject \ slicingTransform \ slicingCmds \ register SLICING_TYPES:=slicingInternals slicingTypes SLICING_TYPES:=$(addprefix src/plugins/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 PLUGIN_TESTS_LIB:= tests/slicing/libSelect.ml tests/slicing/libAnim.ml \ tests/slicing/simple_intra_slice.ml tests/slicing/combine.ml \ tests/slicing/ex_spec_interproc.ml tests/slicing/horwitz.ml \ tests/slicing/mark_all_slices.ml tests/slicing/merge.ml \ tests/slicing/min_call.ml tests/slicing/select_by_annot.ml \ tests/slicing/select_simple.ml tests/slicing/simple_intra_slice.ml \ tests/slicing/slice_no_body.ml tests/slicing/switch.ml \ tests/slicing/adpcm.ml PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes PLUGIN_DEPENDENCIES:=Pdg Callgraph Value $(eval $(call include_generic_plugin_Makefile,$(PLUGIN_NAME))) ##################### # External plug-ins # ##################### define INCLUDE_PLUGIN FRAMAC_SHARE:=$(FRAMAC_ROOT_SRCDIR)/share FRAMAC_PLUGIN:=$(FRAMAC_ROOT_SRCDIR)/lib/plugins FRAMAC_PLUGIN_GUI:=$(FRAMAC_ROOT_SRCDIR)/lib/plugins/gui PLUGIN_DIR:=$(1) 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.{byte,opt} binaries # ################################ ALL_BATCH_CMO= $(filter-out src/kernel_internals/runtime/gui_init.cmo,\ $(ALL_CMO)) ALL_BATCH_CMX= $(filter-out src/kernel_internals/runtime/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) #Profiling version of toplevel.byte using ocamlprof bin/toplevel.prof$(EXE): $(ALL_BATCH_CMO) $(GEN_BYTE_LIBS) \ $(PLUGIN_DYN_CMO_LIST) $(PRINT_OCAMLCP) $@ $(OCAMLCP) $(BLINKFLAGS) -o $@ $(BYTE_LIBS) $(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) #################### # (Ocaml) Toplevel # #################### bin/toplevel.top$(EXE): $(filter-out src/kernel_internals/runtime/boot.ml,$(ALL_BATCH_CMO)) \ src/kernel_internals/runtime/toplevel_config.cmo \ $(GEN_BYTE_LIBS) $(PLUGIN_DYN_CMO_LIST) $(PRINT_OCAMLMKTOP) $@ $(OCAMLMKTOP) $(BFLAGS) -warn-error -31 -custom -o $@ \ -linkpkg $(BYTE_LIBS) $(ALL_BATCH_CMO) \ src/kernel_internals/runtime/toplevel_config.cmo ####### # GUI # ####### ifneq ($(ENABLE_GUI),no) 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/plugins/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_DYN_DEP_GUI_CMO_LIST): BFLAGS+= $(GUI_INCLUDES) $(PLUGIN_DYN_DEP_GUI_CMX_LIST): OFLAGS+= $(GUI_INCLUDES) .PHONY:gui gui:: bin/viewer.byte$(EXE) \ share/Makefile.dynamic_config \ share/Makefile.kernel \ $(PLUGIN_META_LIST) ifeq ($(OCAMLBEST),opt) gui:: bin/viewer.opt$(EXE) 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+= $(GRAPH_GUICMO) 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+= $(GRAPH_GUICMX) 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 ##################### # Config Ocaml File # ##################### CONFIG_DIR=src/kernel_internals/runtime CONFIG_FILE=$(CONFIG_DIR)/config.ml CONFIG_CMO=$(CONFIG_DIR)/config.cmo GENERATED +=$(CONFIG_FILE) #Generated in Makefile.generating empty:= space:=$(empty) $(empty) ifeq ($(ENABLE_GUI),no) CONFIG_CMO=$(ALL_CMO) CONFIG_PLUGIN_CMO=$(PLUGIN_CMO_LIST) else CONFIG_CMO=$(ALL_GUI_CMO) CONFIG_PLUGIN_CMO=$(PLUGIN_GUI_CMO_LIST) endif ifeq ($(HAS_DOT),yes) OPTDOT=Some \"$(DOT)\" else OPTDOT=None endif STATIC_PLUGINS=$(foreach p,$(PLUGIN_LIST),\"$(notdir $p)\"; ) STATIC_GUI_PLUGINS=\ $(foreach p,$(CONFIG_PLUGIN_CMO),\"$(notdir $(patsubst %.cmo,%,$p))\"; ) COMPILATION_UNITS=\ $(foreach p,$(CONFIG_CMO),\"$(notdir $(patsubst %.cmo,%,$p))\"; ) ################### # Generating part # ################### # It is in another file in order to have a dependency only on Makefile.generating. # It must be before `.depend` definition because it modifies $GENERATED. include Makefile.generating ######### # Tests # ######### ifeq ($(PTESTSBEST),opt) PTESTS_FILES=ptests_config.cmi ptests_config.cmx ptests_config.o else PTESTS_FILES=ptests_config.cmi ptests_config.cmo endif .PHONY: tests oracles btests tests_dist libc_tests plugins_ptests_config external_tests \ update_external_tests tests:: byte opt ptests $(PRINT_EXEC) ptests time -p $(PTESTS) $(PTESTS_OPTS) $(FRAMAC_PARALLEL) \ -make "$(MAKE)" $(PLUGIN_TESTS_LIST) external_tests: byte opt ptests tests:: external_tests update_external_tests: PTESTS_OPTS="-update" update_external_tests: external_tests oracles: byte opt ptests $(PRINT_MAKING) oracles ./bin/ptests.$(PTESTSBEST)$(EXE) -make "$(MAKE)" $(PLUGIN_TESTS_LIST) \ > /dev/null 2>&1 ./bin/ptests.$(PTESTSBEST)$(EXE) -make "$(MAKE)" -update \ $(PLUGIN_TESTS_LIST) btests: byte ./bin/ptests.byte$(EXE) $(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.$(PTESTSBEST)$(EXE) -make "$(MAKE)" \ $(PLUGIN_TESTS_LIST) # test only one test suite : make suite_tests %_tests: opt ptests $(PRINT_EXEC) ptests ./bin/ptests.$(PTESTSBEST)$(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 pretty_printing non-free libc value PLUGIN_TESTS_LIST += $(TEST_DIRS_AS_PLUGIN) LONELY_TESTS_ML_FILES=$(wildcard $(TEST_DIRS_AS_PLUGIN:%=tests/%/*.ml)) LONELY_TESTS_BYTE_FILES=$(LONELY_TESTS_ML_FILES:%.ml=%.cmo) LONELY_TESTS_OPT_FILES=$(LONELY_TESTS_ML_FILES:%.ml=%.cmx) LONELY_TESTS_DYN_FILES=$(LONELY_TESTS_ML_FILES:%.ml=%.cmxs) $(LONELY_TESTS_BYTE_FILES): BFLAGS+=$(TEST_DIRS_AS_PLUGIN:%=-I tests/%) $(LONELY_TESTS_OPT_FILES): OFLAGS+=$(TEST_DIRS_AS_PLUGIN:%=-I tests/%) $(LONELY_TESTS_DYN_FILES): OFLAGS+=$(TEST_DIRS_AS_PLUGIN:%=-I tests/%) .PRECIOUS: $(LONELY_TESTS_OPT_FILES) \ $(LONELY_TESTS_DYN_FILES) \ $(LONELY_TESTS_BYTE_FILES) \ $(LONELY_TESTS_BYTE_FILES:%.cmo=%.cmi) # Tests directories without .ml but that must be tested anyway PLUGIN_TESTS_LIST += cil ############## # Emacs tags # ############## .PHONY: tags # otags gives a better tagging of ocaml files than etags ifdef OTAGS tags: $(OTAGS) -r src lib vtags: $(OTAGS) -vi -r src lib 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: doc doc-distrib # 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) byte $(DOC_PLUGIN) ifneq ($(ENABLE_GUI),no) DOC_DEPEND+=bin/viewer.byte$(EXE) 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_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 \ 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) \ $(addprefix -passopt -stdlib ,$(STDLIB_FILES)) \ -t "Frama-C Kernel" \ -sort -css-style ../style.css \ -g $(DOC_PLUGIN) \ -d $(DOC_DIR)/html -dump $@ \ $(MODULES_TODOC); \ RES=$$?; \ if test $$RES -ne 0; then \ $(RM) $@; \ exit $$RES; \ fi DYN_MLI_DIR := src/plugins/print_api .PHONY: doc-dynamic doc-dynamic: doc-kernel $(RM) $(DYN_MLI_DIR)/dynamic_plugins.mli ./bin/frama-c.byte \ -print_api $(call winpath,$(FRAMAC_ROOT_SRCDIR)/$(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) \ -passopt -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) '
  • Dynamically registered plugins' > $(DOC_DIR)/dynamic_plugins.toc doc-index: doc-kernel doc-dynamic plugins-doc $(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-kernel doc-dynamic plugins-doc doc-index doc-kernel doc-dynamic plugins-doc doc-index: $(DOC_DEPEND) 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 #find src -name "*.ml[i]" -o -name "*.ml" -maxdepth 3 | sort -r | xargs dots: $(ALL_CMO) $(PRINT_DOC) callgraph $(OCAMLDOC) $(DOC_FLAGS) $(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 # 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 CHECK_CODE=$(CHECK_API_DIR)/check_code.cmxs .PHONY: check-devguide check-devguide: $(CHECK_CODE) $(DOC_DEPEND) $(DOC_DIR)/kernel-doc.ocamldoc $(PRINT) 'Checking developer guide consistency' $(MKDIR) $(CHECK_API_DIR)/html $(OCAMLDOC) $(DOC_FLAGS) -I $(OCAMLLIB) \ -g $(CHECK_CODE) \ -passopt -docdevpath -passopt "`pwd`/$(CHECK_API_DIR)" \ -load $(DOC_DIR)/kernel-doc.ocamldoc \ -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 ################ # Installation # ################ # line below does not work if INCLUDES contains twice the same directory # Do not attempt to copy gui interfaces if gui is disabled #Byte ALL_BATCH_CMO_FIXED=$(filter-out src/kernel_internals/runtime/gui_init.cmo,$(CMO) $(STARTUP_CMO)) LIB_BYTE_TO_INSTALL=\ $(MLI_ONLY:.mli=.cmi) \ $(ALL_BATCH_CMO_FIXED:.cmo=.cmi) \ $(ALL_BATCH_CMO_FIXED) \ $(filter-out %.o,$(GEN_BYTE_LIBS:.cmo=.cmi)) \ $(GEN_BYTE_LIBS) #Byte GUI ifneq ("$(ENABLE_GUI)","no") LIB_BYTE_TO_INSTALL+=$(SINGLE_GUI_CMI) $(SINGLE_GUI_CMO) endif #Opt ifeq ("$(OCAMLBEST)","opt") ALL_BATCH_CMX_FIXED= $(filter-out src/kernel_internals/runtime/gui_init.cmx,\ $(CMX) $(STARTUP_CMX)) LIB_OPT_TO_INSTALL +=\ $(ALL_BATCH_CMX) \ $(filter %.a,$(ALL_BATCH_CMX_FIXED:.cmxa=.a)) \ $(filter %.o,$(ALL_BATCH_CMX_FIXED:.cmx=.o)) \ $(filter-out %.o,$(GEN_OPT_LIBS)) \ $(filter-out $(GEN_BYTE_LIBS),$(filter %.o,$(GEN_OPT_LIBS:.cmx=.o))) #Opt GUI ifneq ("$(ENABLE_GUI)","no") LIB_OPT_TO_INSTALL += $(SINGLE_GUI_CMX) $(SINGLE_GUI_CMX:.cmx=.o) endif endif clean-install: $(PRINT_RM) "Installation directory" $(RM) -r $(FRAMAC_LIBDIR) install-lib: clean-install $(PRINT_INSTALL) kernel API $(MKDIR) $(FRAMAC_LIBDIR) $(CP) $(LIB_BYTE_TO_INSTALL) $(LIB_OPT_TO_INSTALL) $(FRAMAC_LIBDIR) install-doc-code: $(PRINT_INSTALL) API documentation $(MKDIR) $(FRAMAC_DATADIR)/doc/code (cd doc ; tar cf - --exclude='.svn' --exclude='*.toc' \ --exclude='*.htm' --exclude='*.txt' \ --exclude='*.ml' \ code \ | (cd $(FRAMAC_DATADIR)/doc ; tar xf -)) .PHONY: install install:: install-lib $(PRINT_MAKING) destination directories $(MKDIR) $(BINDIR) $(MKDIR) $(MANDIR)/man1 $(MKDIR) $(FRAMAC_PLUGINDIR)/top $(MKDIR) $(FRAMAC_PLUGINDIR)/gui $(MKDIR) $(FRAMAC_DATADIR)/theme/default $(MKDIR) $(FRAMAC_DATADIR)/theme/colorblind $(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_INSTALL) shared files $(CP) \ $(wildcard share/*.c share/*.h) \ share/Makefile.dynamic share/Makefile.plugin.template share/Makefile.kernel \ share/Makefile.config share/Makefile.common share/Makefile.generic \ share/configure.ac share/autocomplete_frama-c \ $(FRAMAC_DATADIR) $(MKDIR) $(FRAMAC_DATADIR)/emacs $(CP) $(wildcard share/emacs/*.el) $(FRAMAC_DATADIR)/emacs $(CP) share/frama-c.rc $(ICONS) $(FRAMAC_DATADIR) $(CP) $(FEEDBACK_ICONS_DEFAULT) $(FRAMAC_DATADIR)/theme/default $(CP) $(FEEDBACK_ICONS_COLORBLIND) $(FRAMAC_DATADIR)/theme/colorblind if [ -d $(EMACS_DATADIR) ]; then \ $(CP) $(wildcard share/emacs/*.el) $(EMACS_DATADIR); \ fi $(CP) share/Makefile.dynamic_config.external \ $(FRAMAC_DATADIR)/Makefile.dynamic_config $(PRINT_INSTALL) 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_INSTALL) 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.$(PTESTSBEST)$(EXE) \ $(BINDIR)/ptests.$(PTESTSBEST)$(EXE) if [ -x bin/frama-c-config$(EXE) ] ; then \ $(CP) bin/frama-c-config$(EXE) $(BINDIR); \ fi $(PRINT_INSTALL) config files $(CP) $(addprefix ptests/,$(PTESTS_FILES)) $(FRAMAC_LIBDIR) $(PRINT_INSTALL) API documentation $(MKDIR) $(FRAMAC_DATADIR)/doc/code $(CP) $(wildcard $(DOC_GEN_FILES)) $(FRAMAC_DATADIR)/doc/code $(PRINT_INSTALL) dynamic plug-ins if [ -d "$(FRAMAC_PLUGIN)" -a "$(PLUGIN_DYN_EXISTS)" = "yes" ]; then \ $(CP) $(PLUGIN_DYN_CMI_LIST) $(PLUGIN_META_LIST) \ $(FRAMAC_PLUGINDIR); \ $(CP) $(PLUGIN_DYN_CMO_LIST) $(PLUGIN_DYN_CMX_LIST) \ $(FRAMAC_PLUGINDIR)/top; \ fi $(PRINT_INSTALL) 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 $(PRINT_INSTALL) 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.$(PTESTSBEST)$(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 # ################################ # Generating headers #################### CEA_PROPRIETARY:= \ src/*/*/*nonfree*.ml* .PHONY: headers HEADER_SPEC_FILE?=headers/header_spec.txt HDRCK=./headers/hdrck$(EXE) # OPEN_SOURCE: set it to 'yes' if you want to apply open source headers headers:: $(HDRCK) $(PRINT) "Applying $(DISTRIB_HEADERS) headers (OPEN_SOURCE=$(OPEN_SOURCE))..." $(HDRCK) \ -update -C . -header-dirs headers/$(DISTRIB_HEADERS) \ -headache-config-file ./headers/headache_config.txt \ $(HEADER_SPEC_FILE) HEADER_EXCEPTIONS+=$(wildcard src/plugins/*/configure) opam/files hdrck: $(HDRCK) $(HDRCK): headers/hdrck.ml $(PRINT_MAKING) $@ ifeq ($(OCAMLBEST),opt) $(OCAMLOPT) str.cmxa unix.cmxa $< -o $@ else $(OCAMLC) str.cma unix.cma $< -o $@ endif hdrck-clean: $(RM) headers/hdrck headers/hdrck.o $(RM) headers/hdrck.cmx headers/hdrck.cmi headers/hdrck.cmp clean:: hdrck-clean CURRENT_HEADERS?=open-source # OPEN_SOURCE: set it to 'yes' if you want to check open source headers # The target check-headers does the following checks: # 1. Checks entries of HEADER_SPEC_FILE # 2. Checks that every DISTRIB_FILES (except HEADER_EXCEPTIONS) have an entry # inside HEADER_SPEC_FILE # 3. Checks that all these files are not under DISTRIB_PROPRIETARY_HEADERS # licences .PHONY: check-headers check-headers: $(HDRCK) $(PRINT) "Checking $(DISTRIB_HEADERS) headers (OPEN_SOURCE=$(OPEN_SOURCE), CURRENT_HEADERS=$(CURRENT_HEADERS))..." # Workaround to avoid "argument list too long" in make 3.82+ without # using 'file' built-in, only available on make 4.0+ # for make 4.0+, using the 'file' function could be a better solution, # although it seems to segfault in 4.0 (but not in 4.1) $(RM) file_list_to_check.tmp file_list_exceptions.tmp @$(foreach file,$(DISTRIB_FILES),\ echo $(file) >> file_list_to_check.tmp$(NEWLINE)) @$(foreach file,$(HEADER_EXCEPTIONS),\ echo $(file) >> file_list_exceptions.tmp$(NEWLINE)) $(HDRCK) \ -header-dirs headers/$(CURRENT_HEADERS) \ -headache-config-file ./headers/headache_config.txt \ -distrib-file file_list_to_check.tmp \ -header-except-file file_list_exceptions.tmp \ $(HEADER_SPEC_FILE) $(RM) file_list_to_check.tmp file_list_exceptions.tmp ######################################################################## # Makefile is rebuilt whenever Makefile.in or configure.in is modified # ######################################################################## share/Makefile.config: share/Makefile.config.in config.status $(PRINT_MAKING) $@ ./config.status --file $@ 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) $@ autoconf -f # 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 .PHONY: force-clean 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* 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/plugins/gui/*.cm* src/plugins/gui/*.o clean:: $(PLUGIN_LIST:=_CLEAN) $(PLUGIN_DYN_LIST:=_CLEAN) \ clean-tests clean-journal clean-check-libc $(PRINT_RM) lib/plugins $(RM) $(addprefix $(PLUGIN_LIB_DIR)/,*.mli *.cm* *.o META.*) $(RM) $(addprefix $(PLUGIN_TOP_LIB_DIR)/,*.mli *.cm* *.o *.a) $(RM) $(addprefix $(PLUGIN_GUI_LIB_DIR)/,*.mli *.cm* *.o *.a) $(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/plugins/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) $(PRINT_RM) binaries $(RM) bin/toplevel.byte$(EXE) bin/viewer.byte$(EXE) \ bin/ptests.byte$(EXE) bin/*.opt$(EXE) bin/toplevel.top$(EXE) $(RM) bin/frama-c-config$(EXE) smartclean: $(MAKE) -f share/Makefile.clean smartclean # 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 \ $(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 $(PRINT_RM) documentation $(RM) $(DOC_DIR)/kernel-doc.ocamldoc $(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 resources share/frama-c.rc: share/frama-c.WIN32.rc $(PRINT_MAKING) $@ $(CP) $^ $@ else # Use Unix typical resources share/frama-c.rc: share/frama-c.Unix.rc $(PRINT_MAKING) $@ $(CP) $^ $@ endif GENERATED+=share/frama-c.rc ########## # Depend # ########## PLUGIN_DEP_LIST:=$(PLUGIN_LIST) $(PLUGIN_DYN_LIST) .PHONY: depend .depend depend:: $(GENERATED) \ share/Makefile.dynamic_config share/Makefile.kernel $(PRINT_MAKING) .depend $(RM) .depend $(OCAMLDEP) $(INCLUDES) $(FILES_FOR_OCAMLDEP) > .depend $(OCAMLDEP) $(INCLUDES) $(TEST_DIRS_AS_PLUGIN:%=-I tests/%) \ $(LONELY_TESTS_ML_FILES) >> .depend $(CHMOD_RO) .depend #Used by internal plugins to wait until the *.mli of all the plugins are in # $(PLUGIN_LIB_DIR) before computing their .depend. Otherwise ocamldep doesn't # mark inter-plugin dependencies $(PLUGIN_LIB_DIR)/.placeholders_ready: touch $@ ifneq ($(MAKECMDGOALS),clean) ifneq ($(MAKECMDGOALS),distclean) ifneq ($(MAKECMDGOALS),smartclean) sinclude .depend endif endif endif ##################### # ptest development # ##################### .PHONY: ptests PTESTS_SRC=ptests/ptests_config.ml ptests/ptests.ml # Do not generate tests/ptests_config if we are compiling a distribution # that does not contain a 'tests' dir PTESTS_CONFIG:= $(shell if test -d tests; then echo tests/ptests_config; fi) ifeq ($(NATIVE_THREADS),yes) THREAD=-thread ptests: bin/ptests.$(PTESTSBEST)$(EXE) $(PTESTS_CONFIG) else THREAD=-vmthread ptests: bin/ptests.byte$(EXE) $(PTESTS_CONFIG) 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 $^ GENERATED+=ptests/ptests_config.ml tests/ptests_config ####################### # Source distribution # ####################### .PHONY: src-distrib bin-distrib STANDALONE_PLUGINS_FILES = \ $(addprefix src/dummy/hello_world/,hello_world.ml Makefile) \ $(addprefix src/dummy/untyped_metrics/,count_for.ml Makefile) DISTRIB_FILES += $(wildcard $(PLUGIN_DISTRIBUTED_LIST) \ $(PLUGIN_DIST_EXTERNAL_LIST) \ $(PLUGIN_DIST_DOC_LIST) $(STANDALONE_PLUGINS_FILES)) OPEN_SOURCE ?= no ifneq ($(OPEN_SOURCE),yes) # close source version DISTRIB_HEADERS:=close-source DISTRIB_EXCLUDE= DISTRIB_PROPRIETARY_HEADERS = else # open source version DISTRIB_HEADERS:=open-source # files that can be distributed DISTRIB_FILES := $(filter-out \ src/plugins/value/domains/cvalue/builtins_nonfree%,\ $(DISTRIB_FILES)) # files excluded to the final tarball DISTRIB_EXCLUDE=--exclude \"*/non-free/*\" # for checking that distributed files aren't under proprietary licence. DISTRIB_PROPRIETARY_HEADERS = --no-headers CEA_PROPRIETARY endif DISTRIB_FILES:=$(filter-out $(GENERATED) $(PLUGIN_GENERATED_LIST),\ $(DISTRIB_FILES)) # Variables governing the name of the generated .tar.gz. # Optionally define them as empty to silence warnings about undefined variables GITVERSION ?= CLIENT ?= ifeq ("$(GITVERSION)","") VERSION_NAME:=$(VERSION) else VERSION_NAME:=$(shell git describe --tags --match $(VERSION_PREFIX) --dirty) endif DISTRIB_DIR=tmp ifeq ("$(CLIENT)","") VERSION_NAME:=$(VERSION_NAME) else VERSION_NAME:=$(VERSION_NAME)-$(CLIENT) endif DISTRIB?=frama-c-$(VERSION_NAME) CLIENT_DIR=$(DISTRIB_DIR)/$(DISTRIB) # this NEWLINE variable containing literal newline character is used to avoid # the error "argument list too long" in target src-distrib, with gmake 3.82. define NEWLINE endef # useful parameters: # CLIENT: name of the client (in the version number, the archive name, etc) # DISTRIB: name of the generated tarball and of the root tarball directory # OPEN_SOURCE: set it to 'yes' if you want to exclude close source files # GITVERSION: set it to 'yes" if you want to use git to generate the version # number ("distance" to the last tag) + hash of the commit # note: make headers has to be applied... src-distrib: $(HDRCK) ifeq ("$(CLIENT)","") $(PRINT_BUILD) "$(DISTRIB_HEADERS) tarball $(DISTRIB) (OPEN_SOURCE=$(OPEN_SOURCE))" else $(PRINT_BUILD) "$(DISTRIB_HEADERS) tarball $(DISTRIB) for $(CLIENT) (OPEN_SOURCE=$(OPEN_SOURCE))" endif $(RM) -r $(CLIENT_DIR) $(MKDIR) -p $(CLIENT_DIR) @#Workaround to avoid "argument list too long" in make 3.82+ without @#using 'file' built-in, only available on make 4.0+ @#for make 4.0+, using the 'file' function could be a better solution, @#although it seems to segfault in 4.0 (but not in 4.1) $(RM) file_list_to_archive.tmp @$(foreach file,$(DISTRIB_FILES) $(DISTRIB_TESTS),\ echo $(file) >> file_list_to_archive.tmp$(NEWLINE)) $(TAR) -cf - --files-from file_list_to_archive.tmp | $(TAR) -C $(CLIENT_DIR) -xf - $(RM) file_list_to_archive.tmp $(PRINT_MAKING) files (cd $(CLIENT_DIR) ; \ echo "$(VERSION_NAME)" > VERSION && \ DISTRIB_CONF=yes autoconf > ../../.log.autoconf 2>&1) $(MKDIR) $(CLIENT_DIR)/bin $(MKDIR) $(CLIENT_DIR)/lib/plugins $(MKDIR) $(CLIENT_DIR)/lib/gui $(MKDIR) $(CLIENT_DIR)/tests/non-free $(RM) ../$(DISTRIB).tar.gz $(PRINT) "Updating files to archive with $(DISTRIB_HEADERS) headers" $(HDRCK) \ -update -C $(CLIENT_DIR) -header-dirs headers/$(DISTRIB_HEADERS) \ -headache-config-file ./headers/headache_config.txt \ $(HEADER_SPEC_FILE) $(PRINT_TAR) $(DISTRIB).tar.gz # hdrck messes up timestamps, leading make to possibly consider that # a configure file from a freshly extracted archive needs to be # recomputed from configure.in (which would require autoconf on the # host machine). touch $(CLIENT_DIR)/configure (cd $(DISTRIB_DIR); $(TAR) zcf ../$(DISTRIB).tar.gz \ $(DISTRIB_EXCLUDE) \ --exclude "*autom4te.cache*" \ $(DISTRIB) \ ) $(PRINT_RM) $(DISTRIB_DIR) $(RM) -r $(DISTRIB_DIR) clean-distrib: dist-clean $(PRINT_RM) distrib $(RM) -r $(DISTRIB_DIR) $(DISTRIB).tar.gz 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) create_lib_to_install_list = $(addprefix $(FRAMAC_LIB)/,$(call map,notdir,$(1))) byte:: bin/toplevel.byte$(EXE) \ share/Makefile.dynamic_config share/Makefile.kernel \ $(call create_lib_to_install_list,$(LIB_BYTE_TO_INSTALL)) \ $(PLUGIN_META_LIST) opt:: bin/toplevel.opt$(EXE) \ share/Makefile.dynamic_config share/Makefile.kernel \ $(call create_lib_to_install_list,$(LIB_OPT_TO_INSTALL)) \ $(filter %.o %.cmi,\ $(call create_lib_to_install_list,$(LIB_BYTE_TO_INSTALL))) \ $(PLUGIN_META_LIST) top: bin/toplevel.top$(EXE) \ $(call create_lib_to_install_list,$(LIB_BYTE_TO_INSTALL)) \ $(PLUGIN_META_LIST) ################## # Copy in lib/fc # ################## define copy_in_lib $(FRAMAC_LIB)/$(notdir $(1)): $(1) $(MKDIR) $(FRAMAC_LIB) $(CP) $$< $$@ endef $(eval $(foreach file,$(LIB_BYTE_TO_INSTALL),$(call copy_in_lib,$(file)))) $(eval $(foreach file,$(LIB_OPT_TO_INSTALL),$(call copy_in_lib,$(file)))) ################ # Generic part # ################ $(NON_OPAQUE_DEPS:%=%.cmx): OFLAGS := $(OFLAGS) -w -58 include share/Makefile.generic ############################################################################### # Local Variables: # compile-command: "make" # End: frama-c-Phosphorus-20170501/lib/0000755000175000017500000000000013113745001015130 5ustar mehdimehdiframa-c-Phosphorus-20170501/lib/plugins/0000755000175000017500000000000013113745001016611 5ustar mehdimehdiframa-c-Phosphorus-20170501/lib/gui/0000755000175000017500000000000013113745001015714 5ustar mehdimehdiframa-c-Phosphorus-20170501/configure.in0000644000175000017500000007222113113745012016701 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2017 # # 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 Filliâtre # 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_internals/runtime/boot.ml) 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,) AC_MSG_CHECKING([version of 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"` AC_MSG_RESULT($MAKE_MAJOR.$MAKE_MINOR) if test "$MAKE_DISTRIB" != GNU -o "$MAKE_MAJOR" -lt 3 \ -o "$MAKE_MAJOR" = 3 -a "$MAKE_MINOR" -lt 81 then AC_MSG_ERROR([unsupported version; GNU Make version 3.81 or higher is required.]); 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 invalid command-line options # ########################################## case $prefix in *\ * ) AC_MSG_ERROR(spaces not allowed in --prefix argument "$prefix");; * ) ;; esac ############################# # Check for Ocaml compilers # ############################# 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 # we extract Ocaml version number and library path # "sed -n" is the posix version of "sed --quiet" AC_MSG_CHECKING(version of OCaml) OCAMLVERSION=`$OCAMLC -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` AC_MSG_RESULT($OCAMLVERSION) case $OCAMLVERSION in 0.*|1.*|2.*|3.*|4.00.*|4.01.*|4.02.[[012]]) AC_MSG_ERROR(Incompatible OCaml version; use 4.02.3+.);; *) OCAML_ANNOT_OPTION="-bin-annot";; esac # Ocaml library path AC_MSG_CHECKING(OCaml library path) OCAMLLIB=`$OCAMLC -where | tr -d '\\r'` AC_MSG_RESULT($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 ocamlfind AC_CHECK_PROG(OCAMLFIND,ocamlfind,ocamlfind,no) if test "$OCAMLFIND" != no ; then OCAMLC="$OCAMLFIND ocamlc" OCAMLOPT="$OCAMLFIND ocamlopt" else AC_MSG_ERROR(Cannot find ocamlfind.) fi ################################################### # Select devel compilation (warnings, warn-error) # ################################################### # It is inherited by the plugins if test -e ".for_devel"; then DEFAULT_DEVEL_MODE=yes else DEFAULT_DEVEL_MODE=no fi AC_ARG_ENABLE( devel-mode, [ --enable-devel-mode force the devel mode (warnings and warn-error). --disable-devel-mode force the distrib mode (no warnings and no warn-error). ], DEVELOPMENT=$enableval, DEVELOPMENT=$DEFAULT_DEVEL_MODE, # default value ) if test "$DEVELOPMENT" = "yes" ; then AC_MSG_NOTICE(Development mode: warnings and warn-errors are activated) else AC_MSG_NOTICE(Distribution mode: all warnings are deactivated) 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 OCAMLDEP="$OCAMLFIND ocamldep" 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 # ocamlcp AC_CHECK_PROG(OCAMLCP,ocamlcp,ocamlcp,no) if test "$OCAMLCP" = no ; then AC_MSG_ERROR(Cannot find ocamlcp.) else OCAMLCP="$OCAMLFIND ocamlcp" fi # ocamlgraph ############ AC_MSG_CHECKING(for ocamlgraph) OCAMLGRAPH=$($OCAMLFIND query ocamlgraph -format %v) if test -z "$OCAMLGRAPH" ; then AC_MSG_ERROR(Cannot find ocamlgraph via ocamlfind \ (requires ocamlgraph 1.8.5 or higher).) fi case $OCAMLGRAPH in 0.* | 1.[[01234567]].* \ | 1.8.0 | 1.8.0+dev \ | 1.8.1 | 1.8.1+dev \ | 1.8.2 | 1.8.2+dev \ | 1.8.3 | 1.8.3+dev \ | 1.8.4 | 1.8.4+dev) AC_MSG_ERROR(found $OCAMLGRAPH: requires 1.8.5 or higher.);; 1.8.5 | 1.8.6 | 1.8.7) AC_MSG_RESULT(found);; *) AC_MSG_RESULT(found $OCAMLGRAPH: should work);; esac # zarith ######## AC_MSG_CHECKING(for zarith) ZARITH=$($OCAMLFIND query zarith -format %v) if test -z "$ZARITH" ; then AC_MSG_ERROR(Cannot find zarith via ocamlfind.) else AC_MSG_RESULT(found) 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 OCAMLDOC="$OCAMLFIND ocamldoc" fi AC_CHECK_PROG(OCAMLMKTOP,ocamlmktop,ocamlmktop,no) if test "$OCAMLMKTOP" = no ; then AC_MSG_RESULT(Cannot find ocamlmktop: toplevels cannot be built.) else OCAMLMKTOP="$OCAMLFIND ocamlmktop" fi AC_CHECK_PROG(OTAGS,otags,otags,) # apron ######## AC_MSG_CHECKING(for Apron) APRON_PATH=$($OCAMLFIND query apron 2>/dev/null | tr -d '\r\n') if test -f "$APRON_PATH/apron.cmxs"; then HAS_APRON="yes"; AC_MSG_RESULT(found) else HAS_APRON="no"; AC_MSG_RESULT(not found. The corresponding domains won't be available in Eva) fi; # landmarks (profiling tool, for developers) ######## AC_ARG_ENABLE( landmarks, [ --enable-landmarks enable landmarks profiling (default: yes if package installed)], ENABLE_LANDMARKS=$enableval, ENABLE_LANDMARKS=yes) if test "$ENABLE_LANDMARKS" = yes ; then AC_MSG_CHECKING(for Landmarks) LANDMARKS_PATH=$($OCAMLFIND query landmarks 2>/dev/null | tr -d '\r\n') LANDMARKS_PPX_PATH=$($OCAMLFIND query landmarks.ppx 2>/dev/null | tr -d '\r\n') if test -f "$LANDMARKS_PATH/landmarks.cmxs" -a -f "$LANDMARKS_PPX_PATH/ppx_landmarks"; then HAS_LANDMARKS="yes"; AC_MSG_RESULT(found) else HAS_LANDMARKS="no"; AC_MSG_RESULT(not found.) fi; else AC_MSG_RESULT(Landmarks profiling disabled); HAS_LANDMARKS="no" fi ############ # Platform # ############ new_section "configure platform" AC_MSG_CHECKING(platform) # get Sys.os_type as OCAML_OS_TYPE echo "let () = print_string Sys.os_type;;" > test_os_type.ml $OCAMLC -o test_os_type test_os_type.ml OCAML_OS_TYPE=$(./test_os_type) rm -f test_os_type.cmi test_os_type.cmo test_os_type.ml test_os_type if test "$OCAML_OS_TYPE" = "Win32"; then AC_MSG_RESULT(Win32) AC_CHECK_PROG(CYGPATH,cygpath,cygpath,no) OCAMLWIN32=yes EXE=.exe # OCaml on Win32 does not support vmthreads, use native ones. HAS_NATIVE_THREADS=yes else OCAMLWIN32=no if test "$OCAML_OS_TYPE" = "Cygwin"; then AC_MSG_RESULT(Cygwin) EXE=.exe else AC_MSG_RESULT(Unix) EXE= fi # OCaml native threads AC_MSG_CHECKING([OCaml native threads]) echo "let f = Thread.create (fun () -> ())" > test_native_threads.ml if ($OCAMLOPT -thread -o test_native_threads unix.cmxa threads.cmxa \ test_native_threads.ml) 2> /dev/null ; \ then HAS_NATIVE_THREADS=yes AC_MSG_RESULT([ok.]) else HAS_NATIVE_THREADS=no AC_MSG_WARN([unsupported.]) fi rm -f test_native_threads* fi # C and POSIX standard headers used by C bindings. AC_LANG([C]) AC_ARG_WITH(cc,[specifies a custom C compiler and pre-processor],[CC=$withval]) AC_PROG_CC AC_CHECK_HEADERS(stdlib.h) AC_CHECK_HEADERS(assert.h) AC_CHECK_HEADERS(float.h) AC_CHECK_HEADERS(math.h) AC_CHECK_HEADERS(signal.h) AC_CHECK_HEADERS(unistd.h) # Local machdep feature (to generate new platforms) AC_ARG_ENABLE( localmachdep, [ --enable-localmachdep enable local machdep configuration], LOCAL_MACHDEP=$enableval, LOCAL_MACHDEP=no) if test "$LOCAL_MACHDEP" = yes ; then AC_CONFIG_HEADER(config.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 " >$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 } 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) if test "$HAVE_BUILTIN_VA_LIST" = "true" ;then AC_DEFINE_UNQUOTED(HAVE_BUILTIN_VA_LIST, 1) fi AC_MSG_CHECKING([if __thread is a keyword]) AC_COMPILE_IFELSE([AC_LANG_SOURCE([int main(int __thread) { return 0; }])], THREAD_IS_KEYWORD=false, THREAD_IS_KEYWORD=true) AC_MSG_RESULT($THREAD_IS_KEYWORD) if test "$THREAD_IS_KEYWORD" = "true" ;then AC_DEFINE_UNQUOTED(THREAD_IS_KEYWORD, 1) fi # 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([AC_LANG_SOURCE([int main() { __asm__("jmp _main"); }])], UNDERSCORE_NAME=true, UNDERSCORE_NAME=false) AC_MSG_RESULT($UNDERSCORE_NAME) if test "$UNDERSCORE_NAME" = "true" ;then AC_DEFINE_UNQUOTED(UNDERSCORE_NAME, 1) fi fi # local machdep configuration ################################### # Frama-C's pre-processor support # ################################### # Specific preprocessor support AC_ARG_WITH( cpp, [ --with-cpp customize default preprocessor for Frama-C], [FRAMAC_DEFAULT_CPP=$withval], [FRAMAC_DEFAULT_CPP=]) # if no specific pre-processor has been given, check whether we can use # $CC. Note that we want to keep comments in the output, so that AC_PROG_CPP # alone is not sufficient. if test -z "$FRAMAC_DEFAULT_CPP"; then AC_PROG_CPP CPPFLAGS="-C -I."; if test -n "$GCC"; then FRAMAC_GNU_CPP=true; else FRAMAC_GNU_CPP=false; fi else CPP=$FRAMAC_DEFAULT_CPP; FRAMAC_GNU_CPP=true; CPPFLAGS="-dD -nostdinc" AC_PREPROC_IFELSE( [AC_LANG_SOURCE([#define foo 0 /* foo */ ])], FRAMAC_GNU_CPP=true, FRAMAC_GNU_CPP=false) CPPFLAGS= fi AC_PREPROC_IFELSE( [AC_LANG_SOURCE([/* Check whether comments are kept in output */])], [if test -e conftest.i; then if grep -e kept conftest.i; then FRAMAC_DEFAULT_CPP="$CPP $CPPFLAGS"; DEFAULT_CPP_KEEP_COMMENTS=true; else AC_MSG_WARN([Default pre-processing command '$CPP' do not preserve comments. Please define an appropriate pre-processor with --with-cpp, or you will only be able to use ACSL annotations in already pre-processed files]) FRAMAC_DEFAULT_CPP=$CPP; DEFAULT_CPP_KEEP_COMMENTS=false; fi; else # handling old version of autoconf (<2.67) that does not keep # preprocessor result in conftest.i AC_MSG_WARN([Unable to check whether $CPP preserves comments. Assuming everything is fine]) FRAMAC_DEFAULT_CPP="$CPP $CPPFLAGS"; DEFAULT_CPP_KEEP_COMMENTS=true; fi ], [AC_MSG_WARN([Unable to find a working pre-processor. Please define one with --with-cpp, or you will be able to launch Frama-C only on pre-processed files])]; FRAMAC_DEFAULT_CPP=""; DEFAULT_CPP_KEEP_COMMENTS=false; ) AC_MSG_RESULT(Default preprocessor is '$FRAMAC_DEFAULT_CPP'.) FRAMAC_DEFAULT_CPP_ARGS=$CPPFLAGS # Test if preprocessor supports options such as -m16/-m32/-m64 DEFAULT_CPP_SUPPORTED_ARCH_OPTS= # Store original value of CPPFLAGS before doing tests OLD_CPPFLAGS=$CPPFLAGS rm -f conftest.i CPPFLAGS="$OLD_CPPFLAGS -m32" AC_PREPROC_IFELSE( [AC_LANG_SOURCE([/* Check if preprocessor supports option -m32 */])], [if test -e conftest.i; then DEFAULT_CPP_SUPPORTED_ARCH_OPTS+='\"-m32\"; '; fi], []) rm -f conftest.i CPPFLAGS="$OLD_CPPFLAGS -m64" AC_PREPROC_IFELSE( [AC_LANG_SOURCE([/* Check if preprocessor supports option -m64 */])], [if test -e conftest.i; then DEFAULT_CPP_SUPPORTED_ARCH_OPTS+='\"-m64\"; '; fi], []) rm -f conftest.i CPPFLAGS="$OLD_CPPFLAGS -m16" AC_PREPROC_IFELSE( [AC_LANG_SOURCE([/* Check if preprocessor supports option -m16 */])], [if test -e conftest.i; then DEFAULT_CPP_SUPPORTED_ARCH_OPTS+='\"-m16\"; '; fi], []) # revert CPPFLAGS to original value CPPFLAGS=$OLD_CPPFLAGS AC_MSG_RESULT(Default preprocessor supported architecture-related options: $DEFAULT_CPP_SUPPORTED_ARCH_OPTS) ################# # 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= # Tool declarations #################### DOT= REQUIRE_DOT= USE_DOT= HAS_DOT= ### Now plugin declarations PLUGINS_FORCE_LIST= ############################################################################### # # #################### # # Plug-in sections # # #################### # # # # For 'internal' developers: # # Add your own plug-in here # # # ############################################################################### # callgraph ########### check_plugin(callgraph, src/plugins/callgraph, [support for callgraph plugin], yes, yes) plugin_use_external(callgraph,dot) plugin_use(callgraph,gui) plugin_use(callgraph,value_analysis) # constant propagation ###################### check_plugin(semantic_constant_folding, src/plugins/constant_propagation, [support for constant propagation plugin],yes,yes) plugin_require(semantic_constant_folding,value_analysis) # from ###### check_plugin(from_analysis,src/plugins/from,[support for from analysis],yes,yes) plugin_require(from_analysis,value_analysis) plugin_require(from_analysis,callgraph) # gui ##### check_plugin(gui,src/plugins/gui,[support for gui],yes,no) plugin_require_external(gui,lablgtk) plugin_require_external(gui,gnomecanvas) plugin_require_external(gui,gtksourceview) plugin_use_external(gui,dot) # impact ######## check_plugin(impact,src/plugins/impact,[support for impact plugin],yes,yes) 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/plugins/inout,[support for inout analysis],yes,yes) plugin_require(inout,from_analysis) plugin_require(inout,value_analysis) plugin_require(inout,callgraph) # metrics ######### check_plugin(metrics,src/plugins/metrics,[support for metrics analysis],yes,yes) plugin_use(metrics,value_analysis) plugin_use(metrics,gui) # occurrence ############ check_plugin(occurrence,src/plugins/occurrence, [support for occurrence analysis],yes,yes) plugin_use(occurrence,gui) plugin_require(occurrence,value_analysis) # pdg ##### check_plugin(pdg,src/plugins/pdg,[support for pdg plugin],yes,yes,pdg_types) plugin_require(pdg,from_analysis) plugin_require(pdg,value_analysis) plugin_require(pdg,callgraph) # postdominators ################ check_plugin(postdominators,src/plugins/postdominators, [support for postdominators plugin],yes,yes) # rte ##### check_plugin(rtegen,src/plugins/rte, [support for runtime error annotation],yes,yes) # scope ############ check_plugin(scope,src/plugins/scope,[support for scope plugin],yes,yes) plugin_require(scope,postdominators) plugin_require(scope,value_analysis) plugin_require(scope,from_analysis) plugin_require(scope,pdg) plugin_use(scope,gui) # slicing ######### check_plugin(slicing,src/plugins/slicing,[support for slicing plugin],yes,yes, src/slicing_types) plugin_require(slicing,from_analysis) plugin_require(slicing,pdg) plugin_require(slicing,value_analysis) plugin_require(slicing,callgraph) plugin_use(slicing,gui) # spare code ############ check_plugin(sparecode,src/plugins/sparecode, [support for sparecode plugin],yes,yes) plugin_require(sparecode,pdg) plugin_require(sparecode,value_analysis) # users ####### check_plugin(users,src/plugins/users,[support for users analysis],yes,yes) plugin_require(users,value_analysis) plugin_use(users,callgraph) # value ####### check_plugin(value_analysis,src/plugins/value, [support for value analysis],yes,yes) plugin_use(value_analysis,gui) plugin_use(value_analysis,scope) plugin_use(value_analysis,callgraph) #################### # External plugins # #################### EXTRA_EXTERNAL_PLUGINS= AC_ARG_ENABLE(external, [[ --enable-external=plugin allows to compile directly from Frama-C kernel some external plug-ins.]], [ for dir in $enableval; do if test -d $dir; then AC_MSG_NOTICE([external plug-in $dir found.]) EXTRA_EXTERNAL_PLUGINS="$EXTRA_EXTERNAL_PLUGINS $dir" olddir=$(pwd) cd $dir; if test -x ./configure; then new_section "configure plug-in $dir" ./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 $dir]) fi; cd $olddir else AC_MSG_ERROR([--enable-external expects an existing directory as argument.]) fi; done ]) AC_FOREACH([__plugin],m4_esyscmd([ls src/plugins]), [ m4_if(m4_index(KNOWN_SRC_DIRS,__plugin),[-1], [ m4_define([plugin_dir],[src/plugins/__plugin]) m4_syscmd(test -r plugin_dir/configure.in) m4_define([is_configure_in],m4_sysval) m4_syscmd(test -r plugin_dir/configure.ac) m4_define([is_configure_ac],m4_sysval) m4_define([config_file], [m4_if(is_configure_in,0,plugin_dir/configure.in, m4_if(is_configure_ac,0,plugin_dir/configure.ac,no))]) m4_if(config_file,[no], [ m4_syscmd(test -r plugin_dir/Makefile) m4_if(m4_sysval,[0], [ m4_syscmd(test "$DISTRIB_CONF" = "yes" && \ grep -q -e "PLUGIN_DISTRIBUTED *:= *no" \ plugin_dir/Makefile ) m4_if(m4_sysval,[0],, [ check_plugin(__plugin,plugin_dir, [support for __plugin plug-in],yes,yes) if test "$[ENABLE_]tovarname(__plugin)" != "no"; then EXTERNAL_PLUGINS="$EXTERNAL_PLUGINS plugin_dir"; fi])])], [ m4_syscmd(test "$DISTRIB_CONF" = "yes" && \ grep -q -e "PLUGIN_DISTRIBUTED:=no" \ plugin_dir/Makefile.in) m4_if(m4_sysval,[0],, [ m4_define([plugin_prefix],plugin_dir) m4_include(config_file) m4_syscmd(cd plugin_dir && \ [FRAMAC_SHARE]=../../../share autoconf)]) ]) m4_undefine([plugin_dir]) ]) ]) ##################################################### # 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" 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 configure_library([GTKSOURCEVIEW], [$LABLGTKPATH_FOR_CONFIGURE/lablgtksourceview2.$LIB_SUFFIX], [lablgtksourceview2.$LIB_SUFFIX not found], no) configure_library([GNOMECANVAS], [$LABLGTKPATH_FOR_CONFIGURE/lablgnomecanvas.$LIB_SUFFIX], [lablgnomecanvas.$LIB_SUFFIX not found], no) configure_library([LABLGTK], [$LABLGTKPATH_FOR_CONFIGURE/lablgtk.$LIB_SUFFIX], [$LABLGTKPATH_FOR_CONFIGURE/lablgtk.$LIB_SUFFIX not found.], no) # dot and xdot tools #################### configure_tool([DOT],[dot],[dot not found: you should install GraphViz],no) # Checking some other things which cannot be done too early ########################################################### # Check that native dynlink works 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 AC_MSG_RESULT([native dynlink works fine. Great.]) else AC_MSG_ERROR([native dynlink does not work.]) fi rm -f test_dynlink.* # Native version of ptests can be used only if # - a native compiler exists # - native threads are usable PTESTSBEST=byte if test \ "$OCAMLBEST" = "opt" -a \ "$HAS_NATIVE_THREADS" = "yes"; \ then PTESTSBEST=opt; 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(DEVELOPMENT) AC_SUBST(DOT) AC_SUBST(HAS_DOT) AC_SUBST(HAS_APRON) AC_SUBST(HAS_LANDMARKS) 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(FRAMAC_DEFAULT_CPP_ARGS) AC_SUBST(DEFAULT_CPP_SUPPORTED_ARCH_OPTS) AC_SUBST(FRAMAC_GNU_CPP) AC_SUBST(DEFAULT_CPP_KEEP_COMMENTS) AC_SUBST(CC) AC_SUBST(EXTERNAL_PLUGINS) AC_SUBST(HAS_NATIVE_THREADS) AC_SUBST(PTESTSBEST) 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-Phosphorus-20170501/VERSION0000644000175000017500000000002413113744777015451 0ustar mehdimehdiPhosphorus-20170501 frama-c-Phosphorus-20170501/licenses/0000755000175000017500000000000013113744777016212 5ustar mehdimehdiframa-c-Phosphorus-20170501/licenses/LGPLv30000644000175000017500000001672713113744734017152 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-Phosphorus-20170501/licenses/LGPLv20000644000175000017500000006144713113744734017150 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-Phosphorus-20170501/licenses/GPLv30000644000175000017500000010451313113744734017025 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-Phosphorus-20170501/licenses/LGPLv2.10000644000175000017500000005747613113744734017316 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-Phosphorus-20170501/licenses/Q_MODIFIED_LICENSE0000644000175000017500000007577613113744734020756 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 License, 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 license. 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-Phosphorus-20170501/src/0000755000175000017500000000000013113744777015174 5ustar mehdimehdiframa-c-Phosphorus-20170501/src/kernel_services/0000755000175000017500000000000013113744777020357 5ustar mehdimehdiframa-c-Phosphorus-20170501/src/kernel_services/ast_transformations/0000755000175000017500000000000013113745011024435 5ustar mehdimehdiframa-c-Phosphorus-20170501/src/kernel_services/ast_transformations/clone.mli0000644000175000017500000000354713113745010026250 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 (** Experimental module *) (** Returns a clone of a kernel function and adds it into the AST next to the old one *) val clone_defined_kernel_function: kernel_function -> kernel_function (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_transformations/filter.mli0000644000175000017500000001415213113745011026430 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 it 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] implies 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 : ?last:bool -> string -> Info.proj -> Project.t end (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_transformations/filter.ml0000644000175000017500000011304413113745003026260 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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: ?last:bool -> 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() } 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 _ | Throw _ -> () | 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 _ | TryCatch _ -> (* 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 = Extlib.may Cil.CurrentLoc.set (Cil_datatype.Code_annotation.loc 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 ([], { pred_name = []; pred_loc = Cil_datatype.Location.unknown; pred_content = Ptrue}))) end method private process_call is_init_call call_stmt lval _f args loc = let finfo = self#get_finfo () in let info = (pinfo, finfo) 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 = if is_init_call then begin match lval with | None -> (* initializer takes address of variable *) if Info.param_visible called_finfo 1 then begin match new_args with | { enode = AddrOf (Var v, NoOffset) } :: args -> Local_init(v, ConsInit(var_slice,args,Constructor), loc) | _ -> assert false (* We have kept the first argument. *) end else begin (* variable is useless. *) Call(None, new_funcexp, new_args, loc) end | Some _ -> (match new_lval with | None -> Call (None, new_funcexp, new_args, loc) | Some (Var v, NoOffset) -> Local_init(v, ConsInit(var_slice, new_args, Plain_func), loc) | Some _ -> assert false (* destination must be a variable *)) end else 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)) | Instr (Local_init (v, _, _)) -> (* The initialization of the variable is useless (e.g. because it is overwritten before being read). Just treat it as uninitialized. Note that if the variable itself is invisible, we don't have anything to do: it will not appear at all in the function. *) if Info.loc_var_visible (self#get_finfo()) v then begin let v' = Cil.get_varinfo self#behavior v in v'.vdefined <- false; end; mk_new_stmt s (mk_stmt_skip s) | _ -> 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, f, args, loc)) -> let new_call = self#process_call false s lval f args loc in mk_new_stmt s new_call | Instr (Local_init(v, ConsInit(f, args, kind), loc)) -> let new_call = Cil.treat_constructor_as_func (self#process_call true s) v f args kind loc in (match new_call with | Instr(Call _) -> (* initialization's result was found to be useless. *) v.vdefined <- false | _ -> ()); 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 (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. *) if not (Varinfo.Hashtbl.mem fi_table new_var) then begin 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; GFunDecl (Cil.empty_funspec(), new_var, loc), action end else begin let old_finfo = Varinfo.Hashtbl.find fi_table new_var in if not (finfo = old_finfo) then Kernel.fatal "Found two distinct slices of function %a with the same name %s" Kernel_function.pretty kf new_var.vname; (* already processed: no need for more *) GFunDecl(Cil.empty_funspec(),new_var,loc), fun () -> () end 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) | GFunDecl (_, v, loc) -> debug1 "[vglob_aux] GFunDecl %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) | _ -> Cil.DoChildren end let build_cil_file ?last 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 ?last new_proj_name visitor in debug1 "[build_cil_file] done.@."; prj end (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_transformations/clone.ml0000644000175000017500000001043413113745010026070 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 (** Experimental module *) let mk_new_name = let prefix = "__fc_clone_" in let counter = ref 0 in fun name -> incr counter; prefix ^ (string_of_int !counter) ^ "_" ^ name (** Returns a clone of a defined kernel function to add into the current AST *) let clone_function_definition old_kf = let visitor = new Visitor.frama_c_refresh (Project.current()) in let old_fundec = Kernel_function.get_definition old_kf in let old_loc = Kernel_function.get_location old_kf in let old_funspec = Annotations.funspec ~populate:false old_kf in visitor#set_current_kf old_kf; visitor#set_current_func old_fundec; let new_fundec = Visitor.visitFramacFunction visitor old_fundec in (* update the CFG and sallstmts field *) Cfg.clearCFGinfo ~clear_id:false new_fundec; Cfg.cfgFun new_fundec; let new_vi = new_fundec.svar in new_vi.vname <- mk_new_name old_fundec.svar.vname; let new_funspec = Visitor.visitFramacFunspec visitor old_funspec in (* Creates the kernel function for the clone function. *) let new_kf = (* NOTE: it would be better if the replace function would return the associated kernel function that is new here *) Globals.Functions.replace_by_definition new_funspec new_fundec old_loc; try Globals.Functions.get new_fundec.svar with Not_found -> Kernel.fatal "No clone kernel function for %s(%d)" new_fundec.svar.vname new_fundec.svar.vid in new_kf (** Returns a clone of a kernel function and adds it into the current AST *) let clone_defined_kernel_function old_kf = let f = Ast.get() in let new_kf = clone_function_definition old_kf in let new_fundec = Kernel_function.get_definition new_kf in let new_loc = Kernel_function.get_location new_kf in let gfun = GFun (new_fundec, new_loc) in let old_vi = Kernel_function.get_vi old_kf in let is_old_fundec fundec = Cil_datatype.Varinfo.equal fundec.svar old_vi in let is_old_gfun = function | GFun (fundec,_) -> is_old_fundec fundec | _ -> false in (* Scan the globals. Make sure this is tail recursive. *) let rec loop (acc: global list) = function | [] -> begin match f.globinit with | Some fundec when is_old_fundec fundec -> (* The clone function is the global initializer function. Adds it at the end of the list of globals. *) List.rev_append acc [gfun] | _ -> Kernel.fatal "kernel function not found for %s(%d)" old_vi.vname old_vi.vid end | g :: restg when is_old_gfun g -> List.rev_append acc (g:: gfun ::restg) | g :: restg -> loop (g::acc) restg in (* Updates the list of globals *) f.globals <- loop [] f.globals; Ast.mark_as_grown(); new_kf (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_printing/0000755000175000017500000000000013113745011023036 5ustar mehdimehdiframa-c-Phosphorus-20170501/src/kernel_services/ast_printing/cil_descriptive_printer.mli0000644000175000017500000000410613113745011030455 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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-Phosphorus-20170501/src/kernel_services/ast_printing/printer_builder.ml0000644000175000017500000001330513113745004026565 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 module type PrinterClass = sig class printer : Printer_api.extensible_printer_type end let printer_class_ref = ref (module struct class printer = P.printer () end: PrinterClass) let printer_ref = ref None module type PrinterExtension = functor (X: PrinterClass) -> PrinterClass let set_printer p = printer_class_ref := p; printer_ref := None let update_printer x = let module X = (val x: PrinterExtension) in let module Cur = (val !printer_class_ref: PrinterClass) in let module Updated = X(Cur) in set_printer (module Updated: PrinterClass) let printer () : Printer_api.extensible_printer_type = match !printer_ref with | None -> let module Printer = (val !printer_class_ref: PrinterClass) in let p = new Printer.printer in printer_ref := Some p; p#reset (); p | Some p -> p#reset (); p let current_printer () = !printer_class_ref class extensible_printer = P.printer let without_annot f fmt x = (printer ())#without_annot f fmt x let force_brace f fmt x = (printer ())#force_brace f fmt x let pp_varname fmt x = (printer())#varname 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_node fmt x = (printer ())#predicate_node fmt x let pp_predicate fmt x = (printer ())#predicate 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-Phosphorus-20170501/src/kernel_services/ast_printing/cil_types_debug.ml0000644000175000017500000012734013113745007026545 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 (* Note: these could be made configurable, but since debugging requires frequent modifications of settings and recompilation, it may be simpler to just leave them here. *) (* Ideally, these pretty-printers should produce code that is valid OCaml, but this is not required. *) (* print_location is often omitted. *) let print_locations = false (* compinfo, fieldinfo, enuminfo, typeinfo and varinfo are shortened by default. Setting several to true may result in infinite mutually recursive calls! *) let print_full_compinfo = false let print_full_fieldinfo = false let print_full_enuminfo = false let print_full_typeinfo = false let print_full_varinfo = false let pp_list fmt = Pretty_utils.pp_list fmt ~sep:", " ~pre:"[" ~last:"]" ~suf:"" ~empty:"[]" let pp_option fmt = Pretty_utils.pp_opt ~none:"None" ~pre:"Some(" ~suf:")" fmt let pp_ref pp fmt r = Format.fprintf fmt "Ref(%a)" pp !r let pp_pair fmt1 fmt2 = Pretty_utils.pp_pair ~pre:"(" ~sep:", " ~suf:")" fmt1 fmt2 let pp_tuple3 ?(pre=format_of_string "@[") ?(sep=format_of_string ",@,") ?(suf=format_of_string "@]") fmt1 fmt2 fmt3 fmt (a, b, c) = Format.fprintf fmt "%(%)%a%(%)%a%(%)%a%(%)" pre fmt1 a sep fmt2 b sep fmt3 c suf let pp_tuple4 ?(pre=format_of_string "@[") ?(sep=format_of_string ",@,") ?(suf=format_of_string "@]") fmt1 fmt2 fmt3 fmt4 fmt (a, b, c, d) = Format.fprintf fmt "%(%)%a%(%)%a%(%)%a%(%)%a%(%)" pre fmt1 a sep fmt2 b sep fmt3 c sep fmt4 d suf let pp_tuple5 ?(pre=format_of_string "@[") ?(sep=format_of_string ",@,") ?(suf=format_of_string "@]") fmt1 fmt2 fmt3 fmt4 fmt5 fmt (a, b, c, d, e) = Format.fprintf fmt "%(%)%a%(%)%a%(%)%a%(%)%a%(%)%a%(%)" pre fmt1 a sep fmt2 b sep fmt3 c sep fmt4 d sep fmt5 e suf let pp_integer fmt = Format.fprintf fmt "Integer(%a)" (Integer.pretty ~hexa:false) let pp_int64 fmt i64 = Format.fprintf fmt "Int64(%s)" (Int64.to_string i64) let pp_string = Format.pp_print_string let pp_bool = Format.pp_print_bool let pp_int = Format.pp_print_int let pp_char = Format.pp_print_char let pp_float = Format.pp_print_float let pp_variant pp_term = pp_pair pp_term (pp_option pp_string) let pp_allocation pp_locs fmt = function | FreeAlloc(locs_list1,locs_list2) -> Format.fprintf fmt "FreeAlloc(%a,%a)" (pp_list pp_locs) locs_list1 (pp_list pp_locs) locs_list2 | FreeAllocAny -> Format.fprintf fmt "FreeAllocAny" let pp_deps pp_locs fmt = function | From(locs_list) -> Format.fprintf fmt "From(%a)" (pp_list pp_locs) locs_list | FromAny -> Format.fprintf fmt "FromAny" let pp_from pp_locs = pp_pair pp_locs (pp_deps pp_locs) let pp_assigns pp_locs fmt = function | WritesAny -> Format.fprintf fmt "WritesAny" | Writes(from_list) -> Format.fprintf fmt "Writes(%a)" (pp_list pp_locs) from_list let rec pp_file fmt file = Format.fprintf fmt "{fileName=%a;globals=%a;globinit=%a;globinitcalled=%a}" pp_string file.fileName (pp_list pp_global) file.globals (pp_option pp_fundec) file.globinit pp_bool file.globinitcalled and pp_global fmt = function | GType(typeinfo,location) -> Format.fprintf fmt "GType(%a,%a)" pp_typeinfo typeinfo pp_location location | GCompTag(compinfo,location) -> Format.fprintf fmt "GCompTag(%a,%a)" pp_compinfo compinfo pp_location location | GCompTagDecl(compinfo,location) -> Format.fprintf fmt "GCompTagDecl(%a,%a)" pp_compinfo compinfo pp_location location | GEnumTag(enuminfo,location) -> Format.fprintf fmt "GEnumTag(%a,%a)" pp_enuminfo enuminfo pp_location location | GEnumTagDecl(enuminfo,location) -> Format.fprintf fmt "GEnumTagDecl(%a,%a)" pp_enuminfo enuminfo pp_location location | GVarDecl(varinfo,location) -> Format.fprintf fmt "GVarDecl(%a,%a)" pp_varinfo varinfo pp_location location | GFunDecl(funspec,varinfo,location) -> Format.fprintf fmt "GFunDecl(%a,%a,%a)" pp_funspec funspec pp_varinfo varinfo pp_location location | GVar(varinfo,initinfo,location) -> Format.fprintf fmt "GVar(%a,%a,%a)" pp_varinfo varinfo pp_initinfo initinfo pp_location location | GFun(fundec,location) -> Format.fprintf fmt "GFun(%a,%a)" pp_fundec fundec pp_location location | GAsm(string,location) -> Format.fprintf fmt "GAsm(%a,%a)" pp_string string pp_location location | GPragma(attribute,location) -> Format.fprintf fmt "GPragma(%a,%a)" pp_attribute attribute pp_location location | GText(string) -> Format.fprintf fmt "GText(%a)" pp_string string | GAnnot(global_annotation,location) -> Format.fprintf fmt "GAnnot(%a,%a)" pp_global_annotation global_annotation pp_location location and pp_typ fmt = function | TVoid(attributes) -> Format.fprintf fmt "TVoid(%a)" pp_attributes attributes | TInt(ikind,attributes) -> Format.fprintf fmt "TInt(%a,%a)" pp_ikind ikind pp_attributes attributes | TFloat(fkind,attributes) -> Format.fprintf fmt "TFloat(%a,%a)" pp_fkind fkind pp_attributes attributes | TPtr(typ,attributes) -> Format.fprintf fmt "TPtr(%a,%a)" pp_typ typ pp_attributes attributes | TArray(typ,exp_option,bitsSizeofTypCache,attributes) -> Format.fprintf fmt "TArray(%a,%a,%a,%a)" pp_typ typ (pp_option pp_exp) exp_option pp_bitsSizeofTypCache bitsSizeofTypCache pp_attributes attributes | TFun(typ,string_typ_attributes_tuple_list_option,bool,attributes) -> Format.fprintf fmt "TFun(%a,%a,%a,%a)" pp_typ typ (pp_option (pp_list (pp_tuple3 pp_string pp_typ pp_attributes))) string_typ_attributes_tuple_list_option pp_bool bool pp_attributes attributes | TNamed(typeinfo,attributes) -> Format.fprintf fmt "TNamed(%a,%a)" pp_typeinfo typeinfo pp_attributes attributes | TComp(compinfo,bitsSizeofTypCache,attributes) -> Format.fprintf fmt "TComp(%a,%a,%a)" pp_compinfo compinfo pp_bitsSizeofTypCache bitsSizeofTypCache pp_attributes attributes | TEnum(enuminfo,attributes) -> Format.fprintf fmt "TEnum(%a,%a)" pp_enuminfo enuminfo pp_attributes attributes | TBuiltin_va_list(attributes) -> Format.fprintf fmt "TBuiltin_va_list(%a)" pp_attributes attributes and pp_ikind fmt = function | IBool -> Format.fprintf fmt "IBool" | IChar -> Format.fprintf fmt "IChar" | ISChar -> Format.fprintf fmt "ISChar" | IUChar -> Format.fprintf fmt "IUChar" | IInt -> Format.fprintf fmt "IInt" | IUInt -> Format.fprintf fmt "IUInt" | IShort -> Format.fprintf fmt "IShort" | IUShort -> Format.fprintf fmt "IUShort" | ILong -> Format.fprintf fmt "ILong" | IULong -> Format.fprintf fmt "IULong" | ILongLong -> Format.fprintf fmt "ILongLong" | IULongLong -> Format.fprintf fmt "IULongLong" and pp_fkind fmt = function | FFloat -> Format.fprintf fmt "FFloat" | FDouble -> Format.fprintf fmt "FDouble" | FLongDouble -> Format.fprintf fmt "FLongDouble" and pp_bitsSizeofTyp fmt = function | Not_Computed -> Format.fprintf fmt "Not_Computed" | Computed(int) -> Format.fprintf fmt "Computed(%a)" pp_int int | Not_Computable(string,typ) -> Format.fprintf fmt "Not_Computable(%a,%a)" pp_string string pp_typ typ and pp_bitsSizeofTypCache fmt bitsSizeofTypCache = Format.fprintf fmt "{scache=%a}" pp_bitsSizeofTyp bitsSizeofTypCache.scache and pp_attribute fmt = function | Attr(string,attrparam_list) -> Format.fprintf fmt "Attr(%a,%a)" pp_string string (pp_list pp_attrparam) attrparam_list | AttrAnnot(string) -> Format.fprintf fmt "AttrAnnot(%a)" pp_string string and pp_attributes fmt attributes = (pp_list pp_attribute) fmt attributes and pp_attrparam fmt = function | AInt(integer) -> Format.fprintf fmt "AInt(%a)" pp_integer integer | AStr(string) -> Format.fprintf fmt "AStr(%a)" pp_string string | ACons(string,attrparam_list) -> Format.fprintf fmt "ACons(%a,%a)" pp_string string (pp_list pp_attrparam) attrparam_list | ASizeOf(typ) -> Format.fprintf fmt "ASizeOf(%a)" pp_typ typ | ASizeOfE(attrparam) -> Format.fprintf fmt "ASizeOfE(%a)" pp_attrparam attrparam | AAlignOf(typ) -> Format.fprintf fmt "AAlignOf(%a)" pp_typ typ | AAlignOfE(attrparam) -> Format.fprintf fmt "AAlignOfE(%a)" pp_attrparam attrparam | AUnOp(unop,attrparam) -> Format.fprintf fmt "AUnOp(%a,%a)" pp_unop unop pp_attrparam attrparam | ABinOp(binop,attrparam1,attrparam2) -> Format.fprintf fmt "ABinOp(%a,%a,%a)" pp_binop binop pp_attrparam attrparam1 pp_attrparam attrparam2 | ADot(attrparam,string) -> Format.fprintf fmt "ADot(%a,%a)" pp_attrparam attrparam pp_string string | AStar(attrparam) -> Format.fprintf fmt "AStar(%a)" pp_attrparam attrparam | AAddrOf(attrparam) -> Format.fprintf fmt "AAddrOf(%a)" pp_attrparam attrparam | AIndex(attrparam1,attrparam2) -> Format.fprintf fmt "AIndex(%a,%a)" pp_attrparam attrparam1 pp_attrparam attrparam2 | AQuestion(attrparam1,attrparam2,attrparam3) -> Format.fprintf fmt "AQuestion(%a,%a,%a)" pp_attrparam attrparam1 pp_attrparam attrparam2 pp_attrparam attrparam3 and pp_compinfo fmt compinfo = if print_full_compinfo then Format.fprintf fmt "{\ cstruct=%a;\ corig_name=%a;\ cname=%a;\ ckey=%a;\ cfields=%a;\ cattr=%a;\ cdefined=%a;\ creferenced=%a;\ }" pp_bool compinfo.cstruct pp_string compinfo.corig_name pp_string compinfo.cname pp_int compinfo.ckey (pp_list pp_fieldinfo) compinfo.cfields pp_attributes compinfo.cattr pp_bool compinfo.cdefined pp_bool compinfo.creferenced else Format.fprintf fmt "{\ cstruct=%a;\ corig_name=%a;\ cname=%a;\ ckey=%a;\ cattr=%a;\ }" pp_bool compinfo.cstruct pp_string compinfo.corig_name pp_string compinfo.cname pp_int compinfo.ckey pp_attributes compinfo.cattr and pp_fieldinfo fmt fieldinfo = if print_full_fieldinfo then Format.fprintf fmt "{\ fcomp=%a;\ forig_name=%a;\ fname=%a;\ ftype=%a;\ fbitfield=%a;\ fattr=%a;\ floc=%a;\ faddrof=%a;\ fsize_in_bits=%a;\ foffset_in_bits=%a;\ fpadding_in_bits=%a;\ }" pp_compinfo fieldinfo.fcomp pp_string fieldinfo.forig_name pp_string fieldinfo.fname pp_typ fieldinfo.ftype (pp_option pp_int) fieldinfo.fbitfield pp_attributes fieldinfo.fattr pp_location fieldinfo.floc pp_bool fieldinfo.faddrof (pp_option pp_int) fieldinfo.fsize_in_bits (pp_option pp_int) fieldinfo.foffset_in_bits (pp_option pp_int) fieldinfo.fpadding_in_bits else Format.fprintf fmt "{\ forig_name=%a;\ fname=%a;\ ftype=%a;\ fbitfield=%a;\ fattr=%a;\ floc=%a;\ faddrof=%a;\ }" pp_string fieldinfo.forig_name pp_string fieldinfo.fname pp_typ fieldinfo.ftype (pp_option pp_int) fieldinfo.fbitfield pp_attributes fieldinfo.fattr pp_location fieldinfo.floc pp_bool fieldinfo.faddrof and pp_enuminfo fmt enuminfo = if print_full_enuminfo then Format.fprintf fmt "{\ eorig_name=%a;\ ename=%a;\ eitems=%a;\ eattr=%a;\ ereferenced=%a;\ ekind=%a;\ }" pp_string enuminfo.eorig_name pp_string enuminfo.ename (pp_list pp_enumitem) enuminfo.eitems pp_attributes enuminfo.eattr pp_bool enuminfo.ereferenced pp_ikind enuminfo.ekind else Format.fprintf fmt "{\ eorig_name=%a;\ ename=%a;\ eattr=%a;\ ekind=%a;\ }" pp_string enuminfo.eorig_name pp_string enuminfo.ename pp_attributes enuminfo.eattr pp_ikind enuminfo.ekind and pp_enumitem fmt enumitem = Format.fprintf fmt "{\ eiorig_name=%a;\ einame=%a;\ eival=%a;\ eihost=%a;\ eiloc=%a;\ }" pp_string enumitem.eiorig_name pp_string enumitem.einame pp_exp enumitem.eival pp_enuminfo enumitem.eihost pp_location enumitem.eiloc and pp_typeinfo fmt typeinfo = if print_full_typeinfo then Format.fprintf fmt "{\ torig_name=%a;\ tname=%a;\ ttype=%a;\ treferenced=%a;\ }" pp_string typeinfo.torig_name pp_string typeinfo.tname pp_typ typeinfo.ttype pp_bool typeinfo.treferenced else Format.fprintf fmt "{\ torig_name=%a;\ tname=%a;\ }" pp_string typeinfo.torig_name pp_string typeinfo.tname and pp_varinfo fmt varinfo = if print_full_varinfo then Format.fprintf fmt "{\ vname=%a;\ vorig_name=%a;\ vtype=%a;\ vattr=%a;\ vstorage=%a;\ vglob=%a;\ vdefined=%a;\ vformal=%a;\ vinline=%a;\ vdecl=%a;\ vid=%a;\ vaddrof=%a;\ vreferenced=%a;\ vtemp=%a;\ vdescr=%a;\ vdescrpure=%a;\ vghost=%a;\ vsource=%a;\ vlogic_var_assoc=%a;\ }" pp_string varinfo.vname pp_string varinfo.vorig_name pp_typ varinfo.vtype pp_attributes varinfo.vattr pp_storage varinfo.vstorage pp_bool varinfo.vglob pp_bool varinfo.vdefined pp_bool varinfo.vformal pp_bool varinfo.vinline pp_location varinfo.vdecl pp_int varinfo.vid pp_bool varinfo.vaddrof pp_bool varinfo.vreferenced pp_bool varinfo.vtemp (pp_option pp_string) varinfo.vdescr pp_bool varinfo.vdescrpure pp_bool varinfo.vghost pp_bool varinfo.vsource (pp_option pp_logic_var) varinfo.vlogic_var_assoc else Format.fprintf fmt "{vname=%a;vid=%a}" pp_string varinfo.vname pp_int varinfo.vid and pp_storage fmt = function | NoStorage -> Format.fprintf fmt "NoStorage" | Static -> Format.fprintf fmt "Static" | Register -> Format.fprintf fmt "Register" | Extern -> Format.fprintf fmt "Extern" and pp_exp fmt exp = Format.fprintf fmt "{eid=%a;enode=%a;eloc=%a}" pp_int exp.eid pp_exp_node exp.enode pp_location exp.eloc and pp_exp_node fmt = function | Const(constant) -> Format.fprintf fmt "Const(%a)" pp_constant constant | Lval(lval) -> Format.fprintf fmt "Lval(%a)" pp_lval lval | SizeOf(typ) -> Format.fprintf fmt "SizeOf(%a)" pp_typ typ | SizeOfE(exp) -> Format.fprintf fmt "SizeOfE(%a)" pp_exp exp | SizeOfStr(string) -> Format.fprintf fmt "SizeOfStr(%a)" pp_string string | AlignOf(typ) -> Format.fprintf fmt "AlignOf(%a)" pp_typ typ | AlignOfE(exp) -> Format.fprintf fmt "AlignOfE(%a)" pp_exp exp | UnOp(unop,exp,typ) -> Format.fprintf fmt "UnOp(%a,%a,%a)" pp_unop unop pp_exp exp pp_typ typ | BinOp(binop,exp1,exp2,typ) -> Format.fprintf fmt "BinOp(%a,%a,%a,%a)" pp_binop binop pp_exp exp1 pp_exp exp2 pp_typ typ | CastE(typ,exp) -> Format.fprintf fmt "CastE(%a,%a)" pp_typ typ pp_exp exp | AddrOf(lval) -> Format.fprintf fmt "AddrOf(%a)" pp_lval lval | StartOf(lval) -> Format.fprintf fmt "StartOf(%a)" pp_lval lval | Info(exp,exp_info) -> Format.fprintf fmt "Info(%a,%a)" pp_exp exp pp_exp_info exp_info and pp_exp_info fmt _exp_info = Format.fprintf fmt "pp_exp_info_TODO" (*{ exp_type : logic_type; exp_name: string_list; }*) and pp_constant fmt = function | CInt64(integer,ikind,string_option) -> Format.fprintf fmt "CInt64(%a,%a,%a)" pp_integer integer pp_ikind ikind (pp_option pp_string) string_option | CStr(string) -> Format.fprintf fmt "CStr(%a)" pp_string string | CWStr(int64_list) -> Format.fprintf fmt "CWStr(%a)" (pp_list pp_int64) int64_list | CChr(char) -> Format.fprintf fmt "CChr(%a)" pp_char char | CReal(float,fkind,string_option) -> Format.fprintf fmt "CReal(%a,%a,%a)" pp_float float pp_fkind fkind (pp_option pp_string) string_option | CEnum(enumitem) -> Format.fprintf fmt "CEnum(%a)" pp_enumitem enumitem and pp_unop fmt = function | Neg -> Format.fprintf fmt "Neg" | BNot -> Format.fprintf fmt "BNot" | LNot -> Format.fprintf fmt "LNot" and pp_binop fmt = function | PlusA -> Format.fprintf fmt "PlusA" | PlusPI -> Format.fprintf fmt "PlusPI" | IndexPI -> Format.fprintf fmt "IndexPI" | MinusA -> Format.fprintf fmt "MinusA" | MinusPI -> Format.fprintf fmt "MinusPI" | MinusPP -> Format.fprintf fmt "MinusPP" | Mult -> Format.fprintf fmt "Mult" | Div -> Format.fprintf fmt "Div" | Mod -> Format.fprintf fmt "Mod" | Shiftlt -> Format.fprintf fmt "Shiftlt" | Shiftrt -> Format.fprintf fmt "Shiftrt" | Lt -> Format.fprintf fmt "Lt" | Gt -> Format.fprintf fmt "Gt" | Le -> Format.fprintf fmt "Le" | Ge -> Format.fprintf fmt "Ge" | Eq -> Format.fprintf fmt "Eq" | Ne -> Format.fprintf fmt "Ne" | BAnd -> Format.fprintf fmt "BAnd" | BXor -> Format.fprintf fmt "BXor" | BOr -> Format.fprintf fmt "BOr" | LAnd -> Format.fprintf fmt "LAnd" | LOr -> Format.fprintf fmt "LOr" and pp_lval fmt = pp_pair pp_lhost pp_offset fmt and pp_lhost fmt = function | Var(varinfo) -> Format.fprintf fmt "Var(%a)" pp_varinfo varinfo | Mem(exp) -> Format.fprintf fmt "Mem(%a)" pp_exp exp and pp_offset fmt = function | NoOffset -> Format.fprintf fmt "NoOffset" | Field(fieldinfo,offset) -> Format.fprintf fmt "Field(%a,%a)" pp_fieldinfo fieldinfo pp_offset offset | Index(exp,offset) -> Format.fprintf fmt "Index(%a,%a)" pp_exp exp pp_offset offset and pp_init fmt = function | SingleInit(exp) -> Format.fprintf fmt "SingleInit(%a)" pp_exp exp | CompoundInit(typ,offset_init_pair_list) -> Format.fprintf fmt "CompoundInit(%a,%a)" pp_typ typ (pp_list (pp_pair pp_offset pp_init)) offset_init_pair_list and pp_initinfo fmt _initinfo = Format.fprintf fmt "pp_initinfo_TODO" (*{ mutable init : init_option }*) and pp_fundec fmt _fundec = Format.fprintf fmt "pp_fundec_TODO" (*{ mutable svar: varinfo; mutable sformals: varinfo_list; mutable slocals: varinfo_list; mutable smaxid: int; mutable sbody: block; mutable smaxstmtid: int_option; mutable sallstmts: stmt_list; mutable sspec: funspec; }*) and pp_block fmt _block = Format.fprintf fmt "pp_block_TODO" (*{ mutable battrs: attributes; mutable blocals: varinfo_list; mutable bstmts: stmt_list; }*) and pp_stmt fmt _stmt = Format.fprintf fmt "pp_stmt_TODO" (*{ mutable labels: label_list; mutable skind: stmtkind; mutable sid: int; mutable succs: stmt_list; mutable preds: stmt_list; mutable ghost : bool }*) and pp_label fmt = function | Label(string,location,bool) -> Format.fprintf fmt "Label(%a,%a,%a)" pp_string string pp_location location pp_bool bool | Case(exp,location) -> Format.fprintf fmt "Case(%a,%a)" pp_exp exp pp_location location | Default(location) -> Format.fprintf fmt "Default(%a)" pp_location location and pp_stmtkind fmt = function | Instr(instr) -> Format.fprintf fmt "Instr(%a)" pp_instr instr | Return(exp_option,location) -> Format.fprintf fmt "Return(%a,%a)" (pp_option pp_exp) exp_option pp_location location | Goto(stmt_ref,location) -> Format.fprintf fmt "Goto(%a,%a)" (pp_ref pp_stmt) stmt_ref pp_location location | Break(location) -> Format.fprintf fmt "Break(%a)" pp_location location | Continue(location) -> Format.fprintf fmt "Continue(%a)" pp_location location | If(exp,block1,block2,location) -> Format.fprintf fmt "If(%a,%a,%a,%a)" pp_exp exp pp_block block1 pp_block block2 pp_location location | Switch(exp,block,stmt_list,location) -> Format.fprintf fmt "Switch(%a,%a,%a,%a)" pp_exp exp pp_block block (pp_list pp_stmt) stmt_list pp_location location | Loop(code_annotation_list,block,location,stmt_option1,stmt_option2) -> Format.fprintf fmt "Loop(%a,%a,%a,%a,%a)" (pp_list pp_code_annotation) code_annotation_list pp_block block pp_location location (pp_option pp_stmt) stmt_option1 (pp_option pp_stmt) stmt_option2 | Block(block) -> Format.fprintf fmt "Block(%a)" pp_block block | UnspecifiedSequence(stmt_lval_list_lval_list_lval_list_stmt_ref_list_tuple_list) -> Format.fprintf fmt "UnspecifiedSequence(%a)" (pp_list (pp_tuple5 pp_stmt (pp_list pp_lval) (pp_list pp_lval) (pp_list pp_lval) (pp_list (pp_ref pp_stmt)))) stmt_lval_list_lval_list_lval_list_stmt_ref_list_tuple_list | Throw(exp_typ_pair_option,location) -> Format.fprintf fmt "Throw(%a,%a)" (pp_option (pp_pair pp_exp pp_typ)) exp_typ_pair_option pp_location location | TryCatch(block,catch_binder_block_pair_list,location) -> Format.fprintf fmt "TryCatch(%a,%a,%a)" pp_block block (pp_list (pp_pair pp_catch_binder pp_block)) catch_binder_block_pair_list pp_location location | TryFinally(block1,block2,location) -> Format.fprintf fmt "TryFinally(%a,%a,%a)" pp_block block1 pp_block block2 pp_location location | TryExcept(block1,instr_list_exp_pair,block2,location) -> Format.fprintf fmt "TryExcept(%a,%a,%a,%a)" pp_block block1 (pp_pair (pp_list pp_instr) pp_exp) instr_list_exp_pair pp_block block2 pp_location location and pp_catch_binder fmt = function | Catch_exn(varinfo,varinfo_block_pair_list) -> Format.fprintf fmt "Catch_exn(%a,%a)" pp_varinfo varinfo (pp_list (pp_pair pp_varinfo pp_block)) varinfo_block_pair_list | Catch_all -> Format.fprintf fmt "Catch_all" and pp_constructor_kind fmt = function | Constructor -> Format.pp_print_string fmt "Constructor" | Plain_func -> Format.pp_print_string fmt "Plain_func" and pp_local_init fmt = function | AssignInit i -> Format.fprintf fmt "AssignInit(%a)" pp_init i | ConsInit(f,args,kind) -> Format.fprintf fmt "ConsInit(%a,%a,%a)" pp_varinfo f (pp_list pp_exp) args pp_constructor_kind kind and pp_instr fmt = function | Set(lval,exp,location) -> Format.fprintf fmt "Set(%a,%a,%a)" pp_lval lval pp_exp exp pp_location location | Call(lval_option,exp,exp_list,location) -> Format.fprintf fmt "Call(%a,%a,%a,%a)" (pp_option pp_lval) lval_option pp_exp exp (pp_list pp_exp) exp_list pp_location location | Asm(attributes,string_list,extended_asm_option,location) -> Format.fprintf fmt "Asm(%a,%a,%a,%a)" pp_attributes attributes (pp_list pp_string) string_list (pp_option pp_extended_asm) extended_asm_option pp_location location | Skip(location) -> Format.fprintf fmt "Skip(%a)" pp_location location | Code_annot(code_annotation,location) -> Format.fprintf fmt "Code_annot(%a,%a)" pp_code_annotation code_annotation pp_location location | Local_init(vi,i,location) -> Format.fprintf fmt "Local_init(%a,%a,%a)" pp_varinfo vi pp_local_init i pp_location location and pp_extended_asm fmt _extended_asm = Format.fprintf fmt "pp_extended_asm_TODO" (*{ { asm_outputs: (string_option * string * lval)_list; asm_inputs: (string_option * string * exp)_list; asm_clobbers: string_list; asm_gotos: (stmt ref)_list; }*) and pp_lexing_position fmt lexing_position = Format.fprintf fmt "{pos_fname=%s;pos_lnum=%d;pos_bol=%d;pos_cnum=%d}" lexing_position.Lexing.pos_fname lexing_position.Lexing.pos_lnum lexing_position.Lexing.pos_bol lexing_position.Lexing.pos_cnum and pp_location fmt (pos_start,pos_end) = let p = if print_locations then Format.fprintf else Format.ifprintf in p fmt "(%a,%a)" pp_lexing_position pos_start pp_lexing_position pos_end and pp_logic_constant fmt = function | Integer(integer,string_option) -> Format.fprintf fmt "Integer(%a,%a)" pp_integer integer (pp_option pp_string) string_option | LStr(string) -> Format.fprintf fmt "LStr(%a)" pp_string string | LWStr(int64_list) -> Format.fprintf fmt "LWStr(%a)" (pp_list pp_int64) int64_list | LChr(char) -> Format.fprintf fmt "LChr(%a)" pp_char char | LReal(logic_real) -> Format.fprintf fmt "LReal(%a)" pp_logic_real logic_real | LEnum(enumitem) -> Format.fprintf fmt "LEnum(%a)" pp_enumitem enumitem and pp_logic_real fmt _logic_real = Format.fprintf fmt "pp_logic_real_TODO" (*{ r_literal : string ; r_nearest : float ; r_upper : float ; r_lower : float ; }*) and pp_logic_type fmt = function | Ctype(typ) -> Format.fprintf fmt "Ctype(%a)" pp_typ typ | Ltype(logic_type_info,logic_type_list) -> Format.fprintf fmt "Ltype(%a,%a)" pp_logic_type_info logic_type_info (pp_list pp_logic_type) logic_type_list | Lvar(string) -> Format.fprintf fmt "Lvar(%a)" pp_string string | Linteger -> Format.fprintf fmt "Linteger" | Lreal -> Format.fprintf fmt "Lreal" | Larrow(logic_type_list,logic_type) -> Format.fprintf fmt "Larrow(%a,%a)" (pp_list pp_logic_type) logic_type_list pp_logic_type logic_type and pp_identified_term fmt identified_term = Format.fprintf fmt "{it_id=%a;it_content=%a}" pp_int identified_term.it_id pp_term identified_term.it_content and pp_logic_label fmt = function | StmtLabel(stmt_ref) -> Format.fprintf fmt "StmtLabel(%a)" (pp_ref pp_stmt) stmt_ref | LogicLabel(stmt_option,string) -> Format.fprintf fmt "LogicLabel(%a,%a)" (pp_option pp_stmt) stmt_option pp_string string and pp_term fmt term = Format.fprintf fmt "{term_node=%a;term_loc=%a;term_type=%a;term_name=%a}" pp_term_node term.term_node pp_location term.term_loc pp_logic_type term.term_type (pp_list pp_string) term.term_name and pp_term_node fmt = function | TConst(logic_constant) -> Format.fprintf fmt "TConst(%a)" pp_logic_constant logic_constant | TLval(term_lval) -> Format.fprintf fmt "TLval(%a)" pp_term_lval term_lval | TSizeOf(typ) -> Format.fprintf fmt "TSizeOf(%a)" pp_typ typ | TSizeOfE(term) -> Format.fprintf fmt "TSizeOfE(%a)" pp_term term | TSizeOfStr(string) -> Format.fprintf fmt "TSizeOfStr(%a)" pp_string string | TAlignOf(typ) -> Format.fprintf fmt "TAlignOf(%a)" pp_typ typ | TAlignOfE(term) -> Format.fprintf fmt "TAlignOfE(%a)" pp_term term | TUnOp(unop,term) -> Format.fprintf fmt "TUnOp(%a,%a)" pp_unop unop pp_term term | TBinOp(binop,term1,term2) -> Format.fprintf fmt "TBinOp(%a,%a,%a)" pp_binop binop pp_term term1 pp_term term2 | TCastE(typ,term) -> Format.fprintf fmt "TCastE(%a,%a)" pp_typ typ pp_term term | TAddrOf(term_lval) -> Format.fprintf fmt "TAddrOf(%a)" pp_term_lval term_lval | TStartOf(term_lval) -> Format.fprintf fmt "TStartOf(%a)" pp_term_lval term_lval | Tapp(logic_info,logic_label_logic_label_pair_list,term_list) -> Format.fprintf fmt "Tapp(%a,%a,%a)" pp_logic_info logic_info (pp_list (pp_pair pp_logic_label pp_logic_label)) logic_label_logic_label_pair_list (pp_list pp_term) term_list | Tlambda(quantifiers,term) -> Format.fprintf fmt "Tlambda(%a,%a)" pp_quantifiers quantifiers pp_term term | TDataCons(logic_ctor_info,term_list) -> Format.fprintf fmt "TDataCons(%a,%a)" pp_logic_ctor_info logic_ctor_info (pp_list pp_term) term_list | Tif(term1,term2,term3) -> Format.fprintf fmt "Tif(%a,%a,%a)" pp_term term1 pp_term term2 pp_term term3 | Tat(term,logic_label) -> Format.fprintf fmt "Tat(%a,%a)" pp_term term pp_logic_label logic_label | Tbase_addr(logic_label,term) -> Format.fprintf fmt "Tbase_addr(%a,%a)" pp_logic_label logic_label pp_term term | Toffset(logic_label,term) -> Format.fprintf fmt "Toffset(%a,%a)" pp_logic_label logic_label pp_term term | Tblock_length(logic_label,term) -> Format.fprintf fmt "Tblock_length(%a,%a)" pp_logic_label logic_label pp_term term | Tnull -> Format.fprintf fmt "Tnull" | TLogic_coerce(logic_type,term) -> Format.fprintf fmt "TLogic_coerce(%a,%a)" pp_logic_type logic_type pp_term term | TCoerce(term,typ) -> Format.fprintf fmt "TCoerce(%a,%a)" pp_term term pp_typ typ | TCoerceE(term1,term2) -> Format.fprintf fmt "TCoerceE(%a,%a)" pp_term term1 pp_term term2 | TUpdate(term1,term_offset,term2) -> Format.fprintf fmt "TUpdate(%a,%a,%a)" pp_term term1 pp_term_offset term_offset pp_term term2 | Ttypeof(term) -> Format.fprintf fmt "Ttypeof(%a)" pp_term term | Ttype(typ) -> Format.fprintf fmt "Ttype(%a)" pp_typ typ | Tempty_set -> Format.fprintf fmt "Tempty_set" | Tunion(term_list) -> Format.fprintf fmt "Tunion(%a)" (pp_list pp_term) term_list | Tinter(term_list) -> Format.fprintf fmt "Tinter(%a)" (pp_list pp_term) term_list | Tcomprehension(term,quantifiers,predicate_option) -> Format.fprintf fmt "Tcomprehension(%a,%a,%a)" pp_term term pp_quantifiers quantifiers (pp_option pp_predicate) predicate_option | Trange(term_option1,term_option2) -> Format.fprintf fmt "Trange(%a,%a)" (pp_option pp_term) term_option1 (pp_option pp_term) term_option2 | Tlet(logic_info,term) -> Format.fprintf fmt "Tlet(%a,%a)" pp_logic_info logic_info pp_term term and pp_term_lval fmt = pp_pair pp_term_lhost pp_term_offset fmt and pp_term_lhost fmt = function | TVar(logic_var) -> Format.fprintf fmt "TVar(%a)" pp_logic_var logic_var | TResult(typ) -> Format.fprintf fmt "TResult(%a)" pp_typ typ | TMem(term) -> Format.fprintf fmt "TMem(%a)" pp_term term and pp_model_info fmt _model_info = Format.fprintf fmt "pp_model_info_TODO" (*{ mi_name: string; mi_field_type: logic_type; mi_base_type: typ; mi_decl: location; mutable mi_attr: attributes; }*) and pp_term_offset fmt = function | TNoOffset -> Format.fprintf fmt "TNoOffset" | TField(fieldinfo,term_offset) -> Format.fprintf fmt "TField(%a,%a)" pp_fieldinfo fieldinfo pp_term_offset term_offset | TModel(model_info,term_offset) -> Format.fprintf fmt "TModel(%a,%a)" pp_model_info model_info pp_term_offset term_offset | TIndex(term,term_offset) -> Format.fprintf fmt "TIndex(%a,%a)" pp_term term pp_term_offset term_offset and pp_logic_info fmt _logic_info = Format.fprintf fmt "pp_logic_info_TODO" (*{ mutable l_var_info : logic_var; mutable l_labels : logic_label_list; mutable l_tparams : string_list; mutable l_type : logic_type_option; mutable l_profile : logic_var_list; mutable l_body : logic_body; }*) and pp_builtin_logic_info fmt _builtin_logic_info = Format.fprintf fmt "pp_builtin_logic_info_TODO" (*{ 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 pp_logic_body fmt = function | LBnone -> Format.fprintf fmt "LBnone" | LBreads(identified_term_list) -> Format.fprintf fmt "LBreads(%a)" (pp_list pp_identified_term) identified_term_list | LBterm(term) -> Format.fprintf fmt "LBterm(%a)" pp_term term | LBpred(predicate) -> Format.fprintf fmt "LBpred(%a)" pp_predicate predicate | LBinductive(string_logic_label_list_string_list_predicate_list) -> Format.fprintf fmt "LBinductive(%a)" (pp_list (pp_tuple4 pp_string (pp_list pp_logic_label) (pp_list pp_string) pp_predicate)) string_logic_label_list_string_list_predicate_list and pp_logic_type_info fmt _logic_type_info = Format.fprintf fmt "pp_logic_type_info_TODO" (*{ lt_name: string; lt_params : string_list; mutable lt_def: logic_type_def_option; mutable lt_attr: attributes; }*) and pp_logic_type_def fmt = function | LTsum(logic_ctor_info_list) -> Format.fprintf fmt "LTsum(%a)" (pp_list pp_logic_ctor_info) logic_ctor_info_list | LTsyn(logic_type) -> Format.fprintf fmt "LTsyn(%a)" pp_logic_type logic_type and pp_logic_var_kind fmt = function | LVGlobal -> Format.fprintf fmt "LVGlobal" | LVC -> Format.fprintf fmt "LVC" | LVFormal -> Format.fprintf fmt "LVFormal" | LVQuant -> Format.fprintf fmt "LVQuant" | LVLocal -> Format.fprintf fmt "LVLocal" and pp_logic_var fmt logic_var = Format.fprintf fmt "{lv_name=%a;lv_id=%a;TODO}" pp_string logic_var.lv_name pp_int logic_var.lv_id (*{ mutable lv_name : string; mutable lv_id : int; mutable lv_type : logic_type; mutable lv_kind: logic_var_kind; mutable lv_origin : varinfo_option; mutable lv_attr: attributes }*) and pp_logic_ctor_info fmt _logic_ctor_info = Format.fprintf fmt "pp_logic_ctor_info_TODO" (*{ ctor_name: string; ctor_type: logic_type_info; ctor_params: logic_type_list }*) and pp_quantifiers fmt = pp_list pp_logic_var fmt and pp_relation fmt = function | Rlt -> Format.fprintf fmt "Rlt" | Rgt -> Format.fprintf fmt "Rgt" | Rle -> Format.fprintf fmt "Rle" | Rge -> Format.fprintf fmt "Rge" | Req -> Format.fprintf fmt "Req" | Rneq -> Format.fprintf fmt "Rneq" and pp_predicate_node fmt = function | Pfalse -> Format.fprintf fmt "Pfalse" | Ptrue -> Format.fprintf fmt "Ptrue" | Papp(logic_info,logic_label_logic_label_pair_list,term_list) -> Format.fprintf fmt "Papp(%a,%a,%a)" pp_logic_info logic_info (pp_list (pp_pair pp_logic_label pp_logic_label)) logic_label_logic_label_pair_list (pp_list pp_term) term_list | Pseparated(term_list) -> Format.fprintf fmt "Pseparated(%a)" (pp_list pp_term) term_list | Prel(relation,term1,term2) -> Format.fprintf fmt "Prel(%a,%a,%a)" pp_relation relation pp_term term1 pp_term term2 | Pand(predicate1,predicate2) -> Format.fprintf fmt "Pand(%a,%a)" pp_predicate predicate1 pp_predicate predicate2 | Por(predicate1,predicate2) -> Format.fprintf fmt "Por(%a,%a)" pp_predicate predicate1 pp_predicate predicate2 | Pxor(predicate1,predicate2) -> Format.fprintf fmt "Pxor(%a,%a)" pp_predicate predicate1 pp_predicate predicate2 | Pimplies(predicate1,predicate2) -> Format.fprintf fmt "Pimplies(%a,%a)" pp_predicate predicate1 pp_predicate predicate2 | Piff(predicate1,predicate2) -> Format.fprintf fmt "Piff(%a,%a)" pp_predicate predicate1 pp_predicate predicate2 | Pnot(predicate) -> Format.fprintf fmt "Pnot(%a)" pp_predicate predicate | Pif(term,predicate1,predicate2) -> Format.fprintf fmt "Pif(%a,%a,%a)" pp_term term pp_predicate predicate1 pp_predicate predicate2 | Plet(logic_info,predicate) -> Format.fprintf fmt "Plet(%a,%a)" pp_logic_info logic_info pp_predicate predicate | Pforall(quantifiers,predicate) -> Format.fprintf fmt "Pforall(%a,%a)" pp_quantifiers quantifiers pp_predicate predicate | Pexists(quantifiers,predicate) -> Format.fprintf fmt "Pexists(%a,%a)" pp_quantifiers quantifiers pp_predicate predicate | Pat(predicate,logic_label) -> Format.fprintf fmt "Pat(%a,%a)" pp_predicate predicate pp_logic_label logic_label | Pvalid_read(logic_label,term) -> Format.fprintf fmt "Pvalid_read(%a,%a)" pp_logic_label logic_label pp_term term | Pvalid(logic_label,term) -> Format.fprintf fmt "Pvalid(%a,%a)" pp_logic_label logic_label pp_term term | Pvalid_function(term) -> Format.fprintf fmt "Pvalid_function(%a)" pp_term term | Pinitialized(logic_label,term) -> Format.fprintf fmt "Pinitialized(%a,%a)" pp_logic_label logic_label pp_term term | Pdangling(logic_label,term) -> Format.fprintf fmt "Pdangling(%a,%a)" pp_logic_label logic_label pp_term term | Pallocable(logic_label,term) -> Format.fprintf fmt "Pallocable(%a,%a)" pp_logic_label logic_label pp_term term | Pfreeable(logic_label,term) -> Format.fprintf fmt "Pfreeable(%a,%a)" pp_logic_label logic_label pp_term term | Pfresh(logic_label1,logic_label2,term1,term2) -> Format.fprintf fmt "Pfresh(%a,%a,%a,%a)" pp_logic_label logic_label1 pp_logic_label logic_label2 pp_term term1 pp_term term2 | Psubtype(term1,term2) -> Format.fprintf fmt "Psubtype(%a,%a)" pp_term term1 pp_term term2 and pp_identified_predicate fmt _identified_predicate = Format.fprintf fmt "pp_identified_predicate_TODO" (*{ ip_id: int; ip_content: predicate; }*) and pp_predicate fmt _predicate = Format.fprintf fmt "pp_predicate_TODO" (*{ pred_name : string_list; pred_loc : location; pred_content : predicate_node; }*) and pp_spec fmt _spec = Format.fprintf fmt "pp_spec_TODO" (*{ mutable spec_behavior : behavior_list; mutable spec_variant : term variant_option; mutable spec_terminates: identified_predicate_option; mutable spec_complete_behaviors: string_list_list; mutable spec_disjoint_behaviors: string_list_list; }*) and pp_acsl_extension fmt = pp_pair pp_string pp_acsl_extension_kind fmt and pp_acsl_extension_kind fmt = function | Ext_id(int) -> Format.fprintf fmt "Ext_id(%a)" pp_int int | Ext_terms(term_list) -> Format.fprintf fmt "Ext_terms(%a)" (pp_list pp_term) term_list | Ext_preds(predicate_list) -> Format.fprintf fmt "Ext_preds(%a)" (pp_list pp_predicate) predicate_list and pp_behavior fmt _behavior = Format.fprintf fmt "pp_behavior_TODO" (*{ mutable b_name : string; mutable b_requires : identified_predicate_list; mutable b_assumes : identified_predicate_list; mutable b_post_cond : (termination_kind * identified_predicate)_list; mutable b_assigns : identified_term assigns; mutable b_allocation : identified_term allocation; mutable b_extended : acsl_extension_list }*) and pp_termination_kind fmt = function | Normal -> Format.fprintf fmt "Normal" | Exits -> Format.fprintf fmt "Exits" | Breaks -> Format.fprintf fmt "Breaks" | Continues -> Format.fprintf fmt "Continues" | Returns -> Format.fprintf fmt "Returns" and pp_loop_pragma pp_term fmt = function | Unroll_specs(term_list) -> Format.fprintf fmt "Unroll_specs(%a)" (pp_list pp_term) term_list | Widen_hints(term_list) -> Format.fprintf fmt "Widen_hints(%a)" (pp_list pp_term) term_list | Widen_variables(term_list) -> Format.fprintf fmt "Widen_variables(%a)" (pp_list pp_term) term_list and pp_slice_pragma pp_term fmt = function | SPexpr(term) -> Format.fprintf fmt "SPexpr(%a)" pp_term term | SPctrl -> Format.fprintf fmt "SPctrl" | SPstmt -> Format.fprintf fmt "SPstmt" and pp_impact_pragma pp_term fmt = function | IPexpr(term) -> Format.fprintf fmt "IPexpr(%a)" pp_term term | IPstmt -> Format.fprintf fmt "IPstmt" and pp_pragma pp_term fmt = function | Loop_pragma(term) -> Format.fprintf fmt "Loop_pragma(%a)" (pp_loop_pragma pp_term) term | Slice_pragma(term) -> Format.fprintf fmt "Slice_pragma(%a)" (pp_slice_pragma pp_term) term | Impact_pragma(term) -> Format.fprintf fmt "Impact_pragma(%a)" (pp_impact_pragma pp_term) term and pp_code_annotation_node fmt = function | AAssert(string_list,predicate) -> Format.fprintf fmt "AAssert(%a,%a)" (pp_list pp_string) string_list pp_predicate predicate | AStmtSpec(string_list,spec) -> Format.fprintf fmt "AStmtSpec(%a,%a)" (pp_list pp_string) string_list pp_spec spec | AInvariant(string_list,bool,predicate) -> Format.fprintf fmt "AInvariant(%a,%a,%a)" (pp_list pp_string) string_list pp_bool bool pp_predicate predicate | AVariant(term_variant) -> Format.fprintf fmt "AVariant(%a)" (pp_variant pp_term) term_variant | AAssigns(string_list,assigns) -> Format.fprintf fmt "AAssigns(%a,%a)" (pp_list pp_string) string_list (pp_assigns (pp_from pp_identified_term)) assigns | AAllocation(string_list,allocation) -> Format.fprintf fmt "AAllocation(%a,%a)" (pp_list pp_string) string_list (pp_allocation pp_identified_term) allocation | APragma(pragma) -> Format.fprintf fmt "APragma(%a)" (pp_pragma pp_term) pragma | AExtended(string_list,acsl_extension) -> Format.fprintf fmt "AExtended(%a,%a)" (pp_list pp_string) string_list pp_acsl_extension acsl_extension and pp_funspec fmt _funspec = Format.fprintf fmt "pp_funspec_TODO" and pp_code_annotation fmt _code_annotation = Format.fprintf fmt "pp_code_annotation_TODO" (*{ annot_id: int; annot_content : code_annotation_node; }*) and pp_funbehavior fmt = pp_behavior fmt and pp_global_annotation fmt = function | Dfun_or_pred(logic_info,location) -> Format.fprintf fmt "Dfun_or_pred(%a,%a)" pp_logic_info logic_info pp_location location | Dvolatile(identified_term_list,varinfo_option1,varinfo_option2,attributes,location) -> Format.fprintf fmt "Dvolatile(%a,%a,%a,%a,%a)" (pp_list pp_identified_term) identified_term_list (pp_option pp_varinfo) varinfo_option1 (pp_option pp_varinfo) varinfo_option2 pp_attributes attributes pp_location location | Daxiomatic(string,global_annotation_list,attributes,location) -> Format.fprintf fmt "Daxiomatic(%a,%a,%a,%a)" pp_string string (pp_list pp_global_annotation) global_annotation_list pp_attributes attributes pp_location location | Dtype(logic_type_info,location) -> Format.fprintf fmt "Dtype(%a,%a)" pp_logic_type_info logic_type_info pp_location location | Dlemma(string,bool,logic_label_list,string_list,predicate,attributes,location) -> Format.fprintf fmt "Dlemma(%a,%a,%a,%a,%a,%a,%a)" pp_string string pp_bool bool (pp_list pp_logic_label) logic_label_list (pp_list pp_string) string_list pp_predicate predicate pp_attributes attributes pp_location location | Dinvariant(logic_info,location) -> Format.fprintf fmt "Dinvariant(%a,%a)" pp_logic_info logic_info pp_location location | Dtype_annot(logic_info,location) -> Format.fprintf fmt "Dtype_annot(%a,%a)" pp_logic_info logic_info pp_location location | Dmodel_annot(model_info,location) -> Format.fprintf fmt "Dmodel_annot(%a,%a)" pp_model_info model_info pp_location location | Dcustom_annot(custom_tree,string,attributes,location) -> Format.fprintf fmt "Dcustom_annot(%a,%a,%a,%a)" pp_custom_tree custom_tree pp_string string pp_attributes attributes pp_location location and pp_custom_tree fmt _custom_tree = Format.fprintf fmt "CustomDummy" let pp_kinstr fmt = function | Kstmt(stmt) -> Format.fprintf fmt "Kstmt(%a)" pp_stmt stmt | Kglobal -> Format.fprintf fmt "Kglobal" let pp_cil_function fmt = function | Definition(fundec,location) -> Format.fprintf fmt "Definition(%a,%a)" pp_fundec fundec pp_location location | Declaration(funspec,varinfo,varinfo_list_option,location) -> Format.fprintf fmt "Declaration(%a,%a,%a,%a)" pp_funspec funspec pp_varinfo varinfo (pp_option (pp_list pp_varinfo)) varinfo_list_option pp_location location let pp_kernel_function fmt _kernel_function = Format.fprintf fmt "pp_kernel_function_TODO" (*{ mutable fundec : cil_function; mutable spec : funspec; }*) let pp_localisation fmt = function | VGlobal -> Format.fprintf fmt "VGlobal" | VLocal(kernel_function) -> Format.fprintf fmt "VLocal(%a)" pp_kernel_function kernel_function | VFormal(kernel_function) -> Format.fprintf fmt "VFormal(%a)" pp_kernel_function kernel_function let pp_mach fmt _mach = Format.fprintf fmt "pp_mach_TODO" (*{ sizeof_short: int; sizeof_int: int; sizeof_long: int ; sizeof_longlong: int; sizeof_ptr: int; sizeof_float: int; sizeof_double: int; sizeof_longdouble: int; sizeof_void: int; sizeof_fun: int; size_t: string; wchar_t: string; ptrdiff_t: string; alignof_short: int; alignof_int: int; alignof_long: int; alignof_longlong: int; alignof_ptr: int; alignof_float: int; alignof_double: int; alignof_longdouble: int; alignof_str: int; alignof_fun: int; char_is_unsigned: bool; underscore_name: bool; const_string_literals: bool; little_endian: bool; alignof_aligned: int; has__builtin_va_list: bool; __thread_is_keyword: bool; compiler: string; cpp_arch_flags: string_list; version: string; }*) frama-c-Phosphorus-20170501/src/kernel_services/ast_printing/cil_descriptive_printer.ml0000644000175000017500000000644413113745006030317 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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-Phosphorus-20170501/src/kernel_services/ast_printing/cil_printer.ml0000644000175000017500000033513013113745002025707 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (* Modified by TrustInSoft *) open Cil_types open Cil_datatype open Printer_api open Format let debug_logic_types = Kernel.register_category "printer:logic-types" let debug_logic_coercions = Kernel.register_category "printer:logic-coercions" let debug_builtins = Kernel.register_category "printer:builtins" let debug_sid = Kernel.register_category "printer:sid" let debug_unspecified = Kernel.register_category "printer:unspecified" module Behavior_extensions = struct let printer_tbl = Hashtbl.create 5 let register name printer = Hashtbl.add printer_tbl name printer let default_pp printer fmt ext = match ext with | Ext_id i -> Format.pp_print_int fmt i | Ext_terms terms -> Pretty_utils.pp_list ~sep:",@ " printer#term fmt terms | Ext_preds preds -> Pretty_utils.pp_list ~sep:",@ " printer#predicate fmt preds let pp (printer:extensible_printer_type) fmt (name, ext) = let pp = try Hashtbl.find printer_tbl name with Not_found -> default_pp in Format.fprintf fmt "@[%s %a;@]" name (pp printer) ext 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 keep_attr = function | Attr (s,_) -> not (List.mem s !reserved_attributes) | AttrAnnot _ -> true let filter_printing_attributes l = List.filter keep_attr l let needs_quote = let regex = Str.regexp "^[A-Za-z0-9_]+$" in fun s -> not (Str.string_match regex s 0) let print_as_source source = Kernel.Debug.get () = 0 && (Kernel.BigIntsHex.is_default () || not (Str.string_match (Str.regexp "^-?[0-9]+$") source 0)) let print_global g = (* This function decides whether to hide Frama-C's own builtins (in fc_builtin_for_normalization). *) let attrs = Cil_datatype.Global.attr g in let printable = not (Cil.hasAttribute "fc_stdlib" attrs) || Kernel.PrintLibc.get() in let print_var v = not (Cil.is_unused_builtin v) || Kernel.is_debug_key_enabled debug_builtins in match g with | GVar (vi,_,_) | GFun ({svar = vi},_) | GVarDecl (vi,_) | GFunDecl (_,vi,_)-> print_var vi && printable | _ -> printable let print_std_includes fmt globs = if not (Kernel.PrintLibc.get ()) then begin let extract_file acc = function | AStr s -> Datatype.String.Set.add s acc | _ -> Kernel.warning "Unexpected attribute parameter for fc_stdlib"; acc in let add_file acc g = let attrs = Cil_datatype.Global.attr g in match Cil.findAttribute "fc_stdlib" attrs with | [ arg ] -> extract_file acc arg | _ -> acc in let includes = List.fold_left add_file Datatype.String.Set.empty globs in let print_one_include s = Format.fprintf fmt "#include \"%s\"@." s in Datatype.String.Set.iter print_one_include includes end 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.two_power 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.Integer.pretty (Integer.pred max_strict_signed) else Format.fprintf fmt "%a%s" Datatype.Integer.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 = None; 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 multiplicativeLevel = 40 let additiveLevel = 60 let comparativeLevel = 70 let bitwiseLevel = 75 let logic_level = 77 (* Be careful if you change the relative order of these 3 levels *) let and_level = 83 let xor_level = 84 let or_level = 85 let assoc_connector_level x = and_level <= x && x <= or_level let binderLevel = 90 let questionLevel = 100 let upperLevel = 110 let getParenthLevelPred = function | Pfalse | Ptrue | Papp _ | Pallocable _ | Pfreeable _ | Pvalid _ | Pvalid_read _ | Pvalid_function _ | Pinitialized _ | Pdangling _ | Pseparated _ | Pat _ | Pfresh _ -> 0 | Pnot _ -> 30 | Psubtype _ -> 75 | Pand _ -> and_level | Pxor _ -> xor_level | Por _ -> or_level | Pimplies _ -> 87 (* and 88 for positive side *) | Piff _ -> 89 | Pif _ -> questionLevel | Prel _ -> comparativeLevel | Plet _ | Pforall _ | Pexists _ -> binderLevel let compareLevel x y = if assoc_connector_level x && assoc_connector_level y then 0 else compare x y let needParens thisLevel contextprec = let c = compareLevel thisLevel contextprec in if c != 0 then c > 0 else not (thisLevel == binderLevel || thisLevel == 89 (* Piff *) || (assoc_connector_level thisLevel && thisLevel == contextprec && not state.print_cil_as_is)) 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),_,_,_) -> multiplicativeLevel (* 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 *) | Tapp({ l_var_info },[],[_;_]) when l_var_info.lv_name = "\\concat" -> bitwiseLevel (* 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),_,_) -> multiplicativeLevel | Tapp({ l_var_info },[],[_;_]) when l_var_info.lv_name = "\\repeat" -> bitwiseLevel (* 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 let needIndent current pred fmt = let nextLevel = getParenthLevelPred pred.pred_content in let need = not (current == binderLevel && nextLevel == binderLevel) in if need then begin pp_open_box fmt 2; kfprintf (fun fmt -> pp_close_box fmt ()) fmt end else fprintf fmt end let get_termination_kind_name = function | Normal -> "ensures" | Exits -> "exits" | Breaks -> "breaks" | Continues -> "continues" | Returns -> "returns" let rec get_pand_list pred l = match pred.pred_content with | Pand(p1,p2) -> get_pand_list p1 (p2::l) | _ -> pred::l let rec get_tand_list term l = match term.term_node with | TBinOp(LAnd,t1,t2) -> get_tand_list t1 (t2::l) | _ -> term::l let is_compatible_rel_binop op1 op2 = match op1, op2 with | (Lt | Le | Eq), (Lt | Le | Eq) -> true | (Gt | Ge | Eq), (Gt | Ge | Eq) -> true | _ -> false let is_compatible_relation op1 op2 = match op1, op2 with | (Rlt | Rle | Req), (Rlt | Rle | Req) -> true | (Rgt | Rge | Req), (Rgt | Rge | Req) -> true | _ -> false type direction = Nothing | Less | Greater | Both let update_direction_binop dir op = match dir, op with | _, Eq -> dir | (Both | Less), (Lt | Le) -> Less | (Both | Greater), (Gt | Ge) -> Greater | _ -> Nothing let update_direction_rel dir op = match dir, op with | _, Req -> dir | (Both | Less), (Rlt | Rle) -> Less | (Both | Greater), (Rgt | Rge) -> Greater | _ -> Nothing let is_same_direction_binop dir op = update_direction_binop dir op <> Nothing let is_same_direction_rel dir op = update_direction_rel dir op <> Nothing (* when pretty-printing relation chains, a < b && b' < c, it can happen that b has a coercion and b' hasn't or vice-versa (bc c is an integer and a and b are ints for instance). We nevertheless want to pretty-print that as a < b < c. For that, we compare b and b' after having removed any existing head coercion. *) let equal_mod_coercion t1 t2 = let t1 = match t1.term_node with TLogic_coerce(_,t1) -> t1 | _ -> t1 in let t2 = match t2.term_node with TLogic_coerce(_,t2) -> t2 | _ -> t2 in Cil_datatype.Term.equal t1 t2 (* Grab one of the labels of a statement *) let rec pickLabel = function | [] -> None | Label (lbl, _, _) :: _ -> Some lbl | _ :: rest -> pickLabel rest let extract_acsl_list t = let rec aux acc t = match t.term_node with | TDataCons ({ ctor_name }, []) when ctor_name = "\\Nil" -> Some (List.rev acc) | TDataCons ({ ctor_name }, [hd; tl]) when ctor_name = "\\Cons" -> aux (hd :: acc) tl | _ -> None in aux [] t let is_cfg_block = function Stmt_block _ -> false | Then_with_else | Other | Body -> true class cil_printer () = object (self) val mutable logic_printer_enabled = true method reset () = () method pp_keyword fmt s = pp_print_string fmt s method pp_acsl_keyword = self#pp_keyword method pp_open_annotation ?(block=true) ?(pre=format_of_string "/*@@") fmt = (if block then Pretty_utils.pp_open_block else Format.fprintf) fmt "%(%)" pre method pp_close_annotation ?(block=true) ?(suf=format_of_string "*/") fmt = (if block then Pretty_utils.pp_close_block else Format.fprintf) fmt "%(%)" suf 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 (* Do not add a value that depends on a non-constant variable of the kernel here (e.g. [Kernel.Debug.get ()]). Due to the way the pretty-printing class is instantiated, this value would be evaluated too soon. Override the [reset] method instead. *) 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 stmt_has_annot _ = false 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 = [] method location fmt loc = let loc = (fst loc) in Format.fprintf fmt "%s:%d" (Filepath.pretty loc.Lexing.pos_fname) loc.Lexing.pos_lnum (* 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.msvcMode () then "L" else "LL" | IULongLong -> if 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 Format.asprintf "(%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} -> self#varname fmt s (*** VARIABLES ***) method varname fmt v = pp_print_string fmt v (* variable use *) method varinfo fmt v = self#varname fmt 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 (* used to check whether StartOf x can be printed as x or must be rendered as &x[0]. *) val mutable parent_non_decay = false (*** EXPRESSIONS ***) method exp fmt (e: exp) = let non_decay = parent_non_decay in parent_non_decay <- false; 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 "%a(%a)" self#pp_keyword "sizeof" (self#typ None) t | SizeOfE e -> fprintf fmt "%a(%a)" self#pp_keyword "sizeof" self#exp_non_decay e | SizeOfStr s -> fprintf fmt "%a(%a)" self#pp_keyword "sizeof" self#constant (CStr s) (* __alignof__ is a gcc extension, which seems to have a subtle semantic difference with newer C11 _Alignof, as mentioned in https://gcc.gnu.org/bugzilla/show_bug.cgi?id=52023 Neither cookie nor keyword for you. *) | AlignOf t -> fprintf fmt "__alignof__(%a)" (self#typ None) t | AlignOfE e -> fprintf fmt "__alignof__(%a)" self#exp_non_decay e | AddrOf lv -> fprintf fmt "& %a" (self#lval_prec Precedence.addrOfLevel) lv | StartOf(lv) -> if state.print_cil_as_is || non_decay then fprintf fmt "&(%a[0])" self#lval lv else self#lval fmt lv method private exp_non_decay fmt e = parent_non_decay <- true; self#exp fmt e 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 designated_init fmt = function | Field(f, NoOffset), i -> fprintf fmt ".%a = " self#varname f.fname; self#init fmt i | Index(e, NoOffset), i -> fprintf fmt "[%a] = " self#exp e; self#init fmt i | _ -> Kernel.fatal "Trying to print malformed initializer" in if not (Cil.isArrayType t) then Pretty_utils.pp_list ~pre:"{@[" ~sep:",@ " ~suf:"@]}" designated_init fmt initl else begin let print_index prev_index (designator,init as di) = let curr_index = match designator with | Index(e,NoOffset) -> Cil.constFoldToInt ~machdep:false e | _ -> None in let designator_needed = match prev_index, curr_index with | None, _ | _, None -> true | Some p, Some c -> not (Integer.equal (Integer.succ p) c) in if designator_needed then designated_init fmt di else self#init fmt init; curr_index in let print_next_index prev_index di = Format.fprintf fmt ",@ "; print_index prev_index di in Format.fprintf fmt "{@["; (match initl with | [] -> () | i::tl -> let curr_index = print_index (Some Integer.minus_one) i in ignore (List.fold_left print_next_index curr_index tl)); Format.fprintf fmt "@]}" end (** 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); let pp_call dest e fmt 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 in 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 LvalStructEq.equal 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 LvalStructEq.equal 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 LvalStructEq.equal 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 LvalStructEq.equal 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 | Local_init(vi, AssignInit i, _) -> Format.fprintf fmt "@[<2>%a =@ %a%s@]" self#vdecl vi self#init i instr_terminator | Local_init(vi, ConsInit(f, args, Constructor), _) -> let args = Cil.mkAddrOfVi vi :: args in Format.fprintf fmt "@[<2>%a%s@]@\n" self#vdecl vi instr_terminator; pp_call None (Cil.evar f) fmt args | Local_init(vi, ConsInit(f, args, Plain_func), _) -> Format.fprintf fmt "@[<2>%a =@ %a@]" self#vdecl vi (pp_call None (Cil.evar f)) args; (* 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 () 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 () 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,_) -> pp_call dest e fmt args | Asm(attrs, tmpls, ext_asm, l) -> self#line_directive fmt l; let goto = match ext_asm with Some { asm_gotos = _::_ } -> " goto" | _ -> "" in if Cil.msvcMode () then fprintf fmt "__asm%s {@[%a@]}%s" goto (Pretty_utils.pp_list ~sep:"@\n" (fun fmt s -> fprintf fmt "%s" s)) tmpls instr_terminator else begin fprintf fmt "@[__asm__%s%a (@,@[%a@]" goto self#attributes attrs (Pretty_utils.pp_list ~sep:"@\n" (fun fmt x -> fprintf fmt "%S" x)) tmpls; (match ext_asm with | None -> () | Some { asm_outputs; asm_inputs; asm_clobbers; asm_gotos } -> let lab_nil = asm_gotos = [] in let lab_clob_nil = asm_clobbers = [] && lab_nil in let lab_clob_in_nil = asm_inputs = [] && lab_clob_nil in (* We must output at least one column to distinguish basic asm from extended asm whose components are all empty. Other columns will be pretty-printed only if needed, i.e. if there is at least one non-empty list still to be printed. *) Format.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 ^ "] ") c self#lval lv)) asm_outputs; if not lab_clob_in_nil then Format.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 ^ "] ") c self#exp e)) asm_inputs; if not lab_clob_nil then Format.fprintf fmt "@;@[: %a@]" (Pretty_utils.pp_list ~sep:",@ " (fun fmt c -> fprintf fmt "%S" c)) asm_clobbers; (* No need to output a final colon if there's no label. *) if not lab_nil then Pretty_utils.pp_list ~pre:"@;@[:" ~suf:"@]" ~sep:",@ " (fun fmt r -> match pickLabel !r.labels with | Some label -> Format.pp_print_string fmt label | None -> Kernel.error "Cannot find label for target of asm goto: %a" (self#without_annot self#stmt) !r; Format.pp_print_string fmt "__invalid_label") fmt asm_gotos); 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; Format.fprintf fmt "%t " (fun fmt -> self#pp_open_annotation fmt); self#code_annotation fmt annot ; Format.fprintf fmt "@ %t" (fun fmt -> self#pp_close_annotation fmt); end (** For variadic calls *) method private getLastNamedArgument () = match self#current_function with | None -> Kernel.error ~current:true "Current stmt not positioned"; Cil_datatype.Exp.dummy | Some vi -> let formals = Cil.getFormalsDecl vi in match List.rev formals with | [] -> assert false (* Typing error, this function is variadic and should have at least one argument *) | f :: _ -> Cil.new_exp ~loc:f.vdecl (Lval (Cil.var f)) (**** 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 ~pre:"@[" ~sep:"@ " ~suf:"@]@ " self#label fmt s.labels method label fmt = function | Label (s, _, b) when b || not verbose -> fprintf fmt "@[%s:@]" s | Label (s, _, _) -> fprintf fmt "@[%s: /* internal */@]" s | Case (e, _) -> fprintf fmt "@[%a %a:@]" self#pp_keyword "case" self#exp e | Default _ -> fprintf fmt "@[%a:@]" self#pp_keyword "default" (* number of opened ghost code *) val mutable is_ghost = false method private display_comment () = not is_ghost || verbose method annotated_stmt (next: stmt) fmt (s: stmt) = pp_open_hvbox fmt 0; self#stmt_labels fmt s; (* print the statement. *) if Cil.is_skip s.skind && not s.ghost then begin if verbose || s.labels <> [] then fprintf fmt ";" end else begin let was_ghost = is_ghost in let display_ghost = s.ghost && not was_ghost in if display_ghost then begin is_ghost <- true; Format.fprintf fmt "%t %a " (fun fmt -> self#pp_open_annotation fmt) self#pp_acsl_keyword "ghost" end; self#stmtkind next fmt s.skind ; if display_ghost then begin is_ghost <- false; self#pp_close_annotation fmt end end; pp_close_box fmt () method private require_braces ctxt blk = force_brace || verbose || Kernel.is_debug_key_enabled debug_sid (* If one the of condition above is true, /* sid:... */ will be printed on its own line before s. Braces are needed *) || ctxt = Body (* function body is always between braces. *) || (let attrs = filter_printing_attributes blk.battrs in match blk.bstmts, attrs, blk.blocals, ctxt with | _, _, _ :: _,_ | _, _ :: _, _, _ -> true | _::_::_,[],[],Stmt_block s -> not (Cil.has_extern_local_init blk) && self#stmt_has_annot s (* Do not put braces around a Local_init statement if we are not in the appropriate block. This trumps the presence of a binding annotation, in case of something like: { /* start of scoping block */ //@ slicing pragma stmt; /* { */ /* start of non-scoping block int x = 42; x++; ... /* } */ /* end of non-scoping block x++; } /* end of scoping block */ In such case, the pretty-printer can't satisfy the scope of the annotation and the scope of x at the same time. We favor x, which gives us at least a correct, compilable, C code. *) | _::_::_,[],[],_ -> is_cfg_block ctxt | [ { skind = Block b } as s' ], [], [], Stmt_block _ -> b.bscoping && self#require_braces ctxt b && not (self#require_braces (Stmt_block s') b) (* If b wants braces in current context but not in subcontext, put braces directly there. Otherwise, wait for children to do it. *) | [ { skind = Block b } ], [], [], _ -> self#require_braces ctxt b | [ { skind = UnspecifiedSequence s } ], [], [], _ -> self#require_braces ctxt (Cil.block_from_unspecified_sequence s) | [_],[],[], Then_with_else -> self#block_has_dangling_else blk | [ _ ], [], [], _ -> false | [],[],[],_ -> false) method private inline_block ctxt blk = match blk.bstmts with | [] | [ { skind = (Instr _ | Return _ | Goto _ | Break _ | Continue _ ) } ] -> not (self#require_braces ctxt blk) | [ { skind = Block blk } ] -> self#inline_block ctxt blk | _ -> false method private block_is_function blk = match blk.bstmts with | [ { skind = Instr (Call _) } ] -> true | [ { skind = Instr (Local_init (_, ConsInit _, _)) } ] -> true (* NB: a block consisting solely of an initializer is pretty useless, but who knows? *) | [ { 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 display_ghost = v.vghost && not is_ghost in Format.fprintf fmt "@[%t%a;%t@]" (if display_ghost then (fun fmt -> Format.fprintf fmt "%t %a@ " (fun fmt -> self#pp_open_annotation ~block:false fmt) self#pp_acsl_keyword "ghost") else ignore) self#vdecl v (if display_ghost then (fun fmt -> Format.fprintf fmt "@ %t" (fun fmt -> self#pp_close_annotation ~block:false fmt)) else ignore) (* no box around the block *) method private unboxed_block ?(cut=true) ctxt fmt blk = let braces = self#require_braces ctxt blk in let inline = not braces && self#inline_block ctxt blk in if braces then pp_print_char fmt '{'; if braces && not inline then pp_print_space fmt (); if blk.blocals <> [] && verbose then fprintf fmt "@[/* Locals: %a */@]@ " (Pretty_utils.pp_list ~sep:",@ " self#varinfo) blk.blocals; if verbose && not blk.bscoping then fprintf fmt "/* non-scoping */@\n"; 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; let locals_decl = List.filter (fun v -> not v.vdefined) blk.blocals in if locals_decl <> [] then Pretty_utils.pp_list ~pre:"@[" ~sep:"@;" ~suf:"@]@ " self#vdecl_complete fmt locals_decl; 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>}" (* wrapper for unboxed_block. Mainly for keeping a method per type in Cil_types. All internal calls are directed to unboxed_block. *) method block fmt (blk: block) = fprintf fmt "@[%a@]" (self#unboxed_block Other) blk (* 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 = 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.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; " \"" ^ (Filepath.pretty (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 ctxt = match self#current_stmt with None -> Other | Some s -> Stmt_block s in let as_block = Cil.block_from_unspecified_sequence seq in let require_braces = self#require_braces ctxt as_block in let inline_block = self#inline_block ctxt as_block in let print_stmt pstmt fmt (stmt, modifies, writes, reads,_) = pstmt fmt stmt; if verbose || Kernel.is_debug_key_enabled debug_unspecified 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 ] -> print_stmt (self#next_stmt Cil.invalidStmt) fmt srw | srw_first :: ((s_next,_,_,_,_) :: _ as tail) -> print_stmt (self#next_stmt s_next) fmt srw_first ; pp_print_space fmt (); iterblock fmt tail in fprintf fmt "%t%a%t" (fun fmt -> if require_braces then fprintf fmt "@[@[{ /* sequence */@;" else if inline_block then fprintf fmt "@[" else fprintf fmt "@[") iterblock seq (if require_braces then fun fmt -> fprintf fmt "@]@;}@]" else fun fmt -> pp_close_box fmt ()) | Return(None, l) -> fprintf fmt "@[%a%a;@]" (fun fmt -> self#line_directive fmt) l self#pp_keyword "return" | Return(Some e, l) -> fprintf fmt "@[%a@[%a@ %a;@]@]" (fun fmt -> self#line_directive fmt) l self#pp_keyword "return" self#exp e | Goto (sref, l) -> begin match pickLabel !sref.labels with | Some lbl -> fprintf fmt "@[%a%a %s;@]" (fun fmt -> self#line_directive fmt) l self#pp_keyword "goto" lbl | None -> Kernel.error "Cannot find label for target of goto: %a" (self#without_annot self#stmt) !sref; fprintf fmt "@[%a@ __invalid_label;@]" self#pp_keyword "goto" end | Break l -> fprintf fmt "@[%a%a;@]" (fun fmt -> self#line_directive fmt) l self#pp_keyword "break" | Continue l -> fprintf fmt "@[%a%a;@]" (fun fmt -> self#line_directive fmt) l self#pp_keyword "continue" | Instr i -> self#instr fmt i | If(be,t,{bstmts=[];battrs=[]},l) when not state.print_cil_as_is -> fprintf fmt "@[%a@[%a (%a) %a@]@]" (fun fmt -> self#line_directive ~forcefile:false fmt) l self#pp_keyword "if" self#exp be (self#unboxed_block Other) t | If(be,t,{bstmts=[{skind=Goto(gref,_);labels=[]}]; battrs=[]},l) when !gref == next && not state.print_cil_as_is -> fprintf fmt "@[%a@[%a (%a) %a@]@]" (fun fmt -> self#line_directive ~forcefile:false fmt) l self#pp_keyword "if" self#exp be (self#unboxed_block Other) t | If(be,{bstmts=[];battrs=[]},e,l) when not state.print_cil_as_is -> fprintf fmt "@[%a@[%a (%a) %a@]@]" (fun fmt -> self#line_directive ~forcefile:false fmt) l self#pp_keyword "if" self#exp (Cil.dummy_exp(UnOp(LNot,be,Cil.intType))) (self#unboxed_block Other) e | If(be,{bstmts=[{skind=Goto(gref,_);labels=[]}]; battrs=[]},e,l) when !gref == next && not state.print_cil_as_is -> fprintf fmt "@[%a@[%a (%a) %a@]@]" (fun fmt -> self#line_directive ~forcefile:false fmt) l self#pp_keyword "if" self#exp (Cil.dummy_exp(UnOp(LNot,be,Cil.intType))) (self#unboxed_block Other) e; | If(be,t,e,l) -> pp_open_hvbox fmt 0; self#line_directive fmt l; let else_at_newline = (self#require_braces Then_with_else t) || not (self#inline_block Then_with_else t) || not (self#inline_block Other 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 "@[%a (%a) %a@]" self#pp_keyword "if" self#exp be (self#unboxed_block Then_with_else) t; if else_at_newline then fprintf fmt "@\n" else fprintf fmt "@ "; fprintf fmt "@[%a %a@]" self#pp_keyword "else" (self#unboxed_block Other) e; pp_close_box fmt () | Switch(e,b,_,l) -> fprintf fmt "@[%a@[%a (%a) %a@]@]" (fun fmt -> self#line_directive ~forcefile:false fmt) l self#pp_keyword "switch" self#exp e (self#unboxed_block Other) b | Loop(a, b, l, _, _) -> Format.pp_open_hvbox fmt 0; if logic_printer_enabled && a <> [] then begin Format.fprintf fmt "%t " (fun fmt -> self#pp_open_annotation fmt); Pretty_utils.pp_list ~sep:"@\n" self#code_annotation fmt a; Format.fprintf fmt "@ %t" (fun fmt -> self#pp_close_annotation fmt); end; ((* Maybe the first thing is a conditional. Turn it into a WHILE *) try let rec skipEmpty = function | [] -> [] | { skind = Instr (Skip _) } 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 _ } as s ] when self#may_be_skipped s -> e, rest | [], [ { skind = Goto(sref, _) } as s ] when self#may_be_skipped s && Cil_datatype.Stmt.equal !sref next -> e, rest | [ { skind = Break _ } as s ], [] when self#may_be_skipped s -> Cil.dummy_exp (UnOp(LNot, e, Cil.intType)), rest | [ { skind = Goto(sref, _) } as s ], [] when self#may_be_skipped s && Cil_datatype.Stmt.equal !sref next -> 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@[%a (%a) %a@]" (fun fmt -> self#line_directive fmt) l self#pp_keyword "while" self#exp term (self#unboxed_block Other) b; with Not_found -> Format.fprintf fmt "%a@[%a (1) %a@]" (fun fmt -> self#line_directive fmt) l self#pp_keyword "while" (self#unboxed_block Other) b); Format.pp_close_box fmt () | Block b -> let ctxt = match self#current_stmt with None -> Other | Some s -> Stmt_block s in (* 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 been put before by the callers *) let braces = self#require_braces ctxt b in let open_box = if self#inline_block ctxt b 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 ctxt fmt b; if verbose then Pretty_utils.pp_close_block fmt "/*block:end*/"; pp_close_box fmt () | TryFinally (b, h, l) -> fprintf fmt "@[%a@[__try@ %a@]@ @[__finally@ %a@]@]" (fun fmt -> self#line_directive fmt) l (self#unboxed_block Other) b (self#unboxed_block Other) h | TryExcept (b, (il, e), h, l) -> fprintf fmt "@[%a@[__try@ %a@]@ @[__except(@\n@[" (fun fmt -> self#line_directive fmt) l (self#unboxed_block Other) 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 (self#unboxed_block Other) h | Throw (e,_) -> let print_expr fmt (e,_) = self#exp fmt e in fprintf fmt "@[%a@ %a;@]" self#pp_keyword "throw" (Pretty_utils.pp_opt ~pre:"(" ~suf:")" print_expr) e | TryCatch(body,catch,_) -> let print_var_catch_all fmt v = match v with | Catch_all -> pp_print_string fmt "..." | Catch_exn(v,l) -> fprintf fmt "@[@[%a@]%a@]" self#vdecl v (Pretty_utils.pp_list ~pre:"@;" ~sep:"@;" (fun fmt (v,_) -> self#vdecl fmt v)) l in let print_one_catch fmt (v,b) = fprintf fmt "@[@[%a (@;%a@;)@] %a@]" self#pp_keyword "catch" print_var_catch_all v (self#unboxed_block Other) b in fprintf fmt "@[@[%a %a@]@;@[%a@]@]" self#pp_keyword "try" (self#unboxed_block Other) body (Pretty_utils.pp_list ~pre:"" ~sep:"@;" ~suf:"" print_one_catch) catch (*** GLOBALS ***) method global fmt (g:global) = if print_global g then match g with | GFun (fundec, l) -> 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 let oldattr = List.filter keep_attr oldattr in (* Always print 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 | GType (typ, l) -> self#line_directive ~forcefile:true fmt l; fprintf fmt "%a %a;@\n" self#pp_keyword "typedef" (self#typ (Some (fun fmt -> self#varname fmt 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 "%a@[ %a {@\n%a@]@\n}%a;@\n" self#pp_keyword "enum" self#varname enum.ename (Pretty_utils.pp_list ~sep:",@\n" (fun fmt item -> fprintf fmt "%a = %a" self#varname 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 "%a %a;@\n" self#pp_keyword "enum" 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>%a%a %a {@\n%a@]@\n}%a;@\n" self#pp_keyword 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 "%a %a;@\n" self#pp_keyword (if comp.cstruct then "struct" else "union") self#varname comp.cname | GVar (vi, io, l) -> self#line_directive ~forcefile:true fmt l; Format.fprintf fmt "@["; if vi.vghost then Format.fprintf fmt "%t %a@ " (fun fmt -> self#pp_open_annotation ~block:false fmt) self#pp_acsl_keyword "ghost"; self#vdecl fmt vi; (match io.init with | None -> () | Some i -> fprintf fmt " =@ "; self#init fmt i; ); fprintf fmt ";"; if vi.vghost then Format.fprintf fmt "@ %t" (fun fmt -> self#pp_close_annotation ~block:false fmt); fprintf fmt "@]@\n"; (* print global variable 'extern' declarations *) | GVarDecl (vi, l) -> self#line_directive fmt l; fprintf fmt "%a@\n@\n" self#vdecl_complete vi (* print function prototypes *) | GFunDecl (funspec, vi, l) -> 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; self#out_current_function | 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.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) -> (* attributes are purely internal. *) self#line_directive fmt l; fprintf fmt "%t@ %a@ %t@\n" (fun fmt -> self#pp_open_annotation ~block:false fmt) self#global_annotation decl (fun fmt -> self#pp_close_annotation ~block:false fmt) | 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 self#varname fmt 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 "@["; fprintf fmt "%t %a@ %t" (fun fmt -> self#pp_open_annotation ~block:false fmt) self#funspec funspec (fun fmt -> self#pp_close_annotation ~block:false fmt); fprintf fmt "@]@\n") method private fundecl fmt f = (* declaration. *) let was_ghost = is_ghost in let entering_ghost = f.svar.vghost && not was_ghost in fprintf fmt "@[%t%a@\n@[" (if entering_ghost then (fun fmt -> Format.fprintf fmt "%t %a@ " (fun fmt -> self#pp_open_annotation ~block:false fmt) self#pp_acsl_keyword "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. *) if entering_ghost then is_ghost <- true; self#unboxed_block Body fmt f.sbody; if entering_ghost then is_ghost <- false; fprintf fmt "@]%t@]@." (if entering_ghost then (fun fmt -> Format.fprintf fmt "@ %t" (fun fmt -> self#pp_close_annotation ~block:false fmt)) else ignore) (***** PRINTING DECLARATIONS and TYPES ****) method storage fmt = function | NoStorage -> fprintf fmt "" | Static -> fprintf fmt "%a " self#pp_keyword "static" | Extern -> fprintf fmt "%a " self#pp_keyword "extern" | Register -> fprintf fmt "%a " self#pp_keyword "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.msvcMode () then "__int64" else "long long" | IULongLong -> if 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.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 "%a %a%a%a" self#pp_keyword (if comp.cstruct then "struct" else "union") self#varname comp.cname self#attributes a pname true | TEnum (enum, a) -> fprintf fmt "%a %a%a%a" self#pp_keyword "enum" 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.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' | None -> 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 pp_params fmt args pp_args = fprintf fmt "%t(@[%t@])" name' (fun fmt -> match args with | (None | Some []) when isvararg -> fprintf fmt "..." | None -> () | Some [] -> fprintf fmt "void" | Some args -> Pretty_utils.pp_list ~sep:",@ " pp_args fmt args; if isvararg then fprintf fmt "@ , ...") in let pp_params fmt = match fundecl with | None -> let pp_args fmt (aname,atype,aattr) = (* The storage modifiers come first *) let stom, rest = Cil.separateStorageModifiers aattr in fprintf fmt "%a%a%a" self#attributes stom (self#typ (Some (fun fmt -> fprintf fmt "%s" aname))) atype self#attributes rest in pp_params fmt args pp_args | Some fundecl -> let args = try Some (Cil.getFormalsDecl fundecl) with Not_found -> None in pp_params fmt args self#vdecl in self#typ (Some pp_params) 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", [] -> self#pp_keyword fmt "const"; false (* Put the aconst inside the attribute list *) | "aconst", [] when not (Cil.msvcMode ()) -> fprintf fmt "__const__"; true | "thread", [] when not (Cil.msvcMode ()) -> fprintf fmt "__thread"; false | "volatile", [] -> self#pp_keyword fmt "volatile"; false | "restrict", [] -> fprintf fmt "__restrict"; false | "missingproto", [] -> if self#display_comment () then fprintf fmt "/* missing proto */"; false | "cdecl", [] when Cil.msvcMode () -> fprintf fmt "__cdecl"; false | "stdcall", [] when Cil.msvcMode () -> fprintf fmt "__stdcall"; false | "fastcall", [] when Cil.msvcMode () -> fprintf fmt "__fastcall"; false | "declspec", args when Cil.msvcMode () -> fprintf fmt "__declspec(%a)" (Pretty_utils.pp_list ~sep:"" self#attrparam) args; false | "w64", [] when 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,[])] -> if self#display_comment () then fprintf fmt "/* mode(%s) */" tag; false (* sm: also suppress "format" because we seem to print it in a way gcc does not like *) | "format", _ -> if self#display_comment () then fprintf fmt "/* format attribute */"; false | "hidden", _ -> (* hidden attribute list *) 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 *) false | "arraylen", [a] -> if self#display_comment () then fprintf fmt "/*[%a]*/" self#attrparam a; false | "static",_ -> if self#display_comment () then fprintf fmt "/* static */"; false | "", _ -> fprintf fmt "%a " (Pretty_utils.pp_list ~sep:" " self#attrparam) args; true | s, _ when s = Cil.bitfield_attribute_name && not state.print_cil_as_is -> false | _ -> (* This is the default case *) (* Add underscores to the name *) let an' = if Cil.msvcMode () then "__" ^ an else "__" ^ an ^ "__" in (match args with | [] -> fprintf fmt "%s" an' | _ :: _ -> 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.Integer.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 "%a(%a)" self#pp_keyword "sizeof" self#attrparam a | ASizeOf t -> fprintf fmt "%a(%a)" self#pp_keyword "sizeof" (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 (* __blockattribute__ is not standard, and is used only when we are outputting something destined to Cil. Otherwise we output everything between comments. *) let for_cil s = if state.print_cil_input then "" else s in if block then fprintf fmt " %s __blockattribute__(" (for_cil "/*") else fprintf fmt " __attribute__(("; Pretty_utils.pp_list ~sep:",@ " Format.pp_print_string fmt in__attr__; if not block (* reversed so that highlighting matches *) then fprintf fmt "))" else fprintf fmt ") %s" (for_cil "*/") 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 loop [] (filter_printing_attributes 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.Integer.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} -> self#varname fmt 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 name fmt s = if needs_quote s then Format.fprintf fmt "\"%s\"" s else Format.pp_print_string fmt s 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 method identified_term fmt t = self#term fmt t.it_content method term fmt t = let debug = Kernel.is_debug_key_enabled debug_logic_types in if debug then fprintf fmt "/*(type:%a */" (self#logic_type None) t.term_type; begin match t.term_name with | [] -> self#term_node fmt t | _ :: _ -> fprintf fmt "(@[%a:@ %a@])" (Pretty_utils.pp_list ~sep:":@ " self#name) t.term_name self#term_node t end; if debug then fprintf fmt "/*)*/" (* This instance variable recalls the current program point in order to avoid pretty-printing useless {L} labels. Default to Here. Global annotations must take care of setting it to their declared label if needed. *) 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 private tand_list fmt l = match l with | [] -> () | [ t ] -> self#term_prec Precedence.and_level fmt t | { term_node = TBinOp(op1,low,mid1) } :: { term_node = TBinOp(op2,mid2,up) } :: l when is_compatible_rel_binop op1 op2 && equal_mod_coercion mid1 mid2 -> fprintf fmt "@[%a %a@ %a %a@ %a" (self#term_prec Precedence.comparativeLevel) low self#term_binop op1 (self#term_prec Precedence.comparativeLevel) mid1 self#term_binop op2 (self#term_prec Precedence.comparativeLevel) up; let dir = update_direction_binop (update_direction_binop Both op1) op2 in let rec rel_list dir t = function | [] -> fprintf fmt "@]" | { term_node = TBinOp(op,t',up) } :: l when is_same_direction_binop dir op && equal_mod_coercion t t' -> fprintf fmt " %a@ %a" self#term_binop op (self#term_prec Precedence.comparativeLevel) up; rel_list (update_direction_binop dir op) up l | l -> fprintf fmt "@] %a@ %a" self#term_binop LAnd self#tand_list l in rel_list dir up l | t :: l -> fprintf fmt "%a %a@ %a" (self#term_prec Precedence.and_level) t self#term_binop LAnd self#tand_list l 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) -> (match extract_acsl_list t with | Some l when not state.print_cil_as_is -> fprintf fmt "@,[|@;%a|]" (Pretty_utils.pp_list ~sep:",@ " ~pre:"@[" ~suf:"@]@;" self#term_node) l | _ -> 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 "%a(%a)" self#pp_acsl_keyword "sizeof" (self#typ None) t | TSizeOfE e -> fprintf fmt "%a(%a)" self#pp_acsl_keyword "sizeof" self#term e | TSizeOfStr s -> fprintf fmt "%a(%S)" self#pp_acsl_keyword "sizeof" s | TAlignOf e -> fprintf fmt "%a(%a)" self#pp_acsl_keyword "alignof" (self#typ None) e | TAlignOfE e -> fprintf fmt "%a(%a)" self#pp_acsl_keyword "alignof" self#term e | TUnOp (op,e) -> fprintf fmt "%a%a" self#unop op (self#term_prec current_level) e | TBinOp (LAnd, l, r) when not state.print_cil_as_is -> fprintf fmt "@[%a@]" self#tand_list (get_tand_list l [r]) | 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 (* A few built-ins for lists have special syntax. Use it when we're not in print-as-is mode. *) | Tapp ({ l_var_info },[],[e1; e2]) when l_var_info.lv_name = "\\concat" && not state.print_cil_as_is -> fprintf fmt "%a ^ %a" (self#term_prec current_level) e1 (self#term_prec current_level) e2 | Tapp ({ l_var_info },[],[e1;e2]) when l_var_info.lv_name = "\\repeat" && not state.print_cil_as_is -> fprintf fmt "%a *^ %a" (self#term_prec current_level) e1 (self#term_prec current_level) e2 | 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,lab) -> let old_label = current_label in current_label <- lab; if Cil_datatype.Logic_label.equal lab Logic_const.old_label then fprintf fmt "@[%a(@[%a@])@]" self#pp_acsl_keyword "\\old" self#term t else fprintf fmt "@[%a(@[@[%a@],@,@[%a@]@])@]" self#pp_acsl_keyword "\\at" self#term t self#logic_label lab; current_label <- old_label | Toffset (l,t) -> fprintf fmt "%a%a(%a)" self#pp_acsl_keyword "\\offset" self#labels [l] self#term t | Tbase_addr (l,t) -> fprintf fmt "%a%a(%a)" self#pp_acsl_keyword "\\base_addr" self#labels [l] self#term t | Tblock_length (l,t) -> fprintf fmt "%a%a(%a)" self#pp_acsl_keyword "\\block_length" self#labels [l] self#term t | Tnull -> self#pp_acsl_keyword 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 %a %a = %a}" self#term t self#pp_acsl_keyword "\\with" self#term_offset toff self#term v | Tlambda(prms,expr) -> fprintf fmt "@[<2>%a@ %a;@ %a@]" self#pp_acsl_keyword "\\lambda" self#quantifiers prms (self#term_prec current_level) expr | Ttypeof t -> fprintf fmt "%a(%a)" self#pp_acsl_keyword "\\typeof" self#term t | Ttype ty -> fprintf fmt "%a(%a)" self#pp_acsl_keyword "\\type" (self#typ None) ty | Tunion l when ((List.for_all (fun t -> not(Logic_const.is_set_type t.term_type)) l) && (not state.print_cil_as_is)) -> fprintf fmt "{%a}" (Pretty_utils.pp_list ~sep:",@ " self#term) l | Tunion locs -> fprintf fmt "@[%a(@,%a)@]" self#pp_acsl_keyword "\\union" (Pretty_utils.pp_list ~sep:",@ " self#term) locs | Tinter locs -> fprintf fmt "@[%a(@,%a)@]" self#pp_acsl_keyword "\\inter" (Pretty_utils.pp_list ~sep:",@ " self#term) locs | Tempty_set -> self#pp_acsl_keyword 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#predicate p)) pred | Trange(low,high) -> let pp_term = self#term_prec current_level in fprintf fmt "@[%a..%a@]" (Pretty_utils.pp_opt (fun fmt v -> Format.fprintf fmt "%a " pp_term v)) low (Pretty_utils.pp_opt (fun fmt v -> Format.fprintf fmt "@ %a" pp_term v)) 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 fmt p | LBnone | LBreads _ | LBinductive _ -> Kernel.fatal "invalid logic local definition" in fprintf fmt "@[%a@ %a@ =@ %t%t;@ %a@]" self#pp_acsl_keyword "\\let" self#logic_var v (fun fmt -> if args <> [] then fprintf fmt "@[<2>%a@ %a;@]@ " self#pp_acsl_keyword "\\lambda" self#quantifiers args) pp_defn (self#term_prec current_level) body | TLogic_coerce(ty,t) -> let debug = Kernel.is_debug_key_enabled debug_logic_coercions in if debug then fprintf fmt "/* (coercion to:%a */" (self#logic_type None) ty; self#term_prec current_level fmt t; if debug then fprintf fmt "/* ) */" 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 "%a%a" self#pp_acsl_keyword "\\result" 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 = Precedence.needParens thisLevel contextprec in if needParens then fprintf fmt "@[(%a)@]" self#predicate_node p else self#predicate_node 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:":@ " self#name) names self#pred_prec (Precedence.upperLevel, content) else fprintf fmt "(@[%a:@ %a@])" (Pretty_utils.pp_list ~sep:":@ " self#name) names self#pred_prec (Precedence.upperLevel, content) method private pred_prec_named fmt (parenth,p) = self#named_pred fmt (parenth,p.pred_name,p.pred_content) method predicate fmt p = self#named_pred fmt (Precedence.upperLevel, p.pred_name, p.pred_content) method identified_predicate fmt p = if verbose then fprintf fmt "/* ip:%d */" p.ip_id; self#predicate 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 private pand_list fmt l = let term = self#term_prec Precedence.comparativeLevel in let pred fmt p = self#pred_prec_named fmt (Precedence.and_level,p) in match l with | [] -> () | [p] -> pred fmt p | { pred_content = Prel(rel1, low, mid1) } :: { pred_content = Prel(rel2, mid2, up) } :: l when is_compatible_relation rel1 rel2 && equal_mod_coercion mid1 mid2 -> fprintf fmt "@[%a@ %a@ %a@ %a@ %a" term low self#relation rel1 term mid1 self#relation rel2 term up; let dir = update_direction_rel (update_direction_rel Both rel1) rel2 in let rec rel_list dir t = function | [] -> fprintf fmt "@]" | { pred_content = Prel(rel,t',up) } :: l when is_same_direction_rel dir rel && equal_mod_coercion t t' -> fprintf fmt " %a@ %a" self#relation rel term up; rel_list (update_direction_rel dir rel) up l | l -> fprintf fmt "@] %a@ %a" self#term_binop LAnd self#pand_list l in rel_list dir up l | p :: l -> fprintf fmt "%a %a@ %a" pred p self#term_binop LAnd self#pand_list l method predicate_node fmt p = let current_level = Precedence.getParenthLevelPred p in let term = self#term_prec current_level in match p with | Pfalse -> self#pp_acsl_keyword fmt "\\false" | Ptrue -> self#pp_acsl_keyword 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) when not state.print_cil_as_is -> fprintf fmt "@[%a@]" self#pand_list (get_pand_list p1 [p2]) | 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+1,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 Precedence.needIndent current_level p fmt "@[%a@ %a =@ %t%t;@]@ %a" self#pp_acsl_keyword "\\let" self#logic_var v (fun fmt -> if args <> [] then fprintf fmt "@[%a@ %a;@]@ " self#pp_acsl_keyword "\\lambda" self#quantifiers args) pp_defn self#pred_prec_named (current_level,p) | Pforall (quant,pred) -> Precedence.needIndent current_level pred fmt "@[%t %a;@]@ %a" (fun fmt -> if Kernel.Unicode.get () then pp_print_string fmt Utf8_logic.forall else self#pp_acsl_keyword fmt "\\forall") self#quantifiers quant self#pred_prec_named (current_level,pred) | Pexists (quant,pred) -> Precedence.needIndent current_level pred fmt "@[%t %a;@]@ %a" (fun fmt -> if Kernel.Unicode.get () then pp_print_string fmt Utf8_logic.exists else self#pp_acsl_keyword fmt "\\exists") self#quantifiers quant self#pred_prec_named (current_level,pred) | Pfreeable (l,p) -> fprintf fmt "@[%a%a(@[%a@])@]" self#pp_acsl_keyword "\\freeable" self#labels [l] self#term p | Pallocable (l,p) -> fprintf fmt "@[%a%a(@[%a@])@]" self#pp_acsl_keyword "\\allocable" self#labels [l] self#term p | Pvalid (l,p) -> fprintf fmt "@[%a%a(@[%a@])@]" self#pp_acsl_keyword "\\valid" self#labels [l] self#term p | Pvalid_read (l,p) -> fprintf fmt "@[%a%a(@[%a@])@]" self#pp_acsl_keyword "\\valid_read" self#labels [l] self#term p | Pvalid_function p -> fprintf fmt "@[%a(@[%a@])@]" self#pp_acsl_keyword "\\valid_function" self#term p | Pinitialized (l,p) -> fprintf fmt "@[%a%a(@[%a@])@]" self#pp_acsl_keyword "\\initialized" self#labels [l] self#term p | Pdangling (l,p) -> fprintf fmt "@[%a%a(@[%a@])@]" self#pp_acsl_keyword "\\dangling" self#labels [l] self#term p | Pfresh (l1,l2,e1,e2) -> fprintf fmt "@[%a%a(@[%a@],@[%a@])@]" self#pp_acsl_keyword "\\fresh" self#labels [l1;l2] self#term e1 self#term e2 | Pseparated seps -> fprintf fmt "@[%a(@,%a@,)@]" self#pp_acsl_keyword "\\separated" (Pretty_utils.pp_list ~sep:",@ " self#term) seps | Pat(p,lab) -> let old_label = current_label in current_label <- lab; if Cil_datatype.Logic_label.equal lab Logic_const.old_label then fprintf fmt "@[%a(@[%a@])@]" self#pp_acsl_keyword "\\old" self#pred_prec_named (Precedence.upperLevel,p) else fprintf fmt "@[%a(@[@[%a@],@,%a@])@]" self#pp_acsl_keyword "\\at" self#pred_prec_named (Precedence.upperLevel,p) self#logic_label lab; current_label <- old_label | 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>%a@ %a;@]" self#pp_acsl_keyword kw self#term t | Some str -> (*TODO: replace this string with an interpreted variable*) fprintf fmt "@[<2>%a@ %a@ %a@ %s;@]" self#pp_acsl_keyword kw self#term t self#pp_acsl_keyword "for" 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 "@[%a@ %a;@]" self#pp_acsl_keyword "assumes" self#identified_predicate p method requires fmt p = fprintf fmt "@[%a@ %a;@]" self#pp_acsl_keyword "requires" self#identified_predicate p method post_cond fmt (k,p) = let kw = get_termination_kind_name k in fprintf fmt "@[%a@ %a;@]" self#pp_acsl_keyword kw self#identified_predicate p method terminates fmt p = fprintf fmt "@[%a@ %a;@]" self#pp_acsl_keyword "terminates" self#identified_predicate p method private cd_behaviors fmt kind p = fprintf fmt "@[%a %a;@]" self#pp_acsl_keyword (kind^" behaviors") (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 "@[%a@ %a;@]" self#pp_acsl_keyword (if isloop then "loop allocates" else "allocates") self#pp_acsl_keyword "\\nothing" | FreeAlloc(f,a) -> let pFreeAlloc kw fmt = function | [] -> () | _ :: _ as af -> fprintf fmt "@[%a@ %a;@]" self#pp_acsl_keyword (if isloop then "loop "^kw 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 "@[%a %a;@]" self#pp_acsl_keyword kw self#pp_acsl_keyword "\\nothing" | Writes l -> let without_result = List.filter (function (a,_) -> not (Logic_const.is_exit_status a.it_content)) l in fprintf fmt "@[%t%a@]" (fun fmt -> if without_result <> [] then Format.fprintf fmt "%a " self#pp_acsl_keyword 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 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 "@[@[%a@ %a@]@ @[%a %a@];@]" self#pp_acsl_keyword kw self#identified_term base self#pp_acsl_keyword "\\from" self#pp_acsl_keyword "\\nothing" | From l -> fprintf fmt "@[@[%a@ %a@]@ @[%a %a@];@]" self#pp_acsl_keyword kw self#identified_term base self#pp_acsl_keyword "\\from" (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; (* Template for correct line breaks: let nl_line_n = nb_line_(n+1) || is_empty clause_line_(n+1) *) let nl_assigns = nl || b.b_allocation != FreeAllocAny in let nl_extended = nl_assigns || b.b_assigns != WritesAny in let nl_ensures = nl_extended || 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 "@[%a %s:@;<1 2>@[%a@]@]" self#pp_acsl_keyword "behavior" 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 -> Format.pp_print_string fmt "ctrl" | SPstmt -> Format.pp_print_string fmt "stmt" method private impact_pragma fmt = function | IPexpr t -> fprintf fmt "expr @[%a@]" self#term t | IPstmt -> Format.pp_print_string fmt "stmt" (* TODO: add the annot ID in debug mode?*) method code_annotation fmt ca = let pp_for_behavs fmt l = match l with | [] -> () | l -> Format.fprintf fmt "%a @[%a@]:@ " self#pp_acsl_keyword "for" (Pretty_utils.pp_list ~sep:",@ " pp_print_string) l in match ca.annot_content with | AAssert (behav,p) -> fprintf fmt "@[%a%a@ %a;@]" pp_for_behavs behav self#pp_acsl_keyword "assert" self#predicate p | APragma (Slice_pragma sp) -> fprintf fmt "@[%a@ %a;@]" self#pp_acsl_keyword "slice pragma" self#slice_pragma sp | APragma (Impact_pragma sp) -> fprintf fmt "@[%a@ %a;@]" self#pp_acsl_keyword "impact pragma" self#impact_pragma sp | APragma (Loop_pragma lp) -> fprintf fmt "@[%a@ %a;@]" self#pp_acsl_keyword "loop pragma" 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>%a%a@ %a;@]" pp_for_behavs behav self#pp_acsl_keyword "loop invariant" self#predicate i | AInvariant(behav,false,i) -> fprintf fmt "@[<2>%a%a@ %a;@]" pp_for_behavs behav self#pp_acsl_keyword "invariant" self#predicate i | AVariant v -> self#variant fmt v | AExtended (behav, e) -> fprintf fmt "@[<2>%aloop %a@]" pp_for_behavs behav (Behavior_extensions.pp (self:>Printer_api.extensible_printer_type)) e 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 polyTypePrms 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 Cil_datatype.Logic_label.equal current_label l && not state.print_cil_as_is -> () | _ -> 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 "@[%a %a@ @[<2>{@ %a@ };@]" self#pp_acsl_keyword "model" (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,_) -> let old_label = current_label in (match a.l_labels with [l] -> current_label <- l | _ -> ()); fprintf fmt "@[@[%a %a%a=@]@ %a;@]@\n" self#pp_acsl_keyword "type invariant" self#logic_var a.l_var_info (Pretty_utils.pp_list ~pre:"@[(" ~suf:")@] " ~sep:",@ " self#logicPrms) a.l_profile self#predicate (pred_body a.l_body); current_label <- old_label | Dmodel_annot (mfi,_) -> self#model_info fmt mfi | Dcustom_annot(_c, n ,_attr, _) -> (* attributes are meant to be purely internal for now. *) fprintf fmt "@[%a %s: <...>@]@\n" self#pp_acsl_keyword "custom" n | Dinvariant (pred,_) -> let old_label = current_label in (match pred.l_labels with [l] -> current_label <- l | _ -> ()); fprintf fmt "@[@[%a %a:@]@ %a;@]@\n" self#pp_acsl_keyword "global invariant" self#logic_var pred.l_var_info self#predicate (pred_body pred.l_body); current_label <- old_label | Dlemma(name, is_axiom, labels, tvars, pred, _attr, _) -> (* attributes are meant to be purely internal for now. *) let old_lab = current_label in fprintf fmt "@[@[%a %a%a%a:@]@ %t%a;@]@\n" self#pp_acsl_keyword (if is_axiom then "axiom" else "lemma") self#varname name self#labels labels self#polyTypePrms tvars (* pretty printing of lemma statement is done inside an environment with potentially active labels. However, we want the declaration of the label to be explicit. Hence current_label must be updated after the pretty-printing of labels, and before pretty-printing predicate *) (fun _ -> (match labels with [l] -> current_label <- l | _ -> ())) self#predicate pred; current_label <- old_lab | Dtype (ti,_) -> fprintf fmt "@[@[%a %a%a%a;@]@\n" self#pp_acsl_keyword "type" self#varname ti.lt_name self#polyTypePrms ti.lt_params (fun fmt -> function | None -> fprintf fmt "@]" | Some 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 "@[@[%a %a" self#pp_acsl_keyword "logic" (self#logic_type None) rt | None -> (match li.l_body with | LBinductive _ -> fprintf fmt "@[@[%a" self#pp_acsl_keyword "inductive" | _ -> fprintf fmt "@[@[%a" self#pp_acsl_keyword "predicate")); fprintf fmt "@ %a@,%a@,%a@,%a" self#logic_var li.l_var_info self#labels li.l_labels self#polyTypePrms li.l_tparams (Pretty_utils.pp_list ~pre:"@[(" ~suf:")@] " ~sep:",@ " self#logicPrms) li.l_profile; (* Except for inductive definitions, where this must be done for each individual case that declare a unique label, if the predicate declares a single logic label, it can be chosen as the current one to optimize calls. *) let old_lab = current_label in (match li.l_body with | LBnone -> fprintf fmt ";@]" | LBreads reads -> (match li.l_labels with | [ l ] -> current_label <- l | _ -> ()); (match reads with | [] -> fprintf fmt "@]@\n@[%a %a;@]" self#pp_acsl_keyword "reads" self#pp_acsl_keyword "\\nothing" | _ -> fprintf fmt "@]@\n@[%a@ %a;@]" self#pp_acsl_keyword "reads" (Pretty_utils.pp_list ~sep:",@ " (fun fmt x -> self#term fmt x.it_content)) reads) | LBpred def -> (match li.l_labels with | [ l ] -> current_label <- l | _ -> ()); fprintf fmt "=@]@ %a;" self#predicate def | LBinductive indcases -> fprintf fmt "{@]@ %a}" (Pretty_utils.pp_list ~pre:"@[" ~suf:"@]@\n" ~sep:"@\n" (fun fmt (id,labels,tvars,p) -> Format.fprintf fmt "%a %s%a%a: @[%t%a@];" self#pp_acsl_keyword "case" id self#labels labels self#polyTypePrms tvars (fun _ -> (match labels with [l]-> current_label<-l |_-> ())) self#predicate p; (* we restore the current_label between two cases, since they are completely independent *) current_label <- old_lab)) indcases | LBterm def -> (match li.l_labels with | [ l ] -> current_label <- l | _ -> ()); fprintf fmt "=@]@ %a;" self#term def); fprintf fmt "@]@\n"; current_label <- old_lab | Dvolatile(tsets,rvi_opt,wvi_opt,_attr, _) -> (* attributes are meant to be purely internal for now. *) let pp_vol txt fmt = function | None -> () ; | Some vi -> fprintf fmt "@ %s %a" txt self#varinfo vi in fprintf fmt "@[%a@ %a%a%a;@]" self#pp_acsl_keyword "volatile" (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,_attr, _) -> (* attributes are meant to be purely internal for now. *) fprintf fmt "@[@[%a %s {@]@\n%a}@]@\n" self#pp_acsl_keyword "axiomatic" 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" ; print_std_includes fmt file.globals; 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-Phosphorus-20170501/src/kernel_services/ast_printing/logic_print.ml0000644000175000017500000005061413113745005025712 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* 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 | LTattribute (t,attr) -> let pname fmt = fprintf fmt "%a" Cil_printer.pp_attribute attr in print_logic_type (Some pname) fmt t | 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 | PLrepeat _ -> 72 | 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 _ | PLvalid_function _ | PLinitialized _ | PLdangling _ | PLallocable _ | PLfreeable _ | PLfresh _ | PLseparated _ | PLsubtype _ | PLunion _ | PLinter _ -> 10 | PLvar _ | PLconstant _ | PLresult | PLnull | PLtypeof _ | PLtype _ | PLfalse | PLtrue | PLcomprehension _ | PLempty | PLset _ | PLlist _ -> 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 | PLlist(args) -> fprintf fmt "[@[%a@]]" (pp_list ~sep:",@ " print_lexpr_plain) args | PLrepeat(e1,e2) -> fprintf fmt "%a@ *^@ %a" print_lexpr e1 print_lexpr e2 | 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 | PLvalid_function e -> fprintf fmt "\\valid_function(@;@[%a@]@;)" print_lexpr_plain e | PLinitialized (l,e) -> fprintf fmt "\\initialized%a(@;@[%a@]@;)" print_label_1 l print_lexpr_plain e | PLdangling (l,e) -> fprintf fmt "\\dangling%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 | PLset l -> fprintf fmt "{@ @[%a@]@ }" (pp_list ~pre:"@;@[" ~sep:",@ " ~suf:"@]@;" print_lexpr_plain) l | 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 ~pre:"" ~sep:"" ~suf:"" (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_extension fmt (name, ext) = fprintf fmt "%s %a" name (pp_list ~sep:",@ " print_lexpr) ext 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 | AExtended (bhvs,e) -> fprintf fmt "%aloop %a" print_behaviors bhvs print_extension e (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_printing/printer_builder.mli0000644000175000017500000000353513113745007026745 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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-Phosphorus-20170501/src/kernel_services/ast_printing/cprint.mli0000644000175000017500000001231613113745010025042 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-Phosphorus-20170501/src/kernel_services/ast_printing/description.mli0000644000175000017500000000632113113745010026065 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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_named: Format.formatter -> predicate -> unit (** prints the name of a named logic structure (if any), separated by ','. *) 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'" otherwise *) 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-Phosphorus-20170501/src/kernel_services/ast_printing/logic_print.mli0000644000175000017500000000524113113745003026055 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* 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-Phosphorus-20170501/src/kernel_services/ast_printing/cil_types_debug.mli0000644000175000017500000002233113113745002026703 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 pp_list : 'a Pretty_utils.formatter -> 'a list Pretty_utils.formatter val pp_option : 'a Pretty_utils.formatter -> 'a option Pretty_utils.formatter val pp_ref : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a ref -> unit val pp_pair : 'a Pretty_utils.formatter -> 'b Pretty_utils.formatter -> ('a * 'b) Pretty_utils.formatter val pp_tuple3 : ?pre:('a, 'b, 'c, 'd, 'd, 'a) format6 -> ?sep:('e, 'f, 'g, 'h, 'h, 'e) format6 -> ?suf:('i, 'j, 'k, 'l, 'l, 'i) format6 -> (Format.formatter -> 'm -> unit) -> (Format.formatter -> 'n -> unit) -> (Format.formatter -> 'o -> unit) -> Format.formatter -> 'm * 'n * 'o -> unit val pp_tuple4 : ?pre:('a, 'b, 'c, 'd, 'd, 'a) format6 -> ?sep:('e, 'f, 'g, 'h, 'h, 'e) format6 -> ?suf:('i, 'j, 'k, 'l, 'l, 'i) format6 -> (Format.formatter -> 'm -> unit) -> (Format.formatter -> 'n -> unit) -> (Format.formatter -> 'o -> unit) -> (Format.formatter -> 'p -> unit) -> Format.formatter -> 'm * 'n * 'o * 'p -> unit val pp_tuple5 : ?pre:('a, 'b, 'c, 'd, 'd, 'a) format6 -> ?sep:('e, 'f, 'g, 'h, 'h, 'e) format6 -> ?suf:('i, 'j, 'k, 'l, 'l, 'i) format6 -> (Format.formatter -> 'm -> unit) -> (Format.formatter -> 'n -> unit) -> (Format.formatter -> 'o -> unit) -> (Format.formatter -> 'p -> unit) -> (Format.formatter -> 'q -> unit) -> Format.formatter -> 'm * 'n * 'o * 'p * 'q -> unit val pp_integer : Format.formatter -> Integer.t -> unit val pp_int64 : Format.formatter -> int64 -> unit val pp_string : Format.formatter -> string -> unit val pp_bool : Format.formatter -> bool -> unit val pp_int : Format.formatter -> int -> unit val pp_char : Format.formatter -> char -> unit val pp_float : Format.formatter -> float -> unit val pp_variant : 'a Pretty_utils.formatter -> ('a * string option) Pretty_utils.formatter val pp_allocation : 'a Pretty_utils.formatter -> Format.formatter -> 'a Cil_types.allocation -> unit val pp_deps : 'a Pretty_utils.formatter -> Format.formatter -> 'a Cil_types.deps -> unit val pp_from : 'a Pretty_utils.formatter -> ('a * 'a Cil_types.deps) Pretty_utils.formatter val pp_assigns : 'a Cil_types.from Pretty_utils.formatter -> Format.formatter -> 'a Cil_types.assigns -> unit val pp_file : Format.formatter -> Cil_types.file -> unit val pp_global : Format.formatter -> Cil_types.global -> unit val pp_typ : Cil_types.typ Pretty_utils.formatter val pp_ikind : Format.formatter -> Cil_types.ikind -> unit val pp_fkind : Format.formatter -> Cil_types.fkind -> unit val pp_bitsSizeofTyp : Format.formatter -> Cil_types.bitsSizeofTyp -> unit val pp_bitsSizeofTypCache : Format.formatter -> Cil_types.bitsSizeofTypCache -> unit val pp_attribute : Cil_types.attribute Pretty_utils.formatter val pp_attributes : Format.formatter -> Cil_types.attributes -> unit val pp_attrparam : Cil_types.attrparam Pretty_utils.formatter val pp_compinfo : Format.formatter -> Cil_types.compinfo -> unit val pp_fieldinfo : Format.formatter -> Cil_types.fieldinfo -> unit val pp_enuminfo : Format.formatter -> Cil_types.enuminfo -> unit val pp_enumitem : Format.formatter -> Cil_types.enumitem -> unit val pp_typeinfo : Format.formatter -> Cil_types.typeinfo -> unit val pp_varinfo : Cil_types.varinfo Pretty_utils.formatter val pp_storage : Format.formatter -> Cil_types.storage -> unit val pp_exp : Cil_types.exp Pretty_utils.formatter val pp_exp_node : Format.formatter -> Cil_types.exp_node -> unit val pp_exp_info : Format.formatter -> Cil_types.exp_info -> unit val pp_constant : Format.formatter -> Cil_types.constant -> unit val pp_unop : Format.formatter -> Cil_types.unop -> unit val pp_binop : Format.formatter -> Cil_types.binop -> unit val pp_lval : Cil_types.lval Pretty_utils.formatter val pp_lhost : Cil_types.lhost Pretty_utils.formatter val pp_offset : Cil_types.offset Pretty_utils.formatter val pp_init : Cil_types.init Pretty_utils.formatter val pp_initinfo : Format.formatter -> Cil_types.initinfo -> unit val pp_fundec : Format.formatter -> Cil_types.fundec -> unit val pp_block : Cil_types.block Pretty_utils.formatter val pp_stmt : Cil_types.stmt Pretty_utils.formatter val pp_label : Format.formatter -> Cil_types.label -> unit val pp_stmtkind : Format.formatter -> Cil_types.stmtkind -> unit val pp_catch_binder : Cil_types.catch_binder Pretty_utils.formatter val pp_instr : Cil_types.instr Pretty_utils.formatter val pp_extended_asm : Cil_types.extended_asm Pretty_utils.formatter val pp_lexing_position : Format.formatter -> Lexing.position -> unit val pp_location : Format.formatter -> Cil_types.location -> unit val pp_logic_constant : Format.formatter -> Cil_types.logic_constant -> unit val pp_logic_real : Format.formatter -> Cil_types.logic_real -> unit val pp_logic_type : Cil_types.logic_type Pretty_utils.formatter val pp_identified_term : Cil_types.identified_term Pretty_utils.formatter val pp_logic_label : Cil_types.logic_label Pretty_utils.formatter val pp_term : Cil_types.term Pretty_utils.formatter val pp_term_node : Format.formatter -> Cil_types.term_node -> unit val pp_term_lval : Format.formatter -> Cil_types.term_lval -> unit val pp_term_lhost : Cil_types.term_lhost Pretty_utils.formatter val pp_model_info : Format.formatter -> Cil_types.model_info -> unit val pp_term_offset : Cil_types.term_offset Pretty_utils.formatter val pp_logic_info : Format.formatter -> Cil_types.logic_info -> unit val pp_builtin_logic_info : Format.formatter -> 'a -> unit val pp_logic_body : Format.formatter -> Cil_types.logic_body -> unit val pp_logic_type_info : Format.formatter -> Cil_types.logic_type_info -> unit val pp_logic_type_def : Format.formatter -> Cil_types.logic_type_def -> unit val pp_logic_var_kind : Format.formatter -> Cil_types.logic_var_kind -> unit val pp_logic_var : Cil_types.logic_var Pretty_utils.formatter val pp_logic_ctor_info : Cil_types.logic_ctor_info Pretty_utils.formatter val pp_quantifiers : Format.formatter -> Cil_types.quantifiers -> unit val pp_relation : Format.formatter -> Cil_types.relation -> unit val pp_predicate_node : Format.formatter -> Cil_types.predicate_node -> unit val pp_identified_predicate : Format.formatter -> 'a -> unit val pp_predicate : Cil_types.predicate Pretty_utils.formatter val pp_spec : Format.formatter -> Cil_types.spec -> unit val pp_acsl_extension : Format.formatter -> Cil_types.acsl_extension -> unit val pp_acsl_extension_kind : Cil_types.acsl_extension_kind Pretty_utils.formatter val pp_behavior : Format.formatter -> 'a -> unit val pp_termination_kind : Format.formatter -> Cil_types.termination_kind -> unit val pp_loop_pragma : Cil_types.term Pretty_utils.formatter -> Format.formatter -> Cil_types.term Cil_types.loop_pragma -> unit val pp_slice_pragma : Cil_types.term Pretty_utils.formatter -> Format.formatter -> Cil_types.term Cil_types.slice_pragma -> unit val pp_impact_pragma : Cil_types.term Pretty_utils.formatter -> Format.formatter -> Cil_types.term Cil_types.impact_pragma -> unit val pp_pragma : Cil_types.term Pretty_utils.formatter -> Format.formatter -> Cil_types.term Cil_types.pragma -> unit val pp_code_annotation_node : Format.formatter -> Cil_types.code_annotation_node -> unit val pp_funspec : Format.formatter -> Cil_types.funspec -> unit val pp_code_annotation : Cil_types.code_annotation Pretty_utils.formatter val pp_funbehavior : Format.formatter -> 'a -> unit val pp_global_annotation : Cil_types.global_annotation Pretty_utils.formatter val pp_custom_tree : Format.formatter -> Cil_types.custom_tree -> unit val pp_kinstr : Format.formatter -> Cil_types.kinstr -> unit val pp_cil_function : Format.formatter -> Cil_types.cil_function -> unit val pp_kernel_function : Format.formatter -> 'a -> unit val pp_localisation : Format.formatter -> Cil_types.localisation -> unit val pp_mach : Format.formatter -> 'a -> unit frama-c-Phosphorus-20170501/src/kernel_services/ast_printing/cil_printer.mli0000644000175000017500000000502713113745011026057 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 -> Cil_types.acsl_extension_kind -> unit) -> unit (** Register a pretty-printer used for behavior extension. @plugin development guide *) val state: Printer_api.state val print_global: Cil_types.global -> bool (** Is the given global displayed by the pretty-printer. @since Aluminium-20160501 *) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_printing/cabs_debug.ml0000644000175000017500000004136313113745005025460 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 Cabs open Format let pp_cabsloc fmt (pos1 , _pos2) = fprintf fmt "%d,%s" pos1.Lexing.pos_lnum (Filename.basename (pos1.Lexing.pos_fname)) let pp_storage fmt = function | NO_STORAGE -> fprintf fmt "NO_STORAGE" | AUTO -> fprintf fmt "AUTO" | STATIC -> fprintf fmt "STATIC" | EXTERN -> fprintf fmt "EXTERN" | REGISTER -> fprintf fmt "REGISTER" let pp_fun_spec fmt = function | INLINE -> fprintf fmt "INLINE" | VIRTUAL -> fprintf fmt "VIRTUAL" | EXPLICIT -> fprintf fmt "EXPLICIT" let pp_cvspec fmt = function | CV_CONST -> fprintf fmt "CV_CONST" | CV_VOLATILE -> fprintf fmt "CV_VOLATILE" | CV_RESTRICT -> fprintf fmt "CV_RESTRICT" | CV_ATTRIBUTE_ANNOT s -> fprintf fmt "CV_ATTRIBUTE_ANNOT %s" s let pp_const fmt = function | CONST_INT s -> fprintf fmt "CONST_INT %s" s | CONST_FLOAT s -> fprintf fmt "CONST_FLOAT %s" s | CONST_CHAR l -> fprintf fmt "CONST_CHAR{"; List.iter (fun i -> fprintf fmt ",@ %s" (Int64.to_string i)) l; fprintf fmt "}" | CONST_WCHAR l -> fprintf fmt "CONST_WCHAR{"; List.iter (fun i -> fprintf fmt ",@ %s" (Int64.to_string i)) l; fprintf fmt "}" | CONST_STRING s -> fprintf fmt "CONST_STRING %s" s | CONST_WSTRING l -> fprintf fmt "CONST_WSTRING{"; List.iter (fun i -> fprintf fmt ",@ %s" (Int64.to_string i)) l; fprintf fmt "}" let pp_labels fmt lbls = fprintf fmt "%s" (String.concat " " lbls) let rec pp_typeSpecifier fmt = function | Tvoid -> fprintf fmt "Tvoid" | Tchar -> fprintf fmt "Tchar" | Tbool -> fprintf fmt "Tbool" | Tshort -> fprintf fmt "Tshort" | Tint -> fprintf fmt "Tint" | Tlong -> fprintf fmt "Tlong" | Tint64 -> fprintf fmt "Tint64" | Tfloat -> fprintf fmt "Tfloat" | Tdouble -> fprintf fmt "Tdouble" | Tsigned -> fprintf fmt "Tsigned" | Tunsigned -> fprintf fmt "Tunsigned" | Tnamed s -> fprintf fmt "%s" s | Tstruct (sname, None, alist) -> fprintf fmt "struct@ %s {} %a" sname pp_attrs alist | Tstruct (sname, Some fd_gp_list, alist) -> fprintf fmt "struct@ %s {%a}@ attrs=(%a)" sname pp_field_groups fd_gp_list pp_attrs alist | Tunion (uname, None, alist) -> fprintf fmt "union@ %s {} %a" uname pp_attrs alist | Tunion (uname, Some fd_gp_list, alist) -> fprintf fmt "union@ %s {%a}@ attrs=(%a)" uname pp_field_groups fd_gp_list pp_attrs alist | Tenum (ename, None, alist) -> fprintf fmt "enum@ %s {} %a" ename pp_attrs alist | Tenum (ename, Some e_item_list, alist) -> fprintf fmt "enum@ %s {" ename; List.iter (fun e -> fprintf fmt ",@ %a" pp_enum_item e) e_item_list; fprintf fmt "}@ %a" pp_attrs alist; | TtypeofE exp -> fprintf fmt "typeOfE %a" pp_exp exp | TtypeofT (spec, d_type) -> fprintf fmt "typeOfT(%a,%a)" pp_spec spec pp_decl_type d_type and pp_spec_elem fmt = function | SpecTypedef -> fprintf fmt "SpecTypedef" | SpecCV cvspec -> fprintf fmt "SpecCV %a" pp_cvspec cvspec | SpecAttr attr -> fprintf fmt "SpecAttr %a" pp_attr attr | SpecStorage storage -> fprintf fmt "SpecStorage %a" pp_storage storage | SpecInline -> fprintf fmt "SpecInline" | SpecType typeSpec -> fprintf fmt "SpecType %a" pp_typeSpecifier typeSpec | SpecPattern s -> fprintf fmt "SpecPattern %s" s and pp_spec fmt spec_elems = fprintf fmt "@[{" ; List.iter (fun s -> fprintf fmt "@ %a" pp_spec_elem s) spec_elems ; fprintf fmt "} @]" and pp_decl_type fmt = function | JUSTBASE -> fprintf fmt "@[JUSTBASE@]" | PARENTYPE (attrs1, decl_type, attrs2) -> fprintf fmt "@[PARENTYPE(%a, %a, %a)@]" pp_attrs attrs1 pp_decl_type decl_type pp_attrs attrs2 | ARRAY (decl_type, attrs, exp) -> fprintf fmt "@[ARRAY[%a, %a, %a]@]" pp_decl_type decl_type pp_attrs attrs pp_exp exp | PTR (attrs, decl_type) -> fprintf fmt "@[PTR(%a, %a)@]" pp_attrs attrs pp_decl_type decl_type | PROTO (decl_type, single_names, b) -> fprintf fmt "@[PROTO decl_type(%a), single_names(" pp_decl_type decl_type; List.iter (fun sn -> fprintf fmt ",@ %a" pp_single_name sn) single_names; fprintf fmt "),@ %b@]" b and pp_name_group fmt (spec, names) = fprintf fmt "@[name_group@ spec(%a), names{" pp_spec spec; List.iter (fun n -> fprintf fmt "@ %a" pp_name n) names; fprintf fmt "}@]" (* Warning : printing for TYPE_ANNOT is not complete *) and pp_field_group fmt = function | FIELD (spec, l) -> fprintf fmt "@[FIELD spec(%a), {" pp_spec spec; List.iter (fun (n,e_opt) -> fprintf fmt "@ %a" pp_name n; match e_opt with Some exp -> fprintf fmt "@ %a" pp_exp exp | _ -> ()) l; fprintf fmt "}@]" | TYPE_ANNOT _ -> fprintf fmt "TYPE_ANNOT" and pp_field_groups fmt l = fprintf fmt "{"; List.iter (fun a -> fprintf fmt ",@ %a" pp_field_group a) l; fprintf fmt "}" and pp_init_name_group fmt (spec,init_names) = fprintf fmt "@[init_name_group spec(%a), {" pp_spec spec; List.iter ( fun i -> fprintf fmt "@ %a" pp_init_name i) init_names; fprintf fmt "}@]" and pp_name fmt (s,decl_type,attrs,loc) = fprintf fmt "name %s, decl_type(%a), attrs(%a), loc(%a)" s pp_decl_type decl_type pp_attrs attrs pp_cabsloc loc and pp_init_name fmt (name,init_exp) = fprintf fmt "init_name name(%a), init_exp(%a)" pp_name name pp_init_exp init_exp and pp_single_name fmt (spec,name) = fprintf fmt "@[single_name{spec(%a), name(%a)}@]" pp_spec spec pp_name name and pp_enum_item fmt (s,exp,loc) = fprintf fmt "@[enum_item %s, exp(%a, loc(%a))@]" s pp_exp exp pp_cabsloc loc (* Warning : printing for GLOBANNOT and CUSTOM is not complete *) and pp_def fmt = function | FUNDEF (_, single_name, bl, loc1, loc2) -> fprintf fmt "@[FUNDEF (%a), loc1(%a), loc2(%a) {%a} @]" pp_single_name single_name pp_cabsloc loc1 pp_cabsloc loc2 pp_block bl | DECDEF (_, init_name_group, loc) -> fprintf fmt "@[DECDEF (%a, loc(%a))@]" pp_init_name_group init_name_group pp_cabsloc loc | TYPEDEF (name_group, loc) -> (* typedef normal *) fprintf fmt "@[TYPEDEF (%a), loc(%a)@]" pp_name_group name_group pp_cabsloc loc | ONLYTYPEDEF (spec, loc) -> (* ex : struct s{...}; *) fprintf fmt "@[ONLYTYPEDEF (%a), loc(%a)@]" pp_spec spec pp_cabsloc loc | GLOBASM (s, loc) -> fprintf fmt "@[GLOBASM %s, loc(%a)@]" s pp_cabsloc loc | PRAGMA (exp, loc) -> fprintf fmt "@[PRAGMA exp(%a, loc(%a))@]" pp_exp exp pp_cabsloc loc | LINKAGE (s, loc, defs) -> fprintf fmt "@[LINKAGE %s, loc(%a), defs(" s pp_cabsloc loc; List.iter (fun def -> fprintf fmt ",@ def(%a)" pp_def def) defs; fprintf fmt ")@]" | GLOBANNOT _ -> fprintf fmt "GLOBANNOT" | CUSTOM _ -> fprintf fmt "CUSTOM" and pp_file fmt (s,l) = fprintf fmt "@[FILE %s, {" s; List.iter (fun (b,def) -> fprintf fmt "@ %b, def(%a)" b pp_def def) l; fprintf fmt "@] }" and pp_block fmt bl = fprintf fmt "@[labels(%a), attrs(%a), {" pp_labels bl.blabels pp_attrs bl.battrs; List.iter (fun s -> fprintf fmt "@ %a" pp_stmt s) bl.bstmts ; fprintf fmt "}@]" (* Warning : printing for ASM, CODE_ANNOT and CODE_SPEC is not complete *) and pp_raw_stmt fmt = function | NOP loc -> fprintf fmt "@[NOP loc(%a)@]" pp_cabsloc loc | COMPUTATION (exp, loc) -> fprintf fmt "@[COMPUTATION exp(%a, loc(%a))@]" pp_exp exp pp_cabsloc loc | BLOCK (bl, loc1, loc2) -> fprintf fmt "@[BLOCK loc1(%a), loc2(%a) {%a} @]" pp_cabsloc loc1 pp_cabsloc loc2 pp_block bl | SEQUENCE (stmt1, stmt2, loc) -> fprintf fmt "@[SEQUENCE stmt(%a), stmt(%a), loc(%a)@]" pp_stmt stmt1 pp_stmt stmt2 pp_cabsloc loc | IF (exp, stmt1, stmt2, loc) -> fprintf fmt "@[IF cond(%a), stmt(%a), stmt(%a), loc(%a)@]" pp_exp exp pp_stmt stmt1 pp_stmt stmt2 pp_cabsloc loc | WHILE (_loop_inv, exp, stmt, loc) -> (* Warning : no printing for loop_invariant *) fprintf fmt "@[WHILE cond(%a), stmt(%a), loc(%a)@]" pp_exp exp pp_stmt stmt pp_cabsloc loc | DOWHILE (_loop_inv, exp, stmt, loc) -> (* Warning : no printing for loop_invariant *) fprintf fmt "@[DOWHILE cond(%a), stmt(%a), loc(%a)@]" pp_exp exp pp_stmt stmt pp_cabsloc loc | FOR (_loop_inv, for_clause, exp1, exp2, stmt, loc) -> (* Warning : no printing for loop_invariant *) fprintf fmt "@[FOR for_clause(%a), exp1(%a), exp2(%a), stmt(%a), loc(%a)@]" pp_for_clause for_clause pp_exp exp1 pp_exp exp2 pp_stmt stmt pp_cabsloc loc | BREAK loc -> fprintf fmt "@[BREAK loc(%a)@]" pp_cabsloc loc | CONTINUE loc -> fprintf fmt "@[CONTINUE loc(%a)@]" pp_cabsloc loc | RETURN (exp, loc) -> fprintf fmt "@[RETURN exp(%a, loc(%a))@]" pp_exp exp pp_cabsloc loc | SWITCH (exp, stmt, loc) -> fprintf fmt "@[SWITH exp(%a), stmt(%a), loc(%a)@]" pp_exp exp pp_stmt stmt pp_cabsloc loc | CASE (exp, stmt, loc) -> fprintf fmt "@[CASE exp(%a), stmt(%a), loc(%a)@]" pp_exp exp pp_stmt stmt pp_cabsloc loc | CASERANGE (exp1, exp2, stmt, loc) -> fprintf fmt "@[CASE exp(%a), exp(%a), stmt(%a), loc(%a)@]" pp_exp exp1 pp_exp exp2 pp_stmt stmt pp_cabsloc loc | DEFAULT (stmt, loc) -> fprintf fmt "@[DEFAULT stmt(%a), loc(%a)@]" pp_stmt stmt pp_cabsloc loc | LABEL (s, stmt, loc) -> fprintf fmt "@[LABEL %s stmt(%a), loc(%a)@]" s pp_stmt stmt pp_cabsloc loc | GOTO (s, loc) -> fprintf fmt "@[GOTO %s, loc(%a)@]" s pp_cabsloc loc | COMPGOTO (exp, loc) -> fprintf fmt "@[COMPGOTO exp(%a, loc(%a))@]" pp_exp exp pp_cabsloc loc | DEFINITION def -> fprintf fmt "@[DEFINITION %a@]" pp_def def | ASM (_,_,_,_) -> fprintf fmt "ASM" | TRY_EXCEPT (bl1, exp, bl2, loc) -> fprintf fmt "@[TRY_EXCEPT block(%a) exp(%a) block(%a) loc(%a)@]" pp_block bl1 pp_exp exp pp_block bl2 pp_cabsloc loc | TRY_FINALLY (bl1, bl2, loc) -> fprintf fmt "@[TRY_EXCEPT block(%a) block(%a) loc(%a)@]" pp_block bl1 pp_block bl2 pp_cabsloc loc | THROW(e,loc) -> fprintf fmt "@[THROW %a, loc(%a)@]" (Pretty_utils.pp_opt pp_exp) e pp_cabsloc loc | TRY_CATCH(s,l,loc) -> let print_one_catch fmt (v,s) = fprintf fmt "@[@[CATCH %a {@]@;%a@]@;}" (Pretty_utils.pp_opt pp_single_name) v pp_stmt s in fprintf fmt "@[@[TRY %a (loc %a) {@]@;%a@]@;}" pp_stmt s pp_cabsloc loc (Pretty_utils.pp_list ~sep:"@;" print_one_catch) l | CODE_ANNOT (_,_) -> fprintf fmt "CODE_ANNOT" | CODE_SPEC _ -> fprintf fmt "CODE_SPEC" and pp_stmt fmt stmt = fprintf fmt "@[ghost(%b), stmt(%a)@]" stmt.stmt_ghost pp_raw_stmt stmt.stmt_node (*and loop_invariant = Logic_ptree.code_annot list *) and pp_for_clause fmt = function | FC_EXP exp -> fprintf fmt "@[FC_EXP %a@]" pp_exp exp | FC_DECL def -> fprintf fmt "@[FC_DECL %a@]" pp_def def and pp_bin_op fmt = function | ADD -> fprintf fmt "ADD" | SUB -> fprintf fmt "SUB" | MUL -> fprintf fmt "MUL" | DIV -> fprintf fmt "DIV" | MOD -> fprintf fmt "MOD" | AND -> fprintf fmt "AND" | OR -> fprintf fmt "OR" | BAND -> fprintf fmt "BAND" | BOR -> fprintf fmt "BOR" | XOR -> fprintf fmt "XOR" | SHL -> fprintf fmt "SHL" | SHR -> fprintf fmt "SHR" | EQ -> fprintf fmt "EQ" | NE -> fprintf fmt "NE" | LT -> fprintf fmt "LT" | GT -> fprintf fmt "GT" | LE -> fprintf fmt "LE" | GE -> fprintf fmt "GE" | ASSIGN -> fprintf fmt "ASSIGN" | ADD_ASSIGN -> fprintf fmt "ADD_ASSIGN" | SUB_ASSIGN -> fprintf fmt "SUB_ASSIGN" | MUL_ASSIGN -> fprintf fmt "MUL_ASSIGN" | DIV_ASSIGN -> fprintf fmt "DIV_ASSIGN" | MOD_ASSIGN -> fprintf fmt "MOD_ASSIGN" | BAND_ASSIGN -> fprintf fmt "BAND_ASSIGN" | BOR_ASSIGN -> fprintf fmt "BOR_ASSIGN" | XOR_ASSIGN -> fprintf fmt "XOR_ASSIGN" | SHL_ASSIGN -> fprintf fmt "SHL_ASSIGN" | SHR_ASSIGN -> fprintf fmt "SHR_ASSIGN" and pp_un_op fmt = function | MINUS -> fprintf fmt "MINUS" | PLUS -> fprintf fmt "PLUS" | NOT -> fprintf fmt "NOT" | BNOT -> fprintf fmt "BNOT" | MEMOF -> fprintf fmt "MEMOF" | ADDROF -> fprintf fmt "ADDROF" | PREINCR -> fprintf fmt "PREINCR" | PREDECR -> fprintf fmt "PREDECR" | POSINCR -> fprintf fmt "POSINCR" | POSDECR -> fprintf fmt "POSDECR" and pp_exp fmt exp = fprintf fmt "exp(%a)" pp_exp_node exp.expr_node and pp_exp_node fmt = function | NOTHING -> fprintf fmt "NOTHING" | UNARY (un_op, exp) -> fprintf fmt "@[%a(%a)@]" pp_un_op un_op pp_exp exp | LABELADDR s -> fprintf fmt "@[LABELADDR %s@]" s | BINARY (bin_op, exp1, exp2) -> fprintf fmt "@[%a %a %a@]" pp_exp exp1 pp_bin_op bin_op pp_exp exp2 | QUESTION (exp1, exp2, exp3) -> fprintf fmt "@[QUESTION(%a, %a, %a)@]" pp_exp exp1 pp_exp exp2 pp_exp exp3 | CAST ((spec, decl_type), init_exp) -> fprintf fmt "@[CAST (%a, %a) %a@]" pp_spec spec pp_decl_type decl_type pp_init_exp init_exp | CALL (exp1, exps) -> fprintf fmt "@[CALL %a {" pp_exp exp1; List.iter (fun e -> fprintf fmt ",@ %a" pp_exp e) exps; fprintf fmt "}@]" | COMMA exps -> fprintf fmt "@[COMMA {"; List.iter (fun e -> fprintf fmt ",@ %a" pp_exp e) exps; fprintf fmt "}@]" | CONSTANT c -> fprintf fmt "%a" pp_const c | PAREN exp -> fprintf fmt "PAREN(%a)" pp_exp exp | VARIABLE s -> fprintf fmt "VAR %s" s | EXPR_SIZEOF exp -> fprintf fmt "EXPR_SIZEOF(%a)" pp_exp exp | TYPE_SIZEOF (spec, decl_type) -> fprintf fmt "TYP_SIZEOF(%a,%a)" pp_spec spec pp_decl_type decl_type | EXPR_ALIGNOF exp -> fprintf fmt "EXPR_ALIGNOF(%a)" pp_exp exp | TYPE_ALIGNOF (spec, decl_type) -> fprintf fmt "TYP_ALIGNEOF(%a,%a)" pp_spec spec pp_decl_type decl_type | INDEX (exp1, exp2) -> fprintf fmt "INDEX(%a, %a)" pp_exp exp1 pp_exp exp2 | MEMBEROF (exp, s) -> fprintf fmt "MEMBEROF(%a,%s)" pp_exp exp s | MEMBEROFPTR (exp, s) -> fprintf fmt "MEMBEROFPTR(%a,%s)" pp_exp exp s | GNU_BODY bl -> fprintf fmt "GNU_BODY %a" pp_block bl | EXPR_PATTERN s -> fprintf fmt "EXPR_PATTERN %s" s and pp_init_exp fmt = function | NO_INIT -> fprintf fmt "NO_INIT" | SINGLE_INIT exp -> fprintf fmt "SINGLE_INIT %a" pp_exp exp | COMPOUND_INIT l -> fprintf fmt "@[COMPOUND_INIT {"; match l with | [] -> fprintf fmt "}@]" | (iw, ie)::rest -> fprintf fmt ",@ (%a, %a)" pp_initwhat iw pp_init_exp ie; List.iter (fun (iw, ie) -> fprintf fmt ",@ (%a, %a)" pp_initwhat iw pp_init_exp ie) rest; fprintf fmt "}@]" and pp_initwhat fmt = function | NEXT_INIT -> fprintf fmt "NEXT_INIT" | INFIELD_INIT (s,iw) -> fprintf fmt "@[INFIELD_INIT (%s, %a)@]" s pp_initwhat iw | ATINDEX_INIT (exp,iw) -> fprintf fmt "@[ATINDEX_INIT (%a, %a)@]" pp_exp exp pp_initwhat iw | ATINDEXRANGE_INIT (exp1, exp2) -> fprintf fmt "@[ATINDEXRANGE_INIT (%a, %a)@]" pp_exp exp1 pp_exp exp2 and pp_attr fmt (s,el) = fprintf fmt "ATTR (%s, {" s; match el with | [] -> fprintf fmt "})" | e :: es -> fprintf fmt ",@ %a" pp_exp e; List.iter (fun e -> fprintf fmt ",@ %a" pp_exp e) es; fprintf fmt "})" and pp_attrs fmt l = fprintf fmt "{"; match l with | [] -> fprintf fmt "}" | a :: attrs -> fprintf fmt ",@ %a" pp_attr a; List.iter (fun a -> fprintf fmt ",@ %a" pp_attr a) attrs; fprintf fmt "}" frama-c-Phosphorus-20170501/src/kernel_services/ast_printing/cabs_debug.mli0000644000175000017500000000622313113745001025621 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 Cabs open Format val pp_cabsloc : formatter -> cabsloc -> unit val pp_storage : formatter -> storage -> unit val pp_fun_spec : formatter -> funspec -> unit val pp_cvspec : formatter -> cvspec -> unit val pp_const : formatter -> constant -> unit val pp_labels : formatter -> string list -> unit val pp_typeSpecifier : formatter -> typeSpecifier -> unit val pp_spec_elem : formatter -> spec_elem -> unit val pp_spec : formatter -> specifier -> unit val pp_decl_type : formatter -> decl_type -> unit val pp_name_group : formatter -> name_group -> unit val pp_field_group : formatter -> field_group -> unit val pp_field_groups : formatter -> field_group list -> unit val pp_init_name_group : formatter -> init_name_group -> unit val pp_name : formatter -> name -> unit val pp_init_name : formatter -> init_name -> unit val pp_single_name : formatter -> single_name -> unit val pp_enum_item : formatter -> enum_item -> unit val pp_def : formatter -> definition -> unit val pp_block : formatter -> block -> unit val pp_raw_stmt : formatter -> raw_statement -> unit val pp_stmt : formatter -> statement -> unit val pp_for_clause : formatter -> for_clause -> unit val pp_bin_op : formatter -> binary_operator -> unit val pp_un_op : formatter -> unary_operator -> unit val pp_exp : formatter -> expression -> unit val pp_exp_node : formatter -> cabsexp -> unit val pp_init_exp : formatter -> init_expression -> unit val pp_initwhat : formatter -> initwhat -> unit val pp_attr : formatter -> attribute -> unit val pp_attrs : formatter -> attribute list -> unit val pp_file : formatter -> file -> unit frama-c-Phosphorus-20170501/src/kernel_services/ast_printing/description.ml0000644000175000017500000003707413113745004025730 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 Format.asprintf "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 = let np = idpred.ip_content in if np.pred_name <> [] then Format.fprintf fmt " '%s'" (String.concat "," np.pred_name) else pp_kloc kloc fmt np.pred_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.pred_name <> [] then Format.fprintf fmt " '%s'" (String.concat "," nx.pred_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" | AExtended _ -> Format.pp_print_string fmt "extension" let pp_stmt kloc fmt stmt = match stmt.skind with | Instr (Local_init (v,_,loc)) -> Format.fprintf fmt "initialization of '%s'%a" v.vname (pp_kloc kloc) loc | 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 | Throw(_,loc) -> Format.fprintf fmt "throw%a" (pp_kloc kloc) loc | TryFinally(_,_,loc) | TryExcept(_,_,_,loc) | TryCatch(_,_,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_active fmt active = Pretty_utils.pp_list ~pre:" under active behaviors" ~sep:"," Format.pp_print_string fmt (Datatype.String.Set.elements active) let rec pp_prop kfopt kiopt kloc fmt = function | IPAxiom (s,_,_,_,_) -> Format.fprintf fmt "Axiom '%s'" s | IPLemma (s,_,_,_,_) -> Format.fprintf fmt "Lemma '%s'" s | IPTypeInvariant (s,_,_,_) -> Format.fprintf fmt "Type invariant '%s'" s | IPGlobalInvariant (s,_,_) -> Format.fprintf fmt "Global invariant '%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, active, bhv) -> if Cil.is_default_behavior bhv then Format.fprintf fmt "Default behavior%a%a" (pp_opt kiopt (pp_kinstr kloc)) ki (pp_opt kiopt pp_active) active else Format.fprintf fmt "Behavior '%s'%a" bhv.b_name (pp_opt kiopt (pp_kinstr kloc)) ki | IPComplete(_,ki,active, bs) -> Format.fprintf fmt "Complete behaviors%a%a%a" pp_bhvs bs (pp_opt kiopt (pp_kinstr kloc)) ki (pp_opt kiopt pp_active) active | IPDisjoint(_,ki,active, bs) -> Format.fprintf fmt "Disjoint behaviors%a%a%a" pp_bhvs bs (pp_opt kiopt (pp_kinstr kloc)) ki (pp_opt kiopt pp_active) active | IPCodeAnnot(_,_,{annot_content=AAssert(bs,np)}) -> Format.fprintf fmt "Assertion%a%a%a" pp_for bs pp_named np (pp_kloc kloc) np.pred_loc | IPCodeAnnot(_,_,{annot_content=AInvariant(bs,_,np)}) -> Format.fprintf fmt "Invariant%a%a%a" pp_for bs pp_named np (pp_kloc kloc) np.pred_loc | IPCodeAnnot(_,stmt,_) -> Format.fprintf fmt "Annotation %a" (pp_stmt kloc) stmt | IPAllocation(kf,Kglobal,Id_contract (_,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_contract(_, 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_contract(_,bhv),depend) -> Format.fprintf fmt "Froms%a %a%a" pp_bhv bhv (pp_region kloc) [depend] (pp_context kfopt) (Some kf) | IPAllocation(_,ki,Id_contract (active,bhv),(frees,allocates)) -> Format.fprintf fmt "Frees/Allocates%a %a/%a %a%a" pp_bhv bhv (pp_allocation kloc) frees (pp_allocation kloc) allocates (pp_opt kiopt (pp_kinstr kloc)) ki (pp_opt kiopt pp_active) active | IPAssigns(_,ki,Id_contract (active,bhv),region) -> Format.fprintf fmt "Assigns%a %a%a%a" pp_bhv bhv (pp_region kloc) region (pp_opt kiopt (pp_kinstr kloc)) ki (pp_opt kiopt pp_active) active | IPFrom (_,ki,Id_contract (active,bhv),depend) -> Format.fprintf fmt "Froms%a %a%a%a" pp_bhv bhv (pp_region kloc) [depend] (pp_opt kiopt (pp_kinstr kloc)) ki (pp_opt kiopt pp_active) active | IPAllocation(_,_,Id_loop _,(frees,allocates)) -> Format.fprintf fmt "Loop frees%a Loop allocates%a" (pp_allocation kloc) frees (pp_allocation kloc) allocates | IPAssigns(_,_,Id_loop _,region) -> Format.fprintf fmt "Loop assigns %a" (pp_region kloc) region | IPFrom(_,_,Id_loop _,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 | IPPropertyInstance (kfo, ki, ip) -> Format.fprintf fmt "Instance of '%a'%a%a@." (pp_prop kfopt kiopt kloc) ip (pp_context kfopt) kfo (pp_opt kiopt (pp_kinstr kloc)) ki 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 | A of Datatype.String.Set.t 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 | K _, _ -> (-1) | _, K _ -> 1 | A a1, A a2 -> Datatype.String.Set.compare a1 a2 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.pred_name | {annot_content=AInvariant(bs,_,np)} -> for_order 2 bs @ named_order np.pred_name | _ -> [I 4] let loop_order = function | Id_contract (active,b) -> [B b; A active] | Id_loop _ -> [] let rec 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,a,bhv) -> [I 5;F kf;K ki;B bhv; A a] | IPComplete(kf,ki,a,bs) -> [I 6;F kf;K ki; A a] @ for_order 0 bs | IPDisjoint(kf,ki,a, bs) -> [I 7;F kf;K ki; A a] @ 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] | IPPropertyInstance (None,ki,ip) -> [I 17; K ki] @ ip_order ip | IPPropertyInstance (Some kf,ki,ip) -> [I 17; F kf; K ki] @ ip_order ip | IPTypeInvariant(a,_,_,_) -> [I 18; S a] | IPGlobalInvariant(a,_,_) -> [I 19; S a] 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-Phosphorus-20170501/src/kernel_services/ast_printing/printer.mli0000644000175000017500000000337613113745011025235 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_printing/printer_api.mli0000644000175000017500000005376113113745007026076 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (* Modified by TrustInSoft *) (** Type of AST's extensible printers. @since Fluorine-20130401 *) open Cil_types (** context in which a block will be printed. useful to decide whether braces are required or not. *) type block_ctxt = | Stmt_block of stmt (** stmt is Block b. *) | Body (** body of a function. *) | Then_with_else (** block is the then branch of a conditional that has an else branch. *) | Other (** block is any other toplevel block of the cfg (then without else, else branch, switch, while, ... *) (* ********************************************************************* *) (** {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. This flag is synchronized with Frama-C's kernel being on debug mode. *) val mutable is_ghost: bool (** are we printing ghost code? *) 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 stmt_has_annot: stmt -> bool (** [true] if the given statement has some annotations attached to it. @since Phosphorus-20170501-beta1 *) 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: block_ctxt -> block -> bool (** @return [true] if the given block must be enclosed in a pair of braces, given the context in which it appears. @modify Fluorine-20130401 optional arguments has been modified. @modify Phosphorus-20170501-beta1 use proper context to determine result *) method private inline_block: block_ctxt -> 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. @modify Phosphorus-20170501-beta1 use proper context to determine result *) 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 method private opt_funspec: Format.formatter -> funspec -> 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], [GFunDecl], 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 occurrence *) method field: Format.formatter -> fieldinfo -> unit method offset: Format.formatter -> offset -> unit (** Invoked on each offset occurrence. 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 parameter *) 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 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: Format.formatter -> block -> unit (** Prints a block. @modify Fluorine-20130401 optional arguments has been modified. @modify Phosphorus-20170501-beta1 no more options for pretty-printing *) 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_node: Format.formatter -> predicate_node -> unit method predicate: Format.formatter -> predicate -> 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 pp_keyword: Format.formatter -> string -> unit (** All C99 keywords except types "char", "int", "long", "signed", "short", "unsigned", "void" and "_XXX" (like "_Bool") **) method pp_acsl_keyword: Format.formatter -> string -> unit (** All ACSL keywords except logic types *) method pp_open_annotation: ?block:bool -> ?pre:Pretty_utils.sformat -> Format.formatter -> unit method pp_close_annotation: ?block:bool -> ?suf:Pretty_utils.sformat -> Format.formatter -> unit (** Called before/after printing an annotation comment. Put the annotation in a block according to the optional argument. If it is not set, the annotation is put in a block. **) 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 reported on the lines of 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 however 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 val pp_varname: Format.formatter -> string -> unit (* ********************************************************************* *) (** {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 val pp_varinfo: Format.formatter -> varinfo -> unit 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 val pp_label: Format.formatter -> label -> unit val pp_stmt: Format.formatter -> stmt -> unit 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_node: Format.formatter -> predicate_node -> unit val pp_predicate: Format.formatter -> predicate -> 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 obtain a custom pretty-printer. *) (** Auxiliary module type for a pretty-printer *) module type PrinterClass = sig class printer : extensible_printer_type end (** Signature for extending an existing pretty-printer. OCaml forbids inheriting from a class received as argument, so we use a functor instead. *) module type PrinterExtension = functor (X: PrinterClass) -> PrinterClass val update_printer: (module PrinterExtension) -> unit (** Register a pretty-printer extension. The pretty-printer passed as argument [X] in the functor {!PrinterExtension} is the current pretty-printer, which you should inherit from. This is how this function should be used: {[ module PrinterClassDeferred (X: Printer.PrinterClass) = struct class printer : Printer.extensible_printer = object(self) inherit X.printer as super (* Override the standard methods *) end end let () = Printer.update_printer (module PrinterClassDeferred: Printer.PrinterExtension) ]} *) val current_printer: unit -> (module PrinterClass) (** Returns the current pretty-printer, with all the extensions added using {!update_printer}. *) val set_printer: (module PrinterClass) -> unit (** Set the current pretty-printer, typically to a printer previously obtained through {!current_printer}. This can be useful to cancel a modification performed through {!update_printer}. *) end (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_printing/cprint.ml0000644000175000017500000005621713113745003024703 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 because 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 | THROW(e,_) -> fprintf fmt "@[throw%a@]" (Pretty_utils.pp_opt ~pre:" (@;" ~suf:")" print_expression) e | TRY_CATCH(s,l,_) -> let print_one_catch fmt (e,s) = fprintf fmt "@[@[catch %a {@]@;%a@]@;}@;" (Pretty_utils.pp_opt print_single_name) e print_statement s in fprintf fmt "@[@[try %a {@]@;%a@]@;}@;" print_statement s (Pretty_utils.pp_list ~sep:"@;" print_one_catch) l | 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%a@\n%a@]@\n" (Pretty_utils.pp_opt ~pre:"/*@@ @[" ~suf:"@]@\n */@\n" (fun fmt (spec,_) -> Logic_print.print_spec fmt spec)) spec print_single_name proto print_block body | DECDEF (spec,names, _) -> fprintf fmt "@[%a%a;@]@\n" (Pretty_utils.pp_opt ~pre:"/*@@ @[" ~suf:"@]@\n */@\n" (fun fmt (spec,_) -> Logic_print.print_spec fmt spec)) spec 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-Phosphorus-20170501/src/kernel_services/ast_printing/printer.ml0000644000175000017500000002753213113745004025066 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (* Modified by TrustInSoft *) open Cil_types let debug_vid = Kernel.register_category "printer:vid" let debug_sid = Kernel.register_category "printer:sid" 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 _ | AExtended _) -> -1 | AVariant _, AVariant _ -> total_order | AVariant _, _ -> 1 | APragma _, AExtended _ -> -1 | APragma _, APragma _ -> total_order | APragma _, _ -> 1 | AExtended _, AExtended _ -> total_order | AExtended _, _ -> 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 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 self#opt_funspec fmt spec method! private stmt_has_annot s = Annotations.has_code_annot s method! private has_annot = Extlib.may_map self#stmt_has_annot ~dft:false self#current_stmt method! private inline_block ctxt blk = super#inline_block ctxt 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 ctxt blk | _ -> true) | _ :: _ -> false) method! varinfo fmt v = if Kernel.is_debug_key_enabled debug_vid 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 ); Format.fprintf fmt " */" end; super#varinfo fmt v; method! logic_var fmt v = if Kernel.is_debug_key_enabled debug_vid then begin Format.fprintf fmt "/* "; (match v.lv_origin with None -> () | Some v -> Format.fprintf fmt "vid:%d, " v.vid); Format.fprintf fmt "lvid:%d */" v.lv_id end; super#logic_var fmt v; 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 () && Cil_printer.print_global glob 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 | GFunDecl _ | GFun _ -> print_spec <- Ast.is_def_or_last_decl glob; | _ -> ()); super#global fmt glob method private begin_annotation fmt = let pre = if is_ghost then Some ("@@/": Pretty_utils.sformat) else None in self#pp_open_annotation ~block:false ?pre fmt method private end_annotation fmt = let suf = if is_ghost then Some ("@@/": Pretty_utils.sformat) else None in self#pp_close_annotation ~block:false ?suf 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 0; (* print the labels *) self#stmt_labels 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 || Kernel.is_debug_key_enabled debug_sid then Format.fprintf fmt "@[/* sid:%d */@]@\n" 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 Format.fprintf fmt "%t %a " (fun fmt -> self#pp_open_annotation ~pre:"@[/*@@" fmt) self#pp_acsl_keyword "ghost"; is_ghost <- true end; self#stmtkind next fmt s.skind; if not was_ghost && s.ghost then begin self#pp_close_annotation ~suf:"@,*/@]" 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 "@[@[%t@ %a@;<1 1>%t@]@ %a@]" (fun fmt -> self#pp_open_annotation ~block:false fmt) self#code_annotation a (fun fmt -> self#pp_close_annotation ~block:false fmt) (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 () 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.Location.pretty_ref := pp_location 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.Typ.pretty_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.Logic_label.pretty_ref := pp_logic_label let () = Cil_datatype.Logic_type.pretty_ref := pp_logic_type let () = Cil_datatype.Term.pretty_ref := pp_term let () = Cil_datatype.Term_lval.pretty_ref := pp_term_lval let () = Cil_datatype.Term_offset.pretty_ref := pp_term_offset let () = Cil_datatype.Global_annotation.pretty_ref := pp_global_annotation let () = Cil_datatype.Global.pretty_ref := pp_global let () = Cil_datatype.Code_annotation.pretty_ref := pp_code_annotation let () = Cil_datatype.Predicate.pretty_ref := pp_predicate let () = Cil_datatype.Identified_predicate.pretty_ref := pp_identified_predicate let () = Cil_datatype.Funspec.pretty_ref := pp_funspec let () = Cil_datatype.Fieldinfo.pretty_ref := (fun fmt f -> pp_varname fmt f.fname) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/plugin_entry_points/0000755000175000017500000000000013113745013024452 5ustar mehdimehdiframa-c-Phosphorus-20170501/src/kernel_services/plugin_entry_points/kernel.mli0000644000175000017500000003015313113745005026440 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 PrintConfig: Parameter_sig.Bool (** Behavior of option "-print-config" *) module PrintVersion: Parameter_sig.Bool (** Behavior of option "-print-version" *) module PrintShare: Parameter_sig.Bool (** Behavior of option "-print-share-path" *) module PrintLib: Parameter_sig.Bool (** Behavior of option "-print-lib-path" *) module PrintPluginPath: Parameter_sig.Bool (** Behavior of option "-print-plugin-path" *) (* ************************************************************************* *) (** {2 Output Messages} *) (* ************************************************************************* *) module GeneralVerbose: Parameter_sig.Int (** Behavior of option "-verbose" *) module GeneralDebug: Parameter_sig.Int (** Behavior of option "-debug" *) module Quiet: Parameter_sig.Bool (** Behavior of option "-quiet" *) (** @plugin development guide *) module Unicode: sig include Parameter_sig.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: Parameter_sig.Bool (** Behavior of option "-unicode" @deprecated since Nitrogen-20111001 use module {!Unicode} instead. *) module Time: Parameter_sig.String (** Behavior of option "-time" *) (* ************************************************************************* *) (** {2 Input / Output Source Code} *) (* ************************************************************************* *) module PrintCode : Parameter_sig.Bool (** Behavior of option "-print" *) module PrintMachdep : Parameter_sig.Bool (** Behavior of option "-print-machdep" @since Phosphorus-20170501-beta1 *) module PrintLibc: Parameter_sig.Bool (** Behavior of option "-print-libc" @since Phosphorus-20170501-beta1 *) module PrintComments: Parameter_sig.Bool (** Behavior of option "-keep-comments" *) (** Behavior of option "-ocode". @plugin development guide *) module CodeOutput : sig include Parameter_sig.String val output: (Format.formatter -> unit) -> unit end (** Behavior of option "-add-symbolic-path" @since Neon-20140301 *) module SymbolicPath: Parameter_sig.String_set module FloatNormal: Parameter_sig.Bool (** Behavior of option "-float-normal" *) module FloatRelative: Parameter_sig.Bool (** Behavior of option "-float-relative" *) module FloatHex: Parameter_sig.Bool (** Behavior of option "-float-hex" *) module BigIntsHex: Parameter_sig.Int (** Behavior of option "-hexadecimal-big-integers" *) (* ************************************************************************* *) (** {2 Save/Load} *) (* ************************************************************************* *) module SaveState: Parameter_sig.String (** Behavior of option "-save" *) module LoadState: Parameter_sig.String (** Behavior of option "-load" *) module LoadModule: Parameter_sig.String_list (** Behavior of option "-load-module" *) module AutoLoadPlugins: Parameter_sig.Bool (** Behavior of option "-autoload-plugins" *) (** Kernel for journalization. *) module Journal: sig module Enable: Parameter_sig.Bool (** Behavior of option "-journal-enable" *) module Name: Parameter_sig.String (** Behavior of option "-journal-name" *) end module Session_dir: Parameter_sig.String (** Directory in which session files are searched. @since Neon-20140301 *) module Config_dir: Parameter_sig.String (** Directory in which config files are searched. @since Neon-20140301 *) (* this stop special comment does not work as expected (and as explained in the OCamldoc manual, Section 15.2.2. It just skips all the rest of the file instead of skipping until the next stop comment... (**/**) *) module Set_project_as_default: Parameter_sig.Bool (** Undocumented. *) (* See (meta-)comment on the previous stop comment (**/**) *) (* ************************************************************************* *) (** {2 Customizing Normalization and parsing} *) (* ************************************************************************* *) module UnrollingLevel: Parameter_sig.Int (** Behavior of option "-ulevel" *) module UnrollingForce: Parameter_sig.Bool (** Behavior of option "-ulevel-force" @since Neon-20140301 *) (** 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: Parameter_sig.String (** Behavior of option "-enums" *) module Enums: Parameter_sig.String module CppCommand: Parameter_sig.String (** Behavior of option "-cpp-command" *) module CppExtraArgs: Parameter_sig.String_list (** Behavior of option "-cpp-extra-args" *) module CppGnuLike: Parameter_sig.Bool (** Behavior of option "-cpp-frama-c-compliant" *) module FramaCStdLib: Parameter_sig.Bool (** Behavior of option "-frama-c-stdlib" *) module CustomAnnot: Parameter_sig.String (** Behavior of option "-custom-annot-char". *) module ReadAnnot: Parameter_sig.Bool (** Behavior of option "-read-annot" *) module PreprocessAnnot: Parameter_sig.Bool (** Behavior of option "-pp-annot" *) module ContinueOnAnnotError: Parameter_sig.Bool (** Behavior of option "-continue-annot-error" *) module SimplifyCfg: Parameter_sig.Bool (** Behavior of option "-simplify-cfg" *) module KeepSwitch: Parameter_sig.Bool (** Behavior of option "-keep-switch" *) module Keep_unused_specified_functions: Parameter_sig.Bool (** Behavior of option "-keep-unused-specified-function". *) module SimplifyTrivialLoops: Parameter_sig.Bool (** Behavior of option "-simplify-trivial-loops". *) module Constfold: Parameter_sig.Bool (** Behavior of option "-constfold" *) module InitializedPaddingLocals: Parameter_sig.Bool (** Behavior of option "-initialized-padding-locals" *) module AggressiveMerging: Parameter_sig.Bool (** Behavior of option "-aggressive-merging" *) module AsmContractsGenerate: Parameter_sig.Bool (** Behavior of option "-asm-contracts" *) module AsmContractsAutoValidate: Parameter_sig.Bool (** Behavior of option "-asm-contracts-auto-validate." *) module RemoveExn: Parameter_sig.Bool (** Behavior of option "-remove-exn" *) (** Analyzed files *) module Files: Parameter_sig.String_list (** List of files to analyse *) module Orig_name: Parameter_sig.Bool (** Behavior of option "-orig-name" *) val normalization_parameters: Typed_parameter.t list (** All the normalization options that influence the AST (in particular, changing one will reset the AST entirely *) module WarnDecimalFloat: Parameter_sig.String (** Behavior of option "-warn-decimal-float" *) module ImplicitFunctionDeclaration: Parameter_sig.String (** Behavior of option "-implicit-function-declaration" *) module C11: Parameter_sig.Bool (** Behavior of option "-c11" *) (* ************************************************************************* *) (** {3 Customizing cabs2cil options} *) (* ************************************************************************* *) module AllowDuplication: Parameter_sig.Bool (** Behavior of option "-allow-duplication". *) module DoCollapseCallCast: Parameter_sig.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: Parameter_sig.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 Parameter_sig.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 Parameter_sig.Bool val unsafe_set: t -> unit (** Not for casual users. *) end module ConstReadonly: Parameter_sig.Bool (** Global variables with ["const"] qualifier are constant. See also [Cil.typeHasQualifier] *) module UnspecifiedAccess: Parameter_sig.Bool (** Behavior of option "-unspecified-access" *) module SafeArrays: Parameter_sig.Bool (** Behavior of option "-safe-arrays". @plugin development guide *) module SignedOverflow: Parameter_sig.Bool (** Behavior of option "-warn-signed-overflow" *) module UnsignedOverflow: Parameter_sig.Bool (** Behavior of option "-warn-unsigned-overflow" *) module SignedDowncast: Parameter_sig.Bool (** Behavior of option "-warn-signed-downcast" *) module UnsignedDowncast: Parameter_sig.Bool (** Behavior of option "-warn-unsigned-downcast" *) module AbsoluteValidRange: Parameter_sig.String (** Behavior of option "-absolute-valid-range" *) (* module FloatFlushToZero: Parameter_sig.Bool (** Behavior of option "-float-flush-to-zero" *) *) (* ************************************************************************* *) (** {2 Checks} *) (* ************************************************************************* *) module Check: Parameter_sig.Bool (** Behavior of option "-check" *) module Copy: Parameter_sig.Bool (** Behavior of option "-copy" *) module TypeCheck: Parameter_sig.Bool (** Behavior of option "-typecheck" *) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/plugin_entry_points/dynamic.mli0000644000175000017500000001507613113745004026612 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 accesses through dynamic typing. @plugin development guide *) (* ************************************************************************* *) (** {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 *) (* ************************************************************************* *) (** {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 -> Typed_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 append_before: string -> string list -> unit (** @since Neon-20140301 *) val append_after: string -> string list -> unit (** @since Neon-20140301 *) val remove: string -> string -> unit val is_empty: string -> unit -> bool val iter: string -> (string -> unit) -> unit end end (* ************************************************************************* *) (** {2 Dynamically Loaded Modules} *) (* ************************************************************************* *) val load_module: string -> unit (** Load the module specification. See -load-module option. @modify Magnesium-20151001 new API. *) (** Sets the load path for modules in FRAMAC_PLUGIN, prepending it with [path]. Does not load any plugins. Must be invoked only once from boot during extending stage. @since Phosphorus-20170501-beta1. *) val set_module_load_path : string list -> unit (**/**) val load_plugin_path: unit -> unit (** Load all plugins in the path set with [set_module_load_path]. Must be invoked only once from boot during extending stage. @since Magnesium-20151001 new API. @modify Phosphorus-20170501-beta1 changed signature. *) (**/**) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/plugin_entry_points/emitter.ml0000644000175000017500000005237313113745013026467 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. *) (**************************************************************************) (** {2 Datatype} *) (**************************************************************************) type kind = Property_status | Alarm | Code_annot | Funspec | Global_annot type emitter = { name: string; kinds: kind list; tuning_parameters: Typed_parameter.t list; correctness_parameters: Typed_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.t_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.t_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 -> Typed_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 = Format.asprintf "%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 dummy = create "dummy" [] ~correctness:[] ~tuning:[] let get_name e = e.name let correctness_parameters e = List.map (fun p -> p.Typed_parameter.name) e.correctness_parameters let tuning_parameters e = List.map (fun p -> p.Typed_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 usable 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 = Format.asprintf "%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.Typed_parameter.name in let value = Typed_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 emitter_name kinds = try let state = State.get name in State.Hashtbl.replace correctness_states state (); iter_on_kinds (State_dependency_graph.add_dependencies ~from:state) kinds with State.Unknown -> (* in multi-sessions mode (e.g. save/load), the state for this parameter may not exist if the plug-in which defines it is not here anymore (fix bug #2181) *) Kernel.warning ~once:true "emitter %s: correctness parameter %s does not exist anymore. Ignored." emitter_name name let parameter_hooks : (unit -> unit) Datatype.String.Hashtbl.t Typed_parameter.Hashtbl.t = Typed_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. Additionally, 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 = Typed_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.Typed_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 = Typed_parameter.get (State.get_name s) in Typed_parameter.Hashtbl.add parameter_hooks p tbl; let update () = Datatype.String.Hashtbl.iter (fun _ f -> f ()) tbl in match p.Typed_parameter.accessor with | Typed_parameter.Bool(a, _) -> a.Typed_parameter.add_set_hook (fun _ _ -> update ()) | Typed_parameter.Int(a, _) -> a.Typed_parameter.add_set_hook (fun _ _ -> update ()) | Typed_parameter.String(a, _) -> a.Typed_parameter.add_set_hook (fun _ _ -> update ())) (* [JS 2012/02/07] should be limited to [Option_functor.get_selection_context], but it is not possible while each plug-in (including Wp) is not projectified *) (* (Option_functor.get_selection_context ~is_set:false ()))*) (Parameter_state.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 _ -> try iter_on_kinds (State_dependency_graph.remove_dependencies ~from:(State.get p)) e.u_kinds with State.Unknown -> (* In multi-sessions mode (e.g. save/load), the state for this parameter may not exist if the plug-in which defines it is not here anymore. Nothing special to do since the dependencies have already been removed by the load mechanism when states are missing (fix bug #2181). *) ()) e.correctness_values; (* remove hooks corresponding to old tuning parameters *) Typed_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_name e.u_kinds) e.correctness_values; Datatype.String.Map.iter (fun p _ -> try let ty_p = Typed_parameter.get p in register_tuning_parameter e_name ty_p with Not_found -> (* the parameter could not exist anymore in multi-sessions mode (e.g. save/load): just ignore it in that case *) ()) 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.Typed_parameter.name usable_e.u_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 iter_sorted ~cmp f = H.iter_sorted ~cmp f !state let fold_sorted ~cmp f acc = H.fold_sorted ~cmp 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-Phosphorus-20170501/src/kernel_services/plugin_entry_points/journal.ml0000644000175000017500000004174413113745012026467 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 *) (* ****************************************************************************) (* ****************************************************************************) (* ****************************************************************************) open Cmdline.Kernel_log (** 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 default_filename = "frama_c_journal.ml" let filename = ref default_filename let get_session_file = ref (fun _ -> assert false) let get_name () = let f = !filename in if f == default_filename then !get_session_file f else f 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\";@]@;" (get_name ()); Format.fprintf fmt "try run ()@;"; Format.fprintf fmt "@[with@;@[| Unreachable ->@ "; Format.fprintf fmt "@[Kernel.fatal@;\"Journal reaches 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\"@;" (Transitioning.String.capitalize_ascii (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 = get_name () 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]+") name (String.length name - 1) in filename := Str.string_before name n ^ suf with Not_found -> filename := name ^ 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 "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 (fun _ -> 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 let msg = Format.asprintf "a call to the function %s has to be written in the journal, \ but this function was never journalized." name in raise (Not_writable msg)) else invalid_arg ("[Journal.never_write] " ^ name ^ " is not a closure") else f let pp (type t) (ty: t Type.t) fmt (x:t) = assert Cmdline.use_type; 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 (Format.asprintf "no printer registered for value of type %s" (Type.name ty)) else if pp == Datatype.pp_fail then pp_error (Format.asprintf "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 b = gen_binding (varname value) in Binding.add ty value 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: 't. (Format.formatter -> unit) -> 't Type.t -> bool -> (Format.formatter -> unit) option -> 't -> 't = fun (type t) (type a) (type b) f_acc (ty: t Type.t) is_dyn comment (x: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 [t = a -> b] *) let ty: (a -> b) Type.t = Obj.magic (ty: t Type.t) in let f: a -> b = Obj.magic (x: 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 let f (y: a) : b = if !started then (* prevent journalisation if you're journalizing another function *) f y else begin try (* [started] prevents journalization of function call inside another one *) started := true; (* apply the closure [x] to its argument [y] *) let xy = f y in started := false; (* 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 := false; 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 := false; raise e end in (* cast back the closure of type [a -> b] into [t] *) (Obj.magic (f: a -> b): t) 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 f_acc fmt = pp ty fmt x in journalize_function f_acc ty is_dyn comment x 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-Phosphorus-20170501/src/kernel_services/plugin_entry_points/journal.mli0000644000175000017500000001202413113745001026623 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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] observationally 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_name name] changes the filename into the journal is generated. *) 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 restoration. @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 explicitly. Only offers functions retrieving when running a journal file. *) val get_session_file: (string -> string) ref (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/plugin_entry_points/dynamic.ml0000644000175000017500000004210313113745007026433 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Debugging --- *) (* -------------------------------------------------------------------------- *) module Klog = Cmdline.Kernel_log let dkey = Klog.register_category "dynlink" let error ~name ~message ~details = Klog.error "cannot load plug-in '%s': %s%t" name message (fun fmt -> if details <> "" then Format.fprintf fmt "@\nDetails: %s" details) (* -------------------------------------------------------------------------- *) (* --- Dynlink Common Interface & Dynamic Library --- *) (* -------------------------------------------------------------------------- *) exception Unloadable of string module Tbl = Type.String_tbl(struct type 'a t = 'a end) let dynlib_init = ref false let dynlib_init () = if not !dynlib_init then begin dynlib_init := true ; Dynlink.init () ; Dynlink.allow_unsafe_modules true ; end exception Incompatible_type = Tbl.Incompatible_type exception Unbound_value = Tbl.Unbound_value let dynlib_error name = function | Dynlink.Error e -> error ~name ~message:"cannot load module" ~details:(Dynlink.error_message e) ; | Sys_error _ as e -> error ~name ~message:"system error" ~details:(Printexc.to_string e) | Unloadable details -> error ~name ~message:"incompatible with current set-up" ~details (* the three next errors may be raised in case of incompatibilities with another plug-in *) | Incompatible_type s -> error ~name ~message:"code incompatibility" ~details:s | Unbound_value s -> error ~name ~message:"code incompatibility" ~details:("unbound value " ^ s) | Type.No_abstract_type s -> error ~name ~message:"code incompatibility" ~details:("unbound abstract type " ^ s) | Log.AbortError _ | Log.AbortFatal _ | Log.FeatureRequest _ as e -> raise e | e -> error ~name ~message:("unexpected exception: " ^ Printexc.to_string e) ~details:(Printexc.get_backtrace ()) let dynlib_module name file = Klog.feedback ~dkey "Loading module '%s' from '%s'." name file ; try dynlib_init () ; Dynlink.loadfile file ; with error -> Cmdline.add_loading_failures name; dynlib_error name error (* -------------------------------------------------------------------------- *) (* --- Utilities --- *) (* -------------------------------------------------------------------------- *) let split_word = Str.(split (regexp ":")) let split_ext p = try let k = String.rindex p '.' in let d = try String.rindex p '/' with Not_found -> 0 in (* check for '.' belonging to directory or not *) if d <= k then let n = String.length p in String.sub p 0 k , String.sub p k (n-k) else p , "" with Not_found -> p , "" let is_package = let pkg = Str.regexp "[a-z-_]+$" in fun name -> Str.string_match pkg name 0 let is_meta = let meta = Str.regexp "META.frama-c-[a-z-_]+$" in fun name -> Str.string_match meta name 0 let is_dir d = Sys.file_exists d && Sys.is_directory d let is_file base ext = let file = base ^ ext in if Sys.file_exists file then Some file else None let is_object base = if Dynlink.is_native then is_file base ".cmxs" else match is_file base ".cma" with | Some _ as file -> file | None -> is_file base ".cmo" (* -------------------------------------------------------------------------- *) (* --- Package Loading --- *) (* -------------------------------------------------------------------------- *) let packages = Hashtbl.create 64 let () = List.iter (fun p -> Hashtbl.add packages p ()) Config.library_names let missing pkg = not (Hashtbl.mem packages pkg) let once pkg = if Hashtbl.mem packages pkg then false else ( Hashtbl.add packages pkg () ; true ) exception ArchiveError of string let load_archive pkg base file = let path = try Findlib.resolve_path ~base file with Not_found -> let msg = Printf.sprintf "archive '%s' not found in '%s'" file base in raise (ArchiveError msg) in dynlib_module pkg path let mem_package pkg = try ignore (Findlib.package_directory pkg) ; true with Findlib.No_such_package _ -> false let load_packages pkgs = Klog.debug ~dkey "trying to load %a" (Pretty_utils.pp_list ~sep:"@, " Format.pp_print_string) pkgs; try let pkgs = List.filter missing pkgs in List.iter begin fun pkg -> if once pkg then let base = Findlib.package_directory pkg in (** The way plugins are specified in META have been normalized late. So people started to specified it in different ways: - archive(byte,plugin) - archive(byte) - archive(native,plugin) - archive(plugin) The normalized one are: - plugin(byte) - plugin(native) *) let gui = if !Config.is_gui then ["gui"] else [] in let predicates = (** The order is important for the archive cases *) if Dynlink.is_native then [ "plugin", ["native"]@gui; "archive", ["plugin"]@gui; "archive", ["native";"plugin"]@gui; ] else [ "plugin", ["byte"]@gui; "archive", ["byte";"plugin"]@gui; "archive", ["byte"]@gui; ] in let rec find_package_property = function | [] -> let msg = Printf.sprintf "package '%s' doesn't contains any known \ specification for dynamic linking" pkg in raise (ArchiveError msg) | (var,predicates)::l -> try Findlib.package_property predicates pkg var with Not_found -> find_package_property l in let archive = find_package_property predicates in let archives = split_word archive in if archives = [] then Klog.warning "no archive to load for package '%s'" pkg else List.iter (load_archive pkg base) archives end (Findlib.package_deep_ancestors (if Dynlink.is_native then [ "native" ] else [ "byte" ]) pkgs) with | Findlib.No_such_package(pkg,details) -> Cmdline.add_loading_failures pkg; Klog.error "[findlib] package '%s' not found (%s)" pkg details | Findlib.Package_loop pkg -> Cmdline.add_loading_failures pkg; Klog.error "[findlib] cyclic dependencies for package '%s'" pkg | ArchiveError msg -> Cmdline.add_loading_failures "unknown package"; Klog.error "[findlib] %s" msg (* -------------------------------------------------------------------------- *) (* --- Load Objects --- *) (* -------------------------------------------------------------------------- *) let load_path = ref [] (* initialized by load_modules *) let load_script base = Klog.feedback ~dkey "compiling script '%s.ml'" base ; let cmd = Buffer.create 80 in let fmt = Format.formatter_of_buffer cmd in begin if Dynlink.is_native then Format.fprintf fmt "%s -shared -o %s.cmxs" Config.ocamlopt base else Format.fprintf fmt "%s -c" Config.ocamlc ; Format.fprintf fmt " -w Ly -warn-error A -I %s" Config.libdir ; if !Config.is_gui then Format.pp_print_string fmt " -package lablgtk2" ; List.iter (fun p -> Format.fprintf fmt " -I %s" p) !load_path ; Format.fprintf fmt " %s.ml" base ; Format.pp_print_flush fmt () ; let cmd = Buffer.contents cmd in Klog.feedback ~dkey "running '%s'" cmd ; begin let res = Sys.command cmd in if res <> 0 then Klog.error "compilation of '%s.ml' failed" base else let pkg = Filename.basename base in if Dynlink.is_native then dynlib_module pkg (base ^ ".cmxs") else dynlib_module pkg (base ^ ".cmo") ; end ; let erase = Printf.sprintf "rm -f %s.cm* %s.o" base base in Klog.feedback ~dkey "running '%s'" erase ; let st = Sys.command erase in if st <> 0 then Klog.warning "Error when cleaning '%s.[o|cm*]' files" base ; end (* -------------------------------------------------------------------------- *) (* --- Command-Line Entry Points --- *) (* -------------------------------------------------------------------------- *) let set_module_load_path path = let add_dir ~user d ps = if is_dir d then d::ps else ( if user then Klog.warning "cannot load '%s' (not a directory)" d ; ps ) in Klog.debug ~dkey "plugin_dir: %s" (String.concat ":" Config.plugin_dir); load_path := List.fold_right (add_dir ~user:true) path (List.fold_right (add_dir ~user:false) Config.plugin_dir []); let findlib_path = String.concat ":" !load_path in Klog.debug ~dkey "setting findlib path to %s" findlib_path; Findlib.init ~env_ocamlpath:findlib_path () let load_plugin_path () = let scan_directory pkgs dir = Klog.feedback ~dkey "Loading directory '%s'" dir ; try let content = Sys.readdir dir in Array.sort String.compare content ; Array.iter (fun name -> if is_meta name then (* name starts with "META.frama-c-" *) let pkg = String.sub name 5 (String.length name - 5) in pkgs := pkg :: !pkgs ) content ; with Sys_error error -> Klog.error "impossible to read '%s' (%s)" dir error in let pkgs = ref [] in List.iter (scan_directory pkgs) !load_path ; load_packages (List.rev !pkgs) let load_module m = let base,ext = split_ext m in match ext with | ".ml" -> begin (* force script compilation *) match is_file base ".ml" with | Some _ -> load_script base | None -> Klog.error "Missing source file '%s'" m end | "" | "." | ".cmo" | ".cma" | ".cmxs" -> begin (* load object or compile script or find package *) match is_object base with | Some file -> dynlib_module (Filename.basename base) file | None -> match is_file base ".ml" with | Some _ -> load_script base | None -> if is_package m && mem_package m then load_packages [m] else let fc = "frama-c-" ^ Transitioning.String.lowercase_ascii m in if mem_package fc then load_packages [fc] else Klog.error "package or module '%s' not found" m end | _ -> Klog.error "don't know what to do with '%s' (unexpected %s)" m ext (* ************************************************************************* *) (** {2 Registering and accessing dynamic values} *) (* ************************************************************************* *) 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 Klog.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 let get ~plugin name ty = if Cmdline.use_type then Tbl.find dynamic_values (plugin ^ "." ^ name) ty else failwith (Printf.sprintf "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 Typed_parameter.ty let get_state option_name = let prm = get ~plugin:"" option_name Typed_parameter.ty in State.get prm.Typed_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 append_before name = apply "StringList" name "append_before" (Datatype.list Datatype.string) Datatype.unit let append_after name = apply "StringList" name "append_after" (Datatype.list 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 end (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/plugin_entry_points/db.ml0000644000175000017500000013362413113745004025402 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 = [ Table_By_Callstack.self ] 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_By_Callstack.add_hook_on_update (fun _ -> Cvalue.V_Offsetmap.clear_caches (); Cvalue.Model.clear_caches (); Locations.Location_Bytes.clear_caches (); Locations.Zone.clear_caches (); Function_Froms.Memory.clear_caches (); ) 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_By_Callstack.self let only_self = [ self ] let mark_as_computed = Journal.register "Db.Value.mark_as_computed" (Datatype.func Datatype.unit Datatype.unit) Table_By_Callstack.mark_as_computed let is_computed () = Table_By_Callstack.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_By_Callstack = State_builder.Hashtbl(Kernel_function.Hashtbl) (States_by_callstack) (struct let name = "called_functions_by_callstack" let size = 11 let dependencies = only_self end) module Called_Functions_Memo = State_builder.Hashtbl(Kernel_function.Hashtbl) (Cvalue.Model) (struct let name = "called_functions_memo" let size = 11 let dependencies = [ Called_Functions_By_Callstack.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 * (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) module Call_Type_Value_Callbacks = Hook.Build(struct type t = [`Builtin of Value_types.call_result | `Spec of funspec | `Def | `Memexec] * state * (kernel_function * kinstr) list end) ;; module Compute_Statement_Callbacks = Hook.Build (struct type t = stmt * callstack * state 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 merge_initial_state cs state = let open Value_types in let kf = match cs with (kf, _) :: _ -> kf | _ -> assert false in let by_callstack = try Called_Functions_By_Callstack.find kf with Not_found -> let h = Callstack.Hashtbl.create 7 in Called_Functions_By_Callstack.add kf h; h in try let old = Callstack.Hashtbl.find by_callstack cs in Callstack.Hashtbl.replace by_callstack cs (Cvalue.Model.join old state) with Not_found -> Callstack.Hashtbl.add by_callstack cs state let get_initial_state kf = assert (is_computed ()); (* this assertion fails during value analysis *) try Called_Functions_Memo.find kf with Not_found -> let state = try let open Value_types in let by_callstack = Called_Functions_By_Callstack.find kf in Callstack.Hashtbl.fold (fun _cs state acc -> Cvalue.Model.join acc state) by_callstack Cvalue.Model.bottom with Not_found -> Cvalue.Model.bottom in Called_Functions_Memo.add kf state; state let get_initial_state_callstack kf = assert (is_computed ()); (* this assertion fails during value analysis *) try Some (Called_Functions_By_Callstack.find kf) with Not_found -> None 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 = if !no_results (Kernel_function.(get_definition (find_englobing_kf s))) then Cvalue.Model.top else try Table.find s with Not_found -> let ho = try Some (Table_By_Callstack.find s) with Not_found -> None in let state = match ho with | None -> Cvalue.Model.bottom | Some h -> Value_types.Callstack.Hashtbl.fold (fun _cs state acc -> Cvalue.Model.join acc state ) h Cvalue.Model.bottom in Table.add s state; state 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 fold_stmt_state_callstack f acc ~after stmt = assert (is_computed ()); (* this assertion fails during value analysis *) match get_stmt_state_callstack ~after stmt with | None -> acc | Some h -> Value_types.Callstack.Hashtbl.fold (fun _ -> f) h acc let fold_state_callstack f acc ~after ki = assert (is_computed ()); (* this assertion fails during value analysis *) match ki with | Kglobal -> f (globals_state ()) acc | Kstmt stmt -> fold_stmt_state_callstack f acc ~after stmt let is_reachable = Cvalue.Model.is_reachable exception Is_reachable let is_reachable_stmt stmt = if !no_results (Kernel_function.(get_definition (find_englobing_kf stmt))) then true else let ho = try Some (Table_By_Callstack.find stmt) with Not_found -> None in match ho with | None -> false | Some h -> try Value_types.Callstack.Hashtbl.iter (fun _cs state -> if Cvalue.Model.is_reachable state then raise Is_reachable) h; false with Is_reachable -> true let is_accessible ki = match ki with | Kglobal -> Cvalue.Model.is_reachable (globals_state ()) | Kstmt stmt -> is_reachable_stmt 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 state loc = Cvalue.Model.find state loc let access = mk_fun "Value.access" let access_expr = mk_fun "Value.access_expr" (** 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.register_builtin" let registered_builtins = mk_fun "Value.registered_builtins" 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 reduce_by_cond = mk_fun "Value.reduce_by_cond" let find_lv_plus = mk_fun "Value.find_lv_plus" let pretty_state = Cvalue.Model.pretty let pretty = Cvalue.V.pretty 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 | Instr(Local_init(_, ConsInit(f,_,_),_)) -> Kernel_function.Hptset.singleton (Globals.Functions.get f) | _ -> 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 lval_to_zone_with_deps_state = mk_fun "Value.lval_to_zone_with_deps_state" let lval_to_precise_loc_state = ref (fun ~with_alarms:_ _ -> mk_labeled_fun "Value.lval_to_precise_loc") let lval_to_precise_loc_with_deps_state = mk_fun "Value.lval_to_precise_loc_with_deps_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" let verify_assigns_froms = mk_fun "Value.verify_assigns_froms" module Logic = struct let eval_predicate = ref (fun ~pre:_ ~here:_ _ -> raise (Extlib.Unregistered_function "Function 'Value.Logic.eval_predicate' not registered yet")) end 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 display = mk_fun "Value.display" let emitter = ref Emitter.dummy end module From = struct exception Not_lval let access = mk_fun "From.access" 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 find_deps_term_no_transitivity_state = mk_fun "From.find_deps_term_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) * Function_Froms.Memory.t Stmt.Hashtbl.t * (Kernel_function.t * Function_Froms.Memory.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 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" 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 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 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 reset_slice = mk_fun "Slicing.Project.reset_slice" 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 = ref (fun ~caller:_ ~to_call:_ -> mk_labeled_fun "Slicing.Request.add_call_slice") let add_call_fun = ref (fun ~caller:_ ~to_call:_ -> mk_labeled_fun "Slicing.Request.add_call_fun") let add_call_min_fun = ref (fun ~caller:_ ~to_call:_ -> mk_labeled_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 = ref (fun ~propagate_to_callers:_ -> mk_labeled_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 exception No_conversion (** Interpretation and conversions of of formulas *) let code_annot = mk_fun "Properties.Interp.code_annot" let term_lval = mk_fun "Properties.Interp.term_lval" let term = mk_fun "Properties.Interp.term" let predicate = mk_fun "Properties.Interp.predicate" 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_loc_under_over = mk_resultfun "Properties.Interp.loc_to_loc_with_deps" 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 : sig (** The signature of the mli is copy pasted here because of http://caml.inria.fr/mantis/view.php?id=7313 *) 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 -> 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 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_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 an annotation on the given stmt. *) 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 = 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_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 from_nodes = mk_fun "Impact.from_nodes" 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_signed_downCast_status = mk_fun "RteGen.get_signed_downCast_status" let get_memAccess_status = mk_fun "RteGen.get_memAccess_status" let get_pointerCall_status = mk_fun "RteGen.get_pointerCall_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 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 (* ************************************************************************* *) (** {2 GUI} *) (* ************************************************************************* *) let progress = ref (fun () -> ()) exception Cancel (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/plugin_entry_points/plugin.mli0000644000175000017500000001450613113745004026461 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 *) module type S = sig include Log.Messages val add_group: ?memo:bool -> string -> Cmdline.Group.t (** 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: Parameter_sig.Bool (** @deprecated since Oxygen-20120901 *) module Verbose: Parameter_sig.Int module Debug: Parameter_sig.Int module Debug_category: Parameter_sig.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: Parameter_sig.Specific_dir (** Handle the specific `session' directory of the plug-in. @since Neon-20140301 *) module Session: Parameter_sig.Specific_dir (** Handle the specific `config' directory of the plug-in. @since Neon-20140301 *) module Config: Parameter_sig.Specific_dir val help: Cmdline.Group.t (** The group containing option -*-help. @since Boron-20100401 *) val messages: Cmdline.Group.t (** The group containing options -*-debug and -*-verbose. @since Boron-20100401 *) end type plugin = private { p_name: string; p_shortname: string; p_help: string; p_parameters: (string, Typed_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 *) module type General_services = sig include S include Parameter_sig.Builder end (**/**) val register_kernel: unit -> unit (** Begin to register parameters of the kernel. Not for casual users. @since Beryllium-20090601-beta1 *) (**/**) (** 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 (** Make visible to the end-user the --share option. To be called just before applying {!Register} to create plug-in services. @since Oxygen-20120901 *) val is_session_visible: unit -> unit (** Make visible to the end-user the --session option. To be called just before applying {!Register} to create plug-in services. @since Neon-20140301 *) val is_config_visible: unit -> unit (** Make visible to the end-user the --config option. To be called just before applying {!Register} to create plug-in services. @since Neon-20140301 *) val plugin_subpath: string -> unit (** Use the given string as the sub-directory in which the plugin files will be installed (ie. [share/frama-c/plugin_subpath]...). Relevant for directories [Share], [Session] and [Config] above. @since Neon-20140301 *) val default_msg_keys: string list -> unit (** Debug message keys set by default for the plugin. @since Silicon-20161101 *) (* ************************************************************************* *) (** {2 Handling plugins} *) (* ************************************************************************* *) 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 is_present: string -> bool (** Whether a plug-in already exists. Plugins are identified by their short name. @since Magnesium-20151001 *) 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 *) (**/**) (* ************************************************************************* *) (** {2 Internal kernel stuff} *) (* ************************************************************************* *) val positive_debug_ref: int ref (** @since Boron-20100401 *) val session_is_set_ref: (unit -> bool) ref val session_ref: (unit -> string) ref val config_is_set_ref: (unit -> bool) ref val config_ref: (unit -> string) ref (**/**) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/plugin_entry_points/kernel.ml0000644000175000017500000013050013113745012026262 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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} *) (* ************************************************************************* *) module CamlString = String module Fc_config = Config 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) include Cmdline.Kernel_log (* ************************************************************************* *) (** {2 Specialised functors for building kernel parameters} *) (* ************************************************************************* *) module type Input = sig include Parameter_sig.Input val module_name: string end module type Input_with_arg = sig include Parameter_sig.Input_with_arg val module_name: string end module Bool(X:sig include Input val default: bool end) = P.Bool (struct let () = Parameter_customize.set_module_name X.module_name include X end) module False(X: Input) = P.False (struct let () = Parameter_customize.set_module_name X.module_name include X end) module True(X: Input) = P.True (struct let () = Parameter_customize.set_module_name X.module_name include X end) module Int (X: sig val default: int include Input_with_arg end) = P.Int (struct let () = Parameter_customize.set_module_name X.module_name include X end) module Zero(X:Input_with_arg) = P.Zero (struct let () = Parameter_customize.set_module_name X.module_name include X end) module String (X: sig include Input_with_arg val default: string end) = P.String (struct let () = Parameter_customize.set_module_name X.module_name include X end) module String_set(X: Input_with_arg) = P.String_set (struct let () = Parameter_customize.set_module_name X.module_name include X end) module String_list(X: Input_with_arg) = P.String_list (struct let () = Parameter_customize.set_module_name X.module_name include X end) (* ************************************************************************* *) (** {2 Installation Information} *) (* ************************************************************************* *) let () = Parameter_customize.set_group help let () = Parameter_customize.set_cmdline_stage Cmdline.Exiting let () = Parameter_customize.do_not_journalize () let () = Parameter_customize.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 [ "-h"; "-help"] let () = Parameter_customize.set_group help let () = Parameter_customize.set_cmdline_stage Cmdline.Exiting let () = Parameter_customize.do_not_journalize () let () = Parameter_customize.set_negative_option_name "" module ListPlugins = False (struct let option_name = "--list-plugins" let help = "display a general help" let module_name = "ListPlugins" end) let run_list_plugins () = if ListPlugins.get () then Cmdline.list_plugins () else Cmdline.nop let () = Cmdline.run_after_exiting_stage run_list_plugins let () = ListPlugins.add_aliases ["-plugins"; "--plugins"] let () = Parameter_customize.set_group help let () = Parameter_customize.set_cmdline_stage Cmdline.Early let () = Parameter_customize.set_negative_option_name "" module PrintConfig = False (struct let option_name = "-print-config" let module_name = "PrintConfig" let help = "print full config information" end) let () = Parameter_customize.set_group help let () = Parameter_customize.set_cmdline_stage Cmdline.Early let () = Parameter_customize.set_negative_option_name "" module PrintVersion = False(struct let option_name = "-print-version" let module_name = "PrintVersion" let help = "print the Frama-C version" end) let () = PrintVersion.add_aliases [ "-v"; "-version" ; "--version" ] let () = Parameter_customize.set_group help let () = Parameter_customize.set_cmdline_stage Cmdline.Early let () = Parameter_customize.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 () = Parameter_customize.set_group help let () = Parameter_customize.set_cmdline_stage Cmdline.Early let () = Parameter_customize.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 () = Parameter_customize.set_group help let () = Parameter_customize.set_cmdline_stage Cmdline.Early let () = Parameter_customize.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 () = Parameter_customize.set_group help let () = Parameter_customize.set_cmdline_stage Cmdline.Exiting let () = Parameter_customize.set_negative_option_name "" module PrintMachdep = False (struct let module_name = "PrintMachdep" let option_name = "-print-machdep" let help = "pretty print selected machdep" end) let () = Parameter_customize.set_group help let () = Parameter_customize.set_negative_option_name "" module DumpDependencies = P.Empty_string (struct let option_name = "-dump-dependencies" let help = "" let arg_name = "" end) let () = Extlib.safe_at_exit (fun () -> if not (DumpDependencies.is_default ()) then State_dependency_graph.dump (DumpDependencies.get ())) let () = Parameter_customize.set_group help let () = Parameter_customize.set_cmdline_stage Cmdline.Exiting let () = Parameter_customize.do_not_journalize () let () = Parameter_customize.set_negative_option_name "" module AutocompleteHelp = False (struct let option_name = "-autocomplete" let help = "displays all plugin options. Used for zsh autocompletion" let module_name = "AutocompleteHelp" end) let run_list_all_plugin_options () = if AutocompleteHelp.get () then Cmdline.list_all_plugin_options ~print_invisible:true else Cmdline.nop let () = Cmdline.run_after_exiting_stage run_list_all_plugin_options (* ************************************************************************* *) (** {2 Output Messages} *) (* ************************************************************************* *) let () = Parameter_customize.set_group messages let () = Parameter_customize.do_not_projectify () let () = Parameter_customize.do_not_journalize () let () = Parameter_customize.set_cmdline_stage Cmdline.Early let () = Parameter_customize.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 () = Parameter_customize.set_group messages let () = Parameter_customize.do_not_projectify () let () = Parameter_customize.do_not_journalize () let () = Parameter_customize.set_cmdline_stage Cmdline.Early let () = Parameter_customize.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 () = Parameter_customize.set_group messages let () = Parameter_customize.set_negative_option_name "" let () = Parameter_customize.set_cmdline_stage Cmdline.Early let () = Parameter_customize.do_iterate () let () = Parameter_customize.do_not_projectify () let () = Parameter_customize.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 () = Parameter_customize.set_group messages let () = Parameter_customize.set_cmdline_stage Cmdline.Early let () = Parameter_customize.do_not_projectify () let () = Parameter_customize.do_not_journalize () module Permissive = Bool (struct let default = !Parameter_customize.is_permissive_ref let option_name = "-permissive" let module_name = "Permissive" let help = "performs less verification on validity of command-line options" end) let () = Permissive.add_set_hook (fun _ b -> Parameter_customize.is_permissive_ref := b) let () = Parameter_customize.set_group messages let () = Parameter_customize.set_cmdline_stage Cmdline.Extended let () = Parameter_customize.do_not_journalize () let () = Parameter_customize.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 improvement 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 () = Parameter_customize.set_group messages let () = Parameter_customize.do_not_projectify () let () = Parameter_customize.set_cmdline_stage Cmdline.Extending module TTY = True (struct let option_name = "-tty" let module_name = "TTY" let help = "use terminal capabilities for feedback (when available)" end) let () = Log.tty := TTY.get let () = Parameter_customize.set_group messages let () = Parameter_customize.do_not_projectify () module Time = P.Empty_string (struct let option_name = "-time" let arg_name = "filename" let help = "append process time and timestamp to at exit" end) let () = Parameter_customize.set_group messages let () = Parameter_customize.do_not_projectify () module SymbolicPath = String_set (* TODO: to be replaced by an hashtbl *) (struct let option_name = "-add-symbolic-path" let module_name = "SymbolicPath" let arg_name = "name_1:path_1,...,name_n:path_n" let help = "When displaying file locations, replace (absolute) path by the \ corresponding symbolic name" end) (* ************************************************************************* *) (** {2 Input / Output Source Code} *) (* ************************************************************************* *) let inout_source = add_group "Input/Output Source Code" let () = Parameter_customize.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 () = Parameter_customize.set_group inout_source let () = Parameter_customize.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) let () = Parameter_customize.set_group inout_source let () = Parameter_customize.do_not_projectify () module PrintLibc = Bool (struct let module_name = "PrintLibc" let option_name = "-print-libc" let help = "when pretty-printing C code, keep prototypes coming \ from Frama-C standard library" let default = !Fc_config.is_gui (* always print by default on the GUI *) end) module CodeOutput = struct let () = Parameter_customize.set_group inout_source include P.Empty_string (struct 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 () = Extlib.safe_at_exit close_all end let add_path s = try let n = CamlString.index s ':' in let name = CamlString.sub s 0 n in let path = CamlString.sub s (n+1) (CamlString.length s - (n+1)) in Filepath.add_symbolic_dir name path with Not_found -> warning "%s is not a valid option argument for -add-symbolic-path. \ It will be ignored" s let () = SymbolicPath.add_set_hook (fun o n -> let d = Datatype.String.Set.diff n o in Datatype.String.Set.iter add_path d) let () = Parameter_customize.set_group inout_source let () = Parameter_customize.do_not_projectify () module FloatNormal = False (struct let option_name = "-float-normal" let module_name = "FloatNormal" let help = "display floats with internal routine" end) let () = Parameter_customize.set_group inout_source let () = Parameter_customize.do_not_projectify () module FloatRelative = False (struct let option_name = "-float-relative" let module_name = "FloatRelative" let help = "display float intervals as [lower_bound ++ width]" end) let () = Parameter_customize.set_group inout_source let () = Parameter_customize.do_not_projectify () module FloatHex = False (struct let option_name = "-float-hex" let module_name = "FloatHex" let help = "display floats as hexadecimal" end) let () = Parameter_customize.set_group inout_source let () = Parameter_customize.do_not_projectify () 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 () = Parameter_customize.set_group saveload let () = Parameter_customize.do_not_projectify () module SaveState = P.Empty_string (struct let option_name = "-save" let arg_name = "filename" let help = "at exit, save the session into file " end) let () = Parameter_customize.set_group saveload let () = Parameter_customize.set_cmdline_stage Cmdline.Loading (* must be projectified: when loading, this option will be automatically reset *) (*let () = Parameter_customize.do_not_projectify ()*) module LoadState = P.Empty_string (struct let option_name = "-load" let arg_name = "filename" let help = "load a previously-saved session from file " end) let () = Parameter_customize.set_group saveload let () = Parameter_customize.set_cmdline_stage Cmdline.Extending let () = Parameter_customize.do_not_projectify () module AddPath = String_list (struct let option_name = "-add-path" let module_name = "AddPath" let arg_name = "DIR,..." let help = "Prepend directories to FRAMAC_PLUGIN for loading dynamic plug-ins" end) let () = Parameter_customize.set_group saveload let () = Parameter_customize.set_cmdline_stage Cmdline.Extending let () = Parameter_customize.do_not_projectify () module LoadModule = String_list (struct let option_name = "-load-module" let module_name = "LoadModule" let arg_name = "SPEC,..." let help = "Dynamically load plug-ins, modules and scripts. \ Each can be an OCaml source or object file, with \ or without extension, or a Findlib package. \ Loading order is preserved and \ additional dependencies can be listed in *.depend files." end) let () = LoadModule.add_aliases [ "-load-script" ] let () = Parameter_customize.set_group saveload let () = Parameter_customize.set_cmdline_stage Cmdline.Extending let () = Parameter_customize.do_not_projectify () module AutoLoadPlugins = True (struct let option_name = "-autoload-plugins" let module_name = "AutoLoadPlugins" let help = "Automatically load all plugins in FRAMAC_PLUGIN." end) let bootstrap_loader () = begin Dynamic.set_module_load_path (AddPath.get ()); if AutoLoadPlugins.get () then Dynamic.load_plugin_path () ; List.iter Dynamic.load_module (LoadModule.get()) ; end let () = Cmdline.load_all_plugins := bootstrap_loader module Journal = struct let () = Parameter_customize.set_negative_option_name "-journal-disable" let () = Parameter_customize.set_cmdline_stage Cmdline.Early let () = Parameter_customize.set_group saveload let () = Parameter_customize.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 () = Parameter_customize.set_group saveload let () = Parameter_customize.do_not_projectify () module Name = String (struct let module_name = "Journal.Name" let option_name = "-journal-name" let default = let dir = (* duplicate code from Plugin.Session *) if Session.Dir_name.is_set () then Session.Dir_name.get () else try Sys.getenv "FRAMAC_SESSION" with Not_found -> "./.frama-c" in dir ^ "/frama_c_journal.ml" let arg_name = "s" let help = "set the filename of the journal" end) let () = Name.add_set_hook (fun _ s -> Journal.set_name s); end let () = Parameter_customize.set_cmdline_stage Cmdline.Extending let () = Parameter_customize.set_group saveload let () = Parameter_customize.do_not_projectify () module Session_dir = P.Empty_string (struct let option_name = "-session" let arg_name = "" let help = "directory in which session files are searched" end) let () = Plugin.session_is_set_ref := Session_dir.is_set let () = Plugin.session_ref := Session_dir.get let () = Parameter_customize.set_cmdline_stage Cmdline.Extending let () = Parameter_customize.set_group saveload let () = Parameter_customize.do_not_projectify () module Config_dir = P.Empty_string (struct let option_name = "-config" let arg_name = "" let help = "directory in which configuration files are searched" end) let () = Plugin.config_is_set_ref := Config_dir.is_set let () = Plugin.config_ref := Config_dir.get (* ************************************************************************* *) (** {2 Parsing} *) (* ************************************************************************* *) let parsing = add_group "Parsing" let () = Parameter_customize.set_group parsing let () = Parameter_customize.do_not_reset_on_copy () let () = Parameter_customize.set_cmdline_stage Cmdline.Extended 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 () = Parameter_customize.set_group parsing let () = Parameter_customize.do_not_reset_on_copy () module CustomAnnot = P.Empty_string( struct let option_name = "-custom-annot-char" let help = "use a custom character for starting ACSL annotations" let arg_name = "c" end) let () = CustomAnnot.add_set_hook (fun _ s -> if CamlString.length s <> 1 then abort "-custom-annot expects a single character. Invalid argument %s" s) let () = Parameter_customize.set_group parsing let () = Parameter_customize.do_not_reset_on_copy () module ReadAnnot = True(struct let module_name = "ReadAnnot" let option_name = "-annot" let help = "read and parse annotations" end) let () = Parameter_customize.set_group parsing let () = Parameter_customize.do_not_reset_on_copy () module PreprocessAnnot = False(struct let module_name = "PreprocessAnnot" let option_name = "-pp-annot" let help = "pre-process annotations (if they are read). Set by default if \ the pre-processor is GNU-like (see option -cpp-frama-c-compliant)" end) let () = Parameter_customize.set_group parsing let () = Parameter_customize.do_not_reset_on_copy () module CppCommand = P.Empty_string (struct 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 follows:\n\ CPP -o \n\ %1 and %2 can be used into CPP string to mark the position of \ and respectively" end) let () = Parameter_customize.set_group parsing let () = Parameter_customize.do_not_reset_on_copy () let () = Parameter_customize.no_category () module CppExtraArgs = String_list (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 () = Parameter_customize.set_group parsing let () = Parameter_customize.do_not_reset_on_copy () module CppGnuLike = True (struct let module_name = "CppGnuLike" let option_name = "-cpp-frama-c-compliant" let help = "indicates that a custom pre-processor (see option -cpp-command) \ accepts the same set of options as GNU cpp. Set it to false if you \ have pre-processing issues with a custom pre-processor." end) let () = Parameter_customize.set_group parsing let () = Parameter_customize.do_not_reset_on_copy () module FramaCStdLib = True (struct let module_name = "FramaCStdLib" let option_name = "-frama-c-stdlib" let help = "adds -I$FRAMAC_SHARE/libc to the options given to the cpp command. \ If -cpp-frama-c-compliant is not false, also adds -nostdinc to prevent \ inconsistent mix of system and Frama-C header files" end) let () = Parameter_customize.set_group parsing let () = Parameter_customize.do_not_reset_on_copy () 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 () = Parameter_customize.set_group parsing module Orig_name = False(struct let option_name = "-orig-name" let module_name = "Orig_name" let help = "prints a message each time a variable is renamed" end) let () = Parameter_customize.set_group parsing let () = Parameter_customize.do_not_reset_on_copy () module ImplicitFunctionDeclaration = String(struct let option_name = "-implicit-function-declaration" let arg_name = "action" let help = "Warn or abort when a function is called before it has been declared \ (non-C99 compliant); action must be ignore, warn, or error" let default = "warn" let module_name = "ImplicitFunctionDeclaration" end) let () = ImplicitFunctionDeclaration.set_possible_values ["ignore"; "warn"; "error"] let () = Parameter_customize.set_group parsing let () = Parameter_customize.do_not_reset_on_copy () 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 () = Parameter_customize.set_group parsing let () = Parameter_customize.do_not_reset_on_copy () module C11 = False(struct let option_name = "-c11" let help = "allow C11 constructs (experimental; partial support only)" let module_name = "C11" end) (* ************************************************************************* *) (** {2 Customizing Normalization} *) (* ************************************************************************* *) let normalisation = add_group "Customizing Normalization" let () = Parameter_customize.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 () = Parameter_customize.set_group normalisation module UnrollingForce = Bool (struct let module_name = "UnrollingForce" let default = false let option_name = "-ulevel-force" let help = "ignore UNROLL loop pragmas disabling unrolling." end) let () = Parameter_customize.set_group normalisation let () = Parameter_customize.do_not_reset_on_copy () module Enums = P.Empty_string (struct 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 () = Parameter_customize.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 () = Parameter_customize.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 () = Parameter_customize.set_group normalisation let () = Parameter_customize.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 () = Parameter_customize.set_group normalisation module SimplifyTrivialLoops = True(struct let option_name = "-simplify-trivial-loops" let module_name = "SimplifyTrivialLoops" let help = "simplify trivial loops, such as do ... while(0) loops" end) let () = Parameter_customize.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 () = Parameter_customize.set_group normalisation let () = Parameter_customize.do_not_reset_on_copy () 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) let () = Parameter_customize.set_group normalisation module AggressiveMerging = False (struct let option_name = "-aggressive-merging" let module_name = "AggressiveMerging" let help = "merge function definitions modulo renaming \ (defaults to false)" end) let () = Parameter_customize.set_group normalisation module AsmContractsGenerate = True (struct let option_name = "-asm-contracts" let module_name = "AsmContractsGenerate" let help = "generate contracts for assembly code written according \ to gcc's extended syntax" end) let () = Parameter_customize.set_group normalisation module AsmContractsAutoValidate = False (struct let option_name = "-asm-contracts-auto-validate" let module_name = "AsmContractsAutoValidate" let help = "automatically mark contracts generated from asm as valid \ (defaults to false)" end) let () = Parameter_customize.set_group normalisation module RemoveExn = False (struct let option_name = "-remove-exn" let module_name = "RemoveExn" let help = "transforms throw and try/catch statements to normal C functions. \ Disabled by default, unless input source language has \ has an exception mechanism." end) module Files = struct let () = Parameter_customize.is_invisible () let () = Parameter_customize.no_category () include String_list (struct let option_name = "" let module_name = "Files" let arg_name = "" let help = "" end) let () = Cmdline.use_cmdline_files set end let () = Parameter_customize.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 () = Parameter_customize.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 () = Parameter_customize.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 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 () = Parameter_customize.set_group analysis_options 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 () = Parameter_customize.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 () = Parameter_customize.set_group analysis_options let () = Parameter_customize.set_negative_option_name "-const-writable" module ConstReadonly = True (struct let module_name = "ConstReadonly" let option_name = "-const-readonly" let help = "variables with the 'const' qualifier must be actually constant" end) let () = Parameter_customize.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 occurring \ between sequence points are separated" end) let () = Parameter_customize.set_negative_option_name "-unsafe-arrays" let () = Parameter_customize.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 () = Parameter_customize.set_group analysis_options let () = Parameter_customize.do_not_reset_on_copy () 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 () = Parameter_customize.set_group analysis_options let () = Parameter_customize.do_not_reset_on_copy () 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 () = Parameter_customize.set_group analysis_options let () = Parameter_customize.do_not_reset_on_copy () 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 () = Parameter_customize.set_group analysis_options let () = Parameter_customize.do_not_reset_on_copy () 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 () = Parameter_customize.set_group analysis_options let () = Parameter_customize.do_not_reset_on_copy () 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 Sequencing options} *) (* ************************************************************************* *) let misc = add_group "Sequencing 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-last" ~plugin:"" ~group:(misc :> Cmdline.Group.t) ~help:"like `-then', but the second group of actions is executed \ on the last project created by a program transformer." ~visible:true ~ext_help:"" () let () = Cmdline.add_option_without_action "-then-replace" ~plugin:"" ~group:(misc :> Cmdline.Group.t) ~help:"like `-then-last', but also remove the previous current project." ~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:"" () (* ************************************************************************* *) (** {2 Project-related options} *) (* ************************************************************************* *) let misc = add_group "Project-related Options" let () = Parameter_customize.set_group misc let () = Parameter_customize.do_not_projectify () module Set_project_as_default = False(struct let module_name = "Set_project_as_default" let option_name = "-set-project-as-default" let help = "the current project becomes the default one \ (and so future '-then' sequences are applied on it)" end) let () = Parameter_customize.set_group misc let () = Parameter_customize.do_not_projectify () module Remove_projects = P.Make_set (struct include Project.Datatype let of_singleton_string = P.no_element_of_string let of_string s = try Project.from_unique_name s with Project.Unknown_project -> raise (P.Cannot_build ("no project '" ^ s ^ "'")) let to_string = Project.get_unique_name end) (struct let option_name = "-remove-projects" let arg_name = "p1, ..., pn" let help = "remove the given projects , ..., . \ @all_but_current removes all projects but the current one." let default = Project.Datatype.Set.empty let dependencies = [] end) let _ = Remove_projects.Category.enable_all [] (object method fold: 'a. (Project.t -> 'a -> 'a) -> 'a -> 'a = fun f acc -> Project.fold_on_projects (fun acc p -> f p acc) acc method mem _p = true (* impossible to build an unregistered project *) end) let _ = Remove_projects.Category.add "all_but_current" [] (object method fold: 'a. (Project.t -> 'a -> 'a) -> 'a -> 'a = fun f acc -> Project.fold_on_projects (fun acc p -> if Project.is_current p then acc else f p acc) acc method mem p = not (Project.is_current p) end) let () = Cmdline.run_after_configuring_stage (fun () -> Remove_projects.iter (fun project -> Project.remove ~project ())) (* ************************************************************************* *) (** {2 Others options} *) (* ************************************************************************* *) [@@@warning "-60"] (* Warning this three options are parsed and used directly from Cmdline *) let () = Parameter_customize.set_negative_option_name "" let () = Parameter_customize.set_cmdline_stage Cmdline.Early let () = Parameter_customize.is_invisible () module NoType = Bool (struct let module_name = "NoType" let default = not Cmdline.use_type let option_name = "-no-type" let help = "" end) let () = Parameter_customize.set_negative_option_name "" let () = Parameter_customize.set_cmdline_stage Cmdline.Early let () = Parameter_customize.is_invisible () module NoObj = Bool (struct let module_name = "NoObj" let default = not Cmdline.use_obj let option_name = "-no-obj" let help = "" end) let () = Parameter_customize.set_group misc let () = Parameter_customize.set_negative_option_name "" let () = Parameter_customize.set_cmdline_stage Cmdline.Early module Deterministic = Bool (struct let module_name = "Deterministic" let default = not Cmdline.deterministic let option_name = "-deterministic" let help = "" end) [@@@warning "+60"] (* ************************************************************************* *) (** {2 Checks} *) (* ************************************************************************* *) let checks = add_group "Checks" let () = Parameter_customize.set_group checks let () = Parameter_customize.do_not_reset_on_copy () module Check = False(struct let option_name = "-check" let module_name = "Check" let help = "performs consistency checks over the Abstract Syntax \ Tree" end) let () = Parameter_customize.set_group checks module Copy = False(struct let option_name = "-copy" let module_name = "Copy" let help = "always perform a copy of the original AST before analysis begin" end) let () = Parameter_customize.set_group checks let () = Parameter_customize.set_negative_option_name "" module TypeCheck = True(struct let module_name = "TypeCheck" let option_name = "-typecheck" let help = "forces typechecking of the source files" end) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/plugin_entry_points/db.mli0000644000175000017500000023220213113745003025542 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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_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 Values} *) (* ************************************************************************* *) (** The Value analysis itself. @see <../value/index.html> internal documentation. *) 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 emitter: Emitter.t ref (** Emitter used by Value to emit statuses *) 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_By_Callstack: State_builder.Hashtbl with type key = stmt and type data = state Value_types.Callstack.Hashtbl.t (** Table containing the results of the value analysis, ie. the state before the evaluation of each reachable statement. *) module AfterTable_By_Callstack: State_builder.Hashtbl with type key = stmt and type data = state Value_types.Callstack.Hashtbl.t (** 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 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 -> ?replace:string -> builtin_sig -> unit) ref (** [!register_builtin name ?replace f] registers an abstract function [f] to use everytime a C function named [name] is called in the program. If [replace] is supplied and option [-val-builtins-auto] is active, calls to [replace] will also be substituted by the builtin. See also option [-val-builtin] *) val registered_builtins: (unit -> (string * builtin_sig) list) ref (** Returns a list of the pairs (name, builtin_sig) registered via [register_builtin]. @since Aluminium-20160501 *) val mem_builtin: (string -> bool) ref (** returns whether there is an abstract function registered by {!register_builtin} with the given name. *) 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 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 (** @return [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_initial_state_callstack : kernel_function -> state Value_types.Callstack.Hashtbl.t option 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 fold_stmt_state_callstack : (state -> 'a -> 'a) -> 'a -> after:bool -> stmt -> 'a val fold_state_callstack : (state -> 'a -> 'a) -> 'a -> after:bool -> kinstr -> 'a 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 reduce_by_cond: (state -> exp -> bool -> state) ref val find_lv_plus : (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 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. *) val lval_to_zone_with_deps_state: (state -> for_writing:bool -> deps:Locations.Zone.t option -> lval -> Locations.Zone.t * Locations.Zone.t * bool) ref (** [lval_to_zone_with_deps_state state ~for_writing ~deps lv] computes [res_deps, zone_lv, exact], where [res_deps] are the memory zones needed to evaluate [lv] in [state] joined with [deps]. [zone_lv] contains the valid memory zones that correspond to the location that [lv] evaluates to in [state]. If [for_writing] is true, [zone_lv] is restricted to memory zones that are writable. [exact] indicates that [lv] evaluates to a valid location of cardinal at most one. *) val lval_to_precise_loc_state: (with_alarms:CilE.warn_mode -> state -> lval -> state * Precise_locs.precise_location * typ) ref val lval_to_precise_loc_with_deps_state: (state -> deps:Locations.Zone.t option -> lval -> Locations.Zone.t * Precise_locs.precise_location) ref (** 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 (** For internal use only. Evaluate the [assigns] clause of the given function in the given prestate, compare it with the computed froms, return warning and set statuses. *) val verify_assigns_froms : (Kernel_function.t -> pre:state -> Function_Froms.t -> unit) ref (** {3 Evaluation of logic terms and predicates} *) module Logic : sig (** The APIs of this module are not stabilized yet, and are subject to change between Frama-C versions. *) val eval_predicate: (pre:state -> here:state -> predicate -> Property_status.emitted_status) ref (** Evaluate the given predicate in the given states for the Pre and Here ACSL labels. @since Neon-20140301 *) end (** {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 (* before states *) * (state Stmt.Hashtbl.t) Lazy.t) (* after states *) 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. [state] is the state before the call. @deprecated Use Call_Type_Value_Callbacks instead. *) module Call_Value_Callbacks: Hook.Iter_hook with type param = state * callstack (** Actions to perform at each treatment of a "call" statement. [state] is the state before the call. @since Aluminium-20160501 *) module Call_Type_Value_Callbacks: Hook.Iter_hook with type param = [`Builtin of Value_types.call_result | `Spec of funspec | `Def | `Memexec] * state * callstack (** Actions to perform whenever a statement is handled. *) module Compute_Statement_Callbacks: Hook.Iter_hook with type param = stmt * callstack * state list (** {3 Pretty printing} *) val pretty : Format.formatter -> t -> unit val pretty_state : Format.formatter -> state -> unit val display : (Format.formatter -> kernel_function -> unit) ref (**/**) (** {3 Internal use only} *) val noassert_get_state : kinstr -> state (** To be used during the value analysis itself (instead of {!get_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_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 : callstack -> state -> unit (** Store an additional possible initial state for the given callstack 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 (** exception raised by [find_deps_no_transitivity_*] if the given expression is not an lvalue. @since Aluminium-20160501 *) exception Not_lval 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 -> Function_Froms.Memory.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 (** @raise Not_lval if the given expression is not a C lvalue. *) val find_deps_term_no_transitivity_state : (Value.state -> term -> Value_types.logic_dependencies) ref val self: State.t ref (** {3 Pretty printing} *) val pretty : (Format.formatter -> kernel_function -> unit) ref val display : (Format.formatter -> unit) ref (** {3 Callback} *) module Record_From_Callbacks: Hook.Iter_hook with type param = Kernel_function.t Stack.t * Function_Froms.Memory.t Stmt.Hashtbl.t * (Kernel_function.t * Function_Froms.Memory.t) list Stmt.Hashtbl.t (** {3 Access to callwise-stored data} *) 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 (* ************************************************************************* *) (** {2 Properties} *) (* ************************************************************************* *) (** Dealing with logical properties. @plugin development guide *) module Properties : sig (** Interpretation of logic terms. *) module Interp : sig (** {3 Parsing logic terms and annotations} *) (** For the three functions below, [env] can be used to specify which logic labels are parsed. By default, only [Here] is accepted. All the C labels inside the function are also accepted, regardless of [env]. [loc] is used as the source for the beginning of the string. All three functions may raise {!Logic_interp.Error} or {!Parsing.Parse_error}. *) val term_lval : (kernel_function -> ?loc:location -> ?env:Logic_typing.Lenv.t -> string -> Cil_types.term_lval) ref val term : (kernel_function -> ?loc:location -> ?env:Logic_typing.Lenv.t -> string -> Cil_types.term) ref val predicate : (kernel_function -> ?loc:location -> ?env:Logic_typing.Lenv.t -> string -> Cil_types.predicate) ref val code_annot : (kernel_function -> stmt -> string -> code_annotation) ref (** {3 From logic terms to C terms} *) (** Exception raised by the functions below when their given argument cannot be interpreted in the C world. @since Aluminium-20160501 *) exception No_conversion val term_lval_to_lval: (result: Cil_types.varinfo option -> term_lval -> Cil_types.lval) ref (** @raise No_conversion if the argument is not a left value. @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg *) val term_to_lval: (result: Cil_types.varinfo option -> term -> Cil_types.lval) ref (** @raise No_conversion if the argument is not a left value. @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg *) val term_to_exp: (result: Cil_types.varinfo option -> term -> Cil_types.exp) ref (** @raise No_conversion if the argument is not a valid expression. @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg *) val loc_to_exp: (result: Cil_types.varinfo option -> term -> Cil_types.exp list) ref (** @return a list of C expressions. @raise No_conversion if the argument is not a valid set of expressions. @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg *) val loc_to_lval: (result: Cil_types.varinfo option -> term -> Cil_types.lval list) ref (** @return a list of C locations. @raise No_conversion if the argument is not a valid set of left values. @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg *) val term_offset_to_offset: (result: Cil_types.varinfo option -> term_offset -> offset) ref (** @raise No_conversion if the argument is not a valid offset. @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg *) 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 locations who have all the same base address. @raise No_conversion if the given term does not match the precondition @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg *) (** {3 From logic terms to Locations.location} *) val loc_to_loc: (result: Cil_types.varinfo option -> Value.state -> term -> Locations.location) ref (** @raise No_conversion if the translation fails. @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg *) val loc_to_loc_under_over: (result: Cil_types.varinfo option -> Value.state -> term -> Locations.location * Locations.location * Locations.Zone.t) ref (** Same as {!loc_to_loc}, except that we return simultaneously an under-approximation of the term (first location), and an over-approximation (second location). The under-approximation is particularly useful when evaluating Tsets. The zone returned is an over-approximation of locations that have been read during evaluation. Warning: This API is not stabilized, and may change in the future. @raise No_conversion if the translation fails. @modify Aluminium-20160501 raises a custom exn instead of generic Invalid_arg *) (** {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 -> 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 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_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 an annotation on the given stmt. *) 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 interpretation of the term result? @since Carbon-20110201 *) val to_result_from_pred: (predicate -> bool) 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} *) (* ************************************************************************* *) (** 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 (** Syntactic 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 (** 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_divMod_status : (unit -> status_accessor) ref val get_memAccess_status : (unit -> status_accessor) ref val get_pointerCall_status: (unit -> status_accessor) ref val get_signedOv_status : (unit -> status_accessor) ref val get_signed_downCast_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 : (Cil_datatype.Fundec.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 (** Propagate 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 from_nodes: (kernel_function -> PdgTypes.Node.t list -> PdgTypes.NodeSet.t) ref (** Compute the impact analysis of the given set of PDG nodes, that come from the given function. @return the impacted nodes *) 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 *) 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 output 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 output 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. @raise PdgIndex.CallStatement if the given stmt is a function call. *) val find_simple_stmt_nodes : (t -> Cil_types.stmt -> PdgTypes.Node.t list) ref (** Get the nodes corresponding to the statement. It is usually composed of only one node (see {!find_stmt_node}), except for call statement. Be careful that for block statements, it only returns 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], only the id of the node is printed.. *) 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]. *) 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.Hptset.t * (Stmt.Hptset.t * Stmt.Hptset.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.Hptset.t * code_annotation list) ref (** compute the set of statements where the given annotation has the same value as before the given stmt. Also returns the eventual code annotations that are implied by the one given as argument. *) 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 mark the assertions as proven. *) val get_defs : (kernel_function -> stmt -> lval -> (Stmt.Hptset.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.Hptset.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. * @modify Carbon-20110201 optional argument [new_proj_name] added * *) 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 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 val reset_slice : (unit -> unit) ref (** {3 Kernel function} *) val is_called : (kernel_function -> bool) ref (** Return [true] iff the source function is called (even indirectly via transitivity) from a [Slice.t]. *) val has_persistent_selection : (kernel_function -> bool) ref (** return [true] iff the source function has persistent selection *) val change_slicing_level : (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 (* t was turned into unit, but not erased because of the optional parameter *) val extract : (string -> ?f_slice_names:(kernel_function -> bool -> int -> string) -> unit -> 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 recommended 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 -> 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 -> unit) ref (** For debugging... Pretty print project information. *) val is_directly_called_internal : (kernel_function -> bool) ref (** Return [true] if the source function is directly (even via pointer function) called from a [Slice.t]. *) end (** Access to slicing results. *) module Mark : sig type t = SlicingTypes.sl_mark (** Abstract 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 example, 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 : (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 -> 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 whole scope of the function. 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. @modify Magnesium-20151001 argument [~scope] removed. *) val select_stmt_lval : (set -> Mark.t -> Datatype.String.Set.t -> before:bool -> 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 whole scope of the function. 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. @modify Magnesium-20151001 argument [~scope] removed. *) 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 -> 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 -> 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 whole scope of the function. 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. @modify Magnesium-20151001 argument [~scope] removed. *) 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 functional 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 as selecting the zone at the 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 (** Abstract data type for function slice. *) val dyn_t : t Type.t (** For dynamic type checking and journalization. *) val create : (kernel_function -> t) ref (** Used to get an empty slice (nothing selected) related to a function. *) val remove : (t -> unit) ref (** Remove the slice from the project. The slice shouldn't be called. *) val remove_uncalled : (unit -> unit) ref (** Remove the uncalled slice from the project. *) (** {3 Getters} *) val get_all: (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 : (kernel_function -> int -> t) ref val pretty : (Format.formatter -> t -> unit) ref (** For debugging... Pretty print slice information. *) end (** Requests for slicing jobs. Slicing requests are part of a slicing project. So, user requests affect slicing project. *) module Request : sig val apply_all: (propagate_to_callers:bool -> unit) ref (** Apply all slicing requests. *) (** {3 Adding a request} *) val add_selection: (Select.set -> unit) ref (** Add a selection request to all slices (existing) of a function to the project requests. *) val add_persistent_selection: (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 : (unit -> 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: (Slice.t -> Select.t -> unit) ref (** Internally used to add a selection request for a function slice to the project requests. *) val add_selection_internal: (Select.t -> unit) ref (** Internally 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). *) (* This first unit argument is to comply with the signature. I assume there is a nicer solution. *) val add_call_slice: (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: (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: (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: (unit -> unit) ref (** Internally used to apply all slicing requests. *) val apply_next_internal: (unit -> unit) ref (** Internally used to apply the first slicing request of the project list and remove it from the list. That may modify the contents of the remaining list. For example, new requests may be added to the list. *) val is_request_empty_internal: (unit -> bool) ref (** Internally used to know if internal requests are pending. *) val merge_slices: (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: (Slice.t -> Slice.t) ref (** Copy the input slice. The new slice is not called, * so it is the user responsibility to change the calls if he wants to. *) val split_slice: (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 : (unit -> unit) ref (** Apply pending request then propagate user marks to callers recursively then apply pending requests *) val pretty : (Format.formatter -> unit) ref (** For debugging... Pretty print the request 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-Phosphorus-20170501/src/kernel_services/plugin_entry_points/emitter.mli0000644000175000017500000001467013113745010026633 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 *) (**************************************************************************) (** {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:Typed_parameter.t list -> tuning:Typed_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 val dummy: 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 iter_sorted: cmp: (H.key -> H.key -> int) -> (H.key -> internal_tbl -> unit) -> unit val fold_sorted: cmp: (H.key -> H.key -> int) -> (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-Phosphorus-20170501/src/kernel_services/plugin_entry_points/plugin.ml0000644000175000017500000005433713113745011026314 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 CamlString = String let empty_string = "" let positive_debug_ref = ref 0 let session_is_set_ref = Extlib.mk_fun "session_is_set_ref" let session_ref = Extlib.mk_fun "session_ref" let config_is_set_ref = Extlib.mk_fun "config_is_set_ref" let config_ref = Extlib.mk_fun "config_ref" (* ************************************************************************* *) (** {2 Signatures} *) (* ************************************************************************* *) module type S = sig include Log.Messages val add_group: ?memo:bool -> string -> Cmdline.Group.t module Help: Parameter_sig.Bool module Verbose: Parameter_sig.Int module Debug: Parameter_sig.Int module Debug_category: Parameter_sig.String_set module Share: Parameter_sig.Specific_dir module Session: Parameter_sig.Specific_dir module Config: Parameter_sig.Specific_dir val help: Cmdline.Group.t val messages: Cmdline.Group.t end module type General_services = sig include S include Parameter_sig.Builder 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 session_visible_ref = ref false let is_session_visible () = session_visible_ref := true let config_visible_ref = ref false let is_config_visible () = config_visible_ref := true let plugin_subpath_ref = ref None let plugin_subpath s = plugin_subpath_ref := Some s let default_msg_keys_ref = ref [] let default_msg_keys l = default_msg_keys_ref := l let reset_plugin () = kernel := false; share_visible_ref := false; session_visible_ref := false; config_visible_ref := false; plugin_subpath_ref := None; default_msg_keys_ref := []; ;; (* ************************************************************************* *) (** {2 Generic functors} *) (* ************************************************************************* *) let kernel_name = "kernel" type plugin = { p_name: string; p_shortname: string; p_help: string; p_parameters: (string, Typed_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 is_present s = List.exists (fun p -> p.p_shortname = s) !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 let get s = Cmdline.Kernel_log.deprecated "Plugin.get" ~now:"Plugin.get_from_name" get_from_name s (* ************************************************************************* *) (** {2 Global data structures} *) (* ************************************************************************* *) (* File formatters used by options [--log]. *) module File_formatters : sig val get : string -> Format.formatter end = struct (* File formatters must be globally defined so that if a new plugin wants to redirect output to an existing file, the same formatter must be used to avoid re-opening file descriptors and erasing data. E.g. in `frama-c -plugin1-log file.txt -then -plugin2-log file.txt`, the formatter avoids Frama-C from opening file.txt a second time, which would truncate its contents. *) let file_formatters : (string, Format.formatter) Hashtbl.t = Hashtbl.create 0 (* Opens and returns a new file formatter if the file has not been opened yet, otherwise returns the existing formatter for the file. *) let get filename = (* Note: normalized paths are not necessarily canonical, so if the command-line arguments are unusual, this may fail to detect two filenames as referring to the same file. *) let normalized_filename = Filepath.normalize filename in try Hashtbl.find file_formatters normalized_filename with | Not_found -> let oc = open_out normalized_filename in let fmt = Format.formatter_of_out_channel oc in Hashtbl.add file_formatters normalized_filename fmt; Extlib.safe_at_exit (fun () -> Pervasives.close_out oc); fmt 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 verbose_level = ref (fun () -> 1) let debug_level = ref (fun () -> 0) (* unused by the kernel: it uses Cmdline.Kernel_log instead; see module [L] below *) module Plugin_log = Log.Register (struct let channel = P.shortname let label = P.shortname let debug_atleast level = !debug_level () >= level let verbose_atleast level = !verbose_level () >= level end) module L = (val if is_kernel () then (module Cmdline.Kernel_log) else (module Plugin_log) : Log.Messages) (* Add default message keys to the instance of Log.Messages *) let () = let add s = let c = L.register_category s in L.add_debug_keys (Log.Category_set.singleton c) in List.iter add !default_msg_keys_ref 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_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 -> L.abort "cannot register plug-in `%s': %s" P.name s); kernel_ongoing := is_kernel (); plugins := plugin :: !plugins (* ************************************************************************ *) (** {3 Generic options for each plug-in} *) (* ************************************************************************ *) let messages = add_group "Output Messages" include Parameter_builder.Make (struct let shortname = P.shortname module L = L let messages_group = messages let parameters = plugin.p_parameters end) let prefix = if P.shortname = empty_string then "-kernel-" else "-" ^ P.shortname ^ "-" let plugin_subpath = match !plugin_subpath_ref with | None -> P.shortname | Some s -> s (* ************************************************************************ *) (** {3 Specific directories} *) (* ************************************************************************ *) module Make_specific_dir (O: Parameter_sig.Input_with_arg) (D: sig val dir: unit -> string val visible_ref: bool val force_dir: bool end) = struct let is_visible = D.visible_ref let force_dir = D.force_dir let is_kernel = is_kernel () (* the side effect must be applied right now *) let () = Parameter_customize.set_cmdline_stage Cmdline.Extended; if is_visible then Parameter_customize.do_iterate () else Parameter_customize.is_invisible () module Dir_name = Empty_string (struct let option_name = prefix ^ O.option_name let arg_name = O.arg_name let help = if is_visible then O.help else empty_string end) exception No_dir let mk_dir d = try Unix.mkdir d 0o755; L.warning "creating %s directory `%s'" O.option_name d; d with Unix.Unix_error _ -> L.warning "cannot create %s directory `%s'" O.option_name d; raise No_dir let get_and_check_dir ?(error=true) d = (* DO NOT Filepath.normalize the argument, since it can transform an absolute path into a relative one, leading to issues if a chdir occurs at some point. *) if (try Sys.is_directory d with Sys_error _ -> false) then d else if error then L.abort "no %s directory `%s' for plug-in `%s'" O.option_name d P.name else begin if force_dir then begin (* create the parent, if it does not exist *) let p = Filename.dirname d in if not (try Sys.is_directory p with Sys_error _ -> false) then ignore (mk_dir p); mk_dir d end else raise No_dir end let dir ?error () = (* get the specified dir if any *) let d = if is_visible then Dir_name.get () else empty_string in if d = empty_string then (* no specified dir: look for the default one. *) if is_kernel then get_and_check_dir ?error (D.dir ()) else get_and_check_dir ?error (D.dir () ^ "/" ^ plugin_subpath) else get_and_check_dir ?error d let file ?error f = dir ?error () ^ "/" ^ f end module Share = Make_specific_dir (struct let option_name = "share" let arg_name = "dir" let help = "set the plug-in share directory to

    \ (may be used if the plug-in is not installed at the same place as Frama-C)" end) (struct let dir () = Config.datadir let visible_ref = !share_visible_ref let force_dir = false end) module Session = Make_specific_dir (struct let option_name = "session" let arg_name = "dir" let help = "set the plug-in session directory to " end) (struct let dir () = if !session_is_set_ref () then !session_ref () else try Sys.getenv "FRAMAC_SESSION" with Not_found -> "./.frama-c" let visible_ref = !session_visible_ref let force_dir = true end) let () = if is_kernel () then Journal.get_session_file := Session.file ~error:false module Config = Make_specific_dir (struct let option_name = "config" let arg_name = "dir" let help = "set the plug-in config directory to \ (may be used on systems with no default user directory)" end) (struct let dir () = let d, vis = if !config_is_set_ref () then !config_ref (), false else try Sys.getenv "FRAMAC_CONFIG", false with Not_found -> try Sys.getenv "USERPROFILE", false (* Win32 *) with Not_found -> (* Unix like *) try Sys.getenv "XDG_CONFIG_HOME", true with Not_found -> try Sys.getenv "HOME" ^ "/.config", true with Not_found -> ".", false in d ^ if vis then "/frama-c" else "/.frama-c" let visible_ref = !config_visible_ref let force_dir = true end) let help = add_group "Getting Information" let () = Parameter_customize.set_group help let () = Parameter_customize.set_cmdline_stage Cmdline.Exiting let () = if is_kernel () then Parameter_customize.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 = Parameter_customize.set_group messages; Parameter_customize.do_not_projectify (); Parameter_customize.do_not_journalize (); Parameter_customize.do_iterate (); if is_kernel () then begin Parameter_customize.set_cmdline_stage Cmdline.Early; Parameter_customize.set_module_name modname; "-" ^ kernel_name ^ "-" ^ optname end else begin Parameter_customize.set_cmdline_stage Cmdline.Extended; prefix ^ optname end let logfile_optname = output_mode "LogToFile" "log" module LogToFile = struct include String_map (struct include Datatype.String type key = string let of_string ~key:_ ~prev:_ s = match s with | None -> raise (Cannot_build "missing delimiter") | Some s when s = "" -> raise (Cannot_build "missing filename") | Some _ -> s let to_string ~key:_a b = b end) (struct let option_name = logfile_optname let arg_name = "K_1:file_1,..." let help = "copy log messages from " ^ (if is_kernel () then "the Frama-C kernel" else P.name) ^ " to a file. is a combination of these characters:\n\ a: ALL messages (equivalent to 'dfiruw')\n\ d: debug e: user or internal error (same as 'iu')\n\ f: feedback i: internal error\n\ r: result u: user error w: warning\n\ An empty (e.g. \":file.txt\") defaults to 'iruw'. \ One plug-in can output to several files and vice-versa." let default = Datatype.String.Map.empty end) type parse_result = | Parse_OK of Log.kind list | Parse_Error of string (*msg*) (* default kinds when none are specified *) let default_kinds_str = "erw" (* all valid characters for specifying kinds *) let valid_kinds_str = "adefiruw" (* [parse_kinds str] parses [str] to return a list of [kind]s. *) let parse_kinds str = if Str.string_match (Str.regexp ("[^" ^ valid_kinds_str ^ "]")) str 0 then Parse_Error ("invalid log kind character, must be one of: " ^ valid_kinds_str) else let str = if str = "" then default_kinds_str else str in let has_ch c = CamlString.contains str (Transitioning.Char.lowercase_ascii c) in let list_of_bool b e = if b then [e] else [] in let kinds = list_of_bool (has_ch 'd' || has_ch 'a') Log.Debug @ list_of_bool (has_ch 'f' || has_ch 'a') Log.Feedback @ list_of_bool (has_ch 'i' || has_ch 'a' || has_ch 'e') Log.Failure @ list_of_bool (has_ch 'r' || has_ch 'a') Log.Result @ list_of_bool (has_ch 'u' || has_ch 'a' || has_ch 'e') Log.Error @ list_of_bool (has_ch 'w' || has_ch 'a') Log.Warning in Parse_OK kinds let pp_source fmt = function | None -> () | Some src -> Format.fprintf fmt "%s:%d:" (Filepath.pretty src.Lexing.pos_fname) src.Lexing.pos_lnum end (* Output must be synchronized with functions [prefix_*] in module Log. *) let pp_event_prefix fmt event = let pp_dkey fmt = (Pretty_utils.pp_opt ~pre:(format_of_string ":") Format.pp_print_string) fmt event.Log.evt_dkey in match event.Log.evt_kind with | Log.Error -> Format.fprintf fmt "[%s%t] user error:" event.Log.evt_plugin pp_dkey | Log.Warning -> Format.fprintf fmt "[%s%t] warning:" event.Log.evt_plugin pp_dkey | Log.Failure -> Format.fprintf fmt "[%s%t] failure:" event.Log.evt_plugin pp_dkey | _ -> Format.fprintf fmt "[%s%t]" event.Log.evt_plugin pp_dkey (* Note: because of the imperative nature of Log listeners, and the fact that they cannot be removed, whenever the -log option is processed again (e.g. after a -then), we must only add new entries to the list of listeners, otherwise we will duplicate the output. *) (* Also note that this code CANNOT be put inside LogToFile, because it uses Datatype. *) let add_new_listeners plugin_name old_value new_value = let new_entries = Datatype.String.Map.filter (fun k _ -> not (Datatype.String.Map.mem k old_value)) new_value in Datatype.String.Map.iter (fun kinds_str filename -> match LogToFile.parse_kinds kinds_str with | LogToFile.Parse_Error msg -> L.abort "%s" msg | LogToFile.Parse_OK kinds -> let fmt = File_formatters.get filename in Log.add_listener ~plugin:plugin_name ~kind:kinds (fun event -> Format.fprintf fmt "%a%a %s@." LogToFile.pp_source event.Log.evt_source pp_event_prefix event event.Log.evt_message); ) new_entries let () = LogToFile.add_set_hook (add_new_listeners (if is_kernel () then kernel_name else P.shortname) ) 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 begin Cmdline.kernel_verbose_atleast_ref := (fun n -> get () >= n); match !Cmdline.Kernel_verbose_level.value_if_set with | None -> () | Some n -> set n end 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 begin Cmdline.kernel_debug_atleast_ref := (fun n -> get () >= n); match !Cmdline.Kernel_debug_level.value_if_set with | None -> () | Some n -> set n end end let debug_category_optname = output_mode "Msg_key" "msg-key" module Debug_category = Filled_string_set(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" let default = Datatype.String.Set.of_list !default_msg_keys_ref end) let () = let module D = Datatype in Debug_category.add_set_hook (fun before after -> if not (D.String.Set.mem "help" before) && D.String.Set.mem "help" after then (* level 0 just in case user ask to display all categories in an otherwise quiet run *) Cmdline.at_normal_exit (fun () -> L.feedback ~level:0 "@[Available message categories are:%a@]" (fun fmt set -> Log.Category_set.iter (fun s -> let s = (s:Log.category:>string) in if s <> empty_string then Format.fprintf fmt "@;%s" s) set) (L.get_all_categories ())); let add_category c s = D.String.Set.add (c:Log.category:>string) s in let subcategory_closure s = D.String.Set.fold (fun s acc -> Log.Category_set.union (L.get_category s) acc) s Log.Category_set.empty in let string_of_cat_set s = Log.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 L.add_debug_keys added; L.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 Debug_category.unsafe_set after) let () = reset_plugin () include Plugin_log end (* Register *) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/plugin_entry_points/log.mli0000644000175000017500000004032613113745006025745 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 *) open Format type kind = Result | Feedback | Debug | Warning | Error | Failure (** @since Beryllium-20090601-beta1 *) type event = { evt_kind : kind ; evt_plugin : string ; evt_dkey : string option ; 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 registered 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 (** User error that prevents a plugin to terminate. Argument is the name of the plugin. @since Beryllium-20090601-beta1 *) exception AbortFatal of string (** Internal error that prevents a plugin to terminate. Argument is the name of the plugin. @since Beryllium-20090601-beta1 *) exception FeatureRequest of string * string (** Raised 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 Option_signature.Interface} @since Beryllium-20090601-beta1 *) (* -------------------------------------------------------------------------- *) 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 *) type ontty = [ | `Message (** Normal message (default) *) | `Feedback (** Temporary visible on console, normal message otherwise *) | `Transient (** Temporary visible, only on console *) | `Silent (** Not visible on console *) ] module Category_set: FCSet.S with type elt = category (** sets of category keywords *) (** @since Beryllium-20090601-beta1 @plugin development guide *) module type Messages = sig val verbose_atleast : int -> bool (** @since Beryllium-20090601-beta1 *) val debug_atleast : int -> bool (** @since Beryllium-20090601-beta1 *) val printf : ?level:int -> ?dkey:category -> ?current:bool -> ?source:Lexing.position -> ?append:(Format.formatter -> unit) -> ?header:(Format.formatter -> unit) -> ?prefix:string -> ?suffix:string -> ('a,formatter,unit) format -> 'a (** Outputs the formatted message on [stdout]. Levels and key-categories are taken into account like event messages. The header formatted message is emitted as a regular [result] message. Prefix and suffix strings, if provided, are emitted on [stdout] as is, at the beginning of an empty line and with a terminal newline character. *) 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 : ?ontty:ontty -> ?level:int -> ?dkey:category -> 'a pretty_printer (** Progress and feedback. Level is tested against the verbosity level. @since Beryllium-20090601-beta1 @modify Fluorine-20130401 Optional parameter [?dkey] @modify Magnesium-20151001 Optional parameter [?ontty] @plugin development guide *) val debug : ?level:int -> ?dkey:category -> 'a pretty_printer (** Debugging information dedicated to Plugin developers. 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 caught, 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 (** {3 Category management} *) val register_category: string -> category (** register a new debugging/verbose category. Note: categories must be added (e.g. via [add_debug_keys]) after registration. @since Fluorine-20130401 *) 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 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. Note: this should not be used directly by plug-in developers; use instead [Plugin.S.Debug_category.add]. @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 *) 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 clean : unit -> unit (** Flushes the last transient message if necessary. *) 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 : ?isatty:bool -> (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. *) val tty : (unit -> bool) ref (* Callback for command-line option '-(no)-tty' *) (**/**) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/plugin_entry_points/log.ml0000644000175000017500000010263013113745013025567 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 let _pretty_kind fmt = function | Result -> Format.fprintf fmt "Result" | Feedback -> Format.fprintf fmt "Feedback" | Debug -> Format.fprintf fmt "Debug" | Warning -> Format.fprintf fmt "Warning" | Error -> Format.fprintf fmt "Error" | Failure -> Format.fprintf fmt "Failure" type event = { evt_kind : kind ; evt_plugin : string ; evt_dkey : string option; 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 isatty : bool ; mutable clean : bool ; 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 term_clean t = if t.isatty && not t.clean then begin let u = "\r\027[K" in (* TERM escape commands: "\r" is carriage return ; "\027[K" is CSI command EL 'Erase in Line' ; See https://en.wikipedia.org/wiki/ANSI_escape_code *) t.output u 0 (String.length u) ; t.clean <- true ; end let set_terminal t isatty output flush = begin (* Ensures previous terminal state is clean *) assert (is_ready t) ; term_clean t ; (* Now reconfigure the terminal *) t.isatty <- isatty ; t.output <- output ; t.flush <- flush ; t.clean <- true ; end let stdout = { lock = Ready ; clean = true ; delayed = [] ; isatty = Unix.isatty Unix.stdout ; output = Pervasives.output_substring Pervasives.stdout ; flush = (fun () -> Pervasives.flush Pervasives.stdout); } let clean () = term_clean stdout let set_output ?(isatty=false) output flush = set_terminal stdout isatty output flush (* -------------------------------------------------------------------------- *) (* --- 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" ; term_clean t ; 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 buf : FCBuffer.t ; } 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 (FCBuffer.nth text k) then lookup_fwd text (succ k) n else k in lookup_fwd buffer.buf 0 (FCBuffer.length buffer.buf) let trim_end buffer = let rec lookup_bwd text k = if k >= 0 && is_blank (FCBuffer.nth text k) then lookup_bwd text (pred k) else k in lookup_bwd buffer.buf (pred (FCBuffer.length buffer.buf)) let reduce_buffer buffer = if FCBuffer.length buffer.buf > min_buffer then FCBuffer.reset buffer.buf let truncate_text buffer size = if FCBuffer.length buffer.buf > 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 ; end else if n <= size then begin FCBuffer.blit_buffer buffer.buf p buffer.buf 0 n ; end else begin let n_left = size / 2 - 3 in let n_right = size - n_left - 5 in if p > 0 then FCBuffer.blit_buffer buffer.buf p buffer.buf 0 n_left ; FCBuffer.blit_substring "[...]" 0 buffer.buf n_left 5 ; FCBuffer.blit_buffer buffer.buf (q-n_right+1) buffer.buf (n_left + 5) n_right ; FCBuffer.truncate buffer.buf size ; end end let append buffer text k n = FCBuffer.add_substring buffer.buf text k n; if FCBuffer.length buffer.buf > tgr_buffer then truncate_text buffer max_buffer let new_buffer () = let buffer = { formatter = null ; buf = FCBuffer.create min_buffer ; } 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_firstline output text p q width = let t = try String.index_from text p '\n' with Not_found -> succ q in let n = min width (t-p) in output text p n let echo_source output = function | None -> () | Some src -> let s = Printf.sprintf "%s:%d:" (Filepath.pretty 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 = term_clean 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 term_clean terminal ; echo_source terminal.output source ; echo_lines terminal.output text prefix p q ; terminal.flush () end let do_transient terminal source text p q = if p <= q && not (delayed_echo terminal) then begin term_clean terminal ; echo_source terminal.output source ; echo_firstline terminal.output text p q 80 ; if terminal.isatty then terminal.clean <- false else terminal.output "\n" 0 1 ; 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 ontty = [ | `Message (* Normal message (default) *) | `Feedback (* Temporary visible on console, normal message otherwise *) | `Transient (* Temporary visible, only on console *) | `Silent (* Not visible on console *) ] let tty = ref (fun () -> false) 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 ) 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 ?(transient=false) ~kind ~once ?dkey ~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 if transient then do_transient c.terminal source (FCBuffer.contents buffer.buf) p q else begin let event = lazy { evt_kind = kind ; evt_plugin = c.plugin ; evt_dkey = dkey ; evt_message = FCBuffer.sub buffer.buf 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 (FCBuffer.contents buffer.buf) 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 ?dkey ~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_dkey = dkey ; evt_message = if p<=q then FCBuffer.sub buffer.buf 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 (FCBuffer.contents buffer.buf) 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 --- *) (* ------------------------------------------------------------------------- *) type category = string module Category_set = FCSet.Make(String) module type Messages = sig val verbose_atleast: int -> bool val debug_atleast: int -> bool val printf : ?level:int -> ?dkey:category -> ?current:bool -> ?source:Lexing.position -> ?append:(Format.formatter -> unit) -> ?header:(Format.formatter -> unit) -> ?prefix:string -> ?suffix:string -> ('a,formatter,unit) format -> 'a val result : ?level:int -> ?dkey:category -> 'a pretty_printer val feedback: ?ontty:ontty -> ?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 val register_category: string -> category val get_category: string -> Category_set.t val get_all_categories: unit -> Category_set.t 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 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 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 -> (* returning [s] itself is required to get indirect kernel categories (e.g. project) to work. *) Category_set.singleton s 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_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 -> prefix_first | Some key -> Label (Printf.sprintf "[%s:%s] " label key) let prefix_for = function | Result | Feedback | Debug -> 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 and 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 useful 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 ?dkey ~prefix:(prefix_dkey dkey) ~source:(get_source current source) ~once ~emitwith ~echo ~append text else nullprintf text let transient channel = channel.terminal.isatty && !tty () let feedback ?(ontty=`Message) ?(level=1) ?dkey ?(current=false) ?source ?emitwith ?(echo=true) ?(once=false) ?append text = let mode = if verbose_atleast level && has_debug_key dkey then match ontty with | `Feedback -> if transient channel then `Transient else `Message | `Transient -> if transient channel then `Transient else `Silent | `Silent -> if transient channel then `Silent else `Message | `Message -> `Message else `Silent in match mode with | `Message -> logtext channel ~kind:Feedback ?dkey ~prefix:(prefix_dkey dkey) ~source:(get_source current source) ~once ~emitwith ~echo ~append text | `Transient -> logtext channel ~transient:true ~kind:Feedback ?dkey ~prefix:prefix_first ~once:false ~echo:true ~source:None ~emitwith:None ~append:None text | `Silent -> nullprintf text let should_output_debug level dkey = match level, dkey with | None, None -> debug_atleast 1 | Some l, None -> debug_atleast l | None, Some _ -> has_debug_key dkey | Some l, Some _ -> debug_atleast l && has_debug_key dkey let debug ?level ?dkey ?(current=false) ?source ?emitwith ?(echo=true) ?(once=false) ?append text = if should_output_debug level dkey then logtext channel ~kind:Debug ?dkey ~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: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 ())) let noprint _fmt = () let noemit _event = () let spynewline bol output buffer start length = begin let ofs = start+length-1 in if 0 <= ofs && ofs < String.length buffer then bol := buffer.[ofs] = '\n' ; output buffer start length end let printf ?(level=1) ?dkey ?(current=false) ?source ?(append=noprint) ?header ?prefix ?suffix text = if verbose_atleast level && has_debug_key dkey then begin (* Header is a regular message *) let header = match header with None -> noprint | Some h -> h in logtext channel ~kind:Result ?dkey ~prefix:(prefix_dkey dkey) ~source:(get_source current source) ~emitwith:(Some noemit) ~echo:true ~append:None ~once:false "%t" header ; let print_line = function | None -> () | Some line -> stdout.output line 0 (String.length line) ; stdout.output "\n" 0 1 ; stdout.flush () ; in print_line prefix ; let bol = ref true in let stdout = { stdout with output = spynewline bol stdout.output } in let fmt = delayed_terminal stdout in try Format.kfprintf begin fun fmt -> append fmt ; Format.pp_print_flush fmt () ; unlock_terminal stdout fmt ; if not !bol then Format.pp_print_newline fmt () ; print_line suffix ; end fmt text with error -> unlock_terminal stdout fmt ; raise error end else nullprintf text end (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_queries/0000755000175000017500000000000013113745012022662 5ustar mehdimehdiframa-c-Phosphorus-20170501/src/kernel_services/ast_queries/cil_datatype.mli0000644000175000017500000002404513113745005026036 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 of some useful CIL types. @plugin development guide *) open Cil_types open Datatype (** Auxiliary module for datatypes that can be pretty-printed. For those that do not have this signature, module {!Printer} must be used. *) module type S_with_pretty = sig include S (**/**) val pretty_ref: (Format.formatter -> t -> unit) ref end module type S_with_collections_pretty = sig include S_with_collections (**/**) val pretty_ref: (Format.formatter -> t -> unit) ref end (**************************************************************************) (** {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_pretty 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: S_with_pretty with type t = block (* Blocks cannot compared or hashed, so collections are not available *) 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: S_with_collections_pretty with type t = constant (** Note that the equality is based on eid. For structural equality, use {!ExpStructEq} *) module Exp: sig include S_with_collections_pretty with type t = exp val dummy: exp (** @since Nitrogen-20111001 *) end module ExpStructEq: S_with_collections with type t = exp module Fieldinfo: S_with_collections_pretty with type t = fieldinfo module File: S with type t = file module Global: sig include S_with_collections_pretty with type t = global val loc: t -> location val attr: t -> attributes (** @since Phosphorus-20170501-beta1 *) end module Initinfo: S with type t = initinfo module Instr: sig include S_with_pretty with type t = instr val loc: t -> location 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: S_with_collections_pretty with type t = lval (** @since Oxygen-20120901 *) module LvalStructEq: S_with_collections with type t = lval (** Same remark as for Lval. For structural equality, use {!OffsetStructEq}. *) module Offset: S_with_collections_pretty with type t = offset (** @since Oxygen-20120901 *) module OffsetStructEq: S_with_collections with type t = offset module Stmt_Id: Hptmap.Id_Datatype with type t = stmt module Stmt: sig include S_with_collections_pretty with type t = stmt module Hptset: sig include Hptset.S with type elt = stmt and type 'a shape = 'a Hptmap.Shape(Stmt_Id).t 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 *) end module Attribute: S_with_collections_pretty with type t = attribute module Attributes: S_with_collections with type t = attributes (** Types, with comparison over struct done by key and unrolling of typedefs. *) module Typ: sig include S_with_collections_pretty with type t = typ val toplevel_attr: t -> attributes (** returns the attributes associated to the toplevel type, without adding attributes from compinfo, enuminfo or typeinfo. Use {!Cil.typeAttrs} to retrieve the complete set of attributes. *) end (** Types, with comparison over struct done by name and no unrolling. *) module TypByName: S_with_collections_pretty with type t = typ (** Types, with comparison over struct done by key and no unrolling @since Fluorine-20130401 *) module TypNoUnroll: S_with_collections_pretty with type t = typ module Typeinfo: S_with_collections with type t = typeinfo module Varinfo_Id: Hptmap.Id_Datatype (** @plugin development guide *) module Varinfo: sig include S_with_collections_pretty with type t = varinfo module Hptset: sig include Hptset.S with type elt = varinfo and type 'a shape = 'a Hptmap.Shape(Varinfo_Id).t val self: State.t end val dummy: t (**/**) 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_pretty with type t = code_annotation val loc: t -> location option end module Funbehavior: S with type t = funbehavior module Funspec: S_with_pretty with type t = funspec (** @since Fluorine-20130401 *) module Fundec: S_with_collections with type t = fundec module Global_annotation: sig include S_with_collections_pretty with type t = global_annotation val loc: t -> location val attr: t -> attributes (** attributes tied to the global annotation. @since Phosphorus-20170501-beta1 *) 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_pretty with type t = logic_label (** Logic_type. See the various [Typ*] modules for the distinction between those modules *) module Logic_type: S_with_collections_pretty with type t = logic_type module Logic_type_ByName: S_with_collections_pretty with type t = logic_type module Logic_type_NoUnroll: S_with_collections_pretty with type t = logic_type module Logic_type_info: S_with_collections with type t = logic_type_info module Logic_var: S_with_collections_pretty with type t = logic_var (** @since Oxygen-20120901 *) module Model_info: S_with_collections_pretty with type t = model_info module Term: S_with_collections_pretty with type t = term module Term_lhost: S_with_collections with type t = term_lhost module Term_offset: S_with_collections_pretty with type t = term_offset module Term_lval: S_with_collections_pretty with type t = term_lval module Predicate: S_with_pretty with type t = predicate module Identified_predicate: S_with_collections_pretty with type t = identified_predicate (** @since Neon-20140301 *) (**************************************************************************) (** {3 Logic_ptree} Sorted by alphabetic order. *) (**************************************************************************) module Lexpr: S with type t = Logic_ptree.lexpr (**/**) (* ****************************************************************************) (** {2 Internal API} *) (* ****************************************************************************) (* Forward declarations from Cil *) val drop_non_logic_attributes : (attributes -> attributes) ref val constfoldtoint : (exp -> Integer.t option) ref val punrollType: (typ -> typ) ref (**/**) val clear_caches: unit -> unit (**/**) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_queries/logic_const.ml0000644000175000017500000003416513113745007025534 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* 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 } let fresh_predicate_id = PredicateId.next let pred_of_id_pred p = 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; (* no need to refresh b_extended, it contains only named predicates. *) } 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 _ | AExtended _ 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 init_label = LogicLabel (None, "Init") 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} *) let is_list_type = function | Ltype ({lt_name = "\\list"},[_]) -> true | _ -> false (** returns the type of elements of a list type. @raise Failure if the input type is not a list type. *) let type_of_list_elem ty = match ty with | Ltype ({lt_name = "\\list"},[t]) -> t | _ -> failwith "not a list type" (** build the type list of [ty]. *) let make_type_list_of ty = Ltype(Logic_env.find_logic_type "\\list",[ty]) let is_set_type = function | Ltype ({lt_name = "set"},[_]) -> true | _ -> false (** [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 = if is_set_type ty then ty else Ltype(Logic_env.find_logic_type "set",[ty]) (** 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 let boolean_type = Ltype ({ lt_name = Utf8_logic.boolean ; lt_params = [] ; lt_def = None; lt_attr = [] } , []) (** {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=Cil_datatype.Location.unknown) term typ = { term_node = term; term_type = typ; term_name = []; term_loc = loc } let taddrof ?(loc=Cil_datatype.Location.unknown) lv typ = match lv with | TMem h, TNoOffset -> h | _ -> term ~loc (TAddrOf lv) typ (** range of integers *) let trange ?(loc=Cil_datatype.Location.unknown) (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 tstring ?(loc=Cil_datatype.Location.unknown) s = (* Cannot refer to Cil.charConstPtrType in this module... *) let typ = TPtr(TInt(IChar, [Attr("const", [])]),[]) in term ~loc (TConst (LStr s)) (Ctype typ) 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 tlogic_coerce ?(loc=Cil_datatype.Location.unknown) t lt = term ~loc (TLogic_coerce (lt, t)) lt 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 = {pred_content = p ; pred_loc = loc; pred_name = [] } let ptrue = unamed Ptrue let pfalse = unamed Pfalse let pold ?(loc=Cil_datatype.Location.unknown) p = match p.pred_content with | Ptrue | Pfalse -> p | _ -> {p with pred_content = Pat(p, old_label); pred_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.pred_content, p2.pred_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.pred_content, p2.pred_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.pred_content, p2.pred_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.pred_content with | Ptrue -> {p2 with pred_content = Pfalse; pred_loc = loc } | Pfalse -> {p2 with pred_content = Ptrue; pred_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) v p = match p.pred_content with | Ptrue -> p | _ -> unamed ~loc (Plet (v, p)) let pimplies ?(loc=Cil_datatype.Location.unknown) (p1,p2) = match p1.pred_content, p2.pred_content with | Ptrue, _ | _, Ptrue -> p2 | Pfalse, _ -> { pred_name = p1.pred_name; pred_loc = loc; pred_content = Ptrue } | _, _ -> unamed ~loc (Pimplies (p1, p2)) let pif ?(loc=Cil_datatype.Location.unknown) (t,p2,p3) = match (p2.pred_content, p3.pred_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.pred_content, p3.pred_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.pred_content with | Ptrue -> p | _ -> unamed ~loc (Pforall (l,p)) let pexists ?(loc=Cil_datatype.Location.unknown) (l,p) = match l with | [] -> p | _ :: _ -> match p.pred_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 ?(loc=Cil_datatype.Location.unknown) (l,p) = unamed ~loc (Pvalid (l,p)) let pvalid_read ?(loc=Cil_datatype.Location.unknown) (l,p) = unamed ~loc (Pvalid_read (l,p)) let pvalid_function ?(loc=Cil_datatype.Location.unknown) p = unamed ~loc (Pvalid_function 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 pdangling ?(loc=Cil_datatype.Location.unknown) (l,p) = unamed ~loc (Pdangling (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-Phosphorus-20170501/src/kernel_services/ast_queries/logic_typing.mli0000644000175000017500000002370613113745007026070 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* 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. *) open Cil_types (** Relation operators conversion @since Nitrogen-20111001 *) val type_rel: Logic_ptree.relation -> Cil_types.relation (** Arithmetic binop conversion. Addition and Subtraction 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 (** @since Aluminium-20160501 *) val is_list_type: Cil_types.logic_type -> bool (** @since Aluminium-20160501 *) val type_of_list_elem : logic_type -> logic_type 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 (** @deprecated Neon-20130301 use Logic_const.addTermOffsetLval instead *) 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 type type_namespace = Typedef | Struct | Union | Enum (** The different namespaces a C type can belong to, used when we are searching a type by its name. *) module Type_namespace: Datatype.S with type t = type_namespace (** 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_field: compinfo -> string -> offset; find_type : type_namespace -> 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; (**/**) silent: bool; (**/**) type_predicate: typing_context -> Lenv.t -> Logic_ptree.lexpr -> predicate; (** typechecks a predicate. Note that the first argument is itself a [typing_context], which allows for open recursion. Namely, it is possible for the extension to change the type-checking functions for the sub-nodes of the parsed tree, and not only for the toplevel [lexpr]. @plugin development guide *) type_term: typing_context -> Lenv.t -> Logic_ptree.lexpr -> term; type_assigns: typing_context -> accept_formal:bool -> Lenv.t -> Logic_ptree.lexpr assigns -> identified_term assigns; error: 'a 'b. location -> ('a,Format.formatter,unit,'b) format4 -> 'a; } (** [register_behavior_extension name f] registers a typing function [f] to be used to type clause with name [name]. Here is a basic example: let count = ref 0 in let foo_typer ~typing_context ~loc ps = match ps with p::[] -> Ext_preds [ (typing_context.type_predicate typing_context (typing_context.post_state [Normal]) p)]) | [] -> let id = !count in incr count; Ext_id id | _ -> typing_context.error loc "expecting a predicate after keyword FOO" let () = register_behavior_extension "FOO" foo_typer @plugin development guide @since Carbon-20101201 @modify Silicon-20161101 change type of the function *) val register_behavior_extension: string -> (typing_context:typing_context -> loc:location -> Logic_ptree.lexpr list -> acsl_extension_kind) -> unit module Make (C : sig val is_loop: unit -> bool (** whether the annotation we want to type is contained in a loop. Only useful when creating objects of type [code_annotation]. *) 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_type : type_namespace -> string -> typ val find_comp_field: compinfo -> string -> offset 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 (** raises an error at the given location and with the given message. @since Magnesium-20151001 *) val error: location -> ('a,Format.formatter,unit, 'b) format4 -> 'a 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 (** [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 (** appends the "Init" label in the environment @since Sodium-20150201 *) val append_init_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: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_queries/cil_const.ml0000644000175000017500000001212313113745012025170 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; lv_attr = [] } 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-Phosphorus-20170501/src/kernel_services/ast_queries/ast_info.ml0000644000175000017500000003626213113745007025033 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 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 unguarded 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 unguarded then (* Looks first at unguarded behaviors. *) let unguarded_bhvs = List.filter (fun b -> b.b_assumes = []) bhvs in merge_assigns_internal (* Chooses the smallest 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 smallest 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 unguarded 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 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 exception FoundBlock of block let block_of_local (fdec:fundec) vi = let find_in_block bl = if is_block_local vi bl then raise (FoundBlock bl) in let find_in_stmt stmt = match stmt.skind with | Block b | Switch (_, b, _, _) | Loop (_, b, _, _, _) -> find_in_block b | If (_, be, bt, _) -> find_in_block be; find_in_block bt | TryExcept (b1, _, b2, _) | TryFinally (b1, b2, _) -> find_in_block b1; find_in_block b2 | TryCatch (b, l, _) -> find_in_block b; let aux (cb, b) = find_in_block b; match cb with | Catch_all -> () | Catch_exn (vi', _l) -> (* note: vars in [_l] (related to exception subtyping) are generated and never pretty-printed, so need not be compared *) if Cil_datatype.Varinfo.equal vi vi' then raise (FoundBlock b) in List.iter aux l | _ -> () in try find_in_block fdec.sbody; List.iter find_in_stmt fdec.sallstmts; Kernel.abort "[local_declaration_block]: block not found for %a in %a" Cil_datatype.Varinfo.pretty vi Cil_datatype.Varinfo.pretty fdec.svar with FoundBlock bl-> bl (* ************************************************************************** *) (** {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 >= 6 && name.[0] = 'F' && name.[1] = 'r' && name.[2] = 'a' && name.[3] = 'm' && name.[4] = 'a' && name.[5] = '_') let is_cea_function name = Extlib.string_prefix "Frama_C_show_each" name let is_cea_dump_function name = (name = "Frama_C_dump_each") let is_cea_dump_file_function name = Extlib.string_prefix "Frama_C_dump_each_file" name 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-Phosphorus-20170501/src/kernel_services/ast_queries/cil_state_builder.mli0000644000175000017500000000563713113745001027053 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 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 Exp_hashtbl(Data:Datatype.S)(Info: State_builder.Info_with_size) : State_builder.Hashtbl with type key = Cil_types.exp and type data = Data.t module Kernel_function_hashtbl (Data:Datatype.S)(Info: State_builder.Info_with_size): State_builder.Hashtbl with type key = Cil_types.kernel_function 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: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_queries/ast_info.mli0000644000175000017500000002021513113745007025173 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. *) 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 precondition : funspec -> predicate (** Builds the precondition from [b_assumes] and [b_requires] clauses. @since Carbon-20101201 *) val behavior_assumes : funbehavior -> predicate (** Builds the conjunction of the [b_assumes]. @since Nitrogen-20111001 *) val behavior_precondition : funbehavior -> predicate (** Builds the precondition from [b_assumes] and [b_requires] clauses. @since Carbon-20101201 *) val behavior_postcondition : funbehavior -> termination_kind -> predicate (** 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 (** Builds the [disjoint_behaviors] property for the behavior names. @since Nitrogen-20111001 *) val complete_behaviors : funspec -> string list -> predicate (** Builds the [disjoint_behaviors] property for the behavior names. @since Nitrogen-20111001 *) val merge_assigns_from_complete_bhvs: ?warn:bool -> ?unguarded:bool -> funbehavior list -> string list list -> identified_term assigns (** @return the assigns of an unguarded behavior (when [unguarded]=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 emitting 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 emitting 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 emitting 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 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 val block_of_local: fundec -> varinfo -> block (** [local_block f vi] returns the block of [f] in which [vi] is declared. [vi] must be a variable of [f]. *) (* ************************************************************************** *) (** {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-Phosphorus-20170501/src/kernel_services/ast_queries/cil_const.mli0000644000175000017500000001303313113745011025341 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-Phosphorus-20170501/src/kernel_services/ast_queries/cil_state_builder.ml0000644000175000017500000000405713113745007026703 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 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 Exp_hashtbl = Hashtbl(Exp.Hashtbl) module Kernel_function_hashtbl = Hashtbl(Kf.Hashtbl) (* module Code_annotation_hashtbl = State_builder.Hashtbl(Cil_datatype.Code_Annotation) *) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_queries/logic_env.mli0000644000175000017500000001511013113745005025332 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* 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-Phosphorus-20170501/src/kernel_services/ast_queries/logic_utils.ml0000644000175000017500000026274113113745003025545 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* 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 exception Not_well_formed of Cil_types.location * string 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 let is_instance_of vars t1 t2 = let rec aux map t1 t2 = match (unroll_type t1, unroll_type t2) with | _, Lvar s when List.mem s vars -> if Datatype.String.Map.mem s map then Cil_datatype.Logic_type.equal t1 (Datatype.String.Map.find s map), map else true, Datatype.String.Map.add s t1 map | Ltype(ty1,prms1), Ltype(ty2,prms2) -> if Cil_datatype.Logic_type_info.equal ty1 ty2 then aux_list map prms1 prms2 else false, map | Larrow(args1,rt1), Larrow(args2,rt2) -> let flag,map as res = aux map rt1 rt2 in if flag then aux_list map args1 args2 else res | Ctype t1, Ctype t2 -> Cil_datatype.Typ.equal (Cil.typeDeepDropAllAttributes t1) (Cil.typeDeepDropAllAttributes t2), map | (Lvar _ | Ctype _ | Linteger | Lreal | Ltype _ | Larrow _), _ -> Cil_datatype.Logic_type.equal t1 t2, map and aux_list map l1 l2 = match l1, l2 with | [], [] -> true, map | [], _ | _, [] -> false, map | t1 :: tl1, t2 :: tl2 -> let flag, map as res = aux map t1 t2 in if flag then aux_list map tl1 tl2 else res in fst (aux Datatype.String.Map.empty t1 t2) (* ************************************************************************* *) (** {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 predicate_of_identified_predicate ip = 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.pred_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_node = 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.visitCilPredicate 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" (* Make an AddrOf. Given an lval of type T will give back an expression of * type ptr(T) *) let mk_logic_AddrOf ?(loc=Cil_datatype.Location.unknown) lval typ = match lval with | TMem e, TNoOffset -> Logic_const.term ~loc e.term_node e.term_type | b, TIndex(z, TNoOffset) when isLogicZero z -> Logic_const.term ~loc (TStartOf (b, TNoOffset)) (Ctype (TPtr (logicCType typ,[]))) (* array *) | _ -> Logic_const.term ~loc (TAddrOf lval) (Ctype (TPtr (logicCType typ,[]))) 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) ?(force=false) 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) && not force 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', t'.term_node 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' | _, TConst (Integer (i,_)) when Integer.is_zero i -> mk_cast 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 = Transitioning.String.uppercase_ascii (String.sub str (l - ls) ls) in (* Maybe it ends in U or UL. Strip those *) let baseint, kind = if hasSuffix "L" || hasSuffix "l" then String.sub str 0 (l - 1), Some FLongDouble else if hasSuffix "F" || hasSuffix "f" then String.sub str 0 (l - 1), Some FFloat else if hasSuffix "D" || hasSuffix "d" then String.sub str 0 (l - 1), Some FDouble else str, None in match kind with | Some k -> let f = Floating_point.parse_kind k 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 numeric_coerce ltyp t = let coerce t = Logic_const.term ~loc:t.term_loc (TLogic_coerce(ltyp, t)) ltyp in let oldt = unroll_type t.term_type in if Cil_datatype.Logic_type.equal oldt ltyp then t else match t.term_node with | TLogic_coerce(_,e) -> coerce e | TConst(Integer(i,_)) -> (match oldt, ltyp with | Ctype (TInt(ikind,_)), Linteger when Cil.fitsInInt ikind i -> { t with term_type = Linteger } | _ -> coerce t) | TCastE(typ, ({ term_node = TConst(Integer(i,_))} as t')) -> (match unrollType typ with | TInt (ikind,_) when Cil.fitsInInt ikind i -> (match unroll_type t'.term_type with | Linteger -> t' | Ctype (TInt (ikind,_)) when Cil.fitsInInt ikind i -> { t' with term_type = Linteger } | _ -> coerce t') | _ -> coerce t) | _ -> coerce t 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 l' = expr_to_term_coerce ~cast l in let r' = expr_to_term_coerce ~cast r in (* type of the conversion of e in the logic. Beware that boolean operators have boolean type. *) let tcast = match op, cast with | ( Cil_types.Lt | Cil_types.Gt | Cil_types.Le | Cil_types.Ge | Cil_types.Eq | Cil_types.Ne| Cil_types.LAnd | Cil_types.LOr), _ -> Some Logic_const.boolean_type | _, true -> Some (typ_to_logic_type e_typ) | _, false -> None in let tnode = TBinOp (op,l',r') in (* if [cast], we add a cast. Otherwise, when [op] is an operator returning a boolean, we need to cast the whole expression as an integral type, because (1) the recursive subcalls expect an integer/float/pointer here, and (2) there is no implicit conversion Boolean -> integer. *) begin match tcast with | Some lt -> (mk_cast e_typ (Logic_const.term tnode lt)).term_node | None -> tnode end | UnOp (op, u, _) -> let u' = expr_to_term_coerce ~cast u in (* See comments for binop case above. *) let tcast = match op, cast with | Cil_types.LNot, _ -> Some Logic_const.boolean_type | _, true -> Some (typ_to_logic_type e_typ) | _, false -> None in let tnode = TUnOp (op, u') in begin match tcast with | Some lt -> (mk_cast e_typ (Logic_const.term tnode lt)).term_node | None -> tnode end | 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 _ | Lval _ | CastE _ -> (* all immediate values keep their C type by default, and are only lifted to integer/real if needed. *) Logic_const.term ~loc result (Ctype e_typ) | _ -> Logic_const.term ~loc result (typ_to_logic_type e_typ) and expr_to_term_coerce ~cast e = let t = expr_to_term ~cast e in match t.term_type with | Ctype typ when Cil.isIntegralType typ || Cil.isFloatingType typ -> let ltyp = typ_to_logic_type typ in numeric_coerce ltyp t | _ -> t 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) (*no need of numeric coercion - pointer *) and offset_to_term_offset ~cast:cast = function | NoOffset -> TNoOffset | Index (e,off) -> TIndex (expr_to_term_coerce ~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 occurrence 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.pred_content with Pfalse -> true | _ -> false let is_trivially_true p = match p.pred_content with Ptrue -> true | _ -> false let rec add_attribute_glob_annot a g = match g with | Dfun_or_pred ({ l_var_info },_) | Dinvariant({ l_var_info }, _) | Dtype_annot ( { l_var_info }, _) -> l_var_info.lv_attr <- Cil.addAttribute a l_var_info.lv_attr; g | Dvolatile(v,r,w,al,l) -> Dvolatile(v,r,w,Cil.addAttribute a al,l) | Daxiomatic(n,l,al,loc) -> Daxiomatic(n,List.map (add_attribute_glob_annot a) l, Cil.addAttribute a al,loc) | Dtype(ti,_) -> ti.lt_attr <- Cil.addAttribute a ti.lt_attr; g | Dlemma(n,ax,labs,t,p,al,l) -> Dlemma(n,ax,labs,t,p,Cil.addAttribute a al,l) | Dmodel_annot (mi,_) -> mi.mi_attr <- Cil.addAttribute a mi.mi_attr; g | Dcustom_annot(c,n,al,l) -> Dcustom_annot(c,n,Cil.addAttribute a al, l) 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 (* same remark as above *) let compare_logic_label l1 l2 = match l1, l2 with | StmtLabel s1, StmtLabel s2 -> Cil_datatype.Stmt.compare !s1 !s2 | StmtLabel _, LogicLabel _ -> 1 | LogicLabel _, StmtLabel _ -> -1 | LogicLabel (_,l1), LogicLabel(_,l2) -> String.compare 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 compare_opt f x1 x2 = match x1, x2 with | None, None -> 0 | Some _, None -> 1 | None, Some _ -> -1 | Some x1, Some x2 -> f x1 x2 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_string (s1: string) s2 = s1 = s2 let is_same_c_unop (u1: unop) u2 = u1 = u2 let is_same_c_binop (b1: binop) b2 = b1 = b2 let rec is_same_attrparam p1 p2 = match p1,p2 with | AInt i1, AInt i2 -> Integer.equal i1 i2 | AStr s1, AStr s2 -> is_same_string s1 s2 | ACons (s1, p1), ACons (s2, p2) -> is_same_string s1 s2 && is_same_list is_same_attrparam p1 p2 | ASizeOf t1, ASizeOf t2 -> is_same_c_type t1 t2 | ASizeOfE p1, ASizeOfE p2 -> is_same_attrparam p1 p2 | AAlignOf t1, AAlignOf t2 -> is_same_c_type t1 t2 | AAlignOfE p1, AAlignOfE p2 -> is_same_attrparam p1 p2 | AUnOp(u1,p1), AUnOp(u2,p2) -> is_same_c_unop u1 u2 && is_same_attrparam p1 p2 | ABinOp(b1,l1,r1), ABinOp(b2,l2,r2) -> is_same_c_binop b1 b2 && is_same_attrparam l1 l2 && is_same_attrparam r1 r2 | ADot(p1,f1), ADot(p2,f2) -> is_same_string f1 f2 && is_same_attrparam p1 p2 | AStar p1, AStar p2 -> is_same_attrparam p1 p2 | AAddrOf p1, AAddrOf p2 -> is_same_attrparam p1 p2 | AIndex(a1,i1), AIndex(a2,i2) -> is_same_attrparam a1 a2 && is_same_attrparam i1 i2 | AQuestion(q1,t1,e1), AQuestion(q2,t2,e2) -> is_same_attrparam q1 q2 && is_same_attrparam t1 t2 && is_same_attrparam e1 e2 | _ -> false let is_same_attribute a1 a2 = match a1,a2 with | Attr (s1,prm1), Attr (s2,prm2) -> is_same_string s1 s2 && is_same_list is_same_attrparam prm1 prm2 | AttrAnnot s1, AttrAnnot s2 -> is_same_string s1 s2 | _ -> false let is_same_attributes l1 l2 = is_same_list is_same_attribute l1 l2 let is_same_var v1 v2 = v1.lv_name = v2.lv_name && is_same_type v1.lv_type v2.lv_type && is_same_attributes v1.lv_attr v2.lv_attr let compare_var v1 v2 = let res = String.compare v1.lv_name v2.lv_name in if res = 0 then Cil_datatype.Logic_type_ByName.compare v1.lv_type v2.lv_type else res 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 compare_logic_signature l1 l2 = let res = String.compare l1.l_var_info.lv_name l2.l_var_info.lv_name in if res = 0 then let res = compare_opt Cil_datatype.Logic_type_ByName.compare l1.l_type l2.l_type in if res = 0 then let res = Extlib.list_compare String.compare l1.l_tparams l2.l_tparams in if res = 0 then let res = Extlib.list_compare compare_var l1.l_profile l2.l_profile in if res = 0 then Extlib.list_compare compare_logic_label l1.l_labels l2.l_labels else res else res else res else res 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 compare_logic_ctor_info ci1 ci2 = let res = String.compare ci1.ctor_name ci2.ctor_name in if res = 0 then let res = String.compare ci1.ctor_type.lt_name ci2.ctor_type.lt_name in if res = 0 then Extlib.list_compare Cil_datatype.Logic_type_ByName.compare ci1.ctor_params ci2.ctor_params else res else res let is_same_constant = Cil.compareConstant let is_same_pconstant c1 c2 = let open Logic_ptree in 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 constFoldToInt e1.eival, constFoldToInt 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_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_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_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_node 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_predicate lp1 lp2 && is_same_predicate rp1 rp2 | Pnot p1, Pnot p2 -> is_same_predicate p1 p2 | Pif (c1,t1,e1), Pif(c2,t2,e2) -> is_same_term c1 c2 && is_same_predicate t1 t2 && is_same_predicate e1 e2 | Plet (d1,p1), Plet(d2,p2) -> is_same_logic_info d1 d2 && is_same_predicate p1 p2 | Pforall(q1,p1), Pforall(q2,p2) -> is_same_list is_same_var q1 q2 && is_same_predicate p1 p2 | Pexists(q1,p1), Pexists(q2,p2) -> is_same_list is_same_var q1 q2 && is_same_predicate p1 p2 | Pat(p1,l1), Pat(p2,l2) -> is_same_logic_label l1 l2 && is_same_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 | Pvalid_function t1, Pvalid_function t2 -> is_same_term t1 t2 | Pdangling (l1,t1), Pdangling (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 _ | Pvalid_function _ | Pinitialized _ | Pdangling _ | Pfresh _ | Pallocable _ | Pfreeable _ | Psubtype _ | Pxor _ | Pseparated _ ), _ -> false and is_same_predicate pred1 pred2 = is_same_list Datatype.String.equal pred1.pred_name pred2.pred_name && is_same_predicate_node pred1.pred_content pred2.pred_content and is_same_identified_predicate p1 p2 = 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_attributes t1.lt_attr t2.lt_attr && 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_extension (e1, c1) (e2, c2) = Datatype.String.equal e1 e2 && match c1, c2 with | Ext_id i1, Ext_id i2 -> i1 = i2 | Ext_terms t1, Ext_terms t2 -> is_same_list is_same_term t1 t2 | Ext_preds p1, Ext_preds p2 -> is_same_list is_same_predicate p1 p2 | (Ext_id _ | Ext_preds _ | Ext_terms _), _ -> false let is_same_code_annotation (ca1:code_annotation) (ca2:code_annotation) = match ca1.annot_content, ca2.annot_content with | AAssert(l1,p1), AAssert(l2,p2) -> is_same_list (=) l1 l2 && is_same_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_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 | AExtended (l1,e1), AExtended(l2,e2) -> is_same_list (=) l1 l2 && is_same_extension e1 e2 | (AAssert _ | AStmtSpec _ | AInvariant _ | AExtended _ | 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 && is_same_attributes mi1.mi_attr mi2.mi_attr 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,attr1,_), Daxiomatic (id2,ga2,attr2,_) -> id1 = id2 && is_same_list is_same_global_annotation ga1 ga2 && is_same_attributes attr1 attr2 | Dtype (t1,_), Dtype (t2,_) -> is_same_logic_type_info t1 t2 | Dlemma(n1,ax1,labs1,typs1,st1,attr1,_), Dlemma(n2,ax2,labs2,typs2,st2,attr2,_) -> is_same_string n1 n2 && ax1 = ax2 && is_same_list is_same_logic_label labs1 labs2 && is_same_list (=) typs1 typs2 && is_same_predicate st1 st2 && is_same_attributes attr1 attr2 | 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, attr1, _), Dcustom_annot (c2, n2, attr2, _) -> is_same_string n1 n2 && c1 = c2 && is_same_attributes attr1 attr2 | Dvolatile(t1,r1,w1,attr1,_), Dvolatile(t2,r2,w2,attr2,_) -> 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 && is_same_attributes attr1 attr2 | (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 = let open Logic_ptree in 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 = let open Logic_ptree in 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 | LTattribute(t1,attr1), LTattribute(t2,attr2) -> is_same_pl_type t1 t2 && attr1 = attr2 | (LTvoid | LTinteger | LTreal | LTint _ | LTfloat _ | LTarrow _ | LTarray _ | LTpointer _ | LTenum _ | LTunion _ | LTnamed _ | LTstruct _ | LTattribute _),_ -> 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 = let open Logic_ptree in 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 = let open Logic_ptree in 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 = let open Logic_ptree in 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 = let open Logic_ptree in 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 = let open Logic_ptree in 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 = let open Logic_ptree in 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 | PLlist l1, PLlist l2 -> is_same_list is_same_lexpr l1 l2 | 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 | PLrepeat (l1, r1), PLrepeat (l2,r2) | 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 | PLvalid_function e1, PLvalid_function e2 -> is_same_lexpr e1 e2 | PLdangling (l1,e1), PLdangling (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 | PLset l1, PLset l2 | 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 _ | PLlist _ | PLrepeat _ | 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 _ | PLvalid_function _ | PLfreeable _ | PLallocable _ | PLinitialized _ | PLdangling _ | PLseparated _ | PLfresh _ | PLnamed _ | PLsubtype _ | PLcomprehension _ | PLunion _ | PLinter _ | PLset _ | 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 rec compare_term t1 t2 = match t1.term_node, t2.term_node with TConst c1, TConst c2 -> Cil_datatype.Logic_constant.compare c1 c2 | TConst _, _ -> 1 | _,TConst _ -> -1 | TLval l1, TLval l2 -> compare_tlval l1 l2 | TLval _, _ -> 1 | _, TLval _ -> -1 | TSizeOf t1, TSizeOf t2 -> Cil_datatype.TypByName.compare t1 t2 | TSizeOf _, _ -> 1 | _, TSizeOf _ -> -1 | TSizeOfE t1, TSizeOfE t2 -> compare_term t1 t2 | TSizeOfE _, _ -> 1 | _, TSizeOfE _ -> -1 | TSizeOfStr s1, TSizeOfStr s2 -> String.compare s1 s2 | TSizeOfStr _, _ -> 1 | _, TSizeOfStr _ -> -1 | TAlignOf t1, TAlignOf t2 -> Cil_datatype.TypByName.compare t1 t2 | TAlignOf _, _ -> 1 | _, TAlignOf _ -> -1 | TAlignOfE t1, TAlignOfE t2 -> compare_term t1 t2 | TAlignOfE _, _ -> 1 | _, TAlignOfE _ -> -1 | TUnOp (o1,t1), TUnOp(o2,t2) -> let res = Pervasives.compare o1 o2 in if res = 0 then compare_term t1 t2 else res | TUnOp _, _ -> 1 | _, TUnOp _ -> -1 | TBinOp(o1,l1,r1), TBinOp(o2,l2,r2) -> let res = Pervasives.compare o1 o2 in if res = 0 then let res = compare_term l1 l2 in if res = 0 then compare_term r1 r2 else res else res | TBinOp _, _ -> 1 | _, TBinOp _ -> -1 | TCastE(typ1,t1), TCastE(typ2,t2) -> let res = Cil_datatype.TypByName.compare typ1 typ2 in if res = 0 then compare_term t1 t2 else res | TCastE _, _ -> 1 | _, TCastE _ -> -1 | TAddrOf l1, TAddrOf l2 -> compare_tlval l1 l2 | TAddrOf _, _ -> 1 | _, TAddrOf _ -> -1 | TStartOf l1, TStartOf l2 -> compare_tlval l1 l2 | TStartOf _, _ -> 1 | _, TStartOf _ -> -1 | Tapp(f1,labels1, args1), Tapp(f2, labels2, args2) -> let res = compare_logic_signature f1 f2 in if res = 0 then let compare_labels (x,y) (t,z) = let res = compare_logic_label x t in if res = 0 then compare_logic_label y z else res in let res = Extlib.list_compare compare_labels labels1 labels2 in if res = 0 then Extlib.list_compare compare_term args1 args2 else res else res | Tapp _, _ -> 1 | _, Tapp _ -> -1 | Tif(c1,t1,e1), Tif(c2,t2,e2) -> let res = compare_term c1 c2 in if res = 0 then let res = compare_term t1 t2 in if res = 0 then compare_term e1 e2 else res else res | Tif _, _ -> 1 | _, Tif _ -> -1 | 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 res = compare_logic_label l1 l2 in if res = 0 then compare_term t1 t2 else res | Tbase_addr _, _ -> 1 | _, Tbase_addr _ -> -1 | Tblock_length _, _ -> 1 | _, Tblock_length _ -> -1 | Toffset _, _ -> 1 | _, Toffset _ -> -1 | Tat _, _ -> 1 | _, Tat _ -> -1 | Tnull, Tnull -> 0 | Tnull, _ -> 1 | _, Tnull -> -1 | TCoerce(t1,typ1), TCoerce(t2,typ2) -> let res = compare_term t1 t2 in if res = 0 then Cil_datatype.TypByName.compare typ1 typ2 else res | TCoerce _, _ -> 1 | _, TCoerce _ -> -1 | TCoerceE(t1,tt1), TCoerceE(t2,tt2) -> let res = compare_term t1 t2 in if res = 0 then compare_term tt1 tt2 else res | TCoerceE _, _ -> 1 | _, TCoerceE _ -> -1 | Tlambda (v1,t1), Tlambda(v2,t2) -> let res = Extlib.list_compare compare_var v1 v2 in if res = 0 then compare_term t1 t2 else res | Tlambda _, _ -> 1 | _, Tlambda _ -> -1 | TUpdate(t1,i1,nt1), TUpdate(t2,i2,nt2) -> let res = compare_term t1 t2 in if res = 0 then let res = compare_offset i1 i2 in if res = 0 then compare_term nt1 nt2 else res else res | TUpdate _, _ -> 1 | _, TUpdate _ -> -1 | Ttypeof t1, Ttypeof t2 -> compare_term t1 t2 | Ttypeof _, _ -> 1 | _, Ttypeof _ -> -1 | Ttype ty1, Ttype ty2 -> Cil_datatype.TypByName.compare ty1 ty2 | Ttype _, _ -> 1 | _, Ttype _ -> -1 | TDataCons(ci1,prms1), TDataCons(ci2,prms2) -> let res = compare_logic_ctor_info ci1 ci2 in if res = 0 then Extlib.list_compare compare_term prms1 prms2 else res | TDataCons _, _ -> 1 | _, TDataCons _ -> -1 | Tempty_set, Tempty_set -> 0 | Tempty_set, _ -> 1 | _, Tempty_set -> -1 | (Tunion l1, Tunion l2) | (Tinter l1, Tinter l2) -> Extlib.list_compare compare_term l1 l2 | Tunion _, _ -> 1 | _, Tunion _ -> -1 | Tinter _, _ -> 1 | _, Tinter _ -> -1 | Tcomprehension(e1,q1,p1), Tcomprehension(e2,q2,p2) -> let res = compare_term e1 e2 in if res = 0 then let res = Extlib.list_compare compare_var q1 q2 in if res = 0 then compare_opt compare_predicate p1 p2 else res else res | Tcomprehension _, _ -> 1 | _, Tcomprehension _ -> -1 | Trange(l1,h1), Trange(l2,h2) -> let res = compare_opt compare_term l1 l2 in if res = 0 then compare_opt compare_term h1 h2 else res | Trange _, _ -> 1 | _, Trange _ -> -1 | Tlet(d1,b1), Tlet(d2,b2) -> let res = compare_logic_info d1 d2 in if res = 0 then compare_term b1 b2 else res | Tlet _, _ -> 1 | _, Tlet _ -> -1 | TLogic_coerce(ty1,t1), TLogic_coerce(ty2,t2) -> let res = Cil_datatype.Logic_type_ByName.compare ty1 ty2 in if res = 0 then compare_term t1 t2 else res and compare_logic_info l1 l2 = let res = compare_logic_signature l1 l2 in if res = 0 then compare_logic_body l1.l_body l2.l_body else res and compare_logic_body b1 b2 = match b1,b2 with | LBnone, LBnone -> 0 | LBnone, _ -> 1 | _, LBnone -> -1 | LBreads l1, LBreads l2 -> Extlib.list_compare compare_identified_term l1 l2 | LBreads _, _ -> 1 | _, LBreads _ -> -1 | LBterm t1, LBterm t2 -> compare_term t1 t2 | LBterm _, _ -> 1 | _, LBterm _ -> -1 | LBpred p1, LBpred p2 -> compare_predicate p1 p2 | LBpred _, _ -> 1 | _, LBpred _ -> -1 | LBinductive l1, LBinductive l2 -> Extlib.list_compare compare_indcase l1 l2 and compare_indcase (id1,labs1,typs1,p1) (id2,labs2,typs2,p2) = let res = String.compare id1 id2 in if res = 0 then let res = Extlib.list_compare compare_logic_label labs1 labs2 in if res = 0 then let res = Extlib.list_compare String.compare typs1 typs2 in if res = 0 then compare_predicate p1 p2 else res else res else res and compare_tlval (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 | TVar v1, TVar v2 -> compare_var v1 v2 | TVar _, _ -> 1 | _, TVar _ -> -1 | TMem t1, TMem t2 -> compare_term t1 t2 | TMem _, _ -> 1 | _, TMem _ -> -1 | TResult t1, TResult t2 -> Cil_datatype.TypByName.compare t1 t2 and compare_offset o1 o2 = match o1, o2 with | TNoOffset, TNoOffset -> 0 | TNoOffset, _ -> 1 | _, TNoOffset -> -1 | TField (f1,o1), TField(f2,o2) -> let res = String.compare f1.fname f2.fname in if res = 0 then compare_offset o1 o2 else res | TField _, _ -> 1 | _, TField _ -> -1 | TModel(f1,o1), TModel(f2,o2) -> let res = String.compare f1.mi_name f2.mi_name in if res = 0 then compare_offset o1 o2 else res | TModel _, _ -> 1 | _, TModel _ -> -1 | TIndex(t1,o1), TIndex(t2,o2) -> let res = compare_term t1 t2 in if res = 0 then compare_offset o1 o2 else res and compare_predicate_node p1 p2 = match p1, p2 with | Pfalse, Pfalse -> 0 | Pfalse, _ -> 1 | _, Pfalse -> -1 | Ptrue, Ptrue -> 0 | Ptrue, _ -> 1 | _, Ptrue -> -1 | Papp(i1,labels1,args1), Papp(i2,labels2,args2) -> let res = compare_logic_signature i1 i2 in if res = 0 then let compare_labels (x,y) (z,t) = let res = compare_logic_label x z in if res = 0 then compare_logic_label y t else res in let res = Extlib.list_compare compare_labels labels1 labels2 in if res = 0 then Extlib.list_compare compare_term args1 args2 else res else res | Papp _, _ -> 1 | _, Papp _ -> -1 | Prel(r1,lt1,rt1), Prel(r2,lt2,rt2) -> let res = Pervasives.compare r1 r2 in if res = 0 then let res = compare_term lt1 lt2 in if res = 0 then compare_term rt1 rt2 else res else res | Prel _, _ -> 1 | _, Prel _ -> -1 | 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) -> let res = compare_predicate lp1 lp2 in if res = 0 then compare_predicate rp1 rp2 else res | Pand _, _ -> 1 | _, Pand _ -> -1 | Por _, _ -> 1 | _, Por _ -> -1 | Pxor _, _ -> 1 | _, Pxor _ -> -1 | Pimplies _, _ -> 1 | _, Pimplies _ -> -1 | Piff _, _ -> 1 | _, Piff _ -> -1 | Pnot p1, Pnot p2 -> compare_predicate p1 p2 | Pnot _, _ -> 1 | _, Pnot _ -> -1 | Pif (c1,t1,e1), Pif(c2,t2,e2) -> let res = compare_term c1 c2 in if res = 0 then let res = compare_predicate t1 t2 in if res = 0 then compare_predicate e1 e2 else res else res | Pif _, _ -> 1 | _, Pif _ -> -1 | Plet (d1,p1), Plet(d2,p2) -> let res = compare_logic_info d1 d2 in if res = 0 then compare_predicate p1 p2 else res | Plet _, _ -> 1 | _, Plet _ -> -1 | Pforall(q1,p1), Pforall(q2,p2) | Pexists(q1,p1), Pexists(q2,p2) -> let res = Extlib.list_compare compare_var q1 q2 in if res = 0 then compare_predicate p1 p2 else res | Pforall _, _ -> 1 | _, Pforall _ -> -1 | Pexists _, _ -> 1 | _, Pexists _ -> -1 | Pat(p1,l1), Pat(p2,l2) -> let res = compare_logic_label l1 l2 in if res = 0 then compare_predicate p1 p2 else res | Pat _, _ -> 1 | _, Pat _ -> -1 | 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) | Pdangling (l1,t1), Pdangling (l2,t2) -> let res = compare_logic_label l1 l2 in if res = 0 then compare_term t1 t2 else res | Pallocable _, _ -> 1 | _, Pallocable _ -> -1 | Pfreeable _, _ -> 1 | _, Pfreeable _ -> -1 | Pvalid _, _ -> 1 | _, Pvalid _ -> -1 | Pvalid_read _, _ -> 1 | _, Pvalid_read _ -> -1 | Pinitialized _, _ -> 1 | _, Pinitialized _ -> -1 | Pdangling _, _ -> 1 | _, Pdangling _ -> -1 | Pvalid_function t1, Pvalid_function t2 -> compare_term t1 t2 | Pvalid_function _, _ -> 1 | _, Pvalid_function _ -> -1 | Pfresh (l1,m1,t1,n1), Pfresh (l2,m2,t2,n2) -> let res = compare_logic_label l1 l2 in if res = 0 then let res = compare_logic_label m1 m2 in if res = 0 then let res = compare_term t1 t2 in if res = 0 then compare_term n1 n2 else res else res else res | Pfresh _, _ -> 1 | _, Pfresh _ -> -1 | Psubtype(lt1,rt1), Psubtype(lt2,rt2) -> let res = compare_term lt1 lt2 in if res = 0 then compare_term rt1 rt2 else res | Psubtype _, _ -> 1 | _, Psubtype _ -> -1 | Pseparated(seps1), Pseparated(seps2) -> Extlib.list_compare compare_term seps1 seps2 and compare_predicate pred1 pred2 = let res = Extlib.list_compare String.compare pred1.pred_name pred2.pred_name in if res = 0 then compare_predicate_node pred1.pred_content pred2.pred_content else res (* unused for now *) (* and compare_identified_predicate p1 p2 = let res = Extlib.list_compare String.compare p1.ip_name p2.ip_name in if res = 0 then compare_predicate p1.ip_content p2.ip_content else res *) and compare_identified_term l1 l2 = compare_term l1.it_content l2.it_content 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_ip_list l1 l2 = List.fold_right (fun p acc -> if List.exists (fun x -> is_same_identified_predicate p x) acc then acc else p::acc) l1 l2 let merge_post_cond l1 l2 = List.fold_right (fun (k1,p1 as pc) acc -> if List.exists (fun (k2,p2) -> k1 = k2 && is_same_identified_predicate p1 p2) acc then acc else pc::acc) 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 <- merge_ip_list old_b.b_assumes b.b_assumes; old_b.b_requires <- merge_ip_list old_b.b_requires b.b_requires; old_b.b_post_cond <- merge_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 thost = let extract_ctype lty = let get = function | Ctype typ -> Some typ | Ltype _ | Lvar _ | Linteger | Lreal | Larrow _ -> None in match Logic_const.plain_or_set get lty with | None -> Kernel.fatal "[lhost_c_type] logic type %a does not represent a C type" Cil_datatype.Logic_type.pretty lty | Some ty -> ty in match thost with | TVar v -> extract_ctype v.lv_type | TMem t -> let ty = extract_ctype t.term_type in (match Cil.unrollType ty with | 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_extension ca = match ca.annot_content with AExtended _ -> true | _ -> false let is_loop_annot s = is_loop_invariant s || is_assigns s || is_allocation s || is_variant s || is_loop_pragma s || is_loop_extension s let is_trivial_annotation a = match a.annot_content with | AAssert (_,a) -> is_trivially_true a | APragma _ | AStmtSpec _ | AInvariant _ | AVariant _ | AAssigns _| AAllocation _ | AExtended _ -> false 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 [] class complete_types = object inherit Cil.nopCilVisitor method! vterm t = match t.term_node with | TLval (TVar v, TNoOffset) when isLogicType Cil.isCompleteType v.lv_type && not (isLogicType Cil.isCompleteType t.term_type) -> ChangeDoChildrenPost({ t with term_type = v.lv_type }, fun x -> x) | _ -> DoChildren end let complete_types f = Cil.visitCilFileSameGlobals (new complete_types) f (* ************************************************************************* *) (** {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 unroll_type t.term_type with | Ctype ty -> (match Cil.unrollTypeDeep ty with | TPtr(TFun _,_) -> mk_cast ~loc cfct_ptr t, fct_ptr | TPtr(TVoid _,_) -> t, obj_ptr | TPtr _ | TInt _ | TFloat _ | TEnum _ -> (* Value may emit pointer_comparable alarms on anything that may be compared. We cast scalar to void* to account for this *) mk_cast ~loc Cil.voidPtrType t, obj_ptr | TVoid _ | TFun _ | TNamed _ | TComp _ | TBuiltin_va_list _ | TArray _ (* in logic array do not decay implicitly into pointers. *) -> Kernel.fatal "Trying to call \\pointer_comparable on non-pointer value" ) | _ -> Kernel.fatal "Trying to call \\pointer_comparable on non-C pointer type value" 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])) let points_to_valid_string ?loc s = match Logic_env.find_all_logic_functions "\\points_to_valid_string" with [ pi ] -> Logic_const.unamed ?loc (Papp (pi, [], [s])) | _ -> assert false let is_min_max_function name li = li.l_var_info.lv_name = name && match li.l_profile with | [e] -> Cil_datatype.Logic_type.equal e.lv_type (Logic_const.make_set_type Linteger) | _ -> false let is_max_function li = is_min_max_function "\\max" li let is_min_function li = is_min_max_function "\\min" li let rec constFoldTermToInt ?(machdep=true) (e: term) : Integer.t option = match e.term_node with | TBinOp(bop, e1, e2) -> constFoldBinOpToInt ~machdep bop e1 e2 | TUnOp(unop, e) -> constFoldUnOpToInt ~machdep unop e | TConst(LChr c) -> Some (charConstToInt c) | TConst(LEnum {eival = v}) -> Cil.constFoldToInt ~machdep v | TConst (Integer (i, _)) -> Some i | TConst (LReal _ | LWStr _ | LStr _) -> None | TSizeOf typ -> constFoldSizeOfToInt ~machdep typ | TSizeOfE t -> begin match unroll_type t.term_type with | Ctype typ -> constFoldSizeOfToInt ~machdep typ | _ -> None end | TSizeOfStr s -> Some (Integer.of_int (1 + String.length s)) | TAlignOf t -> begin try Some (Integer.of_int (Cil.bytesAlignOf t)) with Cil.SizeOfError _ -> None end | TAlignOfE _ -> None (* exp case is very complex, and possibly incorrect *) | TCastE (typ, e) -> constFoldCastToInt ~machdep typ e | Toffset (_, t) -> if machdep then constFoldToffset t else None | Tif (c, e1, e2) -> begin match constFoldTermToInt ~machdep c with | None -> None | Some i -> constFoldTermToInt ~machdep (if Integer.is_zero i then e2 else e1) end | TLogic_coerce (lt, e) -> if lt = Linteger then constFoldTermToInt ~machdep e else None | Tnull -> Some Integer.zero | Tapp (li, _, [{term_node = (Tunion args | TLogic_coerce (_, {term_node = Tunion args}))}]) when is_max_function li -> constFoldMinMax ~machdep Integer.max args | Tapp (li, _, [{term_node = (Tunion args | TLogic_coerce (_, {term_node = Tunion args}))}]) when is_min_function li -> constFoldMinMax ~machdep Integer.min args | TLval _ | TAddrOf _ | TStartOf _ | Tapp _ | Tlambda _ | TDataCons _ | Tat _ | Tbase_addr _ | Tblock_length _ | TCoerce _ | TCoerceE _ | TUpdate _ | Ttypeof _ | Ttype _ | Tempty_set | Tunion _ | Tinter _ | Tcomprehension _ | Trange _ | Tlet _ -> None and constFoldCastToInt ~machdep typ e = try let ik = match Cil.unrollType typ with | TInt (ik, _) -> ik | TPtr _ -> theMachine.upointKind | TEnum (ei,_) -> ei.ekind | _ -> raise Exit in match constFoldTermToInt ~machdep e with | Some i -> Some (fst (Cil.truncateInteger64 ik i)) | _ -> None with Exit -> None and constFoldSizeOfToInt ~machdep typ = if machdep then try Some (Integer.of_int (bytesSizeOf typ)) with SizeOfError _ -> None else None and constFoldUnOpToInt ~machdep unop e = let i = constFoldTermToInt ~machdep e in match i with | None -> None | Some i -> match unop with | Neg -> Some (Integer.neg i) | BNot -> Some (Integer.lognot i) | LNot -> Some (if Integer.equal i Integer.zero then Integer.one else Integer.zero) and constFoldBinOpToInt ~machdep bop e1 e2 = match constFoldTermToInt ~machdep e1, constFoldTermToInt ~machdep e2 with | Some i1, Some i2 -> begin let comp op = Some (if op i1 i2 then Integer.one else Integer.zero) in let logic op = let b1 = not (Integer.is_zero i1) and b2 = not (Integer.is_zero i2) in Some (if op b1 b2 then Integer.one else Integer.zero) in match bop with | PlusA -> Some (Integer.add i1 i2) | MinusA -> Some (Integer.sub i1 i2) | PlusPI | IndexPI | MinusPI | MinusPP -> None | Mult -> Some (Integer.mul i1 i2) | Div -> if Integer.(equal zero i2) && Integer.(is_zero (rem i1 i2)) then None else Some (Integer.div i1 i2) | Mod -> if Integer.(equal zero i2) then None else Some (Integer.rem i1 i2) | BAnd -> Some (Integer.logand i1 i2) | BOr -> Some (Integer.logor i1 i2) | BXor -> Some (Integer.logxor i1 i2) | Shiftlt when Integer.(ge i2 zero) -> Some (Integer.shift_left i1 i2) | Shiftrt when Integer.(ge i2 zero) -> Some (Integer.shift_right i1 i2) | Shiftlt | Shiftrt -> None | Cil_types.Eq -> comp Integer.equal | Cil_types.Ne -> comp (fun i1 i2 -> not (Integer.equal i1 i2)) | Cil_types.Le -> comp Integer.le | Cil_types.Ge -> comp Integer.ge | Cil_types.Lt -> comp Integer.lt | Cil_types.Gt -> comp Integer.gt | LAnd -> logic (&&) | LOr -> logic (||) end | None, _ | _, None -> None (* [t] is the argument of [\offset] *) and constFoldToffset t = match t.term_node with | TStartOf (TVar v, offset) | TAddrOf (TVar v, offset) -> begin try let start, _width = bitsLogicOffset v.lv_type offset in let size_char = Integer.eight in if Integer.(is_zero (rem start size_char)) then Some (Integer.div start size_char) else None (* bitfields *) with Cil.SizeOfError _ -> None end | _ -> None (* This function supposes that ~machdep is [true] *) and bitsLogicOffset ltyp off : Integer.t * Integer.t = let rec loopOff typ width start = function | TNoOffset -> start, width | TIndex(e, off) -> begin let ei = match constFoldTermToInt e with | Some i -> i | None -> raise (SizeOfError ("Index is not constant", typ)) in let typ_e = Cil.typeOf_array_elem typ in let size_e = Integer.of_int (Cil.bitsSizeOf typ_e) in loopOff typ size_e (Integer.(add start (mul ei size_e))) off end | TField(f, off) -> if f.fcomp.cstruct then begin (* Force the computation of the fields fsize_in_bits and foffset_in_bits *) ignore (Cil.bitsOffset typ (Field (f, NoOffset))); let size = Integer.of_int (Extlib.the f.fsize_in_bits) in let offset_f = Integer.of_int (Extlib.the f.foffset_in_bits) in loopOff f.ftype size (Integer.add start offset_f) off end else (* All union fields start at offset 0 *) loopOff f.ftype (Integer.of_int (Cil.bitsSizeOf f.ftype)) start off | TModel _ -> raise (SizeOfError ("bitsLogicOffset on model field", typ)) in match unroll_type ltyp with | Ctype typ -> loopOff typ Integer.zero Integer.zero off | _ -> raise (SizeOfError ("bitsLogicOffset on logic type", Cil.voidPtrType)) (* Handle \min(\union(args)) or \max(\union(args)), depending on [f] *) and constFoldMinMax ~machdep f args = match args with | [] -> None (* meaningless, cannot simplify *) | arg :: args -> let aux res t = match res, constFoldTermToInt ~machdep t with | None, _ | _, None -> None | Some i, Some i' -> Some (f i i') in List.fold_left aux (constFoldTermToInt ~machdep arg) args let rec fold_itv f b e acc = if Integer.equal b e then f acc b else fold_itv f (Integer.succ b) e (f acc b) (* Find the initializer for index [i] in [init] *) let find_init_by_index init i = let same_offset (off, _) = match off with | Index (i', NoOffset) -> Integer.equal i (Extlib.the (Cil.isInteger i')) | _ -> false in snd (List.find same_offset init) (* Find the initializer for field [f] in [init] *) let find_init_by_field init f = let same_offset (off, _) = match off with | Field (f', NoOffset) -> f == f' | _ -> false in snd (List.find same_offset init) exception CannotSimplify (* Evaluate the bounds of the range [b..e] as constants. The array being indexed has type [typ]. If [b] or [e] are not specified, use default values. *) let const_fold_trange_bounds typ b e = let extract = function None -> raise CannotSimplify | Some i -> i in let b = match b with | Some tb -> extract (constFoldTermToInt tb) | None -> Integer.zero in let e = match e with | Some te -> extract (constFoldTermToInt te) | None -> match Cil.unrollType typ with | TArray (_, Some size, _, _) -> Integer.pred (extract (Cil.isInteger size)) | _ -> raise CannotSimplify in b, e (** Find the value corresponding to the logic offset [loff] inside the initialiser [init]. Zero is used as a default value when the initialiser is incomplete. [loff] must have an integral type. Returns a set of values when [loff] contains ranges. *) let find_initial_value init loff = let module S = Datatype.Integer.Set in let extract = function None -> raise CannotSimplify | Some i -> i in let rec aux loff init = match loff, init with | TNoOffset, SingleInit e -> S.singleton (extract (Cil.constFoldToInt e)) | TIndex (i, loff), CompoundInit (typ, l) -> begin (* Add the initializer at offset [Index(i, loff)] to [acc]. *) let add_index acc i = let vi = try aux loff (find_init_by_index l i) with Not_found -> S.singleton Integer.zero in S.union acc vi in match i.term_node with | Tunion tl -> let conv t = extract (constFoldTermToInt t) in List.fold_left add_index S.empty (List.map conv tl) | Trange (b, e) -> let b, e = const_fold_trange_bounds typ b e in fold_itv add_index b e S.empty | _ -> let i = extract (constFoldTermToInt i) in add_index S.empty i end | TField (f, loff), CompoundInit (_, l) -> if f.fcomp.cstruct then try aux loff (find_init_by_field l f) with Not_found -> S.singleton Integer.zero else (* too complex, a value might be written through another field *) raise CannotSimplify | TNoOffset, CompoundInit _ | (TIndex _ | TField _), SingleInit _ -> assert false | TModel _, _ -> raise CannotSimplify in try match init with | None -> Some (S.singleton Integer.zero) | Some init -> Some (aux loff init) with CannotSimplify -> None (** Evaluate the given term l-value in the initial state *) let eval_term_lval global_find_init (lhost, loff) = match lhost with | TVar lvi -> begin (** See if we can evaluate the l-value using the initializer of lvi*) let off_type = Cil.typeTermOffset lvi.lv_type loff in if Logic_const.plain_or_set Cil.isLogicIntegralType off_type then match lvi.lv_origin with | Some vi when vi.vglob && Cil.typeHasQualifier "const" vi.vtype -> find_initial_value (global_find_init vi) loff | _ -> None else None end | _ -> None class simplify_const_lval global_find_init = object (self) inherit Cil.genericCilVisitor (Cil.copy_visit (Project.current ())) method! vterm t = match t.term_node with | TLval tlv -> begin (* simplify recursively tlv before attempting evaluation *) let tlv = Cil.visitCilTermLval (self:>Cil.cilVisitor) tlv in match eval_term_lval global_find_init tlv with | None -> Cil.SkipChildren | Some itvs -> (* Replace the value/set of values found by something that has the expected logic type (plain/Set) *) let typ = Logic_const.plain_or_set Extlib.id t.term_type in let aux i l = Logic_const.term (TConst (Integer (i,None))) typ :: l in let l = Datatype.Integer.Set.fold aux itvs [] in match l, Logic_const.is_plain_type t.term_type with | [i], true -> Cil.ChangeTo i | _, false -> Cil.ChangeTo (Logic_const.term (Tunion l) t.term_type) | _ -> Cil.SkipChildren end | _ -> Cil.DoChildren end (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_queries/cil_datatype.ml0000644000175000017500000022364313113745011025667 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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_with_pretty = sig include Datatype.S val pretty_ref: (Format.formatter -> t -> unit) ref end module type S_with_collections_pretty = sig include Datatype.S_with_collections val pretty_ref: (Format.formatter -> t -> unit) ref end 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.t_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.t_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" (Filepath.pretty 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 let pretty_ref = ref (fun _ _ -> assert false) 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 = !pretty_ref fmt loc let varname _ = "loc" end) let pretty_long fmt loc = let file = Filepath.pretty (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 | Local_init (_,_,l) -> l | 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_Id = struct let pretty_ref = ref (fun _ _ -> assert false) include 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) let id stmt = stmt.sid end module Stmt = struct include Stmt_Id let pretty_sid fmt s = Format.pp_print_int fmt s.sid module Hptset = struct include Hptset.Make (Stmt_Id) (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) | Throw (_,l) | TryCatch(_,_,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 constfoldtoint = ref (fun _ -> failwith "constfoldtoint not yet defined") let punrollType = ref (fun _ -> failwith "punrollType not yet defined") let drop_non_logic_attributes = ref (fun a -> a) let compare_exp_struct_eq = ref (fun _ -> failwith "compare_exp_struct_eq not yet defined") 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_array_sizes e1o e2o = let compare_non_empty_size e1 e2 = let i1 = !constfoldtoint e1 in let i2 = !constfoldtoint e2 in match i1, i2 with | None, None -> (* inconclusive. do not return 0 *) !compare_exp_struct_eq e1 e2 | _ -> Extlib.opt_compare Integer.compare i1 i2 in Extlib.opt_compare compare_non_empty_size e1o e2o 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', e1, _, l1), TArray (t2', e2, _, l2) -> compare_chain compare_array_sizes e1 e2 (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 (* Shared between the different modules for types. *) let pretty_typ_ref = ref (fun _ _ -> assert false) module Attributes= Datatype.List_with_collections(Attribute) (struct let module_name = "Attributes" end) module MakeTyp(M:sig val config: type_compare_config val name: string end) = struct let pretty_ref = pretty_typ_ref 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= struct include MakeTyp (struct let config = { by_name = false; logic_type = false; unroll = true; } let name = "Typ" end) let toplevel_attr = function | TVoid a -> a | TInt (_, a) -> a | TFloat (_, a) -> a | TNamed (_, a) -> a | TPtr (_, a) -> a | TArray (_, _, _,a) -> a | TComp (_, _, a) -> a | TEnum (_, a) -> a | TFun (_, _, _, a) -> a | TBuiltin_va_list a -> a 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_Id = 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; vtemp = false; vdescr = None; vdescrpure = false; vghost = false; vsource = false; vlogic_var_assoc = None } include 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 id v = v.vid end module Varinfo = struct include Varinfo_Id module Hptset = struct include Hptset.Make (Varinfo_Id) (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 = struct let pretty_ref = Extlib.mk_fun "Cil_datatype.Fieldinfo.pretty_ref" include 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 fmt f = !pretty_ref fmt f let varname = Datatype.undefined end) 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 | CStr _ | CWStr _ | CChr _ -> Hashtbl.hash c | CReal (fn,fk,_) -> Hashtbl.hash fn + Hashtbl.hash fk | CInt64 (n,k,_) -> Integer.hash n + Hashtbl.hash k | CEnum ei -> 95 + Enumitem.hash ei module StructEq = struct let rec compare_exp e1 e2 = match e1.enode, e2.enode with | Const (CStr _), Const (CStr _) | Const (CWStr _), Const (CWStr _) -> compare e1.eid e2.eid | 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 _ -> Cmdline.Kernel_log.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 _ -> Cmdline.Kernel_log.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) let () = compare_exp_struct_eq := ExpStructEq.compare 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; bscoping=true}] 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; lv_attr = []; } 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; lt_attr=[] } ] 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 fmt f = Logic_var.pretty fmt f.l_var_info 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 (* Shared between the different modules for logic types *) let pretty_logic_type_ref = ref (fun _ _ -> assert false) module Make_Logic_type (M: sig val config: type_compare_config val name: string end) = struct let pretty_ref = pretty_logic_type_ref include 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) 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; mi_attr = []; }) 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 = 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; mi_attr = List.map Attribute.copy mi.mi_attr } let pretty fmt t = !pretty_ref fmt t end) end (* -------------------------------------------------------------------------- *) (* --- Comparison Over Terms --- *) (* -------------------------------------------------------------------------- *) (* @return [true] is the given logic real represents an exact float *) let is_exact_float r = Pervasives.classify_float r.r_upper = FP_normal && Datatype.Float.equal r.r_upper r.r_lower 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 -> if is_exact_float r1 && is_exact_float r2 then Datatype.Float.compare r1.r_lower r2.r_lower else 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_logic_constant = function | LStr s -> Datatype.String.hash s | LWStr l -> hash_list Datatype.Int64.hash l | LChr c -> Datatype.Char.hash c | Integer(n, _) -> Integer.hash n | LReal r -> if is_exact_float r then Datatype.Float.hash r.r_lower else Datatype.String.hash r.r_literal | 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 = struct let pretty_ref = ref (fun _ _ -> assert false) include 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 fmt t_o = !pretty_ref fmt t_o let varname = Datatype.undefined end) end module Term_lval = struct let pretty_ref = ref (fun _ _ -> assert false) include Datatype.Pair_with_collections (Term_lhost) (Term_offset) (struct let module_name = "Cil_datatype.Term_lval" end) let pretty fmt t = !pretty_ref fmt t end module Logic_label = struct let pretty_ref = ref (fun _ _ -> assert false) include 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 fmt l = !pretty_ref fmt l let varname _ = "logic_label" end) end module Global_annotation = struct let pretty_ref = ref (fun _ -> assert false) 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 fmt v = !pretty_ref fmt v 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,_,_,attr1,_), Dvolatile(it2,_,_,attr2,_) -> let res = compare_list Identified_term.compare it1 it2 in if res = 0 then Attributes.compare attr1 attr2 else res | Dvolatile _,_ -> -1 | _,Dvolatile _ -> 1 | Daxiomatic (_,g1,attr1,_), Daxiomatic (_,g2,attr2,_) -> (* ACSL does not require the name to be unique. *) let res = compare_list compare g1 g2 in if res = 0 then Attributes.compare attr1 attr2 else res | Daxiomatic _, _ -> -1 | _, Daxiomatic _ -> 1 | Dtype(t1,_), Dtype(t2,_) -> Logic_type_info.compare t1 t2 | Dtype _, _ -> -1 | _, Dtype _ -> 1 | Dlemma (l1,_,_,_,_,attr1,_), Dlemma(l2,_,_,_,_,attr2,_) -> let res = Datatype.String.compare l1 l2 in if res = 0 then Attributes.compare attr1 attr2 else res | 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, attr1, _), Dcustom_annot(_, n2, attr2, _) -> let res = Datatype.String.compare n1 n2 in if res = 0 then Attributes.compare attr1 attr2 else res let equal = Datatype.from_compare let rec hash g = match g with | Dfun_or_pred (l,_) -> 2 * Logic_info.hash l | Dvolatile ([],_,_,_,(_source,_)) -> Cmdline.Kernel_log.fatal "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 let attr = function | Dfun_or_pred({ l_var_info = { lv_attr }}, _) -> lv_attr | Daxiomatic(_, _, attr, _) -> attr | Dtype ({lt_attr}, _) -> lt_attr | Dlemma(_, _, _, _, _, attr, _) -> attr | Dinvariant({ l_var_info = { lv_attr }}, _) -> lv_attr | Dtype_annot({ l_var_info = { lv_attr}}, _) -> lv_attr | Dmodel_annot({ mi_attr }, _) -> mi_attr | Dvolatile(_, _, _, attr, _) -> attr | Dcustom_annot(_,_,attr,_) -> attr end module Global = struct let pretty_ref = ref (fun _ -> assert false) include Make_with_collections (struct type t = global let name = "Global" let reprs = [ GText "" ] let internal_pretty_code = Datatype.undefined let pretty fmt v = !pretty_ref fmt v 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 | GFunDecl (_,v1,_), GFunDecl(_,v2,_) -> Varinfo.compare v1 v2 | GFunDecl _,_ -> -1 | _,GFunDecl _ -> 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 | GFunDecl (_,v,_) -> 43 * Varinfo.hash v let copy = Datatype.undefined end) let loc = function | GFun(_, l) | GType(_, l) | GEnumTag(_, l) | GEnumTagDecl(_, l) | GCompTag(_, l) | GCompTagDecl(_, l) | GVarDecl( _, l) | GFunDecl(_, _, l) | GVar(_, _, l) | GAsm(_, l) | GPragma(_, l) | GAnnot (_, l) -> l | GText _ -> Location.unknown let attr = function | GVar (vi,_,_) | GFun ({svar = vi},_) | GVarDecl (vi,_) | GFunDecl (_,vi,_)-> vi.vattr | GType (t,_) -> Typ.toplevel_attr t.ttype | GCompTag(ci,_) | GCompTagDecl(ci,_) -> ci.cattr | GEnumTag(ei,_) | GEnumTagDecl(ei,_) -> ei.eattr | GAnnot (g,_) -> Global_annotation.attr g | _ -> [] 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.t_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); 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 begin if id k1 = id k2 then begin Cmdline.Kernel_log.fatal "Two kf for %a (%d) and %a (%d) (%d)@." Varinfo.pretty (vi k1) (Extlib.address_of_value k1) Varinfo.pretty (vi k2) (Extlib.address_of_value k2) (id k1) end; false end 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(_,{pred_loc=loc}) | AInvariant(_,_,{pred_loc=loc}) | AVariant({term_loc=loc},_) -> Some loc | AAssigns _ | AAllocation _ | APragma _ | AExtended _ | AStmtSpec _ -> None end module Predicate = struct let pretty_ref = ref (fun _ _ -> assert false) include Make (struct type t = predicate let name = "Predicate" let reprs = [ { pred_name = [ "" ]; pred_loc = Location.unknown; pred_content = Pfalse } ] let internal_pretty_code = Datatype.undefined let pretty fmt x = !pretty_ref fmt x let varname _ = "p" end) end module Identified_predicate = struct let pretty_ref = ref (fun _ _ -> assert false) include Make_with_collections (struct type t = identified_predicate let name = "Identified_predicate" let reprs = [ { ip_content = List.hd Predicate.reprs; ip_id = -1} ] let compare x y = Extlib.compare_basic x.ip_id y.ip_id let equal x y = x.ip_id = y.ip_id let copy = Datatype.undefined let hash x = x.ip_id let internal_pretty_code = Datatype.undefined let pretty fmt x = !pretty_ref fmt x let varname _ = "id_predyes" end) end module Funbehavior = Datatype.Make (struct include Datatype.Serializable_undefined type t = funbehavior let name = "Funbehavior" let reprs = [ { b_name = "default!"; (* Cil.default_behavior_name *) b_requires = Identified_predicate.reprs; b_assumes = Identified_predicate.reprs; b_post_cond = List.map (fun x -> Normal, x) Identified_predicate.reprs; b_assigns = WritesAny; b_allocation = FreeAllocAny; b_extended = [ "toto", Ext_preds Predicate.reprs ]; } ] let mem_project = Datatype.never_any_project end) module Funspec = struct let pretty_ref = ref (fun _ _ -> assert false) include Datatype.Make (struct include Datatype.Serializable_undefined type t = funspec let name = "Funspec" let reprs = [ { spec_behavior = Funbehavior.reprs; spec_variant = None; spec_terminates = None; spec_complete_behaviors = []; spec_disjoint_behaviors = [] } ] let pretty fmt x = !pretty_ref fmt x let mem_project = Datatype.never_any_project end) end module Fundec = struct let make_dummy vi fs = { svar = vi; sformals = []; slocals = []; smaxid = 0; sbody = List.hd (Block.reprs); 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.t_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 (**************************************************************************) (** {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-Phosphorus-20170501/src/kernel_services/ast_queries/file.ml0000644000175000017500000017073213113745010024143 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 Cil_datatype let dkey_print_one = Kernel.register_category "file" let dkey_transform = Kernel.register_category "file:transformation" let dkey_annot = Kernel.register_category "file:annotation" let dkey_pp = Kernel.register_category "pp" type cpp_opt_kind = Gnu | Not_gnu | Unknown let pretty_cpp_opt_kind fmt = function | Gnu -> Format.pp_print_string fmt "Gnu" | Not_gnu -> Format.pp_print_string fmt "Not_gnu" | Unknown -> Format.pp_print_string fmt "Unknown" 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.*) * cpp_opt_kind | 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("", "", Unknown); NoCPP ""; External("", "") ] let structural_descr = Structural_descr.t_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,c) -> Format.fprintf fmt "@[File.NeedCPP (%S,%S,%a)@]" a b pretty_cpp_opt_kind c 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} *) (* ************************************************************************* *) (* Do not trust custom command-line to be gnu like by default, but give them a chance, with a warning indicating that things may go wrong. *) let cpp_opt_kind () = if Kernel.CppGnuLike.is_set () then if Kernel.CppGnuLike.get () then Gnu else Not_gnu else Unknown (* 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 begin (cmdline, cpp_opt_kind ()) end else begin let gnu = if Config.using_default_cpp then if Config.preprocessor_is_gnu_like then Gnu else Not_gnu else cpp_opt_kind () in Config.preprocessor, gnu end let from_filename ?cpp f = let cpp, is_gnu_like = match cpp with | None -> get_preprocessor_command () | Some s -> s, cpp_opt_kind () in 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 if cpp <> "" then begin if not Config.preprocessor_keep_comments then Kernel.warning ~once:true "Default pre-processor does not keep comments. Any ACSL annotation \ on non-pre-processed file will be discarded."; NeedCPP (f, cpp, is_gnu_like) end else Kernel.abort "No working pre-processor found. You can only analyze \ pre-processed .i files." (* ************************************************************************* *) (** {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 () = Ast.add_linked_state Cabshelper.Comments.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.abort "Cannot find file %s, needed for Frama-C initialization. \ Please check that %s is the correct share path for Frama-C, and that \ Frama-C has been installed." 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 Machdep} *) (* ************************************************************************* *) (* not exported, see [pretty_machdep] below. *) let print_machdep fmt (m : Cil_types.mach) = begin let open Cil_types in Format.fprintf fmt "Machine: %s@\n" m.version ; List.iter (fun (name,size,align) -> Format.fprintf fmt " sizeof %11s = %2d (%d bits, aligned on %d bits)@\n" name size (size*8) (align*8)) [ "short", m.sizeof_short, m.alignof_short ; "int", m.sizeof_int, m.alignof_int ; "long", m.sizeof_long, m.alignof_long ; "long long", m.sizeof_longlong, m.alignof_longlong ; "float", m.sizeof_float, m.alignof_float ; "double", m.sizeof_double, m.alignof_double ; "long double", m.sizeof_longdouble, m.alignof_longdouble ; "pointer", m.sizeof_ptr, m.alignof_ptr ; "function", m.sizeof_fun, m.alignof_fun ; "void", m.sizeof_void, 1 ; ] ; List.iter (fun (name,typeof) -> Format.fprintf fmt " typeof %11s = %s@\n" name typeof) [ "sizeof(T)", m.size_t ; "wchar_t", m.wchar_t ; "ptrdiff_t", m.ptrdiff_t ; ] ; Format.fprintf fmt " char is %s@\n" (if m.char_is_unsigned then "unsigned" else "signed"); Format.fprintf fmt " machine is %s endian@\n" (if m.little_endian then "little" else "big") ; Format.fprintf fmt " strings are %s chars@\n" (if m.underscore_name then "const" else "writable") ; Format.fprintf fmt " assembly names %s leading '_'@\n" (if m.underscore_name then "have" else "have no") ; Format.fprintf fmt " compiler %s builtin __va_list@\n" (if m.has__builtin_va_list then "has" else "has not") ; Format.fprintf fmt " compiler %s __head as a keyword@\n" (if m.__thread_is_keyword then "uses" else "does not use") ; end module DatatypeMachdep = Datatype.Make_with_collections(struct include Datatype.Serializable_undefined let reprs = [Machdeps.x86_32] let name = "File.Machdep" type t = Cil_types.mach let compare : t -> t -> int = Pervasives.compare let equal : t -> t -> bool = (=) let hash : t -> int = Hashtbl.hash let copy = Datatype.identity end) let default_machdeps = [ "x86_16", Machdeps.x86_16; "x86_32", Machdeps.x86_32; "x86_64", Machdeps.x86_64; "gcc_x86_16", Machdeps.x86_16; "gcc_x86_32", Machdeps.gcc_x86_32; "gcc_x86_64", Machdeps.gcc_x86_64; "ppc_32", Machdeps.ppc_32; "msvc_x86_64", Machdeps.msvc_x86_64; ] let regexp_existing_machdep_macro = Str.regexp "-D[ ]*__FC_MACHDEP_" let existing_machdep_macro () = let extra = String.concat " " (Kernel.CppExtraArgs.get ()) in try ignore (Str.search_forward regexp_existing_machdep_macro extra 0); true with Not_found -> false let machdep_macro = function | "x86_16" | "gcc_x86_16" -> "__FC_MACHDEP_X86_16" | "x86_32" | "gcc_x86_32" -> "__FC_MACHDEP_X86_32" | "x86_64" | "gcc_x86_64" -> "__FC_MACHDEP_X86_64" | "ppc_32" -> "__FC_MACHDEP_PPC_32" | "msvc_x86_64" -> "__FC_MACHDEP_MSVC_X86_64" | s -> let res = "__FC_MACHDEP_" ^ (Transitioning.String.uppercase_ascii s) in Kernel.warning ~once:true "machdep %s has no registered macro. Using %s for pre-processing" s res; res module Machdeps = State_builder.Hashtbl(Datatype.String.Hashtbl)(DatatypeMachdep) (struct let name = " File.Machdeps" let size = 5 let dependencies = [] end) let mem_machdep s = Machdeps.mem s || List.mem_assoc s default_machdeps let new_machdep s m = try let cm = Machdeps.find s in if not (cm = m) then Kernel.abort "trying to register incompatible machdeps under name `%s'" s with Not_found -> Machdeps.add s m let pretty_machdeps fmt = Machdeps.iter (fun x _ -> Format.fprintf fmt "@ %s" x); List.iter (fun (x, _) -> Format.fprintf fmt "@ %s" x) default_machdeps let machdep_help () = let m = Kernel.Machdep.get () in if m = "help" then begin Kernel.feedback "@[supported machines are%t@ (default is x86_32).@]" pretty_machdeps; raise Cmdline.Exit end else Cmdline.nop let () = Cmdline.run_after_exiting_stage machdep_help let set_machdep () = let m = Kernel.Machdep.get () in if not (mem_machdep m) then Kernel.abort "@[unsupported machine %s.@ Try one of%t.@]" m pretty_machdeps let () = Cmdline.run_after_configuring_stage set_machdep (* Local to this module. Use Cil.theMachine.theMachine outside *) let get_machdep () = let m = Kernel.Machdep.get () in try Machdeps.find m with Not_found -> try List.assoc m default_machdeps with Not_found -> (* Should not happen given the checks above *) Kernel.fatal "Machdep %s not registered" m let pretty_machdep ?fmt ?machdep () = let machine = match machdep with None -> get_machdep () | Some m -> m in match fmt with | None -> Log.print_on_output (fun fmt -> print_machdep fmt machine) | Some fmt -> print_machdep fmt machine (* ************************************************************************* *) (** {2 Initialisations} *) (* ************************************************************************* *) let safe_remove_file f = if not (Kernel.Debug_category.exists (fun x -> x = "parser")) then Extlib.safe_remove f let build_cpp_cmd cmdl 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) let parse_cabs = function | NoCPP f -> if not (Sys.file_exists f) then Kernel.abort "preprocessed file %S does not exist" f; Kernel.feedback "Parsing %s (no preprocessing)" (Filepath.pretty f); Frontc.parse f () | NeedCPP (f, cmdl, is_gnu_like) -> 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 add_if_gnu opt = match is_gnu_like with | Gnu -> [opt] | Not_gnu -> [] | Unknown -> Kernel.warning ~once:true "your preprocessor is not known to handle option `%s'. \ If pre-processing fails because of it, please add \ -no-cpp-frama-c-compliant option to Frama-C's command-line. \ If you do not want to see this warning again, explicitly use \ option -cpp-frama-c-compliant." opt; [opt] 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 (* Hypothesis: the preprocessor is POSIX compliant, hence understands -I and -D. *) let include_args = if Kernel.FramaCStdLib.get () then [Config.datadir ^ "/libc"] else [] in let define_args = if Kernel.FramaCStdLib.get () && not (existing_machdep_macro ()) then [machdep_macro (Kernel.Machdep.get ())] else [] in let extra_args = if include_args = [] && define_args = [] then [] else add_if_gnu "-nostdinc" in let define_args = "__FRAMAC__" :: define_args in (* Hypothesis: the preprocessor does support the arch-related options tested when 'configure' was run. *) let required_cpp_arch_args = (get_machdep ()).cpp_arch_flags in let supported_cpp_arch_args, unsupported_cpp_arch_args = List.partition (fun arg -> List.mem arg Config.preprocessor_supported_arch_options) required_cpp_arch_args in if is_gnu_like = Unknown && not (Kernel.CppCommand.is_set ()) && unsupported_cpp_arch_args <> [] then Kernel.warning ~once:true "your preprocessor is not known to handle option(s) `%a', \ considered necessary for machdep `%s'. To ensure compatibility \ between your preprocessor and the machdep, consider using \ -cpp-command with the appropriate flags. \ Your preprocessor is known to support these flags: %a" (Pretty_utils.pp_list ~sep:" " Format.pp_print_string) unsupported_cpp_arch_args (Kernel.Machdep.get ()) (Pretty_utils.pp_list ~sep:" " Format.pp_print_string) Config.preprocessor_supported_arch_options; let extra_args = if Kernel.ReadAnnot.get () then if Kernel.PreprocessAnnot.is_set () then if Kernel.PreprocessAnnot.get () then "-dD" :: extra_args else extra_args else let opt = add_if_gnu "-dD" in opt @ extra_args else extra_args in let pp_str = Format.pp_print_string in let string_of_supp_args includes defines extra = Format.asprintf "%a%a%a" (Pretty_utils.pp_list ~pre:" -I" ~sep:" -I" ~empty:"" pp_str) includes (Pretty_utils.pp_list ~pre:" -D" ~sep:" -D" ~empty:"" pp_str) defines (Pretty_utils.pp_list ~pre:" " ~sep:" " ~empty:"" pp_str) extra in let supp_args = string_of_supp_args include_args define_args (extra_args @ Kernel.CppExtraArgs.get () @ supported_cpp_arch_args) in if Kernel.is_debug_key_enabled dkey_pp then Kernel.feedback ~dkey:dkey_pp "@{preprocessing@} with \"%s %s %s\"" cmdl supp_args f; Kernel.feedback "Parsing %s (with preprocessing)" (Filepath.pretty f); let cpp_command = build_cpp_cmd cmdl supp_args f ppf in if Sys.command cpp_command <> 0 then begin safe_remove_file 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\"." cpp_command end; let ppf = if Kernel.ReadAnnot.get() && ((Kernel.PreprocessAnnot.is_set () && Kernel.PreprocessAnnot.get()) || (match is_gnu_like with | Gnu -> true | Not_gnu -> false | Unknown -> Kernel.warning ~once:true "trying to preprocess annotation with an unknown \ preprocessor."; true)) then begin let pp_annot_supp_args = Format.asprintf "-nostdinc %a" (Pretty_utils.pp_list ~sep:" " Format.pp_print_string) supported_cpp_arch_args in let ppf' = try Logic_preprocess.file ".c" (build_cpp_cmd cmdl pp_annot_supp_args) ppf with Sys_error _ as e -> safe_remove_file 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 Kernel.feedback "Parsing %s (external front-end)" (Filepath.pretty f); Hashtbl.find check_suffixes suf f with Not_found -> Kernel.abort "could not find a suitable plugin for parsing %s." f let to_cil_cabs f = try let a,c = parse_cabs f in Kernel.debug ~dkey:dkey_print_one "result of parsing %s:@\n%a" (get_name f) Cil_printer.pp_file a; if Errorloc.had_errors () then raise Exit; a, c with exn when Errorloc.had_errors () -> if Kernel.Debug.get () >= 1 then raise exn else Kernel.abort "@[stopping on@ file %S@ that@ has@ errors.%t@]" (get_name f) (fun fmt -> if Filename.check_suffix (get_name f) ".c" && not (Kernel.is_debug_key_enabled dkey_pp) then Format.fprintf fmt "@ Add@ '-kernel-msg-key pp'@ \ for preprocessing command.") let () = let handle f = let preprocess = build_cpp_cmd (fst (get_preprocessor_command ())) "-nostdinc" in let ppf = try Logic_preprocess.file ".c" preprocess f with Sys_error _ as e -> Kernel.abort "preprocessing of annotations failed (%s)" (Printexc.to_string e) in let (cil,(_,defs)) = Frontc.parse ppf () in cil.fileName <- f; safe_remove_file ppf; (cil,(f,defs)) in new_file_type ".ci" handle (** 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 | GFun({svar = v; sspec = spec},_) | GFunDecl(spec,v,_) -> Kernel.MainFunction.get_plain_string () = v.vname (* Always keep the declaration of the entry point *) || (specs && not (is_empty_funspec spec)) (* and the declarations carrying specifications according to the command line.*) | _ -> false let files_to_cabs_cil files = Kernel.feedback ~level:2 "parsing"; (* Parsing and merging must occur in the very same order. Otherwise the order of files on the command line will not be consistently handled. *) let cil_cabs = List.fold_left (fun acc f -> to_cil_cabs f :: acc) [] files in let cil_files, cabs_files = List.split cil_cabs in (* fold_left reverses the list order. This is an issue with pre-registered files. *) let cil_files = List.rev cil_files in let cabs_files = List.rev cabs_files in Ast.UntypedFiles.set cabs_files; (* Clean up useless parts in each file *) Kernel.feedback ~level:2 "cleaning unused parts"; (* 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)) cil_files; (* Perform symbolic merge of all files *) Kernel.feedback ~level:2 "symbolic link"; let merged_file = Mergecil.merge cil_files "whole_program" in (* Tidy up resulting files; in particular remove unused globals *) Logic_utils.complete_types merged_file; Rmtmps.removeUnusedTemps ~isRoot:keep_entry_point merged_file; if Kernel.UnspecifiedAccess.get () then Undefined_sequence.check_sequences merged_file; merged_file, cabs_files (* "Implicit" annotations are those added by the kernel with ACSL name 'Frama_C_implicit_init'. Currently, this concerns statements that are generated to initialize local variables. *) module Implicit_annotations = State_builder.Set_ref (Property.Set) (struct let name = "File.Implicit_annotations" let dependencies = [Annotations.code_annot_state] end) let () = Ast.add_linked_state Implicit_annotations.self let () = Property_status.register_property_remove_hook (fun p -> if Implicit_annotations.mem p then begin Kernel.debug ~dkey:dkey_annot "Removing implicit property %a" Property.pretty p; Implicit_annotations.remove p end) let emit_status p = Kernel.debug ~dkey:dkey_annot "Marking implicit property %a as true" Property.pretty p; Property_status.emit Emitter.kernel ~hyps:[] p Property_status.True let emit_all_statuses _ = Kernel.debug ~dkey:dkey_annot "Marking properties"; Implicit_annotations.iter emit_status let () = Ast.apply_after_computed emit_all_statuses 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 Implicit_annotations.add 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 = super#pop_stmt st; let father = super#current_stmt in super#push_stmt st; 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 st 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_annot,st) annot = if Logic_utils.is_contract annot then begin if has_annot 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; (true, st) 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 (!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 *) (match annot.annot_content with | AStmtSpec _ | APragma (Slice_pragma SPstmt | Impact_pragma IPstmt) -> (* Annotation relative to the effect of next statement *) add_user_annot_for_next_stmt annot | APragma _ | AAssert _ | AAssigns _ | AAllocation _ | AExtended _ | AInvariant _ | AVariant _ -> (* Annotation relative to the current control point *) (match !user_annots_for_next_stmt with | [] -> synchronize_user_annot annot | _ -> (* we have an annotation relative to the next real C statement somewhere above, and we have not reached it yet. Just stack the current annotation.*) add_user_annot_for_next_stmt 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; (* prepareCFG may add additional labels that are not used in the end. *) Rmtmps.remove_unused_labels fundec; end; Globals.Functions.add (Definition(fundec,loc)); | GFunDecl (spec, f,loc) -> (* 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 (vi,_) when not vi.vdefined -> (* 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 (* Remove (inplace) annotations that are physically in the AST (and that have been moved inside kernel tables) by turning them into Skip, then remove empty statements and blocks. *) 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) | _ -> 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 | GFunDecl(s,_,_) -> Logic_utils.clear_funspec s; DoChildren | GType _ | GCompTag _ | GCompTagDecl _ | GEnumTag _ | GEnumTagDecl _ | GVar _ | GVarDecl _ | 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 module Transform_before_cleanup = Hook.Build_ordered (struct module Id = Datatype.String type t = Cil_types.file end) module Transform_after_cleanup = Hook.Build_ordered (struct module Id = Datatype.String type t = Cil_types.file end) module Transform_after_parameter_change = Hook.Build_ordered (struct module Id = Datatype.String type t = State.t end) let transform_parameters = ref State.Set.empty type code_transformation_category = { name: string; before_id: Transform_before_cleanup.id; after_id: Transform_after_cleanup.id; prm_id: Transform_after_parameter_change.id } let register_code_transformation_category s = { name = s; before_id = Transform_before_cleanup.register_key s; after_id = Transform_after_cleanup.register_key s; prm_id = Transform_after_parameter_change.register_key s } let add_transform_parameter ~before ~after name f (p:(module Parameter_sig.S)) = let module P = (val p: Parameter_sig.S) in let hook self = (* hook is launched if AST already exists and the apply was triggered by the corresponding option change *) if State.equal self P.self && Ast.is_computed () then begin Kernel.feedback ~dkey:dkey_transform "applying %s to current AST, after option %s changed" name.name P.option_name; f (Ast.get()); if Kernel.Check.get () then Filecheck.check_ast ("after code transformation: " ^ name.name ^ " triggered by " ^ P.option_name) end in (* P.add_set_hook must be done only once. *) if not (State.Set.mem P.self !transform_parameters) then begin transform_parameters:=State.Set.add P.self !transform_parameters; P.add_set_hook (fun _ _ -> Transform_after_parameter_change.apply P.self) end; Transform_after_parameter_change.extend name.prm_id hook; List.iter (fun b -> Transform_after_parameter_change.add_dependency name.prm_id b.prm_id) before; List.iter (fun a -> Transform_after_parameter_change.add_dependency a.prm_id name.prm_id) after module Cfg_recomputation_queue = State_builder.Set_ref(Cil_datatype.Fundec.Set) (struct let name = "File.Cfg_recomputation_queue" let dependencies = [Ast.self] end) let () = Ast.add_linked_state Cfg_recomputation_queue.self let must_recompute_cfg f = Cfg_recomputation_queue.add f let recompute_cfg _ = (* just in case f happens to modify the CFG *) Cfg_recomputation_queue.iter (fun f -> Cfg.clearCFGinfo ~clear_id:false f; Cfg.cfgFun f); Cfg_recomputation_queue.clear () let transform_and_check name is_normalized f ast = Kernel.feedback ~dkey:dkey_transform "applying %s to file:@\n%a" name Printer.pp_file ast; f ast; recompute_cfg (); if Kernel.Check.get () then begin Filecheck.check_ast ~is_normalized ~ast ("after code transformation: " ^ name); end let add_code_transformation_before_cleanup ?(deps:(module Parameter_sig.S) list = []) ?(before=[]) ?(after=[]) name f = Transform_before_cleanup.extend name.before_id (transform_and_check name.name false f); List.iter (fun b -> Transform_before_cleanup.add_dependency name.before_id b.before_id) before; List.iter (fun a -> Transform_before_cleanup.add_dependency a.before_id name.before_id) after; List.iter (add_transform_parameter ~before ~after name f) deps let add_code_transformation_after_cleanup ?(deps:(module Parameter_sig.S) list = []) ?(before=[]) ?(after=[]) name f = Transform_after_cleanup.extend name.after_id (transform_and_check name.name true f); List.iter (fun b -> Transform_after_cleanup.add_dependency name.after_id b.after_id) before; List.iter (fun a -> Transform_after_cleanup.add_dependency a.after_id name.after_id) after; List.iter (add_transform_parameter ~before ~after name f) deps let syntactic_constant_folding ast = if Kernel.Constfold.get () then Cil.visitCilFileSameGlobals (Cil.constFoldVisitor true) ast let constfold = register_code_transformation_category "constfold" let () = let deps = [ (module Kernel.Constfold: Parameter_sig.S) ] in add_code_transformation_after_cleanup ~deps constfold syntactic_constant_folding let prepare_cil_file ast = Kernel.feedback ~level:2 "preparing the AST"; computeCFG ~clear_id:true ast; if Kernel.Check.get () then begin Filecheck.check_ast ~is_normalized:false ~ast "initial AST" end; Kernel.feedback ~level:2 "First check done"; if Kernel.Orig_name.get () then begin Cil.visitCilFileSameGlobals print_renaming ast end; Transform_before_cleanup.apply ast; (* Compute the list of functions and their CFG *) Rmtmps.removeUnusedTemps ~isRoot:keep_entry_point ast; if Kernel.Check.get () then begin Filecheck.check_ast ~is_normalized:false ~ast "Removed temp vars" end; (try List.iter register_global ast.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"; (* 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 ast; Cfg.computeFileCFG ast; 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 ast; Cfg.computeFileCFG ast; end; cleanup ast; Ast.set_file ast; (* Check that normalization is correct. *) if Kernel.Check.get() then begin Filecheck.check_ast ~ast "AST after normalization"; end; Globals.Functions.iter Annotations.register_funspec; Transform_after_cleanup.apply ast; (* reset tables depending on AST in case they have been computed during the transformation. *) Ast.set_file ast 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_union (List.map 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) 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 end in let globs = (Ast.get()).globals in try List.iter (fun g -> match g with | GAnnot (ga,_) -> if List.exists (fun li' -> Logic_info.equal li li') (extract_logic_infos ga) 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.nb_vertex logic_info_deps = 0 then [] else if Global_annotation_graph.has_cycle logic_info_deps then begin (* Assumption: elements from the stdlib are not part of a cycle with others logic functions, i.e. the stdlib is well-formed. *) let entries = Global_annotation_graph.fold (fun g acc -> let stdlib = Cil.findAttribute "fc_stdlib" (Cil_datatype.Global.attr g) in let key = match stdlib with | [ AStr s ] -> s | _ -> "" in let elts = try Datatype.String.Map.find key acc with Not_found -> [] in Datatype.String.Map.add key (g::elts) acc ) logic_info_deps Datatype.String.Map.empty in Datatype.String.Map.fold (fun k l res -> let attr = if k = "" then [] else [ Attr("fc_stdlib", [AStr k])] in let entries = List.fold_left (fun acc g -> match g with GAnnot (g,_) -> g :: acc | _ -> acc) [] l in (GAnnot (Daxiomatic (unique_name_recursive_axiomatic (), entries, attr, Location.unknown), Location.unknown))::res) entries [] end else begin Global_annotation_graph.fold (fun ga acc -> 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 if Cil.isFunctionType vi.vtype then self#add_needed_decl (GFunDecl (Cil.empty_funspec(),vi,vi.vdecl)) else self#add_needed_decl (GVarDecl (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) 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_node 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,_,_) | GFun({svar = vi},_) | GFunDecl (_,vi,_) -> self#add_known_var vi | GAsm _ | GPragma _ | GText _ -> () | GAnnot (ga,_) -> Stack.push g current_annot; self#add_known_annots ga; 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,_) | GFunDecl (_, vi, _) when Varinfo.Set.mem vi acc.varinfos -> acc | GVarDecl(vi,_) -> { acc with varinfos = Varinfo.Set.add vi acc.varinfos; others = g :: acc.others } | GVar _ | GFun _ | GFunDecl _ -> { 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_custom_ast ast = Visitor.visitFramacFile (new reorder_ast) ast; Remove_spurious.process ast let reorder_ast () = reorder_custom_ast (Ast.get()) (* Fill logic tables with builtins *) let init_cil () = Cil.initCIL (Logic_builtin.init()) (get_machdep ()); Logic_env.Builtins.apply (); Logic_env.prepare_tables () let prepare_from_c_files () = init_cil (); let files = Files.get () in (* Allow pre-registration of prolog files *) let cil, cabs_files = files_to_cabs_cil files in prepare_cil_file cil; (* prepare_cil_file may call syntactic transformers, that will ultimately reset the untyped AST. Restore it here. *) Ast.UntypedFiles.set cabs_files 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 old_ast = Ast.get () in let ast = visitFramacFileCopy vis old_ast in let finalize ast = computeCFG ~clear_id:false ast; Ast.set_file ast in let selection = State_selection.with_dependencies Ast.self in Project.on ~selection prj finalize ast; (* reorder _before_ check. *) if reorder then Project.on prj reorder_ast (); if Kernel.Check.get() then begin let name = prj.Project.name in Kernel.debug ~dkey:dkey_print_one "Check for project %s" name; Project.on prj (Filecheck.check_ast ~ast) ("AST of " ^ name); assert (Kernel.verify (old_ast == Ast.get()) "Creation of project %s modifies original project" name); Filecheck.check_ast ("Original AST after creation of " ^ name) 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 ?(last=true) prj_name visitor = let selection = State_selection.list_union (List.map 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 ~last prj_name in (* reset projectified parameters to their default values *) let temp = Project.create "File.temp" in Project.copy ~selection:(Parameter_state.get_reset_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.Copy.get () then begin let selection = State_selection.diff State_selection.full (State_selection.list_union (List.map 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 ~last:false "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.Check.get () then begin Filecheck.check_ast "Copy of original AST" end; if Kernel.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 ?last ?(preprocess=false) prj_name visitor = let prj = create_project_from_visitor ?reorder ?last 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-Phosphorus-20170501/src/kernel_services/ast_queries/file.mli0000644000175000017500000002652113113745004024313 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. *) (** Whether a given preprocessor supports gcc options used in some configurations. *) type cpp_opt_kind = Gnu | Not_gnu | Unknown type file = | NeedCPP of string * string * cpp_opt_kind (** 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]. @plugin development guide *) val new_machdep: string -> Cil_types.mach -> 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" my_machdep_implem)] @since Nitrogen-20111001 @modify Fluorine-20130401 Receives the machdep (as a module) as argument @modify Sodium-20150201 Receives directly the machdep as argument @raise Invalid_argument if the given name already exists @plugin development guide *) val machdep_macro: string -> string (** [machdep_macro machine] returns the name of a macro __FC_MACHDEP_XXX so that the preprocessor can select std lib definition consistent with the selected machdep. This function will emit a warning if [machine] is not known by default by the kernel and return __FC_MACHDEP_MACHINE in that case. @since Magnesium-20151001 (exported in the API) *) type code_transformation_category (** type of registered code transformations @since Neon-20140301 *) val register_code_transformation_category: string -> code_transformation_category (** Adds a new category of code transformation *) val add_code_transformation_before_cleanup: ?deps:(module Parameter_sig.S) list -> ?before:code_transformation_category list -> ?after:code_transformation_category list -> code_transformation_category -> (Cil_types.file -> unit) -> unit (** [add_code_transformation_before_cleanup name hook] adds an hook in the corresponding category that will be called during the normalization of a linked file, before clean up and removal of temps and unused declarations. If this transformation involves changing statements of a function [f], [f] must be flagged with {!File.must_recompute_cfg}. The optional [before] (resp [after]) categories indicates that current transformation must be executed before (resp after) the corresponding ones, if they exist. In case of dependencies cycle, an arbitrary order will be chosen for the transformations involved in the cycle. The optional [deps] argument gives the list of options whose change (e.g. after a [-then]) will trigger the transformation over the already computed AST. If several transformations are triggered by the same option, their relative order is preserved. At this level, globals and ACSL annotations have not been registered. @since Neon-20140301 @plugin development guide *) val add_code_transformation_after_cleanup: ?deps:(module Parameter_sig.S) list -> ?before:code_transformation_category list -> ?after:code_transformation_category list -> code_transformation_category -> (Cil_types.file -> unit) -> unit (** Same as above, but the hook is applied after clean up. At this level, globals and ACSL annotations have been registered. If the hook adds some new globals or annotations, it must take care of adding them in the appropriate tables. Note that it is the responsibility of the hook to use {!Ast.mark_as_changed} or {!Ast.mark_as_grown} whenever it is the case. @since Neon-20140301 @plugin development guide *) val constfold: code_transformation_category (** category for syntactic constfolding (done after cleanup) @since Silicon-20161101 *) val must_recompute_cfg: Cil_types.fundec -> unit (** [must_recompute_cfg f] must be called by code transformation hooks when they modify statements in function [f]. This will trigger a recomputation of the cfg of [f] after the transformation. @since Neon-20140301 @plugin development guide *) 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 * cpp_opt_kind (** 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} *) (* ************************************************************************* *) 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 -> ?last: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]). If [last] is [true] (by default), remember than the returned project is the last created one. 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 @modify Sodium-20150201 added [last] optional argument @plugin development guide *) val create_rebuilt_project_from_visitor: ?reorder:bool -> ?last: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. Note 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 *) val reorder_custom_ast: Cil_types.file -> unit (** @since Neon-20140301 *) (* ************************************************************************* *) (** {2 Pretty printing} *) (* ************************************************************************* *) val pretty_machdep : ?fmt:Format.formatter -> ?machdep:Cil_types.mach -> unit -> unit (** Prints the associated [machdep], or the current one in current project by default. Default output formatter is [Log.print_on_output]. *) 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-Phosphorus-20170501/src/kernel_services/ast_queries/logic_const.mli0000644000175000017500000002506313113745003025676 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* 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 constructors 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 : code_annotation_node -> 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 (** set fresh id to properties of an existing funspec @since Sodium-20150201 *) val refresh_spec: funspec -> funspec (** creates a new identified predicate with a fresh id. *) val new_predicate: predicate -> 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 (** 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 (** @since Sodium-20150201 *) val init_label: logic_label (* ************************************************************************** *) (** {2 Predicates} *) (* ************************************************************************** *) (** makes a predicate with no name. Default location is unknown.*) val unamed: ?loc:location -> predicate_node -> predicate (** \true *) val ptrue: predicate (** \false *) val pfalse: predicate (** \old *) val pold: ?loc:location -> predicate -> predicate (** application of predicate*) val papp: ?loc:location -> logic_info * (logic_label * logic_label) list * term list -> predicate (** && *) val pand: ?loc:location -> predicate * predicate -> predicate (** || *) val por: ?loc:location -> predicate * predicate -> predicate (** ^^ *) val pxor: ?loc:location -> predicate * predicate -> predicate (** ! *) val pnot: ?loc:location -> predicate -> predicate (** Folds && over a list of predicates. *) val pands: predicate list -> predicate (** Folds || over a list of predicates. *) val pors: predicate list -> predicate (** local binding *) val plet: ?loc:location -> logic_info -> predicate -> predicate (** ==> *) val pimplies : ?loc:location -> predicate * predicate -> predicate (** ? : *) val pif: ?loc:location -> term * predicate * predicate -> predicate (** <==> *) val piff: ?loc:location -> predicate * predicate -> predicate (** Binary relation. @plugin development guide *) val prel: ?loc:location -> relation * term * term -> predicate (** \forall *) val pforall: ?loc:location -> quantifiers * predicate -> predicate (** \exists *) val pexists: ?loc:location -> quantifiers * predicate -> predicate (** \fresh(pt,size) *) val pfresh: ?loc:location -> logic_label * logic_label * term * term -> predicate (** \allocable *) val pallocable: ?loc:location -> logic_label * term -> predicate (** \freeable *) val pfreeable: ?loc:location -> logic_label * term -> predicate (** \valid_read *) val pvalid_read: ?loc:location -> logic_label * term -> predicate (** \valid *) val pvalid: ?loc:location -> logic_label * term -> predicate (** \valid_function *) val pvalid_function: ?loc:location -> term -> predicate (** \initialized *) val pinitialized: ?loc:location -> logic_label * term -> predicate (** \dangling *) val pdangling: ?loc:location -> logic_label * term -> predicate (** \at *) val pat: ?loc:location -> predicate * logic_label -> predicate (** \valid_index: requires index having integer type or set of integers *) val pvalid_index: ?loc:location -> logic_label * term * term -> predicate (** \valid_range: requires bounds having integer type *) val pvalid_range: ?loc:location -> logic_label * term * term * term -> predicate (** subtype relation *) val psubtype: ?loc:location -> term * term -> predicate (** \separated *) val pseparated: ?loc:location -> term list -> predicate (* ************************************************************************** *) (** {2 Logic types} *) (* ************************************************************************** *) (** returns [true] if the type is a set. @since Aluminium-20160501 *) val is_list_type: logic_type -> bool (** [make_type_list_of t] returns the type list<[t]>. @since Aluminium-20160501 *) val make_type_list_of: logic_type -> logic_type (** returns the type of elements of a list type. @raise Failure if the input type is not a list type. @since Aluminium-20160501 *) val type_of_list_elem: logic_type -> logic_type (** returns [true] if the type is a set. @since Neon-20140301 *) val is_set_type: logic_type -> bool (** [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 *) val boolean_type: logic_type (** @since Sodium-20150201 *) (* ************************************************************************** *) (** {1 Logic Terms} *) (* ************************************************************************** *) (** returns a anonymous term of the given type. *) val term : ?loc:Location.t -> term_node -> logic_type -> term (** & @deprecated Neon-20130301 {!Logic_utils.mk_AddrOf} is easier to use.*) 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 (** string constant *) val tstring: ?loc:Location.t -> string -> 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 (** coercion to the given logic type *) val tlogic_coerce: ?loc:Location.t -> term -> logic_type -> 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-Phosphorus-20170501/src/kernel_services/ast_queries/filecheck.mli0000644000175000017500000000504613113745006025312 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 performs various consistency checks over a cil file. Code may vary depending on current development of the kernel and/or identified bugs. *) val check_ast: ?is_normalized:bool -> ?ast:Cil_types.file -> string -> unit (** Visits the given AST (defaults to the AST of the current project) to check whether it is consistent. Use a non-default [ast] argument at your own risks. Note that the check is only partial. @since Aluminium-20160501 @modify Silicon-20161101 adds optional ast argument *) module type Extensible_checker = sig class check: ?is_normalized:bool -> string -> Visitor.frama_c_visitor end (** Allows to register an extension to current checks. The function will be given as input the current state of the checker. @since Phosphorus-20170501-beta1 *) val extend_checker: ((module Extensible_checker) -> (module Extensible_checker)) -> unit (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_queries/logic_typing.ml0000644000175000017500000047304613113745011025720 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* 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 add_offset_lval = Kernel.deprecated "Logic_typing.add_offset_lval" ~now:"Logic_const.addTermOffsetLval" Logic_const.addTermOffsetLval let loc_join (b,_) (_,e) = (b,e) let unescape s = Logic_lexer.chr (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 String.get 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 String.get 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 String.get 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 String.get s !i with | '\\' -> incr i; treat_escape_sequence () | c -> res := Int64.of_int (Char.code c)::!res; incr i done; List.rev (!res) let type_of_list_elem t = Logic_const.type_of_list_elem (unroll_type t) let is_list_type t = Logic_const.is_list_type (unroll_type t) let type_of_set_elem t = Logic_const.type_of_element (unroll_type t) let is_set_type t = Logic_const.is_set_type (unroll_type t) let plain_mk_mem ?loc t ofs = match t.term_node with | TAddrOf lv -> Logic_const.addTermOffsetLval ofs lv | TStartOf lv -> Logic_const.addTermOffsetLval (TIndex (Cil.lzero ?loc (), ofs)) lv | _ -> TMem t, ofs let optimize_comprehension term = (* [term] is equal to {t | \subset(x, set)}. We are trying to get rid of the comprehension by lifting the operations done in [t] over it. *) let lift_operation_above_subset set x t = let loc = set.term_loc in (* Auxiliary function that maps [f] over [set], providing [set] is an lvalue. The other cases are too complex. *) let lval_term f = match set.term_node with | TLval lv -> f lv | _ -> term in let lval f typ = lval_term (fun lv -> Logic_const.term ~loc (f lv) typ) in let is_x y = Cil_datatype.Logic_var.equal x y in let set_type = make_set_type t.term_type in match t.term_node with | TLval (TVar y, TNoOffset) when is_x y -> set (* { x | \subset(x, set) } -> set *) | TLval (TVar y, o) when is_x y -> (* { x.o | \subset(x, set) } -> set.o *) lval (fun lv -> TLval (Logic_const.addTermOffsetLval o lv)) set_type | TLval (TMem { term_node = TLval (TVar y, TNoOffset)},o2) when is_x y -> (* { *(x+o2) | \subset(x, set) } -> *(set+o2) *) Logic_const.term ~loc (TLval (plain_mk_mem ~loc set o2)) set_type | TLval (TMem { term_node = TLval (TVar y, o1); term_type = ty},o2) when is_x y -> (* { (x+o1)->o2 | subset(x, set) } -> (set+o1)->o2*) lval (fun lv -> TLval (plain_mk_mem ~loc (Logic_const.term ~loc (TLval (Logic_const.addTermOffsetLval o1 lv)) (make_set_type ty)) o2)) set_type | TLval (TMem { term_node = TBinOp(op, { term_node = TLval (TVar y, o1); term_type = ty }, shift)},o2) when is_x y -> (* {(op(x+o1, shift))->o2} -> (op(set+o1, shift))->o2 *) let inner_set_type = make_set_type ty in lval (fun lv -> TLval (TMem( Logic_const.term ~loc (TBinOp( op, Logic_const.term ~loc (TLval (Logic_const.addTermOffsetLval o1 lv)) inner_set_type, shift)) inner_set_type),o2)) set_type | TUnOp (op, { term_node = TLval(TVar y,TNoOffset)}) when is_x y -> (* { op(x) | \subset(x, set) } -> op(set) *) Logic_const.term ~loc (TUnOp(op,set)) set_type | TBinOp(op,{term_node = TLval(TVar y, TNoOffset)},t2) when is_x y -> (* { op(x, t2) | \subset(x, set) } -> op(set, t2) *) Logic_const.term ~loc (TBinOp(op,set,t2)) set_type | TBinOp(op,t1,{term_node = TLval(TVar y, TNoOffset)}) when is_x y -> (* { op(t1, x) | \subset(x, set) } -> op(t1, x) *) Logic_const.term ~loc (TBinOp(op,t1,set)) set_type | TAddrOf (TVar y, o) when is_x y -> (* { &x->o | \subset(x, set) } -> &set->o *) lval_term (fun lv -> Logic_utils.mk_logic_AddrOf ~loc (Logic_const.addTermOffsetLval o lv) (Cil.typeTermOffset set.term_type o)) | TStartOf (TVar y,o) when is_x y -> (* { &x[0]->o | \subset(x, set) } -> &set[0]->o *) lval_term (fun lv -> let lv = Logic_const.addTermOffsetLval o lv in let ty = Cil.typeOfTermLval lv in Logic_utils.mk_logic_StartOf (Logic_const.term ~loc (TLval lv) ty)) | TLogic_coerce(lt,{ term_node = TLval(TVar y,TNoOffset)}) when is_x y -> (* { (lt)x | \subset(x, set) } -> (lt set)set *) { t with term_node = TLogic_coerce(Logic_const.make_set_type lt,set); term_type = Logic_const.make_set_type lt } | _ -> term in match term.term_node with | Tcomprehension (t, [x], Some { pred_content = Papp({l_var_info = {lv_name="\\subset"}},[],[elt;set]) }) -> (match elt.term_node with | TLogic_coerce (_, { term_node = TLval(TVar y, TNoOffset) }) when Cil_datatype.Logic_var.equal x y -> lift_operation_above_subset set x t | _ -> term) | _ -> term (* apply a function meant to operate on plain types to a possible set. *) 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 (* coercion from a set to another set: keep the current coercion over the result of the transformation. *) | TLogic_coerce(set,t1) when is_set_type set && is_set_type t1.term_type -> let res = aux t1 in { loc with term_node = TLogic_coerce(set, res) } (* coercion from a singleton to a set: performs the transformation. *) | TLogic_coerce(oset, t1) when is_set_type oset -> let t = f t1 in let nset = make_set_type t.term_type in (* performs the coercion into a set. *) let singleton_coerce = { t with term_node = TLogic_coerce(nset, t); term_type = nset } in (* see whether we have to coerce the set type itself. *) if is_same_type oset nset then singleton_coerce else { loc with term_node = TLogic_coerce(oset, singleton_coerce) } (* if we a term of type set, try to apply f to each element of x by using a comprehension, and see whether we can get rid of said comprehension afterwards. *) | _ when is_set_type loc.term_type -> let elt_type = type_of_set_elem loc.term_type in let x = Cil_const.make_logic_var_quant "_x" elt_type in let t = Logic_const.tvar ~loc:loc.term_loc x in let sub = Logic_env.find_all_logic_functions "\\subset" in (* only one \subset function *) let sub = List.hd sub in let t2 = Logic_const.tvar ~loc:loc.term_loc x in let t2 = Logic_const.term ~loc:loc.term_loc (TLogic_coerce (loc.term_type,t2)) loc.term_type in let p = Logic_const.papp ~loc:loc.term_loc (sub, [], [t2;loc]) in let c = { loc with term_node = Tcomprehension(t,[x],Some p) } in let res = aux c in optimize_comprehension res (* plain term: apply the function directly. *) | _ -> 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 = FCMap.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_init_label env = Lenv.add_logic_label "Init" Logic_const.init_label env 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_init_label env 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 type_namespace = Typedef | Struct | Union | Enum module Type_namespace = Datatype.Make(struct include Datatype.Serializable_undefined let reprs = [Typedef] let name = "Logic_typing.type_namespace" type t = type_namespace let compare : t -> t -> int = Pervasives.compare let equal : t -> t -> bool = (=) let hash : t -> int = Hashtbl.hash end) 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_field: compinfo -> string -> offset; find_type : type_namespace -> 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; silent: bool; type_predicate: typing_context -> Lenv.t -> Logic_ptree.lexpr -> predicate; type_term: typing_context -> Lenv.t -> Logic_ptree.lexpr -> term; type_assigns: typing_context -> accept_formal:bool -> Lenv.t -> Logic_ptree.lexpr Cil_types.assigns -> identified_term Cil_types.assigns; error: 'a 'b. location -> ('a,formatter,unit,'b) format4 -> 'a } module Extensions = struct let typer_tbl = Hashtbl.create 5 let find_typer name = Hashtbl.find typer_tbl name let is_extension name = Hashtbl.mem 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 p = try let typ = find_typer name in typ ~typing_context ~loc p with Not_found -> Kernel.fatal ~source:(fst 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 ~current:true "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_fun_ptr typ = match unroll_type typ with | Ctype (TPtr(ty,_)) -> Cil.isFunctionType ty | _ -> false let is_arithmetic_type = plain_or_set plain_arithmetic_type let is_integral_type = plain_or_set plain_integral_type let is_fun_ptr = plain_or_set plain_fun_ptr 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 ~current:true "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 ~current:true "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) | _ -> Kernel.fatal ~current:true "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 ~current:true "type %a is not a pointer type" Cil_printer.pp_logic_type t 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_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_field: compinfo -> string -> offset val find_type : type_namespace -> 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 val error: location -> ('a,formatter,unit, 'b) format4 -> 'a end) = struct let make_typing_context ~pre_state ~post_state ~assigns_env ~type_predicate ~type_term ~type_assigns = { silent = false; 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_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 = C.error; } let add_logic_function loc li = let l = Logic_env.find_all_logic_functions li.l_var_info.lv_name in if List.exists (Logic_utils.is_same_logic_profile li) l then begin C.error loc "%s %s is already declared with the same profile" (match li.l_type with None -> "predicate" | Some _ -> "logic function") li.l_var_info.lv_name end else C.add_logic_function li let check_non_void_ptr loc ty = if Logic_utils.isLogicVoidPointerType ty then C.error loc "Cannot use a pointer to void here" let check_fun_ptr loc ty = let is_fun_ptr t = match Cil.unrollType t with | TPtr(t,_) when Cil.isFunctionType t -> true | _ -> false in if not (Logic_utils.isLogicType is_fun_ptr ty) then C.error loc "expecting a function pointer, found %a" Cil_datatype.Logic_type.pretty ty let check_object_ptr loc ty = let is_object_ptr t = match Cil.unrollType t with | TPtr(t,_) when not (Cil.isFunctionType t) -> true | _ -> false in if not (Logic_utils.isLogicType is_object_ptr ty) then C.error loc "expecting a pointer to an object, found %a" Cil_datatype.Logic_type.pretty ty 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 -> C.error loc "cannot find field %s" f) | _ -> C.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) | _ -> C.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 fresh_type_var name = fresh (Lvar name) 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 _) -> C.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_type Enum e) with Not_found -> C.error loc "no such enum %s" e) | LTstruct s -> (try Ctype (C.find_type Struct s) with Not_found -> C.error loc "no such struct %s" s) | LTunion u -> (try Ctype (C.find_type Union u) with Not_found -> C.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,[])) | [(_,arg_typ,_)] when isVoidType arg_typ -> (* Same invariant as in C *) Ctype (TFun(rt,Some [],false,[])) | _ -> Ctype (TFun(rt,Some prms,false,[]))) | LTnamed (id,[]) -> (try Lenv.find_type_var id env with Not_found -> try Ctype (C.find_type Typedef id) with Not_found -> try let info = C.find_logic_type id in if info.lt_params <> [] then C.error loc "wrong number of parameter for type %s" id else Ltype (info,[]) with Not_found -> C.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 C.error loc "wrong number of parameter for type %s" id else Ltype (info,List.map (logic_type loc env) l) with Not_found -> C.error loc "no such type %s" id) | LTinteger -> Linteger | LTreal -> Lreal | LTattribute (ty,attr) -> (* attributes can only qualify C types *) Ctype (Cil.typeAddAttributes [attr] (c_logic_type loc env ty)) and c_logic_type loc env t = match logic_type loc env t with | Ctype t -> t | Ltype _ | Linteger | Lreal | Lvar _ | Larrow _ -> C.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 (Logic_const.addTermOffsetLval 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.pred_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) | Pvalid_function t | Pinitialized (_,t) | Pdangling (_, 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 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,_) -> C.error loc "Cannot take the address of model field %s" mf.mi_name | TField(fi,_) -> fi.faddrof <- true end; Logic_utils.mk_logic_AddrOf ~loc lval t.term_type (* 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 rec c_mk_cast ?(force=false) e oldt newt = if is_same_c_type oldt newt then begin if force then Logic_utils.mk_cast ~loc:e.term_loc ~force newt e else e end else begin (* Watch out for constants *) if isPointerType newt && isLogicNull e && not (isLogicZero e) then (* \null can have any pointer type, see ACSL manual. *) { e with term_type = Ctype newt } else if isPointerType newt && isArrayType oldt && is_C_array e then begin let e = mk_logic_StartOf e in let oldt = Logic_utils.logicCType e.term_type in (* we have converted from array to ptr, but the pointed type might differ. Just do another round of conversion. *) c_mk_cast e oldt newt end else begin 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 ~force newt e).term_node; term_type = Ctype newt } end 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_compatible_funtype ty1 ty2 = if is_same_c_type ty1 ty2 then true else begin let rt1, _, variadic1, _ = Cil.splitFunctionType ty1 in let rt2, args2, _, _ = Cil.splitFunctionType ty2 in if not (is_same_c_type rt1 rt2) then false else begin (* types are not identical: they can only be compatible if args2 are not specified and variadic1 is false. *) match args2 with | Some _ -> false | None -> not variadic1 end end 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)) || (is_function_pointer ctyp2 && is_function_pointer ctyp1 && is_compatible_funtype (typeOf_pointed ctyp1) (typeOf_pointed ctyp2)) 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) } | _ when Cil.isLogicArithmeticType t -> Logic_utils.numeric_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 logic_coerce (make_set_type t.term_type) t else if isLogicVoidType ptd_type then C.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"},[_]), Ltype({lt_name="set"},[ty2]) -> let e = lift_set (fun e -> mk_cast e ty2) e in { e with term_type = make_set_type e.term_type} | _ , Ltype({lt_name = "set"},[ ty2 ]) -> let e = mk_cast e ty2 in logic_coerce (make_set_type e.term_type) e | 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 -> C.error loc "%s" s) | Linteger, Ctype _ | Lreal, Ctype _ -> C.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) -> C.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 -> C.error loc "invalid cast from real to integer. \ Use conversion functions instead" | Larrow (args1,_), Larrow(args2,rt2) -> (match e.term_node with | Tlambda (prms,body) when Logic_utils.is_same_list is_same_type args1 args2 -> (* specialized coercion of the body of the lambda instead of the whole expression. *) (* Might also want to specialize when the prms type are not the same, but this implies pushing logic coercions in the body for the newly typed parameters... *) let body = mk_cast body rt2 in { e with term_node = Tlambda(prms,body); term_type = newt } | _ -> logic_coerce newt e) | Ltype _, _ | _, Ltype _ | Lvar _,_ | _,Lvar _ | Larrow _,_ | _,Larrow _ -> C.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) | TPtr (t1,_), TPtr (t2,_) when Cil.isFunctionType t1 && Cil.isFunctionType t2 && is_compatible_funtype t1 t2 -> result | 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 if (isIntegralType ty1 && isIntegralType ty2) then begin let sz1 = bitsSizeOf ty1 in let sz2 = bitsSizeOf ty2 in if (sz1 < sz2 || (sz1 = sz2 && (isSignedInteger ty1 = isSignedInteger ty2)) || is_enum_cst oterm nt) then begin let t, e = c_cast_to ty1 ty2 oterm in Ctype t,e end else if overloaded then raise Not_applicable else C.error loc "invalid implicit conversion from '%a' to '%a'" Cil_printer.pp_typ ty1 Cil_printer.pp_typ ty2 end else if 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 (* not overloaded: raise an error. *) isArrayType ty1 && isPointerType ty2 && is_same_c_type (typeOf_array_elem ty1) (typeOf_pointed ty2) then if Logic_utils.is_C_array oterm then C.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 C.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 C.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 C.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 C.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 C.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) | Ltype({lt_name = "\\list"} as lt, [t1]), Ltype({lt_name = "\\list"}, [t2]) -> let st = find_supertype ~overloaded loc t t1 t2 in Ltype(lt, [st]) | Ltype({lt_name = "set"} as set, [t1]), t2 | t1, Ltype({lt_name = "set"} as set, [t2]) -> let st = find_supertype ~overloaded loc t t1 t2 in Ltype(set, [st]) | 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 C.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 C.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) | Ltype ({lt_name = "\\list"},[t1]), Ltype ({lt_name = "\\list"},[t2]) -> let (env, ot, nt) = partial_unif ~overloaded loc term t1 t2 env in env, ot, make_type_list_of nt | t1, Ltype ({lt_name = "set"},[t2]) -> let (env, ot, nt) = partial_unif ~overloaded loc term t1 t2 env in env, ot, make_set_type nt | Ltype({lt_name = "set"}, [t1]), 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 C.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 ~current:true "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 ~current:true "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 ~current:true "logic integral promotion on non-integral type %a" Cil_printer.pp_logic_type t let mk_shift loc env idx t_elt t = let idx = mk_cast idx (integral_promotion idx.term_type) in let add_offset array idx = Logic_const.term ~loc (TLval (Logic_const.addTermOffsetLval (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 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_type_var "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 lty1 lty2 = match (unroll_type lty1), (unroll_type lty2) 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 (* comparing an enumerated constant with a value of type enum is done on enum, not on the underlying type. *) else if is_enum_cst t1 lty2 then lty2 else if is_enum_cst t2 lty1 then lty1 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 C.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 when is_integral_type t && name = Utf8_logic.boolean -> Ltype(C.find_logic_type Utf8_logic.boolean,[]) | 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 -> lty1 | Lvar s1, Lvar s2 when s1 = s2 -> lty1 | Linteger, Linteger -> Linteger | (Lreal | Linteger) , (Lreal | Linteger) -> Lreal | Ltype ({lt_name = "\\list"} as lt,[t1]), Ltype({lt_name="\\list"},[t2]) -> Ltype(lt,[aux t1 t2]) | 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]) | _ -> C.error loc "types %a and %a are not convertible" Cil_printer.pp_logic_type lty1 Cil_printer.pp_logic_type lty2 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 let typ = Ctype Cil.charPtrType in PointerConv, (if is_set_type ot then make_set_type typ else typ) 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 let list_conversion loc t ot nt env = if is_same_type ot nt then ot else if plain_integral_type ot && plain_integral_type nt then ot else if plain_arithmetic_type ot && plain_arithmetic_type nt then ot else let _,_,t = partial_unif ~overloaded:false loc t ot nt env in t let list_promotion typ = if plain_integral_type typ then Linteger else if plain_arithmetic_type typ then Lreal else typ let list_coercion typ t = if is_same_type typ t.term_type then t else logic_coerce typ 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 String.get 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 -> C.error loc "logic label `%s' not found" l let find_old_label loc env = try Lenv.find_logic_label "Old" env with Not_found -> C.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 C.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 _ -> C.error loc "wrong number of labels for %s" id let add_quantifiers loc ~kind 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_kind id kind 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 C.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 _ -> C.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(Logic_const.addTermOffsetLval 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 || C.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) } (* Updates recursive calls of a function that gets an implicit label during the type-checking of its body. We have to add said implicit label to the call itself to have a consistent AST, i.e. something like logic f{L}(...) = ... f{L}(...). In case of inductive predicates, the considered label is not the one given into the profile of the predicate, but the one given into the defined case, i.e. something like inductive P{...}(...) { case n{L}: .... P{L}(...) }. The visit must be done after the type-checking, as the implicit label may be added after the recursive call has been handled. *) let add_label info lab = let vis = object(self) val mutable curr_lab = lab inherit Cil.nopCilVisitor method! vterm_node t = match t with | Tapp(info',[],args) when Cil_datatype.Logic_info.equal info info' -> ChangeDoChildrenPost(Tapp(info,[lab, curr_lab], args),Extlib.id) | _ -> DoChildren method! vpredicate_node p = match p with | Papp(info',[],args) when Cil_datatype.Logic_info.equal info info' -> ChangeDoChildrenPost (Papp(info, [lab,curr_lab], args),Extlib.id) | _ -> DoChildren method private treat_ind_case (n,labs,t,p as ind) = match labs with | [ mylab ] -> let old = curr_lab in curr_lab <- mylab; let p' = Cil.visitCilPredicate self p in let res = if p' != p then (n, labs, t, p') else ind in curr_lab <- old; res | _ -> ind (* We do not have a context allowing to update the predicate. Implies that any recursive call is already explicitly guarded *) method! vlogic_info_decl info = match info.l_body with | LBinductive l -> let l' = Cil.mapNoCopy self#treat_ind_case l in if l != l' then info.l_body <- LBinductive l'; SkipChildren | _ -> DoChildren end in (* body will be changed in place by visitor if needed. *) ignore (Cil.visitCilLogicInfo vis info) (* In case we have added an implicit label in the environment during type-checking of the body of the logic function/predicate, we update the label list, and visit the body to ensure potential recursive calls are coherent with the declaration. *) let update_info_wrt_default_label info = match info.l_labels with | [] -> (match !Lenv.default_label with | None -> () | Some lab -> info.l_labels <- [ lab ]; add_label info lab ) | _ -> () let update_predicate_wrt_default_label p = match !Lenv.default_label with | None -> p | Some lab -> { p with pred_content = Pat(p,lab) } let update_ind_case_wrt_default_label (name, labs, tvars, p as case) = match labs, !Lenv.default_label with | [], Some lab -> (name, [lab], tvars, update_predicate_wrt_default_label p) | _ -> case type lval_mode = { accept_empty: bool; accept_formal: bool; accept_array: bool; accept_models: bool; accept_func_ptr: bool; } let lval_addressable_mode = { accept_empty = false; accept_formal = true; accept_array = true; accept_models = false; accept_func_ptr = true; } let lval_assignable_mode = { accept_empty = true; accept_formal = true; accept_array = false; accept_models = true; accept_func_ptr = false; } let is_fct_ptr lv = let t = Cil.typeOfTermLval lv in match Logic_utils.unroll_type ~unroll_typedef:true t with | Ctype (TFun _) -> true | _ -> false let check_lval_kind m t = let rec aux t = match t.term_node with | Tempty_set -> m.accept_empty | TLval (lhost,loff) -> (not (isLogicArrayType t.term_type) || m.accept_array) && (match lhost with | TVar v -> begin match v.lv_origin with | None -> (* specific case: \exit_status is a model of the exit status of the program. *) if Logic_const.is_exit_status t then m.accept_models else false (* pure logic variable, at least as long as model variables are not supported. *) | Some v -> not v.vformal || m.accept_formal end | TResult _ -> m.accept_models | _ -> true) && (match snd (Logic_utils.remove_term_offset loff) with | TModel _ -> m.accept_models | _ -> true) | TAddrOf lv -> is_fct_ptr lv && m.accept_func_ptr | Tif (_,t1,t2) -> aux t1 && aux t2 | Tunion l | Tinter l -> List.for_all aux l | TLogic_coerce (_,t) | Tat (t, _) | Tcomprehension (t,_,_) | Tlet (_, t) -> aux t | Trange _ | TConst _ | TSizeOf _ | TSizeOfE _ | TSizeOfStr _ | TAlignOf _ | TAlignOfE _ | TUnOp (_,_) | TBinOp (_,_,_) | TCastE (_,_) | TStartOf _ | Tlambda (_,_) | TDataCons (_,_) | Tbase_addr (_,_) | Toffset (_,_) | Tblock_length (_,_) | Tnull | Tapp _ | TCoerce (_,_) | TCoerceE (_,_) | TUpdate (_,_,_) | Ttypeof _ | Ttype _ -> false in aux t let 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 _) -> C.error loc "expecting a predicate and not a term" let rec normalize_update_term ctxt 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 _ -> if ctxt.silent then raise Backtrack; C.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 = ctxt.type_term ctxt env idx in updated_offset_term idx_typing is_integral_type mk_field mk_idx loc t_type toff in let v = ctxt.type_term ctxt 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 = ctxt.type_term ctxt env idx and normalizing_cont t2 = normalize_update_term ctxt env loc t2 v toffs in normalize_updated_offset_term idx_typing env loc t normalizing_cont toff end and normalize_update_cont ctxt 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 ctxt env loc t v (toffs@contoffs) | ((contoffs,PLupdateCont v)::[]),toffs -> (* {x \with .c1 = {\with .c2 = {\with...}}} = {x \with .c1.c2 = {\with...}} *) normalize_update_cont ctxt 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 = ctxt.type_term ctxt env idx in let normalizing_cont t2 = let normalize t = function | contoffs,PLupdateTerm v -> normalize_update_term ctxt env loc t v contoffs | contoffs,PLupdateCont cont -> normalize_update_cont ctxt 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 = ctxt.type_term ctxt env idx and normalizing_cont t2 = normalize_update_cont ctxt env loc t2 (cont,toffs) in normalize_updated_offset_term idx_typing env loc t normalizing_cont toff and locations_set ctxt ~lift_set env loc l init_type = let convert_ptr, locs, typ = List.fold_left (fun (convert_ptr,locs,typ) t -> let t' = ctxt.type_term ctxt env t in if (not lift_set) && is_set_type t'.term_type then begin if ctxt.silent then raise Backtrack; C.error loc "set of sets is not yet implemented" ; end; let convert_ptr, typ = location_set_conversion t'.term_loc convert_ptr t' t'.term_type typ env in assert (locs <> [] || convert_ptr = NoConv); (convert_ptr,t'::locs, typ)) (NoConv, [], init_type) l in let locs = List.rev_map (make_set_conversion convert_ptr) locs in locs,typ and lfun_app ctxt env loc f labels ttl = begin try let info = C.find_logic_ctor f in if labels <> [] then begin if ctxt.silent then raise Backtrack; C.error loc "symbol %s is a data constructor. \ It cannot have logic labels" f; end; 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 fresh_type_var 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 ctxt.silent then raise Backtrack; C.error loc "symbol %s is a predicate, not a function" f | Some t -> Tapp(info, label_assoc, tl), t end and term_node ctxt env loc pl = let term = ctxt.type_term ctxt in let predicate = ctxt.type_predicate ctxt in match pl with | PLinitIndex _ -> C.error loc "unsupported aggregated array construct" | PLinitField _ -> C.error loc "unsupported aggregated field construct" | PLupdate (t, toff, PLupdateCont cont) -> let t = term env t in normalize_update_cont ctxt env loc t (cont, toff) | PLupdate (t, toff, PLupdateTerm v) -> let t = term env t in normalize_update_term ctxt 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 | _ -> if ctxt.silent then raise Backtrack; C.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 | _ -> if ctxt.silent then raise Backtrack; C.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 let t = term env def in t.term_node, t.term_type 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 ctxt.silent then raise Backtrack; C.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 -> ()); (match info.lv_type with | Ctype(TFun _ as t) -> (* function decays as a pointer *) TAddrOf (TVar info, TNoOffset), Ctype (TPtr (t,[])) | _ -> 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 fresh_type_var info.ctor_type.lt_params) | _ -> C.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 -> Larrow (List.map (fun x -> x.lv_type) l, t) | None, _ -> if ctxt.silent then raise Backtrack; C.error loc "%s is not a logic variable" x in let typ = fresh typ 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 | _ -> C.error loc "%s labels must be explicitly instantiated" x in match C.find_all_logic_functions x with [] -> C.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 -> C.error loc "invalid use of overloaded function \ %s as constant" x) end | PLapp (f, labels, tl) -> let f = try (match (C.find_macro f).lexpr_node with | PLvar (x) -> x | _ -> C.error loc "invalid definition for macro %s" f) with Not_found -> f in let ttl = List.map (term env) tl in fresh_type#reset (); lfun_app ctxt env loc f labels ttl | PLunop (Ubw_not, t) -> let t = type_int_term ctxt env t in TUnOp (BNot, t), logic_arithmetic_promotion t.term_type | PLunop (Uminus, t) -> let t = type_num_term ctxt 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 C.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 env t in if not (check_lval_kind lval_addressable_mode t) then C.error t.term_loc "not an addressable left value: %a" Cil_printer.pp_term t; let t = term_lval (mkAddrOfAndMark loc) 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) | Bbw_xor when is_list_type ty1 && is_list_type ty2 -> fresh_type#reset (); lfun_app ctxt env loc "\\concat" [] [t1;t2] | 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 | _ -> C.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 C.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 C.error loc "subscript is not an integer range" else C.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 ctxt env t1 in let t2 = term env t2 in let t3 = term 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 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 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 C.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 C.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 C.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 ~current:true "\\result associated to non-C type" (* \\result is the value returned by a C function. It has always a C type *) with Not_found -> C.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 C.error loc "cannot cast logic array to pointer type"; (c_mk_cast ~force:true t told tnew).term_node , ctnew | _ -> (Logic_utils.mk_cast tnew t).term_node, ctnew) | Linteger | Lreal | Ltype _ | Lvar _ | Larrow _ -> C.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 _ -> C.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 f _ op t1 t2 = (TBinOp(binop_of_rel op, t1, t2), Ltype(C.find_logic_type Utf8_logic.boolean,[])) in type_relation ctxt env f t1 op t2 | 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 ~kind:LVFormal prms env in let e = term 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 ctxt env t in TUnOp(LNot,t), Ltype (C.find_logic_type Utf8_logic.boolean,[]) | PLand (t1,t2) -> let t1 = type_bool_term ctxt env t1 in let t2 = type_bool_term ctxt env t2 in TBinOp(LAnd,t1,t2), Ltype (C.find_logic_type Utf8_logic.boolean,[]) | PLor (t1,t2) -> let t1 = type_bool_term ctxt env t1 in let t2 = type_bool_term ctxt 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 _ -> C.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 env body in Tlet(var,tbody), tbody.term_type | PLcomprehension(t,quants,pred) -> let quants, env = add_quantifiers loc ~kind:LVQuant quants env in let t = term env t in if is_set_type t.term_type then begin C.error loc "sets of sets are not supported yet" end else begin let pred = Extlib.opt_map (predicate env) pred in Tcomprehension(t,quants,pred), (make_set_type t.term_type) end | PLempty | PLset [] -> fresh_type#reset(); let typ = make_set_type (fresh_type_var "_") in Tempty_set,typ | PLset l -> fresh_type#reset(); let typ = make_set_type (fresh_type_var "_") in let locs,typ = locations_set ctxt ~lift_set:false env loc l typ in Tunion locs, typ | PLunion l -> fresh_type#reset(); let typ = make_set_type (fresh_type_var "_") in let locs,typ = locations_set ctxt ~lift_set:true env loc l typ in Tunion locs, typ | PLinter l -> fresh_type#reset(); let typ = make_set_type (fresh_type_var "_") in let locs,typ = locations_set ctxt ~lift_set:true env loc l typ in Tinter locs, typ | PLlist l -> fresh_type#reset(); let empty_list,typ_items = let empty_list,typ = lfun_app ctxt env loc "\\Nil" [] [] in empty_list,(type_of_list_elem typ) in let l,typ_items = List.fold_left (fun (l,typ_items) t -> let t' = term env t in let typ_items' = list_conversion t'.term_loc t' typ_items t'.term_type env in (t'::l), typ_items') ([],typ_items) l in let typ_items = list_promotion typ_items in let add_ahead (tnode, typ) e = let t' = { term_node = tnode; term_loc=loc; term_type=typ; term_name = [] } in fresh_type#reset(); lfun_app ctxt env loc "\\Cons" [] [(list_coercion typ_items e);t'] in List.fold_left add_ahead (empty_list, (make_type_list_of typ_items)) l | PLrepeat (t1,t2) -> let t1 = term env t1 in let t2 = term env t2 in fresh_type#reset (); lfun_app ctxt env loc "\\repeat" [] [t1; t2] | PLrange (t1,t2) -> (* we allow range of floats/real. *) let t1,ty1 = type_num_term_option ctxt env t1 in let t2,ty2 = type_num_term_option ctxt env t2 in (Trange(t1,t2), Ltype(C.find_logic_type "set", [arithmetic_conversion ty1 ty2])) | PLvalid _ | PLvalid_read _ | PLvalid_function _ | PLfresh _ | PLallocable _ | PLfreeable _ | PLinitialized _ | PLdangling _ | PLexists _ | PLforall _ | PLimplies _ | PLiff _ | PLxor _ | PLsubtype _ | PLseparated _ -> if ctxt.silent then raise Backtrack; C.error loc "syntax error (expression expected but predicate found)" and type_relation: 'a. _ -> _ -> (_ -> _ -> _ -> _ -> 'a) -> _ -> _ -> _ -> 'a = fun ctxt env f t1 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 = ctxt.type_term ctxt env t1 in let ty1 = t1.term_type in let t2 = ctxt.type_term ctxt 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 f loc op (mk_cast t1 t) (mk_cast t2 t) in begin 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 let t2 = (* in case of a set, we perform two conversions: first from integer to pointer, then from pointer to set of pointer. *) if is_set_type t1.term_type then mk_cast t2 (type_of_set_elem t1.term_type) else t2 in f loc op t1 (mk_cast t2 t1.term_type) | Eq | Neq when isLogicPointer t2 && isLogicNull t1 -> let t2 = mk_logic_pointer_or_StartOf t2 in let t1 = if is_set_type t2.term_type then mk_cast t1 (type_of_set_elem t2.term_type) else t1 in f loc op (mk_cast t1 t2.term_type) t2 | Eq | Neq when isLogicArrayType ty1 && isLogicArrayType ty2 -> if is_same_logic_array_type ty1 ty2 then f loc op t1 t2 else C.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 f loc op t1 t2 else if (op=Eq || op = Neq) then conditional_conversion t1 t2 else C.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 | _ -> C.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 and term_lval f t = let check_lval t = match t.term_node with TLval lv | TLogic_coerce(_,{term_node = TLval lv }) | Tat({term_node = TLval lv},_) -> f lv t | TStartOf lv | Tat ({term_node = TStartOf lv}, _) -> f lv t | TAddrOf lv when is_fun_ptr t.term_type -> f lv { t with term_type = type_of_pointed t.term_type; term_node = TLval lv } | _ -> C.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 | [] -> C.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 C.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,(List.map (fun (t, e) -> mk_cast e t) z),t) | _ -> let tl = List.map (fun t -> t.term_type) ttl in C.error loc "ambiguous logic call to %s(%a)" f (Pretty_utils.pp_list ~sep:",@ " Cil_printer.pp_logic_type) tl and type_int_term ctxt env t = let tt = ctxt.type_term ctxt env t in if not (plain_integral_type tt.term_type) then C.error t.lexpr_loc "integer expected but %a found" Cil_printer.pp_logic_type tt.term_type; tt and type_bool_term ctxt env t = let tt = ctxt.type_term ctxt env t in if not (plain_boolean_type tt.term_type) then C.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 ctxt env t = match t with None -> None, Linteger (* Warning: should be an hybrid of integer and float. *) | Some t -> let t = type_num_term ctxt env t in Some t, t.term_type and type_num_term ctxt env t = let tt = ctxt.type_term ctxt env t in if not (is_arithmetic_type tt.term_type) then C.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, _,et' = instantiate_app ~overloaded tloc t et env in let env, l = type_list env (etl, tl) in env, et' :: l | [], _ -> if overloaded then raise Not_applicable else C.error loc "too many arguments" | _, [] -> if overloaded then raise Not_applicable else C.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 t = if overloaded then t else mk_cast t 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_to_predicate ctxt env p0 = boolean_term_to_predicate (ctxt.type_term ctxt env p0) and abstract_predicate ctxt env p0 = let loc = p0.lexpr_loc in match p0.lexpr_node with PLlambda (args,p) -> let (prms,env) = add_quantifiers loc ~kind:LVFormal args env in let other_prms, p = abstract_predicate ctxt env p in (other_prms @ prms), p | _ -> [], ctxt.type_predicate ctxt env p0 let term_lval_assignable ctxt ~accept_formal env t = let t = ctxt.type_term ctxt env t in if not (check_lval_kind { lval_assignable_mode with accept_formal } t) then C.error t.term_loc "not an assignable left value: %a" Cil_printer.pp_term t; lift_set (term_lval (fun _ t -> t)) t let term ctxt env t = match t.lexpr_node with | PLnamed(name,t) -> let t = ctxt.type_term ctxt env t in { t with term_name = name :: t.term_name } | _ -> let t', ty = term_node ctxt env t.lexpr_loc t.lexpr_node in { term_node = t'; term_loc=t.lexpr_loc; term_type=ty; term_name = [] } let predicate ctxt env p0 = let loc = p0.lexpr_loc in let predicate = ctxt.type_predicate ctxt in let term = ctxt.type_term ctxt in (* Auxiliary function for valid, valid_read, initialized and specified *) let predicate_label_non_void_ptr check fpred label t = let l = find_current_logic_label loc env label in let t = term env t in if not (isLogicPointer t) then C.error loc "%a is neither a pointer nor a C array" Cil_printer.pp_term t; let t = mk_logic_pointer_or_StartOf t in check_non_void_ptr t.term_loc t.term_type; check t.term_loc t.term_type; (* higher-order funs do not mix well with (optional) labels, hence the binding below. *) let loc = Some loc in fpred ?loc (l,t) 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 f loc op t1 t2 = prel ~loc (type_rel op, t1, t2) in type_relation ctxt env f t1 op t2 | PLand (p1, p2) -> pand ~loc (predicate env p1, predicate env p2) | PLor (p1, p2) -> por ~loc (predicate env p1, predicate env p2) | PLxor (p1, p2) -> pxor ~loc (predicate env p1, predicate env p2) | PLimplies (p1, p2) -> pimplies ~loc (predicate env p1, predicate env p2) | PLiff (p1, p2) -> piff ~loc (predicate env p1, predicate env p2) | PLnot p -> (match (predicate env p) with | {pred_content = Prel (Cil_types.Rneq, t, z)} when isLogicZero z -> prel ~loc (Cil_types.Req, t, Cil.lzero ~loc ()) | p -> pnot ~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 (info, label_assoc, tl) end | PLif (t, p1, p2) -> begin try let t = type_bool_term { ctxt with silent = true } env t in pif ~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 loc ~kind:LVQuant q env in pforall ~loc (q, predicate env' p) | PLexists (q, p) -> let q, env' = add_quantifiers loc ~kind:LVQuant q env in pexists ~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 C.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 (l1,l2,t,n) else C.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 begin let t = mk_logic_pointer_or_StartOf t in pfreeable ~loc (l,t) end else C.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 begin let t = mk_logic_pointer_or_StartOf t in pallocable ~loc (l,t) end else C.error loc "subscripted value is neither array nor pointer" | PLvalid_read (l, t) -> predicate_label_non_void_ptr check_object_ptr pvalid_read l t | PLvalid (l,t) -> predicate_label_non_void_ptr check_object_ptr pvalid l t | PLvalid_function t -> let t = term env t in if isLogicPointer t then begin check_fun_ptr loc t.term_type; let t = mk_logic_pointer_or_StartOf t in pvalid_function ~loc t end else C.error loc "subscripted value is neither array nor pointer" | PLinitialized (l,t) -> predicate_label_non_void_ptr check_object_ptr pinitialized l t | PLdangling (l,t) -> predicate_label_non_void_ptr check_object_ptr pdangling l t | PLold p -> let lab = find_old_label loc env in let env = Lenv.set_current_logic_label lab env in (* could be Tat(t,lab) *) pold ~loc (predicate env p) | PLat (p, l) -> let lab = find_logic_label loc env l in let env = Lenv.set_current_logic_label lab env in pat ~loc (predicate env p, lab) | PLvar x -> (try let def = C.find_macro x in predicate env def with Not_found -> let make_app info = match info.l_type with | None -> let labels = match info.l_labels with [] -> [] | [l] -> [l,find_current_label loc env] | _ -> C.error loc "%s labels must be explicitly instantiated" x in papp ~loc (info,labels,[]) | Some _ -> boolean_to_predicate ctxt 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 ctxt env p0)) | PLlet(x,def,body) -> let typ, args, tdef = try let tdef = ctxt.type_term { ctxt with 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 ctxt 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 { pred_name = []; pred_loc = loc; pred_content = Plet(var,tbody) } | PLcast _ | PLblock_length _ | PLbase_addr _ | PLoffset _ | PLrepeat _ | PLlist _ | PLarrget _ | PLarrow _ | PLdot _ | PLbinop _ | PLunop _ | PLconstant _ | PLnull | PLresult | PLcoercion _ | PLcoercionE _ | PLsizeof _ | PLsizeofE _ | PLlambda _ | PLupdate _ | PLinitIndex _ | PLinitField _ | PLtypeof _ | PLtype _ -> boolean_to_predicate ctxt env p0 | PLrange _ -> C.error loc "cannot use operator .. within a predicate" | PLnamed (n, p) -> let p = predicate env p in { p with pred_name = n::p.pred_name } | PLsubtype (t,tc) -> psubtype ~loc (term env t, term env tc) | PLseparated seps -> let type_loc l = let res = term env l 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 seps | PLcomprehension _ | PLset _ | PLunion _ | PLinter _ | PLempty -> C.error loc "expecting a predicate and not tsets" let type_from ctxt ~accept_formal env (l,d) = (* Yannick: [assigns *\at(\result,Post)] should be allowed *) let tl = term_lval_assignable ctxt ~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 ctxt ~accept_formal:true env) f in let tf = List.map (fun td -> if Logic_utils.contains_result td then C.error td.term_loc "invalid \\result in dependencies"; Logic_const.new_identified_term td) tf in (tl, From tf) let type_assign ctxt ~accept_formal env a = match a with WritesAny -> WritesAny | Writes l -> let res = List.map (type_from ctxt ~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 base_ctxt env = make_typing_context ~pre_state:env ~post_state:(fun _ -> env) ~assigns_env:env ~type_predicate:predicate ~type_term:term ~type_assigns:type_assign let type_term = term let type_predicate = predicate let term env t = term (base_ctxt env) env t let predicate env t = predicate (base_ctxt env) env t let type_variant env = function | (t, None) -> (type_int_term (base_ctxt env) env t, None) | (t, r) -> (term env t, r) 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) (* For Widen_hints and Widen_variables, we check that the arguments of the pragma can be understood later. Keep this code synchronized with src/plugins/value/utils/widen.ml. *) let loop_pragma env p = let accept_int = function { term_node = TConst (Integer _)} -> true | _ -> false in let accept_var = function { term_node = TLval (TVar {lv_origin = Some _}, _)} -> true | _ -> false in (* fail when the translation of [p] does not verify the predicate [accept]*) let term_accept accept p = let t = term env p in if not (accept t) then C.error t.term_loc "invalid pragma '%a'" Cil_printer.pp_term t; t in match p with | Unroll_specs l -> Unroll_specs (List.map (term env) l) | Widen_variables l -> Widen_variables (List.map (term_accept accept_var) l) | Widen_hints l -> let accept t = accept_int t || accept_var t in Widen_hints (List.map (term_accept accept) l) let type_annot loc ti = let env = append_here_label (append_init_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; add_logic_function loc 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 C.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; mi_attr = []; } 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 C.error loc "reference to unknown behavior %s" x) names let check_unique_behavior_names loc old_behaviors behaviors = List.fold_left (fun names b -> let open Cil_types in if b.b_name = Cil.default_behavior_name then names else begin if (List.mem b.b_name names) then C.error loc "behavior %s already defined" b.b_name ; b.b_name::names end) old_behaviors behaviors let type_extended ~typing_context ~loc (name,ps) = let loc = match ps with | [] -> loc | p::_ -> p.lexpr_loc in if Extensions.is_extension name then name , Extensions.typer name ~typing_context ~loc ps else C.error loc "No type-checking function registered for extension %s" name (* This module is used to sort the list of behaviors in [complete] and [disjoint] clauses, in order to remove duplicate clauses. *) module StringListSet = FCSet.Make( struct type t = string list let compare s1 s2 = Pervasives.(compare (List.sort compare s1) (List.sort compare s2)) end) let type_spec old_behaviors loc is_stmt_contract result env s = let env = append_here_label (append_init_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 (* Usual 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 *) [Cabshelper.mk_behavior ()] else spec_behavior in let b = List.map (fun {b_assigns= ba; b_name; b_post_cond=be; b_assumes= bas; b_allocation=bfa; b_requires=br; b_extended=bext} -> let typing_context = make_typing_context ~pre_state:env ~post_state:multiple_post_clauses_state_env ~assigns_env:assigns_env ~type_predicate ~type_term ~type_assigns:type_assign in let b_assumes = List.map (id_predicate env) bas in let b_requires= List.map (id_predicate env) br in let b_post_cond = List.map (fun (k,p)-> let p' = id_predicate (post_state_env k) p in (k,p')) be in let b_assigns = type_assign typing_context ~accept_formal:is_stmt_contract assigns_env ba in let 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) in let b_extended = List.map (type_extended ~typing_context ~loc) bext in { Cil_types.b_name; b_assumes; b_requires; b_post_cond; b_assigns; b_allocation; b_extended } ) spec_behavior in let none_for_stmt_contract clause = function | None -> None | (Some _) as x -> if is_stmt_contract then C.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 C.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 cleanup_duplicate l = StringListSet.(elements (List.fold_left (fun acc e -> add e acc) empty l)) in let complete = cleanup_duplicate complete in let disjoint = cleanup_duplicate disjoint in { Cil_types.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 (append_init_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 (append_init_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; Cil_types.AAssert (behav,predicate (code_annot_env()) p) | APragma (Impact_pragma sp) -> Cil_types.APragma (Impact_pragma (impact_pragma (code_annot_env()) sp)) | APragma (Slice_pragma sp) -> Cil_types.APragma (Slice_pragma (slice_pragma (code_annot_env()) sp)) | APragma (Loop_pragma lp) -> Cil_types.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.Cil_types.spec_behavior); Cil_types.AStmtSpec (behav,my_spec) | AVariant v -> Cil_types.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; Cil_types.AInvariant (behav,f,predicate env i) | AAllocation (behav,fa) -> check_behavior_names loc current_behaviors behav; Cil_types.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) -> let env = loop_annot_env () in let ctxt = base_ctxt env in Cil_types.AAssigns(behav, type_assign ctxt ~accept_formal:true env a) | AExtended (behav, ext) -> let pre_state = loop_annot_env() in (* not supposed to use post_states in loop annotations. *) let post_state = fun _ -> Lenv.empty() in let assigns_env = Lenv.empty() in let type_assigns = type_assign in let typing_context = make_typing_context ~pre_state ~post_state ~assigns_env ~type_predicate ~type_term ~type_assigns in Cil_types.AExtended (behav, type_extended ~typing_context ~loc ext) 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); C.error loc "duplicated type variable in annotation" with Not_found -> Lenv.add_type_var x (Lvar x) env) (Lenv.empty()) l let rec is_cyclic_typedef s = function | None -> false | Some (LTsum _) -> false | Some (LTsyn typ) -> is_cyclic_typedef_aux s typ and is_cyclic_typedef_aux s = function | Ltype ({ lt_name = s'; lt_def = d },_) -> s = s' || is_cyclic_typedef s d | Larrow (prm,rt) -> List.exists (is_cyclic_typedef_aux s) prm || is_cyclic_typedef_aux s rt | _ -> false (* 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 C.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 C.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 implicitly 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; add_logic_function loc info; env,info let type_datacons loc env type_info (name,params) = (try let info = C.find_logic_ctor name in C.error loc "type constructor %s is already used by type %s" name info.ctor_type.lt_name with Not_found -> ()); 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); (* potential creation of label w.r.t. reads clause *) update_info_wrt_default_label info; 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); (* potential creation of label w.r.t. reads clause *) update_info_wrt_default_label info; 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); (* potential creation of label w.r.t. def *) update_info_wrt_default_label info; Dfun_or_pred (info,loc) end else C.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 info.l_body <- LBpred e; (* potential creation of label w.r.t. def *) update_info_wrt_default_label info; 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 (global_default, l) = List.fold_left (fun (global_default, acc) (id,labels,poly,e) -> Lenv.default_label := None; let labels,env = annot_env loc labels poly in let p = predicate env e in let res = update_ind_case_wrt_default_label (id, labels, poly, p) in let global_default = match global_default, !Lenv.default_label with | _, None -> global_default | Some _, _ -> global_default | None, (Some _ as lab) -> lab in (global_default, res::acc)) (!Lenv.default_label,[]) indcases in Lenv.default_label := global_default; (* After all inductive cases has been processed, we might have added an implicit label for the predicate at some point. Update the inductive cases that need it (i.e. do not define their own label(s)). *) let l = List.rev_map update_ind_case_wrt_default_label l in info.l_body <- LBinductive l; update_info_wrt_default_label info; Dfun_or_pred (info,loc) | LDaxiomatic(id,decls) -> 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 *) lt_attr = []; } in (try ignore (C.find_logic_type s); C.error loc "logic type %s is already defined" s with Not_found -> ()); C.add_logic_type s my_info; (try let tdef = Extlib.opt_map (typedef loc env my_info) def in if is_cyclic_typedef s tdef then C.error loc "Definition of %s is cyclic" s; 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 ~current:true "Logic_env.get_lemma must return Dlemma" in C.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 (append_init_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; add_logic_function loc 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 env = Lenv.empty () in let ctxt = base_ctxt env in let tsets = List.map (term_lval_assignable ctxt ~accept_formal:false env) 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 C.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 () = C.error loc "incompatible type of '%s' with volatile reads 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 () = C.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 -> C.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-Phosphorus-20170501/src/kernel_services/ast_queries/logic_utils.mli0000644000175000017500000003721713113745005025716 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* 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 (** {2 Types} *) (** instantiate type variables in a logic type. *) val instantiate : (string * logic_type) list -> logic_type -> logic_type (** [is_instance_of poly t1 t2] returns [true] if [t1] can be derived from [t2] by instantiating some of the type variable in [poly]. @since Magnesium-20151001 *) val is_instance_of: string list -> logic_type -> logic_type -> bool (** 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. *) (* BY: seriously? *) 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} *) (** @deprecated use Logic_const.pred_of_id_pred instead *) val predicate_of_identified_predicate: identified_predicate -> predicate [@@ deprecated "Use Logic_const.pred_of_id_pred instead"] (** 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 -> predicate (** {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 (** creates an AddrOf from a TLval. The given logic type is the type of the lval. @since Neon-20140301 *) val mk_logic_AddrOf: ?loc:Cil_types.location -> term_lval -> logic_type -> 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. If [force] is [true], the cast will always be inserted. Otherwise (which is the default), [mk_cast typ t] will return [t] if it is already of type [typ] @modify Aluminium-20160501 added [force] optional argument *) val mk_cast: ?loc:location -> ?force:bool -> 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 (** [numeric_coerce typ t] returns a term with the same value as [t] and of type [typ]. [typ] which should be [Linteger] or [Lreal]. [numeric_coerce] tries to avoid unnecessary type conversions in [t]. In particular, [numeric_coerce (int)cst Linteger], where [cst] fits in int will be directly [cst], without any coercion. @since Magnesium-20151001 *) val numeric_coerce: logic_type -> term -> term (** {2 Predicates} *) (** \valid_index *) (* val mk_pvalid_index: ?loc:location -> term * term -> predicate *) (** \valid_range *) (* val mk_pvalid_range: ?loc:location -> term * term * term -> predicate *) val pointer_comparable: ?loc:location -> term -> term -> predicate (** \pointer_comparable @since Fluorine-20130401 *) val points_to_valid_string: ?loc:location -> term -> predicate (** \points_to_valid_string @since Neon-20140301 *) (** {3 Conversion from exp to term}*) (** translates a C expression into an "equivalent" logical term. [cast] specifies how C arithmetic operators are translated. When [cast] is [true], the translation returns a logic [term] having the same semantics of the C [expr] by introducing casts (i.e. the C expr [a+b] can be translated as [(char)(((char)a)+(char)b)] to preserve the modulo feature of the C addition). Otherwise, no such casts are introduced and the C arithmetic operators are translated into perfect mathematical operators (i.e. a floating point addition is translated into an addition of [real] numbers). @plugin development guide *) val expr_to_term : cast:bool -> exp -> term (** same as {!expr_to_term}, except that if the new term has an arithmetic type, it is automatically coerced into real (or integer for integral types). @since Magnesium-20151001 *) val expr_to_term_coerce: 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 (** true if the term is \result or an offset of \result. *) 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 -> bool (** [true] if the predicate is Pfalse @since Nitrogen-20111001 *) val is_trivially_false: predicate -> bool (** {2 Global annotations} *) (** add an attribute to a global annotation @since Phosphorus-20170501-beta1 *) val add_attribute_glob_annot: attribute -> global_annotation -> global_annotation (** {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 -> string * logic_label list * string list * predicate -> 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_node : predicate_node -> predicate_node -> bool val is_same_predicate : predicate -> predicate -> 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 (** comparison compatible with is_same_term *) val compare_term: term -> term -> int (** {2 Merging contracts} *) val get_behavior_names : 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_trivial_annotation : 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 Constant folding} *) val constFoldTermToInt: ?machdep:bool -> term -> Integer.t option (** A [cilVisitor] (by copy) that simplifies expressions of the type [const int x = v], where [v] is an integer and [x] is a global variable. Requires a mapping from [varinfo] to [init option] (e.g. based on [Globals.Vars.find]). @since Silicon-20161101 *) class simplify_const_lval: (varinfo -> init option) -> Cil.cilVisitor (** {2 Type-checking hackery} *) (** give complete types to terms that refer to a variable whose type has been completed after its use in an annotation. Internal use only. @since Neon-20140301 *) val complete_types: file -> unit (** {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-Phosphorus-20170501/src/kernel_services/ast_queries/filecheck.ml0000644000175000017500000012772413113745012025146 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 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) let pretty_logic_var_kind fmt = function | LVGlobal -> Format.pp_print_string fmt "global logic declaration" | LVC -> Format.pp_print_string fmt "C variable" | LVFormal -> Format.pp_print_string fmt "formal parameter" | LVQuant -> Format.pp_print_string fmt "quantified variable" | LVLocal -> Format.pp_print_string fmt "local parameter" let dkey_check = Kernel.register_category "check" (* Use category "check:strict" to enable stricter tests *) let dkey_check_volatile = Kernel.register_category "check:strict:volatile" module Base_checker = struct class check ?(is_normalized=true) what : Visitor.frama_c_visitor = let check_abort fmt = Kernel.fatal ~current:true ("[AST Integrity Check]@ %s@ " ^^ fmt) what in let abort_if cond = if cond then check_abort else Log.nullprintf 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_compinfos = Compinfo.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 logic_labels = [] val mutable globals_functions = Varinfo.Set.empty val mutable globals_vars = Varinfo.Set.empty val mutable return_stmt = None val quant_orig = Stack.create () 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; Cil.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; Cil.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 ~dkey:dkey_check "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 if v.vformal || v.vglob || not v.vdefined then (* A defined local will only enter scope when the corresponding Local_init statement is reached. *) Varinfo.Hashtbl.add known_vars v v; match v.vlogic_var_assoc with | None -> Cil.DoChildren | Some ({ lv_origin = Some v'} as lv) when v == v' -> Kernel.debug ~dkey:dkey_check "var %s(%d) has an associated %s(%d)" v.vname v.vid lv.lv_name lv.lv_id; (match lv.lv_type with | Ctype t -> if not (Cil_datatype.TypNoUnroll.equal t v.vtype) then check_abort "C variable %s and its associated variable do not have the \ same type:@\nC type is %a@\nLogic type is %a" v.vname Cil_datatype.Typ.pretty v.vtype Cil_datatype.Typ.pretty t | lt -> check_abort "Logic variable %s is associated to a C variable but has \ a purely logic type, %a@." lv.lv_name Cil_datatype.Logic_type.pretty lt); Cil.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(%d) is not declared" v.vname v.vid in if not v.vglob || not (Ast_info.is_frama_c_builtin v.vname) then (try if Varinfo.Hashtbl.find known_vars v != v then not_shared () with Not_found -> unknown () ); Cil.DoChildren method! vquantifiers l = let orig = try Stack.top quant_orig with Stack.Empty -> check_abort "Internal error of check visitor: don't know which origin a logic \ variable should be checked against" in List.iter (fun lv -> if lv.lv_kind <> orig then check_abort "logic variable %a is flagged as %a but declared as a %a" Printer.pp_logic_var lv pretty_logic_var_kind lv.lv_kind pretty_logic_var_kind orig) l; Cil.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 -> Cil.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' -> ignore Visitor.(visitFramacLogicType (self:>frama_c_visitor) lv.lv_type); (* DoChildren on initialized local variables would fail, as it performs a vvrbl on the C variable, before having reached the initializer. *) Cil.SkipChildren | 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_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; Cil.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; return_stmt <- Some (Kernel_function.find_return 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 <- []; (match return_stmt with | None -> () | Some _ -> (* can only happen in normalized mode. *) check_abort "Function %a does not have a return statement in its body" Kernel_function.pretty (Extlib.the self#current_kf)); 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 _ | Throw _ -> 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 Cil.typeHasAttribute "noreturn" (Cil.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 Cil.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" (Pretty_utils.pp_list ~sep:",@ " Printer.pp_varinfo) (Varinfo.Set.elements local_vars) Printer.pp_varinfo f.svar end; f in Cil.ChangeDoChildrenPost(f,check) method private check_label s = let ok = List.exists (function Label _ -> true | _ -> false) !s.labels in if not ok then check_abort "Statement is referenced by \\at or goto without having a label"; labelled_stmt <- !s :: labelled_stmt method private check_try_catch_decl (decl,_) = match decl with | Catch_exn(v,l) -> self#check_local_var v; List.iter (fun (v,_) -> self#check_local_var v) l | Catch_all -> () 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,_) -> self#check_label s; Cil.DoChildren | Switch(_,_,cases,loc) -> List.iter (fun s -> Stmt.Hashtbl.add switch_cases s loc) cases; Cil.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 Cil.ChangeDoChildrenPost(s,f) | If (_,bt,be,_) -> begin (** Check that we have 2 successors, in the right order (then before else) *) match s.succs with | [st; se] -> begin (match bt.bstmts with | st' :: _ -> abort_if (not (st == st')) "Invalid 'then' successor for If" | _ -> ()); (match be.bstmts with | se' :: _ -> abort_if (not (se == se')) "Invalid 'else' successor for If" | _ -> ()); Cil.DoChildren end | l -> check_abort "If with %d successors" (List.length l) end | Loop _ -> let old_labels = logic_labels in logic_labels <- Logic_const.(loop_current_label :: loop_entry_label :: logic_labels); Cil.DoChildrenPost (fun s -> logic_labels <- old_labels; s) | TryCatch(_,c,_) -> List.iter self#check_try_catch_decl c; Cil.DoChildren | Return _ -> if is_normalized then begin match return_stmt with | None -> check_abort "Found a second return statement in body of function %a" Kernel_function.pretty (Extlib.the self#current_kf) | Some s' when s != s' -> check_abort "Function %a is supposed to have as return statement %d:@\n%a@\n\ Found in its body statement %d:@\n%a@\n" Kernel_function.pretty (Extlib.the self#current_kf) s'.sid Printer.pp_stmt s' s.sid Printer.pp_stmt s | Some _ -> return_stmt <- None end; Cil.DoChildren | _ -> Cil.DoChildren); method private check_local_var 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(%d) is supposed to be local to a block \ but not mentioned in the function's locals." Printer.pp_varinfo (Extlib.the self#current_func).svar Printer.pp_varinfo v v.vid end (* Stack of local variables that are supposed to be initialized in each currently opened block (with [bscoping=true]), the top of the stack corresponding to the innermost block. Used to check that these variables have a Local_init instruction in the appropriate block. *) val current_block_vars = Stack.create () method! vblock b = let check_locals b = List.iter (fun v -> if v.vdefined then check_abort "Local variable %a is supposed to be defined, \ but no initializer found in the block where it is in scope" Printer.pp_varinfo v) (Stack.pop current_block_vars); b in List.iter self#check_local_var b.blocals; if b.bscoping then begin Stack.push b.blocals current_block_vars; Cil.DoChildrenPost check_locals end else if b.blocals <> [] then (* non-scoping block mustn't declare locals *) check_abort "Block below is declaring local variables %a, but its attributes \ indicates that it is not used as a scope boundary.@\n%a" (Pretty_utils.pp_list ~sep:", " Printer.pp_varinfo) b.blocals Printer.pp_block b else Cil.DoChildren method! vbehavior b = let vpred p = ignore Visitor.(visitFramacIdPredicate (self:>frama_c_visitor) p) in let vextend b = ignore Visitor.(visitFramacExtended (self:>frama_c_visitor) b) in List.iter vpred b.b_requires; List.iter vpred b.b_assumes; List.iter vextend b.b_extended; let old_labels = logic_labels in logic_labels <- Logic_const.post_label :: logic_labels; List.iter Extlib.(vpred $ snd) b.b_post_cond; ignore Visitor.(visitFramacAssigns (self:>frama_c_visitor) b.b_assigns); ignore Visitor.(visitFramacAllocation (self:>frama_c_visitor) b.b_allocation); logic_labels <- old_labels; Cil.SkipChildren method! vspec _ = let old_labels = logic_labels in logic_labels <- Logic_const.( init_label :: here_label :: pre_label :: old_label :: logic_labels); Cil.DoChildrenPost (fun s -> logic_labels <- old_labels; s) method! vcode_annot ca = if Hashtbl.mem known_code_annot_id ca.annot_id then begin check_abort "duplicated code annotation id: %d@\n%a@\nand@\n%a" ca.annot_id Printer.pp_code_annotation (Hashtbl.find known_code_annot_id ca.annot_id) Printer.pp_code_annotation ca end else Hashtbl.add known_code_annot_id ca.annot_id ca; let old_labels = logic_labels in logic_labels <- Logic_const.(init_label :: here_label :: pre_label :: logic_labels); Cil.DoChildrenPost (fun ca -> logic_labels <- old_labels; ca) method! voffs = function | NoOffset -> Cil.SkipChildren | Index _ -> Cil.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; Cil.DoChildren method! vterm_offset = function | TNoOffset -> Cil.SkipChildren | TIndex _ -> Cil.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); Cil.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(%d) is unbound in the AST" fi.fname fi.fcomp.cname fi.fcomp.ckey) end; Cil.DoChildren method! vterm_lhost = function | TResult t when is_normalized -> (* if not normalized, contracts are visited while kf is not set *) (match self#current_kf with | None -> check_abort "\\result found outside of a function contract" | Some kf -> let t1 = Kernel_function.get_return_type kf in if Cil.isVoidType t1 then check_abort "\\result found in a contract for function %a that returns void" Kernel_function.pretty kf; if not (Cil_datatype.TypNoUnroll.equal t t1) then check_abort "\\result of type %a found in a contract for function %a that \ returns %a" Cil_datatype.Typ.pretty t Kernel_function.pretty kf Cil_datatype.Typ.pretty t1 ); Cil.DoChildren | _ -> Cil.DoChildren method private check_ei: 'a. enumitem -> 'a Cil.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; Cil.DoChildren with Not_found -> check_abort "enumitem %s is used but not declared" ei.einame (* can't use vlogic_label, as it also visits the declared labels in Tapp and Papp. *) method private check_logic_label lab = match lab with | StmtLabel _ -> () | LogicLabel _ -> let is_declared = List.exists (fun x -> Cil_datatype.Logic_label.equal x lab) logic_labels in if not is_declared then check_abort "Logic label %a is not declared in this scope" Printer.pp_logic_label lab method private check_logic_app li labs args = let expect = List.length li.l_profile in let actual = List.length args in let pred_or_func = match li.l_type with | None -> "Predicate" | Some _ -> "Logic function" in if not (expect = actual) then check_abort "%s %a expects %d arguments but is used with %d" pred_or_func Printer.pp_logic_var li.l_var_info expect actual; List.iter2 (fun lv arg -> if not (Logic_utils.is_instance_of li.l_tparams arg.term_type lv.lv_type) then check_abort "term %a has type %a, but is used as a parameter of type %a" Printer.pp_term arg Printer.pp_logic_type arg.term_type Printer.pp_logic_type lv.lv_type) li.l_profile args; let lab_declared = List.length li.l_labels in let lab_provided = List.length labs in if not (lab_declared = lab_provided) then check_abort "%s %a expects %d logic labels, but is used with %d" pred_or_func Printer.pp_logic_var li.l_var_info lab_declared lab_provided; List.iter (fun (_,lab) -> self#check_logic_label lab) labs; (* NdV: I'm not sure why the list of labels instantiations contains pairs with the declared label as first component, but as long as the AST stays that way, it cannot hurt to check for consistency here. *) List.iter2 (fun lab (lab',_) -> if not (Cil_datatype.Logic_label.equal lab lab') then check_abort "%s %a has a label declared as %a, which is instantiated as %a" pred_or_func Printer.pp_logic_var li.l_var_info Printer.pp_logic_label lab Printer.pp_logic_label lab') li.l_labels labs method! vterm t = match t.term_node with | TLval _ -> begin match t.term_type with | Ctype ty -> ignore (Kernel.verify (not (Cil.isVoidType ty)) "logic term with void type:%a" Printer.pp_term t); Cil.DoChildren | _ -> Cil.DoChildren end | 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; Cil.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; Cil.DoChildren | Tlambda _ -> Stack.push LVFormal quant_orig; Cil.DoChildrenPost (fun t -> ignore (Stack.pop quant_orig); t) | Tcomprehension _ -> Stack.push LVQuant quant_orig; Cil.DoChildrenPost (fun t -> ignore (Stack.pop quant_orig); t) | Tapp(li,labs,args) -> (match li.l_type with | Some ty when Logic_utils.is_instance_of li.l_tparams t.term_type ty -> () | Some ty -> check_abort "logic function %a has return type %a, \ but application %a has type %a" Printer.pp_logic_var li.l_var_info Printer.pp_logic_type ty Printer.pp_term t Printer.pp_logic_type t.term_type | None -> check_abort "predicate %a is used as a logic function" Printer.pp_logic_var li.l_var_info); self#check_logic_app li labs args; Cil.DoChildren | Tat(_,l) | Tbase_addr(l,_) | Toffset(l,_) | Tblock_length(l,_) -> self#check_logic_label l; Cil.DoChildren | _ -> Cil.DoChildren method! vinitoffs = self#voffs method! vcompinfo c = Kernel.debug ~dkey:dkey_check "Checking composite type %s(%d)" c.cname c.ckey; Compinfo.Hashtbl.add known_compinfos c c; Kernel.debug ~dkey:dkey_check "Adding fields for type %s(%d)" c.cname c.ckey; List.iter (fun x -> Fieldinfo.Hashtbl.add known_fields x x) c.cfields; Cil.DoChildren method! vfieldinfo f = Kernel.debug ~dkey:dkey_check "Check field %s of type %s" f.fname f.fcomp.cname; try let c = Compinfo.Hashtbl.find known_compinfos f.fcomp in if f.fcomp != c then check_abort "field %s of type %s does not refer to the appropriate compinfo node" f.fname f.fcomp.cname; Cil.DoChildren with Not_found -> check_abort "field %s belongs to an unknown type %s" f.fname f.fcomp.cname (* 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 | GFunDecl(_,v,_) -> self#remove_globals_function v; if not (Cil.isFunctionType v.vtype) then check_abort "Function %a has non-function type" Printer.pp_varinfo v; if is_normalized then begin if v.vdefined && not (Kernel_function.is_definition (Globals.Functions.get v)) then check_abort "Function %s(%d) is supposed to be defined, \ but not registered as such" v.vname v.vid; 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); Cil.DoChildren | GVarDecl(v,_) | GVar(v,_,_) -> if Cil.isFunctionType v.vtype then check_abort "Variable %a has function type" Printer.pp_varinfo v; self#remove_globals_var v; Cil.DoChildren | GFun (f,_) -> if not (Cil.isFunctionType f.svar.vtype) then check_abort "Function %a has non-function type" Printer.pp_varinfo f.svar; 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; Cil.DoChildren | _ -> Cil.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 Cil.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; Cil.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); Cil.DoChildren | Dlemma(_,_,labels,_,_,_,_) -> let old_labels = logic_labels in logic_labels <- labels @ logic_labels; Cil.DoChildrenPost (fun g -> logic_labels <- old_labels; g) | _ -> Cil.DoChildren method! vlogic_label = function | StmtLabel l -> self#check_label l; Cil.SkipChildren | _ -> Cil.DoChildren method! vpredicate_node = function | Papp(li,labs,args) -> (match li.l_type with | None -> () | Some _ -> check_abort "Logic function %a is used as a predicate" Printer.pp_logic_var li.l_var_info); self#check_logic_app li labs args; Cil.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; Cil.DoChildren | Pforall _ | Pexists _ -> Stack.push LVQuant quant_orig; Cil.DoChildrenPost (fun p -> ignore (Stack.pop quant_orig); p) | Pat(_,l) | Pvalid_read(l,_) | Pvalid(l,_) | Pinitialized(l,_) | Pdangling(l,_) | Pallocable(l,_) | Pfreeable(l,_) -> self#check_logic_label l; Cil.DoChildren | Pfresh(l1,l2,_,_) -> self#check_logic_label l1; self#check_logic_label l2; Cil.DoChildren | _ -> Cil.DoChildren method private vinductive_case (_,labels,_,p) = let old_labels = logic_labels in logic_labels <- labels @ logic_labels; ignore (Visitor.visitFramacPredicate (self:>Visitor.frama_c_visitor) p); logic_labels <- old_labels method! vlogic_info_decl li = Logic_var.Hashtbl.add known_logic_info li.l_var_info li; List.iter (fun lv -> if lv.lv_kind <> LVFormal then check_abort "Formal parameter %a of logic function/predicate %a is \ flagged with wrong origin" Printer.pp_logic_var lv Printer.pp_logic_var li.l_var_info) li.l_profile; match li.l_body with | LBinductive l -> List.iter self#vinductive_case l; Cil.SkipChildren | _ -> let old_labels = logic_labels in logic_labels <- li.l_labels @ logic_labels; Cil.DoChildrenPost (fun li -> logic_labels <- old_labels; li) 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; Cil.DoChildren val accept_array = Stack.create () method private accept_array = function | SizeOfE _ | AlignOfE _ | CastE _ -> true | _ -> false method! vexpr e = if Cil.typeHasAttribute "volatile" (Cil.typeOf e) then begin let volatile_problem : (_, _, _) format = "Expression with volatile qualification %a" in if Kernel.is_debug_key_enabled dkey_check_volatile then check_abort volatile_problem Printer.pp_exp e else Kernel.warning ~current:true volatile_problem Printer.pp_exp e end; match e.enode with | Const (CEnum ei) -> self#check_ei ei | Lval lv when Cil.isArrayType (Cil.typeOfLval lv) && (Stack.is_empty accept_array || 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; Cil.ChangeDoChildrenPost (e, fun e -> ignore (Stack.pop accept_array); e) method private check_initialized_var v = let block_vars = Stack.pop current_block_vars in match List.partition (Cil_datatype.Varinfo.equal v) block_vars with | [_], block_vars -> Stack.push block_vars current_block_vars; Cil_datatype.Varinfo.Hashtbl.add known_vars v v | [], _ -> if Cil_datatype.Varinfo.Hashtbl.mem known_vars v then check_abort "Local variable %a is initialized twice" Printer.pp_varinfo v else check_abort "%a is initialized, but not marked as a local variable \ of the nearest enclosing block" Printer.pp_varinfo v | _, _ -> check_abort "Local variable %a is present several times in block's locals list" Printer.pp_varinfo v method! vinst i = let treat_call lvopt f args _loc = match f.enode with | Lval (Var f, NoOffset) -> 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 | [],[] -> Cil.DoChildren | _::_, [] -> check_abort "call %a has too few arguments" Printer.pp_instr i | [],e::_ -> if is_variadic then Cil.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 -> Cil.DoChildren | Some targs -> aux targs args) | _ -> (* indirect call. Can't check coherence with a given kf *) Cil.DoChildren in match i with | Call(lvopt,f,args,loc) -> treat_call lvopt f args loc | Local_init (v, AssignInit _, _) -> self#check_initialized_var v; Cil.DoChildren | Local_init (v, ConsInit(f,args,k),loc) -> self#check_initialized_var v; Cil.treat_constructor_as_func treat_call v f args k loc | Asm(_,_,Some { asm_gotos },_) -> List.iter self#check_label asm_gotos; Cil.DoChildren | _ -> Cil.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; Cil.DoChildren | TFun(rt, _, _, attrs) -> (* we do not visit parameters. This is handled elsewhere, and it is not possible to perform a sensible check for dependent types at this level, e.g. for void f(int n, int arr[10][n]); as in TFun the parameters are simple string, and not tied to the varinfo that we would like to put in scope to check that arr[10][n] is well formed. *) ignore (Cil.visitCilType (self:>Cil.cilVisitor) rt); ignore (Cil.visitCilAttributes (self:>Cil.cilVisitor) attrs); Cil.SkipChildren | _ -> Cil.DoChildren initializer let add_func kf = let vi = Kernel_function.get_vi kf in if vi.vsource then globals_functions <- Cil_datatype.Varinfo.Set.add vi globals_functions in let add_var vi _ = if vi.vsource then globals_vars <- Cil_datatype.Varinfo.Set.add vi globals_vars in Globals.Functions.iter add_func; Globals.Vars.iter add_var end end module type Extensible_checker = sig class check: ?is_normalized:bool -> string -> Visitor.frama_c_visitor end let current_checker = ref (module Base_checker: Extensible_checker) let extend_checker f = current_checker := f !current_checker let check_ast ?is_normalized ?(ast = Ast.get()) what = let module M = (val !current_checker : Extensible_checker) in Kernel.debug ~dkey:dkey_check "Checking integrity of AST:@\n%a" (if Extlib.opt_conv true is_normalized then Printer.pp_file else Cil_printer.pp_file) ast; Cil.visitCilFileSameGlobals (new M.check ?is_normalized what :> Cil.cilVisitor) ast (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_queries/cil.mli0000644000175000017500000026415213113745012024146 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. @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 Carbon-20101201 *) (** 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 (** 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) -> Cil_types.mach -> unit (* ************************************************************************* *) (** {2 Customization} *) (* ************************************************************************* *) type theMachine = private { mutable useLogicalOperators: 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 theMachine: mach; mutable lowerConstants: bool; (** Do lower constants (default true) *) mutable insertImplicitCasts: bool; (** Do insert implicit casts (default true) *) mutable underscore_name: bool; (** Whether the compiler generates assembly labels by prepending "_" to the identifier. That is, will function foo() have the label "foo", or "_foo"? *) 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 msvcMode: unit -> bool val gccMode: unit -> bool (* ************************************************************************* *) (** {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 formals of a function declaration with the given list of varinfo. *) val unsafeSetFormalsDecl: varinfo -> varinfo list -> unit (** iterate 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 (** long long *) val longLongType: 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 val scharType: typ val ucharType: typ (** char * *) val charPtrType: typ val scharPtrType: typ val ucharPtrType: 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 (** @return true if and only if the given type is a signed integer type. *) val isSignedInteger: typ -> bool (** @return true if and only if the given type is an unsigned integer type. @since Oxygen-20120901 *) val isUnsignedInteger: typ -> bool (** Creates 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. It also copies the fields, and makes sure that the copied field points back to the copied compinfo. If [fresh] is [true] (the default), it will also give a fresh id to the copy. *) val copyCompInfo: ?fresh:bool -> 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, including the 'struct' or 'union' prefix *) 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. @param allowZeroSizeArrays defaults to [false]. When [true], arrays of size 0 (a gcc extension) are considered as complete *) val isCompleteType: ?allowZeroSizeArrays:bool -> 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 or pointer type. *) val isIntegralOrPointerType: 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 an arithmetic or pointer type (i.e. integer, enum, floating point or pointer *) val isArithmeticOrPointerType: 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 [temp] argument defaults to [false], and corresponds to the [vtemp] field in type {!Cil_types.varinfo}. The [source] argument defaults to [true], and corresponds to the field [vsource] . The first unnamed argument specifies whether the varinfo is for a global and the second is for formals. *) val makeVarinfo: ?source:bool -> ?temp: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. *) 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]. [temp] 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 -> ?temp:bool -> ?insert:bool -> string -> 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. [source] defaults to [true]. [temp] defaults to [false].*) val makeGlobalVar: ?source:bool -> ?temp: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 (** Changes the type of a varinfo and of its associated logic var if any. @since Neon-20140301 *) val update_var_type: varinfo -> typ -> unit (** 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 (** 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 without literal representation. Truncate the integer if [kind] is given, and the integer does not fit inside the type. The integer can have an optional literal representation [repr]. @raise Not_representable if no ikind is provided and the integer is not representable. *) val kinteger64: loc:location -> ?repr:string -> ?kind: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 (** 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 names 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-extended c, IInt, None) *) val charConstToInt: char -> Integer.t val charConstToIntConstant: 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 the given expression, just as [constFold] would. The resulting integer value, if the const-folding was complete, is returned. The [machdep] optional parameter, which is set to [true] by default, forces the simplification of architecture-dependent expressions. *) val constFoldToInt: ?machdep:bool -> exp -> Integer.t option (** 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. 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 (** 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 non-scoping block, i.e. a block that is not used to determine the end of scope of local variables. Hence, the blocals of such a block must always be empty. @since Phosphorus-20170501-beta1 *) val mkBlockNonScoping: 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]). See [mkStmt] for [ghost] and [valid_sid] arguments. @modify Neon-20130301 adds the [valid_sid] optional argument. *) val mkEmptyStmt: ?ghost:bool -> ?valid_sid: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 (** Create an instruction equivalent to a pure expression. The new instruction corresponds to the initialization of a new fresh variable, i.e. [int tmp = exp]. The scope of this fresh variable is determined by the block given in argument, that is the instruction must be placed directly (modulo non-scoping blocks) inside this block. *) val mkPureExprInstr: fundec:fundec -> scope:block -> ?loc:location -> exp -> instr (** Create an instruction as above, enclosed in a block of a single ([Instr]) statement, which will be the scope of the fresh variable holding the value of the expression. As usual, [ghost] defaults to [false]. [loc] defaults to the location of the expression itself. *) val mkPureExpr: ?ghost:bool -> fundec:fundec -> ?loc:location -> exp -> 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 (** [treat_constructor_as_func action v f args kind loc] calls [action] with the parameters corresponding to the call to [f], of kind [kind], initializing [v] with arguments [args]. @since Phosphorus-20170501-beta1 *) val treat_constructor_as_func: (lval option -> exp -> exp list -> location -> 'a) -> varinfo -> varinfo -> exp list -> constructor_kind -> location -> 'a (** [find_def_stmt b v] returns the [Local_init] instruction within [b] that initializes [v]. [v] must have its [vdefined] field set to true, and be among [b.blocals]. @raise Fatal error if [v] is not a local variable of [b] with an initializer. @since Phosphorus-20170501-beta1 *) val find_def_stmt: block -> varinfo -> stmt (** returns [true] iff the given non-scoping block contains local init statements (thus of locals belonging to an outer block), either directly or within a non-scoping block or undefined sequence.labels @since Phosphorus-20170501-beta1 *) val has_extern_local_init: block -> bool (* ************************************************************************* *) (** {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 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 (unfolding the type definition when needed). It only removes attributes of topmost type, i.e. does not recurse under pointers, arrays, ... *) val typeRemoveAttributes: string list -> typ -> typ (** same as above, but remove any existing attribute from the type. @since Magnesium-20151001 *) val typeRemoveAllAttributes: typ -> typ val typeHasAttribute: string -> typ -> bool (** Does the type have the given attribute. Does not recurse through pointer types, nor inside function prototypes. @since Sodium-20150201 *) val typeHasQualifier: string -> typ -> bool (** Does the type have the given qualifier. Handles the case of arrays, for which the qualifiers are actually carried by the type of the elements. It is always correct to call this function instead of {!typeHasAttribute}. For l-values, both functions return the same results, as l-values cannot have array type. @since Sodium-20150201 *) 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 also qualifiers under Ptr and Arrays @since Sodium-20150201 *) val type_remove_qualifier_attributes_deep: 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:identified_predicate list -> ?requires:identified_predicate list -> ?post_cond:(termination_kind * identified_predicate) list -> ?assigns:identified_term Cil_types.assigns -> ?allocation:identified_term Cil_types.allocation -> ?extended:acsl_extension list -> unit -> 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: behavior -> bool val find_default_behavior: funspec -> funbehavior option (** @since Carbon-20101201 *) val find_default_requires: behavior list -> identified_predicate 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 *) val refresh_visit: Project.t -> visitor_behavior (** Makes fresh copies of the mutable structures and provides fresh id for the structures that have ids. Note that as for {!copy_visit}, only varinfo that are declared in the scope of the visit will be copied and provided with a new id. @since Sodium-20150201 *) (** true iff the behavior provides fresh id for copied structs with id. Always [false] for an inplace visitor. @since Sodium-20150201 *) val is_fresh_behavior: visitor_behavior -> bool (** 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. @plugin development guide *) 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 @plugin development guide *) 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. @plugin development guide *) 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. @plugin development guide *) 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. @plugin development guide *) method vvdec: varinfo -> varinfo visitAction (** Invoked for each variable declaration. The children to be traversed are those corresponding to the type and attributes of the variable. Note that variable declarations are [GVar], [GVarDecl], [GFun] and [GFunDecl] globals, the formals of functions prototypes, and the formals and locals of function definitions. This means that the list of formals of a function may be traversed multiple times if there exists both a declaration and a definition, or multiple declarations. @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. Pass the global where this occurs, and the offset *) method vlocal_init: varinfo -> local_init -> local_init visitAction (** local initializer. pass the variable under initialization. *) 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 precede 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 statements. *) 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) *) 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 method vpredicate_node: predicate_node -> predicate_node visitAction method vpredicate: predicate -> predicate 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 (** Indicates how an extended behavior clause is supposed to be visited. The default behavior is [DoChildren], which ends up visiting each identified predicate in the list and leave the id as is. @plugin development guide @since Sodium-20150201 @modify Silicon-20161101 *) val register_behavior_extension: string -> (cilVisitor -> acsl_extension_kind -> (acsl_extension_kind) visitAction) -> unit (**/**) 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 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 a local initializer (with the local being initialized). *) val visitCilLocal_init: cilVisitor -> varinfo -> local_init -> local_init (** 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 (** Mark the given block as candidate to be flattened into its parent block, after returning from its visit. This is not systematic, as the environment might prevent it (e.g. if the preceding statement is a statement contract or a slicing/pragma annotation, or if there are labels involved). Use that whenever you're creating a block in order to hold multiple statements as a result of visiting a single statement. @raise Fatal error if the given block attempts to declare local variables (in which case it can't be marked as transient anyways). @since Phosphorus-20170501-beta1 *) val transient_block: block -> block (** tells whether the block has been marked as transient @since Phosphorus-20170501-beta1. *) val is_transient_block: block -> bool (** [flatten_transient_sub_blocks b] flattens all direct sub-blocks of [b] that have been marked as cleanable, whenever possible @since Phosphorus-20170501-beta1 *) val flatten_transient_sub_blocks: block -> block (**/**) (** Internal usage only. *) (** Indicates that the potentially transient block given as argument must in fact be preserved after the visit. The resulting block will be marked as non-scoping. @since Phosphorus-20170501-beta1. *) val block_of_transient: 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 @modify Silicon-20161101 *) val visitCilExtended: cilVisitor -> acsl_extension -> acsl_extension val visitCilModelInfo: cilVisitor -> model_info -> model_info val visitCilLogicType: cilVisitor -> logic_type -> logic_type val visitCilIdPredicate: cilVisitor -> identified_predicate -> identified_predicate val visitCilPredicateNode: cilVisitor -> predicate_node -> predicate_node val visitCilPredicate: cilVisitor -> predicate -> predicate 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 (* ************************************************************************* *) (** {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 [(Cil.CurrentLoc.get ())] *) val pp_thisloc: Format.formatter -> unit (** @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 confusion. 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 [aggressive] is true, then the new statements are themselves subject to optimization. Each statement in the list is optimized independently. *) val peepHole2: aggressive: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 SizeOf/AlignOf 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 (** The size of a type, in bytes. Raises {!Cil.SizeOfError} when it cannot compute the size. *) val bytesSizeOf: 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 exception Not_representable (** raised by {!intKindForValue}. *) (** @return the smallest kind that will hold the integer's value. The kind will be unsigned if the 2nd argument is true. @raise Not_representable if the bigint is not representable. @modify Neon-20130301 may raise 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 (** 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 (** [intOfAttrparam a] tries to const-fold [a] into a numeric value. Returns [Some n] if it succeeds, [None] otherwise. @since Silicium-20161101 *) val intOfAttrparam: attrparam -> int option (** 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 (** 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} *) (* ************************************************************************* *) (** if the list has 2 elements or more, it will return a block with [bscoping=false] *) 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 -> predicate (** 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 -> 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 -> 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 Case labels of [s], and a "default statement" that either corresponds to the Default label, or to the syntactic successor of [s] if there is no default label. Note that this "default statement" can thus appear in the returned list. *) val separate_switch_succs: stmt -> stmt list * stmt (** Provided [s] is a if, [separate_if_succs s] splits the successors of s according to the truth value of the condition. The first element of the pair is the successor statement if the condition is true, and the second if the condition is false. *) val separate_if_succs: stmt -> stmt * stmt (**/**) val dependency_on_ast: State.t -> unit (** indicates that the given state depends on the AST. *) val set_dependencies_of_ast : State.t -> unit (** Makes all states that have been marked as depending on the AST by {!dependency_on_ast} depend on the given state. Should only be used once when creating the AST state. *) 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-Phosphorus-20170501/src/kernel_services/ast_queries/cil.ml0000644000175000017500000104465613113745004024004 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). *) (****************************************************************************) (* Modified by TrustInSoft *) (* * CIL: An intermediate language for analyzing C programs. * * Version Tue Dec 12 15:21:52 PST 2000 * Scott McPeak, George Necula, Wes Weimer * *) 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 set_dependencies_of_ast, dependency_on_ast = 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 longLongType = TInt(ILongLong,[]) let ulongType = TInt(IULong,[]) let ulongLongType = TInt(IULongLong, []) let charType = TInt(IChar, []) let ucharType = TInt(IUChar, []) let scharType = TInt(ISChar, []) let charPtrType = TPtr(charType,[]) let ucharPtrType = TPtr(ucharType,[]) let scharPtrType = TPtr(scharType,[]) 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 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; } let default_machdep = Machdeps.x86_32 let createMachine () = (* Contain dummy values *) { 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.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 msvcMode () = (theMachine.theMachine.compiler = "msvc") let gccMode () = (theMachine.theMachine.compiler = "gcc") 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 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 } 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 = []; bscoping = true } let mkBlockNonScoping l = let b = mkBlock l in b.bscoping <- false; b 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 = mkBlockNonScoping (List.map (fun i -> mkStmt (Instr i)) il) in 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 hasAttribute (s: string) (al: attribute list) : bool = List.exists (fun a -> attributeName a = s) al let rec dropAttributes (anl: string list) (al: attributes) = match al with | [] -> [] | a :: q -> let q' = dropAttributes anl q in if List.mem (attributeName a) anl then q' (* drop this attribute *) else if q' == q then al (* preserve sharing *) else a :: q' 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 rec typeRemoveAttributes ?anl t = (* Try to preserve sharing. We use sharing to be more efficient, but also to detect that we have removed an attribute under typedefs *) let new_attr al = match anl with None -> [] | Some anl -> dropAttributes anl al in let reshare al f = let al' = new_attr al in if al' == al then t else f al' in match t with | TVoid a -> reshare a (fun a -> TVoid a) | TInt (ik, a) -> reshare a (fun a -> TInt (ik, a)) | TFloat (fk, a) -> reshare a (fun a -> TFloat (fk, a)) | TEnum (enum, a) -> reshare a (fun a -> TEnum (enum, a)) | TPtr (t, a) -> reshare a (fun a -> TPtr (t, a)) | TArray (t, l, s, a) -> reshare a (fun a -> TArray (t, l, s, a)) | TFun (t, args, isva, a) -> reshare a (fun a -> TFun(t, args, isva, a)) | TComp (comp, s, a) -> reshare a (fun a -> TComp (comp, s, a)) | TBuiltin_va_list a -> reshare a (fun a -> TBuiltin_va_list a) | TNamed (tn, a) -> let tn' = typeRemoveAttributes ?anl tn.ttype in if tn' == tn.ttype then reshare a (fun a -> TNamed (tn, a)) else typeAddAttributes (new_attr a) tn' let typeRemoveAllAttributes t = typeRemoveAttributes t let typeRemoveAttributes anl t = typeRemoveAttributes ~anl t let rec typeRemoveAttributesDeep (anl: string list) t = (* Try to preserve sharing. We use sharing to be more efficient, but also to detect that we have removed an attribute under typedefs *) let reshare al f = let al' = dropAttributes anl al in if al' == al then t else f al' in match t with | TVoid a -> reshare a (fun a -> TVoid a) | TInt (ik, a) -> reshare a (fun a -> TInt (ik, a)) | TFloat (fk, a) -> reshare a (fun a -> TFloat (fk, a)) | TEnum (enum, a) -> reshare a (fun a -> TEnum (enum, a)) | TPtr (t, a) -> let t' = typeRemoveAttributesDeep anl t in if t != t' then TPtr(t', dropAttributes anl a) else reshare a (fun a -> TPtr(t,a)) | TArray (t, l, s, a) -> let t' = typeRemoveAttributesDeep anl t in if t!=t' then TArray(t', l, s, dropAttributes anl a) else reshare a (fun a -> TArray (t, l, s, a)) | TFun (t, args, isva, a) -> reshare a (fun a -> TFun(t, args, isva, a)) | TComp (comp, s, a) -> reshare a (fun a -> TComp (comp, s, a)) | TBuiltin_va_list a -> reshare a (fun a -> TBuiltin_va_list a) | TNamed (tn, a) -> let tn' = typeRemoveAttributesDeep anl tn.ttype in if tn' == tn.ttype then reshare a (fun a -> TNamed (tn, a)) else typeAddAttributes (dropAttributes anl a) tn' (* JS: build an attribute annotation from [s]. *) let mkAttrAnnot s = "/*@ " ^ s ^ " */" let type_remove_qualifier_attributes = typeRemoveAttributes qualifier_attributes let type_remove_qualifier_attributes_deep = typeRemoveAttributesDeep 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 specify 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 ?(source=true) ?(temp=false) 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; vtemp = temp; 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; vsource = source; vlogic_var_assoc = None } in Cil_const.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 () = dependency_on_ast selfFormalsDecl let makeFormalsVarDecl (n,t,a) = let vi = makeVarinfo ~temp: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 no_behavior l = match l with | [] -> true | [ b ] -> b.b_name = default_behavior_name && b.b_requires = [] && b.b_post_cond = [] && b.b_assigns = WritesAny && b.b_allocation = FreeAllocAny && b.b_extended = [] | _ -> false let is_empty_funspec (spec : funspec) = (no_behavior 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 = [] (** Get the full name of a comp *) let compFullName comp = (if comp.cstruct then "struct " else "union ") ^ comp.cname let missingFieldName = "" (* "___missing_field_name"*) (* The next compindo identifier to use. Counts up. *) let nextCompinfoKey = let module M = State_builder.SharedCounter(struct let name = "compinfokey" end) in M.next (** 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 ?(fresh=true) ci cname = let ckey = if fresh then nextCompinfoKey () else ci.ckey in let ci' = { ci with cname; ckey } in (* Copy the fields and set the new pointers to parents *) ci'.cfields <- List.map (fun f -> {f with fcomp = ci'}) ci'.cfields; ci' (** 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; cexpr: exp -> exp; ccode_annotation: code_annotation -> code_annotation; (* 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; is_fresh_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 is_fresh_behavior b = b.is_fresh_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; ccode_annotation = id; cexpr = id; is_copy_behavior = false; is_fresh_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_gen fresh 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_set_logic_var x new_x = Cil_datatype.Logic_var.Hashtbl.add logic_vars x new_x in let temp_set_orig_logic_var new_x x = Cil_datatype.Logic_var.Hashtbl.add orig_logic_vars new_x x 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 id = if fresh then Cil_const.new_raw_id () else x.lv_id in let new_x = { x with lv_id = id } in temp_set_logic_var x new_x; temp_set_orig_logic_var new_x x; new_x in (* Format.printf "res is %s#%d@." res.lv_name res.lv_id;*) res in let temp_set_varinfo x new_x = Cil_datatype.Varinfo.Hashtbl.add varinfos x new_x; match x.vlogic_var_assoc, new_x.vlogic_var_assoc with | None, _ | _, None -> () | Some lx, Some new_lx -> Cil_datatype.Logic_var.Hashtbl.add logic_vars lx new_lx in let temp_set_orig_varinfo new_x x = Cil_datatype.Varinfo.Hashtbl.add orig_varinfos new_x x; match new_x.vlogic_var_assoc, x.vlogic_var_assoc with | None, _ | _, None -> () | Some new_lx, Some lx -> Cil_datatype.Logic_var.Hashtbl.add orig_logic_vars new_lx lx in let temp_memo_varinfo x = try Cil_datatype.Varinfo.Hashtbl.find varinfos x with Not_found -> let new_x = if fresh then Cil_const.copy_with_new_vid x else begin let new_x = { x with vid = x.vid } in (match x.vlogic_var_assoc with | None -> () | Some lv -> let new_lv = { lv with lv_origin = Some new_x } in new_x.vlogic_var_assoc <- Some new_lv); new_x end in temp_set_varinfo x new_x; temp_set_orig_varinfo new_x x; new_x in let temp_set_fundec f new_f = Cil_datatype.Varinfo.Hashtbl.add fundecs f.svar new_f in let temp_set_orig_fundec new_f f = Cil_datatype.Varinfo.Hashtbl.add orig_fundecs new_f.svar f 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 temp_set_fundec f new_f; temp_set_orig_fundec new_f f; new_f in let temp_set_kernel_function kf new_kf = Cil_datatype.Kf.Hashtbl.replace kernel_functions kf new_kf; match kf.fundec, new_kf.fundec with | Declaration(_,vi,_,_), Declaration(_,new_vi,_,_) | Declaration(_,vi,_,_), Definition({ svar = new_vi }, _) | Definition({svar = vi},_), Declaration(_,new_vi,_,_) -> temp_set_varinfo vi new_vi | Definition (fundec,_), Definition(new_fundec,_) -> temp_set_fundec fundec new_fundec in let temp_set_orig_kernel_function new_kf kf = Cil_datatype.Kf.Hashtbl.replace orig_kernel_functions new_kf kf; match new_kf.fundec, kf.fundec with | Declaration(_,new_vi,_,_), Declaration(_,vi,_,_) | Declaration(_,new_vi,_,_), Definition({ svar = vi }, _) | Definition({svar = new_vi},_), Declaration(_,vi,_,_) -> temp_set_orig_varinfo new_vi vi | Definition (new_fundec,_), Definition(fundec,_) -> temp_set_orig_fundec new_fundec fundec in let temp_memo_kernel_function kf = try Cil_datatype.Kf.Hashtbl.find kernel_functions kf with Not_found -> let new_kf = match kf.fundec with | Declaration (spec,vi,prms,loc) -> let new_vi = temp_memo_varinfo vi in { kf with fundec = Declaration(spec,new_vi,prms,loc) } | Definition(f,loc) -> let new_f = temp_memo_fundec f in { kf with fundec = Definition(new_f,loc) } in temp_set_kernel_function kf new_kf; temp_set_orig_kernel_function new_kf kf; new_kf in let temp_set_compinfo c new_c = Cil_datatype.Compinfo.Hashtbl.add compinfos c new_c; List.iter2 (fun f new_f -> Cil_datatype.Fieldinfo.Hashtbl.add fieldinfos f new_f) c.cfields new_c.cfields in let temp_set_orig_compinfo new_c c = Cil_datatype.Compinfo.Hashtbl.add orig_compinfos new_c c; List.iter2 (fun new_f f -> Cil_datatype.Fieldinfo.Hashtbl.add orig_fieldinfos new_f f) new_c.cfields c.cfields in let temp_memo_compinfo c = try Cil_datatype.Compinfo.Hashtbl.find compinfos c with Not_found -> let new_c = copyCompInfo ~fresh c c.cname in temp_set_compinfo c new_c; temp_set_orig_compinfo new_c c; new_c 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}); ccode_annotation = if fresh then Logic_const.refresh_code_annotation else (fun x -> { x with annot_id = x.annot_id }); cidentified_predicate = if fresh then Logic_const.refresh_predicate else (fun x -> { x with ip_id = x.ip_id }); cidentified_term = if fresh then Logic_const.refresh_identified_term else (fun x -> { x with it_id = x.it_id}); cexpr = (fun x -> let id = if fresh then Eid.next () else x.eid in { x with eid = id }); is_copy_behavior = true; is_fresh_behavior = fresh; 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 = temp_memo_compinfo; 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 sid = if fresh then Sid.next () else x.sid in let new_x = { x with sid = 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 _ = temp_memo_compinfo x.fcomp in (* memo_compinfo fills the field correspondence table as well *) let new_x = Cil_datatype.Fieldinfo.Hashtbl.find fieldinfos x 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 = temp_memo_kernel_function; memo_fundec = temp_memo_fundec; set_varinfo = temp_set_varinfo; set_compinfo = temp_set_compinfo; 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 = temp_set_logic_var; set_kernel_function = temp_set_kernel_function; set_fundec = temp_set_fundec; set_orig_varinfo = temp_set_orig_varinfo; set_orig_compinfo = temp_set_orig_compinfo; 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 = temp_set_orig_logic_var; set_orig_kernel_function = temp_set_orig_kernel_function; set_orig_fundec = temp_set_orig_fundec; 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); } let copy_visit = copy_visit_gen false let refresh_visit = copy_visit_gen true let visitor_tbl = Hashtbl.create 5 let register_behavior_extension name ext = Hashtbl.add visitor_tbl name ext (* 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 occurrence. 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 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. *) 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 vlocal_init: varinfo -> local_init -> local_init visitAction 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 * precede 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_node: predicate_node -> predicate_node visitAction method vpredicate: predicate -> predicate 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 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 vlocal_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_node _p = DoChildren method vpredicate _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!"; () let vis_tmp_attr = "FRAMAC_VIS_TMP_ATTR" let transient_block b = if b.blocals <> [] then Kernel.fatal "Attempting to mark as transient a block that declares local variables"; b.battrs <- addAttribute (Attr (vis_tmp_attr,[])) b.battrs; b let block_of_transient b = if hasAttribute vis_tmp_attr b.battrs then begin if b.blocals <> [] then Kernel.fatal "Block that is supposed to be transient declares local variabels"; b.battrs <- dropAttribute vis_tmp_attr b.battrs; b.bscoping <- false end; b let is_transient_block b = hasAttribute vis_tmp_attr b.battrs let flatten_transient_sub_blocks b = let prev = ref None in let previous_is_annot () = match !prev with | None -> false | Some { skind = Instr (Code_annot ({ annot_content = AStmtSpec _ | APragma _}, _))} -> true | Some _ -> false in let treat_one_stmt s = match s.skind with | Block b when is_transient_block b -> if previous_is_annot () then begin s.skind <- Block (block_of_transient b); prev := Some s; [ s ] end else begin match s.labels, b.bstmts with | [], _ -> prev:= None; b.bstmts | _, [] -> (* Empty block, but we have a label attached to the statement, so that it is difficult to get rid of it (see below). Replace with a Skip. *) s.skind <- Instr (Skip (Cil_datatype.Stmt.loc s)); prev:=Some s; [s] | _, s'::tl when s'.labels = [] -> (* res is the target of a label (either goto or case). Removing the block would imply updating the origin of the jump, which is quite complicated at this point. On the other hand, since s' is not referred to elsewhere, we can just put its skind in place of the block, and return the list. *) s.skind <- s'.skind; prev:=None; s :: tl | _ -> (* both the block and the first statement have labels. Just keep the block. *) s.skind <- Block (block_of_transient b); prev:=Some s; [s] end | _ -> prev:= Some s; [ s ] in b.bstmts <- List.concat (List.map treat_one_stmt b.bstmts); b let stmt_of_instr_list_visitor ?loc l = let res = stmt_of_instr_list ?loc l in match res with | Block b -> Block (transient_block b) | _ -> res (*** 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 (visitCilPredicate 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, visitCilPredicate vis p)) inddef in if i != inddef then LBinductive i else li.l_body | LBpred odef -> let def = visitCilPredicate 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 visitCilPredicateNode vis p = doVisitCil vis id vis#vpredicate_node childrenPredicateNode p and visitCilPredicate vis p = doVisitCil vis id vis#vpredicate childrenPredicate p and childrenIdentified_predicate vis ip = let p = ip.ip_content in let p' = visitCilPredicate vis p in if p != p' then { ip with ip_content = p' } else ip and childrenPredicate vis p = let content = visitCilPredicateNode vis p.pred_content in if content != p.pred_content then { p with pred_content = content} else p and childrenPredicateNode vis p = let vPred p = visitCilPredicate 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 | Pvalid_function t -> let t' = vTerm t in if t' != t then Pvalid_function 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 | Pdangling (s,t) -> let s' = visitCilLogicLabel vis s in let t' = vTerm t in if t' != t || s != s' then Pdangling (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,p as orig) = let visit = try Hashtbl.find visitor_tbl s with Not_found -> (fun _ _ -> DoChildren) in let p' = doVisitCil vis id (visit vis) childrenCilExtended p in if p == p' then orig else (s,p') and childrenCilExtended vis p = match p with | Ext_id _ -> p | Ext_terms terms -> let terms' = mapNoCopy (visitCilTerm vis) terms in if terms == terms' then p else Ext_terms terms' | Ext_preds preds -> let preds' = mapNoCopy (visitCilPredicate vis) preds in if preds == preds' then p else Ext_preds preds' 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 let mi_attr = visitCilAttributes vis m.mi_attr 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; mi_attr; } else begin m.mi_attr <- mi_attr; m end 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,attr,loc) -> let p' = visitCilPredicate vis p in let attr' = visitCilAttributes vis attr in if p' != p || attr != attr' then Dlemma(s,is_axiom,labels,tvars,p',attr',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,attr,loc) -> let attr' = visitCilAttributes vis attr in if attr != attr' then Dcustom_annot(c,n,attr',loc) else a | Dvolatile(tset,rvi,wvi,attr,loc) -> let tset' = mapNoCopy (visitCilIdTerm vis) tset in let rvi' = optMapNoCopy (visitCilVarUse vis) rvi in let wvi' = optMapNoCopy (visitCilVarUse vis) wvi in let attr' = visitCilAttributes vis attr in if tset' != tset || rvi' != rvi || wvi' != wvi || attr' != attr then Dvolatile(tset',rvi',wvi',attr',loc) else a | Daxiomatic(id,l,attr,loc) -> (* Format.eprintf "cil.visitCilAnnotation on axiomatic %s@." id; *) let l' = mapNoCopy (visitCilAnnotation vis) l in let attr' = visitCilAttributes vis attr in if l' != l || attr != attr' then Daxiomatic(id,l',attr',loc) else a and visitCilCodeAnnotation vis ca = doVisitCil vis vis#behavior.ccode_annotation vis#vcode_annot childrenCodeAnnot ca and childrenCodeAnnot vis ca = let vPred p = visitCilPredicate 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 | AExtended(behav, ext) -> let ext' = visitCilExtended vis ext in if ext' != ext then change_content (AExtended (behav, ext')) else ca and visitCilExpr (vis: cilVisitor) (e: exp) : exp = let oldLoc = CurrentLoc.get () in CurrentLoc.set e.eloc; let res = doVisitCil vis vis#behavior.cexpr 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 visitCilLocal_init (vis: cilVisitor) vi li = doVisitCil vis id (vis#vlocal_init vi) (childrenLocal_init vi) li and childrenLocal_init vi (vis: cilVisitor) li = match li with | AssignInit i -> let i' = visitCilInit vis vi NoOffset i in if i != i' then AssignInit i' else li | ConsInit(f,args, k) -> let f' = visitCilVarUse vis f in let args' = mapNoCopy (visitCilExpr vis) args in if f' != f || args' != args then ConsInit(f',args',k) else li 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 | Local_init (vi, li, l) -> let vi' = visitCilVarUse vis vi in let li' = visitCilLocal_init vis vi' li in if vi' != vi || li' != li then Local_init(vi', li', l) else 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,ext_asm,l) -> (match ext_asm with | None -> i (* only strings and location, nothing to visit. *) | Some ext -> let asm_outputs = mapNoCopy (fun ((id,s,lv) as pair) -> let lv' = fLval lv in if lv' != lv then (id,s,lv') else pair) ext.asm_outputs in let asm_inputs = mapNoCopy (fun ((id,s,e) as pair) -> let e' = fExp e in if e' != e then (id,s,e') else pair) ext.asm_inputs in let asm_gotos = if vis#behavior.is_copy_behavior then List.map (fun s -> ref (vis#behavior.memo_stmt !s)) ext.asm_gotos else ext.asm_gotos in if asm_outputs != ext.asm_outputs || asm_inputs != ext.asm_inputs || asm_gotos != ext.asm_gotos then begin let ext = { ext with asm_outputs; asm_inputs; asm_gotos } in Asm(sl,isvol,Some ext,l) end 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 *) | _ -> let b = mkBlockNonScoping ((List.map (fun i -> mkStmt (Instr i)) !toPrepend) @ [mkStmt res.skind]) in b.battrs <- addAttribute (Attr (vis_tmp_attr, [])) b.battrs; (* Make our statement contain the instructions to prepend *) res.skind <- Block b); 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 (match stmt'.skind with | Block b -> b.battrs <- dropAttribute vis_tmp_attr b.battrs; | _ -> ()); (* 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_visitor ~loc:(Cil_datatype.Instr.loc i) il end | Block b -> let b' = fBlock b in if b' != b then Block b' else s.skind | Throw (e,loc) -> let visit (e,t as exc) = let e' = fExp e in let t' = visitCilType vis t in if e != e' || t != t' then (e',t') else exc in let e' = optMapNoCopy visit e in if e != e' then Throw (e,loc) else s.skind | TryCatch (b,l,loc) -> let b' = fBlock b in let visit (v,b as catch) = let v' = visitCilCatch_binder vis v in let b' = fBlock b in if v != v' || b != b' then (v', b') else catch in let l' = mapNoCopy visit l in if b != b' || l != l' then TryCatch (b', l',loc) 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 visitCilCatch_binder vis cb = match cb with | Catch_exn (v,l) -> let visit_one_conversion (v, b as conv) = let v' = visitCilVarDecl vis v in let b' = visitCilBlock vis b in if v != v' || b != b' then (v', b') else conv in let v' = visitCilVarDecl vis v in let l' = mapNoCopy visit_one_conversion l in if v != v' || l != l' then Catch_exn(v',l') else cb | Catch_all -> cb 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 let res = if stmts' != b.bstmts || locals' != b.blocals then { battrs=b.battrs; bstmts=stmts'; blocals=locals'; bscoping=b.bscoping } else b in flatten_transient_sub_blocks res 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 = (* in case of refresh visitor, the associated new logic var has a different id. We must visit the original logic var associated to it. *) let visit_orig_var_assoc lv = let o = vis#behavior.get_original_logic_var lv in visitCilLogicVarDecl vis o in v.vtype <- visitCilType vis v.vtype; v.vattr <- visitCilAttributes vis v.vattr; v.vlogic_var_assoc <- optMapNoCopy visit_orig_var_assoc 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; (* update fundec tables *) let f = vis#behavior.memo_fundec f in 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 = (* we have already made a copy of the svar, but not visited it. Use the original variable as argument of visitCilVarDecl, update fundec table in case the vid gets changed. *) let v = vis#behavior.get_original_varinfo f.svar in let nv = visitCilVarDecl vis v in if not (Cil_datatype.Varinfo.equal nv f.svar) then begin Kernel.fatal "Visiting the varinfo declared for function %a changes its id." Cil_datatype.Varinfo.pretty nv end; f.svar <- nv; (* 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 = (* already done at copy creation *) (* 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 = let f = vis#behavior.get_original_fieldinfo f in 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) ; 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(v, l) -> let v' = visitCilVarDecl vis v in if v' != v then GVarDecl (v', l) else g | GFunDecl(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 is_empty_funspec spec then begin 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 else begin visitCilFunspec vis spec 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 -> ()); GFunDecl (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 let bytesSizeOfInt (ik: ikind): int = match ik with | IChar | ISChar | IUChar | IBool -> 1 | 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 uint64_t () = TInt(intKindForSize 8 true,[]) let uint32_t () = TInt(intKindForSize 4 true,[]) let uint16_t () = TInt(intKindForSize 2 true,[]) let int64_t () = TInt(intKindForSize 8 false,[]) let int32_t () = TInt(intKindForSize 4 false,[]) let int16_t () = TInt(intKindForSize 2 false,[]) 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.Integer.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 fitsInInt k i then i, false else let i' = 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 in if debugTruncation then Kernel.debug ~level:3 "Truncate %a to %a: %a" Datatype.Integer.pretty i !pp_ikind_ref k Datatype.Integer.pretty i'; i', true exception Not_representable 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 if fitsInInt IULongLong i then IULongLong else raise Not_representable 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 if fitsInInt ILongLong i then ILongLong else raise Not_representable (* Construct an integer constant with possible truncation if the kind is not specified *) let kinteger64 ~loc ?repr ?kind i = if debugTruncation then Kernel.debug ~level:3 "kinteger64 %a" Datatype.Integer.pretty i; let kind = match kind with | None -> (* compute the best ikind: [int] whenever possible and, if no signed type is possible, try unsigned long long. *) if fitsInInt IInt i then IInt else begin try intKindForValue i false with Not_representable as exn -> if fitsInInt IULongLong i then IULongLong else raise exn end | Some k -> k in let i', _truncated = truncateInteger64 kind i in new_exp ~loc (Const (CInt64(i' , kind, repr))) (* Construct an integer of a given kind. *) let kinteger ~loc kind (i: int) = kinteger64 ~loc ~kind (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) *) let charConstToInt c = let c' = Char.code c in if c' < 128 then Integer.of_int c' else Integer.of_int (c' - 256) let charConstToIntConstant c = CInt64(charConstToInt c, IInt, None) let rec isInteger e = match e.enode with | Const(CInt64 (n,_,_)) -> Some n | Const(CChr c) -> Some (charConstToInt c) | Const(CEnum {eival = v}) -> isInteger v | CastE(_, e) -> isInteger e (* BY: This is really strange... *) | _ -> None 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 = Transitioning.String.uppercase_ascii (String.sub str (l - ls) ls) in let l = String.length str in (* See if it is octal or hex or binary *) let octalhexbin = l >= 1 && 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 octalhexbin then [ILongLong; IULongLong] else [ILongLong] else if hasSuffix "UL" || hasSuffix "LU" then 2, [IULong; IULongLong] else if hasSuffix "L" then 1, if octalhexbin then [ILong; IULong; ILongLong; IULongLong] else [ILong; ILongLong] else if hasSuffix "U" then 1, [IUInt; IULong; IULongLong] else 0, if octalhexbin || 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 = if Integer.ge what base then Kernel.fatal ~current:true "Invalid digit %a in integer constant '%s' in base %a." (Integer.pretty ~hexa:false) what str (Integer.pretty ~hexa:false) base; 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 octalhexbin && l >= 2 then (match String.get str 1 with | 'x' | 'X' (* Hexadecimal number *) -> toInt Integer.small_nums.(16) Integer.zero 2 | 'b' | 'B' -> (* Binary number *) toInt Integer.small_nums.(2) Integer.zero 2 | _ -> (* Octal number *) 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 repr = let i,kinds = parseIntAux repr in let rec loop = function | k::rest -> if fitsInInt k i then (* i fits in the current type. *) kinteger64 ~loc ~repr ~kind:k i else loop rest | [] -> Kernel.fatal ~source:(fst loc) "Cannot represent the integer %s" repr in loop kinds 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 ?valid_sid ?(loc=Location.unknown) () = mkStmt ?ghost ?valid_sid (Instr (Skip loc)) let mkStmtOneInstr ?ghost ?valid_sid i = mkStmt ?ghost ?valid_sid (Instr i) let dummyInstr = Asm([], ["dummy statement!!"], None, Location.unknown) let dummyStmt = mkStmt (Instr dummyInstr) 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 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 ~valid_sid:true (Loop ([], mkBlock (mkStmt ~valid_sid:true (If(guard, mkBlock [], 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: exp) ~(incr: exp) ~(body: stmt list) : stmt list = (* See what kind of operator we need *) let nextop = match unrollTypeSkel iter.vtype with | TPtr _ -> PlusPI | _ -> PlusA in mkFor [ mkStmtOneInstr ~valid_sid:true (Set (var iter, first, first.eloc)) ] (new_exp ~loc:stopat.eloc (BinOp(Lt, evar iter, stopat, intType))) [ mkStmtOneInstr ~valid_sid:true (Set (var iter, (new_exp ~loc:incr.eloc (BinOp(nextop, evar iter, incr, iter.vtype))), incr.eloc))] body let block_from_unspecified_sequence us = mkBlock (List.map (fun (x,_,_,_,_) ->x) us) 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 (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 isVoidType t = match unrollTypeSkel t with TVoid _ -> true | _ -> false let isVoidPtrType t = match unrollTypeSkel t with TPtr(tau,_) when isVoidType tau -> true | _ -> false 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 isIntegralOrPointerType t = match unrollTypeSkel t with | TInt _ | TEnum _ | TPtr _ -> 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 isArithmeticOrPointerType t= match unrollTypeSkel t with | TInt _ | TEnum _ | TFloat _ | TPtr _ -> 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 | _ -> Kernel.fatal "Not an array type %a" !pp_typ_ref t (**** 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 (* l-values used as r-values lose their qualifiers (C99 6.3.2.1:2) *) | Lval(lv) -> type_remove_qualifier_attributes (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 (_, _, contagious) = partitionAttributes ~default:(AttrName false) baseAttrs in let putAttributes = function | Ctype typ -> Ctype (typeAddAttributes contagious 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 for the presence of an attribute in a type ****) let typeHasAttribute attr typ = hasAttribute attr (typeAttrs typ) let rec typeHasQualifier attr typ = match typ with | TNamed (t, a) -> hasAttribute attr a || typeHasQualifier attr t.ttype | TArray (t, _, _, a) -> typeHasQualifier attr t || (* ill-formed type *) hasAttribute attr a | _ -> hasAttribute attr (typeAttrs typ) 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 (* Get the minimum alignment 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 other 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 (msvcMode ()) && f.fbitfield = Some 0 then sofar else max sofar (alignOfField f)) 1 fields (* These are some error cases *) | TFun _ when not (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 process_aligned_attribute ~may_reduce:false (fun fmt -> !pp_typ_ref fmt t) (typeAttrs t) alignOfType (* Alignment of a possibly-packed or aligned struct field. From the GCC manual (https://gcc.gnu.org/onlinedocs/gcc/Common-Type-Attributes.html): "Specifying the packed attribute for struct and union types is equivalent to specifying the packed attribute on each of the structure or union members." Note that is not the case for the aligned attribute, which behaves differently when put into a struct, or in each of its fields. *) and alignOfField (fi: fieldinfo) = let fieldIsPacked = hasAttribute "packed" fi.fattr || hasAttribute "packed" fi.fcomp.cattr in if fieldIsPacked then begin if hasAttribute "aligned" fi.fattr then (* field is packed and aligned => process alignment *) let field_alignment = process_aligned_attribute ~may_reduce:true (fun fmt -> Format.fprintf fmt "field %s" fi.fname) fi.fattr (fun () -> bytesAlignOf fi.ftype) in field_alignment else (* packed and without minimum alignment => align on 1 *) 1 end else process_aligned_attribute ~may_reduce:false (fun fmt -> Format.fprintf fmt "field %s" fi.fname) fi.fattr (fun () -> bytesAlignOf fi.ftype) and intOfAttrparam (a:attrparam) : int option = let rec doit a : int = match a with | AInt(n) -> Integer.to_int n | ABinOp(PlusA, a1, a2) -> doit a1 + doit a2 | ABinOp(MinusA, a1, a2) -> doit a1 - doit a2 | ABinOp(Mult, a1, a2) -> doit a1 * doit a2 | ABinOp(Div, a1, a2) -> (doit a1) / (doit a2) | ABinOp(Shiftlt, a1, a2) -> (doit a1) lsl (doit a2) | ABinOp(Lt, a1, a2) -> if doit a1 < doit a2 then 1 else 0 | ABinOp(Gt, a1, a2) -> if doit a1 > doit a2 then 1 else 0 | ABinOp(Le, a1, a2) -> if doit a1 <= doit a2 then 1 else 0 | ABinOp(Ge, a1, a2) -> if doit a1 >= doit a2 then 1 else 0 | ABinOp(Eq, a1, a2) -> if doit a1 = doit a2 then 1 else 0 | ABinOp(Ne, a1, a2) -> if doit a1 <> doit a2 then 1 else 0 | ABinOp(BAnd, a1, a2) -> doit a1 land doit a2 | ABinOp(BXor, a1, a2) -> doit a1 lxor doit a2 | ABinOp(BOr, a1, a2) -> doit a1 lor doit a2 | AQuestion(c,a1,a2) -> if doit c <> 0 then doit a1 else 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 and process_aligned_attribute (pp:Format.formatter->unit) ~may_reduce attrs default_align = (* [may_reduce] indicates if we can reduce the alignment (e.g. a "packed" attribute is present). According to GCC's doc (https://gcc.gnu.org/onlinedocs/gcc/Common-Type-Attributes.html): "The aligned attribute can only increase alignment. Alignment can be decreased by specifying the packed attribute." *) match filterAttributes "aligned" attrs with | [] -> (* no __aligned__ attribute, so get the default alignment *) default_align () | _ when !ignoreAlignmentAttrs -> Kernel.warning ~current:true "ignoring recursive align attributes on %t" pp; default_align () | (Attr(_, [a]) as at)::rest -> begin if rest <> [] then Kernel.warning ~current:true "ignoring duplicate align attributes on %t" pp; match intOfAttrparam a with | Some n -> if may_reduce then n else max n (default_align ()) | None -> Kernel.warning ~current:true "alignment attribute \"%a\" not understood on %t" !pp_attribute_ref at pp; default_align () 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 ~current:true "ignoring duplicate align attributes on %t" pp; theMachine.theMachine.alignof_aligned | at::_ -> Kernel.warning ~current:true "alignment attribute \"%a\" not understood on %t" !pp_attribute_ref at pp; default_align () (* Computation of the offset of the field [fi], given the information [sofar] computed for the previous fields. [last] indicates that we are considering the last field of the struct. Set to [false] by default for unions. *) and offsetOfFieldAcc ?(last=false) ~(fi: fieldinfo) ~(sofar: offsetAcc) : offsetAcc = if msvcMode () then offsetOfFieldAcc_MSVC last fi sofar else offsetOfFieldAcc_GCC last fi sofar (* GCC version *) (* Does not use the sofar.oaPrevBitPack *) and offsetOfFieldAcc_GCC last (fi: fieldinfo) (sofar: offsetAcc) : offsetAcc = (* field type *) let ftype = unrollType fi.ftype in let ftypeAlign = 8 * alignOfField fi in let ftypeBits = (if last then bitsSizeOfEmptyArray else 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 last (fi: fieldinfo) (sofar: offsetAcc) : offsetAcc = (* field type *) let ftype = unrollType fi.ftype in let ftypeAlign = 8 * alignOfField fi in let ftypeBits = (if last then bitsSizeOfEmptyArray else 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 last 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 last 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" (** This is a special version of [bitsSizeOf] that accepts empty arrays. Currently, we only use it for flexible array members *) and bitsSizeOfEmptyArray typ = match unrollType typ with | TArray (_, None, _, _) -> 0 | TArray (_, Some e, _, _) -> begin match constFoldToInt e with | Some i when Integer.is_zero i -> (* Used for GCC extension of non-C99 flexible array members. Note that Cabs2cil no longer rewrites top-level zero-sized arrays, so this can also happen in such cases. *) 0 | _ -> bitsSizeOf typ end | _ -> bitsSizeOf typ (* The size of a type, in bits. If struct or array then trailing padding is * added *) and bitsSizeOf t = 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 (* sizeof() empty structs/arrays is only allowed on GCC/MSVC *) if not comp.cdefined && not (gccMode () || 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 = fold_struct_fields (fun ~last acc fi -> offsetOfFieldAcc ~last ~fi ~sofar:acc) startAcc comp.cfields in if 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 ?last:None ~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 _ -> 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 (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, _, _) -> raise (SizeOfError ("Size of array without number of elements.", t)) (* Iterator on the fields of a structure, with additional information about having reached the last field (for flexible member arrays) *) and fold_struct_fields f acc l = match l with | [] -> acc | [fi_last] -> f ~last:true acc fi_last | fi :: (_ :: _ as q) -> fold_struct_fields f (f ~last:false acc fi) q and addTrailing nrbits roundto = (nrbits + roundto - 1) land (lnot (roundto - 1)) and bytesSizeOf 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 = let rec loopOff (baset: typ) (width: int) (start: int) = function NoOffset -> start, width | Index(e, off) -> begin let ei = match constFoldToInt e with | Some i -> Integer.to_int i | None -> raise (SizeOfError ("Index is not constant", baset)) in let bt = typeOf_array_elem baset in let bitsbt = bitsSizeOf bt in loopOff bt bitsbt (start + ei * bitsbt) off end | Field(f, off) when not f.fcomp.cstruct (* union *) -> 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) (* struct *) -> if check_invariants then assert (match unrollType baset with | TComp (ci, _, _) -> ci == f.fcomp | _ -> false); if f.foffset_in_bits = None then begin let aux ~last acc fi = let acc' = offsetOfFieldAcc ~last ~fi ~sofar:acc in fi.fsize_in_bits <- Some acc'.oaLastFieldWidth; fi.foffset_in_bits <- Some acc'.oaLastFieldStart; acc' in ignore ( fold_struct_fields aux { oaFirstFree = 0; oaLastFieldStart = 0; oaLastFieldWidth = 0; oaPrevBitPack = None } f.fcomp.cfields ); end; let offsbits, size = Extlib.the f.foffset_in_bits, Extlib.the f.fsize_in_bits in loopOff f.ftype size (start + offsbits) off in loopOff baset (bitsSizeOf baset) 0 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 ~loc ?repr ~kind:tk (Integer.neg i) | BNot -> kinteger64 ~loc ~kind: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(charConstToIntConstant 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 (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*) (* Special case to handle the C macro 'offsetof' *) | 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 | Const(CInt64(i,_k,_)),(TInt(nk,a)|TEnum({ekind = nk},a)) when a = [] -> begin (* If the cast has attributes, leave it alone. *) if debugConstFold then Kernel.debug "ConstFold to %a : %a@." !pp_ikind_ref nk Datatype.Integer.pretty i; (* Downcasts might truncate silently *) kinteger64 ~loc ~kind:nk i end | Const (CReal(f,_,_)),(TInt(ik,a)|TEnum({ekind = ik},a)) when a = [] -> (* See above *) begin try let i = Floating_point.truncate_to_integer f in let _i', truncated = truncateInteger64 ik i in if truncated then (* Float is too big. Do not const-fold *) new_exp ~loc (CastE (t, e)) else kinteger64 ~loc ~kind:ik i with Floating_point.Float_Non_representable_as_Int64 _ -> (* too big*) new_exp ~loc (CastE (t, e)) end | _, _ -> 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(charConstToIntConstant 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 ~kind: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 ~kind:tk (Integer.add i1 i2) | MinusA, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> kinteger64 ~loc ~kind:tk (Integer.sub i1 i2) | Mult, Const(CInt64(i1,ik1,_)), Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> kinteger64 ~loc ~kind: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 ~kind: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 ~kind: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 ~kind: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 ~kind: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 ~kind: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 ~kind:tk (Integer.logxor i1 i2) | Shiftlt, Const(CInt64(i1,_ik1,_)),Const(CInt64(i2,_,_)) when shiftInBounds i2 -> kinteger64 ~loc ~kind: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 ~kind:tk (Integer.shift_right_logical i1 i2) else kinteger64 ~loc ~kind: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)) and constFoldToInt ?(machdep=true) e = match (constFold machdep e).enode with | Const(CInt64(c,_,_)) -> Some c | CastE (typ, e) when machdep && isPointerType typ -> begin (* Those casts are left left by constFold *) match constFoldToInt ~machdep e with | None -> None | Some i as r -> if fitsInInt theMachine.upointKind i then r else None end | _ -> None let () = constfoldtoint := constFoldToInt ~machdep:true 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 MSVC, 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 let invalidStmt = mkStmt (Instr (Skip Location.unknown)) 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 () = dependency_on_ast 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"; ] 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 add_builtin ?(prefix="__builtin_") s t l b = Builtin_functions.add (prefix ^ s) (t, l, b) let () = registerAttribute "FC_BUILTIN" (AttrName true) (* Initialize the builtin functions after the machine has been initialized. *) let initGccBuiltins () : unit = let sizeType = theMachine.upointType in let add = add_builtin 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; let uint16t = uint16_t () in add "bswap16" uint16t [uint16t] false; let uint32t = uint32_t () in add "bswap32" uint32t [uint32t] false; let uint64t = uint64_t () in add "bswap64" uint64t [uint64t] 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 "ia32_lfence" voidType [] false; add "ia32_mfence" voidType [] false; add "ia32_sfence" voidType [] 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 "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; add "unreachable" voidType [ ] false; let int8_t = Some scharType in let int16_t = try Some (int16_t ()) with Not_found -> None in let int32_t = try Some (int32_t ()) with Not_found -> None in let int64_t = try Some (int64_t ()) with Not_found -> None in let uint8_t = Some ucharType in let uint16_t = try Some (uint16_t ()) with Not_found -> None in let uint32_t = try Some (uint32_t ()) with Not_found -> None in let uint64_t = try Some (uint64_t ()) with Not_found -> None in (* Binary monomorphic versions of atomic builtins *) let atomic_instances = [int8_t, "_int8_t"; int16_t,"_int16_t"; int32_t,"_int32_t"; int64_t,"_int64_t"; uint8_t, "_uint8_t"; uint16_t,"_uint16_t"; uint32_t,"_uint32_t"; uint64_t,"_uint64_t"] in let add_sync (typ,name) f = match typ with | Some typ -> add ~prefix:"__sync_" (f^name) typ [ TPtr(typ,[]); typ] true | None -> () in let add_sync f = List.iter (fun typ -> add_sync typ f) atomic_instances in add_sync "fetch_and_add"; add_sync "fetch_and_sub"; add_sync "fetch_and_or"; add_sync "fetch_and_and"; add_sync "fetch_and_xor"; add_sync "fetch_and_nand"; add_sync "add_and_fetch"; add_sync "sub_and_fetch"; add_sync "or_and_fetch"; add_sync "and_and_fetch"; add_sync "xor_and_fetch"; add_sync "nand_and_fetch"; add_sync "lock_test_and_set"; List.iter (fun (typ,n) -> match typ with | Some typ -> add ~prefix:"" ("__sync_bool_compare_and_swap"^n) intType [ TPtr(typ,[]); typ ; typ] true | None -> ()) atomic_instances; List.iter (fun (typ,n) -> match typ with | Some typ -> add ~prefix:"" ("__sync_val_compare_and_swap"^n) typ [ TPtr(typ,[]); typ ; typ] true | None -> ()) atomic_instances; List.iter (fun (typ,n) -> match typ with | Some typ -> add ~prefix:"" ("__sync_lock_release"^n) voidType [ TPtr(typ,[]) ] true; | None -> ()) atomic_instances; add ~prefix:"" "__sync_synchronize" voidType [] true ;; (* Builtins related to va_list. Added to all non-msvc machdeps, because Cabs2cil supposes they exist. *) let initVABuiltins () = let hasbva = theMachine.theMachine.has__builtin_va_list in let add = add_builtin in add "next_arg" (* When we parse builtin_next_arg we drop the second argument *) (if hasbva then TBuiltin_va_list [] else voidPtrType) [] 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 let initMsvcBuiltins () : unit = (** Take a number of wide string literals *) Builtin_functions.add "__annotation" (voidType, [ ], true) ;; let init_builtins () = if not (TheMachine.is_computed ()) then Kernel.fatal ~current:true "You must call initCIL before init_builtins" ; if Builtin_functions.length () <> 0 then Kernel.fatal ~current:true "Cil builtins already initialized." ; if msvcMode () then initMsvcBuiltins () else begin initVABuiltins (); if gccMode () then initGccBuiltins (); end (** 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 constFoldToInt e1.eival, constFoldToInt 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 (* 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=FreeAllocAny) ?(extended=[]) () = { b_name = name; b_assumes = assumes; (* must be always empty for default_behavior_name *) b_requires = requires; b_assigns = assigns ; b_allocation = allocation ; b_post_cond = post_cond ; b_extended = extended; } let spare_attributes_for_c_cast = "declspec"::"arraylen"::"fc_stdlib"::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 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 Attributes.equal 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_attr = []; lv_origin = Some vi} in vi.vlogic_var_assoc <- Some lv; lv | Some lv -> lv let copyVarinfo (vi: varinfo) (newname: string) : varinfo = let vi' = Cil_const.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 ?(temp=false) ?(formal=false) fdec name typ = (* a helper function *) let name = findUniqueName fdec name in fdec.smaxid <- 1 + fdec.smaxid; let vi = makeVarinfo ~temp false formal name typ in vi (* Make a local variable and add it to a function *) let makeLocalVar fdec ?scope ?(temp=false) ?(insert = true) name typ = let typ = stripConstLocalType typ in let vi = makeLocal ~temp 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 ~temp:true ?insert name typ in vi.vdescr <- descr; vi.vdescrpure <- descrpure; vi (* 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 ?source ?temp name typ = makeVarinfo ?source ?temp true false name typ let mkPureExprInstr ~fundec ~scope ?loc e = let loc = match loc with None -> e.eloc | Some l -> l in let typ = typeOf e in let descr = Format.asprintf "%a" !pp_exp_ref e in let tmp = makeLocalVar ~temp:true ~scope fundec "tmp" typ in tmp.vdescr <- Some descr; tmp.vdefined <- true; Local_init(tmp, AssignInit (SingleInit e), loc) let mkPureExpr ?(ghost:bool = false) ~(fundec:fundec) ?loc (e : exp) : stmt = let scope = mkBlock [] in let instr = mkPureExprInstr ~fundec ~scope ?loc e in scope.bstmts <- [ mkStmtOneInstr ~ghost instr]; mkStmt (Block scope) 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 ~temp: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) = String.map (fun c -> if c = '-' || c = '.' then '_' else c) 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 (bytesSizeOf 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 | GFunDecl(_, vi, _) :: _rest when vi.vname = name -> vi | GVarDecl(vi,_) :: _rest when vi.vname = name -> Kernel.fatal ~current:true "findOrCreateFunc: can't create %s because another global exists \ with that name." name ; | _ :: rest -> search rest (* tail recursive *) | [] -> (*not found, so create one *) let t' = unrollTypeDeep t in let new_decl = makeGlobalVar ~temp:false name t' in setFormalsDecl new_decl t'; f.globals <- GFunDecl(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 <- GFunDecl (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) | TryCatch(b,l,_) -> peepHole1 doone b.bstmts; List.iter (fun (_,b) -> peepHole1 doone b.bstmts) l | 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 _ | Throw _ -> ()) ss (* Process two statements and possibly replace them both *) let rec peepHole2 ~aggressive (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 aggressive 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 _ | Local_init (_, ConsInit _, _)) -> [ref s] | _ -> [] in let res = (hd, m1@m2, w1 @ w2, r1 @ r2,call hd) :: (List.map (fun x -> x,[],[],[],call x) tl) in if aggressive 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 ~aggressive dotwo tb.bstmts; eb.bstmts <- peepHole2 ~aggressive dotwo eb.bstmts | Switch (_e, b, _, _) -> b.bstmts <- peepHole2 ~aggressive dotwo b.bstmts | Loop (_, b, _l, _, _) -> b.bstmts <- peepHole2 ~aggressive dotwo b.bstmts | Block b -> b.bstmts <- doStmtList [] b.bstmts | TryCatch (b,l,_) -> b.bstmts <- peepHole2 ~aggressive dotwo b.bstmts; List.iter (fun (_,b) -> b.bstmts <- peepHole2 ~aggressive dotwo b.bstmts) l | TryFinally (b, h, _l) -> b.bstmts <- peepHole2 ~aggressive dotwo b.bstmts; b.bstmts <- peepHole2 ~aggressive dotwo h.bstmts | TryExcept (b, (_il, _e), h, _l) -> b.bstmts <- peepHole2 ~aggressive dotwo b.bstmts; h.bstmts <- peepHole2 ~aggressive dotwo h.bstmts; () (*s.skind <- TryExcept (b, (doInstrList il, e), h, l)*) | UnspecifiedSequence seq -> s.skind <- UnspecifiedSequence (doUnspecifiedStmtList seq) | Return _ | Goto _ | Break _ | Continue _ | Throw _ -> () in if aggressive then List.iter process ss; doStmtList [] ss (* 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 treat_constructor_as_func action v f args kind loc = let lv, args = match kind with | Plain_func -> Some (var v), args | Constructor -> None, mkAddrOfVi v :: args in action lv (evar f) args loc let fold_local_init b f acc = let rec find_stmt acc s = match s.skind with | Instr(Local_init(v',i,l)) -> f s (v',i,l) acc | UnspecifiedSequence l -> List.fold_left find_stmt_seq acc l | Block b when not b.bscoping -> List.fold_left find_stmt acc b.bstmts | _ -> acc and find_stmt_seq acc (s, _, _, _, _) = find_stmt acc s in List.fold_left find_stmt acc b.bstmts let find_def_stmt b v = if not (v.vdefined && List.exists (Cil_datatype.Varinfo.equal v) b.blocals) then Kernel.fatal "inconsistent arguments for find_def_stmt"; let module M = struct exception Found of stmt end in let action s (v',_,_) () = if Cil_datatype.Varinfo.equal v v' then raise (M.Found s) else () in try fold_local_init b action (); Kernel.fatal ~source:(fst v.vdecl) "inconsistent AST: local variable %a is supposed to be initialized, \ but no initialization statement found." Cil_datatype.Varinfo.pretty v with M.Found s -> s let has_extern_local_init b = (* a scoping block defines all the locals inside it.*) if b.bscoping then false else begin let action _ _ () = raise Exit in try fold_local_init b action (); false with Exit -> true end 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 ?(forComparison=false) (t : typ) : typ = (* c.f. ISO 6.3.1.1 *) match unrollType t with | TInt ((IShort|ISChar|IBool), a) -> TInt(IInt, a) | TInt (IUChar|IUShort as k, a) -> if bitsSizeOfInt k < bitsSizeOf intType then TInt(IInt, a) else TInt(IUInt,a) | TInt (IChar,a) -> let k = if isSigned IChar then ISChar else IUChar in integralPromotion ~forComparison (TInt (k, 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) -> let r = integralPromotion (TInt(ei.ekind, a)) in if forComparison then (match r with | TInt(kind,_) -> if kind <> ei.ekind then r else t | t -> Kernel.fatal ~current:true "integralPromotion: not expecting %a" !pp_typ_ref t) else r (* gcc packed enums can be < int *) | t -> Kernel.fatal ~current:true "integralPromotion: not expecting %a" !pp_typ_ref t let integralPromotion (t : typ) : typ = integralPromotion 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 (* Issue #!1546 let force = force || (* see warning of need_cast function: [false] as default value for that option is not safe... *) (match e.enode with | Const(CEnum _) -> false | _ -> true) in *) if need_cast ~force oldt newt then begin let target_type = match newt with | TNamed _ -> newt | _ -> type_remove_attributes_for_c_cast newt in let mk_cast exp = (* to new type [newt] *) new_exp ~loc (CastE(target_type,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 ~kind:newik i | TPtr _, CastE (_, e') -> (match unrollType (typeOf e'), e'.enode 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' | _, Const(CInt64 (i, _, _)) when Integer.is_zero i -> mk_cast 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 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 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 zeroing 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 -> (match comp.cfields with | [] -> CompoundInit(t, []) (* tolerate empty initialization. *) | f :: _rest -> (* ISO C99 [6.7.8.10] says that the first field of the union is the one we should initialize. *) CompoundInit(t, [(Field(f, NoOffset), makeZeroInit ~loc f.ftype)])) | TArray(bt, Some len, _, _) as t' -> let n = match constFoldToInt len with | Some 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 let default () = (* iter over the supplied initializers *) List.fold_left (fun acc (o, i) -> doinit o i bt acc) acc initl in if implicit then match leno with | Some lene -> begin match constFoldToInt lene with | Some i -> let len_array = Integer.to_int i in let len_init = List.length initl in if len_array <= len_init then default () (* enough elements in the initializers list *) else (* Some initializers are missing. Iterate over all the indexes in the array, and use either the supplied initializer, or a generic zero one. *) let loc = CurrentLoc.get () in let zinit = makeZeroInit ~loc bt in let acc = ref acc in let initl = ref initl in (* Is [off] the offset for the index [i] we are currently at. Works because [initl] is sorted by Cabs2cil.*) let good_offset i off = match off with | Index (i', NoOffset) -> Integer.(equal (Extlib.the (constFoldToInt i')) (of_int i)) | _ -> Kernel.fatal ~current:true "Invalid initializer" in for i = 0 to len_array - 1 do match !initl with | (off, init) :: qinitl when good_offset i off-> acc := doinit off init bt !acc; initl := qinitl | _ -> acc := doinit (Index(integer ~loc i, NoOffset)) zinit bt !acc done; assert (!initl = []); !acc | _ -> Kernel.fatal ~current:true "foldLeftCompoundAll: array with initializer and non-constant length" end | _ -> Kernel.fatal ~current:true "foldLeftCompoundAll: TArray with initializer and no length" else default () 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 ?(allowZeroSizeArrays=false) t = match unrollType t with | TArray(_t, None, _, _) -> false | TArray(_t, Some z, _, _) when isZero z -> allowZeroSizeArrays | TComp (comp, _, _) -> (* Struct or union *) comp.cdefined && List.for_all (fun fi -> isCompleteType ~allowZeroSizeArrays fi.ftype) comp.cfields | _ -> true (* makes sure that the type of a C variable and the type of its associated logic variable -if any- stay synchronized. See bts 1538 *) let update_var_type v t = v.vtype <- t; match v.vlogic_var_assoc with | None -> () | Some lv -> lv.lv_type <- Ctype t (** Uniquefy the variable names *) let uniqueVarNames (f: file) : unit = (* Setup the alpha conversion table for globals *) let gAlphaTable : (string, location Alpha.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, _, _) | GFunDecl(_, 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 *) Alpha.registerAlphaName gAlphaTable 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 lookupname = v.vname in let data = CurrentLoc.get () in let newname, oldloc = Alpha.newAlphaName ~alphaTable:gAlphaTable ~undolist ~lookupname ~data 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 *) Alpha.undoAlphaChanges gAlphaTable !undolist; () end | _ -> ()); () let is_case_label l = match l with | Case _ | Default _ -> true | _ -> false let initCIL ~initLogicBuiltins machdep = if not (TheMachine.is_computed ()) then begin (* Set the machine *) theMachine.theMachine <- machdep; (* 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 if name = "long long" then ILongLong else if name = "unsigned long long" then IULongLong else Kernel.fatal ~current:true "initCIL: cannot find the right ikind for type %s" 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 referred *) 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 referred 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 *) let aux acc v = if isFunctionType v.vtype then GFunDecl (empty_funspec (),v, loc) :: acc else begin let is_same_decl = function | GVarDecl(v',_) -> Cil_datatype.Varinfo.equal v v' | _ -> false in if List.exists is_same_decl !types then acc else begin variables := List.filter (fun x -> not (is_same_decl x)) !variables; GVarDecl (v, loc) :: acc end end in g :: (List.fold_left aux !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 Cil_const.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.pred_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) | Pvalid_function t | Pinitialized (_,t) | Pdangling (_,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 (visitCilPredicate (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 { pred_name = []; pred_loc = p.pred_loc; pred_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) (* Note: The implementation preserves the order of s.succs in the returned list. *) let separate_switch_succs s = let cases = match s.skind with | Switch (_, _, cases, _) -> cases | _ -> raise (Invalid_argument "separate_switch_succs") in let cases_set = List.fold_left (fun s stmt -> Stmt.Set.add stmt s) Stmt.Set.empty cases in let is_in_cases stmt = Stmt.Set.mem stmt cases_set in let contains_default_label stmt = let is_default_label = function | Default _ -> true | _ -> false in List.exists is_default_label stmt.labels in let contains_case_label stmt = let is_case_label = function | Case _ -> true | _ -> false in List.exists is_case_label stmt.labels in let default = ref None in let set_default s = if !default != None then Kernel.fatal ~current:true "Bad CFG: switch with multiple non-case successors."; default := Some s in let cases_non_default = ref [] in List.iter (fun stmt -> if not (is_in_cases stmt) then set_default stmt else if contains_default_label stmt then (set_default stmt; if contains_case_label stmt then cases_non_default := stmt::!cases_non_default) else (assert (contains_case_label stmt); cases_non_default := stmt::!cases_non_default)) s.succs; match !default with | None -> Kernel.fatal ~current:true "Bad CFG: switch with no non-case successors." | Some(d) -> (List.rev cases, d) ;; (** Get the two successors of an If statement *) let separate_if_succs (s:stmt) : stmt * stmt = match s.skind, s.succs with | If _, [sthen; selse] -> sthen, selse | _-> Kernel.fatal ~current:true "ifSuccs on an invalid If statement." module Switch_cases = State_builder.Hashtbl (Stmt.Hashtbl) (Datatype.Pair(Datatype.List(Stmt))(Stmt)) (struct let name = "Switch_cases" let dependencies = [] let size = 49 end) let () = dependency_on_ast Switch_cases.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 (internal_ty, attrs) -> let tty = typeAddAttributes attrs internal_ty.ttype in (* keep the original type whenever possible *) ChangeDoChildrenPost (tty, fun x -> if x == internal_ty.ttype then ty else 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} *) (* currently empty, but keep this section for future use. *) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_queries/logic_env.ml0000644000175000017500000002476313113745011025174 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* 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 constructors 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 constructors 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-Phosphorus-20170501/src/kernel_services/cmdline_parameters/0000755000175000017500000000000013113745010024172 5ustar mehdimehdiframa-c-Phosphorus-20170501/src/kernel_services/cmdline_parameters/cmdline.ml0000644000175000017500000010510513113745002026142 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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) module Kernel_log = Log.Register (struct let channel = Log.kernel_channel_name let label = Log.kernel_label_name let debug_atleast level = !kernel_debug_atleast_ref level let verbose_atleast level = !kernel_verbose_atleast_ref level end) let dkey = Kernel_log.register_category "cmdline" let quiet_ref = ref false let journal_enable_ref = ref !Config.is_gui let journal_isset_ref = ref false let use_obj_ref = ref true let use_type_ref = ref true let deterministic = ref false let last_project_created_by_copy = ref (fun () -> assert false) (* ************************************************************************* *) (** {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 () = (* Get the backtrace before potentially destroying it in the handler below *) let bt = Printexc.get_backtrace () in let current_src_string = try let src = Log.get_current_source() in Format.asprintf "Current source was: %s:%d@." (Filepath.pretty src.Lexing.pos_fname) src.Lexing.pos_lnum with Not_found -> "Current source was not set\n" in current_src_string ^ "The full backtrace is:\n" ^ bt 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 -> let bt = get_backtrace () in Printf.sprintf "%s\n%s aborted: internal error.%s\n%s" bt (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 -> let bt = get_backtrace () in Printf.sprintf "%s\nUnexpected error (%s).\n%s" bt (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.Build(struct type t = exn end) let at_error_exit = ErrorExit.extend let run_error_exit_hook = ErrorExit.apply let error_occurred_ref = ref None let error_occurred exn = error_occurred_ref := Some exn 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 exit 0 *) Kernel_log.fatal "Cmdline.bail_out must `exit 0'." let catch_toplevel_run ~f ~at_normal_exit ~on_error = (* both functions below handle errors at exit hooks *) let run_at_normal_exit () = try at_normal_exit (); Log.clean () with exn -> Kernel_log.feedback ~level:0 "error occurring when exiting Frama-C: stopping exit procedure.\n%s@." (protect exn); exit 5 in let run_on_error exn = try on_error exn; Log.clean () with exn' -> Kernel_log.feedback ~level:0 "error occurring when handling error: stopping error handling \ procedure.\n%s@." (protect exn'); exit 6 in let cleanup () = (match !error_occurred_ref with | None -> run_at_normal_exit () | Some exn -> run_on_error exn; (* even if an error occurred somewhere, Frama-C stops with error code 0. *) exit 0; ); in let bail_out () = cleanup (); exit 0; in bail_out_ref := bail_out; try f (); (* write again on stdout *) Log.set_output ~isatty:(Unix.isatty Unix.stdout) (Pervasives.output_substring stdout) (fun () -> Pervasives.flush stdout); cleanup (); with | Exit -> bail_out () | exn when catch_at_toplevel exn -> Kernel_log.feedback ~level:0 "%s" (protect exn); run_on_error exn; exit (exit_code exn) | exn -> run_on_error exn; 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 Kernel_log.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 type then_argument = | Default | Last | Replace | Name of string 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" | "-then-last" | "-then-replace" as then_name ] when then_expected -> Kernel_log.warning "ignoring last option `%s'." then_name; 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, Default) | "-then-last" :: then_options when then_expected -> unknown_options, nb_used, Some (then_options, Last) | "-then-replace" :: then_options when then_expected -> unknown_options, nb_used, Some (then_options, Replace) | "-then-on" :: project_name :: then_options when then_expected -> unknown_options, nb_used, Some (then_options, Name 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); "-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); "-deterministic", Unit (fun () -> deterministic := true); ] false all_options in (* Only useful for the toplevel version of Frama-C, so that OCaml does not try to parse those options. *) Arg.current := Array.length Sys.argv; catch_toplevel_run ~f:(fun () -> let remaining_options, _, _ = first_parsing_stage () in non_initial_options_ref := remaining_options) ~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 Kernel_log.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 use_obj = !use_obj_ref let use_type = !use_type_ref let deterministic = !deterministic (* ************************************************************************* *) (** {2 Plugin} *) (* ************************************************************************* *) type cmdline_option = { oname: string; argname: string; ohelp: string; ovisible: bool; ext_help: (unit,Format.formatter,unit) format; mutable 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 replace_option_setting: string -> plugin:string -> group:string -> option_setting -> unit 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 () = let cmp p1 p2 = Extlib.compare_ignore_case p1.name p2.name in List.sort cmp (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 -> Kernel_log.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 Kernel_log.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 -> Kernel_log.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 let replace_option_setting option ~plugin ~group setting = if option <> "" then let options_in_group = find_group plugin group in let rec replace = function | [] -> Kernel_log.fatal "no option %s in plugin %s ((group of options %s)." option plugin group | o :: _ when o.oname = option -> o.setting <- setting | _ :: l -> replace l in replace !options_in_group 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 = Kernel_log.feedback ~dkey "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 Kernel_log.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 let replace_option_setting = Plugin.replace_option_setting module On_Files = Hook.Build(struct type t = string list end) let use_cmdline_files = On_Files.extend let set_files used_loading l = Kernel_log.feedback ~dkey "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 (Kernel_log.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 Kernel_log.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 (Kernel_log.verify !nb_used_relevant "function `nb_given_options' called too early"); !nb_used_ref let load_all_plugins = ref (fun () -> assert false) (** execute one execution shot between 2 "-then*". @return the remaining "-then" and the associated options, if any *) let play_in_toplevel_one_shot 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 Kernel_log.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; Kernel_log.feedback ~dkey "running plug-in mains."; play (); then_options_extended let play_in_toplevel on_from_name nb_used play options = (* [aux then_opts] handles the following "-then" options *) let rec aux current = function | None -> () | Some(options, then_argument) -> let play_on options p = p, on_from_name p (fun () -> play_in_toplevel_one_shot nb_used play options) in let last_current, then_opts = match then_argument with | Default -> current, play_in_toplevel_one_shot nb_used play options | Last -> (match !last_project_created_by_copy () with | None -> Kernel_log.abort "no known last created project." | Some p -> play_on options p) | Replace -> (match !last_project_created_by_copy () with | None -> Kernel_log.abort "no known last created project." | Some p -> play_on (("-remove-projects=-@all,+" ^ current) :: options) p) | Name p -> play_on options p in aux last_current then_opts in (* play the first shot before the first "-then" *) let then_opts = play_in_toplevel_one_shot nb_used play options in (* play the "-then" options *) aux "default" then_opts type on_from_name = { on_from_name: 'a. string -> (unit -> 'a) -> 'a } let parse_and_boot ~on_from_name ~get_toplevel ~play_analysis = 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 !load_all_plugins (); 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.on_from_name (nb_used_early + nb_used_extending) play_analysis 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 -> Format.pp_print_text fmt help) (* the extended description *) (fun fmt -> Format.fprintf fmt ext_help) (* Prints option [o], its arguments, and its aliases. If [o] is an alias itself, print nothing. [print_invisible = true] forces printing invisible options. Returns [true] iff something was printed. *) 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 -> Kernel_log.fatal "[Cmdline.print_option_help] no group %s" group in (* linear search... *) let rec find_then_print = function | [] -> Kernel_log.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 (* Sorts command-line options inside a group *) let sort_cmdline_options = List.sort (fun o1 o2 -> String.compare o1.oname o2.oname) (* Sorts command-line groups inside a plugin *) let sort_groups groups = List.sort (fun (s1, _) (s2, _) -> String.compare s1 s2) (Hashtbl.fold (fun s l acc -> (s, l) :: acc) groups []) 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 (sort_cmdline_options l) in match sort_groups p.Plugin.groups with | [] -> () | g :: l -> let print_group newline (s, o) = if newline then Format.pp_print_newline fmt (); if s <> "" then Format.fprintf fmt "@[*** %s@]@\n@\n" (Transitioning.String.uppercase_ascii s); ignore (print_options !o) in print_group false g; List.iter (print_group true) l)); raise Exit let help () = Log.print_on_output begin fun fmt -> Format.fprintf fmt "\nThis is Frama-C %s\n" Config.version ; Format.fprintf fmt "\nUsage:\n %s [options files ...]\n" Sys.argv.(0) ; let print_line fmt s = Format.(pp_print_string fmt s ; pp_print_newline fmt ()) in List.iter (print_line fmt) [ "" ; "Main Options:" ; " -help This message." ; " -version Version number only." ; " -plugins List of installed plugins." ; " -kernel-h Additional help and options." ; "" ; "Plug-in Options:" ; " - Plug-in activation." ; " --h Additional help and options." ; "" ; ] ; end ; raise Exit (** reverse dependency to dynamic.ml *) let loading_failures = Queue.create () let add_loading_failures s = Queue.add s loading_failures let list_plugins () = Log.print_on_output begin fun fmt -> List.iter (fun p -> if p.Plugin.name <> "" then print_helpline fmt (Transitioning.String.capitalize_ascii p.Plugin.name) (Printf.sprintf "%s (-%s-h)" p.Plugin.help p.Plugin.short) "") (Plugin.all_plugins ()) ; if not (Queue.is_empty loading_failures) then begin Kernel_log.abort "@[The following packages failed to load:@ %a@]" (Pretty_utils.pp_iter Queue.iter ~sep:",@ " Format.pp_print_string) loading_failures; end; end ; raise Exit let list_all_plugin_options ~print_invisible = Log.print_on_output begin fun fmt -> let of_name s = if s = "" then (if Unix.isatty Unix.stdout then "\x1b[31mNO NAME\x1b[0m" else "NO NAME") else s in let print_cmdline_option fmt (c:cmdline_option) = if print_invisible || c.ovisible then Format.fprintf fmt "@[Name: %s@]" c.oname else Format.ifprintf fmt "@[Name: %s@]" c.oname in let print_cmdline_option_list fmt cs = (Pretty_utils.pp_list ~pre:"@[" ~suf:"@]" ~sep:"@;" print_cmdline_option) fmt (sort_cmdline_options cs) in let print_groups fmt gs = let sorted_gs = sort_groups gs in (Pretty_utils.pp_list ~pre:"@[" ~sep:"@;" ~suf:"@]" (Pretty_utils.pp_pair ~pre:"@[" ~suf:"@]" ~sep:"@;" (fun fmt name -> Format.pp_print_string fmt (of_name name)) (fun fmt p -> print_cmdline_option_list fmt !p))) fmt sorted_gs in let print_plugin fmt p = Format.fprintf fmt "@[Name: %s@;%a@]" p.Plugin.name print_groups p.Plugin.groups in Format.fprintf fmt "%a@." (Pretty_utils.pp_list ~pre:"@[" ~suf:"@]" ~sep:"@;" print_plugin) (Plugin.all_plugins ()) end; raise Exit (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/cmdline_parameters/parameter_customize.ml0000644000175000017500000001201513113745006030612 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 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 reset_on_copy_ref = ref true let do_not_reset_on_copy () = reset_on_copy_ref := false let projectify_ref = ref true let do_not_projectify () = projectify_ref := false; do_not_save (); do_not_reset_on_copy () 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 = Cmdline.Kernel_log.deprecated "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 argument_may_be_fundecl_ref = ref false let argument_may_be_fundecl () = argument_may_be_fundecl_ref := true let argument_must_be_fundecl_ref = ref false let argument_must_be_fundecl () = argument_must_be_fundecl_ref := true let argument_must_be_existing_fun_ref = ref false let argument_must_be_existing_fun () = argument_must_be_existing_fun_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 use_category_ref = ref true let no_category () = use_category_ref := false let is_permissive_ref = ref false let find_kf_by_name: (string -> Cil_types.kernel_function) ref = Extlib.mk_fun "Parameter_customize.find_kf_by_name" let plain_fct_finder s = try Cil_datatype.Kf.Set.singleton (!find_kf_by_name s) with Not_found -> Cil_datatype.Kf.Set.empty let mangling_functions = ref [plain_fct_finder] let get_c_ified_functions s = List.fold_left (fun acc f -> Cil_datatype.Kf.Set.union (f s) acc) Cil_datatype.Kf.Set.empty !mangling_functions let add_function_name_transformation f = mangling_functions := f :: !mangling_functions 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; argument_may_be_fundecl_ref := false; argument_must_be_fundecl_ref := false; argument_must_be_existing_fun_ref := false; reset_on_copy_ref := true; use_category_ref := true (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/cmdline_parameters/typed_parameter.mli0000644000175000017500000000613213113745005030070 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. This is a low level API, internally used by the kernel. As a plug-in developer, you certainly prefer to use the API of {!Plugin} instead. @since Nitrogen-20111001 *) 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 *) 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. *) (**/**) (** 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-Phosphorus-20170501/src/kernel_services/cmdline_parameters/parameter_customize.mli0000644000175000017500000002277513113745002030775 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** Configuration of command line options. You can apply the functions below just before applying one of the functors provided by the functor {!Plugin.Register} and generating a new parameter. @plugin development guide *) 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} and {!do_not_reset_on_copy}. @since Beryllium-20090601-beta1 *) val do_not_reset_on_copy: unit -> unit (** Prevents resetting the parameter to its default value when creating a project from a copy visitor. @since Neon-20140301 *) 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: Cmdline.Group.t -> 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. A valid function name is the name of a function defined in the analysed C program. Do nothing if the following applied functor has not type [String]. @since Oxygen-20120901 @modify Sodium-20150201 do nothing when applied to [String_set] or [String_list]. *) val argument_may_be_fundecl: unit -> unit (** Indicate that the argument of the parameter can match a valid function declaration (otherwise it has to match a defined functions). @since Sodium-20150201 *) val argument_must_be_fundecl: unit -> unit (** Indicate that the argument of the parameter must match a valid function declaration. @since Aluminium-20160501 *) val argument_must_be_existing_fun: unit -> unit (** Indicate that if the argument of the parameter does not match a valid function name, it raises an error whatever the value of the option -permissive is. Only meaningful for parameters that are collections of [kernel_function] or [fundec]. This flag {b does not} imply [argument_may_be_fundecl]. If the latter is unset, names of defined-only functions will raise an error as well. @since Sodium-20150201 *) 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 no_category: unit -> unit (** Prevent a collection parameter to use categories and the extension '+', and '-' mechanism. In particular, you should consider this customization when the parameter is a list of '-' prefixed options to an external tool, unless you are willing to let users escape the initial '-' everytime. @since Sodium-20150201 *) val is_permissive_ref: bool ref (** if [true], less checks are performed on value of arguments. Set by {!Kernel.Permissive} option *) (* ************************************************************************* *) (** {2 Function names} *) (* ************************************************************************* *) val get_c_ified_functions: string -> Cil_datatype.Kf.Set.t (** Function names can be modified (aka mangled) from the original source to valid C identifiers. In order to allow users to use the original names on the command-line options manipulating function names, this function will return the set of function whose name correspond to the given string, possibly via a mangling operation registered with the {!add_function_name_transformation} function below. By default, no mangling function is registered, and the returned set is either empty or a singleton corresponding to the unique function with that name. Results from all registered functions are cumulative, so that a mangling function should take care of returning the empty set for names that it does not understand. @since Sodium-20150201 *) val add_function_name_transformation: (string -> Cil_datatype.Kf.Set.t) -> unit (** Adds a mangling operation to allow writing user-friendly function names on command-line. See {!get_c_ified_functions} for more information. @since Sodium-20150201 *) (**/**) (* ************************************************************************* *) (** {2 Internal kernel stuff} *) (* ************************************************************************* *) val reset: unit -> unit (** Reset all customizers to their default values. *) val set_module_name: string -> unit (** For **kernel** parameters, set the name of the module name corresponding to the parameter. Not for casual users. *) val find_kf_by_name: (string -> Cil_types.kernel_function) ref (** @since Sodium-20150201 *) (* ************************************************************************* *) (** {3 The customizers themselves} *) (* ************************************************************************* *) val cmdline_stage_ref: Cmdline.stage ref val journalize_ref: bool ref val negative_option_name_ref: string option ref val negative_option_help_ref: string ref val unset_option_name_ref: string ref val unset_option_help_ref: string ref val must_save_ref: bool ref val reset_on_copy_ref: bool ref val projectify_ref: bool ref val optional_help_ref: (unit, Format.formatter, unit) format ref val argument_is_function_name_ref: bool ref val argument_may_be_fundecl_ref: bool ref val argument_must_be_fundecl_ref: bool ref val argument_must_be_existing_fun_ref: bool ref val group_ref: Cmdline.Group.t ref val do_iterate_ref: bool option ref val is_visible_ref: bool ref val module_name_ref: string ref val use_category_ref: bool ref (**/**) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/cmdline_parameters/typed_parameter.ml0000644000175000017500000000764113113745002027722 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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) 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 *) 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.t_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 ()) | String(a, _) -> Format.fprintf fmt "%s" (a.get ()) let get_value p = Format.asprintf "%a" pretty_value p (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/cmdline_parameters/cmdline.mli0000644000175000017500000003553513113745010026323 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 (** Initial stage for very specific almost hard-coded options. Do not use it. @plugin development guide *) | Extending (** Before loading plug-ins. Run only once. @plugin development guide *) | Extended (** The stage where plug-ins are loaded. It is also the first stage each time the Frama-C main loop is run (e.g. after each "-then"). @plugin development guide *) | Exiting (** Run once when exiting Frama-C. @plugin development guide *) | Loading (** After {!Extended}, the stage where a previous Frama-C internal states is restored (e.g. the one specified by -load or by running the journal). @plugin development guide *) | Configuring (** The stage where all the parameters which were not already set may be modified to take into account cmdline options. Just after this stage, Frama-C will run the plug-in mains. @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 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 at_error_exit: (exn -> unit) -> unit (** Register a hook executed whenever Frama-C exits with error (the exit code is greater than 0). The argument of the hook is the exception at the origin of the error. @since Boron-20100401 @modify Neon-20130301 add the exception as argument of the hook. *) (** Group of command line options. @since Beryllium-20090901 *) module Group : sig type t (** @since Beryllium-20090901 *) val default: t (** @since Beryllium-20090901 *) val name: t -> string (** @since Beryllium-20090901 *) (**/**) (** Kernel internals *) 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 *) (**/**) end (**/**) (* ************************************************************************** *) (* ************************************************************************** *) (** From here: functions required by Kernel Internals only! You should not use them! *) (* ************************************************************************** *) (* ************************************************************************** *) (* ************************************************************************** *) (** {2 Handle Hooks} *) (* ************************************************************************** *) val protect: exn -> string (** Messages for exceptions raised by Frama-C @since Boron-20100401 *) val catch_at_toplevel: exn -> bool (** @return true iff the given exception is caught by the Frama-C toplevel. @since Boron-20100401 *) val catch_toplevel_run: f:(unit -> unit) -> at_normal_exit:(unit -> unit) -> on_error:(exn -> unit) -> unit (** Run [f]. When done, either call [at_normal_exit] if running [f] was ok; or call [on_error] (and exits) in other cases. @modify Boron-20100401 additional arguments. They are now labelled @modify Neon-20140301 add the exception as argument of [on_error]. @modify Magnesium-20151001 Removed argument [~quit] *) val run_normal_exit_hook: unit -> unit (** Run all the hooks registered by {!at_normal_exit}. @since Boron-20100401 *) val run_error_exit_hook: exn -> unit (** Run all the hooks registered by {!at_normal_exit}. @since Boron-20100401 @modify Neon-20130301 add the exception as argument. *) val error_occurred: exn -> unit (** Remember that an error occurred. So {!run_error_exit_hook} will be called when Frama-C will exit. @since Boron-20100401 @modify Neon-20130301 add the exception as argument, fix spelling. *) 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. *) type on_from_name = { on_from_name: 'a. string -> (unit -> 'a) -> 'a } val parse_and_boot: on_from_name:on_from_name -> get_toplevel:(unit -> (unit -> unit) -> unit) -> play_analysis:(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. @since Beryllium-20090901 @modify Carbon-20101201 @modify Sodium-20150201 the first argument of the first functional is no more a string option, just a string @modify Aluminium-20160501 add labels and generalize the type of [on_from_name] *) 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 *) val help: unit -> exit (** Display the help of Frama-C @since Beryllium-20090601-beta1 *) val list_plugins: unit -> exit (** Display the list of installed plug-ins @since Magnesium-20151001 *) (** Display the list of all installed plug-ins and their options, in a condensed format. Used for zsh autocompletion. @since Phosphorus-20170501-beta1 *) val list_all_plugin_options : print_invisible:bool -> exit 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 *) val replace_option_setting: string -> plugin:string -> group:Group.t -> option_setting -> unit (** Replace the previously registered option setting. @since Sodium-20150201 *) (* ************************************************************************** *) (** {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. *) module Kernel_log: Log.Messages (** @since Neon-20140301 *) (** @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 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 *) val deterministic: bool (** Indicates that the plugins should strive to be as deterministic as possible in their outputs. Higher memory consumption or analysis time are acceptable, as reproducibility is more important. @since Aluminium-20160501 *) val last_project_created_by_copy: (unit -> string option) ref val load_all_plugins: (unit -> unit) ref val add_loading_failures: string -> unit (** Add a package to the list of ocamlfind packages that have failed to be loaded. @since Silicon-20161101 *) (**/**) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/cmdline_parameters/parameter_state.ml0000644000175000017500000002313613113745004027714 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 Handling group of parameters} *) (* ************************************************************************* *) let selection : (State.t * bool) list ref = ref [] let no_reset_selection: (State.t * bool) list ref = ref [] let collections: State.Set.t ref = ref State.Set.empty let get_selection_gen ?(is_set=true) selection = 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 get_selection ?is_set () = get_selection_gen ?is_set !selection let get_selection_context ?is_set () = let has_dependencies s = (* each collection whose state is a string has at least 1 dependency which is its typed state. *) let degree = if State.Set.mem s !collections then 1 else 0 in State_dependency_graph.G.out_degree State_dependency_graph.graph s > degree in (* automatically select all options that have some dependencies: they have an impact on 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 let get_reset_selection ?is_set () = let all = get_selection ?is_set () in let no_reset = get_selection_gen ?is_set !no_reset_selection in State_selection.diff all no_reset let extend_selection is_set s = selection := (s, is_set) :: !selection let extend_no_reset_selection is_set s = no_reset_selection := (s,is_set) :: !no_reset_selection (* ************************************************************************* *) (** {2 Generic implementation} *) (* ************************************************************************* *) module Make (P: sig val shortname: string end) (X: sig include Datatype.S val default: unit -> t val option_name: string val functor_name: string end) = struct let is_dynamic = true let projectify = !Parameter_customize.projectify_ref let reset_on_copy = !Parameter_customize.reset_on_copy_ref let must_save = !Parameter_customize.must_save_ref let is_visible = !Parameter_customize.is_visible_ref let module_name = !Parameter_customize.module_name_ref let group = !Parameter_customize.group_ref let stage = !Parameter_customize.cmdline_stage_ref let () = match !Parameter_customize.cmdline_stage_ref with | Cmdline.Early | Cmdline.Extending | Cmdline.Extended | Cmdline.Exiting | Cmdline.Loading -> Parameter_customize.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 = Datatype.never_any_project 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 (* Hack for the parsing of the command line: C files are recognized as an argument of the option with name '""' (empty string). *) let option_name = if X.option_name = "" then "Input C files" else X.option_name let unique_name = option_name let pretty_name = option_name end) module D = Datatype include Internal_state type t = Internal_state.data let () = extend_selection false self; if not reset_on_copy then extend_no_reset_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; if not reset_on_copy then extend_no_reset_selection true 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 !Parameter_customize.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 (* First clear the dependency and next apply the hooks since these hooks may set some states in the dependencies. Even do so for unprojectifed options since they actually use the project system (in a fake way, see module {!Options_state_builder}) and could have some dependencies that must be kept consistent. *) let selection = State_selection.diff (State_selection.with_dependencies self) (State_selection.singleton Is_set.self) in (try Project.clear ~selection () with Project.NoProject -> (* unprojectified early options can be set even before creating the initial project. Do nothing for these ones: consistency will be automatically ensured when creating the initial project. *) assert (not projectify)); 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:"" (Dynamic.Parameter.get_name X.functor_name name X.option_name) ~journalize:false ty f else f let get, set, unsafe_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 "unsafe_set" X.ty D.unit unsafe_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 option_name = X.option_name let add_aliases = Cmdline.add_aliases option_name ~plugin:P.shortname ~group stage let print_help fmt = Cmdline.print_option_help fmt ~plugin:P.shortname ~group option_name end (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/cmdline_parameters/parameter_sig.mli0000644000175000017500000005123513113745010027525 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 command line options. *) (* ************************************************************************** *) (** {2 Input signatures} One of these signatures is required to implement a new command line option. *) (* ************************************************************************** *) (** Minimal signature to implement for each parameter corresponding to an option on the command line argument. *) module type 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 Input_with_arg = sig include 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 (** Minimal signature for collections of custom datatype *) module type Input_collection = sig include Input_with_arg val dependencies: State.t list end (** Signature required to build custom collection parameters in which elements are convertible to string. @since Sodium-20150201 *) module type String_datatype = sig include Datatype.S val of_string: string -> t (** @raise Cannot_build if there is no element corresponding to the given string. *) val to_string: t -> string end (** Signature requires to build custom collection parameters in which elements are convertible to string. @since Sodium-20150201 *) module type String_datatype_with_collections = sig include Datatype.S_with_collections val of_string: string -> t (** @raise Cannot_build if there is no element corresponding to the given string. *) val of_singleton_string: string -> Set.t (** If a single string can be mapped to several elements. Can default to {!no_element_of_string} to indicate that each string [s] is mapped exactly to [of_string s]. *) val to_string: t -> string end (** Signature of the optional value associated to the key and required to build map parameters. @since Sodium-20150201 *) module type Value_datatype = sig include Datatype.S type key val of_string: key:key -> prev:t option -> string option -> t option (** [key] is the key associated to this value, while [prev] is the previous value associated to this key (if any). The optional string is [None] if there is no value associated to the key, and [Some v] (potentially [v = ""]) otherwise. @return None if there is no value to associate to the key or [Some v] otherwise. @raise Cannot_build if there is no element corresponding to the given string. *) val to_string: key:key -> t option -> string option (** [key] is the key associated to this value. The optional string is [None] if there is no value associated to the key, and [Some v] (potentially [v = ""]) otherwise. @return None if there is no value to associate to the key or [Some v] otherwise. *) end (** Signature of the optional value associated to the key and required to build multiple map parameters. Almost similar to {!Value_datatype}. @since Sodium-20150201 *) module type Multiple_value_datatype = sig include Datatype.S type key val of_string: key:key -> prev:t list option -> string option -> t option val to_string: key:key -> t option -> string option end (* ************************************************************************** *) (** {2 Output signatures} Signatures corresponding to a command line option of a specific type. *) (* ************************************************************************** *) (* ************************************************************************** *) (** {3 Generic signatures} *) (* ************************************************************************** *) (** Generic signature of a parameter, without [parameter]. *) module type S_no_parameter = sig type t (** Type of the parameter (an int, a string, etc). It is concrete for each module implementing this signature. *) val set: t -> unit (** Set the option. *) val add_set_hook: (t -> t -> unit) -> unit (** Add a hook to be called after 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 necessarily 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 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 (** Generic signature of a parameter. *) module type S = sig include S_no_parameter val parameter: Typed_parameter.t (** @since Nitrogen-20111001 *) end (* ************************************************************************** *) (** {3 Signatures for simple datatypes} *) (* ************************************************************************** *) (** Signature for a boolean parameter. @plugin development guide *) module type Bool = sig include S 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 an integer parameter. @plugin development guide *) module type Int = sig include S 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 S 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 *) val get_function_name: unit -> string (** returns the given argument only if it is a valid function name (see {!Parameter_customize.get_c_ified_functions} for more information), and abort otherwise. Requires that the AST has been computed. Default getter when {!Parameter_customize.argument_is_function_name} has been called. @since Sodium-20150201 *) val get_plain_string: unit -> string (** always return the argument, even if the argument is not a function name. @since Sodium-20150201 *) end (* ************************************************************************** *) (** {3 Custom signatures} *) (* ************************************************************************** *) (** Signature for a boolean parameter that causes something to be output. *) module type With_output = 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 searching files in a specific directory. *) module type Specific_dir = sig exception No_dir val force_dir: bool (** For functions below: if [force_dir] is true: if [error] is [false], then creates the directory if it does not exist (or raises No_dir if the directory cannot be created). Otherwise ([force_dir = false]), raise No_dir if [error] is [false]. @since Neon-20140301 *) val dir: ?error:bool -> unit -> string (** [dir ~error ()] returns the specific directory name, if any. Otherwise, Frama-C halts on an user error if [error] or if the behavior depends on [force_dir]. Default of [error] is [true]. @raise No_dir if there is no share directory for this plug-in and [not error] and [not force_dir]. *) val file: ?error:bool -> string -> string (** [file basename] returns the complete filename of a file stored in [dir ()]. If there is no such directory, Frama-C halts on an user error if [error] or if the behavior depends on [force_dir]. Default of [error] is [true]. @raise No_dir if there is no share directory for this plug-in and [not error] and [not force_dir]. *) module Dir_name: String (** Option [--]. *) end (* ************************************************************************** *) (** {3 Collections} *) (* ************************************************************************** *) (** Signature for a category over a collection. @since Sodium-20150201 *) module type Collection_category = sig type elt (** Element in the category *) type t = elt Parameter_category.t val none: t (** The category '\@none' *) val default: unit -> t (** The '\@default' category. By default, it is {!none}. *) val all: unit -> t (** The '\@all' category. If this category has not been created, it is {!none}, which means 'ignored'. @since Silicon-20161101 *) val set_default: t -> unit (** Modify the '\@default' category. *) val add: string -> State.t list -> elt Parameter_category.accessor -> t (** Adds a new category for this collection with the given name, accessor and dependencies. *) val enable_all: State.t list -> elt Parameter_category.accessor -> t (** The category '\@all' is enabled in positive occurrences, with the given interpretation. In negative occurrences, it is always enabled and '-\@all' means 'empty'. *) val enable_all_as: t -> unit (** The category '\@all' is equivalent to the given category. *) end (** Common signature to all collections. @since Sodium-20150201 *) module type Collection = sig include S (** A collection is a standard command line parameter. *) type elt (** Element in the collection. *) val is_empty: unit -> bool (** Is the collection empty? *) val iter: (elt -> unit) -> unit (** Iterate over all the elements of the collection. *) val fold: (elt -> 'a -> 'a) -> 'a -> 'a (** Fold over all the elements of the collection. *) val add: elt -> unit (** Add an element to the collection *) module As_string: String (** A collection is a standard string parameter *) module Category: Collection_category with type elt = elt (** Categories for this collection. *) end (** Signature for sets as command line parameters. @since Sodium-20150201 *) module type Set = sig include Collection (** A set is a collection. *) (** {3 Additional accessors to the set.} *) val mem: elt -> bool (** Does the given element belong to the set? *) val exists: (elt -> bool) -> bool (** Is there some element satisfying the given predicate? *) end (** @modify Sodium-20150201 *) module type String_set = Set with type elt = string and type t = Datatype.String.Set.t (** Set of defined kernel functions. If you want to also include pure prototype, use {!Parameter_customize.argument_may_be_fundecl}. @since Sodium-20150201 @plugin development guide *) module type Kernel_function_set = Set with type elt = Cil_types.kernel_function and type t = Cil_datatype.Kf.Set.t (** @since Sodium-20150201 *) module type Fundec_set = Set with type elt = Cil_types.fundec and type t = Cil_datatype.Fundec.Set.t (** Signature for lists as command line parameters. @since Sodium-20150201 *) module type List = sig include Collection (** A list is a collection. *) (** {3 Additional accessors to the list.} *) val append_before: t -> unit (** append a list in front of the current state @since Neon-20140301 *) val append_after: t -> unit (** append a list at the end of the current state @since Neon-20140301 *) end (** @modify Sodium-20150201 *) module type String_list = List with type elt = string and type t = string list (** Signature for maps as command line parameters. @since Sodium-20150201 *) module type Map = sig type key (** Type of keys of the map. *) type value (** Type of the values associated to the keys. *) include Collection with type elt = key * value option (** A map is a collection in which elements are pairs [(key, value)], but some values may be missing. *) (** {3 Additional accessors to the map.} *) val find: key -> value (** Search a given key in the map. @raise Not_found if there is no such key in the map. *) val mem: key -> bool end (** Signature for multiple maps as command line parameters. Almost similar to {!Map}. @since Sodium-20150201 *) module type Multiple_map = sig type key type value include Collection with type elt = key * value list val find: key -> value list val mem: key -> bool end (* ************************************************************************** *) (** {2 All the different kinds of command line options as functors} *) (* ************************************************************************** *) (** Signatures containing the different functors which may be used to generate new command line options. @plugin development guide *) module type Builder = sig val no_element_of_string: string -> 'a (** @raise Cannot_build for any entry @since Sodium-20150201 *) module Bool(X:sig include Input val default: bool end): Bool module Action(X: Input) : Bool (** @plugin development guide *) module False(X: Input) : Bool (** @plugin development guide *) module True(X: Input) : Bool module WithOutput (X: sig include Input val output_by_default: bool end): With_output (** @plugin development guide *) module Int(X: sig include Input_with_arg val default: int end): Int (** @plugin development guide *) module Zero(X: Input_with_arg): Int (** @plugin development guide *) module String(X: sig include Input_with_arg val default: string end): String (** @plugin development guide *) module Empty_string(X: Input_with_arg): String exception Cannot_build of string module Make_set (E: sig include String_datatype_with_collections val of_singleton_string: string -> Set.t end) (X: sig include Input_collection val default: E.Set.t end): Set with type elt = E.t and type t = E.Set.t (** @plugin development guide *) module String_set(X: Input_with_arg): String_set module Filled_string_set (X: sig include Input_with_arg val default: Datatype.String.Set.t end): String_set (** @plugin development guide *) module Kernel_function_set(X: Input_with_arg): Kernel_function_set module Fundec_set(X: Input_with_arg): Fundec_set module Make_list (E: sig include String_datatype val of_singleton_string: string -> t list end) (X: sig include Input_collection val default: E.t list end): List with type elt = E.t and type t = E.t list module String_list(X: Input_with_arg): String_list (** Parameter is a map where multibindings are **not** allowed. *) module Make_map (K: String_datatype_with_collections) (V: Value_datatype with type key = K.t) (X: sig include Input_collection val default: V.t K.Map.t end): Map with type key = K.t and type value = V.t and type t = V.t K.Map.t module String_map (V: Value_datatype with type key = string) (X: sig include Input_with_arg val default: V.t Datatype.String.Map.t end): Map with type key = string and type value = V.t and type t = V.t Datatype.String.Map.t (** As for Kernel_function_set, by default keys can only be defined functions. Use {!Parameter_customize.argument_may_be_fundecl} to also include pure prototypes. *) module Kernel_function_map (V: Value_datatype with type key = Cil_types.kernel_function) (X: sig include Input_with_arg val default: V.t Cil_datatype.Kf.Map.t end): Map with type key = Cil_types.kernel_function and type value = V.t and type t = V.t Cil_datatype.Kf.Map.t (** Parameter is a map where multibindings are allowed. *) module Make_multiple_map (K: String_datatype_with_collections) (V: Multiple_value_datatype with type key = K.t) (X: sig include Input_collection val default: V.t list K.Map.t end): Multiple_map with type key = K.t and type value = V.t and type t = V.t list K.Map.t module String_multiple_map (V: Multiple_value_datatype with type key = string) (X: sig include Input_with_arg val default: V.t list Datatype.String.Map.t end): Multiple_map with type key = string and type value = V.t and type t = V.t list Datatype.String.Map.t (** As for Kernel_function_set, by default keys can only be defined functions. Use {!Parameter_customize.argument_may_be_fundecl} to also include pure prototypes. *) module Kernel_function_multiple_map (V: Multiple_value_datatype with type key = Cil_types.kernel_function) (X: sig include Input_with_arg val default: V.t list Cil_datatype.Kf.Map.t end): Multiple_map with type key = Cil_types.kernel_function and type value = V.t and type t = V.t list Cil_datatype.Kf.Map.t val parameters: unit -> Typed_parameter.t list end (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/cmdline_parameters/parameter_category.mli0000644000175000017500000000617513113745007030571 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** Category for parameter collections. A category groups together a set of possible values of a given type for some parameters. It may be created once and used several times. *) type 'a t (** [\tau t] is the type of a category for the type \tau. *) type 'a accessor = < fold:'acc. ('a -> 'acc -> 'acc) -> 'acc -> 'acc (* fold on elements *); mem:('a -> bool) (* mem *) > (** Type explaining how to manipulate the elements of the category. *) val create: string -> 'a Type.t -> register:bool -> State.t list -> 'a accessor -> 'a t (** [create name ty ~register states access] creates a category of the given name for the given type. No category with such a name for the same type must be already registered. If [register], save the category for further re-use. [states] is a list of states which the category is based upon. [access] is how to manipulate this category. *) val copy_and_rename: string -> register:bool -> 'a t -> 'a t (** [copy_and_rename s ~register c] renames the category [c] into [s] and returns the new built category which is registered according to [register]. *) val use: State.t -> 'a t -> unit (** [use s c] indicates that the state [s] depends on the category [c]. *) val get_name: 'a t -> string (** Name of the category. *) val get_fold: 'a t -> ('a -> 'acc -> 'acc) -> 'acc -> 'acc (** Fold over the elements of the given category. *) val get_mem: 'a t -> 'a -> bool (** Is the given element present in the category? *) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/cmdline_parameters/parameter_builder.ml0000644000175000017500000014433313113745003030224 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 (* all the collection's internal states that depend on the AST. Forward dependency because of linking order (see special_hooks.ml). *) let ast_dependencies: State.t list ref = ref [] let extend_ast_dependencies s = ast_dependencies := s :: !ast_dependencies module D = Datatype (* hide after applying Parameter_state.Make *) let empty_string = "" let find_kf_by_name : (string -> kernel_function) ref = Extlib.mk_fun "Parameter_builder.find_kf_by_name" let find_kf_def_by_name : (string -> kernel_function) ref = Extlib.mk_fun "Parameter_builder.find_kf_def_by_name" let find_kf_decl_by_name : (string -> kernel_function) ref = Extlib.mk_fun "Parameter_builder.find_kf_decl_by_name" let kf_category : (unit -> kernel_function Parameter_category.t) ref = Extlib.mk_fun "Parameter_builder.kf_category" let kf_def_category : (unit -> kernel_function Parameter_category.t) ref = Extlib.mk_fun "Parameter_builder.kf_def_category" let kf_decl_category : (unit -> kernel_function Parameter_category.t) ref = Extlib.mk_fun "Parameter_builder.kf_decl_category" let fundec_category : (unit -> fundec Parameter_category.t) ref = Extlib.mk_fun "Parameter_builder.fundec_category" let kf_string_category : (unit -> string Parameter_category.t) ref = Extlib.mk_fun "Parameter_builder.kf_string_category" let force_ast_compute : (unit -> unit) ref = Extlib.mk_fun "Parameter_builder.force_ast_compute" (* ************************************************************************* *) (** {2 Specific functors} *) (* ************************************************************************* *) let iter_on_this_parameter stage = match !Parameter_customize.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 Make (P: sig val shortname: string val parameters: (string, Typed_parameter.t list) Hashtbl.t module L: sig val abort: ('a,'b) Log.pretty_aborter val warning: 'a Log.pretty_printer end val messages_group: Cmdline.Group.t end) = struct module Build = Parameter_state.Make(P) let parameters_ref : Typed_parameter.t list ref = ref [] let parameters () = !parameters_ref let add_parameter group stage param = if iter_on_this_parameter stage then begin parameters_ref := param :: !parameters_ref; let parameter_groups = P.parameters in try let group_name = Cmdline.Group.name group in let parameters = Hashtbl.find P.parameters group_name in Hashtbl.replace parameter_groups group_name (param :: parameters) with Not_found -> assert false end (* ************************************************************************ *) (** {3 Bool} *) (* ************************************************************************ *) module Bool(X:sig include Parameter_sig.Input val default: bool 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:!Parameter_customize.optional_help_ref stage (Cmdline.Unit (fun () -> set value)) let negative_option_name name = let s = !Parameter_customize.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 = Format.asprintf " (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 empty_string else if opp then Format.asprintf "%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 empty_string else empty_string in let neg_help, neg_visible = match !Parameter_customize.negative_option_name_ref, !Parameter_customize.negative_option_help_ref with | None, "" -> (* no user-specific config: no help *) empty_string, 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 parameter = let negative_option = match !Parameter_customize.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 = Typed_parameter.Bool ({ Typed_parameter.get = get; set = set; add_set_hook = add_set_hook; add_update_hook = add_update_hook }, negative_option) in let p = Typed_parameter.create ~name ~help:X.help ~accessor:accessor ~is_set in add_parameter !Parameter_customize.group_ref stage p; Parameter_customize.reset (); if is_dynamic then let plugin = empty_string in Dynamic.register ~plugin X.option_name Typed_parameter.ty ~journalize:false p else p end module False(X: Parameter_sig.Input) = Bool(struct include X let default = false end) module True(X: Parameter_sig.Input) = Bool(struct include X let default = true end) module Action(X: Parameter_sig.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 () = Parameter_customize.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_sig.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:!Parameter_customize.optional_help_ref ~plugin:P.shortname ~group stage (Cmdline.Int set) 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 P.L.abort "argument of %s must be at least %d." name min; if n > max then P.L.abort "argument of %s must be no more than %d." name max); let accessor = Typed_parameter.Int ({ Typed_parameter.get = get; set = set; add_set_hook = add_set_hook; add_update_hook = add_update_hook }, get_range) in let p = Typed_parameter.create ~name ~help:X.help ~accessor ~is_set:is_set in add_parameter !Parameter_customize.group_ref stage p; add_option X.option_name; Parameter_customize.reset (); if is_dynamic then let plugin = empty_string in Dynamic.register ~plugin X.option_name Typed_parameter.ty ~journalize:false p else p end module Zero(X: Parameter_sig.Input_with_arg) = Int(struct include X let default = 0 end) (* ************************************************************************ *) (** {3 String} *) (* ************************************************************************ *) module Pervasives_string = String module String (X: sig include Parameter_sig.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:!Parameter_customize.optional_help_ref ~plugin:P.shortname ~group stage (Cmdline.String set) let possible_values = ref [] let set_possible_values s = possible_values := s let get_possible_values () = !possible_values let get_function_name = let allow_fundecl = !Parameter_customize.argument_may_be_fundecl_ref in fun () -> let s = get () in (* Using a parameter that is in fact a function name only makes sense if we have an AST somewhere. *) !force_ast_compute(); let possible_funcs = Parameter_customize.get_c_ified_functions s in let possible_funcs = if allow_fundecl then possible_funcs else Cil_datatype.Kf.Set.filter (fun s -> match s.fundec with | Definition _ -> true | Declaration _ -> false) possible_funcs in if Cil_datatype.Kf.Set.is_empty possible_funcs then P.L.abort "'%s' is not a %sfunction. \ Please choose a valid function name for option %s" s (if allow_fundecl then "" else "defined ") name else begin if Cil_datatype.Kf.Set.cardinal possible_funcs > 1 then P.L.warning "ambiguous function name %s for option %s. \ Choosing arbitrary function with corresponding name." s name; (Cil_datatype.Kf.vi (Cil_datatype.Kf.Set.choose possible_funcs)).vname end let get_plain_string = get let get = if !Parameter_customize.argument_is_function_name_ref then get_function_name else get let parameter = add_set_hook (fun _ s -> match !possible_values with | [] -> () | v when List.mem s v -> () | v -> P.L.abort "invalid input '%s' for option %s.@ \ Possible values are: %a" s name (Pretty_utils.pp_list ~sep:",@ " Format.pp_print_string) v); let accessor = Typed_parameter.String ({ Typed_parameter.get = get_plain_string; set = set; add_set_hook = add_set_hook; add_update_hook = add_update_hook }, get_possible_values) in let p = Typed_parameter.create ~name ~help:X.help ~accessor ~is_set in add_parameter !Parameter_customize.group_ref stage p; add_option X.option_name; Parameter_customize.reset (); if is_dynamic then let plugin = empty_string in Dynamic.register ~plugin X.option_name Typed_parameter.ty ~journalize:false p else p end module Empty_string(X: Parameter_sig.Input_with_arg) = String(struct include X let default = empty_string end) (* ************************************************************************ *) (** {3 Collections} *) (* ************************************************************************ *) type collect_action = Add | Remove exception Cannot_build of string let cannot_build msg = raise (Cannot_build msg) let no_element_of_string msg = cannot_build msg module Make_collection (E: sig (* element in the collection *) type t val ty: t Type.t val of_string: string -> t (* may raise [Cannot_build] *) val to_string: t -> string end) (C: sig (* the collection, as a persistent datastructure *) type t val equal: t -> t -> bool val empty: t val is_empty: t -> bool val mem: E.t -> t -> bool val add: E.t -> t -> t val remove: E.t -> t -> t val iter: (E.t -> unit) -> t -> unit val fold: (E.t -> 'a -> 'a) -> t -> 'a -> 'a val of_singleton_string: string -> t (* For specific ways to parse a collection from a single string. If physically equal to [no_element_of_string], we revert back to using [E.of_string] *) val reorder: t -> t (* Used after having parsed a comma-separated string representing parameters. The add actions are done in the reverse order with respect to the list. Can be [Extlib.id] for unordered collections. *) end) (S: sig (* the collection, as a state *) include State_builder.S val memo: (unit -> C.t) -> C.t val clear: unit -> unit end) (X: (* standard option builder *) sig include Parameter_sig.Input_collection val default: C.t end) = struct type t = C.t type elt = E.t (* ********************************************************************** *) (* Categories *) (* ********************************************************************** *) type category = E.t Parameter_category.t (* the available custom categories for this option *) let available_categories : category Datatype.String.Hashtbl.t = Datatype.String.Hashtbl.create 7 module Category = struct type elt = E.t type t = category let check_category_name s = if Datatype.String.Hashtbl.mem available_categories s || Datatype.String.equal s "all" || Datatype.String.equal s "" || Datatype.String.equal s "default" then P.L.abort "invalid category name '%s'" s let use categories = List.iter (fun c -> Parameter_category.use S.self c; Datatype.String.Hashtbl.add available_categories (Parameter_category.get_name c) c) categories let unsafe_add name states accessor = let c = Parameter_category.create name E.ty ~register:false states accessor in use [ c ]; c let add name states get_values = check_category_name name; unsafe_add name states get_values let none = let o = object method fold: 'b. ('a -> 'b -> 'b) -> 'b -> 'b = (fun _ acc -> acc); method mem = fun _ -> false end in unsafe_add "" [] o let default_ref = let o = object method fold : 'b. ('a -> 'b -> 'b) -> 'b -> 'b = fun f acc -> C.fold f X.default acc method mem x = C.mem x X.default end in let c = unsafe_add "default" [] o in Datatype.String.Hashtbl.add available_categories "default" c; ref c let default () = !default_ref let set_default c = Datatype.String.Hashtbl.replace available_categories "default" c; default_ref := c let all_ref: t ref = ref none let all () = !all_ref let on_enable_all c = (* interpretation may have change: reset the state to force the interpretation again *) S.clear (); all_ref := c let enable_all_as c = use [ c ]; let all = Parameter_category.copy_and_rename "all" ~register:false c in Datatype.String.Hashtbl.add available_categories "all" all; on_enable_all all let enable_all states get_values = let all = unsafe_add "all" states get_values in on_enable_all all; all end (* ********************************************************************** *) (* Parsing *) (* ********************************************************************** *) let use_category = !Parameter_customize.use_category_ref (* parsing builds a list of triples (action, is_category?, word) *) let add_action a l = (a, false, None) :: l let add_char c = function | [] -> assert false | (a, f, None) :: l -> (* first char of a new word *) let b = Buffer.create 7 in Buffer.add_char b c; (a, f, Some b) :: l | ((_, _, Some b) :: _) as l -> (* extend the current word *) Buffer.add_char b c; l let set_category_flag = function | (a, false, None) :: l -> (a, true, None) :: l | _ -> assert false type position = | Start (* the very beginning or after a comma *) | Word of (* action already specified, word is being read *) bool (* [true] iff beginning a category with '@' is allowed *) | Escaped (* the next char is escaped in the current word *) let parse_error msg = P.L.abort "@[@[incorrect argument for option %s@ (%s).@]" X.option_name msg (* return the list of tokens, in reverse order *) let parse s = let len = Pervasives_string.length s in let rec aux acc pos i s = if i = len then acc else let next = i + 1 in let read_char_in_word f_acc new_pos = (* assume 'Add' by default *) let acc = if pos = Start then add_action Add acc else acc in aux (f_acc acc) new_pos next s in let read_std_char_in_word c = read_char_in_word (add_char c) (Word false) in let read_backslash_and_char c = (* read '\\' and [c], without considering than '\\' is the escaping character *) read_char_in_word (fun acc -> add_char c (add_char '\\' acc)) (Word false) in match Pervasives_string.get s i, pos with | '+', Start when use_category -> aux (add_action Add acc) (Word true) next s | '-', Start when use_category -> aux (add_action Remove acc) (Word true) next s | '\\', (Start | Word _) -> read_char_in_word (fun x -> x) Escaped | ',', (Start | Word _) -> read_char_in_word (fun x -> x) Start | (' ' | '\t' | '\n' | '\r'), Start -> (* ignore whitespace at beginning of words (must be escaped) *) aux acc pos next s | '@', (Start | Word true) when use_category -> read_char_in_word set_category_flag (Word false) | c, (Start | Word _) -> read_std_char_in_word c | (',' | '\\' as c), Escaped -> read_std_char_in_word c | ('+' | '-' | '@' | ' ' | '\t' | '\n' | '\r' as c), Escaped when i = 1 -> if use_category then read_std_char_in_word c else read_backslash_and_char c | c, Escaped -> read_backslash_and_char c in aux [] Start 0 s (* ********************************************************************** *) (* The parameter itself, as a special string option *) (* ********************************************************************** *) let string_of_collection c = if C.is_empty c then "" else let b = Buffer.create 17 in let first = ref true in C.iter (fun e -> let s = E.to_string e in if !first then begin if s <> "" then first := false end else Buffer.add_string b ","; Buffer.add_string b (E.to_string e)) c; Buffer.contents b (* a collection is a standard string option... *) module As_string = struct include String(struct include X let default = string_of_collection X.default end) let () = Parameter_state.collections := State.Set.add self !Parameter_state.collections let get () = (* the default string may have a custom interpretation when the category @default has been customized: in that case, interpret "@default" to get it *) if use_category && is_default () then "@default" else get () end (* ... which is cumulative, when set from the cmdline (but uniquely from this way since it is very counter-intuitive from the other ways (i.e. programmatically or the GUI). *) let () = Cmdline.replace_option_setting X.option_name ~plugin:P.shortname ~group:As_string.group (Cmdline.String (fun s -> let old = As_string.get () in As_string.set (if Datatype.String.equal old empty_string then s else old ^ "," ^ s))) (* JS personal note: I'm still not fully convinced by this cumulative semantics. *) let () = (* the typed state depends on the string representation *) State_dependency_graph.add_codependencies ~onto:S.self (As_string.self :: X.dependencies) let check_possible_value elt = let a = Category.all () in if a != Category.none && not (Parameter_category.get_mem a elt) then parse_error ("impossible value " ^ E.to_string elt) (* may be costly: use it with parsimony *) let collection_of_string ~check s = (* Format.printf "READING %s: %s@." X.option_name s;*) let tokens = parse s in (* remember: tokens are in reverse order. So handle the last one first. *) let unparsable, col = List.fold_right (fun (action, is_category, word) (unparsable, col) -> let extend = match action with | Add -> C.add | Remove -> C.remove in let word = match word with | None -> "" | Some b -> Buffer.contents b in (* Format.printf "TOKEN %s@." word;*) if is_category then try let c = Datatype.String.Hashtbl.find available_categories word in if word = "all" then match action with | Add -> unparsable, Parameter_category.get_fold c C.add C.empty | Remove -> (* -@all is always equal to the emptyset, even if there were previous elements which are now impossible *) None, C.empty else unparsable, Parameter_category.get_fold c extend col with Not_found -> parse_error ("unknown category '" ^ word ^ "'") else (* not is_category *) try if C.of_singleton_string == no_element_of_string then begin let elt = E.of_string word in unparsable, extend elt col end else begin let elts = C.of_singleton_string word in unparsable, C.fold extend elts col end with Cannot_build msg -> Some msg, col) tokens (None, C.empty) in let col = C.reorder col in (* check each element after parsing all of them, since an element may be added, then removed later (e.g +h,-@all): that has to be accepted *) if check then begin Extlib.may parse_error unparsable; C.iter check_possible_value col end; col (* ********************************************************************** *) (* Memoized access to the state *) (* ********************************************************************** *) let get_nomemo () = S.memo (fun () -> raise Not_found) let get () = let compute () = let s = As_string.get () in (*let c =*) collection_of_string ~check:true s (*in*) (*Format.printf "GET %s@." (As_string.get ()); C.iter (fun s -> Format.printf "ELT %s@." (E.to_string s)) c; c*) in S.memo compute (* ********************************************************************** *) (* Implement the state, by overseded [As_string]: not the more efficient, but the simplest way that prevent to introduce subtle bugs *) (* ********************************************************************** *) let set c = As_string.set (string_of_collection c) let unsafe_set c = As_string.unsafe_set (string_of_collection c) let convert_and_apply f = fun old new_ -> f (collection_of_string ~check:false old) (collection_of_string ~check:true new_) let add_set_hook f = As_string.add_set_hook (convert_and_apply f) let add_update_hook f = As_string.add_update_hook (convert_and_apply f) (* ********************************************************************** *) (* Implement operations *) (* ********************************************************************** *) let add e = set (C.add e (get ())) let is_empty () = C.is_empty (get ()) let iter f = C.iter f (get ()) let fold f acc = C.fold f (get ()) acc (* ********************************************************************** *) (* Re-export values *) (* ********************************************************************** *) let name = As_string.name let option_name = As_string.option_name let is_default = As_string.is_default let is_set = As_string.is_set let clear = As_string.clear let print_help = As_string.print_help let add_aliases = As_string.add_aliases let self = As_string.self let parameter = As_string.parameter let equal = C.equal let is_computed = S.is_computed let mark_as_computed = S.mark_as_computed (* [Datatype] is fully abstract from outside anyway *) module Datatype = As_string.Datatype (* cannot be called anyway since [Datatype] is abstract *) let howto_marshal _marshal _unmarshal = P.L.abort "[how_to_marshal] cannot be implemented for %s." X.option_name (* same as above *) let add_hook_on_update _ = P.L.abort "[add_hook_on_update] cannot be implemented for %s." X.option_name end module Make_set (E: Parameter_sig.String_datatype_with_collections) (X: sig include Parameter_sig.Input_collection val default: E.Set.t end): sig include Parameter_sig.Set with type elt = E.t and type t = E.Set.t module S: sig val self: State.t end (* typed state *) end = struct module C = struct include E.Set let reorder = Extlib.id let of_singleton_string = E.of_singleton_string end module S = struct include State_builder.Option_ref (E.Set) (struct let name = X.option_name ^ " set" let dependencies = X.dependencies end) let memo f = memo f (* ignore the optional argument *) end include Make_collection(E)(C)(S)(X) (* ********************************************************************** *) (* Accessors *) (* ********************************************************************** *) let mem e = E.Set.mem e (get ()) let exists f = E.Set.exists f (get ()) end module String_for_collection = struct include Datatype.String let of_string = Datatype.identity let to_string = Datatype.identity let of_singleton_string = no_element_of_string end module String_set(X: Parameter_sig.Input_with_arg) = Make_set (String_for_collection) (struct include X let dependencies = [] let default = Datatype.String.Set.empty end) module Filled_string_set (X: sig include Parameter_sig.Input_with_arg val default: Datatype.String.Set.t end) = Make_set (String_for_collection) (struct include X let dependencies = [] end) let check_function s must_exist require_fundecl no_function set = if no_function set then let specific_msg = if require_fundecl then " declaration" else "" in let error s = cannot_build (Format.asprintf "no function%s '%s'" specific_msg s) in if require_fundecl then error s else if must_exist then error s else if !Parameter_customize.is_permissive_ref then begin P.L.warning "ignoring non-existing function%s '%s'." specific_msg s; set end else error s else set module Kernel_function_string( A: sig val accept_fundecl: bool val require_fundecl: bool val must_exist: bool end) = struct include Cil_datatype.Kf let of_string s = try (if A.require_fundecl then !find_kf_decl_by_name else if A.accept_fundecl then !find_kf_by_name else !find_kf_def_by_name) s with Not_found -> cannot_build (Format.asprintf "no%s function '%s'" (if A.accept_fundecl then "" else if A.require_fundecl then " declared" else " defined") s) (* Cannot reuse any code to implement [to_string] without forward reference. Prefer small code duplication here. *) let to_string kf = match kf.fundec with | Definition(d, _) -> d.svar.vname | Declaration(_, vi, _, _) -> vi.vname let of_singleton_string s = let fcts = Parameter_customize.get_c_ified_functions s in let filter keep_def keep_decl = Set.filter (fun s -> match s.fundec with | Definition _ -> keep_def | Declaration _ -> keep_decl) in let res = if A.require_fundecl then filter false true fcts else if A.accept_fundecl then fcts else filter true false fcts in check_function s A.must_exist A.require_fundecl Set.is_empty res end module Kernel_function_set(X: Parameter_sig.Input_with_arg) = struct module A = struct let accept_fundecl = !Parameter_customize.argument_may_be_fundecl_ref let require_fundecl = !Parameter_customize.argument_must_be_fundecl_ref let must_exist = !Parameter_customize.argument_must_be_existing_fun_ref end include Make_set (Kernel_function_string(A)) (struct include X let dependencies = [] let default = Cil_datatype.Kf.Set.empty end) let () = if A.accept_fundecl then Category.enable_all_as (!kf_category ()) else if A.require_fundecl then Category.enable_all_as (!kf_decl_category ()) else Category.enable_all_as (!kf_def_category ()) let () = extend_ast_dependencies S.self end module Fundec_set(X: Parameter_sig.Input_with_arg) = struct let must_exist = !Parameter_customize.argument_must_be_existing_fun_ref let require_fundecl = !Parameter_customize.argument_must_be_fundecl_ref include Make_set (struct include Cil_datatype.Fundec let of_string s = try let kf = !find_kf_def_by_name s in match kf.fundec with | Definition (f, _) -> f | Declaration _ -> assert false with Not_found -> cannot_build (Format.asprintf "no defined function '%s'" s) let to_string f = f.svar.vname let of_singleton_string s = let fcts = Parameter_customize.get_c_ified_functions s in let defs = Cil_datatype.Kf.Set.fold (fun s acc -> match s.fundec with | Definition(f,_) -> Set.add f acc | Declaration _ -> acc) fcts Set.empty in check_function s must_exist require_fundecl Set.is_empty defs end) (struct include X let dependencies = [] let default = Cil_datatype.Fundec.Set.empty end) let () = Category.enable_all_as (!fundec_category ()) let () = extend_ast_dependencies S.self end module Make_list (E: sig include Parameter_sig.String_datatype val of_singleton_string: string -> t list end) (X: sig include Parameter_sig.Input_collection val default: E.t list end): Parameter_sig.List with type elt = E.t and type t = E.t list = struct module C = struct include Datatype.List(E) let empty = [] let is_empty l = l == [] let add (x:E.t) l = x :: l let mem = List.mem let remove x l = List.filter (fun y -> not (E.equal x y)) l let iter = List.iter let fold f l acc = List.fold_left (fun acc x -> f x acc) acc l let reorder = List.rev let of_singleton_string = E.of_singleton_string end module S = struct include State_builder.Option_ref (C) (struct let name = X.option_name ^ " list" let dependencies = X.dependencies end) let memo f = memo f (* ignore the optional argument *) end include Make_collection(E)(C)(S)(X) (* ********************************************************************** *) (* Accessors *) (* ********************************************************************** *) let append_before l = set (l @ get ()) let append_after l = set (get () @ l) end module String_list(X: Parameter_sig.Input_with_arg) = Make_list (String_for_collection) (struct include X let dependencies = [] let default = [] end) module Make_map (K: Parameter_sig.String_datatype_with_collections) (V: Parameter_sig.Value_datatype with type key = K.t) (X: sig include Parameter_sig.Input_collection val default: V.t K.Map.t end) = struct type key = K.t type value = V.t let find_ref = ref (fun _ -> assert false) let of_val ~key k ~prev v = try V.of_string ~key ~prev v with Cannot_build s -> cannot_build (Format.asprintf "@[value bound to '%s':@ %s@]" k s) module Pair = struct include Datatype.Pair(K)(Datatype.Option(V)) let of_string = let r = Str.regexp_string ":" in fun s -> match Str.bounded_split_delim r s 2 with | [] -> cannot_build ("cannot interpret '" ^ s ^ "'") | [ k ] -> let key = K.of_string k in let prev = try Some (!find_ref key) with Not_found -> None in key, of_val ~key k ~prev None | [ k; v ] -> let key = K.of_string k in let prev = try Some (!find_ref key) with Not_found -> None in key, of_val ~key k ~prev (Some v) | _ :: _ :: _ :: _ -> (* by definition of [Str.bounded_split_delim]: *) assert false let to_string (key, v) = let v = V.to_string ~key v in let delim, v = match v with | None -> "", "" | Some v -> ":", v in Format.asprintf "%s%s%s" (K.to_string key) delim v end module C = struct type t = V.t K.Map.t let equal = K.Map.equal V.equal let empty = K.Map.empty let is_empty = K.Map.is_empty let add (k, v) m = match v with | None -> (* no value associated to the key: remove the previous binding *) K.Map.remove k m | Some v -> try let old = K.Map.find k m in if V.equal old v then m else begin P.L.warning "@[option %s:@ '%a' previously bound to '%a';@ \ now bound to '%a'.@]" X.option_name K.pretty k V.pretty old V.pretty v; K.Map.add k v m end with Not_found -> K.Map.add k v m let mem (k, _v) m = K.Map.mem k m let remove (k, _v) m = K.Map.remove k m let iter f m = K.Map.iter (fun k v -> f (k, Some v)) m let fold f m acc = K.Map.fold (fun k v -> f (k, Some v)) m acc let reorder = Extlib.id exception Found of V.t let of_singleton_string = let r = Str.regexp "\\([^:]\\|^\\):\\([^:]\\|$\\)" in (* delimiter is no more than 3 characters long, the first belonging to the element before it, the third belonging to the element after it. Treats :: as part of a word to be able to handle C++ function names in a non too awkward manner. *) let split_delim d = (* handle different possible length of the delimiter *) let rbis = Str.regexp ":" in match Str.bounded_full_split rbis d 2 with | [ Str.Delim _] -> (empty_string, empty_string) | [ Str.Delim _; Str.Text t2 ] -> (empty_string, t2) | [ Str.Text t1; Str.Delim _; ] -> (t1, empty_string) | [ Str.Text t1; Str.Delim _; Str.Text t2 ] -> (t1, t2) | _ -> (* impossible case *) raise (Cannot_build ("delimiter="^d)) in let k_of_singleton_string = if (K.of_singleton_string==no_element_of_string) then (fun x -> K.Set.singleton (K.of_string x)) else K.of_singleton_string in fun s -> let (keys, value) = let get_pairing k v_opt = let keys = k_of_singleton_string k in let key = ref None in let prev = try K.Set.iter (fun k -> key := Some k; (* choose any previous value, whatever it is: don't know which clear semantics one would like *) try raise (Found (!find_ref k)) with Not_found -> ()) keys; (* assume there is always at least a key *) None with Found v -> Some v in match !key with | None -> K.Set.empty, None | Some key -> keys, of_val ~key k ~prev v_opt in match Str.bounded_full_split r s 2 with | ([] | [ Str.Text _ ]) -> (* no delimiter ':' *) get_pairing s None | [ Str.Delim d ] -> let (f,s) = split_delim d in get_pairing f (Some s) | [ Str.Delim d; Str.Text t ] -> let (f,s) = split_delim d in get_pairing f (Some (s ^ t)) | [ Str.Text t1; Str.Delim d; Str.Text t2 ] -> let (f,s) = split_delim d in get_pairing (t1 ^ f) (Some (s ^ t2)) | [ Str.Text t; Str.Delim d] -> let (f,s) = split_delim d in get_pairing (t ^ f) (Some s) | _ -> (* by definition of [Str.bounded_full_split]: *) assert false in K.Set.fold (fun key map -> add (key, value) map) keys K.Map.empty end module S = struct include State_builder.Option_ref (K.Map.Make(V)) (struct let name = X.option_name ^ " map" let dependencies = X.dependencies end) let memo f = memo f (* ignore the optional argument *) end include Make_collection(Pair)(C)(S)(X) (* ********************************************************************** *) (* Accessors *) (* ********************************************************************** *) let find k = K.Map.find k (get ()) let mem k = K.Map.mem k (get ()) let () = find_ref := (fun k -> K.Map.find k (get_nomemo ())) end module String_map (V: Parameter_sig.Value_datatype with type key = string) (X: sig include Parameter_sig.Input_with_arg val default: V.t Datatype.String.Map.t end) = Make_map (String_for_collection) (V) (struct include X let dependencies = [] end) module Kernel_function_map (V: Parameter_sig.Value_datatype with type key = kernel_function) (X: sig include Parameter_sig.Input_with_arg val default: V.t Cil_datatype.Kf.Map.t end) = struct module A = struct let accept_fundecl = !Parameter_customize.argument_may_be_fundecl_ref let require_fundecl = !Parameter_customize.argument_must_be_fundecl_ref let must_exist = !Parameter_customize.argument_must_be_existing_fun_ref end include Make_map (Kernel_function_string(A)) (V) (struct include X let dependencies = [] end) let () = extend_ast_dependencies S.self end module Make_multiple_map (K: Parameter_sig.String_datatype_with_collections) (V: Parameter_sig.Multiple_value_datatype with type key = K.t) (X: sig include Parameter_sig.Input_collection val default: V.t list K.Map.t end) = struct type key = K.t type value = V.t let find_ref = ref (fun _ -> assert false) let of_val ~key k ~prev v = try V.of_string ~key ~prev v with Cannot_build s -> cannot_build (Format.asprintf "@[value bound to '%s':@ %s@]" k s) module Pair = struct include Datatype.Pair(K)(Datatype.List(V)) let of_string = let r = Str.regexp_string ":" in fun s -> match Str.split_delim r s with | [] -> cannot_build ("cannot interpret '" ^ s ^ "'") | k :: l -> let key = K.of_string k in let prev = try Some (!find_ref key) with Not_found -> None in let l = match l with | [] -> (match of_val ~key k ~prev None with | None -> [] | Some v -> [ v ]) | _ :: _ -> List.fold_right (* preserve order *) (fun v acc -> match of_val ~key k ~prev (Some v) with | None -> acc | Some v -> v :: acc) l [] in key, l let to_string (key, l) = Format.asprintf "%s%t" (K.to_string key) (fun fmt -> let rec pp_custom_list = function | [] -> () | v :: l -> Extlib.may (fun v -> Format.fprintf fmt ":%s" v) (V.to_string ~key (Some v)); pp_custom_list l in pp_custom_list l) end module C = struct type t = V.t list K.Map.t let equal = K.Map.equal (List.for_all2 V.equal) let empty = K.Map.empty let is_empty = K.Map.is_empty let add (k, l) m = try let l' = K.Map.find k m in K.Map.add k (l @ l') m with Not_found -> K.Map.add k l m let mem (k, _) m = K.Map.mem k m let remove (k, _) m = K.Map.remove k m let iter f m = K.Map.iter (fun k l -> f (k, l)) m let fold f m acc = K.Map.fold (fun k v -> f (k, v)) m acc let reorder = Extlib.id exception Found of V.t list let of_singleton_string = let r = Str.regexp "[^:]:[^:]" in let split_delim d = (Pervasives_string.sub d 0 1, Pervasives_string.sub d 2 1) in let remove_none_and_rev l = List.fold_left (fun acc v -> match v with None -> acc | Some v -> v :: acc) [] l in let rec parse_values ~key k ~prev acc s = function | [] -> remove_none_and_rev (of_val ~key k ~prev (Some s) :: acc) | [Str.Text t] -> remove_none_and_rev (of_val ~key k ~prev (Some (s ^ t)) :: acc) | Str.Text t :: Str.Delim d :: l -> let (suf, pre) = split_delim d in let v = of_val ~key k ~prev (Some (s ^ t ^ suf)) in parse_values ~key k ~prev (v :: acc) pre l | Str.Delim d :: l -> let (suf,pre) = split_delim d in let v = of_val ~key k ~prev (Some (s ^ suf)) in parse_values ~key k ~prev (v :: acc) pre l | Str.Text _ :: Str.Text _ :: _ -> (* By construction, there must be a Delim between two consecutive Text in the value returned by full_split *) assert false in fun s -> let (keys, values) = let get_pairing k v l = let keys = K.of_singleton_string k in let key = ref None in let prev = try K.Set.iter (fun k -> key := Some k; (* choose any previous value, whatever it is: don't know which clear semantics one would like *) try raise (Found (!find_ref k)) with Not_found -> ()) keys; None with Found v -> Some v in match !key with | None -> K.Set.empty, [] | Some key -> keys, parse_values ~key k ~prev [] v l in match Str.full_split r s with | [] -> cannot_build ("cannot interpret '" ^ s ^ "'") | [Str.Text t] -> K.of_singleton_string t, [] | Str.Delim d :: l -> let (f,s) = split_delim d in get_pairing f s l | Str.Text t :: Str.Delim d :: l -> let (f,s) = split_delim d in get_pairing (t ^ f) s l | Str.Text _ :: Str.Text _ :: _ -> (* see above *) assert false in K.Set.fold (fun key map -> K.Map.add key values map) keys K.Map.empty end module S = struct include State_builder.Option_ref (K.Map.Make(Datatype.List(V))) (struct let name = X.option_name ^ " map" let dependencies = X.dependencies end) let memo f = memo f (* ignore the optional argument *) end include Make_collection(Pair)(C)(S)(X) (* ********************************************************************** *) (* Accessors *) (* ********************************************************************** *) let find k = K.Map.find k (get ()) let mem k = K.Map.mem k (get ()) let () = find_ref := (fun k -> K.Map.find k (get_nomemo ())) end module String_multiple_map (V: Parameter_sig.Multiple_value_datatype with type key = string) (X: sig include Parameter_sig.Input_with_arg val default: V.t list Datatype.String.Map.t end) = Make_multiple_map (String_for_collection) (V) (struct include X let dependencies = [] end) module Kernel_function_multiple_map (V: Parameter_sig.Multiple_value_datatype with type key = kernel_function) (X: sig include Parameter_sig.Input_with_arg val default: V.t list Cil_datatype.Kf.Map.t end) = struct module A = struct let accept_fundecl = !Parameter_customize.argument_may_be_fundecl_ref let require_fundecl = !Parameter_customize.argument_must_be_fundecl_ref let must_exist = !Parameter_customize.argument_must_be_existing_fun_ref end include Make_multiple_map (Kernel_function_string(A)) (V) (struct include X let dependencies = [] end) let () = extend_ast_dependencies S.self end (** Options that directly cause an output. *) module WithOutput (X: sig include Parameter_sig.Input val output_by_default: bool end) = struct (* Requested command-line option *) include False(X) (* Command-line option for output. *) let () = Parameter_customize.set_group P.messages_group 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 end (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/cmdline_parameters/parameter_builder.mli0000644000175000017500000000572313113745006030377 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 for implementing new command line options. *) (* ************************************************************************* *) (** {2 Kernel use only} *) (* ************************************************************************* *) module Make (P: sig val shortname: string val parameters: (string, Typed_parameter.t list) Hashtbl.t module L: sig val abort: ('a,'b) Log.pretty_aborter val warning: 'a Log.pretty_printer end val messages_group: Cmdline.Group.t end): Parameter_sig.Builder (* ************************************************************************* *) (** {2 Internal use only} *) (* ************************************************************************* *) open Cil_types val find_kf_by_name: (string -> kernel_function) ref val find_kf_def_by_name: (string -> kernel_function) ref val find_kf_decl_by_name: (string -> kernel_function) ref val kf_category: (unit -> kernel_function Parameter_category.t) ref val kf_def_category: (unit -> kernel_function Parameter_category.t) ref val kf_decl_category: (unit -> kernel_function Parameter_category.t) ref val kf_string_category: (unit -> string Parameter_category.t) ref val fundec_category: (unit -> fundec Parameter_category.t) ref val force_ast_compute: (unit -> unit) ref val ast_dependencies: State.t list ref (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/cmdline_parameters/parameter_category.ml0000644000175000017500000000717613113745005030420 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 accessor = < fold:'acc. ('a -> 'acc -> 'acc) -> 'acc -> 'acc (* folder on elements *); mem:('a -> bool) (* mem *) > type 'a category = { name: string; ty: 'a Type.t; fold: 'b. ('a -> 'b -> 'b) -> 'b -> 'b; mem: 'a -> bool; mutable states: State.t list } type 'a t = 'a category module Categories = struct module By_name = Type.String_tbl(struct type 'a t = 'a category end) (* categories are indexed by [ty] and [name]. To be typable, the [ty] is encoded by its digest, which is a string *) let tbl : By_name.t Datatype.String.Hashtbl.t = Datatype.String.Hashtbl.create 7 let check c = try let internal = Datatype.String.Hashtbl.find tbl (Type.digest c.ty) in try ignore (By_name.find internal c.name c.ty); (* just a warning for compatibility purpose: E.g if the kernel creates a new standard category at release N, then plug-ins which already create this category at release N-1 would be warned, but still work as before. *) Cmdline.Kernel_log.warning "overriding category `%s' for type `%s'" c.name (Type.name c.ty) with | By_name.Unbound_value _ -> () | By_name.Incompatible_type _ -> assert false with Not_found -> () let add c = check c; let internal = try Datatype.String.Hashtbl.find tbl (Type.digest c.ty) with Not_found -> By_name.create 7 in By_name.add internal c.name c.ty c end let create name ty ~register states (accessor: 'a accessor) = let c = { name; ty; fold = (fun x acc -> accessor#fold x acc); mem = accessor#mem; states } in if register then Categories.add c else Categories.check c; c let copy_and_rename name ~register c = let c = { c with name } in if register then Categories.add c else Categories.check c; c let use state c = State_dependency_graph.add_codependencies ~onto:state c.states let get_name c = c.name let get_fold c = c.fold let get_mem c = c.mem (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/cmdline_parameters/parameter_state.mli0000644000175000017500000000651513113745007030072 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 Handling groups of parameters} *) (* ************************************************************************* *) val get_selection_context: ?is_set:bool -> unit -> State_selection.t (** Selection of all the parameters that may have an impact on some analysis. *) 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_reset_selection: ?is_set:bool -> unit -> State_selection.t (** Selection of resettable parameters in case of copy with a visitor. Not for casual user. @since Neon-20140301 *) (**/**) (* ************************************************************************* *) (** {2 Generic implementation of command line option} *) (* ************************************************************************* *) module Make (P: sig val shortname: string end) (X:sig include Datatype.S val default: unit -> t val option_name: string val functor_name: string end): sig include Parameter_sig.S_no_parameter with type t = X.t module Is_set: State_builder.S val group: Cmdline.Group.t val stage: Cmdline.stage val is_visible: bool val is_dynamic: bool val register_dynamic: string -> 'arg Type.t -> 'ret Type.t -> ('arg -> 'ret) -> 'arg -> 'ret val gen_journalized: string -> 'arg Type.t -> ('arg -> unit) -> 'arg -> unit end (**/**) val collections: State.Set.t ref (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_data/0000755000175000017500000000000013113745012022116 5ustar mehdimehdiframa-c-Phosphorus-20170501/src/kernel_services/ast_data/statuses_by_call.ml0000644000175000017500000001535713113745010026021 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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] let size = 97 end) module PropStmt = Datatype.Pair_with_collections(Property)(Cil_datatype.Stmt) (struct let module_name = "Statuses_by_call.PropStmt" end) module FunctionPointers = Cil_state_builder.Stmt_hashtbl(Kernel_function.Hptset) (struct let name = "Statuses_by_call.FunctionPointers" let dependencies = [Ast.self] let size = 37 end) let add_called_function stmt kf = let prev = try FunctionPointers.find stmt with Not_found -> Kernel_function.Hptset.empty in let s = Kernel_function.Hptset.add kf prev in FunctionPointers.replace stmt s let all_functions_with_preconditions stmt = match stmt with | { skind=Instr (Call(_,{enode = Lval (Var vkf, NoOffset)},_,_) |Local_init(_,ConsInit(vkf,_,_),_)) } -> let kf = Globals.Functions.get vkf in Kernel_function.Hptset.singleton kf | _ -> try FunctionPointers.find stmt with Not_found -> Kernel_function.Hptset.empty (* 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 p = Property.ip_property_instance (Some kf_call) (Kstmt stmt) pid 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_called_function stmt kf; add_call_precondition pid p ) | Instr (Local_init(_, ConsInit(vkf,_,_),_)) -> assert (Cil_datatype.Varinfo.equal vkf (Kernel_function.get_vi kf)) | _ -> 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 ~populate:false 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-Phosphorus-20170501/src/kernel_services/ast_data/kernel_function.ml0000644000175000017500000003576613113745012025656 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 cat_blocks = Kernel.register_category "kf:blocks" (* ************************************************************************* *) (** {2 Getters} *) (* ************************************************************************* *) let dummy () = { fundec = Definition (Cil.emptyFunction "@dummy@", Location.unknown); 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_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 self = Kf.self let auxiliary_kf_stmt_state = Kf.self 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_aux s1 s2 = 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 let pp_block fmt b = Pretty_utils.pp_list ~sep:"@\n" Cil_printer.pp_block fmt b in Kernel.debug ~dkey:cat_blocks "Blocks opened for stmt %a@\n%a@\nblocks opened for stmt %a@\n%a" Cil_printer.pp_stmt s1 pp_block b1 Cil_printer.pp_stmt s2 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 let res = aux [] b1 in Kernel.debug ~dkey:cat_blocks "Result:@\n%a" pp_block res; res with Not_found -> (* Invalid statement, or incorrectly filled table 'Kf' *) Kernel.fatal "Unknown statement sid:%d or sid:%d" s1.sid s2.sid let blocks_closed_by_edge s1 s2 = if not (List.exists (Stmt.equal s2) s1.succs) then raise (Invalid_argument "Kernel_function.blocks_closed_by_edge"); blocks_closed_by_edge_aux s1 s2 let blocks_opened_by_edge s1 s2 = if not (List.exists (Stmt.equal s2) s1.succs) then raise (Invalid_argument "Kernel_function.blocks_opened_by_edge"); blocks_closed_by_edge_aux s2 s1 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 module Res = struct exception Found of bool end in let vis = object inherit Cil.nopCilVisitor val is_in_loop = Stack.create () method! vstmt s = match s.skind with | Loop _ -> Stack.push true is_in_loop; if Cil_datatype.Stmt.equal s stmt then raise (Res.Found true); Cil.DoChildrenPost (fun s -> ignore (Stack.pop is_in_loop); s) | _ when Cil_datatype.Stmt.equal s stmt -> raise (Res.Found (Stack.top is_in_loop)) | _ -> Cil.DoChildren initializer Stack.push false is_in_loop end in try ignore (Cil.visitCilFunction vis (get_definition kf)); false with | Res.Found f -> f | No_Definition -> false (* Not the good kf obviously. *) let find_enclosing_loop kf stmt = let module Res = struct exception Found of Cil_types.stmt end in let vis = object inherit Cil.nopCilVisitor val loops = Stack.create () method! vstmt s = match s.skind with | Loop _ -> Stack.push s loops; Cil.DoChildrenPost (fun s -> ignore (Stack.pop loops); s) | _ when Cil_datatype.Stmt.equal s stmt -> raise (Res.Found (Stack.top loops)) | _ -> Cil.DoChildren end in try (match stmt.skind with | Loop _ -> stmt | _ -> ignore (Cil.visitCilFunction vis (get_definition kf)); raise Not_found) with | No_Definition -> raise Not_found (* Not the good kf obviously. *) | Stack.Empty -> raise Not_found (* statement outside of a loop *) | Res.Found s -> s exception Got_return of stmt exception No_Statement module ReturnCache = Cil_state_builder.Kernel_function_hashtbl (Cil_datatype.Stmt) (struct let name = "Kernel_function.ReturnCache" let dependencies = [Ast.self] let size = 43 end) let () = Ast.add_monotonic_state ReturnCache.self let clear_sid_info () = Kf.clear (); ReturnCache.clear () let () = Cfg.clear_sid_info_ref := clear_sid_info let find_return kf = try ReturnCache.find kf with Not_found -> 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); Kernel.fatal "Function %a does not have a return statement" pretty kf with Got_return s -> ReturnCache.add kf s; s in try find_return (get_definition kf) with No_Definition -> raise No_Statement 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 = let add_call callee = let sites = try CallSites.find hmap callee with Not_found -> [] in CallSites.replace hmap callee ((self#kf,stmt)::sites) in match stmt.skind with | Instr(Call(_,fct,_,_)) -> Extlib.may add_call (called_kernel_function fct); Cil.SkipChildren | Instr (Local_init (_, ConsInit(f,_,_),_)) -> add_call (Globals.Functions.get f); Cil.SkipChildren | Instr _ -> Cil.SkipChildren | _ -> Cil.DoChildren (* Skip many other things ... *) method! vexpr _ = Cil.SkipChildren method! vtype _ = Cil.SkipChildren method !vannotation _ = Cil.SkipChildren method !vcode_annot _ = Cil.SkipChildren method !vbehavior _ = 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 is_entry_point kf = let main, _ = Globals.entry_point () in equal kf main 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 Collections} *) (* ************************************************************************* *) module Make_Table = State_builder.Hashtbl(Cil_datatype.Kf.Hashtbl) module Hptset = struct 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 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) (* ************************************************************************* *) (** {2 Memoized get_global} *) (* ************************************************************************* *) module Get_global = Make_Table (Cil_datatype.Global) (struct let name = "Kernel_function.get_global" let size = 8 let dependencies = [ Globals.Functions.self ] end) let compute_get_global () = Cil.iterGlobals (Ast.get ()) (function | GFun({ svar = vi }, _) | GFunDecl(_, vi, _) as g when Ast.is_def_or_last_decl g -> let kf = try Globals.Functions.get vi with Not_found -> Kernel.fatal "[Kernel_function.compute_get_global] unknown function %a" Cil_datatype.Varinfo.pretty vi in Get_global.replace kf g | _ -> ()) let get_global = Get_global.memo (fun kf -> compute_get_global (); try Get_global.find kf with Not_found -> Kernel.fatal "[Kernel_function.get_global] unknown function %a" pretty kf) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_data/globals.mli0000644000175000017500000002474013113745010024251 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 (** Linear in the number of locals and formals of the program. *) (** {2 Iterators} *) val iter: (varinfo -> initinfo -> unit) -> unit val fold: (varinfo -> initinfo -> 'a -> 'a) -> 'a -> 'a (** The next four iterators iter on all global variables present in the AST, following the order in which they are declared/defined. The only exception is for variables that are both declared and defined. In this case, the declarations are skipped altogether. *) val iter_in_file_order: (varinfo -> initinfo -> unit) -> unit val fold_in_file_order: (varinfo -> initinfo -> 'a -> 'a) -> 'a -> 'a (** @since Fluorine-20130401 *) val iter_in_file_rev_order: (varinfo -> initinfo -> unit) -> unit (** @since Neon-20140301 *) val fold_in_file_rev_order: (varinfo -> initinfo -> 'a -> 'a) -> 'a -> 'a (** @since Neon-20140301 *) (** {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_decl_by_name : string -> kernel_function (** @raise Not_found if there is no function declaration of this name. @since Aluminium-20160501 *) (** {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 (** Note: if the varinfo is already registered and bound to a definition, the definition will be erased only if [vdefined] is false. Otherwise, you're trying to register a declaration for a varinfo that is supposed to be defined, which does not look very good. *) 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 Types} *) (* ************************************************************************* *) (** Types, or type-related information. *) module Types : sig (** The two functions below are suitable for use in functor {!Logic_typing.Make} *) val find_enum_tag: string -> exp * typ (** Find an enum constant from its name in the AST. @raise Not_found when no such constant exists. *) val find_type: Logic_typing.type_namespace -> string -> typ (** Find a type from its name in the AST. @raise Not_found when no such type exists. *) val iter_types: (string -> typ -> Logic_typing.type_namespace -> unit) -> unit (** Iteration on named types (typedefs, structs, unions, enums). The first argument is the name of type. *) val global: Logic_typing.type_namespace -> string -> global (** Find the global that defines the corresponding type. @raise Not_found if no such type has been defined. @since Magnesium-20151001 *) 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]. 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 statement. This function is useful only when -keep-comments is on. A comment is associated to a statement if it occurs after the preceding statement and before the current statement ends (except for the last statement in a block, to which statements occurring 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-Phosphorus-20170501/src/kernel_services/ast_data/annotations.ml0000644000175000017500000015624213113745011025016 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 let pretty_spec_location fmt (kf,stmt) = match stmt with | Some _ -> Format.fprintf fmt "statement contract in %a" Kernel_function.pretty kf | None -> Format.fprintf fmt "contract of %a" Kernel_function.pretty kf (* 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 find_englobing_kf ?kf stmt = match kf with | Some kf -> kf | 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 (**************************************************************************) (** {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 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" (* Clear all information linked to [a]: an eventual corresponding alarm, plus all property statuses on [a], or that depend on [a]. *) let clear_linked_to_annot kf stmt e ca = !remove_alarm_ref e stmt ca; let ppts = Property.ip_of_code_annot kf stmt ca in List.iter Property_status.remove ppts let () = Ast.add_linked_state code_annot_state; Code_annots.add_hook_on_remove (fun e stmt l -> let kf = find_englobing_kf stmt in List.iter (fun a -> clear_linked_to_annot kf stmt e a) !l) (**************************************************************************) (** {2 Getting annotations} *) (**************************************************************************) 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 then begin !populate_spec_ref kf spec; end else false let merge_from from1 from2 = match from1, from2 with | FromAny, FromAny -> FromAny | From _, FromAny -> from1 | FromAny, From _ -> from2 | From l1, From l2 -> let l2_only = List.filter (fun f2 -> not (List.exists (Logic_utils.is_same_identified_term f2) l1)) l2 in From (l1 @ l2_only) let merge_froms l1 l2 = let same_from (a1, _) (a2, _) = Logic_utils.is_same_identified_term a1 a2 in let common1, l1_only = List.partition (fun a1 -> List.exists (same_from a1) l2) l1 in let common2, l2_only = List.partition (fun a2 -> List.exists (same_from a2) l1) l2 in let common = List.map (fun (l1, f1 as a1) -> let (_, f2) = List.find (same_from a1) common2 in (l1, merge_from f1 f2)) common1 in l1_only @ common @ l2_only 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 (merge_froms 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; fresh_bhv.b_extended <- fresh_bhv.b_extended @ bhv.b_extended 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 (**************************************************************************) (** {2 Getting annotations} *) (**************************************************************************) module StmtContractMap = FCMap.Make(Datatype.String.Set) let is_same_behavior_set l1 l2 = Datatype.String.Set.(equal (of_list l1) (of_list l2)) let merge_stmt_contracts contracts = let add_one acc c = match c.annot_content with | AStmtSpec(bhvs, spec) -> let bhvs = Datatype.String.Set.of_list bhvs in let fresh_spec, acc = try StmtContractMap.find bhvs acc, acc with Not_found -> let spec = Cil.empty_funspec () in spec, StmtContractMap.add bhvs spec acc (* avoid sharing directly the spec, as merge_funspec will modify it in place*) in merge_funspec fresh_spec spec; acc | _ -> acc in let merged_contracts = List.fold_left add_one StmtContractMap.empty contracts in StmtContractMap.fold (fun bhvs spec acc -> (Logic_const.new_code_annotation (AStmtSpec (Datatype.String.Set.elements bhvs, spec))) :: acc) merged_contracts [] 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 let l = Emitter.Usable_emitter.Hashtbl.fold (fun _ l acc -> filter !l acc) tbl [] in let l1, l2 = List.partition Logic_utils.is_contract l in (match l1 with | [] -> l2 | _ -> (merge_stmt_contracts l1) @ l2) | Some e -> (* No need to merge stmt contracts here: each emitter maintain one statement contract per set of behavior. *) 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 let l = Emitter.Usable_emitter.Hashtbl.fold (fun e l acc -> filter e !l acc) tbl [] in let l1, l2 = List.partition (fun (x,_) -> Logic_utils.is_contract x) l in match l1 with | [] -> l2 | _ -> let contracts, emitters = List.split l1 in let e = List.hd emitters in let emit = if List.for_all (fun x -> Emitter.equal x e) emitters then e else Emitter.kernel in (List.map (fun x -> (x, emit)) contracts) @ l2 with Not_found -> [] 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 ?(sorted=true) f = let cmp s1 s2 = let res = Cil_datatype.Location.compare (Cil_datatype.Stmt.loc s1) (Cil_datatype.Stmt.loc s2) in if res <> 0 then res else Cil_datatype.Stmt.compare s1 s2 in let f_inner stmt tbl = let cmp = Emitter.Usable_emitter.compare in let iter = if sorted then Emitter.Usable_emitter.Hashtbl.iter_sorted ~cmp else Emitter.Usable_emitter.Hashtbl.iter in iter (fun e l -> List.iter (f stmt (Emitter.Usable_emitter.get e)) !l) tbl in let iter = if sorted then Code_annots.iter_sorted ~cmp else Code_annots.iter in iter f_inner let fold_all_code_annot ?(sorted=true) f = let cmp s1 s2 = let res = Cil_datatype.Location.compare (Cil_datatype.Stmt.loc s1) (Cil_datatype.Stmt.loc s2) in if res <> 0 then res else Cil_datatype.Stmt.compare s1 s2 in let f_inner stmt tbl acc = let cmp = Emitter.Usable_emitter.compare in let iter = if sorted then Emitter.Usable_emitter.Hashtbl.fold_sorted ~cmp else Emitter.Usable_emitter.Hashtbl.fold in iter (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 in let fold = if sorted then Code_annots.fold_sorted ~cmp else Code_annots.fold in fold f_inner 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 iter_extended f = iter_bhv_gen (fun b -> b.b_extended) List.iter 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 let fold_extended f = fold_bhv_gen (fun b -> b.b_extended) (fun f l acc -> List.fold_left (Extlib.swap f) acc l) f (* remove_code_annot is called when adding a code annotation that must stay unique for a given combination of statement, active behaviors and emitters. *) 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;*) try let tbl = Code_annots.find stmt in let e = Emitter.get e in try let l = Emitter.Usable_emitter.Hashtbl.find tbl e in let kf = find_englobing_kf ?kf stmt in clear_linked_to_annot kf stmt e ca; l := filterq ~eq:Code_annotation.equal ca !l; with Not_found -> (* the emitter is not the one which emits the annotation *) () with Not_found -> (* annotation not registered *) () (**************************************************************************) (** {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.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 pred_name = s :: names } (** {3 Adding subparts of a function contract} *) type 'a contract_component_addition = Emitter.t -> kernel_function -> ?stmt:stmt -> ?active:string list -> 'a -> unit type 'a behavior_component_addition = Emitter.t -> kernel_function -> ?stmt:stmt -> ?active:string list -> ?behavior:string -> 'a -> unit let filter_stmt_spec active ca = match ca.annot_content with | AStmtSpec(bhvs,_) -> is_same_behavior_set active bhvs | _ -> false let get_spec_e e kf ?stmt ?(active=[]) () = let e = Emitter.get e in match stmt with | None -> (try let tbl = Funspecs.find kf in (try Emitter.Usable_emitter.Hashtbl.find tbl e with Not_found -> let spec = Cil.empty_funspec () in Emitter.Usable_emitter.Hashtbl.add tbl e spec; spec) with Not_found -> let tbl = Emitter.Usable_emitter.Hashtbl.create 7 in let spec = Cil.empty_funspec () in Funspecs.add kf tbl; Emitter.Usable_emitter.Hashtbl.add tbl e spec; spec) | Some stmt -> let create_new () = let spec = Cil.empty_funspec() in let annot = Logic_const.new_code_annotation(AStmtSpec(active,spec)) in (annot,spec) in let new_emitter_annot tbl = let annot, spec = create_new () in Emitter.Usable_emitter.Hashtbl.add tbl e (ref [annot]); spec in (try let tbl = Code_annots.find stmt in (try let annots = Emitter.Usable_emitter.Hashtbl.find tbl e in (try let filter = filter_stmt_spec active in match (List.find filter !annots).annot_content with | AStmtSpec(_,s) -> s | _ -> assert false (* filter prevents anything else *) with Not_found -> (* no existing contract with the same set of active behavior as requirement. *) let annot, spec = create_new () in annots := annot :: !annots; spec) with Not_found -> (*no annotation with this emitter for the stmt *) new_emitter_annot tbl) with Not_found -> (* no annotation for this statement. *) let tbl = Emitter.Usable_emitter.Hashtbl.create 7 in Code_annots.add stmt tbl; new_emitter_annot tbl) let get_spec_all kf ?stmt ?(active=[]) () = match stmt with | None -> funspec ~populate:false kf | Some stmt -> let filter = filter_stmt_spec active in let spec = Cil.empty_funspec () in (match code_annot ~filter stmt with | [ { annot_content = AStmtSpec(_,spec') } ] -> merge_funspec spec spec' | _ -> ()); spec let kinstr stmt = match stmt with | None -> Kglobal | Some s -> Kstmt s let is_same_behavior b1 b2 = b1.b_name = b2.b_name 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 add_behaviors ?(register_children=true) e kf ?stmt ?active bhvs = let full_spec = get_spec_all kf ?stmt ?active () in let emit_spec = get_spec_e e kf ?stmt ?active () in let existing_behaviors = emit_spec.spec_behavior in if register_children then merge_behaviors emit_spec (mk_spec bhvs None None [] []) else List.iter (fun b -> if not (List.exists (is_same_behavior b) existing_behaviors) then merge_behaviors emit_spec (mk_spec [b] None None [] [])) bhvs; (* 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. *) let ki = kinstr stmt in let active = match active with | None -> [] | Some l -> l in List.iter (fun bhv -> if List.exists (is_same_behavior bhv) bhvs then begin let b' = Cil.mk_behavior ~name:bhv.b_name () in merge_behavior b' bhv; merge_behavior b' (List.find (is_same_behavior bhv) bhvs); let ip = Property.ip_of_behavior kf ki active bhv in Property_status.remove ip; (* mergeable clauses, i.e. assigns, from, and allocates may have changed. Thus, if register_children is true, we need to update the property status table. For the other clauses (requires, assumes, ensures) we just need to add the additional ip, nothing will be removed. *) if register_children then begin let ip = Property.ip_from_of_behavior kf ki active bhv in List.iter Property_status.remove ip; let ip = Property.ip_assigns_of_behavior kf ki active bhv in Extlib.may Property_status.remove ip; let ip = Property.ip_allocation_of_behavior kf ki active bhv in Extlib.may Property_status.remove ip; let ip = Property.ip_from_of_behavior kf ki active b' in List.iter Property_status.register ip; let ip = Property.ip_assigns_of_behavior kf ki active b' in Extlib.may Property_status.register ip; let ip = Property.ip_allocation_of_behavior kf ki active b' in Extlib.may Property_status.register ip; end; let ip = Property.ip_of_behavior kf ki active b' in Property_status.register ip; end) full_spec.spec_behavior; if register_children then begin List.iter (fun bhv -> List.iter (* For existing behaviors, behavior, assigns, allocation and from have been dealt with. For brand new behaviors, just register everything. *) (fun ip -> match ip with | IPBehavior _ | IPAssigns _ | IPAllocation _ | IPFrom _ when List.exists (is_same_behavior bhv) full_spec.spec_behavior -> () | _ -> Property_status.register ip) (Property.ip_all_of_behavior kf ki active bhv)) bhvs end let add_decreases e kf v = let full_spec = get_spec_all kf () in let emit_spec = get_spec_e e kf () in (match full_spec.spec_variant with | Some _ -> Kernel.fatal "already a variant for function %a" Kf.pretty kf | None -> emit_spec.spec_variant <- Some v); Property_status.register (Property.ip_of_decreases kf Kglobal v) let add_terminates e kf ?stmt ?active t = let full_spec = get_spec_all kf ?stmt ?active () in let emit_spec = get_spec_e e kf ?stmt ?active () in (match full_spec.spec_terminates with | Some _ -> Kernel.fatal "already a terminates clause for function %a" Kf.pretty kf | None -> emit_spec.spec_terminates <- Some t); Property_status.register (Property.ip_of_terminates kf (kinstr stmt) t) let check_bhv_name spec name = if name = Cil.default_behavior_name then begin Kernel.fatal "Trying to add default behavior in a complete or disjoint clause" end else if List.for_all (fun x -> x.b_name <> name) spec.spec_behavior then begin Kernel.fatal "Trying to add a non-existing behavior %s \ in a complete or disjoint clause" name end let add_complete e kf ?stmt ?active l = let full_spec = get_spec_all kf ?stmt ?active () in let emit_spec = get_spec_e e kf ?stmt ?active () in if List.mem l full_spec.spec_complete_behaviors then Kernel.warning "complete clause %a is already registered for %a. Ignoring the new one" (Pretty_utils.pp_list ~sep:",@ " Format.pp_print_string) l pretty_spec_location (kf,stmt) else begin List.iter (check_bhv_name full_spec) l; emit_spec.spec_complete_behaviors <- l :: emit_spec.spec_complete_behaviors; let active = match active with None -> [] | Some l -> l in Property_status.register (Property.ip_of_complete kf (kinstr stmt) active l) end let add_disjoint e kf ?stmt ?active l = let full_spec = get_spec_all kf ?stmt ?active () in let emit_spec = get_spec_e e kf ?stmt ?active () in if List.mem l full_spec.spec_disjoint_behaviors then Kernel.warning "disjoint clause %a is already registered for %a. Ignoring the new one" (Pretty_utils.pp_list ~sep:",@ " Format.pp_print_string) l pretty_spec_location (kf,stmt) else begin List.iter (check_bhv_name full_spec) l; emit_spec.spec_disjoint_behaviors <- l :: emit_spec.spec_disjoint_behaviors; let active = match active with None -> [] | Some l -> l in Property_status.register (Property.ip_of_disjoint kf (kinstr stmt) active l) end let extend_behavior e kf ?stmt ?active ?(behavior=Cil.default_behavior_name) set_bhv = (* Kernel.feedback "Function %a, behavior %s" Kf.pretty kf bhv_name;*) let has_same_name b = b.b_name = behavior in let full_spec = get_spec_all kf ?stmt ?active () in let emit_spec = get_spec_e e kf ?stmt ?active () in if not (List.exists has_same_name full_spec.spec_behavior) then begin let bhv = Cil.mk_behavior ~name:behavior () in full_spec.spec_behavior <- bhv :: full_spec.spec_behavior end; if not (List.exists has_same_name emit_spec.spec_behavior) then begin let bhv = Cil.mk_behavior ~name:behavior () in emit_spec.spec_behavior <- bhv :: emit_spec.spec_behavior end; let b = List.find has_same_name full_spec.spec_behavior in let b' = List.find has_same_name emit_spec.spec_behavior in let active = match active with None -> [] | Some l -> l in let ip = Property.ip_of_behavior kf (kinstr stmt) active b in Property_status.remove ip; set_bhv b b'; let ip = Property.ip_of_behavior kf (kinstr stmt) active b in Property_status.register ip let add_requires e kf ?stmt ?active ?behavior l = let set_bhv _ bhv = bhv.b_requires <- l @ bhv.b_requires; List.iter (fun p -> Property_status.register (Property.ip_of_requires kf (kinstr stmt) bhv p)) l in extend_behavior e kf ?stmt ?active ?behavior set_bhv let add_assumes e kf ?stmt ?active ?behavior l = let is_default = match behavior with | None -> true | Some s -> s = Cil.default_behavior_name in if is_default then begin match l with | [] -> () (* adding an empty list is a no-op. *) | [_] -> Kernel.warning "Trying to add an assumes clause to default behavior" | _ -> Kernel.warning "Trying to add assumes clauses to default behavior" end else begin let set_bhv _ bhv = bhv.b_assumes <- l @ bhv.b_assumes; List.iter (fun p -> Property_status.register (Property.ip_of_assumes kf (kinstr stmt) bhv p)) l in extend_behavior e kf ?stmt ?active ?behavior set_bhv end let add_ensures e kf ?stmt ?active ?behavior l = let set_bhv _ bhv = bhv.b_post_cond <- l @ bhv.b_post_cond; List.iter (fun a -> Property_status.register (Property.ip_of_ensures kf (kinstr stmt) bhv a)) l in extend_behavior e kf ?stmt ?active ?behavior set_bhv let add_assigns ~keep_empty e kf ?stmt ?active ?behavior a = let set_bhv full_bhv e_bhv = let keep_empty = keep_empty && full_bhv.b_assigns = WritesAny in let ki = kinstr stmt in e_bhv.b_assigns <- merge_assigns ~keep_empty e_bhv.b_assigns a; (match a with | WritesAny -> () | Writes _ -> let active = match active with None -> [] | Some l -> l in (* All assigns of a same behavior share the property. Thus must remove the previous property before adding the new one *) List.iter Property_status.remove (Property.ip_from_of_behavior kf ki active full_bhv); Extlib.may Property_status.remove (Property.ip_assigns_of_behavior kf ki active full_bhv); full_bhv.b_assigns <- merge_assigns keep_empty full_bhv.b_assigns a; Extlib.may Property_status.register (Property.ip_assigns_of_behavior kf ki active full_bhv); List.iter Property_status.register (Property.ip_from_of_behavior kf ki active full_bhv); ) in extend_behavior e kf ?stmt ?active ?behavior set_bhv let add_allocates e kf ?stmt ?active ?behavior a = let ki = kinstr stmt in let set_bhv full_bhv e_bhv = e_bhv.b_allocation <- Logic_utils.merge_allocation e_bhv.b_allocation a; let active = match active with None -> [] | Some l -> l in Extlib.may Property_status.remove (Property.ip_allocation_of_behavior kf ki active full_bhv); full_bhv.b_allocation <- Logic_utils.merge_allocation full_bhv.b_allocation a; Extlib.may Property_status.register (Property.ip_allocation_of_behavior kf ki active full_bhv); in extend_behavior e kf ?stmt ?active ?behavior set_bhv let add_extended e kf ?stmt ?active ?behavior ext = let set_bhv _ e_bhv = e_bhv.b_extended <- ext :: e_bhv.b_extended in extend_behavior e kf ?stmt ?active ?behavior set_bhv (** {3 Adding code annotations} *) let add_code_annot emitter ?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 kf = find_englobing_kf ?kf stmt in let convert a = match a.annot_content with | AAssert(l, p) -> let a = { a with annot_content=AAssert(l,extend_name emitter p) } in a, Property.ip_of_code_annot kf stmt a | AInvariant(l, b, p) -> let a={a with annot_content=AInvariant(l,b,extend_name emitter p)} in a, Property.ip_of_code_annot kf stmt a | AStmtSpec (bhvs, spec) -> let filter ca = match ca.annot_content with | AStmtSpec(bhvs',_) -> is_same_behavior_set bhvs bhvs' | _ -> false in let contract = code_annot ~filter stmt in (match contract with | [] -> a, Property.ip_of_code_annot kf stmt a | [ { annot_content = AStmtSpec _ } ] -> let register_children = true in let active = bhvs in add_behaviors ~register_children emitter kf ~stmt ~active spec.spec_behavior; if spec.spec_variant <> None then Kernel.fatal "statement contract cannot have a decrease clause"; Extlib.may (add_terminates emitter kf ~stmt ~active) spec.spec_terminates; List.iter (add_complete emitter kf ~stmt ~active) spec.spec_complete_behaviors; List.iter (add_disjoint emitter kf ~stmt ~active) spec.spec_disjoint_behaviors; (* By construction, we have exactly one contract corresponding to our criterion and emitter. *) let ca = List.hd (code_annot ~emitter ~filter stmt) in (* remove the previous binding in order to replace it with the updated one. Statuses being attached to sub-elements of the contract, they do not need any update here. *) remove_code_annot emitter ~kf stmt ca; { a with annot_content = ca.annot_content }, [] | _ -> Kernel.fatal "more than one contract attached to a given statement for \ emitter %a. Invariant of annotations management broken." Emitter.pretty emitter) | AVariant _ -> let v = code_annot ~filter:Logic_utils.is_variant stmt in (match v with | [] -> a, Property.ip_of_code_annot kf stmt a | _ -> let source = fst (Cil_datatype.Stmt.loc stmt) in Kernel.fatal ~source "trying to register a second variant for statement %a" Stmt.pretty stmt) | AAssigns (bhvs, assigns) -> let filter ca = match ca.annot_content with | AAssigns (bhvs', _) -> is_same_behavior_set bhvs bhvs' | _ -> false in let assigns' = code_annot ~filter stmt in (match assigns' with | [] -> a, Property.ip_of_code_annot kf stmt a | l -> let merge_assigns_ca acc ca = match ca.annot_content with | AAssigns(_,assigns') -> merge_assigns ~keep_empty:false assigns' acc | _ -> acc in let assigns' = List.fold_left merge_assigns_ca WritesAny l in let merged_ca = { a with annot_content = AAssigns(bhvs,assigns') } in let ip = Property.( ip_of_assigns kf (Kstmt stmt) (Id_loop merged_ca) assigns') in Extlib.may Property_status.remove ip; (match assigns' with | WritesAny -> () | Writes l -> List.iter (fun from -> let ip = Property.( ip_of_from kf (Kstmt stmt) (Id_loop merged_ca) from) in Extlib.may Property_status.remove ip) l); let new_assigns = merge_assigns ~keep_empty:false assigns' assigns in let new_ca = { a with annot_content = AAssigns(bhvs,new_assigns) } in let ips = Extlib.list_of_opt Property.( ip_of_assigns kf (Kstmt stmt) (Id_loop new_ca) new_assigns) in let ips = match new_assigns with | WritesAny -> ips | Writes l -> List.fold_left (fun acc f -> Extlib.opt_fold (fun x y -> x::y) Property.( ip_of_from kf (Kstmt stmt) (Id_loop new_ca) f) acc) ips l in let ca' = code_annot ~emitter ~filter stmt in let new_a = match ca' with | [] -> a | [ { annot_content = AAssigns(_, assigns') } as ca ] -> remove_code_annot emitter ~kf stmt ca; let merged = merge_assigns ~keep_empty:false assigns' assigns in { a with annot_content = AAssigns (bhvs, merged) } | _ -> Kernel.fatal "More than one loop assigns clause for a statement. \ Annotations internal state broken." in new_a, ips) | AAllocation (bhvs, alloc) -> let filter ca = match ca.annot_content with | AAllocation(bhvs',_) -> is_same_behavior_set bhvs bhvs' | _ -> false in (match code_annot ~filter stmt with | [] -> a, Property.ip_of_code_annot kf stmt a | l -> let merge_alloc_ca acc alloc = match alloc.annot_content with | AAllocation(_,a) -> Logic_utils.merge_allocation acc a | _ -> acc in let alloc' = List.fold_left merge_alloc_ca FreeAllocAny l in let merged_a = { a with annot_content = AAllocation(bhvs,alloc') } in let ip = Property.( ip_of_allocation kf (Kstmt stmt) (Id_loop merged_a) alloc') in Extlib.may Property_status.remove ip; let new_alloc = Logic_utils.merge_allocation alloc' alloc in let new_a = { a with annot_content = AAllocation(bhvs,new_alloc) } in let ip = Property.( ip_of_allocation kf (Kstmt stmt) (Id_loop new_a) new_alloc) in let emit_a = match code_annot ~emitter ~filter stmt with | [] -> a | [ { annot_content = AAllocation(_,alloc') } as ca ] -> remove_code_annot emitter ~kf stmt ca; { a with annot_content = AAllocation( bhvs, Logic_utils.merge_allocation alloc' alloc) } | _ -> Kernel.fatal "More than one allocation clause for a statement. \ Annotations internal state broken" in emit_a, Extlib.list_of_opt ip) | APragma _ | AExtended _ -> a, Property.ip_of_code_annot kf stmt a in let ca, ppts = convert ca in let e = Emitter.get emitter 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; },_) | GFunDecl(_, 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 Ast.is_computed() then insert_global_in_ast a (**************************************************************************) (** {2 Removing annotations} *) (**************************************************************************) (* 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 ?(force=false) e kf bhv = let set_spec spec tbl = (* Kernel.feedback "Current spec is %a@." Cil_printer.pp_funspec spec; *) (* do not use physical equality since the behaviors are almost always copied at some points *) spec.spec_behavior <- filterq ~eq:is_same_behavior bhv spec.spec_behavior; let name = bhv.b_name in let check get = if not force && 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; let info = Id_contract (Datatype.String.Set.empty,b) in Extlib.may Property_status.remove (Property.ip_of_allocation kf Kglobal info p) end) spec.spec_behavior in remove_in_funspec e kf set_spec let remove_extended e kf ext = let set_spec spec _tbl = List.iter (fun b -> b.b_extended <- Extlib.filter_out ((==) ext) b.b_extended) 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; let info = Id_contract(Datatype.String.Set.empty, b) in Extlib.may Property_status.remove (Property.ip_of_assigns kf Kglobal info p); (match p with | WritesAny -> () | Writes l -> List.iter (fun f -> Extlib.may Property_status.remove (Property.ip_of_from kf Kglobal info 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_code_annot ca stmt = let tbl = Code_annots.find stmt in try Emitter.Usable_emitter.Hashtbl.iter (fun e lca -> let aux ca' = if Cil_datatype.Code_annotation.equal ca ca' then raise (Found (Emitter.Usable_emitter.get e)) in List.iter aux !lca; ) tbl; raise Not_found with Found e -> e 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-Phosphorus-20170501/src/kernel_services/ast_data/alarms.ml0000644000175000017500000006645113113745012023743 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 | Differing_blocks of exp * 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 | Dangling of lval | Is_nan_or_infinite of exp * fkind | Valid_string of exp | Function_pointer of exp (* If you add one constructor to this type, make sure to add a dummy value in the 'reprs' value below, and increase 'nb_alarms' *) let nb_alarm_constructors = 16 module D = Datatype.Make_with_collections (struct type t = alarm let name = "Alarms" let reprs = (* This reprs is exhaustive (there is one value by constructor) for introspection purposes. *) let e = List.hd Exp.reprs in let lv = List.hd Lval.reprs in let t = List.hd Term.reprs in [ Division_by_zero e; Memory_access (lv, For_reading); Logic_memory_access (t, For_writing); Index_out_of_bound (e, None); Invalid_shift (e, None); Pointer_comparison (None, e); Differing_blocks (e, e); Overflow (Signed, e, Integer.one, Lower_bound); Float_to_int (e, Integer.one, Lower_bound); Not_separated (lv, lv); Overlap (lv, lv); Uninitialized lv; Dangling lv; Is_nan_or_infinite (e, FFloat); Valid_string e; Function_pointer e; ] let nb = 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 | Differing_blocks _ -> 12 | Valid_string _ -> 13 | Dangling _ -> 14 | Function_pointer _ -> 15 let () = (* Lightweight checks *) for i = 0 to nb_alarm_constructors - 1 do assert (List.exists (fun a -> nb a = i) reprs); done 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) -> let n = Pervasives.compare b1 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 s2 in if n = 0 then let n = Exp.compare e1 e2 in if n = 0 then let n = Pervasives.compare b1 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 let n = Pervasives.compare b1 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 | Dangling lv1, Dangling lv2 -> Lval.compare lv1 lv2 | Differing_blocks (e11, e12), Differing_blocks (e21, e22) -> let n = Exp.compare e11 e21 in if n = 0 then Exp.compare e12 e22 else n | Function_pointer e1, Function_pointer e2 | Valid_string(e1), Valid_string(e2) -> Exp.compare e1 e2 | _, (Division_by_zero _ | Memory_access _ | Logic_memory_access _ | Index_out_of_bound _ | Invalid_shift _ | Pointer_comparison _ | Overflow _ | Not_separated _ | Overlap _ | Uninitialized _ | Dangling _ | Is_nan_or_infinite _ | Float_to_int _ | Differing_blocks _ | Valid_string _ | Function_pointer _) -> let n = nb a1 - nb a2 in assert (n <> 0); n let equal = Datatype.from_compare let hash a = match a with | Division_by_zero e -> Hashtbl.hash (nb a, Exp.hash e) | Is_nan_or_infinite (e, fk) -> Hashtbl.hash (nb a, Exp.hash e, fk) | Memory_access(lv, b) -> Hashtbl.hash (nb a, Lval.hash lv, b) | Logic_memory_access(t, b) -> Hashtbl.hash (nb a, Term.hash t, b) | Index_out_of_bound(e1, e2) -> Hashtbl.hash (nb a, Exp.hash e1, match e2 with None -> 0 | Some e -> 17 + Exp.hash e) | Invalid_shift(e, n) -> Hashtbl.hash (nb a, Exp.hash e, n) | Pointer_comparison(e1, e2) -> Hashtbl.hash (nb a, (match e1 with None -> 0 | Some e -> 17 + Exp.hash e), Exp.hash e2) | Differing_blocks (e1, e2) -> Hashtbl.hash (nb a, Exp.hash e1, Exp.hash e2) | Overflow(s, e, n, b) -> Hashtbl.hash (s, nb a, Exp.hash e, Integer.hash n, b) | Float_to_int(e, n, b) -> Hashtbl.hash (nb a, Exp.hash e, Integer.hash n, b) | Not_separated(lv1, lv2) | Overlap(lv1, lv2) -> Hashtbl.hash (nb a, Lval.hash lv1, Lval.hash lv2) | Uninitialized lv -> Hashtbl.hash (nb a, Lval.hash lv) | Dangling lv -> Hashtbl.hash (nb a, Lval.hash lv) | Valid_string(e) -> Hashtbl.hash (nb a, Exp.hash e) | Function_pointer e -> Hashtbl.hash (nb a, Exp.hash e) let structural_descr = Structural_descr.t_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 | Differing_blocks (e1, e2) -> Format.fprintf fmt "Differing_blocks(@[%a@],@ @[%a@])" Printer.pp_exp e1 Printer.pp_exp e2 | Overflow(s, e, n, b) -> Format.fprintf fmt "%s(@[%a@]@ %s@ @[%a@])" (Transitioning.String.capitalize_ascii (string_of_overflow_kind s)) Printer.pp_exp e (match b with Lower_bound -> ">=" | Upper_bound -> "<=") Datatype.Integer.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.Integer.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 | Dangling lv -> Format.fprintf fmt "Unspecified(@[%a@])" Lval.pretty lv | Valid_string e -> Format.fprintf fmt "Valid_string(@[%a@])" Exp.pretty e | Function_pointer e -> Format.fprintf fmt "Function_pointer(@[%a@])" Exp.pretty e 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 () = State.add_hook_on_remove (fun e _ h -> 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 (* kf and stmt at which an alarm emitted at [kinstr] should be registered. When [kinstr] is [Kglobal], we root the code annotation at the first statement of the main function. We should probably be using a precondition instead. *) let alarm_kf_stmt ?kf kinstr = match kinstr with | Kglobal -> begin let kf = match kf with | None -> fst (Globals.entry_point ()) | Some kf -> Kernel.fatal "inconsistency in alarm location" Kernel_function.pretty kf in try let stmt = Kernel_function.find_first_stmt kf in kf, stmt with Kernel_function.No_Statement -> (* TODO: this can actually happen *) Kernel.fatal "[Alarm] main function has no code" end | Kstmt stmt -> begin let kf = match kf with | None -> Kernel_function.find_englobing_kf stmt | Some kf -> kf in kf, stmt end let add_annotation tbl alarm emitter ?kf kinstr annot = let kf, stmt = alarm_kf_stmt ?kf kinstr in Annotations.add_code_annot emitter ~kf stmt annot; let id = Rank.next () in D.Hashtbl.add tbl alarm (annot, kf, stmt, id); Alarm_of_annot.add annot alarm 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" | Differing_blocks _ -> "differing_blocks" | Overflow(s, _, _, _) -> string_of_overflow_kind s | Not_separated _ -> "separation" | Overlap _ -> "overlap" | Uninitialized _ -> "initialisation" | Dangling _ -> "dangling_pointer" | Is_nan_or_infinite _ -> "is_nan_or_infinite" | Float_to_int _ -> "float_to_int" | Valid_string _ -> "valid_string" | Function_pointer _ -> "function_pointer" let get_short_name = function | Overflow _ -> "overflow" | a -> get_name a let get_description = function | Division_by_zero _ -> "Integer division by zero" | Memory_access _ -> "Invalid pointer dereferencing" | Logic_memory_access _ -> "Invalid range dereferencing" | Index_out_of_bound _ -> "Array access out of bounds" | Invalid_shift _ -> "Invalid shift" | Pointer_comparison _ -> "Invalid pointer comparison" | Differing_blocks _ -> "Operation on pointers within different blocks" | Overflow(_, _, _, _) -> "Integer overflow or downcast" | Not_separated _ -> "Unsequenced side-effects on non-separated memory" | Overlap _ -> "Overlap between left- and right-hand-side in assignment" | Uninitialized _ -> "Uninitialized memory read" | Dangling _ -> "Read of a dangling pointer" | Is_nan_or_infinite _ -> "Non-finite (nan or infinite) floating-point value" | Float_to_int _ -> "Overflow in float to int conversion" | Valid_string _ -> "Invalid string argument" | Function_pointer _ -> "Pointer to a function with non-compatible type" (* Given a "topmost" location and another one supposed to be more precise, returns the best (hopefully not unknown) one. *) let best_loc ~loc loc' = if Location.equal loc' Location.unknown then loc else loc' let overflowed_expr_to_term ~loc e = let loc = best_loc ~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 = best_loc ~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 = best_loc ~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 = best_loc ~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 = best_loc ~loc e2.eloc in let t1 = match e1 with | None -> begin let typ = match Cil.unrollTypeDeep (Cil.typeOf e2) with | TPtr (TFun _, _) -> TPtr (TFun(Cil.voidType, None, false, []), []) | _ -> Cil.voidPtrType in let zero = Cil.lzero () in Logic_const.term (TCastE (typ, zero)) (Ctype typ) end | 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 | Valid_string(e) -> let loc = best_loc ~loc e.eloc in let t = Logic_utils.expr_to_term ~cast:true e in Logic_utils.points_to_valid_string ~loc t | Differing_blocks(e1, e2) -> (* \base_addr(e1) == \base_addr(e2) *) let loc = best_loc ~loc e1.eloc in let t1 = Logic_utils.expr_to_term ~cast:true e1 in let here = Logic_const.here_label in let typ = Ctype Cil.charPtrType in let t1 = Logic_const.term ~loc:(best_loc loc e1.eloc) (Tbase_addr(here, t1)) typ in let t2 = Logic_utils.expr_to_term ~cast:true e2 in let t2 = Logic_const.term ~loc:(best_loc loc e2.eloc) (Tbase_addr(here, t2)) typ in Logic_const.prel ~loc (Req, t1, t2) | Overflow(_, e, n, bound) -> (* n <= e or e <= n according to bound *) let loc = best_loc ~loc e.eloc in let t = overflowed_expr_to_term ~loc 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 = best_loc ~loc e.eloc in let te = overflowed_expr_to_term ~loc e in let t = Logic_const.tlogic_coerce ~loc te Lreal in let n = (match bound with Lower_bound -> Integer.sub | Upper_bound -> Integer.add) n Integer.one in let tn = Logic_const.tlogic_coerce ~loc (Logic_const.tint ~loc n) Lreal 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) | Dangling lv -> (* !\dangling(lv) *) let e = Cil.mkAddrOrStartOf ~loc lv in let t = Logic_utils.expr_to_term ~cast:false e in Logic_const.(pnot ~loc (pdangling ~loc (Logic_const.here_label, t))) | Is_nan_or_infinite (e, fkind) -> (* \is_finite((fkind)e) *) let loc = best_loc ~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 ])) | Function_pointer e -> let loc = e.eloc in let t = Logic_utils.expr_to_term ~cast:true e in Logic_const.(pvalid_function ~loc t) in let p = aux alarm in assert (p.pred_name = []); { p with pred_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 (** Converts an alarm to a code annotation. Returns the code annotation, whether said code annotation is new, and the table in which the code annot is/should be inserted. *) let to_annot_aux kinstr ?(loc=Kinstr.loc kinstr) alarm = (* Kernel.debug "registering alarm %a" D.pretty alarm;*) let add alarm = let pred = create_predicate ~loc alarm in Logic_const.new_code_annotation (AAssert([], pred)) in try let by_emitter = State.find kinstr in match find_alarm_in_emitters by_emitter alarm with | None -> (* some alarms already associated to this [kinstr], but not this [alarm] *) add alarm, true, by_emitter | Some (annot, _kf, _stmt, _) -> (* this alarm was already emitted *) annot, false, by_emitter with Not_found -> (* no alarm associated to this [kinstr] *) let by_emitter = Usable_emitter.Hashtbl.create 7 in State.add kinstr by_emitter; add alarm, true, by_emitter let to_annot kinstr ?loc alarm = let ca, fresh, _ = to_annot_aux kinstr ?loc alarm in ca, fresh let register emitter ?kf kinstr ?loc ?status alarm = let annot, fresh, by_emitter = to_annot_aux kinstr ?loc alarm in if fresh then begin 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 add_annotation tbl alarm emitter ?kf kinstr annot; end; begin match status with | Some status -> let kf, stmt = alarm_kf_stmt ?kf kinstr in emit_status emitter kf stmt annot status; | _ -> () end; annot, fresh 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 = unsafe_remove ?filter ?kinstr e let () = Annotations.remove_alarm_ref := (fun e stmt annot -> try let a = Alarm_of_annot.find annot in (* [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-Phosphorus-20170501/src/kernel_services/ast_data/annotations.mli0000644000175000017500000005430013113745003025160 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. @raise No_funspec whenever the given function has no specification *) val behaviors: ?emitter:Emitter.t -> ?populate:bool -> kernel_function -> funbehavior list (** Get the behaviors clause of the contract associated to the given function. Meaning of [emitter] and [populate] is similar to {!funspec}. @raise No_funspec whenever the given function has no specification *) 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}. @raise No_funspec whenever the given function has no specification *) 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}. @raise No_funspec whenever the given function has no specification *) 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}. @raise No_funspec whenever the given function has no specification *) 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}. @raise No_funspec whenever the given function has no specification *) (**************************************************************************) (** {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: ?sorted:bool -> (stmt -> Emitter.t -> code_annotation -> unit) -> unit (** Iter on each code annotation of the program. If [sorted] is [true] (the default), iteration is sorted according to the location of the statements and by emitter. Note that the sorted version is less efficient than the unsorted iteration. @modify Sodium-20150201: iteration is sorted *) val fold_all_code_annot: ?sorted:bool -> (stmt -> Emitter.t -> code_annotation -> 'a -> 'a) -> 'a -> 'a (** Fold on each code annotation of the program. See above for the meaning of the [sorted] argument. @modify Sodium-20150201 sorted fold *) 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_extended: (Emitter.t -> acsl_extension -> unit) -> kernel_function -> string -> unit (** @since Sodium-20150201 *) val fold_extended: (Emitter.t -> acsl_extension -> 'a -> 'a) -> kernel_function -> string -> 'a -> 'a val iter_behaviors: (Emitter.t -> funbehavior -> unit) -> kernel_function -> unit (** Iter on the behaviors of the given kernel function. @since Fluorine-20130401 *) val fold_behaviors: (Emitter.t -> funbehavior -> '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. There might be at most one statement contract associated to a given statement and a given set of enclosing behaviors. Trying to associate more than one will result in a merge of the contracts. The same things happens with loop assigns and allocates/frees. There can be at most one loop variant registered per statement. Attempting to register a second one will result in a fatal error. *) val add_assert: Emitter.t -> ?kf:kernel_function -> stmt -> predicate -> 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. *) type 'a contract_component_addition = Emitter.t -> kernel_function -> ?stmt:stmt -> ?active:string list -> 'a -> unit (** type for functions adding a part of a contract (either for global function or for a given [stmt]). In the latter case [active] may be used to state the list of enclosing behavior(s) for which the contract is supposed to hold. [active] defaults to the empty list, meaning that the contract must always hold. @since Aluminium-20160501 *) type 'a behavior_component_addition = Emitter.t -> kernel_function -> ?stmt:stmt -> ?active:string list -> ?behavior:string -> 'a -> unit (** type for functions adding a part of a [behavior] inside a contract. The contract is found in a similar way as for {!contract_component_addition} functions. Similarly, [active] has the same meaning as for {!contract_component_addition}. Default for [behavior] is {!Cil.default_behavior_name}. @since Aluminium-20160501 *) val add_behaviors: ?register_children:bool -> funbehavior list contract_component_addition (** Add new behaviors into the given contract. if [register_children] is [true] (the default), inner clauses of the behavior will also be registered by the function. @modify Aluminium-20160501 restructuration of annotations management *) 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. @modify Aluminium-20160501 restructuration of annotations management *) val add_terminates: identified_predicate contract_component_addition (** Add a terminates clause into a contract. No terminates clause must previously be attached to this contract. @modify Aluminium-20160501 restructuration of annotations management *) val add_complete: string list contract_component_addition (** Add a new complete behaviors clause into the contract of the given function. Do nothing (but emit a warning) if this clause already exists in the spec. @raise Fatal if one of the given name is either an unknown behavior or {!Cil.default_behavior_name}. @modify Aluminium-20160501 restructuration of annotations management *) val add_disjoint: string list contract_component_addition (** Add a new disjoint behaviors clause into the contract of the given function. Do nothing (but emit a warning) if this clause already exists in the spec. @raise Fatal if one of the given name is either an unknown behavior or {!Cil.default_behavior_name}. @modify Aluminium-20160501 restructuration of annotations management *) val add_requires: identified_predicate list behavior_component_addition (** Add new requires clauses into the given behavior. @modify Aluminium-20160501 restructuration of annotations management *) val add_assumes: identified_predicate list behavior_component_addition (** Add new assumes clauses into the given behavior. Does nothing but emitting a warning if an attempt is made to add assumes clauses to the default behavior. @modify Aluminium-20160501 restructuration of annotations management *) val add_ensures: (termination_kind * identified_predicate) list behavior_component_addition (** Add new ensures clauses into the given behavior. @modify Aluminium-20160501 restructuration of annotations management *) val add_assigns: keep_empty:bool -> identified_term assigns behavior_component_addition (** Add new assigns into the given behavior. 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.) @modify Aluminium-20160501 restructuration of annotations management *) val add_allocates: identified_term allocation behavior_component_addition (** Add new allocates into the given behavior. *) val add_extended: acsl_extension behavior_component_addition (** @since Sodium-20150201 *) (**************************************************************************) (** {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. It is the responsibility of the user to ensure that logic functions/predicates declared in the given annotation are not used elsewhere. *) val remove_behavior: ?force:bool -> Emitter.t -> kernel_function -> funbehavior -> 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. If [force] is [false] (which is the default), it is not possible to remove a behavior whose the name is used in a complete/disjoint clause. If [force] is [true], it is the responsibility of the user to ensure that complete/disjoint clauses refer to existing behaviors. *) 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. *) val remove_extended: Emitter.t -> kernel_function -> acsl_extension -> unit (** @since Sodium-20150201 *) (**************************************************************************) (** {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_code_annot: code_annotation -> stmt -> Emitter.t (** @return the emitter which generated the given code_annotation, assumed to be registered at the given statement. @raise Not_found if the code annotation does not exist, or if it is registered at another statement. @since Magnesium-20151001 *) 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 -> bool) 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-Phosphorus-20170501/src/kernel_services/ast_data/ast.ml0000644000175000017500000001656513113745002023253 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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.Constfold.self; Kernel.ReadAnnot.self; Kernel.PreprocessAnnot.self; Kernel.Files.self; Kernel.UnrollingLevel.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 module After_building = Hook.Build(struct type t = Cil_types.file end) let apply_after_computed = After_building.extend let mark_as_changed () = Kernel.debug "AST has changed"; let depends = State_selection.only_dependencies self in let no_remove = State_selection.of_list !linked_states in let selection = State_selection.diff depends no_remove in Project.clear ~selection (); After_building.apply (get()) let mark_as_grown () = Kernel.debug "AST has grown"; let depends = State_selection.only_dependencies self in let no_remove = State_selection.of_list (!linked_states @ !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.set_dependencies_of_ast self; Logic_env.init_dependencies self; 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 module Computing = State_builder.False_ref( struct let name = "Ast.computing" let dependencies = [] end) let force_compute () = if Computing.get () then Kernel.fatal "attempting to get the AST during its initialization"; Computing.set true; Kernel.feedback ~level:2 "computing the AST"; !default_initialization (); Computing.set false; let s = get () in After_building.apply s; s let get () = memo (fun () -> force_compute ()) let is_computed () = is_computed () (* hide the optional argument [?project] *) let compute () = if not (is_computed ()) then ignore (force_compute ()) let () = Parameter_builder.force_ast_compute := 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 (); if not (Computing.get ()) then (* if we are computing the Ast through force_compute, the hooks will be applied by force_compute itself, and trying to do that here might trigger a Bad_Initialization (see gitlab issue #209) *) 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_def_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,_) | GFunDecl(_,v,_) | GVar (v,_,_) | GFun ({svar=v},_) -> LastDecl.replace v g | _ -> () in List.iter update_one_global globs; LastDecl.mark_as_computed () end let def_or_last_decl v = compute_last_def_decl(); try LastDecl.find v with Not_found -> Kernel.fatal "%a does not have a global declaration in the AST" Cil_printer.pp_varinfo v let is_def_or_last_decl g = let is_eq v = compute_last_def_decl (); try (** using [(==)] is the only way to fulfill the spec (do not use [Cil_datatype.Global.equal] here): if a variable is declared several times in the program, each declaration are equal wrt [Cil_datatype.Global.equal] but only one is [(==)] (and exactly one if [g] comes from the AST). *) LastDecl.find v == g with Not_found -> (* [Not_found] mainly means that the information is irrelevant at this stage, not that there is a dangling varinfo. *) false in match g with | GVarDecl(v,_) | GFunDecl (_,v,_) -> is_eq v | GVar _ | GFun _ -> true | _ -> 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-Phosphorus-20170501/src/kernel_services/ast_data/globals.ml0000644000175000017500000006351313113745012024103 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 dkey = Kernel.register_category "globals" (* ************************************************************************* *) (** {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_globals f l = let treat_global = function | GVar(vi,init,_) -> f vi init | GVarDecl (vi,_) -> (* If it is defined it will appear with the right init later *) if not vi.vdefined then f vi { init = None } | GType _ | GCompTag _ | GCompTagDecl _ | GEnumTag _ | GEnumTagDecl _ | GFunDecl _ | GFun _ | GAsm _ | GPragma _ | GText _ | GAnnot _ -> () in List.iter treat_global l let fold_globals f acc l = let treat_global acc = function | GVar(vi,init,_) -> f vi init acc | GVarDecl (vi,_) -> (* If it is defined it will appear with the right init later *) if vi.vdefined then acc else f vi { init = None } acc | GType _ | GCompTag _ | GCompTagDecl _ | GEnumTag _ | GEnumTagDecl _ | GFunDecl _ | GFun _ | GAsm _ | GPragma _ | GText _ | GAnnot _ -> acc in List.fold_left treat_global acc l let iter_in_file_order f = iter_globals f (Ast.get ()).globals let fold_in_file_order f acc = fold_globals f acc (Ast.get ()).globals let iter_in_file_rev_order f = iter_globals f (List.rev (Ast.get ()).globals) let fold_in_file_rev_order f acc = fold_globals f acc (List.rev (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 numbering scheme. *) module VarinfoAlphaOrderSet = struct let compare_alpha 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 Elts = struct include Cil_datatype.Varinfo let compare = compare_alpha end end module Iterator = struct module State = State_builder.Ref (Datatype.String.Map.Make(VarinfoAlphaOrderSet.Elts)) (struct let name = "FunctionsOrder" let dependencies = [ State.self ] let default () = Datatype.String.Map.empty end) let add v = State.set (Datatype.String.Map.add v.vname v (State.get ())) let iter f = Datatype.String.Map.iter (fun _ v -> f v) (State.get ()) let fold f acc = Datatype.String.Map.fold (fun _ v acc -> f v acc) (State.get ()) acc end let init_kernel_function f spec = { fundec = f; 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 = (match kf.fundec, fundec with (* we never update a definition with a declaration (see bug 1914). If you really want to play this game, just mutate the kf in place and hope for the best. *) | Definition _, Declaration(_,v,_,_) when v.vdefined -> () | _ -> 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 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 ~dkey "@[Register definition %a with specification@. \"%a\"@]" Varinfo.pretty n.svar Cil_printer.pp_funspec n.sspec ; replace_by_definition n.sspec n l; | Declaration (spec, v,_,l) -> Kernel.debug ~dkey "@[Register declaration %a with specification@ \"%a\"@]" Varinfo.pretty 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 let find_by_name fct_name = let vi = Datatype.String.Map.find fct_name (Iterator.State.get ()) in State.find vi let find_def_by_name fct_name = let vi = Datatype.String.Map.find fct_name (Iterator.State.get ()) in let res = State.find vi in if Ast_info.Function.is_definition res.fundec then res else raise Not_found let find_decl_by_name fct_name = let vi = Datatype.String.Map.find fct_name (Iterator.State.get ()) in let res = State.find vi in if Ast_info.Function.is_definition res.fundec then raise Not_found else res let () = Parameter_builder.find_kf_by_name := find_by_name; Parameter_builder.find_kf_def_by_name := find_def_by_name; Parameter_builder.find_kf_decl_by_name := find_decl_by_name; Parameter_customize.find_kf_by_name := find_by_name 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.State.self let category = let o = object method fold: 'a. (kernel_function -> 'a -> 'a) -> 'a -> 'a = fold method mem kf = State.mem (get_vi kf) end in Parameter_category.create "functions" Cil_datatype.Kf.ty ~register:true [ self ] o let generate_kf_category is_definition = let o = object method fold: 'a. (kernel_function -> 'a -> 'a) -> 'a -> 'a = fun f acc -> fold (fun kf acc -> match kf.fundec with | Definition _ -> if is_definition then f kf acc else acc | Declaration _ -> if is_definition then acc else f kf acc) acc method mem kf = State.mem (get_vi kf) && (is_definition = Ast_info.Function.is_definition kf.fundec) end in Parameter_category.create "functions" Cil_datatype.Kf.ty ~register:true [ self ] o let def_category = generate_kf_category true let decl_category = generate_kf_category false let fundec_category = let o = object method fold: 'a. (fundec -> 'a -> 'a) -> 'a -> 'a = fun f acc -> fold (fun kf acc -> match kf.fundec with | Definition(fundec, _) -> f fundec acc | Declaration _ -> acc) acc method mem f = State.mem f.svar end in Parameter_category.create "functions" Cil_datatype.Fundec.ty ~register:true [ self ] o let string_category = let o = object method fold: 'a. (string -> 'a -> 'a) -> 'a -> 'a = fun f -> Iterator.fold (fun v acc -> f v.vname acc) method mem s = Datatype.String.Map.mem s (Iterator.State.get ()) end in Parameter_category.create "functions" Datatype.string ~register:true [ self ] o let () = Parameter_builder.kf_category := (fun () -> category); Parameter_builder.kf_def_category := (fun () -> def_category); Parameter_builder.kf_decl_category := (fun () -> decl_category); Parameter_builder.kf_string_category := (fun () -> string_category); Parameter_builder.fundec_category := (fun () -> fundec_category) 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 Kernel.debug ~dkey "Indexing global in file %s@." (Filepath.pretty 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 occurrence 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 -> match glob with | Cil_types.GVar (vi, _, _) | Cil_types.GVarDecl(vi, _) when vi.vglob -> Varinfo.Set.add vi acc | _ -> 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.GFunDecl(_,x, _) -> if declarations || (match (Functions.get x).fundec with Definition _ -> false | Declaration _ -> true) then Some x 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 Types} *) (* ************************************************************************* *) module Types = struct module PairsExpTyp = Datatype.Pair(Cil_datatype.Exp)(Cil_datatype.Typ) (* Map from enum constant names to an expression containing the constant, and its type. *) module Enums = State_builder.Hashtbl(Datatype.String.Hashtbl)(PairsExpTyp) (struct let size = 137 let dependencies = [Ast.self] let name = "Globals.Types.Enums" end) module Type_Name_Namespace = Datatype.Pair_with_collections (Datatype.String)(Logic_typing.Type_namespace) (struct let module_name = "Globals.Types.Typ_Name_Namespace" end) (* Maps from a type name and its namespace, to the Cil type. *) module Types = State_builder.Hashtbl(Type_Name_Namespace.Hashtbl)(Cil_datatype.Typ) (struct let size = 137 let dependencies = [Ast.self] let name = "Logic_interp.Types" end) (* Maps a typename (with its namespace) to its corresponding global. *) module TypeNameToGlobal = State_builder.Hashtbl (Type_Name_Namespace.Hashtbl) (Cil_datatype.Global) (struct let name = "Globals.Types.TypeNameToGlobal" let size = 7 let dependencies = [ Ast.self ] end) let resolve_types () = let aux_ei ei = (* for enums *) let exp = Cil.new_exp ~loc:ei.eiloc (Const (CEnum ei)) in Enums.replace ei.einame (exp, Cil.typeOf ei.eival) in let aux_glob g = match g with | GType (ti, _loc) -> let name_tag = (ti.tname, Logic_typing.Typedef) in Types.replace name_tag (TNamed (ti, [])); TypeNameToGlobal.replace name_tag g | GEnumTag (ei, _loc) -> let name_tag = (ei.ename, Logic_typing.Enum) in Types.add name_tag (TEnum (ei, [])); List.iter aux_ei ei.eitems; TypeNameToGlobal.replace name_tag g | GEnumTagDecl (ei, _) -> let name_tag = (ei.ename, Logic_typing.Enum) in Types.add name_tag (TEnum (ei, [])); List.iter aux_ei ei.eitems | GCompTag (ci, _loc) -> let kind = Logic_typing.(if ci.cstruct then Struct else Union) in let name_tag = (ci.cname, kind) in Types.add name_tag (TComp (ci, Cil.empty_size_cache (), [])); TypeNameToGlobal.replace name_tag g | GCompTagDecl (ci, _) -> let kind = Logic_typing.(if ci.cstruct then Struct else Union) in let name_tag = (ci.cname, kind) in Types.add name_tag (TComp (ci, Cil.empty_size_cache (), [])) | _ -> () in if not (Enums.is_computed ()) || not (Types.is_computed ()) then begin List.iter aux_glob (Ast.get ()).globals; Enums.mark_as_computed (); Types.mark_as_computed (); TypeNameToGlobal.mark_as_computed () end let find_enum_tag x = resolve_types (); Enums.find x let find_type namespace s = resolve_types (); Types.find (s, namespace) let iter_types f = resolve_types (); Types.iter (fun (name, namespace) typ -> f name typ namespace) let global namespace s = resolve_types (); TypeNameToGlobal.find (s, namespace) end (* ************************************************************************* *) (** {2 Entry point} *) (* ************************************************************************* *) exception No_such_entry_point of string let entry_point () = Ast.compute (); let kf_name, lib = Kernel.MainFunction.get_plain_string (), Kernel.LibEntry.get () in let fcts = Parameter_customize.get_c_ified_functions kf_name in if (Cil_datatype.Kf.Set.is_empty fcts) then raise (No_such_entry_point (Format.sprintf "cannot find entry point `%s'.@;\ Please use option `-main' for specifying a valid entry point." kf_name)) else begin if (Cil_datatype.Kf.Set.cardinal fcts > 1) then Kernel.warning "Ambiguous function name: %s; \ choosing an arbitrary function whose name apply." kf_name; let kf = Cil_datatype.Kf.Set.choose fcts in kf, lib end 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_plain_string () 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 (Filepath.pretty 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-Phosphorus-20170501/src/kernel_services/ast_data/ast.mli0000644000175000017500000001327113113745011023413 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. *) 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_def_or_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, and the GUI to remove redundant declarations of globals. Complexity: O(nb of globals) for the first call, then O(1). @since Oxygen-20120901 *) val def_or_last_decl: Cil_types.varinfo -> Cil_types.global (** [def_or_last_decl v] returns the global [g] declaring or defining [g] such that [is_def_or_last_decl g] is true. [v] must be a global variable declared in the AST. @since Aluminium-20160501 *) 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-Phosphorus-20170501/src/kernel_services/ast_data/property.mli0000644000175000017500000004057113113745004024515 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 @plugin development guide *) 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_contract of Datatype.String.Set.t * funbehavior (** in case of statement contract, we can have different contracts based on different sets of active behaviors. *) | Id_loop of code_annotation (** 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 * Datatype.String.Set.t * funbehavior (** for statement contract, the set of parent behavior for which the contract is active is part of its identification. If the set is empty, the contract is active for all parent behaviors. *) type identified_complete = kernel_function * kinstr * Datatype.String.Set.t * string list (** Same as for {!identified_behavior}. *) type identified_disjoint = identified_complete 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 * location and identified_axiom = identified_lemma (** Specialization of a property at a given point. *) and identified_instance = kernel_function option * kinstr * identified_property and identified_type_invariant = string * typ * predicate * location and identified_global_invariant = string * predicate * location 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 | IPPropertyInstance of identified_instance | IPTypeInvariant of identified_type_invariant | IPGlobalInvariant of identified_global_invariant | IPOther of string * kernel_function option * kinstr include Datatype.S_with_collections with type t = identified_property val short_pretty: Format.formatter -> t -> unit (** output a meaningful name for the property (e.g. the name of the corresponding identified predicate when available) reverting back to the full ACSL formula if it can't find one. The name is not meant to uniquely identify the property. @since Neon-20140301 *) (** @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 (** [ip_allocation_of_behavior kf ki active bhv] builds IPAllocation for behavior [bhv], in the spec in function [kf], at statement [ki], under active behaviors [active] @since Oxygen-20120901 @modify Aluminium-20160501 added active argument *) val ip_allocation_of_behavior: kernel_function -> kinstr -> active:string list -> 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 (** [ip_assigns_of_behavior kf ki active bhv] builds IPAssigns for a contract (if not WritesAny). See {!ip_allocation_of_behavior} for signification of [active]. @since Carbon-20110201 @modify Aluminium-20160501 added active argument *) val ip_assigns_of_behavior: kernel_function -> kinstr -> active:string list -> funbehavior -> identified_property option (** Builds the corresponding IPFrom (if not FromAny) @since Carbon-20110201 @modify Aluminium-20160501 returns an option. *) val ip_of_from: kernel_function -> kinstr -> behavior_or_loop -> identified_term from -> identified_property option (** [ip_from_of_behavior kf ki active bhv] builds IPFrom for a behavior (if not ReadsAny). See {!ip_from_of_behavior} for signification of [active] @since Carbon-20110201 @modify Aluminium-20160501 added active argument *) val ip_from_of_behavior: kernel_function -> kinstr -> active:string list -> 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 (** [ip_post_cond_of_behavior kf ki active bhv] builds all IP related to the post-conditions (including allocates, frees, assigns and from). See {!ip_allocation_of_behavior} for the signification of the [active] argument. @since Carbon-20110201 @modify Aluminium-20160501 added active argument *) val ip_post_cond_of_behavior: kernel_function -> kinstr -> active:string list -> funbehavior -> identified_property list (** [ip_of_behavior kf ki activd bhv] builds the IP corresponding to the behavior itself. See {!ip_allocation_of_behavior} for signification of [active] @since Carbon-20110201 @modify Aluminium-20160501 added active argument *) val ip_of_behavior: kernel_function -> kinstr -> active:string list -> funbehavior -> identified_property (** [ip_all_of_behavior kf ki active bhv] builds all IP related to a behavior. See {!ip_allocation_of_behavior} for signification of [active] @since Carbon-20110201 @modify Aluminium-20160501 added active argument *) val ip_all_of_behavior: kernel_function -> kinstr -> active:string list -> funbehavior -> identified_property list (** [ip_of_complete kf ki active complete] builds IPComplete. See {!ip_allocation_of_behavior} for signification of [active] @since Carbon-20110201 @modify Aluminium-20160501 added active argument *) val ip_of_complete: kernel_function -> kinstr -> active:string list -> string list -> identified_property (** [ip_complete_of_spec kf ki active spec] builds IPComplete of a given spec. See {!ip_allocation_of_behavior} for signification of [active] @since Carbon-20110201 @modify Aluminium-20160501 added active argument *) val ip_complete_of_spec: kernel_function -> kinstr -> active:string list -> funspec -> identified_property list (** [ip_of_disjoint kf ki active disjoint] builds IPDisjoint. See {!ip_allocation_of_behavior} for signification of [active] @since Carbon-20110201 @modify Aluminium-20160501 added active argument *) val ip_of_disjoint: kernel_function -> kinstr -> active:string list -> string list -> identified_property (** [ip_disjoint_of_spec kf ki active spec] builds IPDisjoint of a given spec. See {!ip_allocation_of_behavior} for signification of [active] @since Carbon-20110201 @modify Aluminium-20160501 added active argument *) val ip_disjoint_of_spec: kernel_function -> kinstr -> active:string list -> 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 (** [ip_post_cond_of_spec kf ki active spec] builds all IP of post-conditions related to a spec. See {!ip_post_cond_of_behavior} for more information. @since Carbon-20110201 @modify Aluminium-20160501 added active argument *) val ip_post_cond_of_spec: kernel_function -> kinstr -> active:string list -> funspec -> identified_property list (** [ip_of_spec kf ki active spec] builds all IP related to a spec. See {!ip_allocation_of_behavior} for signification of [active] @since Carbon-20110201 @modify Aluminium-20160501 added active argument *) val ip_of_spec: kernel_function -> kinstr -> active:string list -> funspec -> identified_property list (** Build a specialization of the given property at the given function and stmt *) val ip_property_instance: kernel_function option -> kinstr -> identified_property -> identified_property (** 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 (** Build an IPTypeInvariant. *) val ip_type_invariant: identified_type_invariant -> identified_property (** Build an IPGlobalInvariant. *) val ip_global_invariant: identified_global_invariant -> 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-Phosphorus-20170501/src/kernel_services/ast_data/property.ml0000644000175000017500000011001713113745003024334 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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_contract of Datatype.String.Set.t * funbehavior | Id_loop of code_annotation type identified_complete = kernel_function * kinstr * Datatype.String.Set.t * 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 * Datatype.String.Set.t * 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 type identified_type_invariant = string * typ * predicate * location type identified_global_invariant = string * predicate * location and identified_axiomatic = string * identified_property list and identified_lemma = string * logic_label list * string list * predicate * location and identified_axiom = identified_lemma and identified_instance = kernel_function option * kinstr * identified_property 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 | IPPropertyInstance of identified_instance | IPTypeInvariant of identified_type_invariant | IPGlobalInvariant of identified_global_invariant | 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,_,_) | IPPropertyInstance (_, ki, _) -> ki | IPAxiom _ | IPAxiomatic _ | IPLemma _ -> Kglobal | IPOther(_,_,ki) -> ki | IPCodeAnnot (_,s,_) -> Kstmt s | IPTypeInvariant _ | IPGlobalInvariant _ -> Kglobal 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 (kfopt, _, _) | IPPropertyInstance (kfopt, _, _) | IPOther(_,kfopt,_) -> kfopt | IPTypeInvariant _ | IPGlobalInvariant _ -> None let loc_of_kf_ki kf = function | Kstmt s -> Cil_datatype.Stmt.loc s | Kglobal -> Kernel_function.get_location kf let rec location = function | IPPredicate (_,_,_,ip) -> ip.ip_content.pred_loc | IPBehavior(kf,ki, _,_) | IPComplete (kf,ki,_,_) | IPDisjoint(kf,ki,_,_) | IPReachable(Some kf, ki, _) | IPPropertyInstance (Some kf, ki, _) -> loc_of_kf_ki kf ki | IPPropertyInstance (None, Kstmt s, _) | IPReachable(None, Kstmt s, _) -> Cil_datatype.Stmt.loc s | IPCodeAnnot (_,s,ca) -> ( match Cil_datatype.Code_annotation.loc ca with | None -> Cil_datatype.Stmt.loc s | Some loc -> loc) | IPPropertyInstance (None, Kglobal, _) | IPReachable(None, Kglobal, _) -> Cil_datatype.Location.unknown | 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 | 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) | IPTypeInvariant(_,_,_,loc) | IPGlobalInvariant(_,_,loc) -> loc (* Pretty information about the localization of a IPPropertyInstance *) let pretty_instance_location fmt (kfopt, ki) = match kfopt, ki with | None, Kglobal -> Format.pp_print_string fmt "at global scope" | Some kf, Kglobal -> Format.fprintf fmt "in function %a" Kernel_function.pretty kf | None, Kstmt stmt -> Format.fprintf fmt "at stmt %d" stmt.sid | Some kf, Kstmt stmt when Kernel_function.(equal kf (find_englobing_kf stmt)) -> Format.fprintf fmt "at stmt %d" stmt.sid | Some kf, Kstmt stmt -> Format.fprintf fmt "at stmt %d and function %a" stmt.sid Kernel_function.pretty kf 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_contract (_,b),_) | IPAssigns(_,_,Id_contract (_,b),_) | IPFrom(_,_,Id_contract (_,b),_) -> Some b | IPAllocation(_,_,Id_loop _,_) | IPAssigns(_,_,Id_loop _,_) | IPFrom(_,_,Id_loop _,_) | IPAxiom _ | IPAxiomatic _ | IPLemma _ | IPCodeAnnot (_,_,_) | IPComplete (_,_,_,_) | IPDisjoint(_,_,_,_) | IPDecrease _ | IPReachable _ | IPPropertyInstance _ | IPTypeInvariant _ | IPGlobalInvariant _ | 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 pp_active fmt active = let sep = ref false in let print_one a = Format.fprintf fmt "%s%s" (if !sep then ", " else "") a; sep:=true in Datatype.String.Set.iter print_one active let rec 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 | IPTypeInvariant(s,ty,_,_) -> Format.fprintf fmt "invariant@ %s for type %a" s Cil_printer.pp_typ ty | IPGlobalInvariant(s,_,_) -> Format.fprintf fmt "global invariant@ %s" s | IPBehavior(_kf, ki, active, 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 -> ()); pp_active fmt active | IPCodeAnnot(_, _, a) -> Cil_printer.pp_code_annotation fmt a | IPComplete(_, _, active, l) -> Format.fprintf fmt "complete@ %a" (Pretty_utils.pp_list ~sep:"," (fun fmt s -> Format.fprintf fmt "@ %s" s)) l; pp_active fmt active | IPDisjoint(_, _, active, l) -> Format.fprintf fmt "disjoint@ %a" (Pretty_utils.pp_list ~sep:"," (fun fmt s -> Format.fprintf fmt " %s" s)) l; pp_active fmt active | 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 | IPPropertyInstance (kfopt, ki, ip) -> Format.fprintf fmt "status of '%a'%t %a" pretty ip (fun fmt -> match get_kf ip with | Some kf -> Format.fprintf fmt " of %a" Kernel_function.pretty kf | None -> ()) pretty_instance_location (kfopt, ki) | IPOther(s,_,_) -> Format.pp_print_string fmt s let rec hash = let hash_bhv_loop = function | Id_contract (a,b) -> (0, Hashtbl.hash (a,b.b_name)) | Id_loop 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, y) -> (* complete list is more likely to discriminate than active list. *) Hashtbl.hash (6, Kf.hash f, Kinstr.hash ki, (y:string list), (x:Datatype.String.Set.t)) | IPDisjoint(f, ki, x, y) -> Hashtbl.hash (7, Kf.hash f, Kinstr.hash ki, (y: string list), (x:Datatype.String.Set.t)) | 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, a, b) -> Hashtbl.hash (11, Kf.hash kf, Kinstr.hash s, (b.b_name:string), (a:Datatype.String.Set.t)) | 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) | IPPropertyInstance (kf_caller, ki, ip) -> Hashtbl.hash (14, Extlib.opt_hash Kf.hash kf_caller, Kinstr.hash ki, hash ip) | IPOther(s,_,_) -> Hashtbl.hash (15, (s:string)) | IPTypeInvariant(s,_,_,_) -> Hashtbl.hash (16, (s:string)) | IPGlobalInvariant(s,_,_) -> Hashtbl.hash (17, (s:string)) let rec 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_loop ca1, Id_loop ca2 -> ca1.annot_id = ca2.annot_id | Id_contract (a1,b1), Id_contract (a2,b2) -> Datatype.String.Set.equal a1 a2 && Datatype.String.equal b1.b_name b2.b_name | Id_loop _, Id_contract _ | Id_contract _, Id_loop _ -> false) in match p1, p2 with | IPPredicate (_,_,_,s1), IPPredicate (_,_,_,s2) -> s1.ip_id = s2.ip_id | IPAxiom (s1,_,_,_,_), IPAxiom (s2,_,_,_,_) | IPAxiomatic(s1, _), IPAxiomatic(s2, _) | IPTypeInvariant(s1,_,_,_), IPTypeInvariant(s2,_,_,_) | IPGlobalInvariant(s1,_,_), IPGlobalInvariant(s2,_,_) | IPLemma (s1,_,_,_,_), IPLemma (s2,_,_,_,_) -> Datatype.String.equal s1 s2 | IPCodeAnnot(_,_,ca1), IPCodeAnnot(_,_,ca2) -> ca1.annot_id = ca2.annot_id | IPComplete(f1, ki1, a1, x1), IPComplete(f2, ki2, a2, x2) | IPDisjoint(f1, ki1, a1, x1), IPDisjoint(f2, ki2, a2, x2) -> Kf.equal f1 f2 && Kinstr.equal ki1 ki2 && a1 = a2 && 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, a1, b1), IPBehavior(f2, k2, a2, b2) -> Kf.equal f1 f2 && Kinstr.equal k1 k2 && Datatype.String.Set.equal a1 a2 && 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 | IPPropertyInstance (kf1, ki1, ip1), IPPropertyInstance (kf2, ki2, ip2) -> Extlib.opt_equal Kernel_function.equal kf1 kf2 && Kinstr.equal ki1 ki2 && equal ip1 ip2 | (IPPredicate _ | IPAxiom _ | IPAxiomatic _ | IPLemma _ | IPCodeAnnot _ | IPComplete _ | IPDisjoint _ | IPAssigns _ | IPFrom _ | IPDecrease _ | IPBehavior _ | IPReachable _ | IPAllocation _ | IPOther _ | IPPropertyInstance _ | IPTypeInvariant _ | IPGlobalInvariant _), _ -> false let rec 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_contract (a1,b1), Id_contract (a2,b2) -> let n = Datatype.String.compare b1.b_name b2.b_name in if n = 0 then Datatype.String.Set.compare a1 a2 else n | Id_loop ca1, Id_loop ca2 -> Datatype.Int.compare ca1.annot_id ca2.annot_id | Id_contract _, Id_loop _ -> -1 | Id_loop _, Id_contract _ -> 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, a1, b1), IPBehavior(f2, k2, a2, b2) -> cmp_bhv (f1, k1, Id_contract (a1,b1)) (f2, k2, Id_contract (a2,b2)) | IPComplete(f1, ki1, a1, x1), IPComplete(f2, ki2, a2, x2) | IPDisjoint(f1, ki1, a1, x1), IPDisjoint(f2, ki2, a2, x2) -> let n = Kf.compare f1 f2 in if n = 0 then let n = Kinstr.compare ki1 ki2 in if n = 0 then let n = Extlib.compare_basic x1 x2 in if n = 0 then Datatype.String.Set.compare a1 a2 else n 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, _) | IPTypeInvariant(s1,_,_,_), IPTypeInvariant(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) | IPPropertyInstance (kf1, ki1, ip1), IPPropertyInstance (kf2, ki2, ip2) -> let c = Extlib.opt_compare Kernel_function.compare kf1 kf2 in if c <> 0 then c else let c = Kinstr.compare ki1 ki2 in if c <> 0 then c else compare ip1 ip2 | (IPPredicate _ | IPCodeAnnot _ | IPBehavior _ | IPComplete _ | IPDisjoint _ | IPAssigns _ | IPFrom _ | IPDecrease _ | IPReachable _ | IPAxiom _ | IPAxiomatic _ | IPLemma _ | IPOther _ | IPAllocation _ | IPPropertyInstance _ | IPTypeInvariant _ | IPGlobalInvariant _) 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 | IPPropertyInstance _ -> 15 | IPTypeInvariant _ -> 16 | IPGlobalInvariant _ -> 17 in Datatype.Int.compare (nb x) (nb y) end) let rec short_pretty fmt p = match p with | IPPredicate (_,_,_,{ ip_content = {pred_name = name :: _ }}) -> Format.pp_print_string fmt name | IPPredicate _ -> pretty fmt p | IPAxiom (name,_,_,_,_) | IPLemma(name,_,_,_,_) | IPTypeInvariant(name,_,_,_) -> Format.pp_print_string fmt name | IPGlobalInvariant(name,_,_) -> Format.pp_print_string fmt name | IPAxiomatic (name,_) -> Format.pp_print_string fmt name | IPBehavior(kf,_,_,{b_name = name }) -> Format.fprintf fmt "behavior %s in function %a" name Kernel_function.pretty kf | IPComplete (kf,_,_,_) -> Format.fprintf fmt "complete clause in function %a" Kernel_function.pretty kf | IPDisjoint (kf,_,_,_) -> Format.fprintf fmt "disjoint clause in function %a" Kernel_function.pretty kf | IPCodeAnnot (_,_,{ annot_content = AAssert (_, { pred_name = name :: _ })}) -> Format.pp_print_string fmt name | IPCodeAnnot(_,_,{annot_content = AInvariant (_,_, { pred_name = name :: _ })})-> Format.pp_print_string fmt name | IPCodeAnnot _ -> pretty fmt p | IPAllocation (kf,_,_,_) -> Format.fprintf fmt "allocates/frees clause in function %a" Kernel_function.pretty kf | IPAssigns (kf,_,_,_) -> Format.fprintf fmt "assigns clause in function %a" Kernel_function.pretty kf | IPFrom (kf,_,_,(t,_)) -> Format.fprintf fmt "from clause of term %a in function %a" Cil_printer.pp_identified_term t Kernel_function.pretty kf | IPDecrease(kf,_,_,_) -> Format.fprintf fmt "decrease clause in function %a" Kernel_function.pretty kf | IPPropertyInstance (kfopt, ki, ip) -> Format.fprintf fmt "specialization of %a %a" short_pretty ip pretty_instance_location (kfopt, ki) | IPReachable _ | IPOther _ -> pretty fmt p 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.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 active_prefix fmt a = let print_one a = Format.fprintf fmt "_%s" a in Datatype.String.Set.iter print_one a let rec id_prop_txt p = match p with | IPPredicate (pk,kf,ki,idp) -> Format.asprintf "%s%s%a" (kf_prefix kf) (predicate_kind_txt pk ki) pp_names idp.ip_content.pred_name | IPCodeAnnot (kf,_, ca) -> let name = match ca.annot_content with | AAssert _ -> "assert" | AInvariant (_,true,_) -> "loop_inv" | AInvariant _ -> "inv" | APragma _ -> "pragma" | _ -> assert false in Format.asprintf "%s%s%a" (kf_prefix kf) name pp_code_annot_names ca | IPComplete (kf, ki, a, lb) -> Format.asprintf "%s%s%acomplete%a" (kf_prefix kf) (ki_prefix ki) active_prefix a pp_names lb | IPDisjoint (kf, ki, a, lb) -> Format.asprintf "%s%s%adisjoint%a" (kf_prefix kf) (ki_prefix ki) active_prefix a 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,_) -> Format.asprintf "axiom_%s%a" name pp_names named_pred.pred_name | IPAxiomatic(name, _) -> "axiomatic_" ^ name | IPLemma (name,_,_,named_pred,_) -> Format.asprintf "lemma_%s%a" name pp_names named_pred.pred_name | IPTypeInvariant (name,_,named_pred,_) -> Format.asprintf "type_invariant_%s%a" name pp_names named_pred.pred_name | IPGlobalInvariant (name,named_pred,_) -> Format.asprintf "global_invariant_%s%a" name pp_names named_pred.pred_name | IPAllocation (kf, ki, (Id_contract (a,b)), _) -> Format.asprintf "%s%s%a%salloc" (kf_prefix kf) (ki_prefix ki) active_prefix a (behavior_prefix b) | IPAllocation (kf, Kstmt _s, (Id_loop ca), _) -> Format.asprintf "%sloop_alloc%a" (kf_prefix kf) pp_code_annot_names ca | IPAllocation _ -> assert false | IPAssigns (kf, ki, (Id_contract (a,b)), _) -> Format.asprintf "%s%s%a%sassign" (kf_prefix kf) (ki_prefix ki) active_prefix a (behavior_prefix b) | IPAssigns (kf, Kstmt _s, (Id_loop ca), _) -> Format.asprintf "%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(kf, ki, a, b) -> Format.asprintf "%s%s%a%s" (kf_prefix kf) (ki_prefix ki) active_prefix a b.b_name | IPPropertyInstance (kfopt, ki, ip) -> Format.asprintf "specialization_%s_at_%t" (id_prop_txt ip) (fun fmt -> match kfopt, ki with | None, Kglobal -> Format.pp_print_string fmt "global" | Some kf, Kglobal -> Kernel_function.pretty fmt kf | None, Kstmt s -> Format.fprintf fmt "stmt_%d" s.sid | Some kf, Kstmt s -> Format.fprintf fmt "%a_stmt_%d" Kernel_function.pretty kf s.sid) | IPOther(s,Some kf,ki) -> (kf_prefix kf) ^ (ki_prefix ki) ^ s | IPOther(s,None,ki) -> (ki_prefix ki) ^ s (** function used to normalize basename *) let normalize_basename s = let is_valid_char_id = function | 'a'..'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> true | _ -> false and is_numeric = function | '0'..'9' -> true | _ -> false in if s ="" then "property" else let s = String.map (fun c -> if not (is_valid_char_id c) then '_' else c) s in if is_numeric 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 _ | IPPropertyInstance _ | IPOther _ | IPTypeInvariant _ | IPGlobalInvariant _ -> Before | IPPredicate(PKEnsures _, _, _, _) | IPAssigns _ | IPFrom _ | IPBehavior _ -> After | IPReachable _ -> Kernel.fatal "IPReachable(IPReachable _) is not possible" 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 ~active b = let a = Datatype.String.Set.of_list active in ip_of_allocation kf st (Id_contract (a,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 ~active b = let a = Datatype.String.Set.of_list active in ip_of_assigns kf st (Id_contract (a,b)) b.b_assigns let ip_of_from kf st loc from = match snd from with | FromAny -> None | From _ -> Some (IPFrom (kf,st, loc, from)) let ip_from_of_behavior kf st ~active b = match b.b_assigns with | WritesAny -> [] | Writes l -> let treat_from acc (out, froms) = match froms with | FromAny -> acc | From _ -> let a = Datatype.String.Set.of_list active in let ip = Extlib.the (ip_of_from kf st (Id_contract (a,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_loop 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_loop 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 = Extlib.the (ip_of_from kf st (Id_loop ca) (out, froms)) in ip::acc in List.fold_left treat_from [] l | _ -> [] let ip_post_cond_of_behavior kf st ~active b = ip_ensures_of_behavior kf st b @ (Extlib.list_of_opt (ip_assigns_of_behavior kf st ~active b)) @ ip_from_of_behavior kf st active b @ (Extlib.list_of_opt (ip_allocation_of_behavior kf st ~active b)) let ip_of_behavior kf s ~active b = let a = Datatype.String.Set.of_list active in IPBehavior(kf, s, a, 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 ~active b = ip_of_behavior kf st ~active b :: ip_requires_of_behavior kf st b @ ip_assumes_of_behavior kf st b @ ip_post_cond_of_behavior kf st ~active b let ip_of_complete kf st ~active bhvs = let a = Datatype.String.Set.of_list active in IPComplete(kf,st,a,bhvs) let ip_complete_of_spec kf st ~active s = List.map (ip_of_complete kf st ~active) s.spec_complete_behaviors let ip_of_disjoint kf st ~active bhvs = let a = Datatype.String.Set.of_list active in IPDisjoint(kf,st,a,bhvs) let ip_disjoint_of_spec kf st ~active s = List.map (ip_of_disjoint kf st ~active) 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 ~active s = List.concat (List.map (ip_post_cond_of_behavior kf st ~active) s.spec_behavior) let ip_of_spec kf st ~active s = List.concat (List.map (ip_all_of_behavior kf st ~active) s.spec_behavior) @ ip_complete_of_spec kf st active s @ ip_disjoint_of_spec kf st active 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_type_invariant s = IPTypeInvariant s let ip_global_invariant s = IPGlobalInvariant s let ip_property_instance kfopt ki ip = IPPropertyInstance (kfopt, ki, ip) 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 (active,s) -> ip_of_spec kf st active 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 _ -> [] | AExtended _ -> [] 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, loc) -> let pred = match l.l_body with | LBpred p -> p | _ -> assert false in IPGlobalInvariant(l.l_var_info.lv_name,pred,loc) :: acc | Dtype_annot(l, loc) -> let parameter = match l.l_profile with | h :: [] -> h | _ -> assert false in let ty = match parameter.lv_type with | Ctype x -> x | _ -> assert false in let pred = match l.l_body with | LBpred p -> p | _ -> assert false in IPTypeInvariant(l.l_var_info.lv_name,ty,pred,loc) :: 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-Phosphorus-20170501/src/kernel_services/ast_data/statuses_by_call.mli0000644000175000017500000000726313113745007026175 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 all_functions_with_preconditions: stmt -> Kernel_function.Hptset.t (** Returns the set of functions that can be called at the given statement and for which a precondition has been specialized at this call. Those functions are registered when the function {!precondition_at_call} is called. *) 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-Phosphorus-20170501/src/kernel_services/ast_data/property_status.mli0000644000175000017500000002614713113745004026123 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 implicitly 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 emitting False after emitting 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 inferred? *) } type inconsistent = private { valid: emitter_with_properties list; invalid: emitter_with_properties list } (** Type of the local status of a property. *) type status = private | Never_tried (** Nobody tries to verify the property *) | Best of emitted_status (** The know more precise status *) * emitter_with_properties list (** who attempt the verification under which hypotheses *) | Inconsistent of inconsistent (** someone locally says the property is valid and someone else says it is invalid: only the consolidated status may conclude. *) include Datatype.S with type t = status val get: Property.t -> status (** @return the most precise **local** status and all its emitters. Consider using {!Property_status.Consolidation.get} if you want to know the consolidated status of the property. *) val iter_on_statuses: (emitter_with_properties -> emitted_status -> unit) -> Property.t -> unit val fold_on_statuses: (emitter_with_properties -> emitted_status -> 'a -> 'a) -> Property.t -> 'a -> 'a (** Iteration on all the individual statuses emitted for the given property. @since Aluminium-20160501 *) (* ************************************************************************ *) (** {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 verify 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 val pretty: Format.formatter -> t -> unit 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 register_property_add_hook: (Property.t -> unit) -> unit (** add an hook that will be called for any newly registered property @since Neon-20140301 *) val remove: Property.t -> unit (** Remove the property deeply. Must be called only when removing the corresponding annotation. *) val register_property_remove_hook: (Property.t -> unit) -> unit (** Add and hook that will be called each time a property is removed. @since Neon-20140301 *) 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-Phosphorus-20170501/src/kernel_services/ast_data/kernel_function.mli0000644000175000017500000002171313113745003026012 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 and module Set = Cil_datatype.Kf.Set and module Map = Cil_datatype.Kf.Map and module Hashtbl = Cil_datatype.Kf.Hashtbl 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 the kernel function is only a prototype. @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 [s2] is not a successor of [s1] in the cfg. @since Carbon-20101201 *) val blocks_opened_by_edge: stmt -> stmt -> block list (** [blocks_opened_by_edge s1 s2] returns the (possibly empty) list of blocks that are opened when going from [s1] to [s2]. @raise Invalid_argument if [s2] is not a successor of [s1] in the cfg. @since Magnesium-20151001 *) 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 is_entry_point: t -> bool (** @return true iff the given function is the main of the program (as stated by option -main). @since Sodium-20150201 *) 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 (** For functions with a declaration and a definition, returns the definition.*) 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 = kernel_function and type 'a shape = 'a Hptmap.Shape(Cil_datatype.Kf).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). *) val self: State.t (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_data/property_status.ml0000644000175000017500000015410213113745010025740 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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} *) (**************************************************************************) let dkey = Kernel.register_category "property_status" let dkey_graph = Kernel.register_category "property_status:graph" 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.t_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@ @[(tried by %a)@]@]" Emitted_status.pretty s pp_emitters l | 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_on_statuses f ip = try let h = Status.find ip in Emitter_with_properties.Hashtbl.iter f h with Not_found -> () let fold_on_statuses f ip acc = try let h = Status.find ip in Emitter_with_properties.Hashtbl.fold f h acc with Not_found -> acc 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 (* property --> properties and emitters which use it as hypothesis *) 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 properties 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) module Valid_cycles : sig val add: Emitter.t -> Property.Set.t -> unit val _mem: Usable_emitter.t -> Property.t list -> bool val self: State.t 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 self = S.self 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 (* Those are the states that go together with the statuses themselves. In particular, they must not be cleared unless {!self} is. *) let linked_to_self = State_selection.(of_list [Hypotheses.self; Valid_cycles.self]) (**************************************************************************) (** {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 (* [strengthen 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 strengthen 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 module Register_hook = Hook.Build (struct type t = Property.t end) let register_property_add_hook = Register_hook.extend let rec register ppt = Kernel.debug ~dkey ~level:5 "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_hook.apply ppt; 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, active, b) -> let active = Datatype.String.Set.elements active in (* logical consequence of its postconditions *) logical_consequence Emitter.kernel ppt (Property.ip_post_cond_of_behavior kf ki active 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_plain_string () (* 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 _ | Property.IPPropertyInstance _ | Property.IPTypeInvariant _ | Property.IPGlobalInvariant _ -> () (* 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_plain_string () | 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 _ | Property.IPPropertyInstance _ | Property.IPTypeInvariant _ | Property.IPGlobalInvariant _ -> false and unsafe_emit_and_get e ~hyps ~auto ppt ?(distinct=false) s = Kernel.feedback ~dkey ~level:3 "@[%a emits status@ %a for property@ %a@ \ under %d hypothesis@]" Emitter.pretty e Emitted_status.pretty s Property.pretty ppt (List.length hyps); try let by_emitter = Status.find ppt in let emitter = { emitter = Emitter.get e; properties = hyps; logical_consequence = auto } in let emit s = (* first remove from the hypotheses table, each binding [(previous hypothesis of e, ppt)]. These hypotheses are stored together with the associated emitter as a key of [by_emitter]. Since there is no way to get a key [k'] of an hashtable which is equal to [k] for the hashtable equality, we have to iterate over the [by_emitter] table to find it. Hopefully the number of emitters by property is low. *) (try Emitter_with_properties.Hashtbl.iter (fun e' _ -> if Usable_emitter.equal (Emitter.get e) e'.emitter then begin (* the status [Dont_know] is unused by the call below *) Status.apply_hooks_on_remove e' ppt Dont_know; raise Exit end) by_emitter with Exit -> ()); (* then, clear the dependencies (but not the related internal states, see MR #496) *) let selection = State_selection.only_dependencies Status.self in let selection = State_selection.diff selection linked_to_self in Project.clear ~selection (); (* finally, replace the old emitter by the new one *) let add e s = Emitter_with_properties.Hashtbl.replace 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 _ | Property.IPPropertyInstance _ -> 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 _ | Property.IPTypeInvariant _ | Property.IPGlobalInvariant _ -> 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 = begin 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 _ | Property.IPPropertyInstance _ | Property.IPTypeInvariant _ | Property.IPGlobalInvariant _ -> () end; 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 hypothesis 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 -> () module Remove_hook = Hook.Build(struct type t = Property.t end) let register_property_remove_hook = Remove_hook.extend let remove ppt = Kernel.debug ~dkey ~level:5 "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; Remove_hook.apply ppt let merge ~old l = let property_id fmt p = Format.fprintf fmt "%a(%d)" Property.pretty p (Property.hash p) in (*Kernel.feedback ~dkey "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 -> if not (Status.mem p) then Kernel.fatal "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 ~dkey "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 ~dkey "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 ~dkey "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 -> (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 | Dont_know), _) | Inconsistent _ -> false let rec compute_automatic_status _e properties = let local_get p = let status = get_status p in let emitted_status = match status with | Never_tried | Inconsistent _ -> Dont_know | Best(s, _) -> s in if is_not_verifiable_but_valid p status then True else emitted_status 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 strengthen 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 _ | Property.IPPropertyInstance _ -> 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 _ | Property.IPTypeInvariant _ | Property.IPGlobalInvariant _ -> 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 (**************************************************************************) (** {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@ @[(tried by %a)@]@]" Emitted_status.pretty Emitted.Dont_know (pp_emitters Usable_emitter.pretty) l | 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 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.singleton usable_kernel_emitter v 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 (* 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 (Usable_emitter.Map.singleton e issues) | Never_tried, Unknown _ -> Unknown (Usable_emitter.Map.singleton 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 (Usable_emitter.Map.singleton 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 Format.asprintf "@[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 Format.asprintf "@[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.singleton e (Property.Set.singleton ppt) 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.singleton usable_kernel_emitter (Property.Set.singleton ppt) 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 (Format.asprintf "%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 (* convert a local status into a consolidated one, but ignore hypotheses *) let consolidate_of_local_when_cycle ppt = match get_status ~must_register:false ppt with | Local.Never_tried -> Never_tried | Best(True, _) -> Considered_valid | Best((False_if_reachable | False_and_reachable), _) -> (* no cycle is possible *) Kernel.fatal "invalid cycle for invalid property %a" Property.pretty ppt | Best(Dont_know, _) | Local.Inconsistent _ -> Unknown (Emitter.Usable_emitter.Map.singleton usable_kernel_emitter (Emitter.Usable_emitter.Map.singleton usable_kernel_emitter (Property.Set.singleton ppt))) let consolidate_reachable ppt = match ppt with | Property.IPReachable _ -> () | _ -> 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 ~dkey "status of hypotheses of %a: %a" Property.pretty ppt pretty status;*) let s = merge_hypotheses_and_local_status ppt status local in (* Kernel.feedback ~dkey "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 consolidate_of_local_when_cycle ppt (* [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 consolidate_of_local_when_cycle ppt 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 ~dkey "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 ~dkey "status of hypotheses for emitter `%a': %a" Usable_emitter.pretty e.emitter pretty s; Kernel.feedback ~dkey "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 pretty fmt = function | Never_tried -> Format.fprintf fmt "Never_tried" | Considered_valid -> Format.fprintf fmt "Considered_valid" | Valid -> Format.fprintf fmt "Valid" | Valid_under_hyp -> Format.fprintf fmt "Valid_under_hyp" | Unknown -> Format.fprintf fmt "Unknown" | Invalid -> Format.fprintf fmt "Invalid" | Invalid_under_hyp -> Format.fprintf fmt "Invalid_under_hyp" | Invalid_but_dead -> Format.fprintf fmt "Invalid_but_dead" | Valid_but_dead -> Format.fprintf fmt "Valid_but_dead" | Unknown_but_dead -> Format.fprintf fmt "Unknown_but_dead" | Inconsistent -> Format.fprintf fmt "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 Graph_by_property = State_builder.Hashtbl (Property.Hashtbl) (Datatype.Pair (Datatype.Make (struct type t = G.t let name = "consolidation graph" let reprs = [ G.empty ] include Datatype.Serializable_undefined end)) (Datatype.Bool) (* is the graph truncated? *)) (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 = Format.asprintf "%t" (fun fmt -> Usable_emitter.pretty_parameter fmt ~tuning e s) let already_done = Property.Hashtbl.create 17 let rec get ppt = let compute ppt = Kernel.debug ~dkey:dkey_graph "BUILDING GRAPH of %a" Property.pretty 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, true else begin Kernel.debug ~dkey:dkey_graph "MARK %a" Property.pretty ppt; 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, false | Best(s, emitters) -> get_emitters g v_ppt s emitters | Inconsistent i -> let g, truncated1 = get_emitters g v_ppt True i.valid in let g, truncated2 = get_emitters g v_ppt False_and_reachable i.invalid in g, truncated1 || truncated2 end in let change (_, truncated as data) = if truncated then compute ppt else data in Graph_by_property.memo ~change compute ppt and get_emitters g v_ppt s l = assert (l <> []); List.fold_left (fun (g, b) 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 Kernel.debug ~dkey:dkey_graph "%a --> %a (%a)" Property.pretty (match v_ppt with Property p -> p | _ -> assert false) Usable_emitter.pretty emitter Emitted_status.pretty s; 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 (Correctness_parameter s); g) (distinct_correctness_parameters emitter) g in*) (* adding the hypotheses *) let g, truncated = List.fold_left (fun (g, b) h -> let g', truncated = 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), b || truncated) (g, false) e.properties in g, b || truncated) (g, false) l let get ppt = Kernel.debug ~dkey:dkey_graph "GET %a" Property.pretty ppt; let g, truncated = get ppt in if truncated then Graph_by_property.replace ppt (g, false); 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 Format.asprintf "\"%s\"" s let label v = let s = match v with | Property p -> Format.asprintf "%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-Phosphorus-20170501/src/kernel_services/ast_data/cil_types.mli0000644000175000017500000023425613113745012024630 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 launching 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 preceded 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 varinfo * location (** A variable declaration (not a definition) for a variable with object type. 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. Either has storage Extern or there must be a definition in this file *) | GFunDecl of funspec * varinfo * location (** A variable declaration (not a definition) for a function, i.e. a prototype. There can be several declarations and at most one definition for a given function. 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 preceded 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 precedes 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 precedes 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; (** (Deprecated. Use {!Cil.bitsOffset} instead.) Similar to [fbitfield] for all types of fields. @deprecated only Jessie uses this *) mutable foffset_in_bits: int option; (** Offset at which the field starts in the structure. Do not read directly, but use {!Cil.bitsOffset} instead. *) mutable fpadding_in_bits: int option; (** (Deprecated.) 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 referred 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], [GFunDecl] 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; (** - For global variables, true iff the variable or function is defined in the file. - For local variables, true iff the variable is explicitely initialized at declaration time. - Unused for formals 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]. *) vtemp: bool; (** [true] for temporary variables generated by CIL normalization. [false] for all the other variables. *) 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 *) vsource: bool; (** [true] iff this variable appears in the source of the program, which is the case of all the variables in the initial AST. Plugins may create variables with [vsource=false], for example to handle dynamic allocation. Those variables do *not* have an associated {!GVar} or {!GVarDecl}. *) mutable vlogic_var_assoc: logic_var option (** Logic variable representing this variable in the logic world. Do not access this field directly. Instead, call {!Cil.cvar_to_lvar}. *) } (** 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 } (** kind of constructor for initializing a local variable through a function call. @since Phosphorus-20170501-beta1. *) and constructor_kind = | Plain_func (** plain function call, whose result is used for initializing the variable. *) | Constructor (** C++-like constructor: the function takes as first argument the address of the variable to be initialized, and returns [void]. *) (** Initializers for local variables. @since Phosphorus-20170501-beta1 *) and local_init = | AssignInit of init (** normal initialization *) | ConsInit of varinfo * exp list * constructor_kind (** [ConsInit(f,args,kind)] indicates that the corresponding local is initialized via a call to [f], of kind [kind] with the given [args]. *) (* ************************************************************************* *) (** {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. @plugin development guide *) 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. In addition, blocks are used to determine the scope of variables, through the blocals field. Variables in [blocals] that have their [vdefined] field set to [true] must appear as the target of a [Local_init] instruction directly in the [bstmts], with two exceptions: the [Local_init] instruction can be part of an [UnspecifiedSequence], or of a block that has [bscoping] set to [false]. Such block _must not_ itself have local variables: it denotes a simple list of statements grouped together (e.g. to stay in scope of an annotation extending to the whole list). *) and block = { mutable battrs: attributes; (** Attributes for the block *) mutable bscoping: bool; (** Whether the block is used to determine the scope of local variables. *) 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. @plugin development guide *) | Return of exp option * location (** The return statement. This is a leaf in the CFG. @plugin development guide *) | 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. @plugin development guide *) | Break of location (** A break to the end of the nearest enclosing Loop or Switch. @plugin development guide *) | Continue of location (** A continue to the start of the nearest enclosing [Loop]. @plugin development guide *) | If of exp * block * block * location (** A conditional. Two successors, the "then" and the "else" branches (in this order). Both branches fall-through to the successor of the If statement. @plugin development guide *) | 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. @plugin development guide *) | 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. @plugin development guide *) | Block of block (** Just a block of statements. Use it as a way to keep some block attributes local. @plugin development guide *) | 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, in this order. - lvals that are written during the sequence and whose future value depends upon the statement (it is legal to read from them, but not to write to 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}). @plugin development guide *) | Throw of (exp * typ) option * location (** Throws an exception, C++ style. We keep the type of the expression, to match it against the appropriate catch clause. A Throw node has no successor, even if it is in try-catch block that will catch the exception: we keep normal and exceptional control-flow completely separate, as in Jo and Chang, ICSSA 2004. *) | TryCatch of block * (catch_binder * block) list * location | 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. @plugin development guide *) | 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. @plugin development guide *) (** Kind of exceptions that are caught by a given clause. *) and catch_binder = | Catch_exn of varinfo * (varinfo * block) list (** catch exception of given type(s). If the list is empty, only exceptions with the same type as the varinfo can be caught. If the list is non-empty, only exceptions matching one of the type of a varinfo in the list are caught. The associated block contains the operations necessary to transform the matched varinfo into the principal one. Semantics is by value (i.e. the varinfo is bound to a copy of the caught object). This clause is a declaration point for the varinfo(s) mentioned in it. More precisely, for [Catch_exn(v_0,[(v_1, b_1),..., (v_n, b_n)])], the [v_i] must be referenced in the [slocals] of the enclosing [fundec], and _must not_ appear in any [blocals] of some block. The scope of v_0 is all the [b_i] and the corresponding block in the [catch_binder * block list] of the [TryCatch] node the binder belongs to. The scope of the other [v_i] is the corresponding [b_i]. *) | Catch_all (** default catch clause: all exceptions are caught. *) (** 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. *) | Local_init of varinfo * local_init * location (** initialization of a local variable. The corresponding varinfo must belong to the [blocals] list of the innermost enclosing block that does not have attribute {!Cil.block_no_scope_attr}. Such blocks are purely here for grouping statements and do not play a role for scoping variables. See {!Cil_types.block} definition for more information @since Phosphorus-20170501-beta1 *) (* 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) *) * extended_asm option * 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) GCC extended asm information if any (4) location information *) | Skip of location | Code_annot of code_annotation * location (** GNU extended-asm information: - a list of outputs, each of which is an lvalue with optional names and constraints. - a list of input expressions along with constraints - clobbered registers - Possible destinations statements *) and extended_asm = { asm_outputs: (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 *); asm_inputs: (string option * string * exp) list (** inputs with optional names and constraints *); asm_clobbers: string list (** register clobbers *); asm_gotos: (stmt ref) list (** list of statements this asm section may jump to. Destination must have a label. *); } (** 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. A name can be an arbitrary string, where '"' and '\'' are escaped by a \, and which does not end with a \. Hence, "name" and 'name' should be recognized as a unique label by most tools. *) } (** 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 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. *) mutable mi_attr: attributes; (** attributes tied to the field. @since Phosphorus-20170501-beta1 *) } (** 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 (** direct definition of a predicate. *) | LBinductive of (string * logic_label list * string list * predicate) 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. *) mutable lt_attr: attributes; (** attributes associated to the logic type. @since Phosphorus-20170501-beta1 *) } (* 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 or \lambda abstraction *) | LVQuant (** Bound by a quantifier (\exists or \forall) *) | 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. *) mutable lv_attr: attributes (** attributes tied to the logic variable @since Phosphorus-20170501-beta1 *) } (** 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_node = | 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 * predicate (** conjunction *) | Por of predicate * predicate (** disjunction. *) | Pxor of predicate * predicate (** logical xor. *) | Pimplies of predicate * predicate (** implication. *) | Piff of predicate * predicate (** equivalence. *) | Pnot of predicate (** negation. *) | Pif of term * predicate * predicate (** conditional *) | Plet of logic_info * predicate (** definition of a local variable *) | Pforall of quantifiers * predicate (** universal quantification. *) | Pexists of quantifiers * predicate (** existential quantification. *) | Pat of predicate * 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_function of term (** the pointed function has a type compatible with the one of pointer. *) | Pinitialized of logic_label * term (** the given locations are initialized. *) | Pdangling of logic_label * term (** the given locations contain dangling addresses. *) | 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_id: int; (** identifier *) ip_content: predicate; (** the predicate itself*) } (** predicates with a location and an optional list of names *) and predicate = { pred_name : string list; (** list of given names *) pred_loc : location; (** position in the source code. *) pred_content : predicate_node;(** content *) } (* 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. *) (** Function or statement contract. This type shares the name of its constructors with {!Logic_ptree.spec}. *) and spec = { mutable spec_behavior : behavior list; (** behaviors *) mutable spec_variant : term variant option; (** variant for recursive functions. *) mutable spec_terminates: identified_predicate 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 *) } (** extension to standard ACSL clause. Each extension is associated to a keyword. An extension can be registered through the following functions: - {!Logic_typing.register_behavior_extension} for parsing and type-checking - {!Cil_printer.register_behavior_extension} for pretty-printing an extended clause - {!Cil.register_behavior_extension} for visiting an extended clause @plugin development guide *) and acsl_extension = string * acsl_extension_kind (** @plugin development guide *) and acsl_extension_kind = | Ext_id of int (** id used internally by the extension itself. *) | Ext_terms of term list | Ext_preds of predicate list (** a list of predicates, the most common case of for extensions *) (** Behavior of a function or statement. This type shares the name of its constructors with {!Logic_ptree.behavior}. @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 behavior = { mutable b_name : string; (** name of the behavior. *) mutable b_requires : identified_predicate list; (** require clauses. *) mutable b_assumes : identified_predicate list; (** assume clauses. *) mutable b_post_cond : (termination_kind * identified_predicate) list (** post-condition. *); mutable b_assigns : identified_term assigns; (** assignments. *) mutable b_allocation : identified_term allocation; (** frees, allocates. *) mutable b_extended : acsl_extension list (** extensions @plugin development guide *) } (** 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. This type shares the name of its constructors with {!Logic_ptree.code_annot}. *) and code_annotation_node = | AAssert of string list * predicate (** assertion to be checked. The list of strings is the list of behaviors to which this assertion applies. *) | AStmtSpec of string list * spec (** statement contract (potentially restricted to some enclosing behaviors). *) | AInvariant of string list * bool * predicate (** 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 * identified_term 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 * identified_term 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. *) | AExtended of string list * acsl_extension (** extension in a loop annotation. @since Silicon-20161101 *) (** function contract. *) and funspec = 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 : code_annotation_node; (** content of the annotation. *) } (** behavior of a function. *) and funbehavior = 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 * attributes * location (** associated terms, reading function, writing function *) | Daxiomatic of string * global_annotation list * attributes * location | Dtype of logic_type_info * location (** declaration of a logic type. *) | Dlemma of string * bool * logic_label list * string list * predicate * attributes * 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 * attributes * 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 []]). *) (** Only field [fundec] can be used directly. Use {!Annotations.funspec}, [Annotations.add_*] and [Annotations.remove_*] to query or modify field [spec]. *) type kernel_function = { mutable fundec : cil_function; 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 (** Definition of a machine model (architecture + compiler). @plugin development guide *) type mach = { 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 *) underscore_name: bool; (* If assembly names have leading underscore *) 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 *); compiler: string; (* Compiler being used. Currently recognized names are 'gcc', 'msvc' and 'generic'. *) cpp_arch_flags: string list; (* Architecture-specific flags to be given to the preprocessor (if supported) *) version: string; (* Information on this machdep *) } (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/ast_data/alarms.mli0000644000175000017500000001364613113745002024111 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. *) 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 | Differing_blocks of exp * exp (** The two expressions (which evaluate to pointers) must point to the same allocated block *) | 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 | Dangling of lval | Is_nan_or_infinite of exp * fkind | Valid_string of exp | Function_pointer of exp (** the type of the pointer is compatible with the type of the pointed function. *) 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 -> alarm -> code_annotation * bool (** Register the given alarm on the given statement. By default, no status is emitted. [kf] must be given only if the [kinstr] is a statement, and must be the function enclosing this statement. @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 @modify Aluminium-20160501 removed argument save. Use {!to_annot} instead. *) val to_annot: kinstr -> ?loc:location -> alarm -> code_annotation * bool (** Conversion of an alarm to a [code_annotation], without any registration. The returned boolean indicates that the alarm has not been registered in the kernel yet. *) 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 (** Generate the predicate corresponding to a given alarm. @since Fluorine-20130401 *) val get_name: t -> string (** Short name of the alarm, used to prefix the assertion in the AST. *) val get_short_name: t -> string (** Even shorter name. Similar alarms (e.g. signed overflow vs. unsigned overflow) are aggregated. *) val get_description: t -> string (** Long description of the alarm, explaining the UB it guards against. *) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/visitors/0000755000175000017500000000000013113745010022216 5ustar mehdimehdiframa-c-Phosphorus-20170501/src/kernel_services/visitors/visitor.ml0000644000175000017500000011135213113745002024253 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 let dkey = Kernel.register_category "visitor" (* ************************************************************************* *) (** {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 orig_stmt = Cil.get_original_stmt self#behavior stmt in let annots = Annotations.fold_code_annot (fun e a acc -> (e, a) :: acc) orig_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 annots = List.sort (fun (_,a) (_,b) -> Cil_datatype.Code_annotation.compare a b) annots in let make_children_annot vis = let add, remove = List.fold_left (fun (add, remove) (e, x) -> let y = visitCilCodeAnnotation (vis:>cilVisitor) x in (* Given x, we compute whether it must be removed from the destination project, and whether we should add its copy y, again in the destination project. *) let is_trivial = Logic_utils.is_trivial_annotation in (* we keep [y] only if it is non-trivial (non-\true), except if [x] is already trivial itself. *) let becomes_trivial = is_trivial y && not (is_trivial x) in let curr_add, remove_curr = if Cil.is_copy_behavior vis#behavior then (* Copy visitor. We add [y], except if trivial. No sense in removing [x], since the stmt is a new one. *) (if not becomes_trivial then [e, y] else []), false else (* Inplace visitor. We remove [x] if it becomes trivial, or if it has changed (because we need to add it back with the new content). We re-add [y] if [x] has changed and has not became trivial. Do not always remove then re-add, as this would mess up property statuses. *) (if x != y && not becomes_trivial then [e, y] else []), (x != y || becomes_trivial) in (add @ curr_add, if remove_curr then (e, x) :: remove else remove) ) ([],[]) annots in (add, remove) in let change_stmt stmt (add, remove) = if (add <> [] || 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 () -> List.iter (fun (e, a) -> Annotations.remove_code_annot e ~kf:new_kf stmt a) remove; List.iter (fun (e, a) -> Annotations.add_code_annot e ~kf:new_kf stmt a) add) self#get_filling_actions end in let post_action f stmt = let (add, _ as new_annots) = make_children_annot self in let stmt = f stmt in (match stmt.skind with | Block b when annots <> [] || add <> [] -> stmt.skind <- Block (Cil.block_of_transient b) | _ -> ()); change_stmt stmt new_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 old_extended = fold_elt Annotations.fold_extended in let b' = if Cil.is_copy_behavior self#behavior then { b with b_name = b.b_name } else b 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 behavior r -> Annotations.add_requires e kf ~behavior [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 behavior a -> Annotations.add_assumes e kf ~behavior [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 behavior p -> Annotations.add_ensures e kf ~behavior [p]) (fun x l -> x :: l) [] in b'.b_post_cond <- ensures; let add_assigns e kf behavior a = match a with | WritesAny -> () | _ -> Annotations.add_assigns ~keep_empty:false e kf ~behavior 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 (fun e kf behavior a -> Annotations.add_allocates e kf ~behavior a) concat_allocation FreeAllocAny in b'.b_allocation <- a; let ext = fold_elt { Fold.apply = Annotations.fold_extended } Cil.visitCilExtended Annotations.remove_extended (fun e kf behavior ex -> Annotations.add_extended e kf ~behavior ex) (fun x y -> x::y) [] in b'.b_extended <- ext; 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 behavior r -> Annotations.add_requires e kf ~behavior [r]) Annotations.fold_requires old_requires b'; remove_and_add (fun b -> b.b_assumes) Annotations.remove_assumes (fun e kf behavior r -> Annotations.add_assumes e kf ~behavior [r]) Annotations.fold_assumes old_assumes b'; remove_and_add (fun b -> b.b_post_cond) Annotations.remove_ensures (fun e kf behavior r -> Annotations.add_ensures e kf ~behavior [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 behavior a -> match a with | WritesAny -> () | Writes _ -> Annotations.add_assigns ~keep_empty:false e kf ~behavior a) Annotations.fold_assigns old_assigns b'; remove_and_add (fun b -> match b.b_allocation with FreeAllocAny -> [] | a -> [a]) Annotations.remove_allocates (fun e kf behavior a -> Annotations.add_allocates e kf ~behavior a) Annotations.fold_allocates old_allocates b'; remove_and_add (fun b -> b.b_extended) Annotations.remove_extended (fun e kf behavior ex -> Annotations.add_extended e kf ~behavior ex) Annotations.fold_extended old_extended 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 | GFunDecl(_,v,_) -> let ov = Cil.get_original_varinfo self#behavior v in let kf = try Globals.Functions.get ov 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 find 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 | GFunDecl _ | GFun _ when Ast.is_def_or_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 correspondence between annotations and emitters. *) let get_spec () = match g with | GFun _ | GFunDecl _ when Ast.is_def_or_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 | GFunDecl(_,v,l) -> (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 ~dkey "@[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 (post_action $ f) | 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, post_change_to $ f) | 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_refresh prj = generic_frama_c_visitor (refresh_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 = let orig_var = Cil.get_original_varinfo vis#behavior f.svar in let old_current_kf = vis#current_kf in vis#set_current_kf (Globals.Functions.get orig_var); let f' = visitCilFunction (vis:>cilVisitor) f in vis#reset_current_kf (); Extlib.may vis#set_current_kf old_current_kf; vis#fill_global_tables; f' let visitFramacKf vis kf = let glob = Ast.def_or_last_decl (Kernel_function.get_vi kf) in ignore (visitFramacGlobal vis glob); match vis#project with | None -> kf | Some prj -> let vi = Kernel_function.get_vi kf in let vi' = Cil.get_varinfo vis#behavior vi in Project.on prj Globals.Functions.get vi' 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 visitFramacLogicVarDecl vis v = let v' = visitCilLogicVarDecl (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 visitFramacAllocation vis a = let a' = visitCilAllocation (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 visitFramacPredicateNode vis p = let p' = visitCilPredicateNode (vis:>cilVisitor) p in vis#fill_global_tables; p' let visitFramacPredicate vis p = let p' = visitCilPredicate (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' let visitFramacExtended vis e = let e'= visitCilExtended (vis:>cilVisitor) e in vis#fill_global_tables; e' (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/visitors/cabsvisit.ml0000644000175000017500000005344313113745002024551 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; alabels = labels } -> 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 ; alabels = labels } 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 | THROW (e,l) -> let e' = optMapNoCopy (visitCabsExpression vis) e in if e != e' then { s with stmt_node = THROW(e',l) } else s | TRY_CATCH(t,l,loc) -> let visit_one_catch (v,s as c) = let v' = optMapNoCopy (childrenSingleName vis NVar) v in let s' = vs loc s in if v' != v || s' != s then (v,s) else c in let t' = vs loc t in let l' = mapNoCopy visit_one_catch l in if t' != t || l' != l then { s with stmt_node = TRY_CATCH(t',l',loc) } 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-Phosphorus-20170501/src/kernel_services/visitors/visitor.mli0000644000175000017500000002231013113745010024416 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 visitors dealing with projects. *) open Cil_types (** 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 frama_c_refresh: Project.t -> frama_c_visitor (** Similar to {!frama_c_copy}, but ids will be refreshed in the copy. @since Sodium-20150201 *) 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 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. {b Warning} Do not call this function during another visit using the same visitor, as it is not reentrant: the inner visit will leave the visitor in an inconsistent state for the outer visit. *) val visitFramacGlobal: frama_c_visitor -> global -> global list (** Visit a kernel_function. More precisely, the entry point for the visit will be the global corresponding to the last declaration/definition of the kf. The returned kf is the one that has the varinfo associated to the varinfo of the original kf. If this is a new kf, it is however the responsibility of the visitor to insert it in the AST at the appropriate place. @since Aluminium-20160501 *) val visitFramacKf: frama_c_visitor -> Kernel_function.t -> Kernel_function.t (** 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 a logic variable declaration @since Magnesium-20151001 *) val visitFramacLogicVarDecl: frama_c_visitor -> logic_var -> logic_var (** 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 visitFramacAllocation: frama_c_visitor -> identified_term allocation -> identified_term allocation 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 visitFramacPredicateNode: frama_c_visitor -> predicate_node -> predicate_node val visitFramacPredicate: frama_c_visitor -> predicate -> predicate 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 val visitFramacExtended: frama_c_visitor -> acsl_extension -> acsl_extension (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/visitors/cabsvisit.mli0000644000175000017500000001356013113745010024715 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 in a * 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-Phosphorus-20170501/src/kernel_services/parsetree/0000755000175000017500000000000013113745010022326 5ustar mehdimehdiframa-c-Phosphorus-20170501/src/kernel_services/parsetree/cabs.ml0000644000175000017500000003464213113745001023601 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). *) (****************************************************************************) (** Untyped AST. @plugin development guide **) (* ** 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. @plugin development guide *) 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 *) alabels: string list (* the labels for "asm goto" statements in gcc >= 4.6 *) } 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 (* Exception mechanism *) | THROW of expression option * cabsloc (** throws the corresponding expression. [None] corresponds to re-throwing the exception currently being caught (thus is only meaningful in a catch clause). This node is not generated by the C parser, but can be used by external front-ends. *) | TRY_CATCH of statement * (single_name option * statement) list * cabsloc (** [TRY_CATCH(s,clauses,loc)] catches exceptions thrown by execution of [s], according to [clauses]. An exception [e] is caught by the first clause [(spec,(name, decl, _, _)),body] such that the type of [e] is compatible with [(spec,decl)]. [name] is then associated to a copy of [e], and [body] is executed. If the [single_name] is [None], all exceptions are caught by the corresponding clause. The corresponding [TryCatch] node in {!Cil_types.stmtkind} has a refined notion of catching that allows a clause to match for more than one type using appropriate conversions (see also {!Cil_types.catch_binder}). This node is not generated by the C parser, but can be used by external front-ends. *) (** 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 representation *) | 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: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/parsetree/cabshelper.mli0000644000175000017500000001152613113745003025150 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 val getident : unit -> int 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 (* hack to avoid shift/reduce conflict is attr parsing. *) val push_attr_test: unit -> unit val pop_attr_test: unit -> unit val is_attr_test: unit -> bool val mk_behavior : ?name:string -> ?assumes:Logic_ptree.lexpr list -> ?requires:Logic_ptree.lexpr list -> ?post_cond:(Cil_types.termination_kind * Logic_ptree.lexpr) list -> ?assigns:Logic_ptree.lexpr Cil_types.assigns -> ?allocation:Logic_ptree.lexpr Cil_types.allocation -> ?extended:Logic_ptree.extension list -> unit -> Logic_ptree.behavior frama-c-Phosphorus-20170501/src/kernel_services/parsetree/cabshelper.ml0000644000175000017500000002135113113745001024772 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 dkey = Kernel.register_category "comments" let nextident = ref 0 let getident () = nextident := !nextident + 1; !nextident let cabslu = Lexing.dummy_pos,Lexing.dummy_pos 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 let () = Cil.dependency_on_ast 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 ~dkey "Searching for comments between positions %a and %a@." Cil_datatype.Position.pretty first Cil_datatype.Position.pretty last; if Cil_datatype.Position.equal first Lexing.dummy_pos || Cil_datatype.Position.equal last Lexing.dummy_pos then begin Kernel.debug ~dkey "skipping dummy position@."; [] end else let r = 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 ()) [] in Kernel.debug ~dkey "%d results@." (List.length r); r 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 | THROW(_,l) -> l | TRY_CATCH(_,_,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 type attr_test = Normal | Test let state_stack = Stack.create () let () = Stack.push Normal state_stack let push_attr_test () = Stack.push Test state_stack let pop_attr_test () = ignore (Stack.pop state_stack) let is_attr_test () = Stack.top state_stack = Test let mk_behavior ?(name=Cil.default_behavior_name) ?(assumes=[]) ?(requires=[]) ?(post_cond=[]) ?(assigns=Cil_types.WritesAny) ?(allocation=Cil_types.FreeAllocAny) ?(extended=[]) () = { Logic_ptree.b_name = name; b_assumes = assumes; (* must be always empty for default_behavior_name *) b_requires = requires; b_assigns = assigns ; b_allocation = allocation ; b_post_cond = post_cond ; b_extended = extended; } (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/parsetree/logic_ptree.mli0000644000175000017500000003705013113745010025332 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* 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 *) (** 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 Cil_types.ikind (** C integral type.*) | LTfloat of Cil_types.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 | LTattribute of logic_type * Cil_types.attribute (* Only const and volatile can appear here *) type location = Cil_types.location (** 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. *) | PLvalid_function of lexpr (** function pointer is compatible with pointed type. *) | 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 (** pointer is guaranteed to be initialized *) | PLdangling of string option * lexpr (** pointer is guaranteed to be dangling *) | 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)\}})*) | PLset of lexpr list (** sets of elements. *) | PLunion of lexpr list (** union of sets. *) | PLinter of lexpr list (** intersection of sets. *) | PLempty (** empty set. *) | PLlist of lexpr list (** list of elements. *) | PLrepeat of lexpr * lexpr (** repeat a list of elements a number of times. *) (** 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. *) type extension = string * lexpr list (** Behavior in a specification. This type shares the name of its constructors with {!Cil_types.behavior}. *) type behavior = { mutable b_name : string; (** name of the behavior. *) mutable b_requires : lexpr list; (** require clauses. *) mutable b_assumes : lexpr list; (** assume clauses. *) mutable b_post_cond : (Cil_types.termination_kind * lexpr) list; (** post-condition. *) mutable b_assigns : lexpr Cil_types.assigns; (** assignments. *) mutable b_allocation : lexpr Cil_types.allocation; (** frees, allocates. *) mutable b_extended : extension list (** extensions *) } (** Function or statement contract. This type shares the name of its constructors with {!Cil_types.spec}. *) type spec = { mutable spec_behavior : behavior list; (** behaviors *) mutable spec_variant : lexpr Cil_types.variant option; (** variant for recursive functions. *) mutable spec_terminates: lexpr 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 *) } (** all annotations that can be found in the code. This type shares the name of its constructors with {!Cil_types.code_annotation_node}. *) type code_annot = | AAssert of string list * lexpr (** assertion to be checked. The list of strings is the list of behaviors to which this assertion applies. *) | AStmtSpec of string list * spec (** statement contract (potentially restricted to some enclosing behaviors). *) | AInvariant of string list * bool * lexpr (** 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 lexpr Cil_types.variant (** loop variant. Note that there can be at most one variant associated to a given statement *) | AAssigns of string list * lexpr Cil_types.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 * lexpr Cil_types.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 lexpr Cil_types.pragma (** pragma. *) | AExtended of string list * extension (** extension in a loop annotation. @since Silicon-20161101 *) (** 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 bool * string * lexpr (* lexpr contains a location *) | Ext_include of bool * string * location type ext_function = | Ext_spec of spec * location (* function spec *) | Ext_stmt of string list * annot * location (* loop/code annotation. *) | Ext_glob of ext_decl type ext_module = string option * ext_decl list * ((string * location) option * ext_function list) list type ext_spec = ext_module list (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/analysis/0000755000175000017500000000000013113745012022161 5ustar mehdimehdiframa-c-Phosphorus-20170501/src/kernel_services/analysis/undefined_sequence.ml0000644000175000017500000001555313113745011026354 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 (* Print a warning message when an undefined behavior may occurs in an unspecified sequence, i.e. two writes or a write and a read. See full doc in .mli. *) let check_sequences file = (* checks whether offsets starting from the same base might overlap *) let rec may_overlap_offset offs1 offs2 = match offs1, offs2 with | NoOffset,_ | _, NoOffset -> true | Field (f1,offs1), Field(f2,offs2) -> (* it's probably a bit overkill to check if any of the field is in an union, as the types of offs1 and offs2 are very probably identical, but I don't have a Coq proof of that fact at the moment. *) (not f1.fcomp.cstruct || not f2.fcomp.cstruct) || (f1.fname = f2.fname && f1.fcomp.ckey = f2.fcomp.ckey && may_overlap_offset offs1 offs2) | Index(i1,offs1), Index(i2,offs2) -> (match Cil.constFoldToInt i1, Cil.constFoldToInt i2 with | Some c1, Some c2 -> Integer.equal c1 c2 && may_overlap_offset offs1 offs2 | None, _ | _, None -> may_overlap_offset offs1 offs2 ) | (Index _|Field _), (Index _|Field _) -> (* A bit strange, but we're not immune against some ugly cast. Let's play safe here. *) true in (* checks whether two lval may overlap *) let may_overlap_lval (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 && may_overlap_offset offs1 offs2 in (* checks whether some element of the first list may overlap with some element of the second one. *) let may_overlap l1 l2 = Extlib.product_fold (fun f e1 e2 -> f || may_overlap_lval e1 e2) false l1 l2 in let check_unspec = object inherit Cil.nopCilVisitor method! vstmt s = (match s.skind with | UnspecifiedSequence [] | UnspecifiedSequence [ _ ] -> () | UnspecifiedSequence seq -> (* We have more than one side-effect in an unspecified sequence. For each statement, we check whether its side effects may overlap with the others, or with the reads. *) 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 (* when checking for overlaps, we do not consider temporaries introduced by the normalization. In other words, we assume that the normalization itself is correct. *) let remove_mod m l = List.filter (fun x -> not (List.exists (Cil_datatype.Lval.equal x) m)) l in (* l1 contains two lists: the first one is the temporaries we do not want to consider, the second one are locations that are read by a given statement. l2 contains locations that are written by another statement. *) let may_overlap_modified l1 l2 = List.fold_left (fun flag (m,r) -> flag || may_overlap (remove_mod m l2) r) false l1 in let warn,_,_ = List.fold_left (fun ((warn,writes,reads) as res) (_,m,w,r,_) -> (* the accumulator contains the lists of written and read locations from the previous statements. We check for overlapping between the following pairs: - w vs writes - r vs writes (modulo temporaries m as explained above). - reads vs w (id. ) As soon as we have identified a potential overlap, we output the whole unspecified sequence. *) if warn then res else begin let new_writes = w @ writes in let new_reads = (m,r)::reads in let new_warn = warn || may_overlap writes w || may_overlap (remove_mod m writes) r || may_overlap_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 | _ -> ()); Cil.DoChildren end in Cil.visitCilFileSameGlobals check_unspec file frama-c-Phosphorus-20170501/src/kernel_services/analysis/dataflow2.mli0000644000175000017500000002512213113745010024547 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 data flow analyses over user-supplied domains. *) 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 (** 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. Useful when {!t} is a mutable type. A copy of the data stored for a statement is made each time this statement is processed, just before {!doStmt} is called. *) val pretty: Format.formatter -> t -> unit (** Pretty-print the state. *) val computeFirstPredecessor: Cil_types.stmt -> t -> t (** [computeFirstPredecessor s d] is called when [s] is reached for the first time (i.e. no previous data is associated with it). The data [d] is propagated to [s] from an unspecified preceding statement [s']. The result of the call is stored as the new data for [s]. [computeFirstPredecessor] usually leaves [d] unchanged, but may potentially change it. It is also possible to perform a side-effect, for dataflows that store information out of the type [t]. *) val combinePredecessors: Cil_types.stmt -> old:t -> t -> t option (** Take some old data for the given statement, and some new data for the same point. Return None if the combination is identical to the old data, to signify that a fixpoint is currently reached for this statement. Otherwise, compute the combination, and return it. *) val doInstr: Cil_types.stmt -> Cil_types.instr -> t -> t (** The (forwards) transfer function for an instruction, internally called by {!doStmt} when the returned action is not {!SDone}. The current location is updated before this function is called. The argument of type [stmt] is the englobing statement. *) val doGuard: Cil_types.stmt -> Cil_types.exp -> t -> t guardaction * t guardaction (** Generate the successors [act_th, act_el] to an [If] statement. [act_th] (resp. [act_el]) corresponds to the case where the given expression evaluates to zero (resp. non-zero). It is always possible to return [GDefault, GDefault], especially for analyses that do not use guard information. This is equivalent to returning [GUse d, GUse d], where [d] is the input state. A return value of GUnreachable indicates that this half of the branch will not be taken and should not be explored. [stmt] is the corresponding [If] statement, passed as information 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 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 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) *) val compute_strategy: Cil_types.stmt list -> Wto_statement.wto -> unit (** Same as compute but using a given strategy, instead of the default strategy computed by the Wto module. *) val compute_worklist: Cil_types.stmt list -> unit (** Same as compute but using only a working list of statements instead of iterating on a weak topological ordering. *) 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 (** 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) *) 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 statements (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: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/analysis/stmts_graph.mli0000644000175000017500000001127113113745005025223 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. *) 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 trivial 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 *) (** [reachable_stmts kf stmt] returns the transitive closure of the successors of [stmt] in [kf]. The result is cached for later calls. @modify Silicon-20161101 return type changed to hptset *) val reachable_stmts: kernel_function -> stmt -> Stmt.Hptset.t (** 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 from outside the loop - the back edges. Notice that there might be nothing in the entry point when the loop is 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-Phosphorus-20170501/src/kernel_services/analysis/service_graph.ml0000644000175000017500000002731713113745005025350 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 type 'a vertex = { node: 'a; mutable is_root: bool; mutable root: 'a vertex } type edge = Inter_services | Inter_functions | Both module type S = sig type node type graph module Service_graph: sig include Graph.Sig.G with type V.t = node vertex and type E.label = edge module Datatype: Datatype.S with type t = t end val compute: graph -> Datatype.String.Set.t -> Service_graph.t val output_graph: out_channel -> Service_graph.t -> unit val entry_point: unit -> Service_graph.V.t option module TP: Graph.Graphviz.GraphWithDotAttrs with type t = Service_graph.t and type V.t = node vertex and type E.t = Service_graph.E.t end 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 graph = G.t type node = G.V.t module Vertex = struct type t = node 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 HVertex = Hashtbl.Make(G.V) module Edge = struct type t = edge let default = Inter_functions let compare : t -> t -> _ = Extlib.compare_basic end module Service_graph = 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.Service_graph.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 node vertex | Final of node vertex type service = Maybe_fresh of node vertex | In_service of node vertex module Vertices = struct let vertices : (node vertex * service) HVertex.t = HVertex.create 7 let find = HVertex.find vertices let add = HVertex.add vertices let replace = HVertex.replace vertices let clear () = HVertex.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 = Service_graph.iter_edges_e (fun e -> edge_invariant (Service_graph.E.src e) (Service_graph.E.dst e) (Service_graph.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); Service_graph.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 (* the original graph may contain several edges from [caller] to [callee] (one per callsite). We must visit them only once. Hence the table [visited].*) let visited = HVertex.create 7 in G.iter_vertex (fun node -> let v = find node in HVertex.reset visited; G.iter_succ (fun node' -> let succ = find node' in if not (HVertex.mem visited succ.node) then begin HVertex.add visited succ.node (); Service_graph.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 Service_graph.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 no-root vertex and going to another service. no need of a 'function_to_service' edge too since the only possible edges between two services go to a root. *) end end) g node) g let compute g initial_roots = entry_point_ref := None; let module Go = Graph.Topological.Make(G) in let callg = Service_graph.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 Service_graph 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 (Service_graph.E.src e) in [ `Color (Extlib.number_to_color sr) ] in if !inter_services_ref then color e else match Service_graph.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_parent = None; 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-Phosphorus-20170501/src/kernel_services/analysis/wto_statement.mli0000644000175000017500000000512013113745012025557 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** Specialization of WTO for the CIL statement graph. See the Wto module for more details *) open Cil_types (** A weak topological ordering where nodes are Cil statements *) type wto = stmt Wto.partition (** The datatype for statement WTOs *) module WTO : Datatype.S with type t = wto (** @return the computed wto for the given function *) val wto_of_kf : kernel_function -> wto (** the position of a statement in a wto given as the list of component heads *) type wto_index = stmt list (** Datatype for wto_index *) module WTOIndex : Datatype.S with type t = wto_index (** @return the wto_index for a statement *) val wto_index_of_stmt : stmt -> wto_index (** @return the components left and the components entered when going from one index to another *) val wto_index_diff : wto_index -> wto_index -> stmt list * stmt list (** @return the components left and the components entered when going from one stmt to another *) val wto_index_diff_of_stmt : stmt -> stmt -> stmt list * stmt list frama-c-Phosphorus-20170501/src/kernel_services/analysis/loop.mli0000644000175000017500000000407313113745001023637 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. *) open Cil_types val is_natural : kernel_function -> stmt -> bool val get_naturals : kernel_function -> stmt list Cil_datatype.Stmt.Map.t val is_non_natural: kernel_function -> stmt -> bool val get_non_naturals: kernel_function -> Cil_datatype.Stmt.Set.t val back_edges : kernel_function -> stmt -> stmt list (** Statements that are the origin of a back-edge to a natural loop. *) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/analysis/dominators.ml0000644000175000017500000002441613113745003024701 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 dominators. Based on "A Simple, Fast Dominance Algorithm" by K. D. Cooper et al. *) (* A domination tree, represented as a map from a statement to its immediate dominator. The first statement in a function, and statically unreachable statements (that do not have idoms), are mapped to None. *) module Dom_tree = State_builder.Hashtbl (Cil_datatype.Stmt.Hashtbl) (Datatype.Option(Cil_datatype.Stmt)) (struct let name = "dominators.dom_tree" let dependencies = [ Ast.self ] let size = 197 end) ;; (** Compute dominator information for the statements in a function *) open Cil_types let dkey = Kernel.register_category "dominators" (****************************************************************) module type DIRECTION = sig (* Number of statements in the function. *) val nb_stmts: int (* Conversion between statements and ordered statements. *) val to_ordered: stmt -> Ordered_stmt.ordered_stmt val to_stmt: Ordered_stmt.ordered_stmt -> stmt (* Iterates on all the statements, except the roots of the domination tree; in topological order for dominators, and reverse topological order for the post-dominators. *) val iter: (Ordered_stmt.ordered_stmt -> unit) -> unit (* Entry point (for dominators) or return (for post-dominators), that will be the root of the dominator/post-dominator tree. *) val root_stmt: Ordered_stmt.ordered_stmt;; val is_further_from_root: Ordered_stmt.ordered_stmt -> Ordered_stmt.ordered_stmt -> bool (* List of all predecessors for the dominators, list of successors for the post-dominators (for the post-dominators, it can be seen as the predecessors in the reversed control flow graph that goes from the sinks to the entry point). *) val preds: Ordered_stmt.ordered_stmt -> Ordered_stmt.ordered_stmt list val name:string end module Compute(D:DIRECTION) = struct (* Computes the smallest common dominator between two statements. *) let nearest_common_ancestor find_domtree ord1 ord2 = Kernel.debug ~dkey ~level:2 "computing common ancestor %d %d" (D.to_stmt ord1).sid (D.to_stmt ord2).sid; let finger1 = ref ord1 in let finger2 = ref ord2 in while (!finger1 != !finger2) do ( while ( D.is_further_from_root !finger1 !finger2) do finger1 := (match find_domtree !finger1 with | None -> assert false | Some x -> x) done; while ( D.is_further_from_root !finger2 !finger1) do finger2 := (match find_domtree !finger2 with | None -> assert false | Some x -> x) done;) done; !finger1 ;; (* Note: None means either unprocessed, or that the statement has no predecessor or that all its ancestors are at None *) (* based on "A Simple, Fast Dominance Algorithm" by K.D. Cooper et al *) let domtree () = let domtree = Array.make D.nb_stmts None in (* Initialize the dataflow: for each root, add itself to its own set of dominators. *) domtree.(D.root_stmt) <- Some D.root_stmt; let changed = ref true in while !changed do changed := false; D.iter (fun b -> let ordered_preds = D.preds b in let processed_preds = let was_processed p = match domtree.(p) with | None -> false | Some(_) -> true in List.filter was_processed ordered_preds in match processed_preds with | [] -> () (* No predecessor (e.g. unreachable stmt): leave it to None.*) | first::rest -> let find i = domtree.(i) in let new_idom = List.fold_left (nearest_common_ancestor find) first rest in (match domtree.(b) with | Some(old_idom) when old_idom == new_idom -> () | _ -> (domtree.(b) <- Some(new_idom); changed := true)) ); done; (* The roots are not _immediate_ dominators of themselves, so revert that now that the dataflow has finished. *) domtree.(D.root_stmt) <- None; domtree ;; let display domtree = Kernel.debug ~dkey ~level:2 "Root is %d" (D.to_stmt 0).sid; Array.iteri (fun orig dest -> match dest with | Some(x) -> Kernel.debug ~dkey ~level:2 "%s of %d is %d" D.name (D.to_stmt orig).sid (D.to_stmt x).sid | None -> Kernel.debug ~dkey ~level:2 "no %s for %d" D.name (D.to_stmt orig).sid) domtree ;; end let direction_dom kf = let (stmt_to_ordered,ordered_to_stmt,_) = Ordered_stmt.get_conversion_tables kf in let to_stmt = Ordered_stmt.to_stmt ordered_to_stmt in let module Dominator = struct let to_ordered = Ordered_stmt.to_ordered stmt_to_ordered;; let to_stmt = to_stmt;; let nb_stmts = Array.length ordered_to_stmt;; let root_stmt = to_ordered (Kernel_function.find_first_stmt kf) (* Iterate on all statements, except the entry point. *) let iter f = for i = 0 to nb_stmts -1 do if i != root_stmt then f i done;; let is_further_from_root p1 p2 = p1 > p2 let preds s = List.map to_ordered (to_stmt s).Cil_types.preds let name = "dom" end in (module Dominator: DIRECTION) ;; (* Fill the project table with the dominators of a given function. *) let store_dom domtree to_stmt = Array.iteri( fun ord idom -> let idom = Extlib.opt_map to_stmt idom in let stmt = to_stmt ord in Kernel.debug ~dkey ~level:2 "storing dom for %d: %s" stmt.sid (match idom with None -> "self" | Some s ->string_of_int s.sid); Dom_tree.add stmt idom ) domtree let compute_dom kf = let direction = direction_dom kf in let module Dominator = (val direction: DIRECTION) in let module ComputeDom = Compute(Dominator) in let domtree = ComputeDom.domtree () in store_dom domtree Dominator.to_stmt ;; (* Note: The chosen semantics for postdominator is the following one: a post-dominates b if all the paths from b to the return statement goes through a. Statements on the paths that go only into infinite loop, or to __no_return function, do not have any post dominator (they are set to None). This definition of post-dominator gives a single root to the post-domination tree, which is required by the Cooper algorithm above. Beware that there are alternative, incompatible, definitions to post-domination, e.g. saying that a post dominates b if all the paths from b to any return statement or infinite loop go through a. *) (* TODO: - For each statement, associate its immediate post-dominator (if it exists), and the list of sinks that dominates it - Attempt to find the post-dominator by intersection only if the list of sinks of the points is the same. Otherwise, state that there is no immediate post-dominator, and that the point is dominated by the union of the lists of sinks of its successors. *) let _compute_pdom kf = let (stmt_to_ordered,ordered_to_stmt,_) = Ordered_stmt.get_conversion_tables kf in let module PostDominator = struct let to_ordered = Ordered_stmt.to_ordered stmt_to_ordered;; let to_stmt = Ordered_stmt.to_stmt ordered_to_stmt;; let nb_stmts = Array.length ordered_to_stmt;; let root_stmt = to_ordered (Kernel_function.find_return kf) let iter f = for i = nb_stmts -1 downto 0 do if i != root_stmt then f i done;; let is_further_from_root p1 p2 = p1 < p2 let preds s = List.map to_ordered (to_stmt s).Cil_types.succs let name = "postdom" end in let module ComputePDom = Compute(PostDominator) in let domtree = ComputePDom.domtree () in ComputePDom.display domtree ;; (****************************************************************) (* For each statement we maintain a set of statements that dominate it *) (* Try to find the idom, and fill the table if not already computed. *) let get_idom s = try Dom_tree.find s with Not_found -> let kf = Kernel_function.find_englobing_kf s in let _ = (compute_dom kf) in try Dom_tree.find s with _ -> assert false ;; (** Check whether one block dominates another. This assumes that the "idom" * field has been computed. *) let rec dominates (s1: stmt) (s2: stmt) = s1.sid = s2.sid || match (get_idom s2) with | None -> false | Some s2idom -> dominates s1 s2idom let nearest_common_ancestor l = match l with | [] -> failwith "" | s :: _ -> let kf = Kernel_function.find_englobing_kf s in let direction = direction_dom kf in let module Dominator = (val direction: DIRECTION) in let module ComputeDom = Compute(Dominator) in (try ignore (Dom_tree.find s) with Not_found -> let domtree = ComputeDom.domtree () in store_dom domtree Dominator.to_stmt ); let to_ordered = Dominator.to_ordered in let to_stmt = Dominator.to_stmt in let find i = Extlib.opt_map to_ordered (Dom_tree.find (to_stmt i)) in let rec aux = function | [] -> assert false | [s] -> to_ordered s | s :: (_ :: _ as q) -> ComputeDom.nearest_common_ancestor find (to_ordered s) (aux q) in Dominator.to_stmt (aux l) frama-c-Phosphorus-20170501/src/kernel_services/analysis/logic_interp.mli0000644000175000017500000000373613113745002025352 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 the interesting functions of this module are exported through {!Db.Interp}. *) (* TODO: remove the module Properties from Db and export directly the functions from here. *) module To_zone : sig exception NYI of string val not_yet_implemented : string ref end exception Error of Cil_types.location * string (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/analysis/dataflow.mli0000644000175000017500000003205713113745011024473 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). *) (****************************************************************************) (** Deprecated: use {!Dataflows} instead. 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 forward 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 (** [computeFirstPredecessor s d] is called when [s] is reached for the first time (i.e. no previous data is associated with it). The data [d] is propagated to [s] from an unspecified preceding statement [s']. The result of the call is stored as the new data for [s]. [computeFirstPredecessor] usually leaves [d] unchanged, but may potentially change it. It is also possible to perform a side-effect, for dataflows that store information out of the type [t]. *) val combinePredecessors: Cil_types.stmt -> old:t -> t -> t option (** Take some old data for the given statement, and some new data for the same point. Return None if the combination is identical to the old data, to signify that a fixpoint is currently reached for this statement. 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 (which is englobed by the given statement). The action [Default] propagates the state passed as an argument unchanged. The current location is updated before this function is called. *) val doGuard: Cil_types.stmt -> Cil_types.exp -> t -> t guardaction * t guardaction (** Generate the successors [act_th, act_el] to an [If] statement. [act_th] (resp. [act_el]) corresponds to the case where the given expression evaluates to zero (resp. non-zero). It is always possible to return [GDefault, GDefault], especially for analyses that do not use guard information. This is equivalent to returning [GUse d, GUse d], where [d] is the input state. A return value of GUnreachable indicates that this half of the branch will not be taken and should not be explored. [stmt] is the corresponding [If] statement, passed as information 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 there 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 there 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 statements (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: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/analysis/exn_flow.mli0000644000175000017500000000443013113745007024512 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** Manages information related to possible exceptions thrown by each function in the AST. *) (** returns the set of exceptions that a given kernel function might throw. *) val get_kf_exn: Kernel_function.t -> Cil_datatype.Typ.Set.t (** computes the information if not already done. *) val compute: unit -> unit (**/**) (** internal state of the module. *) val self_fun: State.t val self_stmt: State.t (**/**) (** transforms functions that may throw into functions returning a union type composed of the normal return or one of the exceptions. *) val remove_exn: Cil_types.file -> unit (** category of the code transformation above. *) val transform_category: File.code_transformation_category frama-c-Phosphorus-20170501/src/kernel_services/analysis/ordered_stmt.ml0000644000175000017500000001212413113745010025204 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 (* Hashtable from stmts to ordered_stmts, an int corresponding to the topological ordering. *) module Order = struct include Cil_datatype.Stmt.Hashtbl.Make(Datatype.Int) let get h stmt = try Cil_datatype.Stmt.Hashtbl.find h stmt with Not_found -> assert false end (* Table from ordered stmts to stmts. As he topological numbering is contiguous, so the 'back' table uses an array. *) module Unorder = struct include Datatype.Array(Cil_datatype.Stmt) let get = Array.get end (* Array from ordered_stmts to connex_component number. *) module Connex_components = struct include Datatype.Array(Datatype.Int) end module Ordered_stmt = Kernel_function.Make_Table (Datatype.Triple(Order)(Unorder)(Connex_components)) (struct let name = "Dataflow2.Ordered_stmt" let dependencies = [ Ast.self ] let size = 17 end) ;; (* Skeleton for an OCamlGraph topological sort *) module CFG = struct type t = kernel_function module V = Cil_datatype.Stmt let iter_vertex f kf = List.iter f (Kernel_function.get_definition kf).sallstmts (* In order to preserve a pleasant order on If and Switch, we follow Cil succs field in reverse order. *) let rec rev_iter f = function | [] -> () | [s] -> f s | [s1; s2] -> f s2; f s1; | e :: q -> rev_iter f q; f e let iter_succ f _kf stmt = rev_iter f stmt.succs end module TopoForward = Graph.Topological.Make(CFG) module Connex = Graph.Components.Make(CFG) let get_ordered_stmt kf = let stmts = (Kernel_function.get_definition kf).sallstmts in let nb_stmts = List.length stmts in (* Compute conversion tables between stmt and ordered_stmt. *) let stmt_to_ordered = Cil_datatype.Stmt.Hashtbl.create nb_stmts in let ordered_to_stmt = Array.make nb_stmts (List.hd stmts) in let n = ref 0 in let f stmt = ordered_to_stmt.(!n) <- stmt; Cil_datatype.Stmt.Hashtbl.add stmt_to_ordered stmt !n; incr n; in TopoForward.iter f kf; (* Compute the strongly connected components. *) let (_nb_scc,f_scc) = Connex.scc kf in let sccs = Array.make nb_stmts (-1) in Array.iteri (fun ordered stmt -> sccs.(ordered) <- f_scc stmt) ordered_to_stmt; (stmt_to_ordered, ordered_to_stmt, sccs);; type ordered_stmt = int;; type 'a ordered_stmt_array = 'a array;; type ordered_to_stmt = stmt array;; type stmt_to_ordered = ordered_stmt Cil_datatype.Stmt.Hashtbl.t;; let get_conversion_tables = Ordered_stmt.memo get_ordered_stmt;; let to_stmt = Unorder.get let to_ordered = Order.get (* TODO: The dataflow propagation strategy iterates on strongly connected components (scc); and for each scc, it iterates on all the statements of the scc in order, before starting a new iteration on that scc. To make the dataflow efficient, it is important that statements inside the scc are ordered topologically, ignoring back edges. This is not what is currently done: as the topological sort is global, there is no guarantee on the orders between statements inside of a cycle. Furthermore, to make the dataflow propagation strategy more understandable, the topological sort should be stable with regards to program order (i.e. the order between a and b may change only when there is a path from a to b, and no path from b to a). For cycles, the smallest element of the cycle should be the first element in program order, which has a predecessor in one of the previous strongly connected components. Ocamlgraph has a Make_stable functor, but it does not work when some components are not connected. *) frama-c-Phosphorus-20170501/src/kernel_services/analysis/loop.ml0000644000175000017500000001144513113745006023474 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 dkey = Kernel.register_category "natural_loops" module Natural_Loops = Kernel_function.Make_Table (Stmt.Map.Make(Datatype.List(Stmt))) (struct let name = "natural_loops" let size = 97 let dependencies = [ Ast.self ] end) let pretty_natural_loops fmt loops = Stmt.Map.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 (** Compute the start of the natural loops of the function. For each start, we also return the origins of the back edges. *) let findNaturalLoops (f: fundec) = let loops = List.fold_left (fun acc b -> (* Iterate over all successors, and see if they are among the dominators for this block. Such a successor [s] is a natural loop, and [b -> s] is a back-edge. *) List.fold_left (fun acc s -> if Dominators.dominates s b then let cur = try Stmt.Map.find s acc with Not_found -> [] in Stmt.Map.add s (b :: cur) acc else acc) acc b.succs) Stmt.Map.empty f.sallstmts in Kernel.debug ~dkey "Natural loops:\n%a" pretty_natural_loops loops; loops let get_naturals kf = let loops = Natural_Loops.memo (fun kf -> match kf.fundec with | Declaration _ -> Stmt.Map.empty | Definition (cilfundec,_) -> Kernel.debug ~dkey "Compute natural loops for '%a'" Kernel_function.pretty kf; let naturals = findNaturalLoops cilfundec in Kernel.debug ~dkey "Done computing natural loops for '%a':@.%a" Kernel_function.pretty kf pretty_natural_loops naturals; naturals ) kf in loops let is_natural kf = let loops = get_naturals kf in fun s -> Stmt.Map.mem s loops let back_edges kf stmt = try Stmt.Map.find stmt (get_naturals kf) with Not_found -> [] let get_non_naturals kf = let visited = Stmt.Hashtbl.create 17 in let current = Stmt.Hashtbl.create 17 in let res = ref Stmt.Set.empty in let is_natural = is_natural kf in let rec aux s = if Stmt.Hashtbl.mem visited s then begin if Stmt.Hashtbl.mem current s && not (is_natural s) then begin res := Stmt.Set.add s !res; Kernel.warning ~once:true ~source:(fst (Cil_datatype.Stmt.loc s)) "Non-natural loop detected." end end else begin Stmt.Hashtbl.add visited s (); Stmt.Hashtbl.add current s (); List.iter aux s.Cil_types.succs; Stmt.Hashtbl.remove current s; end in aux (Kernel_function.find_first_stmt kf); !res module Non_Natural_Loops = Kernel_function.Make_Table (Stmt.Set) (struct let name = "Loop.non_natural_loops" let size = 37 let dependencies = [ Ast.self ] end) let get_non_naturals = Non_Natural_Loops.memo get_non_naturals let is_non_natural kf s = Stmt.Set.mem s (get_non_naturals kf) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/analysis/stmts_graph.ml0000644000175000017500000003604413113745010025053 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 (Cil_datatype.Stmt_Id) (struct include Datatype.Bool let pretty_debug = pretty end) (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 ()) (* 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 (* 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 = StmtCanReachCache.memo stmt_can_reach 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 SG_Dfs = Graph.Traverse.Dfs(SG) module TP = struct include SG let graph_attributes _ = [] let pretty_raw_stmt s = let s = Format.asprintf "%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 | Throw _ -> Format.sprintf "THROW <%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,_,_,_) -> Format.asprintf "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 | TryCatch _ -> Format.sprintf "TRY CATCH <%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 = State_builder.Hashtbl(Stmt.Hashtbl)(Stmt.Hptset) (struct let name = "Stmts_graph.Reachable_Stmts" let size = 97 let dependencies = [ Ast.self ] end) let reachable_stmts kf s = try Reachable_Stmts.find s with Not_found -> (* compute successors *) let g = get_graph kf in let visited = ref Stmt.Hptset.empty in SG_Dfs.prefix_component (fun s' -> visited := Stmt.Hptset.add s' !visited) g s; Reachable_Stmts.replace s !visited; !visited (* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *) (** 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 _ | Throw _ -> 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 | TryCatch(t,c,_) -> List.fold_left (fun acc (_,b) -> Stmt.Set.union acc (get_block_stmts b)) (get_block_stmts t) c | 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-Phosphorus-20170501/src/kernel_services/analysis/dataflows.mli0000644000175000017500000002345213113745007024662 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). *) (****************************************************************************) (** Implementation of data flow analyses over user-supplied domains. *) (* Instead of defining a single dataflow interface that tries to accommodate with all the options (as was done in {!Dataflow2}), having a set of dataflows allow to keep things simple in the general case; specific demands are handled by using more general dataflows. Simpler-to-instantiate dataflows are instances of the more general dataflows. *) open Cil_types;; open Ordered_stmt;; (** Environment relative to the function being processed, and function to create them from Kf. *) module type FUNCTION_ENV = sig val to_ordered: stmt -> ordered_stmt val to_stmt: ordered_stmt -> stmt val connected_component: ordered_stmt -> int val nb_stmts: int val kf: Kernel_function.t end val function_env: kernel_function -> (module FUNCTION_ENV);; module type JOIN_SEMILATTICE = sig type t (** Must be idempotent (join a a = a), commutative, and associative. *) val join: t -> t -> t (** Must verify that forall a, join a bottom = a. *) val bottom: t (** Must verify: a is_included b <=> a join b = b. The dataflow does not require this function. *) val is_included: t -> t -> bool (** This function is used by the dataflow algorithm to determine if something has to be recomputed. Joining and inclusion testing are similar operations, so it is often more efficient to do both at the same time (e.g. when joining with bottom). Instead of defining it directly, it can be defined from join and equal, or from is_included, for instance by [if is_included new old then (true,old) else (false, join old new)] or [let j = join old new in (equal j new, j)]. *) val join_and_is_included: t -> t -> (t * bool) (** Display the contents of an element of the lattice. *) val pretty: Format.formatter -> t -> unit end (** {2 Backward dataflow} *) (** Statement-based backward dataflow. Contrary to the forward dataflow, the transfer function cannot differentiate the state before a statement between different predecessors. *) module type BACKWARD_MONOTONE_PARAMETER = sig include JOIN_SEMILATTICE (** [transfer_stmt s state] must implement the transfer function for [s]. *) val transfer_stmt: stmt -> t -> t (** The initial state after each statement. Statements in this list are given the associated value, and are added to the worklist. Other statements are initialized to bottom. To get results for an entire function, this list should contain information for the following statements: - the final statement of the function ({!Kernel_function.find_return}) - all the statements with no successors - at least one statement per non-terminating loop *) val init: (stmt * t) list end module Simple_backward(Fenv:FUNCTION_ENV)(P:BACKWARD_MONOTONE_PARAMETER) : sig (** {3 Retrieving the state before and after a statement.} *) val post_state: stmt -> P.t val pre_state: stmt -> P.t (** This function calls [transfer_stmt] on the result of [post_state]. Beware if [transfer_stmt] is impure or costly *) (** {3 Iterations on the results of the dataflow.} In this dataflow, the results are the post-states of all the statements that may reach the statements in [P.init]. *) val fold_on_result: ('a -> stmt -> P.t -> 'a) -> 'a -> 'a val iter_on_result: (stmt -> P.t -> unit) -> unit (**/**) val after:P.t Ordered_stmt.ordered_stmt_array (**/**) end (** {2 Forward dataflow} *) (** Edge-based forward dataflow. It is edge-based because the transfer function can differentiate the state after a statement between different successors. In particular, the state can be reduced according to the conditions in if statements. *) module type FORWARD_MONOTONE_PARAMETER = sig include JOIN_SEMILATTICE (** [transfer_stmt s state] must returns a list of pairs in which the first element is a statement [s'] in [s.succs], and the second element a value that will be joined with the current result for before [s']. Note that it is allowed that not all succs are present in the list returned by [transfer_stmt] (in which case, the successor is assumed to be unreachable in the current state), or that succs are present several times (this is useful to handle switches). Helper functions are provided for [If] and [Switch] statements. See {!transfer_if_from_guard} and {!transfer_switch_from_guard} below. *) val transfer_stmt: stmt -> t -> (stmt * t) list (** The initial value for each statement. Statements in this list are given the associated value, and are added to the worklist. Other statements are initialized to bottom. Unless you want to do something very specific, supplying only the state for the first statement of the function (as found by {!Kernel_function.find_first_stmt}) is sufficient. *) val init: (stmt * t) list end module Simple_forward(Fenv:FUNCTION_ENV)(P:FORWARD_MONOTONE_PARAMETER) : sig (** {3 Retrieve the state before and after a statement.} *) val pre_state: stmt -> P.t val post_state: stmt -> P.t (** This function calls [transfer_stmt] on the result of [pre_state]. Beware if [transfer_stmt] is impure or costly *) (** {3 Iterations on the results of the dataflow.} In this dataflow, the results are the pre-states of all the statements reachable from the statements from [P.init]. *) val fold_on_result: ('a -> stmt -> P.t -> 'a) -> 'a -> 'a val iter_on_result: (stmt -> P.t -> unit) -> unit (**/**) val before:P.t Ordered_stmt.ordered_stmt_array (* TODO: Should disappear, together with Fenv? *) (**/**) end;; (** {3 Helper functions for forward dataflow.} *) val transfer_if_from_guard: (stmt -> exp -> 'a -> 'a * 'a) -> stmt -> 'a -> (stmt * 'a) list (** [transfer_if_from_guard] implements [FORWARD_MONOTONE_PARAMETER.transfer_stmt] for the [If] statement, given a function [transfer_guard]. [transfer_guard] receives a conditional expression, the current statement, and the current state, and must return two states in which the conditional is assumed to be true and false respectively. Returning twice the current state is a valid, albeit imprecise, result. *) val transfer_switch_from_guard: (stmt -> exp -> 'a -> 'a * 'a) -> stmt -> 'a -> (stmt * 'a) list (** Same as {!transfer_if_from_guard}, but for a [Switch] statement. The same function [transfer_guard] can be used for [transfer_if_from_guard] and [transfer_switch_from_guard]. *) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/analysis/dataflows.ml0000644000175000017500000005615213113745003024510 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 dkey = Kernel.register_category "dataflows" let dkeyscc = Kernel.register_category "dataflows_scc" open Ordered_stmt;; open Cil_types;; (****************************************************************) (* Environment relative to the function being processed. *) module type FUNCTION_ENV = sig val to_ordered: stmt -> ordered_stmt val to_stmt: ordered_stmt -> stmt val connected_component: ordered_stmt -> int val nb_stmts: int val kf: Kernel_function.t end let function_env kf = (module struct let (order,unorder,connex) = Ordered_stmt.get_conversion_tables kf;; let nb_stmts = Array.length unorder;; let to_stmt ordered = Ordered_stmt.to_stmt unorder ordered;; let to_ordered stmt = Ordered_stmt.to_ordered order stmt;; let connected_component ord = connex.(ord) let kf = kf end : FUNCTION_ENV) (****************************************************************) (* Worklists. *) module type WORKLIST = sig (** Add a statement to the worklist. The statement can already be in the worklist; in this case it will not appear twice in the worklist (i.e. the worklist is a set, not a list). *) val insert: ordered_stmt -> unit (** Retrieve and remove the next element of the worklist. Returns [None] if the worklist is empty. *) val extract: unit -> ordered_stmt option end module type CONSULTABLE_WORKLIST = sig include WORKLIST (** [in_worklist x] returns true if it is guaranteed that a further call to [extract()] will return [x] (Thus it is safe for a worklist implementation to always return false here). *) val in_worklist: ordered_stmt -> bool end (** {2 Examples of use} *) [@@@ warning "-60"] (* Worklist for a "rapid" framework. Just iterate over all statements until none has changed. *) module Rapid_forward_worklist(Fenv:FUNCTION_ENV):CONSULTABLE_WORKLIST = struct type t = { mutable changed: bool; mutable current_index: ordered_stmt; } ;; let w = { changed = false; current_index = Fenv.nb_stmts } ;; let insert _ord = w.changed <- true ;; let extract () = if w.current_index >= Fenv.nb_stmts - 1 then if w.changed then (w.changed <- false; w.current_index <- 0; Some 0) else None else (w.current_index <- w.current_index + 1; Some w.current_index) ;; let in_worklist ord = w.changed || ord > w.current_index end (* Iterates on all statements in order, but do something only on those for which there is a pending change. *) module Simple_forward_worklist(Fenv:FUNCTION_ENV):CONSULTABLE_WORKLIST = struct (* The worklist, and the current index. *) type t = { bv: Bitvector.t; mutable index: int };; let w = let bv = Bitvector.create Fenv.nb_stmts in let first = Fenv.to_ordered (Kernel_function.find_first_stmt Fenv.kf) in {bv; index=first} ;; let insert ord = Bitvector.set w.bv ord;; let extract () = try let next = Bitvector.find_next_true w.bv w.index in Bitvector.clear w.bv next; w.index <- next; Some next with Not_found -> (* Try to start over. *) try let next = Bitvector.find_next_true w.bv 0 in Bitvector.clear w.bv next; w.index <- next; Some next (* Nothing to do left. *) with Not_found -> None let in_worklist ord = Bitvector.mem w.bv ord end ;; [@@@ warning "+60"] type direction = Forward | Backward;; (* Iterate over statements by strongly connected components: i.e. do not leave a scc if there is still work to do in this scc. All statements inside a scc are handled before starting over on that scc. Iteration is done using the topological order of sccs. *) module Connected_component_worklist (Dir:sig val direction:direction end) (Fenv:FUNCTION_ENV) :CONSULTABLE_WORKLIST = struct (** Workqueue, implemented as a bit vector. Because the [find_next_true] operation only operates in ascending indices, we need to put statements in the reverse order for the backward dataflow. *) module Workqueue:sig val clear: ordered_stmt -> unit val set: ordered_stmt -> unit val mem: ordered_stmt -> bool val find_next_true: ordered_stmt -> ordered_stmt end = struct let rev = match Dir.direction with | Forward -> fun x -> x | Backward -> fun x -> (Fenv.nb_stmts - 1) - x ;; let bv = Bitvector.create Fenv.nb_stmts let clear i = Bitvector.clear bv (rev i) let set i = Bitvector.set bv (rev i) let mem i = Bitvector.mem bv (rev i) let find_next_true current = rev (Bitvector.find_next_true bv (rev current)) end (* Forward iteration follows topological order, while backward iteration follows reverse topological order. Further, nearer etc. reflects topological distance to the first node. *) let first = match Dir.direction with | Forward -> 0 | Backward -> Fenv.nb_stmts - 1 let get_next = match Dir.direction with | Forward -> fun x -> x + 1 | Backward -> fun x -> x - 1 let is_further = match Dir.direction with | Forward -> (>=) | Backward -> (<=) let is_strictly_nearer = match Dir.direction with | Forward -> (<) | Backward -> (>) let nearest a b = match Dir.direction with | Forward -> min a b | Backward -> max a b (* Next statement to be retrieved. *) let next = ref first (* The current strongly connected component. Set it initially to the one of [next] so that extraction directly returns the initial [next]. *) let current_scc = ref (Fenv.connected_component !next);; Kernel.debug ~dkey:dkeyscc "First statement %d, first scc %d" !next !current_scc;; (* We normally iterate using the ordered_stmt order. The only exception is when we have to restart iteration on the current strongly connected component. If this is the case, must_restart_cc is set to [Some(x)], where [x] is the first statement to be processed when we restart iterating on the current scc. *) let must_restart_scc = ref None let insert ord = (* We always iterate in topological order or stay in same connected component order. *) assert ((is_further ord !next) || (Fenv.connected_component ord) = !current_scc); Workqueue.set ord; if is_strictly_nearer ord !next then must_restart_scc := match !must_restart_scc with | None -> Some ord | Some(x) -> Some(nearest ord x) let extract () = (* Note: these functions are called in tail position, and should be optimized as jumps. *) (* Remove i from the worklist, set up next for the next call, and return i. *) let select i = Kernel.debug ~dkey:dkeyscc "Selecting %d" i; Workqueue.clear i; next := get_next i; Some i in (* We reached the end of the current scc, and we need to further iterate on it. *) let select_restart_scc i = Kernel.debug ~dkey:dkeyscc "Restarting to %d in same scc %d (current_scc = %d)" i (Fenv.connected_component i) !current_scc; assert((Fenv.connected_component i) == !current_scc); must_restart_scc := None; select i in (* We reached the end of the current scc, and we can switch to the next. *) let select_new_scc i = Kernel.debug ~dkey:dkeyscc "Changing to %d in scc %d (current_scc = %d)" i (Fenv.connected_component i) !current_scc; assert((Fenv.connected_component i) != !current_scc); current_scc := Fenv.connected_component i; must_restart_scc := None; select i in (* We did not reach the end of the current scc. *) let select_same_scc i = Kernel.debug ~dkey:dkeyscc "Continuing to %d in scc %d (current_scc = %d)" i (Fenv.connected_component i) !current_scc; assert((Fenv.connected_component i) == !current_scc); select i in try let next_true = Workqueue.find_next_true !next in let next_true_scc = Fenv.connected_component next_true in if next_true_scc = !current_scc then select_same_scc next_true else (* We reached the end of the current connected component. The trick is that OCamlgraph's topological ordering guarantees that elements of the same connected component have contiguous indexes, so we know that we have reached the end of the current scc. Check if we should start over in the same scc, or continue to the next scc. *) match !must_restart_scc with | None -> select_new_scc next_true | Some(i) -> select_restart_scc i with Not_found -> (* We found no further statement with work to do, but the current scc may still contain some work. *) match !must_restart_scc with | None -> None | Some(i) -> select_restart_scc i ;; let in_worklist ord = Workqueue.mem ord end module Forward_connected_component_worklist = Connected_component_worklist(struct let direction = Forward end) ;; module Backward_connected_component_worklist = Connected_component_worklist(struct let direction = Backward end) ;; (****************************************************************) (* Monotone Framework (see Nielson, Nielson, Hankin) *) module type JOIN_SEMILATTICE = sig type t (* Must be idempotent ([join a a = a]), commutative, and associative. *) val join: t -> t -> t (* Must verify that [join a bottom = a]. *) val bottom: t (* Must verify: [is_included a b <=> join a b = b]. The dataflow does not require this function. *) val is_included: t -> t -> bool (* This function is used by the dataflow algorithm to determine if something has to be recomputed. Joining and inclusion testing are similar operations, so it is often more efficient to do both at the same time (e.g. when joining with bottom). Note that the names [smaller] and [larger] are actually correct only if there is an inclusion. Instead of defining it directly, it can be defined from join and equal, or from is_included, for instance by [if is_included new old then (true,old) else (false, join old new)] or [let j = join old new in (equal j new, j)]. *) val join_and_is_included: t -> t -> (t * bool) (* Display the contents of an element of the lattice. *) val pretty: Format.formatter -> t -> unit end module CurrentLoc = Cil_const.CurrentLoc;; (****************************************************************) (* Statement-based backward dataflow. Contrary to the forward dataflow, the transfer function cannot differentiate the state before a statement between different predecessors. *) module type BACKWARD_MONOTONE_PARAMETER = sig include JOIN_SEMILATTICE (* [transfer_stmt s state] must implement the transfer function for [s]. *) val transfer_stmt: stmt -> t -> t (* The initial value for each statement. Statements in this list are given the associated value, and are added to the worklist. Other statements are initialized to bottom. *) val init: (stmt * t) list end module Simple_backward(Fenv:FUNCTION_ENV)(P:BACKWARD_MONOTONE_PARAMETER) = struct module W = Backward_connected_component_worklist(Fenv) let after = Array.make Fenv.nb_stmts P.bottom;; List.iter (fun (stmt,state) -> let ord = Fenv.to_ordered stmt in after.(ord) <- state; W.insert ord ) P.init;; let rec loop () = match W.extract() with | None -> () | Some(ord) -> let stmt = Fenv.to_stmt ord in let before_state = P.transfer_stmt stmt after.(ord) in Kernel.debug ~dkey "backward: %d before_state = %a" stmt.sid P.pretty before_state; let to_update = List.map Fenv.to_ordered stmt.preds in let update_f upd = let join = (* If we know that we already have to recompute before.(ord), we can omit the inclusion testing, and only perform the join. The rationale is that querying the worklist is cheap, while inclusion testing can be costly. *) if W.in_worklist upd then P.join after.(upd) before_state else (* compute join and check inclusion between computed state ([before_state]) and stored state for [upd] ([after.(upd)]) *) let (join,is_included) = P.join_and_is_included before_state after.(upd) in Kernel.debug ~dkey "%a + %a -> %b, %a" P.pretty after.(upd) P.pretty before_state is_included P.pretty join; if not is_included then W.insert upd; join in Kernel.debug ~dkey "backward: updating %d, %a" (Fenv.to_stmt upd).sid P.pretty join; after.(upd) <- join in List.iter update_f to_update; loop() ;; loop();; (* Easy access to the result of computation. *) let fold_on_result f init = let rec loop acc = function | i when i = Fenv.nb_stmts -> acc | i -> let acc = f acc (Fenv.to_stmt i) after.(i) in loop acc (i+1) in loop init 0;; let iter_on_result f = for i = 0 to (Fenv.nb_stmts - 1) do f (Fenv.to_stmt i) after.(i) done;; let post_state stmt = after.(Fenv.to_ordered stmt) let pre_state stmt = P.transfer_stmt stmt (post_state stmt) end (* Edge-based forward dataflow. It is edge-based because the transfer function can differentiate the state after a statement between different successors. In particular, the state can be reduced according to the conditions in if statements. *) module type FORWARD_MONOTONE_PARAMETER_GENERIC_STORAGE = sig include JOIN_SEMILATTICE (* [transfer_stmt s state] must returns a list of pairs in which the first element is a statement [s'] in [s.succs], and the second element a value that will be joined with the current result for before [s']. Note that it is allowed that not all succs are present in the list returned by [transfer_stmt], or that succs are present several times (this is useful to handle switchs). *) val transfer_stmt: stmt -> t -> (stmt * t) list (* These functions explain how we store the state associated to each statement (the state before the statement). *) val get_before: ordered_stmt -> t val set_before: ordered_stmt -> t -> unit (* The initial value for each statement. Statements in this list are given the associated value, and are added to the worklist. Other statements are initialized to bottom. *) val init: (stmt * t) list end module Forward_monotone_generic_storage (Fenv:FUNCTION_ENV) (P:FORWARD_MONOTONE_PARAMETER_GENERIC_STORAGE) (W:CONSULTABLE_WORKLIST) = struct List.iter (fun (stmt,state) -> let ord = Fenv.to_ordered stmt in P.set_before ord state; W.insert ord) P.init;; let update_before (stmt, new_state) = let ord = Fenv.to_ordered stmt in CurrentLoc.set (Cil_datatype.Stmt.loc stmt); let join = (* If we know that we already have to recompute before.(ord), we can omit the inclusion testing, and only perform the join. The rationale is that querying the worklist is cheap, while inclusion testing can be costly. *) if W.in_worklist ord then P.join new_state (P.get_before ord) else let (join, is_included) = P.join_and_is_included new_state (P.get_before ord) in if not is_included then W.insert ord; join in P.set_before ord join ;; let do_stmt ord = let cur_state = P.get_before ord in let stmt = Fenv.to_stmt ord in Kernel.debug ~dkey "forward: doing stmt %d" stmt.sid; CurrentLoc.set (Cil_datatype.Stmt.loc stmt); let l = P.transfer_stmt stmt cur_state in List.iter update_before l ;; (* Performs the fixpoint computation; the result is in [before]. *) let rec compute() = match W.extract() with | None -> () | Some(ord) -> do_stmt ord; compute() in compute() ;; (* Easy access to the result of computation. *) let fold_on_result f init = let rec loop acc = function | i when i = Fenv.nb_stmts -> acc | i -> let acc = f acc (Fenv.to_stmt i) (P.get_before i) in loop acc (i+1) in loop init 0;; let iter_on_result f = for i = 0 to (Fenv.nb_stmts - 1) do f (Fenv.to_stmt i) (P.get_before i) done;; let pre_state stmt = P.get_before (Fenv.to_ordered stmt) let post_state stmt = let post_states = List.map snd (P.transfer_stmt stmt (pre_state stmt)) in List.fold_left P.join P.bottom post_states end (****************************************************************) (* Edge-based forward dataflow with array-based storage. Should be used for most applications of the forward dataflow. *) module type FORWARD_MONOTONE_PARAMETER = sig include JOIN_SEMILATTICE (* [transfer_stmt s state] must returns a list of pairs in which the first element is a statement [s'] in [s.succs], and the second element a value that will be joined with the current result for before [s']. Note that it is allowed that not all succs are present in the list returned by [transfer_stmt], or that succs are present several times (this is useful to handle switchs). *) val transfer_stmt: stmt -> t -> (stmt * t) list (* The initial value for each statement. Statements in this list are given the associated value, and are added to the worklist. Other statements are initialized to bottom. *) val init: (stmt * t) list end module Simple_forward(Fenv:FUNCTION_ENV)(P:FORWARD_MONOTONE_PARAMETER) = struct module W = Forward_connected_component_worklist(Fenv);; module P_array = struct include P let before = Array.make Fenv.nb_stmts P.bottom;; List.iter (fun (stmt,state) -> let ord = Fenv.to_ordered stmt in before.(ord) <- state; W.insert ord) P.init;; let get_before ord = before.(ord);; let set_before ord value = before.(ord) <- value;; end include Forward_monotone_generic_storage(Fenv)(P_array)(W);; let before = P_array.before;; end (****************************************************************) (* Helper functions for implementing [transfer_stmt]. *) (* The following functions allow implementing [transfer_stmt] for the [If] and [Switch] instruction, from a [transfer_guard] function. *) let transfer_if_from_guard transfer_guard stmt state = let exp = match stmt.skind with | If(exp,_,_,_) -> exp | _ -> Kernel.fatal ~current:true "transfer_if_from_guard on a non-If statement." in let (then_state, else_state) = transfer_guard stmt exp state in let (then_stmt, else_stmt) = Cil.separate_if_succs stmt in [(then_stmt,then_state); (else_stmt, else_state)] ;; let transfer_switch_from_guard transfer_guard stmt state = let cond = match stmt.skind with | Switch( cond, _, _, _) -> cond | _ -> Kernel.fatal ~current:true "transfer_switch_from_guard on a non-Switch statement." in let cases, default = Cil.separate_switch_succs stmt in let result = ref [] in (* We fold on the cases; the accumulator contains the state when the label is not taken. *) (* Note: we could early-exit the handling of the switch if we can detect that the false_state is bottom. *) let do_one_case input_state succ = let do_one_label input_state label = match label with (* We do nothing for Default, because we handle it last. *) | Label _ | Default _ -> input_state | Case (exp_case, _) -> let if_equivalent_cond = match exp_case.enode with (* This helps when switch is used on boolean expressions. *) | Const (CInt64 (z,_,_)) when Integer.equal z Integer.zero -> Cil.new_exp ~loc:cond.eloc (UnOp(LNot,cond,Cil.intType)) | _ -> Cil.new_exp exp_case.eloc (BinOp (Eq, cond, exp_case, Cil.intType)) in let (true_state, false_state) = transfer_guard stmt if_equivalent_cond input_state in result := (succ, true_state)::!result; false_state in List.fold_left do_one_label input_state succ.labels in (* We handle the default case last, so that we may benefit from the reduction of the successive guards. *) let final_state = List.fold_left do_one_case state cases in (default,final_state)::!result ;; (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/analysis/destructors.ml0000644000175000017500000002171713113745006025107 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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_destructor (_, l as acc) var = let loc = var.vdecl in match Cil.findAttribute Cabs2cil.frama_c_destructor var.vattr with | [] -> acc | [ attr ] -> let mk_call f e args = let kf = Globals.Functions.find_by_name f in let e = match Globals.Functions.get_params kf with | vi :: _ -> if Cil.need_cast (Cil.typeOf e) vi.vtype then Cil.mkCast e vi.vtype else e | [] -> Kernel.fatal "Destructor function %a should take at least one argument" Kernel_function.pretty kf in let vf = Kernel_function.get_vi kf in vf.vreferenced <- true; let s = Cil.mkStmtOneInstr ~valid_sid:true (Call(None,Cil.evar ~loc vf,e::args,loc)) in (true, s :: l) in let rec aux e a = match a with | AAddrOf a -> aux (Cil.mkAddrOfVi var) a | AStr f -> mk_call f e [] | ACons (f, [n]) -> (match Cil.intOfAttrparam n with | Some n -> mk_call f e [Cil.kinteger ~loc Cil.(theMachine.kindOfSizeOf) n] | None -> Kernel.fatal "unexpected argument of attribute %s: %a" Cabs2cil.frama_c_destructor Printer.pp_attrparam a) | _ -> Kernel.fatal "unexpected argument of attribute %s: %a" Cabs2cil.frama_c_destructor Printer.pp_attrparam a in aux (Cil.evar ~loc var) attr | _ -> Kernel.fatal "attribute %s expects exactly one argument" Cabs2cil.frama_c_destructor (* we expect the variables from oldest to newest. Hence the fold_left will call the destructors in the reverse order, starting with the newest ones. *) let add_destructors vars = List.fold_left add_destructor (false,[]) vars (* insert the destructors before the given jump statement. *) let insert_destructors destructors s stmts = let rec aux previous tl = match tl with | [] -> false, [] | hd :: _ when Cil_datatype.Stmt.equal hd s -> true, List.rev_append previous destructors @ tl | { skind = UnspecifiedSequence l } as s :: tl -> let (has_inserted, res) = aux_seq [] l in if has_inserted then true, List.rev_append previous ({s with skind = UnspecifiedSequence res}:: tl) else aux (s::previous) tl | hd :: tl -> aux (hd :: previous) tl and aux_seq previous tl = match tl with | [] -> false, [] | (s', _, _, _, _) :: _ when Cil_datatype.Stmt.equal s s' -> let destructors = List.map (fun s -> s,[],[],[],[]) destructors in true, List.rev_append previous destructors @ tl (* There can't be a block here, since we are by definition in the innermost block containing the statement. *) | hd :: tl -> aux_seq (hd :: previous) tl in let (has_inserted, res) = aux [] stmts in if has_inserted then res else Kernel.fatal ~current:true "Statement %a not found in the current block" Printer.pp_stmt s class vis flag = object(self) inherit Visitor.frama_c_inplace val blocks = Stack.create () method! vblock b = Stack.push b.bstmts blocks; let post b = let stmts = Stack.pop blocks in let has_destructors, my_destructors = add_destructors b.blocals in let stmts = if has_destructors then begin flag := true; if stmts = [] then my_destructors else begin let stmt = Extlib.last stmts in if Cabs2cil.stmtFallsThrough stmt then stmts @ my_destructors else stmts end end else stmts in if stmts != b.bstmts then b.bstmts <- stmts; b in Cil.DoChildrenPost post method! vstmt_aux s = let inspect_closed_blocks b = (* blocks are sorted from innermost to outermost. The fold_left will give us the list in appropriate order for add_destructors which expects variable from oldest to newest. *) let vars = List.fold_left (fun acc b -> b.blocals @ acc) [] b in let has_destructors, stmts = add_destructors vars in if has_destructors then begin flag:=true; let curr_block = Stack.pop blocks in let curr_block = insert_destructors stmts s curr_block in Stack.push curr_block blocks; end; Cil.SkipChildren in let abort_if_non_trivial_type kind v = if Cil.hasAttribute Cabs2cil.frama_c_destructor v.vattr then Kernel.abort "%a, cannot jump from %s statement \ bypassing initialization of variable %a, declared at %a" Printer.pp_location (Cil_datatype.Stmt.loc s) kind Printer.pp_varinfo v Printer.pp_location v.vdecl in let check_def_domination kind b s v = if v.vdefined then begin let def = Cil.find_def_stmt b v in if not (Dominators.dominates s def) then (* if the jump's target [s] dominates the definition [def], jumping to it from outside the block will not prevent the initialization, hence is permitted: technically, the scope only begins at the end of the declaration part of [def]. See C11, 6.2.1§7 and C++11, stmt.dcl§3. *) abort_if_non_trivial_type kind v end else abort_if_non_trivial_type kind v in let inspect_local_vars kind b s lv = List.iter (check_def_domination kind b s) lv in let treat_jump_close s = match s.succs with | [ succ ] -> inspect_closed_blocks (Kernel_function.blocks_closed_by_edge s succ) | _ -> Kernel.fatal ~current:true "%a in function %a is expected to have a single successor" Printer.pp_stmt s Kernel_function.pretty (Extlib.the self#current_kf) in let treat_succ_open kind s succ = let blocks = Kernel_function.blocks_opened_by_edge s succ in List.iter (fun b -> inspect_local_vars kind b succ b.blocals) blocks in let treat_jump_open k s = List.iter (treat_succ_open k s) s.succs in match s.skind with (* jump to a statement inside the function. *) | Break _ | Continue _ -> treat_jump_close s (* For goto, we must verify in addition that we do not enter the scope of VLA or similar non trivial types (C++). See 6.8.6.1§1 of C11 and stmt.dcl§3 of C++11 *) | Goto _ -> treat_jump_open "goto" s; treat_jump_close s (* Ensures that there's no VLA declared between the switch and the case label. See 6.8.4§2 of C11 and stmt.dcl§3 and footnote 88 of C++11. *) | Switch _ -> treat_jump_open "switch" s; Cil.DoChildren (* jump outside of the function: all currently opened blocks are closed. *) | Return _ | Throw _ -> inspect_closed_blocks (Kernel_function.find_all_enclosing_blocks s) (* no jump yet, visit children *) | _ -> Cil.DoChildren end let treat_one_function flag kf = let my_flag = ref false in let vis = new vis my_flag in ignore (Visitor.visitFramacKf vis kf); if !my_flag then begin flag := true; File.must_recompute_cfg (Kernel_function.get_definition kf) end let add_destructor _ast = let has_grown = ref false in Globals.Functions.iter (treat_one_function has_grown); if !has_grown then Ast.mark_as_grown () let transform_category = File.register_code_transformation_category "expand_destructors" let () = let after = [Exn_flow.transform_category] in File.add_code_transformation_after_cleanup ~after transform_category add_destructor frama-c-Phosphorus-20170501/src/kernel_services/analysis/bit_utils.mli0000644000175000017500000001167013113745011024666 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 -> Integer.t (** @return the maximal possible offset in bits of a memory base. *) val max_bit_size : unit -> Integer.t (** @return the maximal possible size in bits of a memory base. *) val max_byte_address : unit -> Integer.t (** @return the maximal possible offset in bytes of a memory base. @since Aluminium-20160501 *) val max_byte_size : unit -> Integer.t (** @return the maximal possible size in bytes of a memory base. @since Aluminium-20160501 *) (** {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. *) (** {2 Mapping from numeric offsets to symbolic ones.} *) (** We want to find a symbolic offset that corresponds to a numeric one, with one additional criterion: *) type offset_match = | MatchType of typ (** Offset that has this type (modulo attributes) *) | MatchSize of Integer.t (** Offset that has a type of this size *) | MatchFirst (** Return first symbolic offset that matches *) exception NoMatchingOffset (** [find_offset typ ~offset ~size] finds a subtype [t] of [typ] that describes the type of the bits [offset..offset+size-1] in [typ]. May return a subtype of [typ], or a type that is a sub-array of an array type in [typ]. Also returns a {!Cil_types.offset} [off] that corresponds to [offset]. (But we do not have the guarantee that [typeof(off) == typ], because of sub-arrays.) @raise NoMatchingOffset when no offset matches. *) val find_offset: typ -> offset:Integer.t -> offset_match -> Cil_types.offset * Cil_types.typ (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/analysis/dataflow.ml0000644000175000017500000006262513113745002024326 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: data Cil_datatype.Stmt.Hashtbl.t = 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 (** 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 | Throw _ | TryCatch _ -> Kernel.not_yet_implemented "[dataflow] exception handling" | 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 = Cil.separate_if_succs s in doBranch thenSucc thenGuard; doBranch elseSucc elseGuard; end | Switch (exp_sw, _, _, _) -> let cases, default = 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 succ -> if rem_state = None then None else List.fold_left (fun rem_state label -> match rem_state with | None -> rem_state | Some state -> f succ label state ) rem_state succ.labels ) (Some curr) 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 = iter_all_labels (fun succ label before -> match label with | Label _ (* Label not related to the switch *) | Cil_types.Default _ -> (* The default case is handled at the end *) (Some before) | Case (exp_case, _) -> let after = explore_succ before succ exp_case in after ) 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 -> reachedStatement s default 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 i -> begin CurrentLoc.set (Cil_datatype.Instr.loc i); let action = T.doInstr s i res in match action with | Done s' -> s' | Default -> res (* do nothing *) | Post f -> f res end | _ -> 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 statements (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-Phosphorus-20170501/src/kernel_services/analysis/service_graph.mli0000644000175000017500000000714213113745012025511 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 *) type 'a vertex = private { node: 'a; mutable is_root: bool; mutable root: 'a vertex } type edge = private Inter_services | Inter_functions | Both (** Output signature for services. *) module type S = sig type node type graph module Service_graph: sig include Graph.Sig.G with type V.t = node vertex and type E.label = edge module Datatype: Datatype.S with type t = t end val compute: graph -> Datatype.String.Set.t -> Service_graph.t val output_graph: out_channel -> Service_graph.t -> unit val entry_point: unit -> Service_graph.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 = Service_graph.t and type V.t = node vertex and type E.t = Service_graph.E.t (** @since Beryllium-20090902 *) end (** 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 [id >= 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) : S with type node = G.V.t and type graph = G.t (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/analysis/undefined_sequence.mli0000644000175000017500000000401613113745007026522 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 a warning message when an undefined behavior may occurs in an unspecified sequence, i.e. two writes or a write and a read (not used for determining the value to write, Cf. C99 6.5§2). We compute an over-approximation here but under the assumption that it is not possible to access two distinct fields by overflowing an index, i.e. s.f[i] is always distinct from s.g[j] *) val check_sequences: Cil_types.file -> unit frama-c-Phosphorus-20170501/src/kernel_services/analysis/destructors.mli0000644000175000017500000000474413113745012025256 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** retrieve local variables with [__fc_destructor] attribute and add the appropriate calls to the corresponding destructor function when we exit the scope of the variable. Argument of the attribute can take the following forms: - [AStr f], where [f] is the name of the function to call. - [ACons (f, [AInt n])], where [f] is the name of the function to call and n an argument that will be passed to f in addition to the variable. Will be used for destructing local C++ arrays. - [AAddrOf a] where [a] is of the form above, to indicate that the destructor should be given the address of the variable and not the variable directly *) (** category of the transformation. Should be done after any transformation susceptible to change the CFG of the program (e.g. {!Exn_flow.transform_category}) *) val transform_category: File.code_transformation_category frama-c-Phosphorus-20170501/src/kernel_services/analysis/logic_interp.ml0000644000175000017500000011767213113745004025210 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 -> Globals.Vars.find_from_astinfo x VGlobal 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 in_loop: bool (* Only useful for code annotations *) end) = Logic_typing.Make (struct let anonCompFieldName = Cabs2cil.anonCompFieldName let conditionalConversion = Cabs2cil.logicConditionalConversion let is_loop () = X.in_loop let find_macro _ = raise Not_found let find_var x = find_var X.kf x let find_enum_tag x = try Globals.Types.find_enum_tag x with Not_found -> (* The ACSL typer tries to parse a string, first as a variable, then as an enum. We report the "Unbound variable" message here, as it is nicer for the user. However, this short-circuits the later stages of resolution, for example global logic variables. *) raise (Unbound ("Unbound variable " ^ x)) let find_comp_field info s = let field = Cil.getCompField info s in Field(field,NoOffset) let find_type = Globals.Types.find_type 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 (Format.asprintf "term %a has type %a, but %a is expected." Printer.pp_term t Printer.pp_logic_type Linteger Printer.pp_typ ty)) let error loc msg = Pretty_utils.ksfprintf (fun e -> raise (Error (loc, e))) msg end) (** Set up the parser for the infamous 'C hack' needed to parse typedefs *) let sync_typedefs () = Logic_env.reset_typenames (); Globals.Types.iter_types (fun name _ ns -> if ns = Logic_typing.Typedef then Logic_env.add_typename name) let wrap f loc = try f () with Unbound s -> raise (Error (loc, s)) let code_annot kf stmt s = sync_typedefs (); let module LT = DefaultLT(struct let kf = kf let in_loop = Kernel_function.stmt_in_loop kf stmt end) in let loc = Stmt.loc stmt in let pa = match snd (Logic_lexer.annot (fst 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 loc let default_term_env () = Logic_typing.append_here_label (Logic_typing.Lenv.empty()) let term kf ?(loc=Location.unknown) ?(env=default_term_env ()) s = sync_typedefs (); let module LT = DefaultLT(struct let kf = kf let in_loop = false (* unused *) end) in let (_,pa_expr) = Logic_lexer.lexpr (fst loc, s) in let parse () = LT.term env pa_expr in wrap parse loc let term_lval kf ?(loc=Location.unknown) ?(env=default_term_env ()) s = match (term kf ~loc ~env s).term_node with | TLval lv -> lv | _ -> raise (Error (loc, "Syntax error (expecting an lvalue)")) let predicate kf ?(loc=Location.unknown) ?(env=default_term_env ()) s = sync_typedefs (); let module LT = DefaultLT(struct let kf = kf let in_loop = false (* unused *) end) in let (_,pa_expr) = Logic_lexer.lexpr (fst loc, s) in let parse () = LT.predicate env pa_expr in wrap parse loc let error_lval () = raise Db.Properties.Interp.No_conversion 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 | TLogic_coerce(Linteger, t) when Logic_typing.is_integral_type t.term_type -> loc_to_exp ~result t | TLogic_coerce(Lreal, t) when Logic_typing.is_integral_type t.term_type -> List.map (fun x -> new_exp ~loc (CastE (logic_type_to_typ Lreal, x))) (loc_to_exp ~result t) | TLogic_coerce(Lreal, t) when Logic_typing.is_arithmetic_type t.term_type -> loc_to_exp ~result t | TLogic_coerce (set, t) when Logic_const.is_set_type set && Logic_utils.is_same_type (Logic_typing.type_of_set_elem set) t.term_type -> loc_to_exp ~result t | Tnull -> [ Cil.mkCast (Cil.zero ~loc) (TPtr(TVoid [], [])) ] (* additional constructs *) | Tapp _ | Tlambda _ | Trange _ | Tlet _ | TDataCons _ | Tif _ | Tat _ | Tbase_addr _ | Toffset _ | Tblock_length _ | 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 -> [] (* coercions to arithmetic types cannot be lval. We only have to consider a coercion to set here. *) | TLogic_coerce(set, t) when Logic_typing.is_set_type set && Logic_utils.is_same_type (Logic_typing.type_of_set_elem set) t.term_type -> loc_to_lval ~result t | 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 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 follows: - 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 follows: - 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 -> ctx -> (zone_info * decl) (** Entry point to get zones needed to evaluate the [predicate] relative to the [ctx] of interpretation. *) val from_preds: predicate 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 occurring into a [term]. *) let extract_locals_from_term term = extract_locals (extract_free_logicvars_from_term term) (** Predicate utility: Extract C local variables occurring 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_init | AbsLabel_loop_entry | AbsLabel_loop_current | 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 | AbsLabel_init, LogicLabel (_, "Init") -> true | AbsLabel_loop_entry, LogicLabel (_, "LoopEntry") -> true | AbsLabel_loop_current, LogicLabel (_, "LoopCurrent") -> 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 | AbsLabel_init -> raise (NYI "[logic_interp] Init label") | AbsLabel_loop_current -> raise (NYI "[logic_interp] LoopCurrent label") | AbsLabel_loop_entry -> raise (NYI "[logic_interp] LoopEntry label") 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 forbidden inside clauses \ related to 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 forbidden inside clauses \ related to 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 \ forbidden." | 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 \ forbidden." | 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 forbidden 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 forbidden 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_aux: 'a. _ -> 'a -> 'a visitAction = fun lbl x -> self#change_label lbl 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 forbidden inside clauses related \ to 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_node p = let fail () = raise (NYI (Pretty_utils.sfprintf "[logic_interp] %a" Printer.pp_predicate_node 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 (_, LogicLabel (_,"Init")) -> self#change_label_aux AbsLabel_init p | Pat (_, LogicLabel (_,"LoopCurrent")) -> self#change_label_aux AbsLabel_loop_current p | Pat (_, LogicLabel (_,"LoopEntry")) -> self#change_label_aux AbsLabel_loop_entry p | Pat (_, LogicLabel (_,s)) -> failwith ("unknown logic label" ^ s) | Pat (_, StmtLabel st) -> self#change_label_to_stmt !st p | 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) | Pdangling (lbl, t) -> (* Dependencies of [\initialized(p)] or [\dangling(p)] are the dependencies of [*p]. *) 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 | Pvalid_function _ -> DoChildren | Papp _ | Pallocable _ | Pfreeable _ | Pfresh _ | Psubtype _ -> fail () method private do_term_lval t = let current_before, current_stmt = self#get_ctrl_point () in let state = Db.Value.get_stmt_state current_stmt in try let deps = !Db.From.find_deps_term_no_transitivity_state state t in (* TODO: what we should we do with other program points? *) let z = Logic_label.Map.find (LogicLabel (None,"Here")) deps in let z = Locations.Zone.filter_base (function Base.CLogic_Var _ -> false | _ -> true) z in add_result current_before current_stmt z with Db.From.Not_lval -> raise (NYI "[logic_interp] dependencies of a term lval") 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 (_, LogicLabel (_,"Init")) -> self#change_label_aux AbsLabel_init t | Tat (_, LogicLabel (_,"LoopCurrent")) -> self#change_label_aux AbsLabel_loop_current t | Tat (_, LogicLabel (_,"LoopEntry")) -> self#change_label_aux AbsLabel_loop_entry t | Tat (_, StmtLabel st) -> self#change_label_to_stmt !st t | Tat (_, LogicLabel (_,s)) -> failwith ("unknown logic label" ^ s) | TSizeOf _ | TSizeOfE _ | TSizeOfStr _ | TAlignOf _ | TAlignOfE _ -> (* These are static constructors, there are no dependencies here *) SkipChildren | _ -> 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.visitFramacPredicate (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.visitFramacPredicate (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 = 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.visitFramacPredicate (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") | AExtended _ -> raise (NYI "[logic_interp] extension") (** 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 _ | AExtended _ (* TODO *) -> 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.visitFramacPredicate visitor p); false with Prune -> true) let () = Db.Properties.Interp.code_annot := code_annot; Db.Properties.Interp.term_lval := term_lval; Db.Properties.Interp.term := term; Db.Properties.Interp.predicate := predicate; 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.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-Phosphorus-20170501/src/kernel_services/analysis/wto_statement.ml0000644000175000017500000001133413113745003025412 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 wto = stmt Wto.partition (* ********************************************************************** *) (** {Interface to the Wto module} *) (* ********************************************************************** *) module Scheduler = Wto.Make (struct include Cil_datatype.Stmt let pretty fmt s = Format.pp_print_int fmt s.sid end) let build_wto kf = let init = Kernel_function.find_first_stmt kf and succs = fun stmt -> List.rev stmt.succs in Scheduler.partition ~init ~succs (* ********************************************************************** *) (** {Datatype and State} *) (* ********************************************************************** *) (** {WTO as datatype} *) module WTO = Datatype.Make (struct include Datatype.Serializable_undefined type t = wto let name = "Wto_statement.WTO" let pretty = Scheduler.pretty_partition let copy w = w let reprs = [List.map (fun s -> Wto.Node s) Cil_datatype.Stmt.reprs] end) module WTOState = Kernel_function.Make_Table (WTO) (struct let size = 97 let name = "Wto_statement.WTOState" let dependencies = [Ast.self] end) (** Returns the wto of a kernel function *) let wto_of_kf = WTOState.memo build_wto;; (* ********************************************************************** *) (** {WTO Indexes} *) (* ********************************************************************** *) type wto_index = stmt list module WTOIndex = Datatype.Make (struct include Datatype.Serializable_undefined type t = wto_index let reprs = [Cil_datatype.Stmt.reprs] let name = "Wto_statement.WTOIndex" let pretty = Pretty_utils.pp_list ~sep:"," (fun fmt stmt -> Format.pp_print_int fmt stmt.sid) let copy w = w end) module StmtTable = Cil_datatype.Stmt.Hashtbl module WTOIndexState = Kernel_function.Make_Table (StmtTable.Make (WTOIndex)) (struct let size = 97 let name = "Wto_statement.WTOIndexState" let dependencies = [Ast.self] end) let build_wto_index_table kf = let table = StmtTable.create 17 in let rec iter_wto index w = List.iter (iter_element index) w and iter_element index = function | Wto.Node s -> StmtTable.add table s index | Wto.Component (h, w) -> let new_index = h :: index in iter_wto new_index (Wto.Node h :: w) in iter_wto [] (wto_of_kf kf); table let get_wto_index_table = WTOIndexState.memo build_wto_index_table let wto_index_of_stmt stmt = let kf = Kernel_function.find_englobing_kf stmt in let table = get_wto_index_table kf in try StmtTable.find table stmt with Not_found -> [] let wto_index_diff index1 index2 = let rec remove_common_prefix l1 l2 = match l1, l2 with | x :: l1, y :: l2 when Cil_datatype.Stmt.equal x y -> remove_common_prefix l1 l2 | l1, l2 -> l1, l2 in let l1 = List.rev index1 and l2 = List.rev index2 in let left, entered = remove_common_prefix l1 l2 in List.rev left, entered let wto_index_diff_of_stmt stmt1 stmt2 = wto_index_diff (wto_index_of_stmt stmt1) (wto_index_of_stmt stmt2) frama-c-Phosphorus-20170501/src/kernel_services/analysis/exn_flow.ml0000644000175000017500000007570413113745012024351 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 let dkey = Kernel.register_category "exn_flow" (* all exceptions that can be raised somewhere in the AST. Used to handle function pointers without exn specification *) module All_exn = State_builder.Option_ref(Cil_datatype.Typ.Set) (struct let name = "Exn_flow.All_exn" let dependencies = [Ast.self] end) module Exns = State_builder.Hashtbl(Kernel_function.Hashtbl)(Cil_datatype.Typ.Set) (struct let name = "Exn_flow.Exns" let dependencies = [Ast.self; All_exn.self] let size = 47 end) module ExnsStmt = State_builder.Hashtbl(Cil_datatype.Stmt.Hashtbl)(Cil_datatype.Typ.Set) (struct let name = "Exn_flow.ExnsStmt" let dependencies = [Ast.self; All_exn.self] let size = 53 end) let self_fun = Exns.self let self_stmt = ExnsStmt.self let purify t = let t = Cil.unrollTypeDeep t in Cil.type_remove_qualifier_attributes_deep t class all_exn = object inherit Visitor.frama_c_inplace val mutable all_exn = Cil_datatype.Typ.Set.empty method get_exn = all_exn method! vstmt_aux s = match s.skind with | Throw (Some (_,t),_) -> all_exn <- Cil_datatype.Typ.Set.add (purify t) all_exn; SkipChildren | _ -> DoChildren end let compute_all_exn () = let vis = new all_exn in Visitor.visitFramacFileSameGlobals (vis:>Visitor.frama_c_visitor) (Ast.get()); vis#get_exn let all_exn () = All_exn.memo compute_all_exn let add_exn_var exns v = let t = Cil.unrollTypeDeep v.vtype in let t = Cil.type_remove_qualifier_attributes t in Cil_datatype.Typ.Set.add t exns let add_exn_clause exns (v,_) = add_exn_var exns v (* We're not really interested by intra-procedural Dataflow here: all the interesting stuff happens at inter-procedural level (except for Throw encapsulated directly in a TryCatch, but even then it is easily captured at syntactical level). Therefore, we can as well use a syntactic pass at intra-procedural level *) class exn_visit = object (self) inherit Visitor.frama_c_inplace val stack = Stack.create () val possible_exn = Stack.create () (* current set of exn included in a catch-all clause. Used to handle Throw None; *) val current_exn = Stack.create () method private recursive_call kf = try Stack.iter (fun (kf',_) -> if Kernel_function.equal kf kf' then raise Exit) stack; false with Exit -> true method private add_exn t = let current_uncaught = Stack.top possible_exn in current_uncaught:= Cil_datatype.Typ.Set.add t !current_uncaught method private union_exn s = let current_uncaught = Stack.top possible_exn in current_uncaught := Cil_datatype.Typ.Set.union s !current_uncaught method! vstmt_aux s = match s.skind with | Throw (None,_) -> let my_exn = Stack.top current_exn in self#union_exn my_exn; ExnsStmt.replace s my_exn; SkipChildren | Throw(Some (_,t),_) -> let t = Cil.unrollTypeDeep t in let t = Cil.type_remove_qualifier_attributes t in self#add_exn t; ExnsStmt.replace s (Cil_datatype.Typ.Set.singleton t); SkipChildren | TryCatch (t,c,_) -> let catch, catch_all = List.fold_left (fun (catch, catch_all) -> function | (Catch_all,_) -> catch, true | (Catch_exn(v,[]),_) -> let catch = add_exn_var catch v in catch, catch_all | (Catch_exn(_,aux), _) -> let catch = List.fold_left add_exn_clause catch aux in catch, catch_all) (Cil_datatype.Typ.Set.empty,false) c in Stack.push (ref Cil_datatype.Typ.Set.empty) possible_exn; ignore (Visitor.visitFramacBlock (self:>Visitor.frama_c_inplace) t); let my_exn = Stack.pop possible_exn in let uncaught = Cil_datatype.Typ.Set.diff !my_exn catch in (* uncaught exceptions are lift to previous set of exn, but only if there's no catch-all clause. *) Stack.push (ref Cil_datatype.Typ.Set.empty) possible_exn; if not catch_all then self#union_exn uncaught; List.iter (fun (v,b) -> (match v with | Catch_all -> (* catch_all will catch all exceptions that are not already handled by a previous clause. It must be the last handler (C++11, 15.3§5), thus there's no handler ordering issue *) Stack.push uncaught current_exn | Catch_exn (v,[]) -> let catch = add_exn_var Cil_datatype.Typ.Set.empty v in Stack.push catch current_exn | Catch_exn (_,aux) -> let catch = List.fold_left add_exn_clause Cil_datatype.Typ.Set.empty aux in Stack.push catch current_exn); ignore (Visitor.visitFramacBlock (self:>Visitor.frama_c_inplace) b); ignore (Stack.pop current_exn)) c; let my_exn = !(Stack.pop possible_exn) in ExnsStmt.replace s my_exn; self#union_exn my_exn; SkipChildren | If _ | Switch _ | Loop _ | Block _ | UnspecifiedSequence _ | TryFinally _ | TryExcept _ | Instr _ -> (* must take into account exceptions thrown by a fun call*) Stack.push (ref Cil_datatype.Typ.Set.empty) possible_exn; DoChildrenPost (fun s -> let my_exn = !(Stack.pop possible_exn) in ExnsStmt.replace s my_exn; self#union_exn my_exn; s) (* No exception can be thrown here. *) | Return _ | Goto _ | Break _ | Continue _ -> ExnsStmt.replace s Cil_datatype.Typ.Set.empty; SkipChildren method! vinst = function | Call(_,{ enode = Lval(Var f,NoOffset) },_,_) | Local_init(_, ConsInit(f, _, _), _) -> let kf = Globals.Functions.get f in if self#recursive_call kf then begin let module Found = struct exception F of Cil_datatype.Typ.Set.t end in let computed_exn = try Stack.iter (fun (kf', exns) -> if Kernel_function.equal kf kf' then raise (Found.F !exns)) stack; Kernel.fatal "No cycle found!" with Found.F exns -> exns in let known_exn = try Exns.find kf with Not_found -> Cil_datatype.Typ.Set.empty in if Cil_datatype.Typ.Set.subset computed_exn known_exn then begin (* Fixpoint found, no need to recurse. *) self#union_exn known_exn end else begin (* add known exns in table and recurse. Termination is ensured by the fact that only a finite number of exceptions can be thrown. *) let kf_exn = Cil_datatype.Typ.Set.union computed_exn known_exn in Exns.replace kf kf_exn; ignore (Visitor.visitFramacFunction (self:>Visitor.frama_c_visitor) (Kernel_function.get_definition kf)); let callee_exn = Exns.find kf in self#union_exn callee_exn end end else if Exns.mem kf then begin self#union_exn (Exns.find kf) end else if Kernel_function.is_definition kf then begin let def = Kernel_function.get_definition kf in ignore (Visitor.visitFramacFunction (self:>Visitor.frama_c_visitor) def); let callee_exn = Exns.find kf in self#union_exn callee_exn end else begin (* TODO: introduce extension to declare exceptions that can be thrown by prototypes. *) Kernel.warning "Assuming declared function %a can't throw any exception" Kernel_function.pretty kf end; SkipChildren | Call _ -> (* Function pointer: we consider that it can throw any possible exception. *) self#union_exn (all_exn()); SkipChildren | _ -> SkipChildren method! vfunc f = let my_exns = ref Cil_datatype.Typ.Set.empty in let kf = Globals.Functions.get f.svar in Stack.push (kf,my_exns) stack; Stack.push my_exns possible_exn; let after_visit f = let callee_exn = Stack.pop possible_exn in Exns.add kf !callee_exn; ignore (Stack.pop stack); f in DoChildrenPost after_visit end let compute_kf kf = if Kernel_function.is_definition kf then ignore (Visitor.visitFramacFunction (new exn_visit) (Kernel_function.get_definition kf)) (* just ignore prototypes. *) let compute () = Globals.Functions.iter compute_kf let get_type_tag t = let rec aux t = match t with | TVoid _ -> "v" | TInt (IBool,_) -> "B" | TInt (IChar,_) -> "c" | TInt (ISChar,_) -> "sc" | TInt (IUChar,_) -> "uc" | TInt (IInt,_) -> "i" | TInt (IUInt,_) -> "ui" | TInt (IShort,_) -> "s" | TInt (IUShort,_) -> "us" | TInt (ILong,_) -> "l" | TInt (IULong,_) -> "ul" | TInt (ILongLong,_) -> "ll" | TInt (IULongLong,_) -> "ull" | TFloat(FFloat,_) -> "f" | TFloat(FDouble,_) -> "d" | TFloat (FLongDouble,_) -> "ld" | TPtr(t,_) -> "p" ^ aux t | TArray(t,_,_,_) -> "a" ^ aux t | TFun(rt,l,_,_) -> let base = "fun" ^ aux rt in (match l with | None -> base | Some l -> List.fold_left (fun acc (_,t,_) -> acc ^ aux t) base l) | TNamed _ -> Kernel.fatal "named type not correctly unrolled" | TComp (s,_,_) -> (if s.cstruct then "S" else "U") ^ s.cname | TEnum (e,_) -> "E" ^ e.ename | TBuiltin_va_list _ -> "va" in "__fc_" ^ aux t let get_type_enum t = "__fc_exn_kind_" ^ (get_type_tag t) let get_kf_exn kf = if not (Exns.is_computed()) then compute(); Exns.find kf let exn_uncaught_name = "exn_uncaught" let exn_kind_name = "exn_kind" let exn_obj_name = "exn_obj" (* enumeration for all possible exceptions *) let generate_exn_enum exns = let loc = Cil_datatype.Location.unknown in let v = ref 0 in let info = { eorig_name = "__fc_exn_enum"; ename = "__fc_exn_enum"; eitems = []; eattr = []; ereferenced = true; (* not generated if no exn can be thrown *) ekind = IInt; (* Take into account -enum option? *) } in let create_enum_item t acc = let ve = Cil.kinteger ~loc IInt !v in let name = get_type_enum t in incr v; { eiorig_name = name; einame = name; eival = ve; eihost = info; eiloc = loc; } :: acc in let enums = Cil_datatype.Typ.Set.fold create_enum_item exns [] in info.eitems <- enums; info (* discriminated union (i.e. struct + union) for all possible exceptions. *) let generate_exn_union e exns = let loc = Cil_datatype.Location.unknown in let create_union_fields _ = let add_one_field t acc = (get_type_tag t, t, None, [], loc) :: acc in Cil_datatype.Typ.Set.fold add_one_field exns [] in let union_name = "__fc_exn_union" in let exn_kind_union = Cil.mkCompInfo false union_name ~norig:union_name create_union_fields [] in let create_struct_fields _ = let uncaught = (exn_uncaught_name, Cil.intType, None, [], loc) in let kind = (exn_kind_name, TEnum (e,[]), None, [], loc) in let obj = (exn_obj_name, TComp(exn_kind_union, { scache = Not_Computed } , []), None, [], loc) in [uncaught; kind; obj] in let struct_name = "__fc_exn_struct" in let exn_struct = Cil.mkCompInfo true struct_name ~norig:struct_name create_struct_fields [] in exn_kind_union, exn_struct let add_types_and_globals typs globs f = let iter_globs (acc,added) g = match g with | GVarDecl _ | GVar _ | GFun _ as g when not added -> (g :: List.rev_append globs (List.rev_append typs acc), true) | _ -> g :: acc, added in let globs, added = List.fold_left iter_globs ([],false) f.globals in let globs = if added then List.rev globs else List.rev_append globs (List.rev_append typs globs) in f.globals <- globs; f let make_init_assign loc v init = let rec aux lv acc = function | SingleInit e -> Cil.mkStmtOneInstr (Set(lv,e,loc)) :: acc | CompoundInit(_,l) -> let treat_one_offset acc (o,i) = aux (Cil.addOffsetLval o lv) acc i in List.fold_left treat_one_offset acc l in List.rev (aux (Var v, NoOffset) [] init) let find_exns_func v = try Exns.find (Globals.Functions.get v) with Not_found -> Cil_datatype.Typ.Set.empty let find_exns e = match e.enode with | Lval(Var v, NoOffset) -> find_exns_func v | _ -> all_exn () class erase_exn = object(self) inherit Visitor.frama_c_inplace (* reverse before filling. *) val mutable new_types = [] val exn_enum = Cil_datatype.Typ.Hashtbl.create 7 val exn_union = Cil_datatype.Typ.Hashtbl.create 7 val mutable modified_funcs = Cil_datatype.Fundec.Set.empty val mutable exn_struct = None val mutable exn_var = None val mutable can_throw = false val mutable catched_var = None val mutable label_counter = 0 val exn_labels = Cil_datatype.Typ.Hashtbl.create 7 val catch_all_label = Stack.create () method modified_funcs = modified_funcs method private update_enum_bindings enum exns = let update_one_binding t = let s = get_type_enum t in let ei = List.find (fun ei -> ei.einame = s) enum.eitems in Cil_datatype.Typ.Hashtbl.add exn_enum t ei in Cil_datatype.Typ.Set.iter update_one_binding exns method private update_union_bindings union exns = let update_one_binding t = let s = get_type_tag t in Kernel.debug ~dkey "Registering %a as possible exn type" Cil_datatype.Typ.pretty t; let fi = List.find (fun fi -> fi.fname = s) union.cfields in Cil_datatype.Typ.Hashtbl.add exn_union t fi in Cil_datatype.Typ.Set.iter update_one_binding exns method private exn_kind t = Cil_datatype.Typ.Hashtbl.find exn_enum t method private is_thrown t = Cil_datatype.Typ.Hashtbl.mem exn_enum t method private exn_field_off name = List.find (fun fi -> fi.fname = name) (Extlib.the exn_struct).cfields method private exn_field name = Var (Extlib.the exn_var), Field(self#exn_field_off name, NoOffset) method private exn_field_term name = TVar(Cil.cvar_to_lvar (Extlib.the exn_var)), TField(self#exn_field_off name, TNoOffset) method private exn_obj_field = self#exn_field exn_obj_name method private exn_obj_field_term = self#exn_field_term exn_obj_name method private exn_kind_field = self#exn_field exn_kind_name method private exn_kind_field_term = self#exn_field_term exn_kind_name method private uncaught_flag_field = self#exn_field exn_uncaught_name method private uncaught_flag_field_term = self#exn_field_term exn_uncaught_name method private exn_obj_kind_field t = Kernel.debug ~dkey "Searching for %a as possible exn type" Cil_datatype.Typ.pretty t; Cil_datatype.Typ.Hashtbl.find exn_union t method private test_uncaught_flag loc b = let e1 = Cil.new_exp ~loc (Lval self#uncaught_flag_field) in let e2 = if b then Cil.one ~loc else Cil.zero ~loc in Cil.new_exp ~loc (BinOp(Eq,e1,e2,Cil.intType)) method private pred_uncaught_flag loc b = let e1 = Logic_const.term ~loc (TLval self#uncaught_flag_field_term) Linteger in let e2 = if b then Logic_const.tinteger ~loc 1 else Logic_const.tinteger ~loc 0 in Logic_const.prel ~loc (Req,e1,e2) method private set_uncaught_flag loc b = let e = if b then Cil.one ~loc else Cil.zero ~loc in Cil.mkStmtOneInstr (Set(self#uncaught_flag_field,e,loc)) method private set_exn_kind loc t = let e = self#exn_kind (purify t) in let e = Cil.new_exp ~loc (Const (CEnum e)) in Cil.mkStmtOneInstr(Set(self#exn_kind_field,e,loc)) method private set_exn_value loc t e = let lv = self#exn_obj_field in let union_field = self#exn_obj_kind_field (purify t) in let lv = Cil.addOffsetLval (Field (union_field, NoOffset)) lv in Cil.mkStmtOneInstr (Set(lv,e,loc)) method private jumps_to_default_handler loc = if Stack.is_empty catch_all_label then begin (* no catch-all clause in the function: just go up in the stack. *) let kf = Extlib.the self#current_kf in let ret = Kernel_function.find_return kf in let rtyp = Kernel_function.get_return_type kf in if ret.labels = [] then ret.labels <- [Label("__ret_label",Cil_datatype.Stmt.loc ret,false)]; let goto = mkStmt (Goto (ref ret,loc)) in match ret.skind with | Return (None,_) -> [goto] (* rt is void: do not need to create a dummy return value *) | Return (Some { enode = Lval(Var rv, NoOffset) },_) -> let init = Cil.makeZeroInit ~loc rtyp in make_init_assign loc rv init @ [goto] | Return _ -> Kernel.fatal "exception removal should be used after oneRet" | _ -> Kernel.fatal "find_return did not give a Return statement" end else begin let stmt = Stack.top catch_all_label in [mkStmt (Goto (ref stmt, loc))] end method private jumps_to_handler loc t = let t = purify t in try let stmt = Cil_datatype.Typ.Hashtbl.find exn_labels t in [mkStmt (Goto (ref stmt, loc))] with | Not_found -> self#jumps_to_default_handler loc method! vfile f = let exns = all_exn () in if not (Cil_datatype.Typ.Set.is_empty exns) then begin let loc = Cil_datatype.Location.unknown in let e = generate_exn_enum exns in let u,s = generate_exn_union e exns in let exn = Cil.makeGlobalVar "__fc_exn" (TComp (s,{scache = Not_Computed},[])) in self#update_enum_bindings e exns; self#update_union_bindings u exns; exn_struct <- Some s; can_throw <- true; new_types <- GCompTag (s,loc) :: GCompTag (u,loc) :: GEnumTag (e,loc) :: new_types; exn_var <- Some exn; let exn_init = Cil.makeZeroInit ~loc (TComp(s,{scache=Not_Computed},[])) in let gexn_var = GVar(exn, { init = Some exn_init }, loc) in ChangeDoChildrenPost( f,add_types_and_globals (List.rev new_types) [gexn_var]) end else (* nothing can be thrown in the first place, but we still have to get rid of (useless) try/catch blocks if any. *) DoChildren method private visit_catch_clause loc (v,b) = let loc = match b.bstmts with | [] -> loc | [x] -> Cil_datatype.Stmt.loc x | x::tl -> fst (Cil_datatype.Stmt.loc x), snd (Cil_datatype.Stmt.loc (Extlib.last tl)) in let add_unreachable_block b = Cil.mkStmt (If(Cil.zero ~loc, b, Cil.mkBlock [], loc)) in let assign_catched_obj v b = let exn_obj = self#exn_obj_field in let kind_field = self#exn_obj_kind_field (purify v.vtype) in let lv = Cil.addOffsetLval (Field (kind_field,NoOffset)) exn_obj in let s = Cil.mkStmtOneInstr (Set ((Var v, NoOffset), Cil.new_exp ~loc (Lval lv), loc)) in b.bstmts <- s :: b.bstmts in let f = Extlib.the self#current_func in let update_locals v b = if not (List.memq v b.blocals) then b.blocals <- v::b.blocals; if not (List.memq v f.slocals) then f.slocals <- v::f.slocals in let b = (match v with | Catch_all -> b | Catch_exn (v,[]) -> v.vtype <- purify v.vtype; update_locals v b;assign_catched_obj v b; b | Catch_exn(v,aux) -> let add_one_aux stmts (v,b) = v.vtype <- purify v.vtype; update_locals v b; assign_catched_obj v b; add_unreachable_block b :: stmts in b.blocals <- List.filter (fun v' -> v!=v') b.blocals; let aux_blocks = List.fold_left add_one_aux [Cil.mkStmt (Block b)] aux in let main_block = Cil.mkBlock aux_blocks in v.vtype <- purify v.vtype; update_locals v main_block; main_block) in ignore (Visitor.visitFramacBlock (self :> Visitor.frama_c_visitor) b); add_unreachable_block b method! vfunc _ = label_counter <- 0; DoChildren method private modify_current () = modified_funcs <- Cil_datatype.Fundec.Set.add (Extlib.the self#current_func) modified_funcs; method private aux_handler_goto target (v,b) = let loc = v.vdecl in let goto_main_handler = Cil.mkStmt (Goto (ref target,loc)) in let suf = if label_counter = 0 then "" else "_" ^ (string_of_int label_counter) in let lab = (get_type_tag (purify v.vtype)) ^ suf in label_counter <- label_counter + 1; b.bstmts <- b.bstmts @ [goto_main_handler]; (* we have at least the goto statement in the block *) let s = List.hd b.bstmts in s.labels <- (Label(lab,loc,false)::s.labels); Cil_datatype.Typ.Hashtbl.add exn_labels (purify v.vtype) s method private guard_post_cond (kind,pred as orig) = match kind with (* If we exit explicitly with exit, we haven't seen an uncaught exception anyway. *) | Exits | Breaks | Continues -> orig | Returns | Normal -> let loc = pred.ip_content.pred_loc in let p = self#pred_uncaught_flag loc false in let pred' = Logic_const.pred_of_id_pred pred in (kind, (Logic_const.new_predicate (Logic_const.pimplies ~loc (p,pred')))) method! vbehavior b = match self#current_kf, self#current_stmt with | None, None -> SkipChildren (* Prototype is assumed to not throw any exception. *) | None, Some _ -> Kernel.fatal "Inconsistent visitor state: visiting a statement \ outside of any function." | Some f, None when not (Kernel_function.is_definition f) -> (* By hypothesis, prototypes do not throw anything. *) SkipChildren | Some f, None -> (* function contract *) let exns = Exns.find f in if Cil_datatype.Typ.Set.is_empty exns then SkipChildren else begin b.b_post_cond <- List.map self#guard_post_cond b.b_post_cond; ChangeTo b (* need to register the new clauses. *) end | Some _, Some s -> (* statement contract *) let exns = ExnsStmt.find s in if Cil_datatype.Typ.Set.is_empty exns then SkipChildren else begin b.b_post_cond <- List.map self#guard_post_cond b.b_post_cond; ChangeTo b end method private clean_catch_clause (bind,b as handler) acc = let remove_local v = let f = Cil.get_fundec self#behavior (Extlib.the self#current_func) in let v = Cil.get_varinfo self#behavior v in f.slocals <- List.filter (fun v' -> v!=v') f.slocals; in match bind with | Catch_all -> handler :: acc | Catch_exn (v, []) -> if self#is_thrown (purify v.vtype) then handler :: acc else begin remove_local v; acc end | Catch_exn (v, l) -> let caught, remove = List.partition (fun (v,_) -> self#is_thrown (purify v.vtype)) l in List.iter (fun (v,_) -> remove_local v) remove; if caught = [] then begin remove_local v; acc end else (Catch_exn (v,caught), b) :: acc method! vstmt_aux s = let generate_jumps instr exns loc = if Cil_datatype.Typ.Set.is_empty exns then SkipChildren else begin self#modify_current (); let make_jump t (stmts, uncaught) = let t = purify t in if Cil_datatype.Typ.Hashtbl.mem exn_labels t then begin let e = self#exn_kind t in let e = Cil.new_exp ~loc (Const (CEnum e)) in let b = self#jumps_to_handler loc t in let s = Cil.mkStmt (Block (Cil.mkBlock b)) in s.labels <- [Case (e,loc)]; s::stmts, uncaught end else stmts, true in let stmts, uncaught = Cil_datatype.Typ.Set.fold make_jump exns ([],false) in let stmts = if uncaught then begin let default = Cil.mkStmt ( Block (Cil.mkBlock (self#jumps_to_default_handler loc))) in default.labels <- [Default loc]; List.rev_append stmts [default] end else List.rev stmts in let test = self#test_uncaught_flag loc true in let cases = Cil.new_exp ~loc (Lval self#exn_kind_field) in let switch = Cil.mkStmt (Switch(cases,Cil.mkBlock stmts,stmts,loc)) in let handler = Cil.mkStmt (If(test,Cil.mkBlock [switch],Cil.mkBlock [],loc)) in let instr = Visitor.visitFramacInstr (self:>Visitor.frama_c_visitor) instr in let call = Cil.mkStmtOneInstr (List.hd instr) in s.skind <- Block (Cil.mkBlockNonScoping [call;handler]); SkipChildren end in match s.skind with | Instr (Call (_,f,_,loc) as instr) -> generate_jumps instr (find_exns f) loc | Instr (Local_init(_, ConsInit(f,_,_), loc) as instr) -> generate_jumps instr (find_exns_func f) loc | Throw _ when not can_throw -> Kernel.fatal "Unexpected Throw statement" | Throw(Some(e,t),loc) -> self#modify_current(); let s1 = self#set_uncaught_flag loc true in let s2 = self#set_exn_kind loc t in let s3 = self#set_exn_value loc t e in let rv = self#jumps_to_handler loc t in let b = mkBlock (s1 :: s2 :: s3 :: rv) in s.skind <- Block b; SkipChildren | Throw (None,loc) -> self#modify_current (); let s1 = self#set_uncaught_flag loc true in let t = purify (Extlib.the exn_var).vtype in let rv = self#jumps_to_handler loc t in let b = mkBlock (s1 :: rv) in s.skind <- Block b; SkipChildren | TryCatch (t,_,_) when not can_throw -> self#modify_current(); (* no exception can be thrown: we can simply remove the catch clauses. *) s.skind <- (Block t); DoChildren (* visit the block for nested try catch. *) | TryCatch (t,c,loc) -> self#modify_current(); (* First, remove handlers of exceptions that cannot be thrown. *) let c = List.fold_right self#clean_catch_clause c [] in (* Visit the catch clauses first, as they are in the same catch scope than the current block. As we are adding statements in the auxiliary blocks, we need to do that before adding labels to the entry points of these blocks. *) let stmts = List.map (self#visit_catch_clause loc) c in let suf = if label_counter = 0 then "" else "_" ^ (string_of_int label_counter) in label_counter <- label_counter + 1; (* now generate the labels for jumping to the appropriate block when catching an exception. *) List.iter (function | (Catch_exn (v,aux),b) -> (* first thing that we do is to flag the exn as caught *) let stmt = self#set_uncaught_flag v.vdecl false in let label = (get_type_tag (purify v.vtype)) ^ suf in stmt.labels <- [Label (label,v.vdecl,false)]; b.bstmts <- stmt :: b.bstmts; (match aux with | [] -> Cil_datatype.Typ.Hashtbl.add exn_labels (purify v.vtype) stmt | _ :: _ -> List.iter (self#aux_handler_goto stmt) aux) | (Catch_all, b) -> let loc = match b.bstmts with [] -> loc | s::_ -> Cil_datatype.Stmt.loc s in let stmt = self#set_uncaught_flag loc false in stmt.labels <- [Label ("catch_all" ^ suf,loc,false)]; b.bstmts <- stmt :: b.bstmts; Stack.push stmt catch_all_label) (* We generate the bindings in reverse order, as if two clauses match the same type, the first one (which is the one that has to be taken), will be visited last, hiding the binding of the second in the Hashtbl. *) (List.rev c); ignore (Visitor.visitFramacBlock (self:>Visitor.frama_c_visitor) t); List.iter (function | (Catch_exn (v,[]), _) -> Cil_datatype.Typ.Hashtbl.remove exn_labels (purify v.vtype) | Catch_exn(_,l), _ -> List.iter (fun (v,_) -> Cil_datatype.Typ.Hashtbl.remove exn_labels (purify v.vtype)) l | Catch_all,_ -> ignore (Stack.pop catch_all_label)) c; (* we remove bindings in the reverse order as we added them, though order does not really matter here. *) t.bstmts <- t.bstmts @ stmts; s.skind <- Block t; SkipChildren | _ -> DoChildren end let prepare_file f = if Kernel.SimplifyCfg.get () then begin Cfg.prepareCFG ~keepSwitch:false f; end; File.must_recompute_cfg f let remove_exn f = if Kernel.RemoveExn.get() then begin Visitor.visitFramacFileSameGlobals (new exn_visit) f; let vis = new erase_exn in Visitor.visitFramacFile (vis :> Visitor.frama_c_visitor) f; Cil_datatype.Fundec.Set.iter prepare_file vis#modified_funcs end let transform_category = File.register_code_transformation_category "remove_exn" let () = let deps = [ (module Kernel.RemoveExn: Parameter_sig.S) ] in File.add_code_transformation_after_cleanup ~deps transform_category remove_exn frama-c-Phosphorus-20170501/src/kernel_services/analysis/bit_utils.ml0000644000175000017500000005611713113745002024522 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 (** [sizeof(char)] in bits *) let sizeofchar () = Integer.of_int (bitsSizeOf charType) (** [sizeof(char* )] in bits *) let sizeofpointer () = bitsSizeOf theMachine.upointType (** 2^(8 * sizeof( void * )) *) let max_byte_size () = Integer.two_power_of_int (sizeofpointer()) (** 8 * 2^(8 * sizeof( void * )) *) let max_bit_size () = Integer.mul (sizeofchar()) (max_byte_size ()) (** 2^(8 x sizeof( void * )) - 1 *) let max_byte_address () = Integer.pred (max_byte_size()) (** 8 * 2^(8 x sizeof( void * )) - 1 *) let max_bit_address () = Integer.pred (max_bit_size()) let warn_if_zero ty r = if r = 0 then Kernel.warning "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 (Integer.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 (Integer.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 (Integer.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.fatal "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) (* -------------------------------------------------------------------------- *) (* --- 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 : Integer.t ; mutable misaligned : bool ; mutable types: types ; } type bfinfo = Other | Bitfield of int64 type fieldpart = | NamedField of string * bfinfo * typ * Integer.t * Integer.t * Integer.t (* name, parameters to pretty_bits_internal for the field *) | RawField of char * Integer.t * Integer.t (* parameters for raw_bits of the raw field *) type arraypart = | ArrayPart of Integer.t * Integer.t * typ * Integer.t * Integer.t * Integer.t (* start index, stop index, typ of element , align , start, stop *) let rec pretty_bits_internal env bfinfo typ ~align ~start ~stop = assert ( Integer.le Integer.zero align && Integer.lt align env.rh_size); assert (if (Integer.lt start Integer.zero || Integer.lt stop Integer.minus_one) then (Format.printf "start: %a stop: %a@." Abstract_interp.Int.pretty start Abstract_interp.Int.pretty stop; false) else true); let update_types typ = env.types <- update_types env.types typ in let req_size = Integer.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 (Integer.equal (Integer.pos_rem start env.rh_size) align)) || (not (Integer.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 Integer.equal stop (max_bit_address ()) then Format.fprintf fmt "bits %a to .." Abstract_interp.Int.pretty start else Format.fprintf fmt "bits %a to %a" Abstract_interp.Int.pretty start Abstract_interp.Int.pretty stop ) (if cond then (env.misaligned <- true ; "#") else "") in assert (if (Integer.lt req_size Integer.zero || Integer.lt start Integer.zero || Integer.lt stop Integer.minus_one) then (Format.printf "req_s: %a start: %a stop: %a@." Abstract_interp.Int.pretty req_size Abstract_interp.Int.pretty start Abstract_interp.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 -> Integer.of_int (bitsSizeOf typ) | Bitfield i -> Integer.of_int64 i in (if Integer.is_zero start && Integer.equal size req_size then (** pretty print a full offset *) (if not env.use_align || (Integer.equal start align && Integer.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 -> let size = Integer.of_int (try bitsSizeOf typ with SizeOfError _ -> 0) in if (not env.use_align) && Integer.compare req_size size = 0 then update_types typ (* do not print sub-fields if the size is exactly the right one and the alignment is not important *) else begin try 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 = Integer.of_int start_o, Integer.of_int width_o in let new_start = if compinfo.cstruct then Integer.max Integer.zero (Integer.sub start start_o) else start in let new_stop = if compinfo.cstruct then Integer.min (Integer.sub stop start_o) (Integer.pred width_o) else stop in if Integer.le new_start new_stop then let new_bfinfo = match field.fbitfield with | None -> Other | Some i -> Bitfield (Integer.to_int64 (Integer.of_int i)) in let new_align = Integer.pos_rem (Integer.sub align start_o) env.rh_size in let name = Format.asprintf "%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 = Integer.of_int start_o, Integer.of_int width_o in let succ_stop_o = Integer.add start_o width_o in if Integer.gt start_o stop then acc else if Integer.le succ_stop_o start then acc else if Integer.gt start_o last_field_offset then (* found a hole *) (RawField('c', last_field_offset,Integer.pred start_o)::s, succ_stop_o) else (s,succ_stop_o) ) (full_fields_to_print,start) compinfo.cfields else full_fields_to_print, Integer.zero in let overflowing = if compinfo.cstruct && Integer.le succ_last stop then RawField('o',Integer.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 '}' with Cil.SizeOfError _ -> raw_bits '?' start stop end | TArray (typ, _, _, _) -> let size = try Integer.of_int (bitsSizeOf typ) with Cil.SizeOfError _ -> Integer.zero in if Integer.is_zero size then raw_bits 'z' start stop else let start_case = Integer.pos_div start size in let stop_case = Integer.pos_div stop size in let rem_start_size = Integer.pos_rem start size in let rem_stop_size = Integer.pos_rem stop size in if Integer.equal start_case stop_case then (** part of one element *) let new_align = Integer.pos_rem (Integer.sub align (Integer.mul start_case size)) env.rh_size in Format.fprintf env.fmt "[%a]" Abstract_interp.Int.pretty start_case; pretty_bits_internal env Other typ ~align:new_align ~start:rem_start_size ~stop:rem_stop_size else if Integer.equal (Integer.rem start env.rh_size) align && (Integer.is_zero (Integer.rem size env.rh_size)) then let pred_size = Integer.pred size in let start_full_case = if Integer.is_zero rem_start_size then start_case else Integer.succ start_case in let stop_full_case = if Integer.equal rem_stop_size pred_size then stop_case else Integer.pred stop_case in let first_part = if Integer.is_zero rem_start_size then [] else [ArrayPart(start_case,start_case, typ,align,rem_start_size,pred_size)] in let middle_part = if Integer.lt stop_full_case start_full_case then [] else [ArrayPart(start_full_case,stop_full_case, typ,align,Integer.zero,pred_size)] in let last_part = if Integer.equal rem_stop_size pred_size then [] else [ArrayPart(stop_case,stop_case, typ,align,Integer.zero,rem_stop_size)] in let do_part = function | ArrayPart(start_index,stop_index,typ,align,start,stop) -> if Integer.equal start_index stop_index then Format.fprintf env.fmt "[%a]" Abstract_interp.Int.pretty start_index else Format.fprintf env.fmt "[%a..%a]" Abstract_interp.Int.pretty start_index Abstract_interp.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 = Integer.pos_rem (Abstract_interp.Rel.add_abs start align) rh_size in assert (Integer.le Integer.zero align && Integer.lt align rh_size); if Integer.lt start Integer.zero then (Format.fprintf fmt "[%sbits %a to %a]#(negative offsets)" (if Kernel.debug_atleast 1 then "?" else "") Abstract_interp.Int.pretty start Abstract_interp.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) (* -------------------------------------------------------------------------- *) (* --- Mapping numeric offset -> symbolic one --- *) (* -------------------------------------------------------------------------- *) exception NoMatchingOffset type offset_match = | MatchType of typ | MatchSize of Integer.t | MatchFirst (* Comparison of the shape of two types. Attributes are completely ignored. *) let rec equal_type_no_attribute t1 t2 = match Cil.unrollType t1, Cil.unrollType t2 with | TVoid _, TVoid _ -> true | TInt (i1, _), TInt (i2, _) -> i1 = i2 | TFloat (f1, _), TFloat (f2, _) -> f1 = f2 | TPtr (t1, _), TPtr (t2, _) -> equal_type_no_attribute t1 t2 | TArray (t1', s1, _, _), TArray (t2', s2, _, _) -> equal_type_no_attribute t1' t2' && (s1 == s2 || try Integer.equal (Cil.lenOfArray64 s1) (Cil.lenOfArray64 s2) with Cil.LenOfArray -> false) | TFun (r1, a1, v1, _), TFun (r2, a2, v2, _) -> v1 = v2 && equal_type_no_attribute r1 r2 && (match a1, a2 with | None, _ | _, None -> true | Some l1, Some l2 -> try List.for_all2 (fun (_, t1, _) (_, t2, _) -> equal_type_no_attribute t1 t2) l1 l2 with Invalid_argument _ -> false) | TNamed _, TNamed _ -> assert false | TComp (c1, _, _), TComp (c2, _, _) -> c1.ckey = c2.ckey | TEnum (e1, _), TEnum (e2, _) -> e1.ename = e2.ename | TBuiltin_va_list _, TBuiltin_va_list _ -> true | (TVoid _ | TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _ | TNamed _ | TComp _ | TEnum _ | TBuiltin_va_list _), _ -> false (* We have found a possible matching offset of type [typ] for [om], do we stop here? *) let offset_matches om typ = match om with | MatchFirst -> true | MatchSize size -> Integer.equal size (Integer.of_int (Cil.bitsSizeOf typ)) | MatchType typ' -> equal_type_no_attribute typ typ' (* Can we match [om] inside a cell of an array whose elements have size [size_elt] *) let offset_match_cell om size_elt = match om with | MatchFirst -> true | MatchSize size -> Integer.le size size_elt | MatchType typ' -> Integer.le (Integer.of_int (Cil.bitsSizeOf typ')) size_elt let minus_one_expr = Cil.mone ~loc:Cil_datatype.Location.unknown let rec find_offset typ ~offset om = (* Format.printf "Searching offset %a in %a, size %a@." Abstract_interp.Int.pretty offset Printer.pp_typ typ Abstract_interp.Int.pretty size; *) let loc = Cil_datatype.Location.unknown in if Integer.is_zero offset && offset_matches om typ then NoOffset, typ else match Cil.unrollType typ with | TArray (typ_elt, _, _, _) -> let size_elt = Integer.of_int (Cil.bitsSizeOf typ_elt) in if Integer.(equal size_elt zero) then begin (* array of elements of size 0 - trying to recompute the original offset in the case of multidimensional incomplete arrays is too complicated, to we just "normalize" everything to -1, which should be a noticeable visual indicator that the element size is 0. Since the sizeof each element is zero, any offset is valid anyway. *) let typ = TArray (typ_elt, Some minus_one_expr, Cil.empty_size_cache (),[]) in Index (minus_one_expr, NoOffset), typ end else let start = Integer.pos_div offset size_elt in let exp_start = Cil.kinteger64 ~loc start in let rem = Integer.pos_rem offset size_elt in if offset_match_cell om size_elt then (* [size] covers at most one cell; we continue in the relevant one *) let off, typ = find_offset typ_elt rem om in Index (exp_start, off), typ else begin match om with | MatchFirst | MatchType _ -> raise NoMatchingOffset | MatchSize size -> if Integer.is_zero rem && Integer.is_zero (Integer.rem size size_elt) then (* We cover more than one cell, but we are aligned. *) let nb = Integer.div size size_elt in let exp_nb = Cil.kinteger64 ~loc nb in let typ = TArray (typ_elt, Some exp_nb, Cil.empty_size_cache (),[]) in Index (exp_start, NoOffset), typ else (* We match different parts of multiple cells: too imprecise. *) raise NoMatchingOffset end | TComp (ci, _, _) -> let rec find_field = function | [] -> raise NoMatchingOffset | fi :: q -> try let off_fi, len_fi = Cil.bitsOffset typ (Field (fi, NoOffset)) in let off_fi, len_fi = Integer.of_int off_fi, Integer.of_int len_fi in if Integer.(ge offset (add off_fi len_fi)) then (* [offset] is not in the interval occupied by [fi]. Try the next one (including for union: maybe the next fields are larger). *) find_field q else let off, typ = find_offset fi.ftype (Integer.sub offset off_fi) om in Field (fi, off), typ with NoMatchingOffset when not ci.cstruct -> (* Mismatch between [offset] and the structure of [fi.ftype]. In the union case, we try the other fields. In the struct case, the other fields are too far and we abort. *) find_field q in find_field ci.cfields | _ -> raise NoMatchingOffset let find_offset typ ~offset om = try find_offset typ ~offset om with Cil.SizeOfError _ | Cil.Not_representable -> raise NoMatchingOffset (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/analysis/dataflow2.ml0000644000175000017500000006235113113745003024405 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 (** 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: data Cil_datatype.Stmt.Hashtbl.t = 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 (** Find which function we are analysing from the set of initial statements *) let current_kf = function | [] -> assert false | s :: q -> let kf = Kernel_function.find_englobing_kf s in let same_kf s' = let kf' = Kernel_function.find_englobing_kf s' in Kernel_function.equal kf kf' in assert (List.for_all same_kf q); kf module type WORKLIST = sig type t (** Create a worklist for function [kf], initially populated by the stmt list. *) val create: Kernel_function.t -> stmt list -> t (** Add a statement to the worklist. If the statement is already there, it is not added a second time. *) val add: t -> stmt -> unit (** Remove a statement from the worklist. *) val clear: t -> stmt -> unit (** Tells whether a statement is in the worklist or not. *) val mem : t -> stmt -> bool (** Retrieve and remove the next element in the worklist. Raise [Empty] if the worklist is empty. *) val pop_next: t -> stmt exception Empty val is_empty: t -> bool val fold: (stmt -> 'b -> 'b) -> t -> 'b -> 'b end module type MAYBE_REVERSE = sig (* [maybe_rev_int a b] is [a] in forward dataflow (no reversal), or [b+1-a] in reverse dataflow (reversal, i.e. counts from the end). *) val maybe_rev_int: int -> int -> int end module Worklist(MaybeReverse:MAYBE_REVERSE):WORKLIST = struct (* The worklist algorithm determines the order of propagation of the dataflow. The current strategy is to iterate one strongly connected components after another; inside one strongly connected component, we reexecute a statement already seen only once all the statements in the strongly connected component has been executed. This is implemented with a bitvector used as a priority queue, which is scanned iteratively, and rolled back (if necessary) at the end of a strongly connected component. *) type ordered_stmt = int type connex_component = int type t = { (** Priority queue implemented as a bit vector. Index 0 has the highest priority.*) bv: Bitvector.t; (** Conversions between stmt and ordered_stmt. *) order: Ordered_stmt.stmt_to_ordered; unorder: Ordered_stmt.ordered_to_stmt; connex: connex_component array; (** Next stmt to be retrieved. *) mutable next: ordered_stmt; (** The connex component for the last call to next(). *) mutable current_scc: connex_component; (** The first statement changed in the current scc, or None if the scc has not changed. *) mutable must_restart_cc: ordered_stmt option; } (* Forward and backward dataflow use the same data structure, but the index in the bitvector is reversed: in forward dataflow, 0 corresponds to the entry point of the function, while in backward dataflow, it is one of the sinks. *) let maybe_reverse t i = let nb_stmts = Array.length t.unorder in MaybeReverse.maybe_rev_int i nb_stmts ;; let stmt_from_ordered t ordered = Ordered_stmt.to_stmt t.unorder (maybe_reverse t ordered) ;; let ordered_from_stmt t stmt = maybe_reverse t (Ordered_stmt.to_ordered t.order stmt) ;; let connex_of_ordered t ordered = let k = maybe_reverse t ordered in t.connex.(k) ;; let create kf stmts = let (order,unorder,connex) = Ordered_stmt.get_conversion_tables kf in let nb_stmts = Array.length unorder in let bv = Bitvector.create nb_stmts in let (min, ordereds) = List.fold_left (fun (cur_min,cur_list) stmt -> let ordered = MaybeReverse.maybe_rev_int (Ordered_stmt.to_ordered order stmt) nb_stmts in (min cur_min ordered, ordered::cur_list)) (0,[]) stmts in List.iter (fun ordered -> Bitvector.set bv ordered) ordereds; let next = min in let current_scc = connex.(next) in let must_restart_cc = None in { bv; order; unorder; next; current_scc; connex; must_restart_cc } let add t stmt = let i = ordered_from_stmt t stmt in Bitvector.set t.bv i; if i < t.next then t.must_restart_cc <- match t.must_restart_cc with | None -> Some(i) | Some(j) -> Some(min i j) ;; let clear t stmt = let i = ordered_from_stmt t stmt in Bitvector.clear t.bv i; ;; let mem t stmt = let i = ordered_from_stmt t stmt in Bitvector.mem t.bv i; ;; let is_empty t = Bitvector.is_empty t.bv exception Empty;; let pop_next t = let restart_from i = (* We should restart in the same connex component. *) assert((connex_of_ordered t i) == t.current_scc); t.must_restart_cc <- None; i in let real_next = try let next_true = Bitvector.find_next_true t.bv t.next in let next_true_scc = connex_of_ordered t next_true in if next_true_scc == t.current_scc then (* Continue in the same connex component. *) next_true else (* We reached the end of the current connex component. The trick is that OCamlgraph's topological ordering guarantee that elements of the same connex component have contiguous indexes, so we know that we have reached the end of the current connex component. Check if we should start over in the same connex component, or continue to the next cc. *) ((* assert (next_true_scc < t.current_scc); *) match t.must_restart_cc with | None -> t.current_scc <- next_true_scc; next_true | Some(i) -> restart_from i) with Not_found -> (* We found no further work, but it could be because the graph ends with a non-trivial connex component (e.g. the function ends with a loop). *) (match t.must_restart_cc with | None -> raise Empty | Some(i) -> restart_from i) in Bitvector.clear t.bv real_next; t.next <- real_next + 1; t.current_scc <- connex_of_ordered t real_next; let stmt = stmt_from_ordered t real_next in (* Kernel.debug "next: %d\n" stmt.sid; *) stmt ;; let fold f t init = Bitvector.fold_true (fun acc i -> f (stmt_from_ordered t i) acc) init t.bv end module ForwardWorklist = Worklist(struct let maybe_rev_int k _ = k end) module BackwardWorklist = Worklist(struct let maybe_rev_int k n = (n-1) - k end) (****************************************************************** ********** ********** FORWARDS ********** ********************************************************************) module type ForwardsTransfer = sig val name: string val debug: bool type t val copy: t -> t val pretty: Format.formatter -> t -> unit val computeFirstPredecessor: stmt -> t -> t val combinePredecessors: stmt -> old:t -> t -> t option val doInstr: stmt -> instr -> t -> t val doGuard: stmt -> exp -> t -> t guardaction * t guardaction val doStmt: stmt -> t -> t stmtaction val doEdge: stmt -> stmt -> t -> t 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 (** We call this function when we have encountered a statement, with some * state. *) let reachedStatement worklist 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'; ForwardWorklist.add worklist s (** Process a statement *) let processStmt worklist (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 worklist 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 after = T.doInstr s i curr in do_succs after | UnspecifiedSequence _ | Goto _ | Break _ | Continue _ | TryExcept _ | TryFinally _ | Loop _ | Return _ | Block _ -> do_succs curr | Throw _ | TryCatch _ -> Kernel.not_yet_implemented "[dataflow] exception handling" | 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 worklist s succ curr | GUse d -> reachedStatement worklist 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 = Cil.separate_if_succs s in doBranch thenSucc thenGuard; doBranch elseSucc elseGuard; end | Switch (exp_sw, _, _, _) -> let cases, default = Cil.separate_switch_succs s in (* Auxiliary function that iterates 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 succ -> if rem_state = None then None else List.fold_left (fun rem_state label -> match rem_state with | None -> rem_state | Some state -> f succ label state ) rem_state succ.labels ) (Some curr) 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 (* This helps when switch is used on boolean expressions. *) | 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 worklist s succ before; | GUse d -> reachedStatement worklist 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 = iter_all_labels (fun succ label before -> match label with | Label _ (* Label not related to the switch *) | Cil_types.Default _ -> (* The default case is handled at the end *) (Some before) | Case (exp_case, _) -> let after = explore_succ before succ exp_case in after ) 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 -> reachedStatement worklist s default state) end let init_worklist (sources: stmt list) = let kf = current_kf sources in let worklist = ForwardWorklist.create kf sources in List.iter (fun s -> ForwardWorklist.add worklist s) sources; worklist (** All initial stmts must have non-bottom data *) let check_initial_stmts (sources: stmt list) = 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 (** Compute the data flow using worklists and starting with the given sources. *) let compute_worklist (sources: stmt list) = check_initial_stmts sources; let worklist = init_worklist sources in if T.debug then (Kernel.debug "FF(%s): processing" T.name); let rec fixedpoint () = if T.debug && not (ForwardWorklist.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 (ForwardWorklist.fold (fun s acc -> s :: acc) worklist []))); let s = ForwardWorklist.pop_next worklist in processStmt worklist s; fixedpoint () in try fixedpoint () with ForwardWorklist.Empty -> if T.debug then Kernel.debug "FF(%s): done" T.name (** Compute the dataflow for the given strategy. *) let compute_strategy (sources: stmt list) (strategy : Wto_statement.wto) = check_initial_stmts sources; let worklist = init_worklist sources in (* the reference "change" tracks whether something has been computed *) let rec process_wto change wto = List.iter (process_element change) wto and process_element change = function (* Some statement, process it and mark as changed if necessary *) | Wto.Node (stmt) -> if ForwardWorklist.mem worklist stmt then begin ForwardWorklist.clear worklist stmt; processStmt worklist stmt; change := true; end (* Component, iterate until it reached a fixpoint *) | Wto.Component (stmt, wto) -> let component_change = ref true in while !component_change do component_change := false; process_wto component_change (Wto.Node stmt :: wto); if !component_change then change := true done in process_wto (ref false) strategy (** Compute the dataflow for the default strategy. *) let compute (sources: stmt list) = let kf = current_kf sources in let strategy = Wto_statement.wto_of_kf kf in compute_strategy sources strategy end (****************************************************************** ********** ********** BACKWARDS ********** ********************************************************************) module type BackwardsTransfer = sig val name: string val debug: bool type t val pretty: Format.formatter -> t -> unit val funcExitData: t val combineStmtStartData: Cil_types.stmt -> old:t -> t -> t option val combineSuccessors: t -> t -> t val doStmt: stmt -> t action val doInstr: stmt -> instr -> t -> t action val filterStmt: stmt -> stmt -> bool 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 i -> begin CurrentLoc.set (Cil_datatype.Instr.loc i); let action = T.doInstr s i res in match action with | Done s' -> s' | Default -> res (* do nothing *) | Post f -> f res end | _ -> 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 (** Compute the data flow. Must have the CFG initialized *) let compute (sinks: stmt list) = let kf = current_kf sinks in let worklist = BackwardWorklist.create kf sinks in List.iter (fun s -> BackwardWorklist.add worklist s) sinks; if T.debug && not (BackwardWorklist.is_empty worklist) then (Kernel.debug "\nBF(%s): processing\n" T.name); let rec fixedpoint () = if T.debug && not (BackwardWorklist.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 (BackwardWorklist.fold (fun s acc -> s :: acc) worklist []))); let s = BackwardWorklist.pop_next 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 then BackwardWorklist.add worklist p) s.preds; end; fixedpoint () in try fixedpoint () with BackwardWorklist.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 statements (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-Phosphorus-20170501/src/kernel_services/analysis/dominators.mli0000644000175000017500000000417513113745007025056 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 dominators. *) open Cil_types;; val get_idom: stmt -> stmt option (** Immediate dominator of the statement. *) val dominates: stmt -> stmt -> bool (** [dominates a b] tells whether [a] dominates [b]. *) val nearest_common_ancestor: stmt list -> stmt (** Finds the statement lowest in the function that dominates all the statements in the list passed as argument. The list must not be empty, and must contain statements that are all in the same function. *) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/analysis/ordered_stmt.mli0000644000175000017500000000600513113745004025361 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 (** An [ordered_stmt] is an int representing a stmt in a particular function. They are sorted by the topological ordering of stmts (s1 < s2 if s1 precedes s2, or s2 does not precede s1); they are contiguous and start from 0. Note: due to the presence of unreachable statements in the graph, you should not assume that the entry point is statement number 0 and the return is statement number |nb_stmts - 1|. Use [Kernel_function.find_first_stmt] and [Kernel_function.find_return] instead.*) type ordered_stmt = (* private *) int (** As [ordered_stmts] are contiguous and start from 0, they are suitable for use by index in a array. This type denotes arrays whose index are ordered stmts. *) type 'a ordered_stmt_array = 'a array;; (** Types of conversion tables between stmt and ordered_stmt. *) type ordered_to_stmt = stmt ordered_stmt_array;; type stmt_to_ordered (** Conversion functions between stmt and ordered_stmt. *) val to_ordered: stmt_to_ordered -> stmt -> ordered_stmt val to_stmt: ordered_to_stmt -> ordered_stmt -> stmt (** This function computes, caches, and returns the conversion tables between a stmt and an [ordered_stmt], and a table mapping each ordered_stmt to a connex component number (connex component number are also sorted in topological order *) val get_conversion_tables: kernel_function -> stmt_to_ordered * ordered_to_stmt * int ordered_stmt_array frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/0000755000175000017500000000000013113745013023523 5ustar mehdimehdiframa-c-Phosphorus-20170501/src/kernel_services/abstract_interp/base.ml0000644000175000017500000004010513113745011024765 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 variable_validity = { mutable weak: bool; mutable min_alloc : Int.t; mutable max_alloc : Int.t; max_allocable: Int.t (* not mutable, determined when the base is created *); } type validity = | Empty | Known of Int.t * Int.t | Unknown of Int.t * Int.t option * Int.t | Variable of variable_validity | Invalid let pretty_validity fmt v = match v with | Empty -> Format.fprintf fmt "Empty" | 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" | Variable variable_v -> Format.fprintf fmt "Variable [0..%a--%a]" Int.pretty variable_v.min_alloc Int.pretty variable_v.max_alloc module Validity = Datatype.Make (struct type t = validity let name = "Base.validity" let structural_descr = Structural_descr.t_abstract let reprs = [ Known (Int.zero, Int.one) ] (* Invalid > Variable > Unknown > Known > Empty *) let compare v1 v2 = match v1, v2 with | Empty, Empty -> 0 | Known (b1, e1), Known (b2, e2) -> let c = Int.compare b1 b2 in if c = 0 then Int.compare e1 e2 else c | Unknown (b1, m1, e1), Unknown (b2, m2, e2) -> let c = Int.compare b1 b2 in if c = 0 then let c = Extlib.opt_compare Int.compare m1 m2 in if c = 0 then Int.compare e1 e2 else c else c | Variable v1, Variable v2 -> let c = Int.compare v1.min_alloc v2.min_alloc in if c = 0 then let c = Int.compare v1.max_alloc v2.max_alloc in if c = 0 then Int.compare v1.max_allocable v2.max_allocable else c else c | Invalid, Invalid -> 0 | Empty, (Known _ | Unknown _ | Variable _ | Invalid) | Known _, (Unknown _ | Variable _ | Invalid) | Unknown _, (Variable _ | Invalid) | Variable _, Invalid -> -1 | Invalid, (Variable _ | Unknown _ | Known _ | Empty) | Variable _, (Unknown _ | Known _ | Empty) | Unknown _, (Known _ | Empty) | Known _, Empty -> 1 let equal = Datatype.from_compare let hash v = match v with | Empty -> 13 | Invalid -> 37 | Known (b, e) -> Hashtbl.hash (3, Int.hash b, Int.hash e) | Unknown (b, m, e) -> Hashtbl.hash (7, Int.hash b, Extlib.opt_hash Int.hash m, Int.hash e) | Variable variable_v -> Hashtbl.hash (Int.hash variable_v.min_alloc, Int.hash variable_v.max_alloc) 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 cstring = CSString of string | CSWstring of Escape.wstring type base = | Var of varinfo * validity | CLogic_Var of logic_var * typ * validity | Null (** base for addresses like [(int* )0x123] *) | String of int * cstring (** String constants *) | Allocated of varinfo * validity let id = function | Var (vi,_) | Allocated (vi,_) -> vi.vid | CLogic_Var (lvi, _, _) -> lvi.lv_id | Null -> 0 | String (id,_) -> id let hash = id let null = Null let is_null x = match x with Null -> true | _ -> false let pretty fmt t = match t with | String (_, CSString s) -> Format.fprintf fmt "%S" s | String (_, CSWstring s) -> Format.fprintf fmt "L\"%s\"" (Escape.escape_wstring s) | Var (t,_) | Allocated (t,_) -> Printer.pp_varinfo fmt t | CLogic_Var (lvi, _, _) -> Printer.pp_logic_var fmt lvi | Null -> Format.pp_print_string fmt "NULL" let pretty_addr fmt t = (match t with | Var _ | CLogic_Var _ | Allocated _ -> Format.pp_print_string 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 | CLogic_Var (_, ty, _) -> Some ty | Null -> None | Var (v,_) | Allocated(v,_) -> Some (unrollType v.vtype) let cstring_bitlength s = let u, l = match s with | CSString s -> bitsSizeOf charType, (String.length s) | CSWstring s -> bitsSizeOf theMachine.wcharType, (List.length s) 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,_) | Allocated (v,_) -> Bit_utils.sizeof_vid v | CLogic_Var (_, ty, _) -> Bit_utils.sizeof ty 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 "%s@-%s" (fun min max -> (* let mul_CHAR_BIT = Int64.mul (Int64.of_int (bitsSizeOf charType)) in *) (* the above is what we would like to write but it is too early *) let mul_CHAR_BIT = Int.mul Int.eight in MinValidAbsoluteAddress.set (mul_CHAR_BIT (Int.of_string min)); MaxValidAbsoluteAddress.set ((Int.pred (mul_CHAR_BIT (Int.succ (Int.of_string 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_from_size size = assert Int.(ge size zero); if Int.(equal size zero) then Empty else Known (Int.zero, Int.pred size) let validity_from_known_size size = match size with | Int_Base.Value size -> (* all start to be valid at offset 0 *) validity_from_size size | Int_Base.Top -> Unknown (Int.zero, None, Bit_utils.max_bit_address ()) let validity b = match b with | Var (_,v) | CLogic_Var (_, _, v) | Allocated (_,v) -> v | 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 | String _ -> let size = bits_sizeof b in validity_from_known_size size exception Not_valid_offset let is_read_only base = match base with | String _ -> true | Var (v,_) -> Kernel.ConstReadonly.get () && typeHasQualifier "const" v.vtype | _ -> false (* Minor optimization compared to [is_weak (validity b)] *) let is_weak = function | Allocated (_, Variable { weak }) -> weak | _ -> false let is_valid_offset ~for_writing size base offset = let wrap_inf = function | None -> raise Not_valid_offset | Some v -> v in if for_writing && (is_read_only base) then raise Not_valid_offset; match validity base with | Empty -> if not (Int.(equal zero size) && Ival.(equal offset zero)) then raise Not_valid_offset | Invalid -> (* Special case. We stretch the truth and say that the address of the base itself is valid for a size of 0. We use a size of 0 to emulate the semantics of "past-one" pointers. *) if not (Int.(equal zero size) && Ival.(equal offset zero)) then raise Not_valid_offset | Known (min_valid,max_valid) | Unknown (min_valid, Some max_valid, _) -> (* valid between min_valid .. max_valid inclusive *) if not (Ival.is_bottom offset) then let min = wrap_inf (Ival.min_int offset) in if Int.lt min min_valid then raise Not_valid_offset; let max = wrap_inf (Ival.max_int offset) in if Int.gt (Int.pred (Int.add max size)) max_valid then raise Not_valid_offset | Variable {min_alloc = min_valid} -> (* valid between 0 .. min_valid inclusive *) if not (Ival.is_bottom offset) then let min = wrap_inf (Ival.min_int offset) in if Int.lt min Int.zero then raise Not_valid_offset; let max = wrap_inf (Ival.max_int offset) in if Int.gt (Int.pred (Int.add max size)) min_valid then raise Not_valid_offset | Unknown (_, None, _) -> raise Not_valid_offset let is_function base = match base with | String _ | Null | CLogic_Var _ | Allocated _ -> 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,_) | Allocated(v,_) -> Int.is_zero (Int.rem (Int.of_int (Cil.bytesAlignOf v.vtype)) alignment) | CLogic_Var (_, ty, _) -> Int.is_zero (Int.rem (Int.of_int (Cil.bytesAlignOf ty)) alignment) | Null -> true | String _ -> Int.is_one alignment let is_any_formal_or_local v = match v with | Var (v,_) -> v.vsource && not v.vglob | Allocated _ | CLogic_Var _ -> false | Null | String _ -> false let is_any_local v = match v with | Var (v,_) -> v.vsource && not v.vglob && not v.vformal | Allocated _ | CLogic_Var _ -> false | Null | String _ -> false let is_global v = match v with | Var (v,_) -> v.vglob | Allocated _ | Null | String _ -> true | CLogic_Var _ -> false let is_formal_or_local v fundec = match v with | Var (v,_) -> Ast_info.Function.is_formal_or_local v fundec | Allocated _ | CLogic_Var _ | Null | String _ -> false let is_formal_of_prototype v vi = match v with | Var (v,_) -> Ast_info.Function.is_formal_of_prototype v vi | Allocated _ | CLogic_Var _ | Null | String _ -> false let is_local v fundec = match v with | Var (v,_) -> Ast_info.Function.is_local v fundec | Allocated _ | CLogic_Var _ | Null | String _ -> false let is_formal v fundec = match v with | Var (v,_) -> Ast_info.Function.is_formal v fundec | Allocated _ | CLogic_Var _ | Null | String _ -> false let is_block_local v block = match v with | Var (v,_) -> Ast_info.is_block_local v block | Allocated _ | CLogic_Var _ | 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 -> validity_from_size size type range_validity = | Invalid_range | Valid_range of Int_Intervals_sig.itv option let valid_range = function | Invalid -> Invalid_range | Empty -> Valid_range None | Known (min_valid,max_valid) | Unknown (min_valid,_,max_valid)-> Valid_range (Some (min_valid, max_valid)) | Variable variable_v -> Valid_range (Some (Int.zero, variable_v.max_alloc)) let is_weak_validity = function | Variable { weak } -> weak | _ -> false let create_variable_validity ~weak ~min_alloc ~max_alloc = let max_allocable = Bit_utils.max_bit_address () in { weak; min_alloc; max_alloc; max_allocable } let update_variable_validity v ~weak ~min_alloc ~max_alloc = v.min_alloc <- Int.min min_alloc v.min_alloc; v.max_alloc <- Int.max max_alloc v.max_alloc; if weak then v.weak <- true module Base = struct include Datatype.Make_with_collections (struct type t = base let name = "Base" let structural_descr = Structural_descr.t_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 Base module Hptset = Hptset.Make (Base) (struct let v = [ [ ]; [Null] ] end) (struct let l = [ Ast.self ] end) let () = Ast.add_monotonic_state Hptset.self let () = Ast.add_hook_on_update Hptset.clear_caches let null_set = Hptset.singleton Null module VarinfoNotSource = Cil_state_builder.Varinfo_hashtbl (Base) (struct let name = "Base.VarinfoLogic" let dependencies = [ Ast.self ] let size = 89 end) let () = Ast.add_monotonic_state VarinfoNotSource.self let base_of_varinfo varinfo = assert varinfo.vsource; let validity = validity_from_type varinfo in Var (varinfo, validity) module Validities = Cil_state_builder.Varinfo_hashtbl (Base) (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 of_varinfo_aux = Validities.memo base_of_varinfo let register_memory_var varinfo validity = assert (not varinfo.vsource && not (VarinfoNotSource.mem varinfo)); let base = Var (varinfo,validity) in VarinfoNotSource.add varinfo base; base let register_allocated_var varinfo validity = assert (not varinfo.vsource); let base = Allocated (varinfo,validity) in VarinfoNotSource.add varinfo base; base let of_c_logic_var lv = match Logic_utils.unroll_type lv.lv_type with | Ctype ty -> CLogic_Var (lv, ty, validity_from_known_size (Bit_utils.sizeof ty)) | _ -> Kernel.fatal "Logic variable with a non-C type %s" lv.lv_name let of_varinfo varinfo = if varinfo.vsource then of_varinfo_aux varinfo else try VarinfoNotSource.find varinfo with Not_found -> Kernel.fatal "Querying base for unknown non-source variable %a" Printer.pp_varinfo varinfo exception Not_a_C_variable let to_varinfo t = match t with | Var (t,_) | Allocated (t,_) -> t | CLogic_Var _ | Null | String _ -> raise Not_a_C_variable module LiteralStrings = State_builder.Hashtbl (Datatype.Int.Hashtbl) (Base) (struct let name = "literal strings" let dependencies = [ Ast.self ] let size = 17 end) let () = Ast.add_monotonic_state LiteralStrings.self let of_string_exp e = let cstring = match e.enode with | Const (CStr s) -> CSString s | Const (CWStr s) -> CSWstring s | _ -> assert false in LiteralStrings.memo (fun _ -> String (Cil_const.new_raw_id (), cstring)) e.eid module SetLattice = Make_Hashconsed_Lattice_Set(Base)(Hptset) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/lattice_type.mli0000644000175000017500000002135213113745002026715 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** Lattice signatures. @plugin developer guide *) module type Join_Semi_Lattice = sig include Datatype.S (** datatype of element of the lattice *) val join: t -> t -> t (** over-approximation of union *) val is_included: t -> t -> bool (**is first argument included in the second?*) val join_and_is_included: t -> t -> (t * bool) (**Do both ops simultaneously*) end module type Bounded_Join_Semi_Lattice = sig include Join_Semi_Lattice;; val bottom: t (** smallest element *) end module type With_Top = sig type t val top: t (** largest element *) end module type With_Top_Opt = sig type t val top_opt: t option (** optional largest element *) end module type With_Error_Top = sig exception Error_Top end module type With_Error_Bottom = sig exception Error_Bottom end module type With_Errors = sig include With_Error_Top include With_Error_Bottom end module type With_Narrow = sig type t val narrow: t -> t -> t (** over-approximation of intersection *) end module type With_Under_Approximation = sig type t val link: t -> t -> t (** under-approximation of union *) val meet: t -> t -> t (** under-approximation of intersection *) end (** {2 Over- and under-approximations} Nearly all abstract operations implemented in the lattices of Frama-C are *over-approximations*: the (abstract) operation assumes that its operands are already over-approximations, and returns a result that over-approximates (abstracts) the results that would have been given by the concrete operation on the concretization of the arguments. Conversely, some functions, suffixed by [_under] assumes that their arguments are under-approximations, and returns a result that under-approximates the concrete operation. The functions [link] and [meet] in {With_Under_Approximation} are exceptions, that are not suffixed by [_under]. Finally, some functions are *exact*, in the sense that they preserve the concretization of the concrete function. Hence, they implement over-approximations when given over-approximated arguments, and under-approximations when given under-approximated ones. This 'exact' property is usually mentioned in the comments for the function. *) module type With_Intersects = sig type t val intersects: t -> t -> bool (** [intersects t1 t2] returns [true] iff the intersection of [t1] and [t2] is non-empty. *) end module type With_Enumeration = sig type t val fold_enum : (t -> 'a -> 'a) -> t -> 'a -> 'a (** Fold on the elements of the value one by one if possible. Raises {!Abstract_interp.Not_less_than} when there is an infinite number of elements to enumerate. *) val cardinal_less_than: t -> int -> int (** Raises {!Abstract_interp.Not_less_than} whenever the cardinal of the given lattice is strictly higher than the given integer. *) end module type With_Diff = sig type t val diff : t -> t -> t (** [diff t1 t2] is an over-approximation of [t1-t2]. [t2] must be an under-approximation or exact. *) end module type With_Diff_One = sig type t val diff_if_one : t -> t -> t (** [diff_of_one t1 t2] is an over-approximation of [t1-t2]. @return [t1] if [t2] is not a singleton. *) end module type With_Cardinal_One = sig type t val cardinal_zero_or_one: t -> bool end module type With_Widening = sig type t type widen_hint (** hints for the widening *) val widen: widen_hint -> t -> t -> t (** [widen h t1 t2] is an over-approximation of [join t1 t2]. Assumes [is_included t1 t2] *) end (** {2 Common signatures} *) (** Signature shared by some functors of module {!Abstract_interp}. *) module type AI_Lattice_with_cardinal_one = sig include Bounded_Join_Semi_Lattice include With_Top with type t:= t include With_Widening with type t:= t include With_Cardinal_One with type t := t include With_Narrow with type t := t include With_Under_Approximation with type t := t include With_Intersects with type t := t end (** Lattice with over- and under-approximation of join and meet, and intersection and difference. *) module type Full_Lattice = sig include Bounded_Join_Semi_Lattice include With_Top with type t := t include With_Narrow with type t := t include With_Under_Approximation with type t := t include With_Intersects with type t := t include With_Diff with type t := t end (** Most complete lattices: all operations plus widening, notion of cardinal (including enumeration) and difference. *) module type Full_AI_Lattice_with_cardinality = sig include AI_Lattice_with_cardinal_one include With_Diff with type t := t include With_Diff_One with type t := t include With_Enumeration with type t := t include With_Error_Top end (** {2 Results of generic functors, in module {!Abstract_interp}. } *) (** Generic signature for the base elements of a lattice *) module type Lattice_Value = Datatype.S_with_collections (** Signature for a product lattice in which [Bottom] is handled especially. (see {!Abstract_interp.Make_Lattice_Product}). *) module type Lattice_Product = sig type t1 type t2 type t = private Product of t1*t2 | Bottom include AI_Lattice_with_cardinal_one with type t := t val inject : t1 -> t2 -> t val fst : t -> t1 val snd : t -> t2 end (** Signature for a product lattice (see {!Abstract_interp.Make_Lattice_UProduct}). *) module type Lattice_UProduct = sig type t1 type t2 type t = t1*t2 include AI_Lattice_with_cardinal_one with type t := t end (** Signature for a lattice over a sum type (see {!Abstract_interp.Make_Lattice_Sum}). *) module type Lattice_Sum = sig type t1 type t2 type sum = private Top | Bottom | T1 of t1 | T2 of t2 include AI_Lattice_with_cardinal_one with type t = sum val inject_t1 : t1 -> t val inject_t2 : t2 -> t end module type Lattice_Base = sig type l type t = private Top | Bottom | Value of l exception Error_Top exception Error_Bottom include AI_Lattice_with_cardinal_one with type t := t val project : t -> l val inject: l -> t val transform: (l -> l -> l) -> t -> t -> t end (** Signatures for a lattice over a set (see {!Abstract_interp.Make_Lattice_Set} or {!Abstract_interp.Make_Hashconsed_Lattice_Set}). *) module type Lattice_Set_Generic = sig module O: sig type t type elt end exception Error_Top type t = private Set of O.t | Top include AI_Lattice_with_cardinal_one with type t := t 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 filter: (O.elt -> bool) -> t -> t val project : t -> O.t val mem : O.elt -> t -> bool end module type Lattice_Set = sig module O: Datatype.Set include Lattice_Set_Generic with module O := O end module type Lattice_Hashconsed_Set = sig module O: sig include FCSet.S_Basic_Compare include Datatype.S with type t := t end include Lattice_Set_Generic with module O := O end (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/ival.mli0000644000175000017500000003142613113745005025170 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. *) open Abstract_interp type t = private | Set of Int.t array | Float of Fval.t (** [Top(min, max, rem, modulo)] represents the interval between [min] and [max], congruent to [rem] modulo [modulo]. A value of [None] for [min] (resp. [max]) represents -infinity (resp. +infinity). [modulo] is > 0, and [0 <= rem < modulo]. Actual [Top] is thus represented by Top(None,None,Int.zero,Int.one) *) | Top of Int.t option * Int.t option * Int.t * Int.t (** {2 General guidelines of this module} - Functions suffixed by [_int] expect arguments that are integers. Hence, they will fail on an ival with constructor [Float]. Conversely, [_float] suffixed functions expect float arguments: the constructor [Float], or the singleton set [ [| Int.zero |] ], that can be tested by {!is_zero}. The function {!force_float} forces a bit-level conversion from the integer representation to the floating-point one. - see the comment in {!Lattice_type} about over- and under-approximations, and exact operations. *) module Widen_Hints : sig include FCSet.S with type elt = Integer.t include Datatype.S with type t:=t val default_widen_hints: t end exception Error_Bottom type size_widen_hint = Integer.t type generic_widen_hint = Widen_Hints.t include Datatype.S_with_collections with type t := t include Lattice_type.Full_AI_Lattice_with_cardinality with type t := t and type widen_hint = size_widen_hint * generic_widen_hint val is_bottom : t -> bool val partially_overlaps : size:Integer.t -> t -> t -> bool val add_int : t -> t -> t (** Addition of two integer (ie. not [Float]) ivals. *) val add_int_under : t -> t -> t (** Underapproximation of the same operation *) val add_singleton_int: Integer.t -> t -> t (** Addition of an integer ival with an integer. Exact operation. *) val neg_int : t -> t (** Negation of an integer ival. Exact operation. *) val sub_int : t -> t -> t val sub_int_under: t -> t -> t val min_int : t -> Integer.t option (** A [None] result means the argument is unbounded. Raises [Error_Bottom] if the argument is bottom. *) val max_int : t -> Integer.t option (** A [None] result means the argument is unbounded. Raises [Error_Bottom] if the argument is bottom. *) val min_max_r_mod : t -> Integer.t option * Integer.t option * Integer.t * Integer.t val min_and_max : t -> Integer.t option * Integer.t option val bitwise_and : size:int -> signed:bool -> t -> t -> t val bitwise_or : t -> t -> t val bitwise_xor : t -> t -> t val bitwise_not: t -> t val bitwise_not_size: size:int -> signed:bool -> t -> t (** bitwise negation on a finite integer type. The argument is assumed to fit within the type. *) val min_and_max_float : t -> Fval.F.t * Fval.F.t val zero : t (** The lattice element that contains only the integer 0. *) val one : t (** The lattice element that contains only the integer 1. *) val minus_one : t (** The lattice element that contains only the integer -1. *) val zero_or_one : t (** The lattice element that contains only the integers 0 and 1. *) val positive_integers : t (** The lattice element that contains exactly the positive or null integers *) val negative_integers : t (** The lattice element that contains exactly the negative or null integers *) val float_zeros : t (** The lattice element containing exactly -0. and 0. *) val is_zero : t -> bool val is_one : t -> bool val contains_zero : t -> bool val contains_non_zero : t -> bool val top_float : t val top_single_precision_float : t exception Nan_or_infinite val project_float : t -> Fval.t (** @raise Nan_or_infinite when the float may be NaN or infinite. *) val force_float: Cil_types.fkind -> t -> bool * t (** Reinterpret the given value as a float of the given kind. If the returned boolean is [true], some of the values may not be representable as finite floats. *) (** Building Ival *) val inject_singleton : Integer.t -> t val inject_float : Fval.t -> t val inject_float_interval : float -> float -> t val inject_range : Integer.t option -> Integer.t option -> t (** [None] means unbounded. The interval is inclusive. *) val inject_interval: min: Integer.t option -> max: Integer.t option -> rem: Integer.t -> modu: Integer.t -> t (** Builds the set of integers between [min] and [max] included and congruent to [rem] modulo [modulo]. For [min] and [max], [None] is the corresponding infinity. Checks that [modu] > 0 and 0 <= [rest] < [modu], and fails otherwise. *) val inject_top : Integer.t option -> Integer.t option -> Integer.t -> Integer.t -> t (** [inject_top min max r m] checks [min], [max], [r] and [m] for consistency as arguments of the [Top] constructor and returns the lattice element of integers equal to [r] modulo [m] between [min] and [max] (which may be a Set if there are few of these). For [min] and [max], [None] means unbounded. @deprecated {!inject_interval} offers a better API, and normalizes the [min] and [max] bounds. *) (** Cardinality *) val cardinal_zero_or_one : t -> bool val is_singleton_int : t -> bool exception Not_Singleton_Int val project_int : t -> Integer.t (** @raise Not_Singleton_Int when the cardinal of the argument is not 1, or if it is not an integer. *) val cardinal: t -> Integer.t option (** [cardinal v] returns [n] if [v] has finite cardinal [n], or [None] if the cardinal is not finite. *) val cardinal_estimate: t -> Integer.t -> Integer.t (** [cardinal_estimate v size] returns an estimation of the cardinal of [v], knowing that [v] fits in [size] bits. *) 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 cardinal_is_less_than: t -> int -> bool (** Same than cardinal_less_than but just return if it is the case. *) val fold_int : (Integer.t -> 'a -> 'a) -> t -> 'a -> 'a (** Iterate on the integer values of the ival in increasing order. Raise {!Error_Top} if the argument is a float or a potentially infinite integer. *) val fold_int_decrease : (Integer.t -> 'a -> 'a) -> t -> 'a -> 'a (** Iterate on the integer values of the ival in decreasing order. Raise {!Error_Top} if the argument is a float or a potentially infinite integer. *) val fold_enum : (t -> 'a -> 'a) -> t -> 'a -> 'a (** Iterate on every value of the ival. Raise {!Error_Top} if the argument is a non-singleton float or a potentially infinite integer. *) val fold_split : split:int -> (t -> 'a -> 'a) -> t -> 'a -> 'a val apply_set: (Integer.t -> Integer.t -> Integer.t ) -> t -> t -> t val apply_set_unary: (Integer.t -> Integer.t ) -> t -> t val subdiv_float_interval : size:int -> t -> t * t val subdiv_int: t -> t * t (** [compare_min_float m1 m2] returns 1 if the float interval [m1] has a better min bound (i.e. greater) than the float interval [m2]. *) val compare_min_float : t -> t -> int (** [compare_max_float m1 m2] returns 1 if the float interval [m1] has a better max bound (i.e. lower) than the float interval [m2]. *) val compare_max_float : t -> t -> int (** [compare_min_int m1 m2] returns 1 if the int interval [m1] has a better min bound (i.e. greater) than the int interval [m2]. *) val compare_min_int : t -> t -> int (** [compare_max_int m1 m2] returns 1 if the int interval [m1] has a better max bound (i.e. lower) than the int interval [m2]. *) val compare_max_int : t -> t -> int val scale : Integer.t -> t -> t (** [scale f v] returns the interval of elements [x * f] for [x] in [v]. The operation is exact, except when [v] is a float. *) val scale_div : pos:bool -> Integer.t -> t -> t (** [scale_div ~pos:false f v] is an over-approximation of the set of elements [x / f] for [x] in [v]. [scale_div ~pos:true f v] is an over-approximation of the set of elements [x pos_div f] for [x] in [v]. *) val scale_div_under : pos:bool -> Integer.t -> t -> t (** [scale_div_under ~pos:false f v] is an under-approximation of the set of elements [x / f] for [x] in [v]. [scale_div_under ~pos:true f v] is an under-approximation of the set of elements [x pos_div f] for [x] in [v]. *) val div : t -> t -> t (** Integer division *) val scale_rem : pos:bool -> Integer.t -> t -> t (** [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]. *) val c_rem : t -> t -> t val mul : t -> t -> t val shift_left: t -> t -> t val shift_right: t -> t -> t val interp_boolean : contains_zero:bool -> contains_non_zero:bool -> 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:Integer.t -> stop:Integer.t -> size:Integer.t -> t -> t val create_all_values_modu: modu:Integer.t -> signed:bool -> size:int -> t val create_all_values: signed:bool -> size:int -> t (** [all_values ~size v] returns true iff v contains all integer values representable in [size] bits. *) val all_values: size:Integer.t -> t -> bool val backward_mult_int_left: right:t -> result:t -> t option Bottom.or_bottom val backward_comp_int_left : Comp.t -> t -> t -> t (** [backward_comp_int op l r] reduces [l] into [l'] so that [l' op r] holds. [l] is assumed to be an integer *) val backward_comp_float_left : Comp.t -> bool -> Fval.float_kind -> t -> t -> t (** Same as {!backward_comp_int_left}, except that the arguments should now be floating-point values. *) val forward_comp_int: Comp.t -> t -> t -> Comp.result (** In the results of [min_int] and [max_int], [None] represents the corresponding infinity. [compare_max_min ma mi] compares [ma] to [mi], interpreting [None] for [ma] as +infinity and [None] for [mi] as -infinity. *) val compare_max_min : Integer.t option -> Integer.t option -> int (** In the results of [min_int] and [max_int], [None] represents the corresponding infinity. [compare_min_max mi ma] compares [ma] to [ma], interpreting [None] for [ma] as +infinity and [None] for [mi] as -infinity. *) val compare_min_max : Integer.t option -> Integer.t option -> int val scale_int_base : Int_Base.t -> t -> t val cast_float_to_int : signed:bool -> size:int -> t -> (** non-finite *) bool * (** Overflow, in each direction *) (bool * bool) * t val cast_float_to_int_inverse: single_precision:bool -> t (** floating-point *)-> t (** integer *) val cast_int_to_float_inverse: single_precision:bool -> t (** floating-point *) -> t (** integer *) val of_int : int -> t val of_int64 : int64 -> t val cast_int_to_float : Fval.rounding_mode -> t -> bool * t val cast : size:Integer.t -> signed:bool -> value:t -> t val cast_float : rounding_mode:Fval.rounding_mode -> t -> bool * t val cast_double : t -> bool * t val pretty_debug : Format.formatter -> t -> unit val get_small_cardinal: unit -> int (** Value of option -ilevel *) (**/**) (* 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-Phosphorus-20170501/src/kernel_services/abstract_interp/lattice_messages.ml0000644000175000017500000000462013113745012027372 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 = | Approximation of string | Imprecision of string | Costly of string | Unsoundness of string type emitter = unit let emit _emitter msg = match msg with | Imprecision _ -> () (* Only for debug purposes *) | Approximation str | Costly str | Unsoundness str -> Kernel.feedback ~current:true ~once:true "%s" str ;; let register _name = () let emit_approximation emitter = Format.kfprintf (fun _fmt -> let str = Format.flush_str_formatter() in emit emitter (Approximation str)) Format.str_formatter ;; let emit_costly emitter = Format.kfprintf (fun _fmt -> let str = Format.flush_str_formatter() in emit emitter (Costly str)) Format.str_formatter ;; let emit_imprecision emitter str = emit emitter (Imprecision str) ;; (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/int_Intervals.ml0000644000175000017500000000326613113745003026704 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 Offsetmap.Int_Intervals (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/bottom.mli0000644000175000017500000000676613113745004025551 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** Types, monads and utilitary functions for lattices in which the bottom is managed separately from other values. *) module Type : sig type 'a or_bottom = [ `Value of 'a | `Bottom ] (** This monad propagates the `Bottom value if needed. *) val (>>-) : 'a or_bottom -> ('a -> 'b or_bottom) -> 'b or_bottom (** Use this monad if the following function returns a simple value. *) val (>>-:) : 'a or_bottom -> ('a -> 'b) -> 'b or_bottom end include module type of Type val non_bottom: 'a or_bottom -> 'a val equal: ('a -> 'a -> bool) -> 'a or_bottom -> 'a or_bottom -> bool val is_included: ('a -> 'a -> bool) -> 'a or_bottom -> 'a or_bottom -> bool val join: ('a -> 'a -> 'a) -> 'a or_bottom -> 'a or_bottom -> 'a or_bottom val narrow: ('a -> 'a -> 'a or_bottom) -> 'a or_bottom -> 'a or_bottom -> 'a or_bottom val pretty : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a or_bottom -> unit (** Datatype constructor. *) module Make_Datatype (Domain: Datatype.S) : Datatype.S with type t = Domain.t or_bottom (** Bounds a semi-lattice. *) module Bound_Lattice (Lattice: Lattice_type.Join_Semi_Lattice) : Lattice_type.Bounded_Join_Semi_Lattice with type t = Lattice.t or_bottom (** In a lattice where the elements are lists of non-bottom values, the empty list is the bottom case. *) (** Conversion functions. *) val bot_of_list: 'a list -> 'a list or_bottom val list_of_bot: 'a list or_bottom -> 'a list (** [elt >:: list] adds [elt] to the [list] if it is not bottom. *) val add_to_list : 'a or_bottom -> 'a list -> 'a list (** Lattices in which both top and bottom are managed separately *) module Top: sig type 'a or_top_bottom = [ 'a or_bottom | `Top ] val join: ('a -> 'a -> 'a) -> 'a or_top_bottom -> 'a or_top_bottom -> 'a or_top_bottom val narrow: ('a -> 'a -> 'a or_bottom) -> 'a or_top_bottom -> 'a or_top_bottom -> 'a or_top_bottom end frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/lmap_bitwise.mli0000644000175000017500000001515213113745001026706 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 Locations exception Bitwise_cannot_copy module type Location_map_bitwise = sig type v type map type lmap = Top | Map of map | Bottom include Datatype.S with type t = lmap include Lattice_type.Bounded_Join_Semi_Lattice with type t := t include Lattice_type.With_Top with type t := t module LOffset : module type of Offsetmap_bitwise_sig with type v = v and type intervals = Int_Intervals.t val is_empty : t -> bool val is_bottom : t -> bool val empty : t val empty_map: map val pretty_generic_printer: ?pretty_v: v Pretty_utils.formatter -> ?skip_v: (v -> bool) -> sep:string -> unit -> t Pretty_utils.formatter val pretty_debug: t Pretty_utils.formatter val add_binding : exact:bool -> t -> Zone.t -> v -> t val add_binding_loc: exact:bool -> t -> location -> v -> t val add_base: Base.t -> LOffset.t -> t -> t val remove_base: Base.t -> t -> t val find : t -> Zone.t -> v val filter_base : (Base.t -> bool) -> t -> t (** {2 Iterators} *) val map: (v -> v) -> t -> t (** The following fold_* functions, as well as {!map2} take arguments of type [map] to force their user to handle the cases Top and Bottom explicitly. *) val fold: (Zone.t -> v -> 'a -> 'a) -> map -> 'a -> 'a (** [fold f m] folds a function [f] on the bindings in [m]. Contiguous bits with the same value are merged into a single zone. Different bases are presented in different zones. *) val fold_base : (Base.t -> LOffset.t -> 'a -> 'a) -> map -> 'a -> 'a val fold_fuse_same : (Zone.t -> v -> 'a -> 'a) -> map -> 'a -> 'a (** Same behavior as [fold], except if two non-contiguous ranges [r1] and [r2] of a given base are mapped to the same value. [fold] will call its argument [f] on each range successively (hence, in our example, on [r1] and [r2] separately). Conversely, [fold_fuse_same] will call [f] directly on [r1 U r2], U being the join on sets of intervals. *) val fold_join_zone: both:(Int_Intervals.t -> LOffset.t -> 'a) -> conv:(Base.t -> 'a -> 'b) -> empty_map:(Locations.Zone.t -> 'b) -> join:('b -> 'b -> 'b) -> empty:'b -> Locations.Zone.t -> map -> 'b (** [fold_join_zone ~both ~conv ~empty_map ~join ~empty z m] folds over the intervals present in [z]. When a base [b] is present in both [z] and [m], and bound respectively to [itvs] and [mb], [both itvs mb] is called. The results obtained for this base [b] are then converted using [conv]. If a sub-zone [z'] is present in [z], but the corresponding bases are not bound in [m], [empty_map z'] is called. All the sub-results (of type) ['b] are joined using [join]. [empty] is used when an empty map or sub-zone is encountered. It must be a neutral element for [join]. This function internally uses a cache, and {b must} be partially applied to its named arguments. (This explains the somewhat contrived interface, in particular the fact that [both] and [conv] are not fused.) *) val map2: cache:Hptmap_sig.cache_type -> symmetric:bool -> idempotent:bool -> empty_neutral: bool -> (LOffset.t -> LOffset.t -> LOffset.map2_decide) -> (v -> v -> v) -> map -> map -> map (** 'map'-like function between two interval maps, implemented as a simultaneous descent in both maps. [map2 ~cache ~symmetric ~idempotent ~empty_neutral decide_fast f m1 m2] computes the map containing [k |-> f v_1 v_2] for all the keys [k] present in either [m1] or [m2]. When a key is present, [v_i] is the corresponding value in the map. When it is missing in one of the maps, a default value is generated. (See argument [default] to functor {!Make_bitwise} below.) [symmetric], [idempotent], [empty_neutral] and [decide_fast] are present for optimisation purposes, to avoid visiting some trees. If [symmetric] holds, [f v1 v2 = f v2 v1] must also holds. If [idempotent] holds, [f v v = v] must also holds. Similarly, if [empty_neutral] holds, [f v default = f default v = v] must hold. [decide_fast] is called before visiting two subtrees, and can be used to stop the recursion early. See the documentation of {!Offsetmap_sig.map2_decide}. Depending on the value of [cache], the results of this function will be cached. *) (** {2 Misc} *) val shape: map -> LOffset.t Hptmap.Shape(Base.Base).t val imprecise_write_msg: string ref (** 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 module type With_default = sig include Lattice_type.Bounded_Join_Semi_Lattice include Lattice_type.With_Top with type t := t include Lattice_type.With_Narrow with type t := t val default: t end module Make_bitwise(V : With_default) : Location_map_bitwise with type v = V.t (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/base.mli0000644000175000017500000002054613113745002025145 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** Abstraction of the base of an addressable memory zone, together with the validity of the zone.*) open Abstract_interp type cstring = CSString of string | CSWstring of Escape.wstring (** This type abstracts over the two kinds of constant strings present in strings. It is used in a few modules below Base. *) (** Validity for variables that might change size. *) type variable_validity = private { mutable weak : bool (** Indicate that the variable is weak, i.e. that it may represent multiple memory locations *); mutable min_alloc : Int.t (** First bit guaranteed to be valid; can be -1 *); mutable max_alloc : Int.t (** Last possibly valid bit *); max_allocable: Int.t (** Maximum valid bit after size increase *); } type base = private | Var of Cil_types.varinfo * validity (** Base for a standard C variable. *) | CLogic_Var of Cil_types.logic_var * Cil_types.typ * validity (** Base for a logic variable that has a C type. *) | Null (** Base for an address like [(int* )0x123] *) | String of int (** unique id of the constant string (one per code location)*) * cstring (** contents of the constant string *) | Allocated of Cil_types.varinfo * validity (** Base for a variable dynamically allocated via malloc/calloc/realloc *) and validity = | Empty (** For 0-sized bases *) | 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. *) | Variable of variable_validity (** Variable(min_alloc, max_alloc) means: - all offsets between [0] and [min_alloc] are valid; min_alloc can be -1, in which case no offsets are guaranteed to be valid. - offsets between [min_alloc+1] and [max_alloc] are potentially valid; - offsets above [max_alloc+1] are invalid. *) | Invalid (** Valid nowhere. Typically used for the NULL base, or for function pointers. *) module Base: sig include Datatype.S_with_collections with type t = base val id: t -> int end include Datatype.S_with_collections with type t = base module Hptset: Hptset.S with type elt = t and type 'a shape = 'a Hptmap.Shape(Base).t module SetLattice: Lattice_type.Lattice_Hashconsed_Set with module O = Hptset module Validity: Datatype.S with type t = validity (** [pretty_addr fmt base] pretty-prints the name of [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 (** Type of the memory block that starts from the given base. Useful to give to the function {!Bit_utils.pretty_bits}, typically. *) (** {2 Validity} *) val pretty_validity : Format.formatter -> validity -> unit val validity : t -> validity (** [validity_from_size size] returns [Empty] if [size] is zero, or [Known (0, size-1)] if [size > 0]. [size] must not be negative. @since Aluminium-20160501 *) val validity_from_size : Int.t -> validity val validity_from_type : Cil_types.varinfo -> validity type range_validity = | Invalid_range | Valid_range of Int_Intervals_sig.itv option (** [valid_range v] returns [Invalid_range] if [v] is [Invalid], [Valid_range None] if [v] is [Empty], or [Valid_range (Some (mn, mx))] otherwise, where [mn] and [mx] are the minimum and maximum (possibly) valid bounds of [v]. *) val valid_range: validity -> range_validity (** [is_weak_validity v] returns true iff [v] is a [Weak] validity. *) val is_weak_validity: validity -> bool val create_variable_validity: weak:bool -> min_alloc:Int.t -> max_alloc:Int.t -> variable_validity val update_variable_validity: variable_validity -> weak:bool -> min_alloc:Int.t -> max_alloc:Int.t -> unit (** Update the corresponding fields of the variable validity. Bases already weak cannot be made 'strong' through this function, and the validity bounds can only grow. *) (** {2 Finding bases} *) val of_varinfo: Cil_types.varinfo -> t val of_string_exp: Cil_types.exp -> t val of_c_logic_var: Cil_types.logic_var -> t (** Must only be called on logic variables that have a C type *) (** {2 Origin of the variable underlying a base} *) exception Not_a_C_variable val to_varinfo: t -> Cil_types.varinfo (** @return the variable's varinfo if the base corresponds to a C variable (in particular, not a logic variable). @raise Not_a_C_variable otherwise. *) 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_function : t -> bool (** {2 NULL base} *) val null : t val is_null : t -> bool val null_set: Hptset.t (** Set containing only the base {!null}. *) val min_valid_absolute_address: unit -> Int.t val max_valid_absolute_address: unit -> Int.t (** Bounds for option absolute-valid-range *) (** {2 Size of a base} *) val bits_sizeof : t -> Int_Base.t exception Not_valid_offset val is_valid_offset : for_writing:bool -> Int.t -> t -> Ival.t -> unit (** [is_valid_offset ~for_writing size b offset] checks that [offset] (expressed in bits) plus [size] bits is valid in [b]. It does nothing in this case, and raises [Not_valid_offset] if the offset may be invalid. *) (** {2 Misc} *) val is_read_only : t -> bool (** Is the base valid as a read/write location, or only for reading. The [const] attribute is not currently taken into account. *) val is_weak : t -> bool (** Is the given base a weak one (in the sens that its validity is {!Weak}). Only possible for {!Allocated} bases. *) val id : t -> int val is_aligned_by : t -> Int.t -> bool (** {2 Registering bases} This is only useful to create an initial memory state for analysis, and is never needed for normal users. *) val register_allocated_var: Cil_types.varinfo -> validity -> t (** Allocated variables are variables not present in the source of the program, but instead created through dynamic allocation. Their field [vsource] is set to false. *) val register_memory_var : Cil_types.varinfo -> validity -> t (** Memory variables are variables not present in the source of the program. They are created only to fill the contents of another variable. Their field [vsource] is set to false. *) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/abstract_interp.ml0000644000175000017500000007620313113745005027252 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 Can_not_subdiv let msg_emitter = Lattice_messages.register "Abstract_interp" open Lattice_type module Comp = struct type t = Lt | Gt | Le | Ge | Eq | Ne type result = True | False | Unknown let inv = function | Gt -> Le | Lt -> Ge | Le -> Gt | Ge -> Lt | Eq -> Ne | Ne -> Eq let sym = function | Gt -> Lt | Lt -> Gt | Le -> Ge | Ge -> Le | Eq -> Eq | Ne -> Ne let pretty_comp fmt = function | Gt -> Format.pp_print_string fmt ">" | Lt -> Format.pp_print_string fmt "<" | Le -> Format.pp_print_string fmt "<=" | Ge -> Format.pp_print_string fmt ">=" | Eq -> Format.pp_print_string fmt "==" | Ne -> Format.pp_print_string fmt "!=" let inv_result = function | Unknown -> Unknown | True -> False | False -> True end module Make_Lattice_Set(V:Lattice_Value): Lattice_Set with type O.elt = V.t = struct exception Error_Top module O = struct include Datatype.Set (FCSet.Make(V)) (V) (struct let module_name = "Make_lattice_set" end) end type t = Set of O.t | Top type set = t 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 filter f = function | Top -> Top | Set s -> Set (O.filter f s) 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 join_and_is_included t1 t2 = let t12 = join t1 t2 in (t12, equal t12 t2) 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 = set let name = V.name ^ " lattice_set" let structural_descr = Structural_descr.t_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) : Datatype.S with type t := t) end module Make_Hashconsed_Lattice_Set(V: Hptmap.Id_Datatype)(O: Hptset.S with type elt = V.t) : Lattice_Hashconsed_Set with module O = O = struct exception Error_Top module O = O type t = Set of O.t | Top type set = t 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 filter f = function | Top -> Top | Set o as s -> let o' = O.filter f o in if o == o' then s else Set o' 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 join_and_is_included t1 t2 = let t = join t1 t2 in (t, t == t2) let intersects t1 t2 = match t1,t2 with | _,Top | Top,_ -> true | Set s1,Set s2 -> O.intersects s1 s2 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 = set let name = V.name ^ " hashconsed_lattice_set" let structural_descr = Structural_descr.t_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) : Datatype.S with type t := t) let () = Type.set_ml_name ty None end module Make_Lattice_Base (V:Lattice_Value):(Lattice_Base with type l = V.t) = struct type l = V.t type t = Top | Bottom | Value of l type base = t 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 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 join_and_is_included t1 t2 = let t = join t1 t2 in (t, equal t t2);; let intersects t1 t2 = not (equal (meet t1 t2) Bottom) include (Datatype.Make (struct type t = base (*= Top | Bottom | Value of l*) let name = V.name ^ " lattice_base" let structural_descr = Structural_descr.t_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) : Datatype.S with type t := t) let () = Type.set_ml_name ty None end module Int = struct include (Integer: module type of Integer with type t = Integer.t) include (Datatype.Integer: 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 rec fold_incr ~counter ~inf acc = if equal counter onethousand then Lattice_messages.emit_costly msg_emitter "enumerating %a integers" pretty nb_loop; if le inf sup then begin (* Format.printf "Int.fold: %a@\n" pretty inf; *) fold_incr ~counter:(succ counter) ~inf:(add step inf) (f inf acc) end else acc in let rec fold_decr ~counter ~sup acc = if equal counter onethousand then Lattice_messages.emit_costly msg_emitter "enumerating %a integers" pretty nb_loop; if le inf sup then begin (* Format.printf "Int.fold: %a@\n" pretty inf; *) fold_decr ~counter:(succ counter) ~sup:(add step sup) (f sup acc) end else acc in if le zero step then fold_incr ~counter:zero ~inf acc else fold_decr ~counter:zero ~sup acc end (* Typing constraints are enforced 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 Bool = struct type t = Top | True | False | Bottom let hash (b : t) = Hashtbl.hash b let equal (b1 : t) (b2 : t) = b1 = b2 let compare (b1 : t) (b2 : t) = Pervasives.compare b1 b2 let pretty fmt = function | Top -> Format.fprintf fmt "Top" | True -> Format.fprintf fmt "True" | False -> Format.fprintf fmt "False" | Bottom -> Format.fprintf fmt "Bottom" let is_included t1 t2 = match t1, t2 with | Bottom, _ | _, Top | True, True | False, False -> true | _ -> false let bottom = Bottom let top = Top let join b1 b2 = match b1, b2 with | Top, _ | _, Top | True, False -> Top | True, _ | _, True -> True | False, _ | _, False -> False | Bottom, Bottom -> Bottom let narrow b1 b2 = match b1, b2 with | Bottom, _ | _, Bottom | True, False -> Bottom | True, _ | _, True -> True | False, _ | _, False -> False | Top, Top -> Top let link = join let meet = narrow let join_and_is_included b1 b2 = join b1 b2, is_included b1 b2 type widen_hint = unit let widen () = join let cardinal_zero_or_one b = not (equal b top) let intersects b1 b2 = match b1, b2 with | Bottom, _ | _, Bottom -> false | _, Top | Top, _ -> true | False, False | True, True -> true | False, True | True, False -> false let diff b1 b2 = match b1, b2 with | b1, Bottom -> b1 | _, Top -> Bottom | Bottom, _ -> Bottom | Top, True -> False | Top, False -> True | True, True -> Bottom | True, False -> True | False, True -> False | False, False -> Bottom let diff_if_one b1 b2 = match b1, b2 with | b1, Top -> b1 | _, _ -> diff b1 b2 let fold_enum f b init = let elements = match b with | Top -> [True; False] | True -> [True] | False -> [False] | Bottom -> [] in List.fold_right (fun b acc -> f b acc) elements init let cardinal = function | Top -> 2 | True | False -> 1 | Bottom -> 0 let cardinal_less_than b i = let c = cardinal b in if c > i then raise Not_less_than else c type blt = t include (Datatype.Make_with_collections (struct type t = blt let name = "Bool_lattice" let structural_descr = Structural_descr.t_abstract let reprs = [Top; True; False; Bottom] let equal = equal let compare = compare let hash = hash let rehash = Datatype.identity let copy = Datatype.identity let pretty = pretty let internal_pretty_code = Datatype.undefined let varname = Datatype.undefined let mem_project = Datatype.never_any_project end) : Datatype.S with type t := t) exception Error_Top (* for With_Error_Top *) end module type Collapse = sig val collapse : bool end (** If [C.collapse] then [L1.Bottom,_ = _,L2.Bottom = Bottom] *) module Make_Lattice_Product(L1:AI_Lattice_with_cardinal_one)(L2:AI_Lattice_with_cardinal_one)(C:Collapse): (Lattice_Product with type t1 = L1.t and type t2 = L2.t) = struct type t1 = L1.t type t2 = L2.t type t = Product of t1*t2 | Bottom type product = t 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_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 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.link l1 l2, L2.link ll1 ll2) let narrow x1 x2 = if x1 == x2 then x1 else match x1,x2 with | Bottom, _ | _, Bottom -> Bottom | Product (l1,ll1), Product (l2,ll2) -> let l1 = L1.narrow l1 l2 in let l2 = L2.narrow ll1 ll2 in inject l1 l2 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 join_and_is_included x1 x2 = let x12 = join x1 x2 in (x12, equal x12 x2) include (Datatype.Make (struct type t = product (*= Product of t1*t2 | Bottom*) let name = "(" ^ L1.name ^ ", " ^ L2.name ^ ") lattice_product" let structural_descr = Structural_descr.t_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) : Datatype.S with type t := t) let () = Type.set_ml_name ty None end module Make_Lattice_UProduct(L1:AI_Lattice_with_cardinal_one)(L2:AI_Lattice_with_cardinal_one): (Lattice_UProduct with type t1 = L1.t and type t2 = L2.t) = struct type t1 = L1.t type t2 = L2.t type t = t1 * t2 type widen_hint = L1.widen_hint * L2.widen_hint let hash (v1, v2) = L1.hash v1 + 31 * L2.hash v2 let cardinal_zero_or_one (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_uproduct: \ %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 | (a,b), (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 | ( (a,b)), ( (a',b')) -> L1.equal a a' && L2.equal b b' let top = (L1.top,L2.top) let bottom = L1.bottom,L2.bottom 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 (L1.widen wh1 t1 l1), (L2.widen wh2 t2 l2) let join (l1,ll1) (l2,ll2) = L1.join l1 l2, L2.join ll1 ll2 let link (l1,ll1) (l2,ll2) = L1.link l1 l2, L2.link ll1 ll2 let narrow (l1,ll1) (l2,ll2) = L1.narrow l1 l2, L2.narrow ll1 ll2 let meet (l1,ll1) (l2,ll2) = L1.meet l1 l2, L2.meet ll1 ll2 let pretty fmt (l1, l2) = Format.fprintf fmt "(%a,%a)" L1.pretty l1 L2.pretty l2 let intersects (l1,ll1) (l2,ll2) = (L1.intersects l1 l2) && (L2.intersects ll1 ll2) let is_included x1 x2 = (x1 == x2) || match x1,x2 with | (l1,ll1), (l2,ll2) -> (L1.is_included l1 l2) && (L2.is_included ll1 ll2) let join_and_is_included (l1,ll1) (l2,ll2) = let (l,b) = L1.join_and_is_included l1 l2 in if b then let (ll,bb) = L2.join_and_is_included ll1 ll2 in ((l,ll),bb) else ((l, L2.join ll1 ll2), false);; include (Datatype.Make (struct type uproduct = t type t = uproduct (*= t1*t2 *) let name = "(" ^ L1.name ^ ", " ^ L2.name ^ ") lattice_uproduct" let structural_descr = Structural_descr.t_sum [| [| L1.packed_descr; L2.packed_descr |] |] let reprs = List.fold_left (fun acc l1 -> List.fold_left (fun acc l2 -> (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): Datatype.S with type t := t) let () = Type.set_ml_name ty None end module Make_Lattice_Sum (L1:AI_Lattice_with_cardinal_one) (L2:AI_Lattice_with_cardinal_one): (Lattice_Sum with type t1 = L1.t and type t2 = L2.t) = struct 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_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 u v = if u == v then u else match u,v with | T1 t1,T1 t2 -> T1 (L1.link t1 t2) | T2 t1,T2 t2 -> T2 (L2.link t1 t2) | Bottom,x| x,Bottom -> x | _,_ -> (*Format.printf "Degenerating collision : %a <==> %a@\n" pretty u pretty v;*) top let narrow u v = if u == v then u else match u,v with | T1 t1,T1 t2 -> inject_t1 (L1.narrow t1 t2) | T2 t1,T2 t2 -> inject_t2 (L2.narrow t1 t2) | (T1 _ | T2 _),Top -> u | Top,(T1 _ | T2 _) -> v | Top,Top -> top | T1 _, T2 _ | T2 _, T1 _ | Bottom, _ | _, Bottom -> bottom 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 | T1 _, T2 _ | T2 _, T1 _ | Bottom, _ | _, Bottom -> 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 join_and_is_included a b = let ab = join a b in (ab, equal a b) include Datatype.Make (struct type t = sum let name = "(" ^ L1.name ^ ", " ^ L2.name ^ ") lattice_sum" let structural_descr = Structural_descr.t_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-Phosphorus-20170501/src/kernel_services/abstract_interp/offsetmap_sig.mli0000644000175000017500000003017713113745010027061 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 type alarm = bool (** [true] indicates that an alarm may have occurred *) include Datatype.S (** Datatype for the offsetmaps *) (** {2 Pretty-printing} *) val pretty_generic: ?typ:Cil_types.typ -> ?pretty_v:(Cil_types.typ option -> Format.formatter -> v -> unit) -> ?skip_v:(v -> bool) -> ?sep:string -> unit -> 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 of_list: ((t -> v -> t) -> t -> 'l -> t) -> 'l -> Int.t -> t (** [from_list fold c size] creates an offsetmap by applying the iterator [fold] to the container [c], the elements of [c] being supposed to be of size [size]. [c] must be such that [fold] is called at least once. *) val empty: t (** offsetmap containing no interval. *) val size_from_validity: Base.validity -> Integer.t Bottom.or_bottom (** [size_from_validity v] returns the size to be used when creating a new offsetmap for a base with validity [v]. This is a convention that must be shared by all modules that create offsetmaps, because operations such as {!join} or {!is_included} require offsetmaps of the same . Returns [`Bottom] iff [v] is {!Base.Invalid}. @since Aluminium-20160501 *) (** {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 follows: - [(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: ?direction:[`LTR | `RTL] -> entire:bool -> Int.t * Int.t -> ((Int.t * Int.t) -> (v * Int.t * Rel.t) -> 'a -> 'a) -> t -> 'a -> 'a (** [fold_between ~direction:`LTR ~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. [fold_between ~direction:`RTL] reverses the iteration order: interval are passed in decreasing order. Default is [`LTR]. *) (** {2 Interval-unaware iterators} *) val iter_on_values: (v -> 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. Interval bounds, the alignment of the value and its size are not computed. *) val fold_on_values: (v -> 'a -> 'a) -> t -> 'a -> 'a (** Same as [iter_on_values] but with an accumulator *) val map_on_values: (v -> v) -> t -> t (** [map_on_values f m ] creates the map derived from [m] by applying [f] to each interval. For each interval, the size of the new value and its offset relative to the beginning of the interval is kept unchanged. *) type map2_decide = ReturnLeft | ReturnRight | ReturnConstant of v | Recurse (** This type describes different possibilities to accelerate a simultaneous iteration on two offsetmaps. {!ReturnLeft} (resp. {!ReturnRight}) means 'return the left (resp. right) operand unchanged, and stop the recursive descent'. [ReturnConstant v] means 'return a constant offsetmap of the good size and that contains [v] everywhere'. It is always correct to return {!Recurse}, which will force the recursion until the maps have been fully decomposed. Typical usage include functions that verify [f v v = v], maps [m] such that [f m m' = m'], etc. *) val map2_on_values: Hptmap_sig.cache_type -> (t -> t -> map2_decide) -> (v -> v -> v) -> t -> t -> t (** [map2_on_values cache decide join m1 m2] applies [join] pointwise to all the elements of [m1] and [m2] and builds the resulting map. This function can only be called if [m1] and [m2] contain isotropic values. [decide] is called during the iteration, and can be used to return early; it is always correct to return {!Recurse}. Depending on [cache], the results of the partially applied function [map2_on_values cache decide join] will be cached between different calls. *) (** {2 Join and inclusion testing} *) include Lattice_type.Join_Semi_Lattice with type t := t 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 Narrowing} *) module Make_Narrow (X: sig include Lattice_type.With_Top with type t := v include Lattice_type.With_Narrow with type t := v end) : sig val narrow: t -> t -> t (** Over-approximation of the intersection of abstract values, without considering (bitwise) reinterpretations. In particular, values with equivalent representations (e.g. [-1] and [0xFF] on 8 bits) may be considered different, leading to empty intersections. This may result in unsound results; the function {!narrow_reinterpret} below should be preferred in general. *) val narrow_reinterpret: t -> t -> t (** Variant of the function above that bitwise-reinterprets values before performing the intersection (in order to get normal forms). This may lead to situations where the result is not included in the arguments, but this function should be preferred to {!narrow}. *) end (** {2 Searching values} *) val find : validity:Base.validity -> ?conflate_bottom:bool -> offsets:Ival.t -> size:Integer.t -> t -> bool * v (** Find the value bound to a set of intervals, expressed as an ival, in the given rangemap. The returned boolean (alarm) indicates that at least one of the offsets does not comply with [validity]. *) val find_imprecise: validity:Base.validity-> t -> v (** [find_imprecise ~validity m] returns an imprecise join of the values bound in [m], in the range described by [validity]. *) val find_imprecise_everywhere: t -> v (** Returns an imprecise join of all the values bound in the offsetmap. *) val copy_slice: validity:Base.validity -> offsets:Ival.t -> size:Integer.t -> t -> alarm * t Bottom.or_bottom (** [copy_slice ~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. [size] must be strictly greater than zero. *) (** {2 Adding values} *) val add : ?exact:bool -> (Int.t * Int.t) -> (v * Int.t * Rel.t) -> t -> t (** [add (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]. *) val update : ?origin:Origin.t -> validity:Base.validity -> exact:bool -> offsets:Ival.t -> size:Int.t -> v -> t -> alarm * t Bottom.or_bottom (** [update ?origin ~validity ~exact ~offsets ~size v m] writes [v], of size [size], each [offsets] in [m]; [m] must be of the size implied by [validity]. [~exact=true] results in a strong update, while [~exact=false] performs a weak update. If [offsets] contains too many offsets, or if [offsets] and [size] are not compatible, [offsets] and/or [v] are over-approximated. In this case, [origin] is used as the source of the resulting imprecision. Returns [`Bottom] when all offsets are invalid. The boolean returned indicates a potential alarm. *) val update_under : validity:Base.validity -> exact:bool -> offsets:Ival.t -> size:Int.t -> v -> t -> alarm * t Bottom.or_bottom (** Same as {!update}, except that no over-approximation on the set of offsets or on the value written occurs. In case of imprecision, [m] is not updated. *) val update_imprecise_everywhere: validity:Base.validity -> Origin.t -> v -> t -> t Bottom.or_bottom (** [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: validity:Base.validity -> exact:bool -> from:t -> size:Int.t -> offsets:Ival.t -> t -> alarm * t Bottom.or_bottom (** {2 Shape} *) 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. *) val is_single_interval: t -> bool (** [is_single_interval o] is true if the offsetmap [o] contains a single binding. *) val single_interval_value: t -> v option (** [single_interval_value o] returns [Some v] if [o] contains a single interval, to which [v] is bound, and [None] otherwise. *) val is_same_value: t -> v -> bool (** [is_same_value o v] is true if the offsetmap [o] contains a single binding to [v], or is the empty offsetmap. *) (** {2 Misc} *) val imprecise_write_msg: string ref (** The message "more than N . Approximating." is displayed when the offsetmap must update too many locations in one operation. *) (** 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 (**/**) val pretty_debug: t Pretty_utils.formatter (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/locations.mli0000644000175000017500000003450313113745002026224 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 (** Association between bases 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 (** Mapping from bases to bytes-expressed offsets *) 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 val shape: t -> Ival.t Hptmap.Shape(Base.Base).t end type t = | Top of Base.SetLattice.t * Origin.t (** Garbled mix of the addresses in the set *) | Map of M.t (** Precise set of addresses+offsets *) (** This type should be considered private *) (* TODO: make it private when OCaml 4.01 is mandatory *) type size_widen_hint = Ival.size_widen_hint type generic_widen_hint = Base.t -> Ival.generic_widen_hint type widen_hint = size_widen_hint * generic_widen_hint (** Those locations have a lattice structure, including standard operations such as [join], [narrow], etc. *) include Lattice_type.AI_Lattice_with_cardinal_one with type t := t and type widen_hint := widen_hint include Lattice_type.With_Error_Top include Datatype.S_with_collections with type t := t 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 : Fval.F.t -> t val add : Base.t -> Ival.t -> t -> t (** [add b i loc] binds [b] to [i] in [loc] when [i] is not {!Ival.bottom}, and returns {!bottom} otherwise. *) 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 val shift_under : Ival.t -> t -> t (** Over- and under-approximation of shifting the value by the given Ival. *) val sub_pointwise: ?factor:Int_Base.t -> t -> t -> Ival.t (** Subtracts the offsets of two locations [loc1] and [loc2]. Returns the pointwise subtraction of their offsets [off1 - factor * off2]. [factor] defaults to [1]. *) (** 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 topify_with_origin: Origin.t -> t -> t val topify_with_origin_kind: Origin.kind -> t -> t val inject_top_origin : Origin.t -> Base.Hptset.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. *) (* {2 Iterators} *) 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 fold_topset_ok: (Base.t -> Ival.t -> 'a -> 'a) -> t -> 'a -> 'a (** Fold with offsets, including in the case [Top bases]. In this case, [Ival.top] is supplied to the iterator. @raise Error_Top in the case [Top Top]. *) val fold_enum : (t -> 'a -> 'a) -> t -> 'a -> 'a (** [fold_enum f loc acc] enumerates the locations in [acc], and passes them to [f]. Make sure to call {!cardinal_less_than} before calling this function, as all possible combinations of bases/offsets are presented to [f]. Raises {!Error_Top} if [loc] is [Top _] or if one offset cannot be enumerated. *) val cached_fold: cache_name:string -> 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 *) val filter_base : (Base.t -> bool) -> t -> t (** {2 Number of locations} *) val cardinal_zero_or_one : t -> bool val cardinal_less_than : t -> int -> int (** [cardinal_less_than v card] returns the cardinal of [v] if it is less than [card], or raises [Not_less_than]. *) val cardinal: t -> Integer.t option (** None if the cardinal is unbounded *) val find_lonely_key : t -> Base.t * Ival.t (** if there is only one base [b] in the location, then returns the pair [b,o] where [o] are the offsets associated to [b]. @raise Not_found otherwise. *) val find_lonely_binding : t -> Base.t * Ival.t (** if there is only one binding [b -> o] in the location (that is, only one base [b] with [cardinal_zero_or_one o]), returns the pair [b,o]. @raise Not_found otherwise *) (** {2 Destructuring} *) val find: Base.t -> t -> Ival.t 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 to. Never fails, but may return [Base.SetLattice.Top]. *) (** {2 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 address of a variable for which [is_local] returns [true] *) val remove_escaping_locals : (M.key -> bool) -> t -> bool * t (** [remove_escaping_locals is_local v] removes from [v] the information associated with bases for which [is_local] returns [true]. The returned boolean indicates that [v] contained some locals. *) val contains_addresses_of_any_locals : t -> bool (** [contains_addresses_of_any_locals loc] returns [true] iff [loc] contains the address of a local variable or of a formal variable. *) (** {2 Misc} *) 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] *) (** [is_relationable loc] returns [true] iff [loc] represents a single memory location. *) 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 get_garbled_mix: unit -> t list (** All the garbled mix that have been created so far, sorted by "temporal" order of emission. *) val clear_garbled_mix: unit -> unit (** Clear the information on created garbled mix. *) val do_track_garbled_mix: bool -> unit (**/**) val pretty_debug: t Pretty_utils.formatter val clear_caches: unit -> unit end (** Association between bases and offsets in bits. @plugin development guide *) module Location_Bits : module type of Location_Bytes (** Association between bases and ranges of bits. @plugin development guide *) module Zone : sig type map_t (** This type should be considered private *) (* TODO: make it private when OCaml 4.01 is mandatory *) type t = private Top of Base.SetLattice.t * Origin.t | Map of map_t include Datatype.S_with_collections with type t := t val pretty_debug: t Pretty_utils.formatter include Lattice_type.Bounded_Join_Semi_Lattice with type t := t include Lattice_type.With_Top with type t := t include Lattice_type.With_Narrow with type t := t include Lattice_type.With_Under_Approximation with type t := t include Lattice_type.With_Diff with type t := t val is_bottom: t -> bool val inject : Base.t -> Int_Intervals.t -> t 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 find: Base.t -> 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 (** {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_name:string -> temporary:bool -> f:(Base.t -> Int_Intervals.t -> 'b) -> projection:(Base.t -> Int_Intervals.t) -> joiner:('b -> 'b -> 'b) -> empty:'b -> t -> 'b val fold2_join_heterogeneous: cache:Hptmap_sig.cache_type -> empty_left:('a Hptmap.Shape(Base.Base).t -> 'b) -> empty_right:(t -> 'b) -> both:(Base.t -> Int_Intervals.t -> 'a -> 'b) -> join:('b -> 'b -> 'b) -> empty:'b -> t -> 'a Hptmap.Shape(Base.Base).t -> 'b (** {3 Misc} *) val shape: map_t -> Int_Intervals.t Hptmap.Shape(Base.Base).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 is_bottom_loc: location -> bool 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 valid_part : for_writing:bool -> ?bitfield: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 may not be reduced by [valid_part]. [bitfield] indicates whether the location may be the one of a bitfield, and is true by default. If it is set to false, the location is assumed to be byte aligned, and its offset (expressed in bits) is reduced to be congruent to 0 modulo 8. *) 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} *) (* Note: the first two operations are exact (if offsets are not floats.) The last one can return an over-approximation, and has an under-approximating counterpart. *) 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 loc_bits_to_loc_bytes_under : Location_Bits.t -> Location_Bytes.t val enumerate_bits : location -> Zone.t val enumerate_bits_under : location -> Zone.t val enumerate_valid_bits : for_writing:bool -> location -> Zone.t (** @plugin development guide *) val enumerate_valid_bits_under : for_writing:bool -> location -> Zone.t 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-Phosphorus-20170501/src/kernel_services/abstract_interp/fval.ml0000644000175000017500000013626413113745010025016 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 F = struct type t = float let packed_descr = Structural_descr.p_float (** NOTE: all floating-point comparisons using OCaml's standard operators do NOT distinguish between -0.0 and 0.0. Whenever floats are compared using them, it implies that negative zeroes are also considered, e.g. "if x < 0.0" is equivalent to "if x < -0.0", which is also equivalent to "F.compare x (-0.0) < 0". This 'compare' operator distinguishes -0. and 0. *) (* replace "noalloc" with [@@noalloc] for OCaml version >= 4.03.0 *) [@@@ warning "-3"] external compare : float -> float -> int = "float_compare_total" "noalloc" [@@@ warning "+3"] let equal f1 f2 = compare f1 f2 = 0 (* The Caml version of compare below is fine but the C version above is faster and does not allocate—it would be possible for the Caml version to avoid allocation, but OCaml 4.00.1 allocates 80 bytes, for instance *) (* 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 le f1 f2 = compare f1 f2 <= 0 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 zero = 0.0 let minus_zero = -0.0 let max_single_precision_float = Floating_point.max_single_precision_float let most_negative_single_precision_float = Floating_point.most_negative_single_precision_float let max_float = max_float let infinity = infinity let neg_infinity = neg_infinity let most_negative_float = -. max_float (* Maximum integer value M such that all 0 < n < M are exactly representable as doubles. *) let max_precise_integer = 2. ** 53. (* works but allocates: let is_negative f = Int64.bits_of_float f < Int64.zero *) (* replace "noalloc" with [@@noalloc] for OCaml version >= 4.03.0 *) [@@@ warning "-3"] external is_negative : float -> bool = "float_is_negative" "noalloc" [@@@ warning "+3"] let zero_of_same_sign f = if is_negative f then minus_zero else zero let is_infinity = (=) infinity let is_neg_infinity = (=) neg_infinity (* Must *not* be exported. All functions of this module should check the arguments with which they call the functions labelled "may raise Nan exception" *) exception NaN (* May raise NaN exception *) let ensure_not_nan r = match classify_float r with | FP_nan -> raise NaN | FP_normal | FP_subnormal | FP_infinite | FP_zero -> r let ensure_not_nan_unary f x = ensure_not_nan (f x) let ensure_not_nan_binary f x y = ensure_not_nan (f x y) let add = ensure_not_nan_binary (+.) let sub = ensure_not_nan_binary (-.) let neg = ensure_not_nan_unary (~-.) let mult = ensure_not_nan_binary ( *.) (* May raise NaN exception on zero divisor *) let div = ensure_not_nan_binary (/.) 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 (* assumption: [0. <= x <= y]. returns the median of the range [x..y] in number of double values. *) let split_positive x y = let ix = Int64.bits_of_float x in let iy = Int64.bits_of_float y in Int64.(float_of_bits (add ix (div (sub iy ix) 2L))) (* assumption: [x <= y] *) let _split x y = match is_negative x, is_negative y with | false, false -> split_positive x y | true, true -> -. (split_positive (-.x) (-.y)) | true, false -> minus_zero | false, true -> assert false let le_ieee = ((<=) : float -> float -> bool) let lt_ieee = ((<) : float -> float -> bool) let sqrt = (* See bts #1396. We patch Pervasives function only when needed *) if compare (sqrt minus_zero) minus_zero <> 0 then fun v -> if v = minus_zero then v else sqrt v else sqrt (* May raise NaN exception on negative arguments *) let sqrt = ensure_not_nan_unary sqrt let cos = ensure_not_nan_unary cos let sin = ensure_not_nan_unary sin let exp = ensure_not_nan_unary exp (* May raise NaN exception on negative or zero arguments *) let log = ensure_not_nan_unary log let log10 = ensure_not_nan_unary log10 let floor = ensure_not_nan_unary floor let ceil = ensure_not_nan_unary ceil let trunc = ensure_not_nan_unary Floating_point.trunc let fround = ensure_not_nan_unary Floating_point.fround let atan2 = ensure_not_nan_binary atan2 (* May raise NaN exception *) let pow = ensure_not_nan_binary ( ** ) (* May raise NaN exception on zero second argument *) let fmod = ensure_not_nan_binary mod_float (* single-precision *) let expf = ensure_not_nan_unary Floating_point.expf let logf = ensure_not_nan_unary Floating_point.logf let log10f = ensure_not_nan_unary Floating_point.log10f let powf = ensure_not_nan_binary Floating_point.powf let sqrtf = ensure_not_nan_unary Floating_point.sqrtf 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 next_previous_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 next_previous int64fup int64fdown float = match classify_float float with | FP_nan -> raise NaN | FP_infinite -> float | FP_normal | FP_subnormal -> begin let f = next_previous_normal int64fup int64fdown float in match classify_float f with | FP_nan -> assert false (* can only be produced from an infinity *) | FP_infinite | FP_normal | FP_subnormal | FP_zero -> f end | FP_zero -> (next_previous_normal int64fup int64fdown (float +. min_float)) -. min_float let next_float = next_previous Int64.succ Int64.pred let prev_float = next_previous Int64.pred Int64.succ let id = fun x -> x let of_float = ensure_not_nan_unary id let to_float = id let classify_float = Pervasives.classify_float end type float_kind = Float32 | Float64 exception Non_finite (* Alarms produced by built-ins. *) type builtin_alarm = APosInf | ANegInf | ANaN of string | AAssume of string module Builtin_alarms = Set.Make(struct type t = builtin_alarm let compare (x : t) (y : t) = Pervasives.compare x y end) let no_alarm = Builtin_alarms.empty let an_alarm a = Builtin_alarms.singleton a let next_after fkind x y = match fkind with | Float32 -> Floating_point.nextafterf x y | Float64 -> Floating_point.nextafter x y let max_representable_float = function | Float32 -> F.max_single_precision_float | Float64 -> F.max_float let most_negative_representable_float = function | Float32 -> F.most_negative_single_precision_float | Float64 -> F.most_negative_float type denormal_treatment = Denormals | FTZ | DenormalsandFTZ let denormal_treatment = Denormals let _ = DenormalsandFTZ (* VP: silence warning about unused DenormalsandFTZ *) module FRange : sig type t = private I of F.t * F.t val inject : F.t -> F.t -> t val inject_r_f : float_kind -> F.t -> F.t -> (bool * bool * t) end = struct type t = I of F.t * F.t let inject b e = if not (F.le b e) then Kernel.fatal "Invalid bounds for float interval@\n%a .. %a@." (F.pretty_normal ~use_hex:true) b (F.pretty_normal ~use_hex:true) e; I(b, e) (* If [fkind] is [Float32], we check that [b] and [e] are valid 32-bit representations: lower bits are 0, and the value fits inside a 32-bit float. *) let check_representability fkind b e = if fkind = Float32 && (Floating_point.round_to_single_precision_float b <> b || Floating_point.round_to_single_precision_float e <> e) then Kernel.fatal "Ival: invalid float32, b=%g (%a) e=%g (%a)" b (Floating_point.pretty_normal ~use_hex:true) b e (Floating_point.pretty_normal ~use_hex:true) e let inject_r_f fkind b e = if F.is_neg_infinity e || F.is_infinity b then raise Non_finite; let infinite_e, e = match F.classify_float e with | FP_infinite -> let pos = F.le_ieee F.zero e in if pos then true, max_representable_float fkind else raise Non_finite | FP_subnormal -> let pos = F.le_ieee F.zero e in begin match pos with | true when denormal_treatment = FTZ -> false, F.zero | false when denormal_treatment <> Denormals -> false, F.minus_zero | _ -> false, e end | FP_normal | FP_zero -> false, e | FP_nan -> assert false in let infinite_b, b = match F.classify_float b with | FP_infinite -> let pos = F.le_ieee F.zero b in if pos then raise Non_finite else true, most_negative_representable_float fkind | FP_subnormal -> let pos = F.le_ieee F.zero b in begin match pos with | false when denormal_treatment = FTZ -> false, F.minus_zero | true when denormal_treatment <> Denormals -> false, F.zero | _ -> false, b end | FP_normal | FP_zero -> false, b | FP_nan -> assert false in check_representability fkind b e; infinite_b, infinite_e, inject b e end type t = FRange.t (* open Private_Couple *) (* Workaround for Ocaml bug 5718 *) type builtin_res = Builtin_alarms.t * FRange.t Bottom.or_bottom let structural_descr = Structural_descr.t_sum [| [| F.packed_descr; F.packed_descr |] |] let packed_descr = Structural_descr.pack structural_descr let inject = FRange.inject let inject_r_f = FRange.inject_r_f let inject_r b e = let ib, ie, r = FRange.inject_r_f Float64 b e in ib || ie, r let inject_f fkind b e = let _,_,r = (inject_r_f fkind b e) in r let min_and_max (FRange.I(b,e)) = b, e let top_f fkind = inject (most_negative_representable_float fkind) (max_representable_float fkind) let top = top_f Float64 let compare (FRange.I(b1,e1)) (FRange.I(b2,e2)) = let r = F.compare b1 b2 in if r <> 0 then r else F.compare e1 e2 let equal (FRange.I(b1,e1)) (FRange.I(b2,e2)) = F.equal b1 b2 && F.equal e1 e2 let pretty_aux pp_min pp_max fmt (FRange.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 Floating_point.set_round_nearest_even (); Format.fprintf fmt "[%a ++ %a]" F.pretty b F.pretty d end else begin Format.fprintf fmt "[%a .. %a]" pp_min b pp_max e end end let pretty = pretty_aux F.pretty F.pretty let pretty_overflow = let pp_aux bound fmt f = if F.equal bound f then Format.pp_print_string fmt "--." else F.pretty fmt f in let pp_min = pp_aux F.most_negative_float in let pp_max = pp_aux F.max_float in pretty_aux pp_min pp_max let hash (FRange.I(b,e)) = F.hash b + (5 * F.hash e) (* True only iff the interval contains at least one finite number. *) let has_finite (FRange.I(b, e)) = let is_finite f = match classify_float f with | FP_nan | FP_infinite -> false | _ -> true in match is_finite b, is_finite e with | false, false -> (* check if the interval is not [-oo,+oo] *) F.is_neg_infinity b && F.is_infinity e | _, _ -> true let inject_singleton x = inject x x let one = inject_singleton F.one let zero = inject_singleton F.zero let minus_zero = inject_singleton F.minus_zero let zeros = inject F.minus_zero F.zero let compare_min (FRange.I(m1,_)) (FRange.I(m2,_)) = F.compare m1 m2 let compare_max (FRange.I(_, m1)) (FRange.I(_, m2)) = F.compare m2 m1 let is_included (FRange.I(b1, e1)) (FRange.I(b2, e2)) = F.le b2 b1 && F.le e1 e2 let join (FRange.I(b1, e1)) (FRange.I(b2, e2)) = inject (F.min b1 b2) (F.max e1 e2) let join_or_bottom = Bottom.join join let meet (FRange.I(b1, e1)) (FRange.I(b2, e2)) = if F.le b2 e1 && F.le b1 e2 then `Value (inject (F.max b1 b2) (F.min e1 e2)) else `Bottom let narrow = meet let contains_zero = is_included zero let contains_minus_zero = is_included minus_zero (* Returns true if [f] is certainly a zero (positive, negative or both). *) let is_a_zero f = is_included f zeros let fold_split n f (FRange.I(b, e)) acc = let bound = ref b in let acc = ref acc in begin 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; bound := new_bound done; end; (* Format.printf "float fold_split %a@." pretty (!bound, e); *) f (inject !bound e) !acc let contains_a_zero (FRange.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 (FRange.I(b, e)) = F.equal b e exception Not_Singleton_Float let project_float (FRange.I(b, e)) = if F.equal b e then b else raise Not_Singleton_Float let neg (FRange.I(b, e)) = inject (F.neg e) (F.neg b) (* do not round because exact operation *) let abs (FRange.I(b, e) as f) = if contains_zero f then inject F.zero (F.max (abs_float b) (abs_float e)) else if F.compare e F.zero < 0 then neg f else f 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 (FRange.I(b, e)) = 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 if rounding_mode = Any then Floating_point.set_round_nearest_even (); let infb, b = match classify_float b, denormal_treatment with | FP_infinite, _ -> if F.equal_ieee b F.infinity then raise Non_finite; true, F.most_negative_single_precision_float | FP_subnormal, FTZ -> false, F.zero_of_same_sign b | FP_subnormal, DenormalsandFTZ when not (F.is_negative 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 Non_finite; true, F.max_single_precision_float | FP_subnormal, FTZ -> false, F.zero_of_same_sign e | FP_subnormal, DenormalsandFTZ when F.is_negative e -> false, F.minus_zero | _ -> false, e in infb || infe, inject b e (* Format.printf "Casting double -> float %a -> %B %a@." pretty _arg fl pretty _res; fl, _res *) (* Bitwise reinterpretation of a double to a 64-bit integer. signedness of the integer is defined by ~signed *) let bits_of_float64 ~signed (FRange.I(l, u)) = if F.is_negative u then begin if signed then Int.of_int64 (Int64.bits_of_float u), Int.of_int64 (Int64.bits_of_float l) else Int.(add_2_64 (of_int64 (Int64.bits_of_float u))), Int.(add_2_64 (of_int64 (Int64.bits_of_float l))) end else if F.is_negative l then begin if signed then Int.of_int64 Int64.min_int, Int.of_int64 (Int64.bits_of_float u) else Int.zero, Int.(add_2_64 (of_int64 (Int64.bits_of_float l))) end else Int.of_int64 (Int64.bits_of_float l), Int.of_int64 (Int64.bits_of_float u) (* Bitwise reinterpretation of a float to a 32-bit integer. signedness of the integer is defined by ~signed *) let bits_of_float32 ~signed (FRange.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.is_negative u then begin if signed then Int.of_int32 (Int32.bits_of_float u), Int.of_int32 (Int32.bits_of_float l) else Int.(add_2_32 (of_int32 (Int32.bits_of_float u))), Int.(add_2_32 (of_int32 (Int32.bits_of_float l))) end else if F.is_negative l then begin if signed then Int.of_int32 Int32.min_int, Int.of_int32 (Int32.bits_of_float u) else Int.zero, Int.(add_2_32 (of_int32 (Int32.bits_of_float l))) end else Int.of_int32 (Int32.bits_of_float l), Int.of_int32 (Int32.bits_of_float u) let add rounding_mode (FRange.I(b1, e1)) (FRange.I(b2, e2)) = 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 if rounding_mode = Any then Floating_point.set_round_nearest_even (); inject_r bs es let sub rounding_mode v1 v2 = add rounding_mode v1 (neg v2) let mul rounding_mode (FRange.I(b1, e1)) (FRange.I(b2, e2)) = 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 Floating_point.set_round_nearest_even (); 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 (** Assumes that [v2] does not contain zero. No NaN can be created by F.div in this case. *) let div_non_zero rounding_mode (FRange.I(b1, e1)) (FRange.I(b2, e2)) = 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 Floating_point.set_round_nearest_even (); 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 div rounding_mode v1 v2 = if is_a_zero v2 then raise Non_finite else if contains_zero v2 then true, top (* could be improved when v2 is strictly positive or negative. However, if it very difficult to produce +0. without -0. or the converse. Thus, this is not worth the effort. *) else div_non_zero rounding_mode v1 v2 let nan_sqrt = an_alarm (ANaN "negative argument") let nan_sqrt_assume = Builtin_alarms.add (AAssume "non-negative argument") nan_sqrt (* [sqrt_f] is the actual function computing the (exact) square root, in single precision (sqrtf) or double precision (sqrt). *) let sqrt' sqrt_f rounding_mode (FRange.I(b, e)) = if F.lt_ieee e F.zero then nan_sqrt, `Bottom else let alarm, min = if F.le_ieee F.zero b then begin if rounding_mode = Any then Floating_point.set_round_downward () else Floating_point.set_round_nearest_even (); let min = sqrt_f b in if rounding_mode = Any then Floating_point.set_round_nearest_even (); no_alarm, min end else (* case e < 0 treated above, some values are positive or zero *) nan_sqrt_assume, F.minus_zero in if rounding_mode = Any then Floating_point.set_round_upward (); let max = sqrt_f e in if rounding_mode = Any then Floating_point.set_round_nearest_even (); alarm, `Value (inject min max) let sqrt = sqrt' F.sqrt let sqrtf = sqrt' F.sqrtf let minus_one_one = inject F.minus_one F.one let minus_pi_pi = inject F.m_minus_pi F.m_pi let atan2 (FRange.I(b1, e1)) (FRange.I(b2, e2)) = Floating_point.set_round_nearest_even (); let res = if F.equal b1 e1 && F.equal b2 e2 then begin let c = F.atan2 b1 b2 in inject c c end else (* Unless y ([b1,e1]) crosses the x-axis, atan2 is continuous, and its minimum/maximum are at the ends of the intervals of x and y. Otherwise, the result is [-pi,+pi]. *) if not (F.compare b1 F.zero < 0 && F.compare e1 F.minus_zero > 0) then let a1, a2, a3, a4 = F.atan2 b1 b2, F.atan2 b1 e2, F.atan2 e1 b2, F.atan2 e1 e2 in let b = F.min a1 (F.min a2 (F.min a3 a4)) in let e = F.max a1 (F.max a2 (F.max a3 a4)) in inject b e else minus_pi_pi in (no_alarm(* never emits alarms *), `Value res) (* Returns true iff [f] represents an integer. *) let is_integer f = f = (F.trunc f) (* Returns true iff [f] represents an odd integer. *) let is_odd f = abs_float (mod_float f 2.0) = 1.0 (* Maximum odd integer representable in float64 (2^53-1). *) let max_double_odd_integer = 9007199254740991.0 (* Maximum odd integer representable in float32 (2^24-1). *) let max_single_odd_integer = 16777215.0 (* Most negative odd integer representable in float64. *) let most_negative_double_odd_integer = -.max_double_odd_integer (* Most negative odd integer representable in float32. *) let most_negative_single_odd_integer = -.max_single_odd_integer let max_odd_integer fkind = match fkind with | Float64 -> max_double_odd_integer | Float32 -> max_single_odd_integer let most_negative_odd_integer fkind = match fkind with | Float64 -> most_negative_double_odd_integer | Float32 -> most_negative_single_odd_integer (* Returns [Some (⌈b⌉, ⌊e⌋), if ⌈b⌉ <= ⌊e⌋, or None otherwise. *) let enclosed_integer_range (FRange.I(b, e)) = let ib, ie = ceil b, floor e in if ib <= ie then Some (inject ib ie) else None (* [fkind] is not used, but present for symmetry with odd function *) let min_and_max_enclosed_even _fkind (FRange.I(b, e)) = assert (is_integer b); assert (is_integer e); let b_is_odd = is_odd b in if b_is_odd && b = e then (* odd singleton *) None else (* note: no rounding errors may happen below because odd numbers are bounded *) Some ((if b_is_odd then b +. 1.0 else b), if is_odd e then e -. 1.0 else e) (* large floating-point numbers are not symmetrical w.r.t. evenness *) let min_and_max_enclosed_odd fkind (FRange.I(b, e)) = assert (is_integer b); assert (is_integer e); let min_odd = if is_odd b then b else max (most_negative_odd_integer fkind) (b +. 1.0) in let max_odd = if is_odd e then e else min (max_odd_integer fkind) (e -. 1.0) in if max_odd < min_odd then None else Some (min_odd, max_odd) (* Returns true iff [b..e] contains at least one odd positive integer. *) let contains_odd_positive_integer fkind (FRange.I(b, e)) = if e < 1.0 || b > max_odd_integer fkind then false else let posb, pose = max 0.0 b, max 0.0 e in let ib, ie = ceil posb, floor pose in ib < ie || (ib = ie && is_odd ib) (* Splits [b..e] in (Some [b..f[, Some [f..e]). An empty sub-interval is represented by None. *) let split_interval fkind (FRange.I(b, e) as x) f = if F.compare b f > 0 || F.equal b f then (None, Some x) else if F.compare e f < 0 then (Some x, None) else let pred_f = next_after fkind f neg_infinity in (Some (inject b pred_f), Some (inject f e)) let nan_pow = an_alarm (ANaN "negative base and noninteger exponent") let nan_pow_assume1 = Builtin_alarms.add (AAssume ("non-negative base")) nan_pow let nan_pow_assume2 (FRange.I(b, e)) = assert (is_integer b && is_integer e); Builtin_alarms.add (AAssume (Printf.sprintf "integer exponent between %g and %g for negative bases" b e)) nan_pow (* Negative x => function is only defined for integer values of y. *) let pow_negative_x pow_f fkind ox y : builtin_res = match ox with | None -> no_alarm, `Bottom | Some (FRange.I(x1, x2)) -> match enclosed_integer_range y with | None -> (* no integer values of y *) nan_pow_assume1, `Bottom | Some y_int -> (* alert if y may contain non-integer values *) let alarms = if not (is_a_zero y) && (y <> y_int || not (is_singleton y)) then nan_pow_assume2 y_int else no_alarm in let compute_for_integer_y ~even min_and_max_f fkind y_int = match min_and_max_f fkind y_int with | None -> no_alarm, `Bottom | Some (min_y, max_y) -> let fx1, fx1' = pow_f x1 min_y, pow_f x1 max_y in let fx2, fx2' = pow_f x2 min_y, pow_f x2 max_y in let min_f = min fx1 (min fx1' (min fx2 fx2')) in let min_f = if even && F.equal min_f F.zero && contains_odd_positive_integer fkind y then (* underflow: include minus zero *) F.minus_zero else min_f in let max_f = max fx1 (max fx1' (max fx2 fx2')) in let infb, infe, res = inject_r_f fkind min_f max_f in let inf_alarms = Builtin_alarms.union (if infb then an_alarm ANegInf else no_alarm) (if infe then an_alarm APosInf else no_alarm) in Builtin_alarms.union alarms inf_alarms, `Value res in (* positive interval: even y *) let even_alarms, pos_itv = compute_for_integer_y ~even:true min_and_max_enclosed_even fkind y_int in let odd_alarms, neg_itv = compute_for_integer_y ~even:false min_and_max_enclosed_odd fkind y_int in Builtin_alarms.union even_alarms odd_alarms, join_or_bottom pos_itv neg_itv (* We compute the "actual" values to generate alarms, but also the "precise" values (ignoring -inf/+inf). *) let compute_for_zero_x has_neg_inf has_minus_zero has_zero has_one has_pos_inf = let min_f = match has_minus_zero, has_zero, has_one with | true, _, _ -> `Value minus_zero | _, true, _ -> `Value zero | _, _, true -> `Value one | false, false, false -> `Bottom in let max_f = match has_one, has_zero, has_minus_zero with | true, _, _ -> `Value one | _, true, _ -> `Value zero | _, _, true -> `Value minus_zero | false, false, false -> `Bottom in let alarms = Builtin_alarms.union (if has_neg_inf then an_alarm ANegInf else no_alarm) (if has_pos_inf then an_alarm APosInf else no_alarm) in alarms, join_or_bottom min_f max_f (* x equal to -0.0 or 0.0 *) let pow_zero_x fkind ox (FRange.I(y1, y2) as y) : builtin_res = match ox with | None -> no_alarm, `Bottom | Some x -> let has_zero = y2 > 0.0 in let has_one = contains_a_zero y in let has_pos_inf = y1 < -0.0 in match Extlib.opt_bind (min_and_max_enclosed_odd fkind) (enclosed_integer_range y) with | None -> (* no odd integers *) let has_neg_inf = false in let has_minus_zero = false in compute_for_zero_x has_neg_inf has_minus_zero has_zero has_one has_pos_inf | Some (min_odd_y, max_odd_y) -> let has_neg_inf = contains_minus_zero x && min_odd_y < 0.0 in let has_minus_zero = contains_minus_zero x && max_odd_y > 0.0 in compute_for_zero_x has_neg_inf has_minus_zero has_zero has_one has_pos_inf (* x greater than 0.0 *) let pow_positive_x pow_f fkind ox (FRange.I(y1, y2)) : builtin_res = match ox with | None -> no_alarm, `Bottom | Some (FRange.I(x1, x2)) -> let fx1, fx1' = pow_f x1 y1, pow_f x1 y2 in let fx2, fx2' = pow_f x2 y1, pow_f x2 y2 in let min_f = min fx1 (min fx1' (min fx2 fx2')) in let max_f = max fx1 (max fx1' (max fx2 fx2')) in let infb, infe, res = inject_r_f fkind min_f max_f in let alarms = Builtin_alarms.union (if infb then an_alarm ANegInf else no_alarm) (if infe then an_alarm APosInf else no_alarm) in alarms, `Value res (* [pow_f] is the actual function computing the exact power, according to the desired precision: powf for single precision, pow for double precision. *) let pow' pow_f fkind (FRange.I(b1, e1) as x) (FRange.I(b2, e2) as y) = Floating_point.set_round_nearest_even (); (* deterministic case *) if F.equal b1 e1 && F.equal b2 e2 then begin try let c = pow_f b1 b2 in match classify_float c with | FP_nan -> assert false | FP_infinite -> an_alarm (if c < 0. then ANegInf else APosInf), `Bottom | _ -> no_alarm, `Value (inject_f fkind c c) with F.NaN (* raised by pow_f *) -> nan_pow, `Bottom end else (* split analysis in 3 intervals for x: negatives (]-oo..-0.0[), zero ([-0.0..0.0]) and positives (]0.0..+oo[) *) let x_neg, x_pos_or_zero = split_interval fkind x (-0.0) in let x_zero, x_pos = match x_pos_or_zero with | None -> None, None | Some x_pos_or_zero -> let zero_succ = next_after fkind F.zero infinity in split_interval fkind x_pos_or_zero zero_succ in (* negative x is computed later because it may fail *) let alarms1, itv_for_zero_x = pow_zero_x fkind x_zero y in let alarms2, itv_for_pos_x = pow_positive_x pow_f fkind x_pos y in let alarms3, itv_for_neg_x = pow_negative_x pow_f fkind x_neg y in Builtin_alarms.union alarms1 (Builtin_alarms.union alarms2 alarms3), join_or_bottom itv_for_neg_x (join_or_bottom itv_for_zero_x itv_for_pos_x) let pow = pow' F.pow Float64 let powf = pow' F.powf Float32 let cos (FRange.I(b, e)) = Floating_point.set_round_nearest_even (); 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 (FRange.I(b, e)) = Floating_point.set_round_nearest_even (); 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 (** See discussion in the .mli about [rounding_mode] *) (* [exp_f] is the actual underlying function computing the exponential, according to the desired precision: expf for single precision, exp for double precision. *) let exp' exp_f fkind rounding_mode (FRange.I(b, e)) = if rounding_mode = Any then Floating_point.set_round_downward () else Floating_point.set_round_nearest_even (); let min = exp_f b in if rounding_mode = Any then Floating_point.set_round_upward (); let max = exp_f e in if rounding_mode = Any then Floating_point.set_round_nearest_even (); let infb, infe, r = inject_r_f fkind min max in let alarms = Builtin_alarms.union (if infb then an_alarm ANegInf else no_alarm) (if infe then an_alarm APosInf else no_alarm) in alarms, r let exp = exp' F.exp Float64 let expf = exp' F.expf Float32 let widen (FRange.I(b1,e1)) (FRange.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 forward_eq (FRange.I(b1, e1)) (FRange.I(b2, e2)) = let intersects = F.le_ieee b1 e2 && F.le_ieee b2 e1 in if not intersects then Comp.False else if F.equal_ieee b1 e1 && F.equal_ieee b2 e2 then Comp.True else Comp.Unknown let forward_le (FRange.I(b1, e1)) (FRange.I(b2, e2)) = if F.le_ieee e1 b2 then Comp.True else if F.lt_ieee e2 b1 then Comp.False else Comp.Unknown let forward_lt (FRange.I(b1, e1)) (FRange.I(b2, e2)) = if F.lt_ieee e1 b2 then Comp.True else if F.le_ieee e2 b1 then Comp.False else Comp.Unknown let forward_comp op f1 f2 = let open Abstract_interp.Comp in match op with | Le -> forward_le f1 f2 | Ge -> forward_le f2 f1 | Lt -> forward_lt f1 f2 | Gt -> forward_lt f2 f1 | Eq -> forward_eq f1 f2 | Ne -> Comp.inv_result (forward_eq f1 f2) let diff (FRange.I(b1, e1) as f1) (FRange.I(b2, e2)) = if F.le b2 b1 && F.le e1 e2 then `Bottom else if F.le b2 e1 && F.le e1 e2 then `Value (inject b1 b2) else if F.le b1 e2 && F.le b2 b1 then `Value (inject e2 e1) else `Value f1 let backward_le_f allmodes fkind (FRange.I(b1, e1) as f1) e2 = let e2 = if F.equal_ieee F.zero e2 then F.zero else match fkind with | Float32 -> (* Preserve the invariant that the returned interval has 32bits floating-point bounds *) if allmodes then Floating_point.set_round_upward () (* conservative direction *) else Floating_point.set_round_downward () (* precise direction *); let r = Floating_point.round_to_single_precision_float e2 in Floating_point.set_round_nearest_even (); r | Float64 -> e2 in if not (F.le b1 e2) then `Bottom else if F.le e1 e2 then `Value f1 else `Value (inject b1 e2) let backward_le allmodes fkind f1 (FRange.I(_b2, e2) as _f2) = backward_le_f allmodes fkind f1 e2 let backward_lt allmodes fkind (FRange.I(b1, _e1) as f1) (FRange.I(_b2, e2)) = if F.le_ieee e2 b1 then `Bottom else let e2 = if allmodes then e2 else if F.equal_ieee F.zero e2 then Floating_point.neg_min_denormal else F.prev_float e2 (* non-infinite because >= b1 *) in backward_le_f allmodes fkind f1 e2 let backward_ge_f allmodes fkind (FRange.I(b1, e1) as f1) b2 = let b2 = if F.equal_ieee F.minus_zero b2 then F.minus_zero else match fkind with | Float32 -> (* see comments in backward_le_f *) if allmodes then Floating_point.set_round_downward () else Floating_point.set_round_upward (); let r = Floating_point.round_to_single_precision_float b2 in Floating_point.set_round_nearest_even (); r | Float64 -> b2 in if not (F.le b2 e1) then `Bottom else if F.le b2 b1 then `Value f1 else `Value (inject b2 e1) let backward_ge allmodes fkind f1 (FRange.I(b2, _e2)) = backward_ge_f allmodes fkind f1 b2 let backward_gt allmodes fkind (FRange.I(_b1, e1) as f1) (FRange.I(b2, _e2)) = if F.le_ieee e1 b2 then `Bottom else let b2 = if allmodes then b2 else if F.equal_ieee F.zero b2 then Floating_point.min_denormal else F.next_float b2 (* non-infinite because <= e1 *) in backward_ge_f allmodes fkind f1 b2 let backward_comp_left op allmodes fkind f1 f2 = match op with | Comp.Le -> backward_le allmodes fkind f1 f2 | Comp.Ge -> backward_ge allmodes fkind f1 f2 | Comp.Lt -> backward_lt allmodes fkind f1 f2 | Comp.Gt -> backward_gt allmodes fkind f1 f2 | Comp.Eq -> (* -0 and +0 must not be distinguished here *) let f2 = if contains_a_zero f2 then join f2 zeros else f2 in narrow f1 f2 | Comp.Ne -> (* compute ]-infty,min[ \cup ]max,infty[ *) let before_or_after min max = Bottom.join join (backward_lt allmodes fkind f1 min) (backward_gt allmodes fkind f1 max) in (* As usual, we cannot reduce if [f2] is not a singleton, except that the two zeros are a kind of singleton. Checking whether [f2] is on a frontier of [f1] is not obvious because of the multiple cases (and [allmodes]) so we use the transformers for [lt] instead. *) if is_a_zero f2 then before_or_after minus_zero zero else if is_singleton f2 then before_or_after f2 f2 else `Value f1 let nan_fmod = an_alarm (ANaN "division by zero") (* Emits a warning if there may be a division by zero. Raises [Builtin_invalid_domain] if there must be a division by zero. Evaluates the function for y ∉ {+0.0,-0.0}. *) let fmod (FRange.I(b1, e1) as x) (FRange.I(b2, e2) as y) = let alarms = if contains_a_zero y then nan_fmod else no_alarm in if is_a_zero y then alarms, `Bottom else begin Floating_point.set_round_nearest_even (); (* case analysis for extra precision *) (* 1. deterministic case: y is a singleton and x ≠ 0 (already tested) *) if F.equal b1 e1 && F.equal b2 e2 then let c = F.fmod b1 b2 in no_alarm, `Value (inject_f Float64 c c) else (* 2. [0 ∉ y] and [max_x < min_y] => [fmod(x,y) = x]. (i.e., x is too small w.r.t. y and unaffected by fmod *) if not (contains_a_zero y) && F.compare (F.max (abs_float b1) (abs_float e1)) (F.min (abs_float b2) (abs_float e2)) < 0 then (alarms, `Value x) else (* 3. x and y are within the same continuous region. (i.e. do not contain zero, do not cross any modulo boundaries, etc.) Example: x=[6,7] and y=[4,5]. Restriction: [|x/y| < 2^53], otherwise truncation to an integer (to test the above property) may return an incorrect result. Note: to avoid issues with rounding, we conservatively set the limit to 2^51 instead of 2^53. *) let trunc x = if F.compare x F.zero < 0 then ceil x else floor x in let max_i = F.max_precise_integer /. 4. in let _ = Floating_point.set_round_toward_zero () in let f1 = trunc (abs_float (b1 /. b2)) in let f2 = trunc (abs_float (e1 /. e2)) in let f3 = trunc (abs_float (b1 /. e2)) in let f4 = trunc (abs_float (e1 /. b2)) in Floating_point.set_round_nearest_even (); if not (contains_zero x) && not (contains_zero y) && F.compare f1 f2 = 0 && F.compare f2 f3 = 0 && F.compare f3 f4 = 0 && F.compare f1 max_i < 0 then (* normalize x and to positive intervals to minimize number of cases (x and y do not contain 0). The sign of x is forwarded to the result, and the sign of y is ignored. *) let x', y' = abs x, abs y in let res_is_positive = F.compare e1 F.minus_zero > 0 in match x', y' with | FRange.I(x1, x2), FRange.I(y1, y2) -> let r_min = mod_float x1 y2 in let r_max = mod_float x2 y1 in let res_abs = inject_f Float64 r_min r_max in let res = if res_is_positive then res_abs else neg res_abs in (alarms, `Value res) else (* General case: |fmod(x,y)| <= max(|b1|,|e1|) and |fmod(x,y)| < max(|b2|,|e2|), e.g. (2.5 fmod 6) <= 2.5, and (6 fmod 2.5) < 2.5. Also, if x > 0, then 0 <= fmod(x,y), and symmetrically for x < 0. *) (* Auxiliary functions to filter interval extremities *) let backward_lower_bound (FRange.I(b,_) as i) = Bottom.non_bottom (backward_gt false Float64 i (inject_f Float64 b b)) in let backward_upper_bound (FRange.I(_,e) as i) = Bottom.non_bottom (backward_lt false Float64 i (inject_f Float64 e e)) in (* remove zeroes from y, by normalizing it to [ay1,ay2], where [ay1] and [ay2] are both positive. This is valid because fmod is an even function w.r.t. y (e.g. f(x,y) = f(x,-y)). Compute fmod on ]0, max(|b2|,|e2|)] if y crosses the x-axis, or on |[b2,e2]| otherwise. *) let max (FRange.I(_,e)) = e in let x', y' = abs x, abs y in let y' = if contains_zero y' then (* y crosses the x-axis, filter zero out (alarm already emitted) *) backward_lower_bound (inject_f Float64 F.zero (max y')) else y' in let r_mod = F.min (max x') (max y') in (* To know whether we can ignore the extremities of the interval, we check if the result modulus is due to the y interval. *) let strict_le = F.compare (max y') (max x') <= 0 in (* The final result is [0, r_mod] if x is always non-negative, [-r_mod, 0] if x is always negative, or [-r_mod, r_mod] otherwise. The interval is closed or open according to [strict_le]. *) let res = if F.compare e1 F.zero < 0 then (* x always negative *) let r = inject_f Float64 (-.r_mod) F.minus_zero in if strict_le then backward_lower_bound r else r else if F.compare b1 F.minus_zero > 0 then (* x always positive *) let r = inject_f Float64 F.zero r_mod in if strict_le then backward_upper_bound r else r else (* x may be negative or positive => intersect [-r_mod, r_mod] with the original interval *) let r = inject_f Float64 (-.r_mod) r_mod in let r = if strict_le then backward_lower_bound (backward_upper_bound r) else r in Bottom.non_bottom (meet x r) in (alarms, `Value res) end let nan_log = an_alarm (ANaN "negative argument") let nan_log_assume = Builtin_alarms.add (AAssume "argument greater than zero") nan_log (** See discussion in the .mli about [rounding_mode] *) let log_float_aux fkind flog rounding_mode (FRange.I(_, e) as v) = (* we want to compute the smallest denormal bigger than zero -> use allroundingmodes=false. *) match backward_gt false fkind v zero with | `Bottom -> nan_log, `Bottom | `Value (FRange.I(b_reduced, _) as reduced) -> let alarm = if equal reduced v then no_alarm else nan_log_assume in if rounding_mode = Any then Floating_point.set_round_downward () else Floating_point.set_round_nearest_even (); let min = flog b_reduced in if rounding_mode = Any then Floating_point.set_round_upward (); let max = flog e in if rounding_mode = Any then Floating_point.set_round_nearest_even (); let alm', alm'', r = inject_r_f fkind min max in assert (not (alm'||alm'')); (* alm' and alm'' should always be false *) alarm, `Value r let log = log_float_aux Float64 F.log let log10 = log_float_aux Float64 F.log10 let logf = log_float_aux Float32 F.logf let log10f = log_float_aux Float32 F.log10f (* The functions defined using [exact_aux] below are, among other properties, (1) exact (the result as a real can always be represented exactly, in the good type), and (2) total. In particular, given a float 'x', 'ff x == (float)(f (double)x)'. Thus, in this module, the 'f' functions are also the non-f (since float32 are represented using double) *) let exact_aux fkind ff _rounding_mode (FRange.I(b, e)) = let fb, fe = ff b, ff e in no_alarm, inject_f fkind fb fe let floor = exact_aux Float64 F.floor let ceil = exact_aux Float64 F.ceil let trunc = exact_aux Float64 F.trunc let fround = exact_aux Float64 F.fround let floorf = exact_aux Float32 F.floor let ceilf = exact_aux Float32 F.ceil let truncf = exact_aux Float32 F.trunc let froundf = exact_aux Float32 F.fround let subdiv_float_interval ~size (FRange.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.next_float midpoint in if size = 64 then if F.le smidpoint u then if F.next_float 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 (); 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 Floating_point.set_round_nearest_even (); 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 let cast_float_to_double_inverse (FRange.I(min, max)) = Floating_point.set_round_upward (); let min' = Floating_point.round_to_single_precision_float min in Floating_point.set_round_downward (); let max' = Floating_point.round_to_single_precision_float max in Floating_point.set_round_nearest_even (); inject min' max' let enlarge_1ulp fk (FRange.I(b, e)) = let b' = next_after fk b (-. infinity) in let e' = next_after fk e infinity in let ib, ie, r = inject_r_f fk b' e' in if ib || ie then raise Non_finite; r (* Local Variables: compile-command: "make -C ../../.. byte" End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/origin.mli0000644000175000017500000000662713113745013025530 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 Lattice_type.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, typically 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 initial 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 (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/lmap.mli0000644000175000017500000000775413113745004025174 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 *) (** Contents of a variable when it is not present in the state. See function [default_contents] in the functor below *) type 'a default_contents = | Bottom | Top of 'a | Constant of 'a | Other module Make_LOffset (V: sig include module type of Offsetmap_lattice_with_isotropy include Lattice_type.With_Top_Opt with type t := t end) (Offsetmap: module type of Offsetmap_sig with type v = V.t and type widen_hint = V.generic_widen_hint) (Default_offsetmap: sig val name: string (** Used to create different datatypes each time the functor is applied *) val default_offsetmap : Base.t -> Offsetmap.t Bottom.or_bottom (** Value returned when a map is queried, and the base is not present. [`Bottom] indicates that the base is never bound in such a map. *) val default_contents: V.t default_contents (** This function is used to optimize functions that add keys in a map, in particular when maintaining canonicity w.r.t. default contents. It describes the contents [c] of the offsetmap resulting from [default_offsetmap b]. The possible values are: - [Bottom] means that [c] is [V.bottom] everywhere, and furthermore that [V.bottom] has an empty concretization. We deduce from this fact that unmapped keys do not contribute to a join, and that [join c v] is never [c] as soon as [v] is not itself [v]. - [Top] means that [c] is [V.top] everywhere. Thus unmapped keys have a default value more general than the one in a map where the key is bound. - [`Constant v] means that [c] is an offsetmap with a single interval containing [v] everywhere. [v] must be isotropic (in the sense of {!V.is_isotropic}). - [`Other] means that [default_offsetmap] returns something arbitrary. This function is only used on keys that change values. Thus it is safe to have [default_offsetmap] return something that do not match [default_contents] on constant keys. *) end): module type of Lmap_sig with type v = V.t and type widen_hint_base = V.generic_widen_hint and type offsetmap = Offsetmap.t (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/origin.ml0000644000175000017500000001563013113745012025350 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 = | 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 ()) (* Do not let garbled mix locations grow. We stop at cardinal one. *) let join o1 o2 = match o1, o2 with | Top, _ | _, Top -> top | Set s1, Set s2 -> (* use the fact that [s1] and [s2] are never empty. *) if O.equal s1 s2 then o1 else top 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_source fmt = function | LocationSetLattice.Top -> () (* Hide unhelpful 'TopSet' *) | LocationSetLattice.Set _ as s -> Format.fprintf fmt "@ %a" LocationSetLattice.pretty s let pretty fmt o = match o with | Unknown -> Format.fprintf fmt "Unknown" | Misalign_read o -> Format.fprintf fmt "Misaligned%a" pretty_source o | Leaf o -> Format.fprintf fmt "Library function%a" pretty_source o | Merge o -> Format.fprintf fmt "Merge%a" pretty_source o | Arith o -> Format.fprintf fmt "Arithmetic%a" pretty_source 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.t_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)) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/abstract_interp.mli0000644000175000017500000001156313113745002027416 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 for generic lattices implementations. @plugin developer guide *) exception Not_less_than (** Raised by {!Lattice.cardinal_less_than}. *) exception Can_not_subdiv (** Used by other modules e.g. {!Fval.subdiv_float_interval}. *) (** Signatures for comparison operators [==, !=, <, >, <=, >=]. *) module Comp: sig type t = Lt | Gt | Le | Ge | Eq | Ne (** comparison operators *) type result = True | False | Unknown (** result of a comparison *) val pretty_comp: t Pretty_utils.formatter val inv: t -> t (** Inverse relation: [a op b <==> ! (a (inv op) b)]. *) val sym: t -> t (** Opposite relation: [a op b <==> b (sym op) a]. *) val inv_result: result -> result (** Given a result [r] for an operation [op], [inv_result r] is the result that would have been obtained for [inv op]. *) end open Lattice_type module Int : sig include module type of Integer with type t = Integer.t include Lattice_Value with type t := t val fold : (t -> 'a -> 'a) -> inf:t -> sup:t -> step:t -> 'a -> 'a (** Fold the function on the value between [inf] and [sup] at every step. If [step] is positive the first value is [inf] and values go increasing, if [step] is negative the first value is [sup] and values go decreasing *) 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 add : t -> t -> 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 Bool : sig type t = Top | True | False | Bottom include Full_AI_Lattice_with_cardinality with type t := t end module Make_Lattice_Base (V : Lattice_Value) : Lattice_Base with type l = V.t module Make_Lattice_Set (V : Lattice_Value) : Lattice_Set with type O.elt=V.t module Make_Hashconsed_Lattice_Set (V : Hptmap.Id_Datatype) (O: Hptset.S with type elt = V.t) : Lattice_Hashconsed_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 forbidden by the datatype library, and would cause hashconsing problems) *) module type Collapse = sig val collapse : bool end (** If [C.collapse] then [L1.bottom,_] = [_,L2.bottom] = [bottom] *) (* Untested *) module Make_Lattice_Product (L1:AI_Lattice_with_cardinal_one) (L2:AI_Lattice_with_cardinal_one) (C:Collapse): Lattice_Product with type t1 = L1.t and type t2 = L2.t (** Uncollapsed product. Literally the set of (e1, e2) ordered pairs equipped with the order (e1, e2) < (d1, d2) <==> e1 < d1 && e2 < d2. *) module Make_Lattice_UProduct (L1:AI_Lattice_with_cardinal_one) (L2:AI_Lattice_with_cardinal_one) : Lattice_UProduct with type t1 = L1.t and type t2 = L2.t (* Untested *) module Make_Lattice_Sum (L1:AI_Lattice_with_cardinal_one) (L2:AI_Lattice_with_cardinal_one): (Lattice_Sum with type t1 = L1.t and type t2 = L2.t) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/offsetmap_lattice_with_isotropy.mli0000644000175000017500000000642013113745012032723 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 the arguments of functor {!Offsetmap.Make} *) open Lattice_type type generic_widen_hint type size_widen_hint = Integer.t include Bounded_Join_Semi_Lattice include With_Widening with type t := t and type widen_hint = size_widen_hint * generic_widen_hint include With_Cardinal_One with type t := t val pretty_typ: Cil_types.typ option -> t Pretty_utils.formatter (** Are the bits independent? *) val is_isotropic : t -> bool val extract_bits : topify:Origin.kind -> start:Integer.t -> stop:Integer.t -> size:Integer.t -> t -> bool * t (** Extract the bits between {!start} and {!stop} in the value of type [t], assuming this value has {!size} bits. Return the corresponding value, and a boolean indicating that an imprecision occurred during the operation. In the latter case, the origin of the imprecision is flagged as having kind [topify] *) val little_endian_merge_bits : topify:Origin.kind -> conflate_bottom:bool -> value:t -> offset:Integer.t -> t -> t val big_endian_merge_bits : topify:Origin.kind -> conflate_bottom:bool -> total_length:int -> length:Integer.t -> value:t -> offset:Integer.t -> t -> t val merge_neutral_element: t (** Value that can be passed to {!little_endian_merge_bits} or {!big_endian_merge_bits} as the starting value. This value must be neutral wrt. concatenation of values. *) val topify_with_origin : Origin.t -> t -> t (** Force a value to be isotropic, when a loss of imprecision occurs. The resulting value must verify {!is_isotropic}. *) val anisotropic_cast : size:Integer.t -> t -> t (** Convert the given value so that it fits in [size] bits. *) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/lmap_sig.mli0000644000175000017500000001721113113745003026022 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 a location *) type offsetmap (** type of the maps associated to a base *) type widen_hint_base (** widening hints for each base *) type map (** Maps from {!Base.t} to {!offsetmap} *) type lmap = private Bottom | Top | Map of map include Datatype.S_with_collections with type t = lmap include Lattice_type.With_Error_Top val pretty: Format.formatter -> t -> unit val pretty_debug: Format.formatter -> t -> unit val pretty_filter: Format.formatter -> t -> Zone.t -> unit (** [pretty_filter m z] pretties only the part of [m] that correspond to the bases present in [z] *) val pretty_diff: Format.formatter -> t -> t -> unit (** {2 General shape} *) val top: t val is_top: t -> bool (** Empty map. Casual users do not need this except to create a custom initial state. *) val empty_map : t val is_empty_map : t -> bool val bottom : t (** Every location is associated to the value [bottom] of type [v] in this state. This state can be reached only in dead code. *) val is_reachable : t -> bool (** {2 Join and inclusion} *) val join : t -> t -> t val is_included : t -> t -> bool module Make_Narrow(X: sig include Lattice_type.With_Top with type t := v include Lattice_type.With_Narrow with type t := v val bottom_is_strict: bool end): sig val narrow : t -> t -> t end (** Bases that must be widening in priority, plus widening hints for each base. *) type widen_hint = Base.Set.t * (Base.t -> widen_hint_base) val widen : widen_hint-> t -> t -> t (** {2 Finding values} *) val find: ?conflate_bottom:bool -> t -> location -> v (** @raise Error_Top when the location or the state are Top, and there is no Top value in the type {!v}. *) val copy_offsetmap : Location_Bits.t -> Integer.t -> t -> offsetmap Bottom.or_bottom (** [copy_offsetmap alarms loc size m] returns the superposition of the ranges of [size] bits starting at [loc] within [m]. [size] must be strictly greater than zero. Return [None] if all pointed addresses are invalid in [m]. @raise Error_Top when the location or the state are Top, and there is no Top value in the type {!v}. *) val find_base : Base.t -> t -> offsetmap Bottom.Top.or_top_bottom (** @raise Not_found if the varid is not present in the map. *) val find_base_or_default : Base.t -> t -> offsetmap Bottom.Top.or_top_bottom (** Same as [find_base], but return the default values for bases that are not currently present in the map. Prefer the use of this function to [find_base], unless you explicitly want to see if the base is bound. *) (** {2 Binding variables} *) (** [add_binding ~exact initial_mem loc v] simulates the effect of writing [v] at location [loc], in the initial memory state given by [initial_mem]. If [loc] is not writable, {!bottom} is returned. If [exact] is true, and [loc] is a precise location, a strong update is performed. Only locations that may be valid are written. Returns the resulting memory after the write. *) val add_binding: exact:bool -> t -> location -> v -> t (** [paste_offsetmap ~from ~dst_loc ~size ~exact m] copies [from], which is supposed to be exactly [size] bits, and pastes them at [dst_loc] in [m]. The copy is exact if and only if [dst_loc] is exact, and [exact] is true. Only the locations that may be valid are written. *) val paste_offsetmap : from:offsetmap -> dst_loc:Location_Bits.t -> size:Integer.t -> exact:bool -> t -> t val add_base : Base.t -> offsetmap -> t -> t (** [add_base b o m] adds base [b] bound to [o], replacing any previous bindings of [b]. No effect on [Top] or [Bottom]. *) val add_base_value: Base.t -> size:Integer.t -> v -> size_v:Integer.t -> t -> t (** Creates the offsetmap described by [size], [v] and [size_v], and binds it to the base. No effect on [Top] or [Bottom]. *) (** {2 Filters} *) val filter_base : (Base.t -> bool) -> t -> t (** Remove from the map all the bases that do not satisfy the predicate. *) val filter_by_shape: 'a Hptmap.Shape(Base.Base).t -> t -> t (** Remove from the map all the bases that are not also present in the given [Base.t]-indexed tree. *) (** Removes the base if it is present. Does nothing otherwise. *) val remove_base : Base.t -> t -> t (** {2 Iterators} *) (** Notice that some iterators require an argument of type {!map}: the cases {!Top} and {!Bottom} must be handled separately. All the iterators below only present bases that are bound to non-default values, according to the function [is_default_offsetmap] of the function {!Lmap.Make_Loffset}. *) val iter: (Base.base -> offsetmap -> unit) -> map -> unit val fold : (Base.t -> offsetmap -> 'a -> 'a) -> map -> 'a -> 'a (** {3 Cached iterators} *) (** These functions are meant to be partially applied to all their arguments but the final one (the map). They must be called at the toplevel of OCaml modules, as they create persistent caches. *) val cached_fold : f:(Base.t -> offsetmap -> 'a) -> cache_name:string -> temporary:bool -> joiner:('a -> 'a -> 'a) -> empty:'a -> map -> 'a val cached_map : f:(Base.t -> offsetmap -> offsetmap) -> cache:string * int -> temporary:bool -> t -> t (** {2 Misc} *) val remove_variables: Cil_types.varinfo list -> t -> t val shape: map -> offsetmap Hptmap.Shape(Base.Base).t (** Shape of the map. This can be used for simultaneous iterations on other maps indexed by type {!Base.Base.t}. *) (** 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 (**/**) (** {2 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 (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/locations.ml0000644000175000017500000006577013113745005026070 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 let emitter = Lattice_messages.register "Locations" module Initial_Values = struct let v = [ [Base.null,Ival.zero]; [Base.null,Ival.one]; [Base.null,Ival.zero_or_one]; [Base.null,Ival.top]; [Base.null,Ival.top_float]; [Base.null,Ival.top_single_precision_float]; [Base.null,Ival.float_zeros]; ] end (* Store the information that the location has at most cardinal 1, ignoring weak bases. The rationale is as follows: this compositional bool is used to improve the performance of slevel, to detect the parts of memory states that are "exact". Intuitively, locations that involve weak bases do not qualify. However, "exact" must be understood w.r.t. the [is_included] function: a value is "exact" if no other value than itself and bottom are included in it. Said otherwise, we do not consider the cardinality of the concretization, but instead the one of the Ocaml datastructure. *) module Comp_exact = struct let e = true (* corresponds to bottom *) let f _b v = Ival.cardinal_zero_or_one v (* on Ival, both forms of cardinal coincide *) let compose _ _ = false (* Keys cannot be bound to Bottom (see MapLattice). Hence, two subtrees have a t least cardinal two. *) end module MapLatticeIval = Map_Lattice.Make (Base.Base)(Base.SetLattice)(Ival)(Comp_exact)(Initial_Values) module Location_Bytes = struct include MapLatticeIval (* Invariant : [Top (s, _) must always contain NULL, _and_ at least another base. Top ({Null}, _) is replaced by Top_int]. See inject_top_origin_internal below. *) let inject_ival i = inject Base.null i let inject_float f = inject_ival (Ival.inject_float (Fval.inject_singleton f)) (** Check that those values correspond to {!Initial_Values} above. *) let singleton_zero = inject_ival Ival.zero let singleton_one = inject_ival Ival.one let zero_or_one = inject_ival Ival.zero_or_one let top_int = inject_ival Ival.top let top_float = inject_ival Ival.top_float let top_single_precision_float = inject_ival Ival.top_single_precision_float (* 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 = if Ival.is_bottom offset then bottom else try map_offsets (Ival.add_int offset) l with Error_Top -> l (* [shift_under offset l] is the location [l] (an under-approximation) shifted by [offset] (another under-approximation); returns an underapproximation. *) let shift_under offset l = if Ival.is_bottom offset then bottom else try map_offsets (Ival.add_int_under offset) l (* Note: having an under-approximation at top is probably wrong. *) with Error_Top -> assert false let sub_pointwise ?factor l1 l2 = let factor = match factor with | None -> Int_Base.minus_one | Some f -> Int_Base.neg f in match l1, l2 with | Top _, Top _ | Top (Base.SetLattice.Top, _), Map _ | Map _, Top (Base.SetLattice.Top, _) -> Ival.top | Top (Base.SetLattice.Set s, _), Map m | Map m, Top (Base.SetLattice.Set s, _) -> let s' = Base.SetLattice.O.add Base.null s in if M.exists (fun base _ -> Base.SetLattice.O.mem base s') m then Ival.top else Ival.bottom | Map m1, Map m2 -> (* Subtract pointwise for all the bases that are present in both m1 and m2. *) M.fold2_join_heterogeneous ~cache:Hptmap_sig.NoCache ~empty_left:(fun _ -> Ival.bottom) ~empty_right:(fun _ -> Ival.bottom) ~both:(fun _b i1 i2 -> Ival.add_int i1 (Ival.scale_int_base factor i2)) ~join:Ival.join ~empty:Ival.bottom m1 (M.shape m2) let cardinal_zero_or_one = function | Top _ -> false | Map m -> M.is_empty m || M.on_singleton (fun b i -> not (Base.is_weak b) && Ival.cardinal_zero_or_one i) m let cardinal = function | Top _ -> None | Map m -> let aux_base b i card = if Base.is_weak b then None else match card, Ival.cardinal i with | None, _ | _, None -> None | Some c1, Some c2 -> Some (Int.add c1 c2) in M.fold aux_base m (Some Int.zero) (* These two states contain the garbled mix that we track. The list preserves the creation order (except it is reversed), while the set is used to test inclusion efficiently so far. Only "original" garbled mix are tracked, i.e. operations that _transform a garbled mix are not tracked. *) module ListGarbledMix = State_builder.List_ref(MapLatticeIval) (struct let name = "Locations.ListGarbledMix" let dependencies = [MapLatticeIval.M.self] end) module SetGarbledMix = State_builder.Set_ref(MapLatticeIval.Set) (struct let name = "Locations.SetGarbledMix" let dependencies = [MapLatticeIval.M.self] end) let get_garbled_mix () = List.rev (ListGarbledMix.get ()) let clear_garbled_mix () = ListGarbledMix.clear (); SetGarbledMix.clear (); ;; (* We skip Well origins, because they have no location information and can be tracked in the initial state. Unknown origins have no location, and are only built as a side-product of the analysis. Leaf origins are also skipped, because we may create tons of those, that get reduced to precise values by the specifications of the function. *) let is_gm_to_log m = let open Origin in match m with | Map _ | Top (_, (Well | Unknown | Leaf _)) -> false | Top (_, (Misalign_read _ | Merge _ | Arith _)) -> true let ref_track_garbled_mix = ref true let do_track_garbled_mix b = ref_track_garbled_mix := b (* track a garbled mix if needed, then return it (more convenient for the caller). *) let track_garbled_mix gm = if !ref_track_garbled_mix && is_gm_to_log gm && not (SetGarbledMix.mem gm) then begin SetGarbledMix.set (MapLatticeIval.Set.add gm (SetGarbledMix.get ())); ListGarbledMix.set (gm :: ListGarbledMix.get ()); end; gm let top_with_origin origin = track_garbled_mix (Top(Base.SetLattice.top, origin)) (* This internal function builds a garbled mix, but does *not* track its creation. This is useful for functions that transform existing GMs. *) let inject_top_origin_internal o b = if Base.Hptset.(equal b empty || equal b Base.null_set) then top_int else begin if Base.Hptset.mem Base.null b then Top (Base.SetLattice.inject b, o) else Top (Base.(SetLattice.inject (Hptset.add null b)), o) end let inject_top_origin o b = track_garbled_mix (inject_top_origin_internal o b) (** some functions can reduce a garbled mix, make sure to normalize the result when only NULL remains *) let normalize_top m = match m with | Top (Base.SetLattice.Top, _) | Map _ -> m | Top (Base.SetLattice.Set s, o) -> inject_top_origin_internal o s let narrow m1 m2 = normalize_top (narrow m1 m2) let meet m1 m2 = normalize_top (meet m1 m2) 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.Empty | Base.Known _ | Base.Unknown _ | Base.Invalid -> true | Base.Variable { Base.weak } -> not weak 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 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_int (fun i () -> f base strz (Int.to_int i) len) roffs () | _ -> ()) m 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 (Base.SetLattice.Top, _) -> true | Top (Base.SetLattice.Set s,_) -> Base.Hptset.mem base s | Map m -> try ignore (M.find base m); true with Not_found -> false let contains_addresses_of_locals is_local l = match l with | Top (Base.SetLattice.Top,_) -> true | Top (Base.SetLattice.Set s, _) -> Base.SetLattice.O.exists is_local s | Map m -> M.exists (fun b _ -> is_local b) m let remove_escaping_locals is_local v = let non_local b = not (is_local b) in match v with | Top (Base.SetLattice.Top,_) -> true, v | Top (Base.SetLattice.Set garble, orig) -> let nonlocals = Base.Hptset.filter non_local garble in if Base.Hptset.equal garble nonlocals then false, v else true, inject_top_origin_internal orig nonlocals | Map m -> let nonlocals = M.filter non_local m in if M.equal nonlocals m then false, v else true, Map nonlocals 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_name:"loc_top_any_locals" ~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 type overlaps = Overlaps of (M.t -> M.t -> bool) module DatatypeOverlap = Datatype.Make(struct include Datatype.Undefined (* Closures: cannot be marshalled *) type t = overlaps let name = "Locations.DatatypeOverlap.t" let reprs = [Overlaps (fun _ _ -> true)] let mem_project = Datatype.never_any_project end) module PartiallyOverlaps = State_builder.Int_hashtbl(DatatypeOverlap)(struct let size = 7 let dependencies = [Ast.self] let name = "Locations.PartiallyOverlap" end) let partially_overlaps ~size mm1 mm2 = match mm1, mm2 with | Top _, _ | _, Top _ -> intersects mm1 mm2 | Map m1, Map m2 -> let size_int = Int.to_int size in let map_partially_overlaps = try (match PartiallyOverlaps.find size_int with Overlaps f -> f) with Not_found -> let name = Format.asprintf "Locations.Overlap(%d)" size_int in let f = M.symmetric_binary_predicate (Hptmap_sig.TemporaryCache name) M.ExistentialPredicate ~decide_fast:(fun _ _ -> M.PUnknown) ~decide_one:(fun _ _ -> false) ~decide_both:(fun _ x y -> Ival.partially_overlaps size x y) in PartiallyOverlaps.add size_int (Overlaps f); f in map_partially_overlaps m1 m2 let widen (size, wh) = let widen_map = let decide k v1 v2 = (* Do not perform size-based widening for pointers. This will only delay convergence, for no real benefit. The only interesting bound is the validity. *) let size = if Base.equal k Base.null then size else Integer.zero in Ival.widen (size, wh k) v1 v2 in M.join ~cache:Hptmap_sig.NoCache (* No cache, because of wh *) ~symmetric:false ~idempotent:true ~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) end module Location_Bits = Location_Bytes module Zone = struct module Initial_Values = struct let v = [ ] end include Map_Lattice.Make_without_cardinal (Base.Base) (Base.SetLattice) (Int_Intervals) (Hptmap.Comp_unused) (Initial_Values) 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 "@[%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 = intersects let mem_base b = function | Top (top_param, _) -> Base.SetLattice.mem b top_param | Map m -> M.mem b m let shape = M.shape let fold2_join_heterogeneous ~cache ~empty_left ~empty_right ~both ~join ~empty = let f_top = (* Build a zone corresponding to the garbled mix. Do not add NULL, we are reasoning on zones. Inefficient if empty_right does not use its argument, though... *) let build_z set = let aux b z = M.add b Int_Intervals.top z in Map (Base.Hptset.fold aux set M.empty) in let empty_right set = empty_right (build_z set) in let both base v = both base Int_Intervals.top v in Base.SetLattice.O.fold2_join_heterogeneous ~cache ~empty_left ~empty_right ~both ~join ~empty in let f_map = let empty_right m = empty_right (Map m) in let both base itvs v = both base itvs v in M.fold2_join_heterogeneous ~cache ~empty_left ~empty_right ~both ~join ~empty in fun z -> match z with | Top (Base.SetLattice.Top, _) -> raise Error_Top | Top (Base.SetLattice.Set s, _) -> f_top s | Map mm -> f_map mm end type location = { loc : Location_Bits.t; size : Int_Base.t } exception Found_two (* Reduce [offsets] so that reading [size] from [offsets] fits within the validity of [base]. If [aligned] is set to true, make the offset congruent to 0 modulo 8. *) let reduce_offset_by_validity ~for_writing ?(bitfield=true) base offsets size = if for_writing && Base.is_read_only base then Ival.bottom else match Base.validity base, size with | Base.Empty, _ -> if Int_Base.(compare size zero) > 0 then Ival.bottom else Ival.zero | Base.Invalid, _ -> Ival.bottom | _, Int_Base.Top -> offsets | (Base.Known (minv,maxv) | Base.Unknown (minv,_,maxv)), Int_Base.Value size -> let maxv = Int.succ (Int.sub maxv size) in let range = if bitfield then Ival.inject_range (Some minv) (Some maxv) else Ival.inject_interval (Some minv) (Some maxv) Int.zero Int.eight in Ival.narrow range offsets | Base.Variable variable_v, Int_Base.Value size -> let maxv = Int.succ (Int.sub variable_v.Base.max_alloc size) in let range = Ival.inject_range (Some Int.zero) (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 -> if Int_Base.is_top size then false else begin Location_Bits.M.iter (fun base offsets -> if Base.is_weak base then raise Found_two; 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 end 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_bits_to_loc_bytes_under x = match x with | Location_Bits.Map _ -> Location_Bits.map_offsets (Ival.scale_div_under ~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 = { loc = loc_bits; size = size } let is_valid ~for_writing {loc; size} = try let size = Int_Base.project size in let is_valid_offset b o = Base.is_valid_offset ~for_writing size b o 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 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 (msg, _) -> Lattice_messages.emit_approximation emitter "imprecise size for variable %a (%s)" Printer.pp_varinfo v msg; Int_Base.top let loc_of_varinfo v = let base = Base.of_varinfo 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 b typ offset = try let offs, size = Cil.bitsOffset typ offset in let size = Int_Base.inject (Int.of_int size) in make_loc (Location_Bits.inject b (Ival.of_int offs)) size with SizeOfError _ as _e -> make_loc (Location_Bits.inject b Ival.top) Int_Base.top let loc_bottom = make_loc Location_Bits.bottom Int_Base.top let is_bottom_loc l = Location_Bits.is_bottom l.loc 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 "@[%a@]" Base.pretty k | _ -> Format.fprintf fmt "@[%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 (* Case [Top (Top, _)] must be handled by caller. *) let enumerate_valid_bits_under_over under_over ~for_writing {loc; 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 = under_over base valid_offset size in if Int_Intervals.(equal bottom valid_itvs) then acc else Zone.M.add base valid_itvs acc in Zone.Map (Location_Bits.fold_topset_ok compute_offset loc Zone.M.empty) let interval_from_ival_over _ offset size = Int_Intervals.from_ival_size offset size let interval_from_ival_under base offset size = match Base.validity base with | Base.Variable { Base.weak = true } -> Int_Intervals.bottom | _ -> Int_Intervals.from_ival_size_under offset size let enumerate_valid_bits ~for_writing loc = match loc.loc with | Location_Bits.Top (Base.SetLattice.Top, _) -> Zone.top | _ -> enumerate_valid_bits_under_over interval_from_ival_over ~for_writing loc ;; let enumerate_valid_bits_under ~for_writing loc = match loc.size with | Int_Base.Top -> Zone.bottom | Int_Base.Value _ -> match loc.loc with | Location_Bits.Top _ -> Zone.bottom | Location_Bits.Map _ -> enumerate_valid_bits_under_over interval_from_ival_under ~for_writing loc ;; (** [valid_part l] is an over-approximation of the valid part of the location [l]. *) let valid_part ~for_writing ?(bitfield=true) {loc = loc; size = size } = let compute_loc base offs acc = let valid_offset = reduce_offset_by_validity ~for_writing ~bitfield 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 _, _) -> Location_Bits.(Map (fold_topset_ok compute_loc loc M.empty)) | 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_under_over under_over {loc; size} = let compute_offset base offs acc = let valid_offset = under_over base offs size in if Int_Intervals.(equal valid_offset bottom) then acc else Zone.M.add base valid_offset acc in Zone.Map (Location_Bits.fold_topset_ok compute_offset loc Zone.M.empty) let enumerate_bits loc = match loc.loc with | Location_Bits.Top (Base.SetLattice.Top, _) -> Zone.top | _ -> enumerate_bits_under_over interval_from_ival_over loc let enumerate_bits_under loc = match loc.loc, loc.size with | Location_Bits.Top _, _ | _, Int_Base.Top -> Zone.bottom | _ -> enumerate_bits_under_over interval_from_ival_under loc 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-Phosphorus-20170501/src/kernel_services/abstract_interp/int_Intervals.mli0000644000175000017500000000375113113745003027054 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 intervals with a lattice structure. Consecutive intervals are automatically fused. *) (* For compilation reasons, the type of this module is in {!Int_Intervals_sig}, and the implementation is in {!Offsetmap.Int_Intervals}. *) include module type of Int_Intervals_sig with type t = Offsetmap.Int_Intervals.t (* Local Variables: compile-command: "make -C ../../.. byte" End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/fval.mli0000644000175000017500000002312613113745004025162 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 intervals, used to construct arithmetic lattices. The interfaces of this module may change between Frama-C versions. Contact us if you need stable APIs. *) open Abstract_interp module F : sig type t val packed_descr : Structural_descr.pack val of_float : float -> t (** fails on NaNs, but allows infinities. *) val to_float : t -> float val compare : t -> t -> int val equal : t -> t -> bool (** Those functions distinguish -0. and +0. *) val pretty : Format.formatter -> t -> unit val pretty_normal : use_hex:bool -> Format.formatter -> t -> unit val zero : t val next_float : float -> float (** First double strictly above the argument. Must be called on non-NaN floats. Returns +infty on MAX_FLT. Infinities are left unchanged. *) val prev_float : float -> float (** First double strictly below the argument. Must be called on non-NaN floats. Returns -infty on -MAX_FLT. Infinities are left unchanged. *) end type t val packed_descr : Structural_descr.pack (** [Non_finite] is produced when the result of a computation is entirely not-finite, such as [+oo,+oo] (results in [Bottom]). *) exception Non_finite type rounding_mode = Any | Nearest_Even val top_single_precision_float : t val round_to_single_precision_float : rounding_mode:rounding_mode -> t -> bool * t val bits_of_float64 : signed:bool -> t -> Int.t * Int.t val bits_of_float32 : signed:bool -> t -> Int.t * Int.t (** [has_finite f] returns true iff [f] contains at least one finite element. *) val has_finite : t -> bool (** Floating-point builtins may produce three kinds of alarms: - [APosInf] when the result may contain +oo; - [ANegInf] when the result may contain -oo; - [ANaN msg] when the result is NaN; an explanation of why the argument is invalid is given. - [AAssume msg] is a variant of ANaN for debugging purposes, mostly for internal use. Ignored when printing alarms. Builtins may sometimes raise [Non_finite] when no part of the result is finite. *) type builtin_alarm = APosInf | ANegInf | ANaN of string | AAssume of string module Builtin_alarms : (Set.S with type elt = builtin_alarm) type builtin_res = Builtin_alarms.t * t Bottom.or_bottom (** Builtins return structured alarms, in the guise of a set of string explaining the problem. *) type float_kind = | Float32 (** 32 bits float (a.k.a 'float' C type) *) | Float64 (** 64 bits float (a.k.a 'double' C type) *) (** Equivalent to the [nextafter/nextafterf] functions in C. *) val next_after : float_kind -> F.t -> F.t -> F.t (** [inject] creates an abstract float interval. Does not handle infinities or NaN. Does not enlarge subnormals to handle flush-to-zero modes *) val inject : F.t -> F.t -> t (** [inject_r_f] creates an abstract float interval. It handles infinities and flush-to-zero (rounding subnormals if needed), but not NaN. The returned booleans are true if the lower/upper bound may be infinite. May raise {!Non_finite} when no part of the result would be finite. Inputs must be compatible with [float_kind]. *) val inject_r_f : float_kind -> F.t -> F.t -> bool (*-inf*) * bool (*+inf*) * t (** Alias for [inject_r_f Float64]. *) val inject_r : F.t -> F.t -> bool (* not finite *) * t (** Equivalent to [inject_r_f], but ignores the boolean [not_finite]. The caller must emit appropriate warnings in the presence of non-finite values. *) val inject_f : float_kind -> F.t -> F.t -> t val inject_singleton : F.t -> t val compare_min : t -> t -> int val compare_max : t -> t -> int val min_and_max : t -> F.t * F.t val top : t val add : rounding_mode -> t -> t -> bool * t val sub : rounding_mode -> t -> t -> bool * t val mul : rounding_mode -> t -> t -> bool * t val div : rounding_mode -> t -> t -> bool * t val is_a_zero : t -> bool (** [is_a_zero f] returns true iff f ⊆ [-0.0,+0.0] *) val fold_split : int -> (t -> 'a -> 'a) -> t -> 'a -> 'a (** no splitting occurs if the integer argument is less than 2 *) val contains_zero : t -> bool val compare : t -> t -> int val pretty : Format.formatter -> t -> unit val pretty_overflow: Format.formatter -> t -> unit (** This pretty-printer does not display -FLT_MAX and FLT_MAX as interval bounds. Instead, the special notation [--.] is used. *) val hash : t -> int val zero : t val minus_zero: t val zeros: t (** Both positive and negative zero *) val is_zero : t -> bool val is_included : t -> t -> bool val join : t -> t -> t val meet : t -> t -> t Bottom.or_bottom val narrow : t -> t -> t Bottom.or_bottom val contains_a_zero : t -> bool val is_singleton : t -> bool exception Not_Singleton_Float val project_float: t -> F.t (** @raise Not_Singleton_Float when the interval is not a single float. *) val minus_one_one : t val subdiv_float_interval : size:int -> t -> t * t val neg : t -> t val cos : t -> t val sin : t -> t val atan2: t -> t -> builtin_res (** Returns atan2(y,x). Does not emit any alarms. *) val pow: t -> t -> builtin_res (** Returns pow(x,y). *) val powf : t -> t -> builtin_res (** Single-precision version of pow. *) val fmod: t -> t -> builtin_res (** Returns fmod(x,y). May return a "division by zero" alarm. Raises [Builtin_invalid_domain] if there is certainly a division by zero. *) val sqrt : rounding_mode -> t -> builtin_res (** Discussion regarding -all-rounding-modes and the functions below. Support for fesetround(FE_UPWARD) and fesetround(FE_DOWNWARD) seems to be especially poor, including in not-so-old versions of Glibc (https://sourceware.org/bugzilla/show_bug.cgi?id=3976). The code for {!exp}, {!log} and {!log10} is correct wrt. -all-rounding-modes ONLY if the C implementation of these functions is correct in directed rounding modes. Otherwise, anything could happen, including crashes. For now, unless the Libc is known to be reliable, these functions should be called with [rounding_mode=Nearest_Even] only. Also note that there the Glibc does not guarantee that f(FE_DOWNWARD) <= f(FE_TONEAREST) <= f(FE_UPWARD), which implies that using different rounding modes to bound the final result does not ensure correct bounds. Here's an example where it does not hold (glibc 2.21): log10f(3, FE_TONEAREST) < log10f(3, FE_DOWNWARD). *) val exp : rounding_mode -> t -> Builtin_alarms.t * t val log: rounding_mode -> t -> builtin_res val log10: rounding_mode -> t -> builtin_res (** All three functions may raise {!Non_finite}. Can only be called to approximate a computation on double (float64). *) val floor: rounding_mode -> t -> Builtin_alarms.t * t val ceil: rounding_mode -> t -> Builtin_alarms.t * t val trunc: rounding_mode -> t -> Builtin_alarms.t * t val fround: rounding_mode -> t -> Builtin_alarms.t * t val expf : rounding_mode -> t -> Builtin_alarms.t * t val logf : rounding_mode -> t -> builtin_res val log10f : rounding_mode -> t -> builtin_res val sqrtf : rounding_mode -> t -> builtin_res val floorf: rounding_mode -> t -> Builtin_alarms.t * t val ceilf: rounding_mode -> t -> Builtin_alarms.t * t val truncf: rounding_mode -> t -> Builtin_alarms.t * t val froundf: rounding_mode -> t -> Builtin_alarms.t * t (** Single-precision versions *) val widen : t -> t -> t val forward_comp: Comp.t -> t -> t -> Comp.result val diff : t -> t -> t Bottom.or_bottom val backward_comp_left : Comp.t -> bool -> float_kind -> t -> t -> t Bottom.or_bottom (** [backward_comp op allroundingmodes fkind f1 f2] attempts to reduce [f1] into [f1'] so that the relation [f1' op f2] holds. [fkind] is the type of [f1] and [f1'] (not necessarily of [f2]). If [allroundingmodes] is set, all possible rounding modes are taken into account. [op] must be [Eq], [Ne], [Le], [Ge], [Lt] or [Gt] *) val cast_float_to_double_inverse: t -> t (** [cast_float_to_double_inverse d] return all possible float32 [f] such that [(double)f = d]. The double of [d] that have no float32 equivalent are discarded. *) val enlarge_1ulp: float_kind -> t -> t (** enlarge the bounds of the interval by one ulp. @raise Non_finite if the result is not fully finite. *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/int_Base.ml0000644000175000017500000000615513113745005025611 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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.t_sum [| [| Datatype.Integer.packed_descr |] |] let reprs = Top :: List.map (fun v -> Value v) Datatype.Integer.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-Phosphorus-20170501/src/kernel_services/abstract_interp/lmap.ml0000644000175000017500000006353213113745005025020 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 let msg_emitter = Lattice_messages.register "Lmap";; type 'a default_contents = | Bottom | Top of 'a | Constant of 'a | Other module Make_LOffset (V: sig include module type of Offsetmap_lattice_with_isotropy include Lattice_type.With_Top_Opt with type t := t end) (Offsetmap: module type of Offsetmap_sig with type v = V.t and type widen_hint = V.generic_widen_hint) (Default_offsetmap: sig val name: string val default_offsetmap : Base.t -> Offsetmap.t Bottom.or_bottom val default_contents: V.t default_contents end) = struct type v = V.t type offsetmap = Offsetmap.t type widen_hint_base = V.generic_widen_hint exception Error_Top open Default_offsetmap (* to be used only when we are sure that the base is not Invalid, for example because it is bound in at least one map. *) let default_bound_offsetmap b = match Default_offsetmap.default_offsetmap b with | `Bottom -> assert false | `Value o -> o let () = match Default_offsetmap.default_contents with | Constant v -> if not (V.is_isotropic v) then Kernel.fatal "[Lmap] invalid default contents for offsetmaps %a \ (datatype: %s)" V.pretty v V.name | _ -> () let vtop () = match V.top_opt with | None -> raise Error_Top | Some v -> v module M = struct module Comp = struct let f _base offsetmap = Offsetmap.cardinal_zero_or_one offsetmap let compose a b = a && b let e = true end module Initial_Values = struct let v = [ [] ] end module M = Hptmap.Make (Base.Base) (struct include Offsetmap let name = Offsetmap.name ^ " " ^ Default_offsetmap.name end) (Comp) (Initial_Values) (struct let l = [ Ast.self ] end) let () = Ast.add_monotonic_state M.self include M let add = match Default_offsetmap.default_contents with | Bottom -> fun b o m -> add b o m | Top top -> fun b o m -> if Offsetmap.is_same_value o top then remove b m else add b o m | Constant v -> fun b o m -> if Offsetmap.is_same_value o v then remove b m else add b o m | Other -> fun b o m -> let o' = default_bound_offsetmap b in if Offsetmap.equal o o' then remove b m else add b o m let find_or_default b map = try `Value (find b map) with Not_found -> default_offsetmap b let find_base = find let pretty fmt m = Pretty_utils.pp_iter ~pre:"@[" ~sep:"@ " ~suf:"@]" (Extlib.iter_uncurry2 iter) (fun fmt (base, offs) -> let typ = Base.typeof base in Format.fprintf fmt "@[%a@[%a@]@]" Base.pretty base (Offsetmap.pretty_generic ?typ ()) offs) fmt m (* TODO: can be improved in quite a few ways. *) let filter_base f m = fold (fun k v acc -> if f k then add k v acc else acc) m empty let offsetmap_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 only the bases present in [filter], but including those that are bound to their default value. *) let pretty_filter fmt m zfilter = let first = ref true in let filter base _itvs () = match find_or_default base m with | `Bottom -> () | `Value offsm -> if not (offsetmap_all_bottom offsm) then begin if !first then first := false else Format.fprintf fmt "@ "; let typ = Base.typeof base in Format.fprintf fmt "@[%a%a@]" Base.pretty base (Offsetmap.pretty_generic ?typ ()) offsm end in match zfilter with | Zone.Top (Base.SetLattice.Top, _) -> pretty fmt m (* fallback *) | _ -> Format.fprintf fmt "@["; Zone.fold_topset_ok filter zfilter (); Format.fprintf fmt "@]" let add_base_value base ~size v ~size_v m = add base (Offsetmap.create ~size v ~size_v) m exception Result_is_top let add_binding ~exact mem {loc; size} v = let had_non_bottom = ref false in let result = ref mem in let aux origin b offsets = let validity = Base.validity b in match find_or_default b mem with | `Bottom -> () | `Value offm -> let offm' = match size with | Int_Base.Top -> let orig = Origin.current Origin.K_Arith in Offsetmap.update_imprecise_everywhere ~validity orig v offm | Int_Base.Value size -> assert (Int.ge size Int.zero); let _, r = Offsetmap.update ?origin ~validity ~exact ~offsets ~size v offm in r in match offm' with | `Bottom -> () | `Value offm' -> had_non_bottom := true; if offm != offm' then result := add b offm' !result in match loc with | Location_Bits.Top (Base.SetLattice.Top, orig) -> Lattice_messages.emit_approximation msg_emitter "writing at a completely unknown address @[%a@]" Origin.pretty_as_reason orig; raise Result_is_top | Location_Bits.Top (Base.SetLattice.Set set, origin) -> Base.Hptset.iter (fun b -> aux (Some origin) b Ival.top) set; !had_non_bottom, !result | Location_Bits.Map loc_map -> Location_Bits.M.iter (fun b off -> aux None b off) loc_map; !had_non_bottom, !result (* may raise Error_Top in the case Top Top. Make sure to annotate callers *) let find ?(conflate_bottom=true) mem {loc ; size} = let handle_imprecise_base base acc = match find_or_default base mem with | `Bottom -> acc | `Value offsetmap -> V.join (Offsetmap.find_imprecise_everywhere offsetmap) acc in match loc with | Location_Bits.Top (Base.SetLattice.Top, _) -> vtop () | Location_Bits.Top (Base.SetLattice.Set s, _) -> Base.SetLattice.O.fold handle_imprecise_base s V.bottom | Location_Bits.Map loc_map -> begin match size with | Int_Base.Top -> let aux base _ acc = handle_imprecise_base base acc in Location_Bits.M.fold aux loc_map V.bottom | Int_Base.Value size -> let aux_base base offsets acc_v = let validity = Base.validity base in match find_or_default base mem with | `Bottom -> acc_v | `Value offsetmap -> let _alarm_o, new_v = Offsetmap.find ~conflate_bottom ~validity ~offsets ~size offsetmap in V.join new_v acc_v in Location_Bits.M.fold aux_base loc_map V.bottom end (* Internal function for join and widen, that handles efficiently the values bound by default in maps. *) let join_widen op = let cache = match op with | `Join -> Hptmap_sig.PersistentCache "lmap.join" | `Widen _ -> Hptmap_sig.NoCache in let symmetric = match op with `Join -> true | `Widen _ -> false in let op = match op with | `Join -> fun _b o1 o2 -> Offsetmap.join o1 o2 | `Widen wh -> fun b o1 o2 -> Offsetmap.widen (wh b) o1 o2 in let idempotent = true in let default = default_bound_offsetmap in let decide_both_revert default b o1 o2 = let o = op b o1 o2 in if Offsetmap.is_same_value o default then None else Some o in match Default_offsetmap.default_contents with | Bottom -> (* Missing keys are neutral w.r.t. merge because they are Bottom. Values cannot revert to default (bottom). *) join ~cache ~symmetric ~idempotent ~decide:op | Top top -> (* Join with a missing key returns Top, hence the default: we can use [inter]. Values can revert to the default through [op]. *) let decide b o1 o2 = decide_both_revert top b o1 o2 in inter ~cache ~symmetric ~idempotent ~decide | Constant v -> (* Missing keys must be treated one by one. Values can revert to default *) let decide_both b o1 o2 = decide_both_revert v b o1 o2 in let decide_left b o = decide_both_revert v b o (default b) in let decide_right b o = decide_both_revert v b (default b) o in merge ~cache ~symmetric ~idempotent ~decide_both ~decide_left:(Traversing decide_left) ~decide_right:(Traversing decide_right) | Other -> (* Same idea as VCst *) let decide_two b default o1 o2 = let o = op b o1 o2 in if Offsetmap.equal o default then None else Some o in let decide_both b o1 o2 = decide_two b (default b) o1 o2 in let decide_left b o = let default = default b in decide_two b default o default in let decide_right b o = let default = default b in decide_two b default default o in merge ~cache ~symmetric ~idempotent ~decide_both ~decide_left:(Traversing decide_left) ~decide_right:(Traversing decide_right) let join = join_widen `Join module Make_Narrow (X: sig include Lattice_type.With_Top with type t := V.t include Lattice_type.With_Narrow with type t := V.t val bottom_is_strict: bool end) = struct exception NarrowReturnsBottom module OffsetmapNarrow = Offsetmap.Make_Narrow(struct let top = X.top (* If bottom is strict, catch results of [narrow] that are bottom and raise an exception instead *) let narrow = if X.bottom_is_strict then fun x y -> let r = X.narrow x y in if V.(equal bottom r) then raise NarrowReturnsBottom; r else fun x y -> X.narrow x y end) (* may raise {!NarrowReturnsBottom} when Bottom is strict *) let narrow_internal = let cache = Hptmap_sig.PersistentCache "lmap.narrow" and symmetric = true and idempotent = true in match Default_offsetmap.default_contents with | Bottom -> (* Bases completely mapped to Bottom disappear from the result, but we do *not* raise NarrowReturnsBottom (otherwise, we would never be able to call narrow with two different sets of variables). *) let decide b o1 o2 = let o = OffsetmapNarrow.narrow o1 o2 in let default = default_bound_offsetmap b in if Offsetmap.equal o default then None else Some o in M.inter ~cache~symmetric ~idempotent ~decide | Top _ -> (* Missing keys are implicitly bound to Top, hence neutral for the operation. Hence, we can use join. No need to check if a variable reverts to default, because narrow only decreases *) let decide _k v1 v2 = OffsetmapNarrow.narrow v1 v2 in M.join ~cache ~symmetric ~idempotent ~decide | Constant _ | Other -> (* No special optimisation, we perform a pointwise narrow and see if we revert to the default value. [`Constant] case could be improved. Since [narrow] is symmetric, [decide_left == decide_right]. Otherwise, see [`Other] case in {!join_widen} *) let decide_two default o1 o2 = let o = OffsetmapNarrow.narrow o1 o2 in if Offsetmap.equal o default then None else Some o in let decide_one b o = let default = default_bound_offsetmap b in decide_two default o default in let decide_both b o1 o2 = decide_two (default_bound_offsetmap b) o1 o2 in let decide_left = Traversing decide_one in merge ~cache ~symmetric ~idempotent ~decide_both ~decide_left ~decide_right:decide_left end 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_generic ?typ ()) m | None, Some m -> let typ = Base.typeof base in Format.fprintf fmt "@[R %a@[%a@]@]@ " Base.pretty base (Offsetmap.pretty_generic ?typ ()) m | Some m1, Some m2 -> if not (Offsetmap.equal m1 m2) then let typ = Base.typeof base in let pp = Offsetmap.pretty_generic ?typ () in Format.fprintf fmt "@[%a @[L@[%a@]@,R@[%a@]@]@]@ " Base.pretty base pp m1 pp m2 in (* The diff is implemented by performing a merge on the two offsetmaps. We _must not_ cache the result, as we are interested only in the side effects. *) let decide b m1 m2 = print b m1 m2; (match m1, m2 with (* We need something to return *) | Some m, _ | _, Some m -> m | None, None -> assert false (* generic_merge invariant *)) in let aux = generic_join ~cache:Hptmap_sig.NoCache ~idempotent:true ~symmetric:true ~decide in Format.fprintf fmt "@["; ignore (aux m1 m2); Format.fprintf fmt "@]" let pretty_diff fmt m1 m2 = if m1 == m2 then Format.fprintf fmt "Equal" else pretty_diff_aux fmt m1 m2 let is_included = let name = Format.asprintf "Lmap(%s).is_included" V.name in let decide_fst base v1 = Offsetmap.is_included v1 (default_bound_offsetmap base) in let decide_snd base v2 = Offsetmap.is_included (default_bound_offsetmap base) v2 in let decide_both _ m1 m2 = Offsetmap.is_included m1 m2 in let decide_fast = match Default_offsetmap.default_contents with | Bottom -> (fun s t -> if s == t || is_empty s (*all bases present in t but not in s are implicitly bound to Bottom in s, hence the inclusion holds *) then PTrue else PUnknown) | Top _ -> (fun s t -> if s == t || is_empty t (*all bases present in s but not in t are implicitly bound to Top in t, hence the inclusion holds *) then PTrue else PUnknown) | _ -> (fun s t -> if s == t then PTrue else PUnknown) in binary_predicate (Hptmap_sig.PersistentCache name) UniversalPredicate ~decide_fast ~decide_fst ~decide_snd ~decide_both type widen_hint = Base.Set.t * (Base.t -> V.generic_widen_hint) (* Precondition : m1 <= m2 *) let widen (wh_key_set, wh_hints: widen_hint) m1 m2 = let widened, something_done = Base.Set.fold (fun key (widened, something_done) -> let offs2 = find_or_default key m2 in let offs1 = find_or_default key m1 in match offs1, offs2 with | `Bottom, _ | _, `Bottom -> assert false (* cannot be invalid and bound *) | `Value offs1, `Value offs2 -> let unchanged = Offsetmap.equal offs2 offs1 in (* Format.printf "key=%a, fixed=%b@." Base.pretty key fixed; *) if unchanged then (widened, something_done) else let new_off = Offsetmap.widen (wh_hints key) offs1 offs2 in (add key new_off widened, true) ) wh_key_set (m2, false) in if something_done then widened else join_widen (`Widen wh_hints) m1 m2 let paste_offsetmap ~from ~dst_loc ~size ~exact m = let loc_dst = make_loc dst_loc (Int_Base.inject size) in assert (Int.le Int.zero size); 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 = let validity = Base.validity base_dst in let offsetmap_dst = find_or_default base_dst m in match offsetmap_dst with | `Bottom -> acc | `Value offsetmap_dst -> let _this_alarm, new_offsetmap = Offsetmap.paste_slice ~validity ~exact ~from ~size ~offsets:i_dst offsetmap_dst in had_non_bottom := true; match new_offsetmap with | `Bottom -> acc | `Value new_offsetmap -> if offsetmap_dst != new_offsetmap then add base_dst new_offsetmap acc else acc in match dst_loc with | Location_Bits.Map _ -> let result = Location_Bits.fold_i treat_dst dst_loc m in !had_non_bottom, result | Location_Bits.Top (top, orig) -> if not (Base.SetLattice.equal top Base.SetLattice.top) then Lattice_messages.emit_approximation msg_emitter "writing somewhere in @[%a@]@[%a@]." Base.SetLattice.pretty top Origin.pretty_as_reason orig; let validity = Base.validity_from_size size in let v = Offsetmap.find_imprecise ~validity from in add_binding ~exact:false m loc_dst v let top_offsetmap size = let top = vtop () in `Value (Offsetmap.create_isotropic ~size top) (* may raise Error_Top in the case Top Top *) let copy_offsetmap src_loc size m = let treat_src k_src i_src acc = let validity = Base.validity k_src in match find_or_default k_src m with | `Bottom -> acc | `Value offsetmap_src -> let _alarm_copy, copy = Offsetmap.copy_slice ~validity ~offsets:i_src ~size offsetmap_src in Bottom.join Offsetmap.join acc copy in try Location_Bits.fold_topset_ok treat_src src_loc `Bottom with Location_Bits.Error_Top -> top_offsetmap size end type map = M.t let shape = M.shape let clear_caches = M.clear_caches exception Found_prefix = M.Found_prefix type lmap = | Bottom | Top | Map of M.t let equal m1 m2 = match m1, m2 with | Bottom, Bottom -> true | Top, Top -> true | Map m1, Map m2 -> M.equal m1 m2 | (Bottom | Top | Map _), _ -> false let comp_prefixes m1 m2 = match m1, m2 with | Map m1, Map m2 -> M.comp_prefixes m1 m2 | _ -> () type subtree = M.subtree let find_prefix m p = match m with | Map m -> M.find_prefix m p | Top | Bottom -> None let equal_subtree = M.equal_subtree let hash_subtree = M.hash_subtree let compare = if M.compare == Datatype.undefined then Datatype.undefined else fun m1 m2 -> match m1, m2 with | Bottom, Bottom | Top, Top -> 0 | Map m1, Map m2 -> M.compare m1 m2 | Bottom, (Top | Map _) | Top, Map _ -> -1 | Map _, (Top | Bottom) | Top, Bottom -> 1 let empty_map = Map M.empty let hash = function | Bottom -> 457 | Top -> 458 | Map m -> M.hash m let pretty fmt m = match m with | Bottom -> Format.fprintf fmt "@[NOT ACCESSIBLE@]" | Top -> Format.fprintf fmt "@[NO INFORMATION@]" | Map m -> M.pretty fmt m let pretty_debug fmt m = match m with | Top | Bottom -> pretty fmt m | Map m -> M.pretty_debug fmt m include Datatype.Make_with_collections (struct type t = lmap let structural_descr = Structural_descr.t_sum [| [| M.packed_descr |] |] let name = Printf.sprintf "(%s, %s) Lmap" Offsetmap.name Default_offsetmap.name let reprs = Bottom :: Top :: List.map (fun b -> Map b) M.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 let add_base base offsetmap acc = match acc with | Map acc -> Map (M.add base offsetmap acc) | Bottom -> Bottom | Top -> Top let is_empty_map = function | Bottom -> false | Top -> false | Map m -> M.is_empty m let filter_base f = function | Top -> Top | Bottom -> Bottom | Map m -> Map (M.filter_base f m) let filter_by_shape shape = function | Top -> Top | Bottom -> Bottom | Map m -> Map (M.inter_with_shape shape m) let find_base b = function | Bottom -> `Bottom | Top -> `Top | Map m -> `Value (M.find_base b m) let find_base_or_default b = function | Bottom -> `Bottom | Top -> `Top | Map m -> (M.find_or_default b m :> _ Bottom.Top.or_top_bottom) let remove_base b = function | Bottom -> Bottom | Top -> Top | Map m -> Map (M.remove b m) let is_reachable = function | Bottom -> false | Top | Map _ -> true let pretty_filter fmt m zfilter = match m with | Bottom -> Format.fprintf fmt "@[NON TERMINATING FUNCTION@]" | Top -> Format.fprintf fmt "@[NO INFORMATION@]" | Map m -> M.pretty_filter fmt m zfilter let add_base_value base ~size v ~size_v = function | Bottom -> Bottom | Top -> Top | Map m -> Map (M.add_base_value base ~size v ~size_v m) let add_binding ~exact m loc v = (* TODO: this should depend on bottom being strict. *) if V.equal v V.bottom then Bottom else match m with | Top -> Top | Bottom -> Bottom | Map m -> try let non_bottom, r = M.add_binding ~exact m loc v in if non_bottom then Map r else Bottom with M.Result_is_top -> Top let find ?(conflate_bottom=true) m loc = match m with | Bottom -> V.bottom | Top -> vtop () | Map m -> M.find ~conflate_bottom m loc let join mm1 mm2 = match mm1, mm2 with | Bottom,m | m,Bottom -> m | Top, _ | _, Top -> Top | Map m1, Map m2 -> if M.equal m1 m2 then mm1 else Map (M.join m1 m2) module Make_Narrow (X: sig include Lattice_type.With_Top with type t := v include Lattice_type.With_Narrow with type t := v val bottom_is_strict: bool end) = struct include M.Make_Narrow(X) let narrow mm1 mm2 = match mm1, mm2 with | Bottom,_ | _,Bottom -> Bottom | Top, m | m, Top -> m | Map m1, Map m2 -> if M.equal m1 m2 then mm1 else try Map (narrow_internal m1 m2) with NarrowReturnsBottom -> Bottom end let pretty_diff fmt m1 m2 = match m1, m2 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 -> M.pretty_diff fmt m1 m2 let is_included m1 m2 = match m1, m2 with | Bottom,_ -> true | _,Bottom -> false | _, Top -> true | Top, _ -> false | Map m1, Map m2 -> M.is_included m1 m2 type widen_hint = M.widen_hint (* Precondition : m1 <= m2 *) let widen wh r1 r2 = match r1,r2 with | Top, Top | _, Top -> Top | Bottom,Bottom -> Bottom | _, Bottom | Top, Map _-> assert false (* thanks to precondition *) | Bottom, m -> m | Map m1,Map m2 -> Map (M.widen wh m1 m2) let paste_offsetmap ~from ~dst_loc ~size ~exact m = match m with | Bottom -> m | Top -> m | Map m -> try let non_bottom, r = M.paste_offsetmap ~from ~dst_loc ~size ~exact m in if non_bottom then Map r else Bottom with M.Result_is_top -> Top let copy_offsetmap src_loc size m = match m with | Bottom -> `Bottom | Top -> M.top_offsetmap size | Map m -> M.copy_offsetmap src_loc size m let fold = M.fold let iter = M.iter let cached_fold ~f ~cache_name ~temporary ~joiner ~empty = let cached_f = M.cached_fold ~f ~cache_name ~temporary ~joiner ~empty in fun m -> cached_f m let cached_map ~f ~cache ~temporary = let cached_f = M.cached_map ~f ~cache ~temporary in function | Top -> Top | Bottom -> Bottom | Map m -> Map (cached_f m) let remove_variables vars state = let cleanup acc v = remove_base (Base.of_varinfo v) acc in List.fold_left cleanup state vars end (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/int_Intervals_sig.mli0000644000175000017500000000632413113745012027715 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 intervals with a lattice structure. Consecutive intervals are automatically fused. *) open Abstract_interp type itv = Int.t * Int.t include Lattice_type.Full_Lattice include Lattice_type.With_Error_Top val is_top: t -> bool val inject_bounds: Int.t -> Int.t -> t val inject_itv: itv -> 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 over-approximated. *) val from_ival_size_under: Ival.t -> Int_Base.t -> t (** Same as [from_ival_size], except that the result is an under-approximation if the ival points to too many locations *) val project_set: t -> itv list (** May raise [Error_Top]. As intervals are not represented as lists, this function has an overhead. Use iterators whenever possible instead. *) val project_singleton: t -> itv option (** Iterators *) val fold: (itv -> 'a -> 'a) -> t -> 'a -> 'a (** May raise [Error_Top] *) val iter: (itv -> unit) -> t -> unit (** May raise [Error_Top] *) 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 range_covers_whole_type: Cil_types.typ -> t -> bool (** Does the interval cover the entire range of bits that are valid for the given type. *) (**/**) val pretty_debug: t Pretty_utils.formatter (* Local Variables: compile-command: "make -C ../../.. byte" End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/map_Lattice.ml0000644000175000017500000004421413113745003026303 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 from a set of keys to values (a [Lattice_With_Diff]), equipped with the natural lattice interpretation. Keys must be mappable to integers in an unique way, and one of its elements ([null]) is singled out. *) open Abstract_interp module type Key = sig include Datatype.S val id : t -> int end module Make_without_cardinal (K : Key) (Top_Param : Lattice_type.Lattice_Hashconsed_Set with type O.elt=K.t) (V : sig include Lattice_type.Full_Lattice val pretty_debug: t Pretty_utils.formatter end) (Comp: sig (** See {!Hptmap} for the documentation of this option *) val e: bool val f : K.t -> V.t -> bool val compose : bool -> bool -> bool end) (L: sig val v : (K.t * V.t) list list end) = struct module M = Hptmap.Make (K) (V) (Comp) (struct let v = [] :: 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 t = Top of Top_Param.t * Origin.t | Map of map_t (** No function of this module creates a [Top] out of a [Map]. [Top] are always derived from an existing [Top] value. *) 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.hash 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 add k v m = match m with | Top (Top_Param.Top, _) -> m | Top (Top_Param.Set s, o) -> Top (Top_Param.(inject (O.add k s)), o) | Map m -> Map (add_or_bottom k v m) let bottom = Map M.empty let inject k v = Map (add_or_bottom k v M.empty) 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 pretty_debug 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 -> M.pretty_debug fmt m let find_or_bottom k m = try M.find_check_missing k m (* locations are usually small, so the difference between [M.find] and [M.find_check_missing] is usually unimportant. However, [find_check_missing] is more efficient when we query NULL, which is a very common case. *) 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_Top 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 decide _ v1 v2 = V.join v1 v2 in let name = Printf.sprintf "Map_Lattice(%s).join" V.name in let symmetric_merge = M.join ~cache:(Hptmap_sig.PersistentCache name) ~symmetric:true ~idempotent:true ~decide in fun m1 m2 -> if m1 == m2 then m1 else 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, o), Map m | Map m, Top (Top_Param.Set t, o) -> let s = M.fold (fun k _ acc -> Top_Param.O.add k acc) m t in Top (Top_Param.inject s, o) | Map mm1, Map mm2 -> let mresult = symmetric_merge mm1 mm2 in assert (true || 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 mr' = M.fold merge_key mm1 mm2 in if M.equal mresult mr' then true else begin let pp_one fmt mm = Format.fprintf fmt "%a (%d;%x)@." M.pretty_debug mm (M.hash mm) (Extlib.address_of_value mm) in Format.printf "Map_Lattice.join incorrect@. %a+%a->@. %a/%a" pp_one mm1 pp_one mm2 pp_one mresult pp_one mr'; false; end); Map mresult let cached_fold ~cache_name ~temporary ~f ~projection ~joiner ~empty = let folded_f = M.cached_fold ~cache_name ~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, o) -> begin try let add v acc = if f v then Top_Param.O.add v acc else acc in let s = Top_Param.fold add t Top_Param.O.empty in Top (Top_Param.inject s, o) with Top_Param.Error_Top -> top end | Map m -> Map (M.fold (fun k _ acc -> if f k then acc else M.remove k acc) m m) let meet = let decide _k v1 v2 = let r = V.meet v1 v2 in if V.equal V.bottom r then None else Some r in let name = Printf.sprintf "Map_Lattice(%s).meet" V.name in let merge = M.inter ~cache:(Hptmap_sig.PersistentCache name) ~symmetric:true ~idempotent:true ~decide in fun m1 m2 -> 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 -> Top_Param.O.mem v set) x | Map m1, Map m2 -> Map (merge m1 m2) let narrow = 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 decide _k v1 v2 = let r = V.narrow v1 v2 in if V.equal V.bottom r then None else Some r in let name = Printf.sprintf "Map_Lattice(%s).narrow" V.name in let merge = M.inter ~cache:(Hptmap_sig.PersistentCache name) ~symmetric:true ~idempotent:true ~decide in fun m1 m2 -> 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 -> Top_Param.O.mem v set) x | Map m1, Map m2 -> Map (merge m1 m2) let is_included = let name = Format.asprintf "Map_Lattice(%s)(%s).is_included" K.name V.name in let decide_fst _ _ = false in let decide_snd _ _ = true in let decide_both _ v1 v2 = V.is_included v1 v2 in let decide_fast = M.decide_fast_inclusion in let map_is_included = M.binary_predicate (Hptmap_sig.PersistentCache name) M.UniversalPredicate ~decide_fast ~decide_fst ~decide_snd ~decide_both in fun m1 m2 -> (match m1,m2 with | Top (s,a), Top (s',a') -> Top_Param.is_included s s' && Origin.is_included a a' | Map _, Top (Top_Param.Top, _) -> true | Map m, Top (Top_Param.Set set, _) -> M.for_all (fun k _ -> Top_Param.O.mem k set) m | Top _, Map _ -> false | Map m1, Map m2 -> map_is_included m1 m2) let join_and_is_included a b = let ab = join a b in (ab, equal a b) (* under-approximation of union *) let link = let decide _k v1 v2 = V.link v1 v2 in let name = Printf.sprintf "Map_Lattice(%s).link" V.name in let merge = M.join ~cache:(Hptmap_sig.PersistentCache name) ~symmetric:true ~idempotent:true ~decide in fun m1 m2 -> 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 -> Map (merge mm1 mm2) let intersects = let name = Format.asprintf "Map_Lattice(%s)(%s).intersects" K.name V.name in let map_intersects = M.symmetric_binary_predicate (Hptmap_sig.PersistentCache name) M.ExistentialPredicate ~decide_fast:M.decide_fast_intersection ~decide_one:(fun _ _ -> false) ~decide_both:(fun _ x y -> V.intersects x y) in fun mm1 mm2 -> match mm1, mm2 with | Top (s1, _), Top (s2, _) -> Top_Param.intersects s1 s2 | Top (Top_Param.Top, _), Map m | Map m, Top (Top_Param.Top, _) -> not (M.equal m M.empty) | Top (Top_Param.Set s, _), Map m | Map m, Top (Top_Param.Set s, _) -> M.exists (fun b _ -> Top_Param.O.mem b s) m | Map m1, Map m2 -> map_intersects m1 m2 let find k v = match v with | Top (s, _) -> if Top_Param.mem k s then V.top else V.bottom | Map m -> find_or_bottom k m (** 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 -> match M.is_singleton m with | Some p -> p | _ -> raise Not_found 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, _) -> 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, _) -> 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 include (Datatype.Make_with_collections (struct type map = t type t = map let name = M.name ^ " map_lattice" let structural_descr = Structural_descr.t_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): Datatype.S_with_collections with type t := t) let clear_caches = M.clear_caches end module Make (K : Key) (Top_Param : Lattice_type.Lattice_Hashconsed_Set with type O.elt=K.t) (V : sig type generic_widen_hint type size_widen_hint include Lattice_type.Full_AI_Lattice_with_cardinality with type widen_hint = size_widen_hint * generic_widen_hint val pretty_debug: t Pretty_utils.formatter end) (Comp: sig (** See {!Hptmap} for the documentation of this option *) val e: bool val f : K.t -> V.t -> bool val compose : bool -> bool -> bool end) (L: sig val v : (K.t * V.t) list list end) = struct include Make_without_cardinal(K)(Top_Param)(V)(Comp)(L) type size_widen_hint = V.size_widen_hint type generic_widen_hint = K.t -> V.generic_widen_hint type widen_hint = size_widen_hint * generic_widen_hint let widen (size,wh) = let widen_map = let decide k v1 v2 = V.widen (size,wh k) v1 v2 in M.join ~cache:Hptmap_sig.NoCache (* No cache, because of wh *) ~symmetric:false ~idempotent:true ~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) (** 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 fold_enum 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 g vl acc) m acc with V.Error_Top -> raise Error_Top 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 end (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/offsetmap_bitwise_sig.mli0000644000175000017500000001343413113745006030611 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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_bitwise} module, that implement efficient maps from intervals to values. Values are simpler than those of the {!Offsetmap_sig} module: given a value [v] bound to an interval [i], all sub-intervals of [i] are implicitly also bound to [v]. If you need e.g. to extract the k-th bit of the interval to retrieve a more precise value, you must use the {!Offsetmap} module instead. *) type v (** Type of the values stored in the offsetmap *) include Datatype.S (** Datatype for the offsetmap *) type intervals (** {2 Pretty-printing} *) val pretty: t Pretty_utils.formatter val pretty_generic : ?typ:Cil_types.typ -> ?pretty_v:(Format.formatter -> v -> unit) -> ?skip_v:(v -> bool) -> ?sep:string -> unit -> Format.formatter -> t -> unit val pretty_debug: t Pretty_utils.formatter (** {2 Join and inclusion testing} *) val join : t -> t -> t val is_included : t -> t -> bool (** {2 Finding values} *) val find : Int_Intervals_sig.itv -> t -> v val find_iset : validity:Base.validity -> intervals -> t -> v (** {2 Adding values} *) val add_binding_intervals : validity:Base.validity -> exact:bool -> intervals -> v -> t -> t Bottom.or_bottom val add_binding_ival : validity:Base.validity -> exact:bool -> Ival.t -> size:Int_Base.t -> v -> t -> t Bottom.or_bottom (** {2 Creating an offsetmap} *) (** [size] must be strictly greater than zero. *) val create: size:Integer.t -> v -> t val empty: t (** offsetmap containing no interval. *) val size_from_validity: Base.validity -> Integer.t Bottom.or_bottom (** [size_from_validity v] returns the size to be used when creating a new offsetmap for a base with validity [v]. This is a convention that should be shared by all modules that create offsetmaps. Returns [`Bottom] iff [v] is [Invalid]. @since Aluminium-20160501 *) (** {2 Iterators} *) val map : (v -> v) -> t -> t type map2_decide = ReturnLeft | ReturnRight | ReturnConstant of v | Recurse (** See the documentation of type {!Offsetmap_sig.map2_decide} *) val map2: Hptmap_sig.cache_type -> (t -> t -> map2_decide) -> (v -> v -> v) -> t -> t -> t (** See the documentation of function {!Offsetmap_sig.map2_on_values}. *) val fold : (intervals -> v -> 'a -> 'a) -> t -> 'a -> 'a val fold_fuse_same: (intervals -> v -> '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 fold_itv: ?direction:[`LTR | `RTL] -> entire:bool -> (Int_Intervals_sig.itv -> v -> 'a -> 'a) -> Int_Intervals_sig.itv -> t -> 'a -> 'a (** See documentation of {!Offsetmap_sig.fold_between}. *) (** [fold_join f join vempty itvs m] is an implementation of [fold] that restricts itself to the intervals in [itvs]. Unlike in [fold] (where the equivalent of [f] operates on an accumulator), [f] returns a value on each sub-interval independently. The results are joined using [joined]. [vempty] is the value that must be returned on {!Int_Intervals.bottom}. This function uses a cache internally. Hence, it must be partially applied to its first three arguments. If you do not need a cache, use [fold] instead. *) val fold_join_itvs: cache:Hptmap_sig.cache_type -> (Integer.t -> Integer.t -> v -> 'a) -> ('a -> 'a -> 'a) -> 'a -> intervals -> t -> 'a (** {2 Shape} *) val is_single_interval: t -> bool (** [is_single_interval o] is true if the offsetmap [o] contains a single binding. *) val single_interval_value: t -> v option (** [single_interval_value o] returns [Some v] if [o] contains a single interval, to which [v] is bound, and [None] otherwise. *) val is_same_value: t -> v -> bool (** [is_same_value o v] is true if the offsetmap [o] contains a single binding to [v], or is the empty offsetmap. *) (** {2 Misc} *) (** 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 (**/**) val imprecise_write_msg: string ref frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/bottom.ml0000644000175000017500000001174013113745004025364 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 = struct type 'a or_bottom = [ `Value of 'a | `Bottom ] (* This monad propagates the `Bottom value if needed. *) let (>>-) t f = match t with | `Bottom -> `Bottom | `Value t -> f t (* Use this monad if the following function returns a simple value. *) let (>>-:) t f = match t with | `Bottom -> `Bottom | `Value t -> `Value (f t) end include Type let non_bottom = function | `Value v -> v | `Bottom -> assert false let equal equal x y = match x, y with | `Bottom, `Bottom -> true | `Value vx, `Value vy -> equal vx vy | _ -> false let is_included is_included x y = match x, y with | `Bottom, _ -> true | _, `Bottom -> false | `Value vx, `Value vy -> is_included vx vy let join join x y = match x, y with | `Value vx, `Value vy -> `Value (join vx vy) | `Bottom, (`Value _ as v) | (`Value _ as v), `Bottom | (`Bottom as v), `Bottom -> v let narrow narrow x y = match x, y with | `Value vx, `Value vy -> narrow vx vy | `Bottom, `Value _ | `Value _, `Bottom | `Bottom, `Bottom -> `Bottom let pretty pretty fmt = function | `Bottom -> Format.fprintf fmt "Bottom" | `Value v -> pretty fmt v let counter = ref 0 module Make_Datatype (Domain: Datatype.S) = Datatype.Make ( struct include Datatype.Serializable_undefined type t = Domain.t or_bottom let () = incr counter let name = Domain.name ^ "+bottom(" ^ string_of_int !counter ^ ")" let reprs = [`Bottom; `Value (List.hd Domain.reprs)] let structural_descr = Structural_descr.t_unknown (* Structural_descr.t_sum [| [| Domain.packed_descr |] |] *) let equal a b = match a, b with | `Bottom, `Bottom -> true | `Value v, `Value w -> Domain.equal v w | _, _ -> false let compare a b = match a, b with | `Bottom, `Bottom -> 0 | `Bottom, _ -> -1 | _, `Bottom -> 1 | `Value v, `Value w -> Domain.compare v w let hash = function | `Bottom -> 0 | `Value v -> Domain.hash v let rehash = Datatype.identity let copy = function | `Bottom -> `Bottom | `Value v -> `Value (Domain.copy v) let pretty fmt = function | `Bottom -> Format.fprintf fmt "Bottom" | `Value v -> Domain.pretty fmt v let mem_project = Datatype.never_any_project end) module Bound_Lattice (Lattice: Lattice_type.Join_Semi_Lattice) = struct include Make_Datatype (Lattice) let bottom = `Bottom let join = join Lattice.join let is_included = is_included Lattice.is_included let join_and_is_included a b = match a, b with | `Bottom, _ -> b, true | _, `Bottom -> a, false | `Value a, `Value b -> let joined, is_included = Lattice.join_and_is_included a b in `Value joined, is_included end let bot_of_list = function | [] -> `Bottom | l -> `Value l let list_of_bot = function | `Bottom -> [] | `Value l -> l let add_to_list elt list = match elt with | `Bottom -> list | `Value elt -> elt :: list module Top = struct type 'a or_top_bottom = [ 'a or_bottom | `Top ] let join vjoin x y = match x, y with | `Top, _ | _, `Top -> `Top | (#or_bottom as x), (#or_bottom as y) -> join vjoin x y let narrow vnarrow x y = match x, y with | `Top, v | v, `Top -> v | (#or_bottom as x), (#or_bottom as y) -> (narrow vnarrow x y :> _ or_top_bottom) end frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/ival.ml0000644000175000017500000025342313113745006025023 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 F_Set = Set.Make(Fval.F) (* Uses F's total compare function *) (* 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 debug_cardinal = false let set_small_cardinal i = assert (2 <= i && i <= 1024); 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 let emitter = Lattice_messages.register "Ival";; let log_imprecision s = Lattice_messages.emit_imprecision emitter s ;; module Widen_Arithmetic_Value_Set = struct include Datatype.Integer.Set 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 of_list l = match l with | [] -> empty | [e] -> singleton e | e :: q -> List.fold_left (fun acc x -> add x acc) (singleton e) q let default_widen_hints = of_list (List.map Int.of_int [-1;0;1]) 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 = FCSet.Make(Integer) type pre_set = Pre_set of O.t * int | Pre_top of Int.t * Int.t * Int.t type t = | Set of Int.t array | Float of Fval.t | Top of Int.t option * Int.t option * Int.t * Int.t (* Binary abstract operations do not model precisely float/integer operations. It is the responsibility of the callers to have two operands of the same implicit type. The only exception is for [singleton_zero], which is the correct representation of [0.] *) module Widen_Hints = Widen_Arithmetic_Value_Set type size_widen_hint = Integer.t type generic_widen_hint = Widen_Hints.t type widen_hint = size_widen_hint * generic_widen_hint let some_zero = Some Int.zero let bottom = Set (Array.make 0 Int.zero) let top = Top(None, None, Int.zero, Int.one) 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 * Fval.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) -> Fval.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) -> Fval.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 min_le_elt min elt = match min with | None -> true | Some m -> Int.le m elt let max_ge_elt max elt = 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 fail min max r modu = let bound fmt = function | None -> Format.fprintf fmt "--" | Some(x) -> Int.pretty fmt x in Kernel.fatal "Ival: broken Top, min=%a max=%a r=%a modu=%a" bound min bound max Int.pretty r Int.pretty modu let is_safe_modulo r modu = (Int.ge r Int.zero ) && (Int.ge modu Int.one) && (Int.lt r modu) let check_modulo min max r modu = if not (is_safe_modulo r modu) then fail min max r modu let is_safe_bound bound r modu = match bound with | None -> true | Some m -> Int.equal (Int.pos_rem m modu) r (* Sanity check for Top's arguments *) let check min max r modu = if not (is_safe_modulo r modu && is_safe_bound min r modu && is_safe_bound max r modu) then fail min max r modu let cardinal_zero_or_one v = match v with | Top _ -> false | Set s -> Array.length s <= 1 | Float f -> Fval.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 minus_one = Set [| Int.minus_one |] let zero_or_one = Set [| Int.zero ; Int.one |] let float_zeros = Float Fval.zeros let positive_integers = Top(Some Int.zero, None, Int.zero, Int.one) let negative_integers = Top(None, Some Int.zero, Int.zero, Int.one) let strictly_negative_integers = Top(None, Some Int.minus_one, 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 Fval.is_zero f then zero else Float f let inject_float_interval flow fup = let flow = Fval.F.of_float flow in let fup = Fval.F.of_float fup in if Fval.F.equal Fval.F.zero flow && Fval.F.equal Fval.F.zero fup then zero else Float (Fval.inject flow fup) let subdiv_float_interval ~size v = match v with | Float f -> let f1, f2 = Fval.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 (Fval.minus_zero, Fval.minus_zero) *) let is_one = equal one exception Nan_or_infinite let project_float v = if is_zero v then Fval.zero else match v with | Float f -> f | Top _ | Set _ -> raise Nan_or_infinite (* Also catches bottom. TODO *) let in_interval x min max r modu = Int.equal (Int.pos_rem x modu) r && min_le_elt min x && max_ge_elt max x 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 -> Fval.contains_zero f exception Not_Singleton_Int let project_int v = match v with | Set [| e |] -> e | _ -> raise Not_Singleton_Int let cardinal v = match v with | Top (None,_,_,_) | Top (_,None,_,_) -> None | Top (Some mn, Some mx,_,m) -> Some (Int.succ ((Int.native_div (Int.sub mx mn) m))) | Set s -> Some (Int.of_int (Array.length s)) | Float f -> if Fval.is_singleton f then Some Int.one else None let cardinal_estimate v size = match v with | Set s -> Int.of_int (Array.length s) | Top (mn,mx,_,d) -> (* Note: we clip the interval to get a finite cardinal. *) let mn = match mn with | None -> Integer.(neg (two_power (pred size))) | Some(mn) -> mn in let mx = match mx with | None -> Integer.(pred (two_power size)) | Some(mx) -> mx in Int.(div (sub mx mn) d) | Float f -> if Fval.is_singleton f then Int.one (* TODO: Get exponent of min and max, and multiply by two_power the size of mantissa. *) else Int.two_power size 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 Fval.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 cardinal_is_less_than v n = match cardinal v with | None -> false | Some c -> Int.le c (Int.of_int n) let share_top min max r modu = let r = Top (min, max, r, modu) in if equal r top then top else r let make ~min ~max ~rem ~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, rem, modu) else if Int.equal mx mn then inject_singleton mn else bottom | _ -> share_top min max rem modu let inject_top min max rem modu = check min max rem modu; make ~min ~max ~rem ~modu let inject_interval ~min ~max ~rem:r ~modu = check_modulo min max r modu; let min = Extlib.opt_map (fun min -> Int.round_up_to_r ~min ~r ~modu) min and max = Extlib.opt_map (fun max -> Int.round_down_to_r ~max ~r ~modu) max in make ~min ~max ~rem:r ~modu let subdiv_int v = match v with | Float _ -> raise Can_not_subdiv | 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) Int.two in let succmean = 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 Fval.top let top_single_precision_float = Float Fval.top_single_precision_float let unsafe_make_top_from_set_4 s = if debug_cardinal then 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 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) -> if debug_cardinal then 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 if debug_cardinal then 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 -> Fval.F.zero, Fval.F.zero | Float f -> Fval.min_and_max f | _ -> assert false 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 Fval.compare_min f1 f2 let compare_max_float t1 t2 = let f1 = project_float t1 in let f2 = project_float t2 in Fval.compare_max f1 f2 let widen (bitsize,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 (Fval.is_included f1 f2) then assert false; Float (Fval.widen f1 f2) with Nan_or_infinite (* raised by project_float *) -> assert false) | Top _ | Set _ -> (* Add possible interval limits deducted from the bitsize *) let wh = if Integer.is_zero bitsize then wh else let limits = [ Integer.neg (Integer.two_power (Integer.pred bitsize)); Integer.pred (Integer.two_power (Integer.pred bitsize)); Integer.pred (Integer.two_power bitsize); ] in let module ISet = Datatype.Integer.Set in ISet.union wh (ISet.of_list limits) in 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 = Integer.ppcm m1 m2 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 (* Do the two arrays have an integer in common *) let arrays_intersect a1 a2 = let l1 = Array.length a1 in let l2 = Array.length a2 in let rec aux i1 i2 = if i1 = l1 || i2 = l2 then false else let e1 = a1.(i1) in let e2 = a2.(i2) in if Int.equal e1 e2 then true else if Int.lt e1 e2 then aux (succ i1) i2 else aux i1 (succ i2) in aux 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.make 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) -> begin match Fval.meet f1 f2 with | `Value f -> inject_float f | `Bottom -> bottom end | (Float f) as ff, other | other, ((Float f) as ff) -> if equal top other then ff else if (Fval.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 intersects v1 v2 = v1 == v2 || match v1, v2 with | Top _, Top _ -> not (is_bottom (meet v1 v2)) (* YYY: slightly inefficient *) | Set s1 , Set s2 -> arrays_intersect s1 s2 | Set s, Top (min, max, rm, modu) | Top (min, max, rm, modu), Set s -> Extlib.array_exists (fun x -> in_interval x min max rm modu) s | Float f1, Float f2 -> begin match Fval.forward_comp Comp.Eq f1 f2 with | Comp.False -> false | Comp.True | Comp.Unknown -> true end | Float f, other | other, Float f -> equal top other || (Fval.contains_zero f && contains_zero other) let narrow v1 v2 = match v1, v2 with | _, Set [||] | Set [||], _ -> bottom | Float _, Float _ | (Top _| Set _), (Top _ | Set _) -> meet v1 v2 (* meet is exact *) | v, (Top _ as t) when equal t top -> v | (Top _ as t), v when equal t top -> v | Float f, (Set _ as s) | (Set _ as s), Float f when is_zero s -> begin match Fval.narrow f Fval.zeros with | `Value f -> inject_float f | `Bottom -> bottom end | Float _, (Set _ | Top _) | (Set _ | Top _), Float _ -> (* ill-typed case. It is better to keep the operation symmetric *) top (* Given a set of elements that is an under-approximation, returns an ival (while maintaining the ival invariants that the "Set" constructor is used only for small sets of elements. *) let set_to_ival_under set = let card = Int.Set.cardinal set in if card <= !small_cardinal then (let a = Array.make card Int.zero in ignore(Int.Set.fold (fun elt i -> Array.set a i elt; i + 1) set 0); share_array a card) else (* If by chance the set is contiguous. *) if (Int.equal (Int.sub (Int.Set.max_elt set) (Int.Set.min_elt set)) (Int.of_int (card - 1))) then Top( Some(Int.Set.min_elt set), Some(Int.Set.max_elt set), Int.one, Int.zero) (* Else: arbitrarily drop some elements of the under approximation. *) else let a = Array.make !small_cardinal Int.zero in log_imprecision "Ival.set_to_ival_under"; try ignore(Int.Set.fold (fun elt i -> if i = !small_cardinal then raise Exit; Array.set a i elt; i + 1) set 0); assert false with Exit -> Set a ;; let link v1 v2 = match v1, v2 with | Set a1, Set a2 -> let s1 = Array.fold_right Int.Set.add a1 Int.Set.empty in let s2 = Array.fold_right Int.Set.add a2 s1 in set_to_ival_under s2 | Top(mn1,mx1,r1,m1), Top(mn2,mx2,r2,m2) -> if Int.equal r1 r2 && Int.equal m1 m2 then let min = match mn1,mn2 with | Some(a), Some(b) -> Some(Int.min a b) | _ -> None in let max = match mx1,mx2 with | Some(a), Some(b) -> Some(Int.max a b) | _ -> None in inject_top min max r1 m1 else v1 (* No best abstraction anyway. *) | Top(mn,mx,r,m), Set s | Set s, Top(mn,mx,r,m) -> let max = match mx with | None -> None | Some(max) -> let curmax = ref max in for i = 0 to (Array.length s) - 1 do let elt = s.(i) in if Int.equal elt (Int.add !curmax m) then curmax := elt done; Some(!curmax) in let min = match mn with | None -> None | Some(min) -> let curmin = ref min in for i = (Array.length s) - 1 downto 0 do let elt = s.(i) in if Int.equal elt (Int.sub !curmin m) then curmin := elt done; Some(!curmin) in inject_top min max r m | _ -> bottom ;; 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 mn1 mx1 r1 m1; check 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 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.make 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 (Fval.join f1 f2) | Float (f) as ff, other | other, (Float (f) as ff) -> if is_zero other then inject_float (Fval.join Fval.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 let fold_int 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_int_decrease 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:(Int.neg step) acc | Set s -> Array.fold_right (fun x acc -> f x acc) s acc let fold_enum f v acc = match v with | Float fl when Fval.is_singleton fl -> f v acc | Float _ -> raise Error_Top | Set _ | Top _ -> fold_int (fun x acc -> f (inject_singleton x) acc) v acc let fold_split ~split f v acc = match v with | Float (fl) when Fval.is_singleton fl -> f v acc | Float (fl) -> Fval.fold_split split (fun fl acc -> f (inject_float fl) acc) fl acc | Top(_,_,_,_) | Set _ -> fold_int (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 [||], Top _ -> true | Set s, Top(min, max, r, modu) -> (* Inclusion of bounds is needed for the entire inclusion *) min_le_elt min s.(0) && max_ge_elt max s.(Array.length s-1) && (Int.equal Int.one modu || (*Top side contains all integers, we're done*) array_for_all (fun x -> Int.equal (Int.pos_rem x modu) r) s) | Set s1, Set s2 -> array_subset s1 s2 | Float(f1), Float(f2) -> Fval.is_included f1 f2 | Float _, _ -> equal t2 top | _, Float (f) -> is_zero t1 && (Fval.contains_zero f) let join_and_is_included a b = let ab = join a b in (ab, equal a b) 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 (min_le_elt mi (Int.add e psize))) || (not (max_ge_elt ma (Int.sub e psize))) || ( 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 | _ -> top let apply_set_unary f v = match v with | Set s -> map_set_exnsafe f s | _ -> top let apply_bin_1_strict_incr f x (s : Integer.t array) = let l = Array.length s in let r = Array.make 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.make 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.make 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.make 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.make 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 add_singleton_int i v = match v with | Float _ -> assert false | Set s -> apply_bin_1_strict_incr Int.add i s | Top (mn, mx, r, m) -> let incr v = Int.add i v in let new_mn = opt1 incr mn in let new_mx = opt1 incr mx in let new_r = Int.pos_rem (incr r) m in share_top new_mn new_mx new_r m let rec add_int v1 v2 = match v1,v2 with | Float _, _ | _, Float _ -> assert false | 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 _ 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 *) add_singleton_int s.(0) t else add_int t (unsafe_make_top_from_array s) let add_int_under v1 v2 = match v1,v2 with | Float _, _ | _, Float _ -> assert false | Set [| x |], Set s | Set s, Set [| x |]-> apply_bin_1_strict_incr Int.add x s | Set s1, Set s2 -> let set = Array.fold_left (fun acc i1 -> Array.fold_left (fun acc i2 -> Int.Set.add (Int.add i1 i2) acc) acc s2) Int.Set.empty s1 in set_to_ival_under set | Top(min1,max1,r1,modu1) , Top(min2,max2,r2,modu2) when Int.equal modu1 modu2 -> (* Note: min1+min2 % modu = max1 + max2 % modu = r1 + r2 % modu; no need to trim the bounds here. *) let r = Int.rem (Int.add r1 r2) modu1 in let min = match min1, min2 with | Some min1, Some min2 -> Some (Int.add min1 min2) | _ -> None in let max = match max1, max2 with | Some max1, Some max2 -> Some (Int.add max1 max2) | _ -> None in inject_top min max r modu1 (* In many cases, there is no best abstraction; for instance when modu1 divides modu2, a part of the resulting interval is congruent to modu1, and a larger part is congruent to modu2. In general, one can take the intersection. In any case, this code should be rarely called. *) | Top _, Top _ -> bottom | 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: precise. *) add_singleton_int s.(0) t else begin log_imprecision "Ival.add_int_under"; (* Not worse than another computation. *) add_singleton_int s.(0) t end ;; let neg_int v = match v with | Float _ -> assert false | 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_int v1 v2 = add_int v1 (neg_int v2) let sub_int_under v1 v2 = add_int_under v1 (neg_int 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) | (Ninf | Pinf as x), Val v | Val v, (Ninf | Pinf as x) -> if Int.gt v Int.zero then x else if Int.lt v Int.zero then ext_neg x else 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 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 (* Rounds up (x+1) to the next power of two, then subtracts one; optimized. *) let next_pred_power_of_two x = (* Unroll the first iterations, and skip the tests. *) 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 x = Int.logor x (Int.shift_right x Int.four) in let x = Int.logor x (Int.shift_right x Int.eight) in let x = Int.logor x (Int.shift_right x Int.sixteen) in let shift = Int.thirtytwo in let rec loop old shift = let x = Int.logor old (Int.shift_right old shift) in if Int.equal old x then x else loop x (Int.shift_left shift Int.one) in loop x shift (* [different_bits min max] returns an overapproximation of 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. Note: the algorithm below is optimal for the problem as stated. It is possible to compute this optimal solution faster but it does not seem worth the time necessary to think about it as long as integers are at most 64-bit. *) 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; *) let fold_maxs max1 p f acc = let rec aux p acc = let p = Int.shift_right p Int.one in if Int.is_zero p then f max1 acc else if Int.is_zero (Int.logand p max1) then aux p acc else let c = Int.logor (Int.sub max1 p) (Int.pred p) in aux p (f c acc) in aux p acc in let sx1 = Int.succ x1 in let n1 = fold_maxs max1 sx1 (fun _ y -> succ y) 0 in let maxs1 = Array.make n1 sx1 in let _ = fold_maxs max1 sx1 (fun x i -> Array.set maxs1 i x; succ i) 0 in fold_maxs max2 (Int.succ x2) (fun max2 acc -> Array.fold_left (fun acc max1 -> Int.max (Int.logand max1 max2) acc) acc maxs1) (Int.logand max1 max2) let bitwise_or 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 | Set [|s|],(Top _ as v) | (Top _ as v),Set [|s|] when Int.is_zero s -> v | 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.max mn1 mn2 in (* Or can only add bits *) inject_range (Some new_min) (Some new_max) | _ -> 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.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_common ~pos f v degenerate_ival degenerate_float = 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 = let negative = max_is_greater (some_zero) mx1 in if (negative (* all negative *) || pos (* good div *) || (min_is_lower (some_zero) mn1) (* all positive *) || (Int.is_zero (Int.rem r1 f)) (* exact *) ) && (Int.is_zero (Int.rem m1 f)) then let modu = Int.abs (div_f m1) in let r = if negative then Int.sub r1 m1 else r1 in (Int.pos_rem (div_f r) modu), modu else (* degeneration*) degenerate_ival r1 m1 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 _ -> degenerate_float let scale_div ~pos f v = scale_div_common ~pos f v (fun _ _ -> Int.zero, Int.one) top ;; let scale_div_under ~pos f v = try (* TODO: a more precise result could be obtained by transforming Top(min,max,r,m) into Top(min,max,r/f,m/gcd(m,f)). But this is more complex to implement when pos or f is negative. *) scale_div_common ~pos f v (fun _r _m -> raise Exit) bottom with Exit -> bottom ;; 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) | _ -> log_imprecision "Ival.div_range"; 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 | Float _ -> assert false | Top (None, _, _, _) | Top (_, None, _, _) -> log_imprecision "Ival.div"; 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 div_f a = if pos then Int.pos_div a f else Int.c_div a f in (* See if [mn..mx] is included in [k*f..(k+1)*f] for some [k]. In this case, [%] is monotonic and [mn%f .. mx%f] is a more precise result. *) if Int.equal (div_f mn) (div_f mx) then rem_f mn, rem_f mx 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, _, _) -> min_le_elt mn Int.minus_one, max_ge_elt mx Int.one, (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 ~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.two_power_of_int (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.two_power_of_int 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 create_all_values ~signed ~size = if size <= !small_cardinal_log then (* We may need to create a set. Use slow path *) create_all_values_modu ~signed ~size ~modu:Int.one else if signed then let b = Int.two_power_of_int (size-1) in Top (Some (Int.neg b), Some (Int.pred b), Int.zero, Int.one) else let b = Int.two_power_of_int size in Top (Some Int.zero, Some (Int.pred b), Int.zero, Int.one) let big_int_64 = Int.of_int 64 let big_int_32 = Int.thirtytwo let cast ~size ~signed ~value = if equal top value then create_all_values ~size:(Int.to_int size) ~signed else let result = let factor = Int.two_power size in let mask = Int.two_power (Int.pred size) in let rem_f value = Int.cast ~size ~signed ~value in let not_p_factor = Int.neg 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 -> begin let all = create_all_values ~size:(Int.to_int size) ~signed in if is_included value all then value else map_set_exnsafe rem_f s end | Float f -> let low, high = if Int.equal size big_int_64 then let l, h = Fval.bits_of_float64 ~signed f in Some l, Some h else if Int.equal size big_int_32 then let l, h = Fval.bits_of_float32 ~signed f in Some l, Some h else None, None in inject_range low high in (* If sharing is no longer preserved, please change Cvalue.V.cast *) if equal result value then value else result let cast_float ~rounding_mode v = match v with | Float f -> ( try let b, f = Fval.round_to_single_precision_float ~rounding_mode f in b, inject_float f with Fval.Non_finite -> 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 mn1 mx1 r1 m1; check 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 (pgcd (mul m1 m2) (mul r1 m2)) (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 (** Computes [x (op) ({y >= 0} * 2^n)], as an auxiliary function for [shift_left] and [shift_right]. [op] and [scale] must verify [scale a b == op (inject_singleton a) b] *) let shift_aux scale op (x: t) (y: t) = let y = narrow (inject_range (Some Int.zero) None) y in try match y with | Set s -> Array.fold_left (fun acc n -> join acc (scale (Int.two_power n) x)) bottom s | _ -> let min_factor = Extlib.opt_map Int.two_power (min_int y) in let max_factor = Extlib.opt_map Int.two_power (max_int y) in let modu = match min_factor with None -> Int.one | Some m -> m in let factor = inject_top min_factor max_factor Int.zero modu in op x factor with Integer.Too_big -> Lattice_messages.emit_imprecision emitter "Ival.shift_aux"; (* We only preserve the sign of the result *) if is_included x positive_integers then positive_integers else if is_included x negative_integers then negative_integers else top let shift_right x y = shift_aux (scale_div ~pos:true) div x y let shift_left x y = shift_aux scale mul x y let interp_boolean ~contains_zero ~contains_non_zero = match contains_zero, contains_non_zero with | true, true -> zero_or_one | true, false -> zero | false, true -> one | false, false -> bottom module Infty = struct let lt0 = function | None -> true | Some a -> Int.lt a Int.zero let div a b = match a with | None -> None | Some a -> match b with | None -> Some Int.zero | Some b -> Some (Int.div a b) let neg = function | Some a -> Some (Int.neg a) | None -> None end let backward_mult_pos_left min_right max_right result = let min_res, max_res = min_and_max result in let min_left = Infty.div min_res (if Infty.lt0 min_res then Some min_right else max_right) and max_left = Infty.div max_res (if Infty.lt0 max_res then max_right else Some min_right) in inject_range min_left max_left let backward_mult_neg_left min_right max_right result = backward_mult_pos_left (Integer.neg max_right) (Infty.neg min_right) (neg_int result) let backward_mult_int_left ~right ~result = match min_and_max right with | None, None -> `Value None | Some a, Some b when a > b -> `Bottom | Some a, Some b when a = Int.zero && b = Int.zero -> if contains_zero result then `Value None else `Bottom | Some a, max when a > Int.zero -> `Value (Some (backward_mult_pos_left a max result)) | Some a, max when a >= Int.zero -> if contains_zero result then `Value None else `Value (Some (backward_mult_pos_left Int.one max result)) | min, Some b when b < Int.zero -> `Value (Some (backward_mult_neg_left min b result)) | min, Some b when b = Int.zero -> if contains_zero result then `Value None else `Value (Some (backward_mult_neg_left min Int.minus_one result)) | min, max -> if contains_zero result then `Value None else `Value (Some (join (backward_mult_pos_left Int.one max result) (backward_mult_neg_left min Int.one result))) let backward_le_int max v = match v with | Float _ -> v | Set _ | Top _ -> narrow v (Top(None,max,Int.zero,Int.one)) let backward_ge_int min v = match v with | Float _ -> v | Set _ | Top _ -> narrow v (Top(min,None,Int.zero,Int.one)) let backward_lt_int max v = backward_le_int (opt1 Int.pred max) v let backward_gt_int min v = backward_ge_int (opt1 Int.succ min) v 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 diff value rem = log_imprecision "Ival.diff"; diff_if_one value rem let backward_comp_int_left op l r = let open Comp in try match op with | Le -> backward_le_int (max_int r) l | Ge -> backward_ge_int (min_int r) l | Lt -> backward_lt_int (max_int r) l | Gt -> backward_gt_int (min_int r) l | Eq -> narrow l r | Ne -> diff_if_one l r with Error_Bottom (* raised by max_int *) -> bottom let backward_comp_float_left op allmodes fkind f1 f2 = try let f1 = project_float f1 in let f2 = project_float f2 in begin match Fval.backward_comp_left op allmodes fkind f1 f2 with | `Value f -> inject_float f | `Bottom -> bottom end with | Nan_or_infinite (* raised by project_float *) -> f1 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 -> begin let l, u = if Int.equal size big_int_64 then let l, u = Fval.bits_of_float64 ~signed:true f in Some l, Some u else if Int.equal size big_int_32 then let l, u = Fval.bits_of_float32 ~signed:true f in Some l, Some u else (* long double *) None, None in extract_bits ~start ~stop ~size (inject_range l u) end | Top(_,_,_,_) as d -> try let dived = scale_div ~pos:true (Int.two_power start) d in scale_rem ~pos:true (Int.two_power (Int.length start stop)) dived with Integer.Too_big -> Lattice_messages.emit_imprecision emitter "Ival.extract_bits"; top ;; let all_values ~size v = if Int.lt big_int_64 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.two_power size) (Int.length mn mx) | 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) 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 forward_le_int i1 i2 = if compare_max_min (max_int i1) (min_int i2) <= 0 then Comp.True else if compare_min_max (min_int i1) (max_int i2) > 0 then Comp.False else Comp.Unknown let forward_lt_int i1 i2 = if compare_max_min (max_int i1) (min_int i2) < 0 then Comp.True else if compare_min_max (min_int i1) (max_int i2) >= 0 then Comp.False else Comp.Unknown let forward_eq_int i1 i2 = if cardinal_zero_or_one i1 && equal i1 i2 then Comp.True else if intersects i2 i2 then Comp.Unknown else Comp.False let forward_comp_int op i1 i2 = let open Abstract_interp.Comp in match op with | Le -> forward_le_int i1 i2 | Ge -> forward_le_int i2 i1 | Lt -> forward_lt_int i1 i2 | Gt -> forward_lt_int i2 i1 | Eq -> forward_eq_int i1 i2 | Ne -> inv_result (forward_eq_int i1 i2) include ( Datatype.Make_with_collections (struct type ival = t type t = ival let name = Int.name ^ " lattice_mod" open Structural_descr let structural_descr = let s_int = Descr.str Int.descr in t_sum [| [| pack (t_array s_int) |]; [| Fval.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): Datatype.S_with_collections with type t := t) let scale_int_base factor v = match factor with | Int_Base.Top -> top | Int_Base.Value f -> scale f v type overflow_float_to_int = | FtI_Ok of Int.t (* Value in range *) | FtI_Overflow of Floating_point.sign (* Overflow in the corresponding direction *) let cast_float_to_int ~signed ~size iv = let all = create_all_values ~size ~signed in let min_all = Extlib.the (min_int all) in let max_all = Extlib.the (max_int all) in try let min, max = Fval.min_and_max (project_float iv) in let conv f = try (* truncate_to_integer returns an integer that fits in a 64 bits integer, but might not fit in [size, sized] *) let i = Floating_point.truncate_to_integer f in if Int.ge i min_all then if Int.le i max_all then FtI_Ok i else FtI_Overflow Floating_point.Pos else FtI_Overflow Floating_point.Neg with Floating_point.Float_Non_representable_as_Int64 sign -> FtI_Overflow sign in let min_int = conv (Fval.F.to_float min) in let max_int = conv (Fval.F.to_float max) in match min_int, max_int with | FtI_Ok min_int, FtI_Ok max_int -> (* no overflow *) false, (false, false), inject_range (Some min_int) (Some max_int) | FtI_Overflow Floating_point.Neg, FtI_Ok max_int -> (* one overflow *) false, (true, false), inject_range (Some min_all) (Some max_int) | FtI_Ok min_int, FtI_Overflow Floating_point.Pos -> (* one overflow *) false, (false, true), inject_range (Some min_int) (Some max_all) (* two overflows *) | FtI_Overflow Floating_point.Neg, FtI_Overflow Floating_point.Pos -> false, (true, true), inject_range (Some min_all) (Some max_all) (* Completely out of range *) | FtI_Overflow Floating_point.Pos, FtI_Overflow Floating_point.Pos -> false, (false, true), bottom | FtI_Overflow Floating_point.Neg, FtI_Overflow Floating_point.Neg -> false, (true, false), bottom | FtI_Overflow Floating_point.Pos, FtI_Overflow Floating_point.Neg | FtI_Overflow Floating_point.Pos, FtI_Ok _ | FtI_Ok _, FtI_Overflow Floating_point.Neg -> assert false (* impossible if min-max are correct *) with | Nan_or_infinite -> (* raised by project_float *) true, (true, true), all (* These are the bounds of the range of integers that can be represented exactly as 64 bits double values *) let double_min_exact_integer = Int.neg (Int.two_power_of_int 53) let double_max_exact_integer = Int.two_power_of_int 53 (* same with 32 bits single values *) let single_min_exact_integer = Int.neg (Int.two_power_of_int 24) let single_max_exact_integer = Int.two_power_of_int 24 (* Same values expressed as double *) let double_min_exact_integer_d = -. (2. ** 53.) let double_max_exact_integer_d = 2. ** 53. let single_min_exact_integer_d = -. (2. ** 24.) let single_max_exact_integer_d = 2. ** 24. (* finds all floating-point values [f] such that casting [f] to an integer type returns [i]. *) let cast_float_to_int_inverse ~single_precision i = let exact_min, exact_max = if single_precision then single_min_exact_integer, single_max_exact_integer else double_min_exact_integer, double_max_exact_integer in match min_and_max i with | Some min, Some max when Int.lt exact_min min && Int.lt max exact_max -> let minf = if Int.le min Int.zero then (* min is negative. We want to return [(float)((real)(min-1)+epsilon)], as converting this number to int will truncate all the fractional part (C99 6.3.1.4). Given [exact_min] and [exact_max], 1ulp is at most 1 here, so adding 1ulp will at most cancel the -1. Hence, we can use [next_float]. *) (* This float is finite because min is small enough *) let r = Fval.F.next_float (Int.to_float (Int.pred min)) in if single_precision then begin (* Single precision: round towards 0 (hence up) to minimize the range of the value returned. *) Floating_point.set_round_upward (); let r = Floating_point.round_to_single_precision_float r in Floating_point.set_round_nearest_even (); r; end else r else (* min is positive. Since casting truncates towards 0, [(int)((real)min-epsilon)] would return [min-1]. Hence, we can simply return the float corresponding to [min] -- which can be represented precisely given [exact_min] and [exact_max]. *) Int.to_float min in (* All operations are dual w.r.t. the min bound. *) let maxf = if Int.le Int.zero max then (* This float is finite because max is big enough *) let r = Fval.F.prev_float (Int.to_float (Int.succ max)) in if single_precision then begin Floating_point.set_round_downward (); let r = Floating_point.round_to_single_precision_float r in Floating_point.set_round_nearest_even (); r; end else r else Int.to_float max in Float (Fval.inject (Fval.F.of_float minf) (Fval.F.of_float maxf)) | _ -> if single_precision then top_single_precision_float else top_float let cast_int_to_float_inverse ~single_precision f = (* We restrict ourselves to f \in [exact_min, exact_max]. Outside of this range, the conversion int -> float is not exact, and the operation is more involved. *) let exact_min, exact_max = if single_precision then single_min_exact_integer_d, single_max_exact_integer_d else double_min_exact_integer_d, double_max_exact_integer_d in (* We find the integer range included in [f] *) let min, max = min_and_max_float f in let min = Fval.F.to_float min in let max = Fval.F.to_float max in if exact_min <= min && max <= exact_max then (* Round to integers in the proper direction: discard the non-floating-point values on each extremity. *) let min = ceil min in let max = floor max in let conv f = try Some (Integer.of_float f) with Integer.Too_big -> None in let r = inject_range (conv min) (conv max) in (* Kernel.result "Cast I->F inv: %a -> %a@." pretty f pretty r; *) r else top (* Approximate *) let of_int i = inject_singleton (Int.of_int i) let of_int64 i = inject_singleton (Int.of_int64 i) (* This function always succeeds without alarms for C integers, because they always fit within a float32. *) 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 -> Floating_point.set_round_nearest_even (); (* PC: Do not even ask *) let b = Int.to_float min in let e = Int.to_float max in (* Note that conversion from integer to float in modes other than round-to-nearest is unavailable when using Big_int and Linux because 1- Big_int implements the conversion to float with a conversion from the integer to a decimal representation (!) followed by strtod() 2- Linux does not honor the FPU direction flag in strtod(), as it arguably should http://stackoverflow.com/a/2595848/139746 *) let b', e' = if rounding_mode = Fval.Nearest_Even || (Int.le double_min_exact_integer min && Int.le max double_max_exact_integer) then b, e else Fval.F.prev_float b, Fval.F.next_float e in let ok, f = Fval.inject_r (Fval.F.of_float b') (Fval.F.of_float e') in not ok, inject_float f exception Unforceable let force_float kind i = match i with | Float _ -> false, i | Set _ when is_zero i -> false, i | Set _ when is_bottom i -> true, i | Top _ | Set _ -> (* Convert a range of integers to a range of floats. Float are ordered this way : if [min_i], [max_i] are the bounds of the signed integer type that has the same number of bits as the floating point type, and [min_f] [max_f] are the integer representation of the most negative and most positive finite float of the type, and < is signed integer comparison, we have: min_i < min_f < min_f+1 < -1 < 0 < max_f < max_f+1 < max_i | | | | | | | | --finite-- -not finite- -finite- -not finite- | | |<---------> | | |<---------> -0. -max +inf NaNs +0. max +inf NaNs The float are of the same sign as the integer they convert into. Furthermore, the conversion function is increasing on the positive interval, and decreasing on the negative one. *) let reinterpret size conv min_f max_f = let i = cast ~size:(Integer.of_int size) ~signed:true ~value:i in match min_and_max i with | Some mn, Some mx -> let range mn mx = let red, fa = Fval.inject_r mn mx in assert (not red); inject_float fa in if Int.le Int.zero mn && Int.le mx max_f then range (conv mn) (conv mx) else if Int.le mx min_f then range (conv mx) (conv mn) else begin match i with | Set a -> let s = ref F_Set.empty in for i = 0 to Array.length a - 1 do if Int.((le zero a.(i) && le a.(i) max_f) || le a.(i) min_f) then s := F_Set.add (conv a.(i)) !s (* Not NaN *) else raise Unforceable done; (* cannot fail, [i] is not bottom, hence [a] is not empty *) let mn, mx = F_Set.min_elt !s, F_Set.max_elt !s in range mn mx | _ -> raise Unforceable end | _, _ -> raise Unforceable in let open Floating_point in match kind with | Cil_types.FDouble -> begin let conv v = Fval.F.of_float (Int64.float_of_bits (Int.to_int64 v)) in try false, reinterpret 64 conv bits_of_most_negative_double bits_of_max_double with Unforceable -> true, top_float end | Cil_types.FFloat -> begin let conv v = Fval.F.of_float (Int32.float_of_bits (Int64.to_int32 (Int.to_int64 v))) in try false, reinterpret 32 conv bits_of_most_negative_float bits_of_max_float with Unforceable -> true, top_single_precision_float end | Cil_types.FLongDouble -> true, 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_intervals ~size ~signed v1 v2 = 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 half_range = Int.two_power_of_int (pred size) in let minint = Int.neg half_range 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 strictly_negative_integers in let somenegativev2 = intersects v2 strictly_negative_integers 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 vmin, vmax (* [common_low_bits v] returns the common pattern between the least-significant bits of all the elements of the Ival [v]. The pattern is in the form [lower_bits, mask] where [mask] indicates the consecutive least significant bits that are common between all elements, and [lower_bits] indicates their values. *) let common_low_bits v = match v with | Float _ -> assert false | Top(_,_,r,m) -> if Int.is_zero (Int.logand m (Int.pred m)) then (* m is a power of two *) r, Int.pred m else Int.zero, Int.zero (* TODO *) | Set [| v |] -> v, next_pred_power_of_two v | Set _ -> Int.zero, Int.zero (* TODO *) let bitwise_and ~size ~signed v1 v2 = if is_bottom v1 || is_bottom v2 then bottom else match v1, v2 with | Float _, _ | _, Float _ -> assert false | Set s1, Set s2 -> apply2_v Int.logand s1 s2 | Top _, other | other, Top _ -> let min, max = bitwise_and_intervals ~signed ~size v1 v2 in let lower_bits1, mask1 = common_low_bits v1 in let lower_bits2, mask2 = common_low_bits v2 in let mask = Int.logand mask1 mask2 in let modu = Int.succ mask in let r = Int.logand lower_bits1 (Int.logand lower_bits2 mask) in let min = match min with | Some min -> Some (Int.round_up_to_r ~min ~r ~modu) | _ -> min in let max = match max with | Some max -> Some (Int.round_down_to_r ~max ~r ~modu) | _ -> max in let result = inject_top min max r modu 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) let bitwise_not v = (* the result is [-v - 1] *) match v with | Float _ -> assert false | Top _ -> add_int (neg_int v) minus_one | Set s -> map_set_strict_decr Int.lognot s let bitwise_not_size ~size ~signed v = let nv = bitwise_not v in if not signed then cast ~size:(Integer.of_int size) ~signed ~value:nv else nv (* always fits in the type if the argument fitted. *) let pretty_debug = pretty let name = "ival" (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/tr_offset.mli0000644000175000017500000000746713113745006026241 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 and a size) by a base validity. Only the locations in the trimmed result are valid. *) type t = private | Invalid (** No location is valid *) | Set of Integer.t list (** Limited number of locations *) | Interval of (** min *) Integer.t * (** max *) Integer.t * (** modu *)Integer.t | Overlap of (** min *) Integer.t * (** max *) Integer.t * Origin.t (** The location covers the entire range [min..max], but consecutive offsets overlap *) val pretty: t Pretty_utils.formatter (** [trim_by_validity ?origin offsets size validity] reduces [offsets] so that all accesses to [offsets+(0..size-1)] are valid according to [validity]. The returned boolean indicates that at least one of the offsets does not comply with [validity]. If the valid offsets cannot be represented precisely, the [Imprecise] constructor is returned. When specified, the [origin] argument is used as the source of this imprecision . *) val trim_by_validity : ?origin:Origin.t -> Ival.t -> Integer.t -> Base.validity -> bool (** alarm *) * t (** This is a more complete specification of this function, for a single offset [o]. We want to write [size>0 bits], on a base possibly valid between [min_valid..max_maybe_valid], and guaranteed to be valid between [min_valid..max_sure_valid]. The case [max_sure_valid < min_valid] is possible: in this case, no bit is guaranteed to be valid. For Valid and non-Empty bases, [min_valid max_maybe_valid] - If [start_to..stop_to] is not included in [min_valid..max_sure_valid], then we must emit an alarm. This translates to [start_to max_sure_valid]. This convention works even when [min_valid..max_sure_valid] is not a real interval. *) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/offsetmap.mli0000644000175000017500000000520013113745012026206 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. *) (** Maps from intervals to values. The documentation of the returned maps is in module {!Offsetmap_sig}. *) module Make (V : module type of Offsetmap_lattice_with_isotropy) : module type of Offsetmap_sig with type v = V.t and type widen_hint = V.generic_widen_hint (**/**) (* Exported as Int_Intervals, do not use this module directly *) module Int_Intervals: module type of Int_Intervals_sig (**/**) (** Maps from intervals to simple values. The documentation of the returned maps is in module {!Offsetmap_bitwise_sig}. *) module Make_bitwise(V: sig include Lattice_type.Bounded_Join_Semi_Lattice include Lattice_type.With_Narrow with type t := t include Lattice_type.With_Top with type t := t end) : module type of Offsetmap_bitwise_sig with type v = V.t and type intervals = Int_Intervals.t (**/**) (* This is automatically set by the Value plugin. Do not modify. *) val set_plevel: int -> unit val get_plevel: unit -> int (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/lattice_messages.mli0000644000175000017500000000457013113745011027546 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** Message and logging facility for abstract lattices. *) type t = | Approximation of string (** Abstract transfer function that intentionally approximates its result *) | Imprecision of string (** Abstract transfer function not fully implemented *) | Costly of string (** Abstract operation will be costly *) | Unsoundness of string (** Unsound abstract operation *) type emitter (** Register a new emitter for a message. *) val register: string -> emitter;; (** Emit a message. *) val emit: emitter -> t -> unit val emit_imprecision: emitter -> string -> unit val emit_approximation: emitter -> ('a, Format.formatter, unit) format -> 'a val emit_costly: emitter -> ('a, Format.formatter, unit) format -> 'a (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/tr_offset.ml0000644000175000017500000001143713113745010026053 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 t = | Invalid | Set of Int.t list | Interval of Int.t * Int.t * Int.t | Overlap of Int.t * Int.t * Origin.t let pretty fmt = function | Invalid -> Format.fprintf fmt "Invalid" | Set l -> Format.fprintf fmt "Set [%a]" (Pretty_utils.pp_list ~sep:",@ " Int.pretty) l | Interval (mn, mx, modu) -> Format.fprintf fmt "Interval (%a,%a,%a)" Int.pretty mn Int.pretty mx Int.pretty modu | Overlap (mn, mx, o) -> Format.fprintf fmt "Overlap (%a,%a,%a)" Int.pretty mn Int.pretty mx Origin.pretty o (* Returns (alarm, reduced_ival)] *) let trim_by_validity ?(origin=Origin.Unknown) ival size validity = let pred_size = Int.pred size in (* reduce [ival] so that all accesses fit within [min_valid] and [max_maybe_valid]; uses [opt_max_sure_valid] to generate alarms *) let reduce_for_bounds min_valid opt_max_sure_valid max_maybe_valid = let max_in_bound = Int.sub max_maybe_valid pred_size in let is_in_bound mn mx r modu = let alarm_min, new_mn = match mn with | Some mn when (Int.ge mn min_valid) -> false, mn | _ -> true, Int.round_up_to_r ~r ~modu ~min:min_valid in let alarm_min_or_max, new_mx = match mx with | Some mx when (Int.le mx max_in_bound) -> let alarm_max = match opt_max_sure_valid with | None -> true (* all accesses are possibly invalid *) | Some max_sure_valid -> Int.gt mx (Int.sub max_sure_valid pred_size) in alarm_min || alarm_max, 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.equal new_mn new_mx then Set [new_mn] (* No need to compare [size] and [modu] in this case *) else if Int.lt modu size then Overlap(new_mn, Int.add new_mx pred_size, origin) else Interval(new_mn, new_mx, modu) end else Invalid in alarm_min_or_max, itv_or_set in begin match ival with | Ival.Float _ -> assert false | Ival.Top (mn,mx,r,m) -> is_in_bound mn mx r m | Ival.Set s -> let alarm, set = Array.fold_right (fun offset (alarm_acc, reduced_acc) -> let sOffset = Some offset in let alarm, reduced = is_in_bound sOffset sOffset Int.zero Int.one in alarm || alarm_acc, if reduced != Invalid then offset :: reduced_acc else reduced_acc) s (false, []) in if set = [] then (alarm, Invalid) else (alarm, Set set) end in match validity with | Base.Invalid -> true, Invalid | Base.Empty -> let valid_access = Int.(equal size zero) && Ival.(equal ival zero) in not valid_access, Set [] | Base.Known (min, max) -> reduce_for_bounds min (Some max) max | Base.Unknown (min, sure, max) -> reduce_for_bounds min sure max | Base.Variable variable_v -> reduce_for_bounds Int.zero (Some variable_v.Base.min_alloc) variable_v.Base.max_alloc (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/int_Base.mli0000644000175000017500000000405213113745013025753 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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-Phosphorus-20170501/src/kernel_services/abstract_interp/lmap_bitwise.ml0000644000175000017500000003304613113745011026540 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 exception Bitwise_cannot_copy module type Location_map_bitwise = sig type v type map type lmap = Top | Map of map | Bottom include Datatype.S with type t = lmap include Lattice_type.Bounded_Join_Semi_Lattice with type t := t include Lattice_type.With_Top with type t := t module LOffset : module type of Offsetmap_bitwise_sig with type v = v and type intervals = Int_Intervals.t val is_empty : t -> bool val is_bottom : t -> bool val empty : t val empty_map: map val pretty_generic_printer: ?pretty_v: v Pretty_utils.formatter -> ?skip_v: (v -> bool) -> sep:string -> unit -> t Pretty_utils.formatter val pretty_debug: t Pretty_utils.formatter val add_binding : exact:bool -> t -> Zone.t -> v -> t val add_binding_loc: exact:bool -> t -> location -> v -> t val add_base: Base.t -> LOffset.t -> t -> t val remove_base: Base.t -> t -> t val find : t -> Zone.t -> v val filter_base : (Base.t -> bool) -> t -> t val map: (v -> v) -> t -> t val fold : (Zone.t -> v -> 'a -> 'a) -> map -> 'a -> 'a val fold_base : (Base.t -> LOffset.t -> 'a -> 'a) -> map -> 'a -> 'a val fold_fuse_same : (Zone.t -> v -> 'a -> 'a) -> map -> 'a -> 'a val fold_join_zone: both:(Int_Intervals.t -> LOffset.t -> 'a) -> conv:(Base.t -> 'a -> 'b) -> empty_map:(Locations.Zone.t -> 'b) -> join:('b -> 'b -> 'b) -> empty:'b -> Locations.Zone.t -> map -> 'b val map2: cache:Hptmap_sig.cache_type -> symmetric:bool -> idempotent:bool -> empty_neutral:bool -> (LOffset.t -> LOffset.t -> LOffset.map2_decide) -> (v -> v -> v) -> map -> map -> map val shape: map -> LOffset.t Hptmap.Shape(Base.Base).t val imprecise_write_msg: string ref val clear_caches: unit -> unit end module type With_default = sig include Lattice_type.Bounded_Join_Semi_Lattice include Lattice_type.With_Top with type t := t include Lattice_type.With_Narrow with type t := t val default: t end module Make_bitwise (V: With_default): Location_map_bitwise with type v = V.t = struct module LOffset = struct include Offsetmap.Make_bitwise(V) let copy = Datatype.undefined end exception Invalid_base (* validity must not be invalid; otherwise, Invalid_base is raised. *) let default_offsetmap_aux b validity = let size_or_bottom = LOffset.size_from_validity validity in let default () = match size_or_bottom with | `Bottom -> raise Invalid_base | `Value size -> LOffset.create ~size V.default in if Base.equal Base.null b then match validity with | Base.Invalid -> raise Invalid_base | Base.Known (ib, ie) -> if Integer.is_zero ib then default () else begin (* NULL is special, because the validity may not start at 0. We must bind the beginning of the interval to bottom. *) assert (Integer.gt ib Integer.zero); let size = Bottom.non_bottom size_or_bottom in let to_bottom = LOffset.create ~size V.bottom in let range = Int_Intervals.inject_bounds ib ie in match LOffset.add_binding_intervals ~validity ~exact:true range V.default to_bottom with | `Bottom -> assert false | `Value m -> m end | Base.Unknown _ | Base.Empty | Base.Variable _ -> assert false else default () let default_offsetmap b = default_offsetmap_aux b (Base.validity b) module LBase = struct include Hptmap.Make(Base.Base)(LOffset)(Hptmap.Comp_unused)(struct let v = [[]] end)(struct let l = [ Ast.self ] end) let () = Ast.add_monotonic_state self (* We override [add] so that the map is canonical: no key should be bound to its default value. *) let add b offsm m = let is_default = if Base.is_null b then (* If we are binding something to NULL, NULL should not be invalid *) let default = default_offsetmap Base.null in LOffset.equal default offsm else LOffset.is_same_value offsm V.default in if is_default then remove b m else add b offsm m end let clear_caches () = LBase.clear_caches (); LOffset.clear_caches (); ;; type map = LBase.t let imprecise_write_msg = LOffset.imprecise_write_msg let find_or_default b m = try LBase.find b m with Not_found -> default_offsetmap b type lmap = Top | Map of LBase.t | Bottom type v = V.t let empty_map = LBase.empty let empty = Map LBase.empty let bottom = Bottom 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 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 _) | Map _, Top -> -1 | Top, (Bottom | Map _) | Map _, Bottom -> 1 let is_empty x = equal empty x let is_bottom x = x = Bottom let top = Top let pretty_generic_printer ?pretty_v ?skip_v ~sep () fmt m = match m with | Top -> Format.fprintf fmt "@[%sTOP@]" sep | Bottom -> Format.fprintf fmt "@[%sUNREACHABLE@]" sep | Map m -> let pp_one fmt (base, offs) = Format.fprintf fmt "@[%a@[%a@]@]" Base.pretty base (LOffset.pretty_generic ?typ:(Base.typeof base) ?pretty_v ?skip_v ~sep ()) offs in Pretty_utils.pp_iter ~pre:"@[" ~sep:"@ " ~suf:"@]" (Extlib.iter_uncurry2 LBase.iter) pp_one fmt m let pretty = pretty_generic_printer ~sep:"FROM" () let pretty_debug fmt m = match m with | Top | Bottom -> pretty fmt m | Map m -> LBase.pretty_debug fmt m include Datatype.Make (struct type t = lmap let reprs = Top :: List.map (fun b -> Map b) LBase.reprs let structural_descr = Structural_descr.t_sum [| [| LBase.packed_descr |] |] let name = LOffset.name ^ " lmap_bitwise" let hash = hash let equal = equal 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 fold f m acc = 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 = 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 = let aux_base_offset base offs m = let validity = Base.validity base in try let offsm = find_or_default base m in match LOffset.add_binding_intervals ~validity ~exact offs v offsm with | `Bottom -> m | `Value new_offsetmap -> LBase.add base new_offsetmap m with Invalid_base -> m in match loc, m with | Zone.Top (Base.SetLattice.Top, _),_|_,Top -> Top | _, Bottom -> Bottom | _, Map m -> Map (Zone.fold_topset_ok aux_base_offset loc m) let add_binding_loc ~exact m loc v = let aux_base_offset base offs m = let validity = Base.validity base in try let offsm = find_or_default base m in let new_offsetmap = LOffset.add_binding_ival ~validity ~exact offs ~size:loc.size v offsm in match new_offsetmap with | `Bottom -> m | `Value new_offsetmap -> LBase.add base new_offsetmap m with Invalid_base -> m in match loc.loc, m with | Location_Bits.Top (Base.SetLattice.Top, _),_|_,Top -> Top | _, Bottom -> Bottom | _, Map m -> Map (Location_Bits.fold_topset_ok aux_base_offset loc.loc m) let add_base b offsm = function | Bottom | Top as m -> m | Map m -> Map (LBase.add b offsm m) let remove_base b = function | Bottom | Top as m -> m | Map m -> Map (LBase.remove b m) let join_on_map = (* [join t Empty] is [t] if unbound bases are bound to [bottom] by default*) if V.(equal default bottom) then LBase.join ~cache:(Hptmap_sig.PersistentCache "lmap_bitwise.join") ~decide:(fun _ v1 v2 -> LOffset.join v1 v2) ~symmetric:true ~idempotent:true else let decide = let get b = function Some v -> v | None -> default_offsetmap b in fun b v1 v2 -> LOffset.join (get b v1) (get b v2) in LBase.generic_join ~cache:(Hptmap_sig.PersistentCache "lmap_bitwise.join") ~symmetric:true ~idempotent:true ~decide let join m1 m2 = let result = match m1, m2 with | Top, _ | _, Top -> Top | Bottom, m | m, Bottom -> m | Map m1, Map m2 -> Map (join_on_map m1 m2) in (*Format.printf "JoinBitWise: m1=%a@\nm2=%a@\nRESULT=%a@\n" pretty m1 pretty m2 pretty result;*) result let map f = function | Top -> Top | Bottom -> Bottom | Map m -> Map (LBase.map (fun m -> LOffset.map f m) m) let map2 ~cache ~symmetric ~idempotent ~empty_neutral fv f = let aux = LOffset.map2 cache fv f in let decide b om1 om2 = match om1, om2 with | None, None -> assert false (* decide is never called in this case *) | Some m1, None -> aux m1 (default_offsetmap b) | None, Some m2 -> aux (default_offsetmap b) m2 | Some m1, Some m2 -> aux m1 m2 in if empty_neutral then LBase.join ~symmetric ~idempotent ~cache ~decide:(fun _ m1 m2 -> aux m1 m2) else LBase.generic_join ~symmetric ~idempotent ~cache ~decide let is_included_map = let name = Format.asprintf "Lmap_bitwise(%s).is_included" V.name in let decide_fst b offs1 = LOffset.is_included offs1 (default_offsetmap b) in let decide_snd b offs2 = LOffset.is_included (default_offsetmap b) offs2 in let decide_both _ offs1 offs2 = LOffset.is_included offs1 offs2 in LBase.binary_predicate (Hptmap_sig.PersistentCache name) LBase.UniversalPredicate ~decide_fast:LBase.decide_fast_inclusion ~decide_fst ~decide_snd ~decide_both let is_included m1 m2 = match m1, m2 with | _, Top -> true | Top ,_ -> false | Bottom, _ -> true | _, Bottom -> false | Map m1, Map m2 -> is_included_map m1 m2 let join_and_is_included m1 m2 = match (m1,m2) with | _, Top -> (Top, true) | Top, _ -> (Top, false) | Bottom, m2 -> (m2, true) | m1, Bottom -> (m1, false) | Map mm1, Map mm2 -> let m = join_on_map mm1 mm2 in if LBase.equal m mm2 then m2, true else Map m, false 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 find m loc = match loc, m with | Zone.Top _, _ | _, Top -> V.top | _, Bottom -> V.bottom | Zone.Map _, Map m -> let treat_offset base itvs acc = let validity = Base.validity base in if validity = Base.Invalid then acc else let offsetmap = find_or_default base m in let v = LOffset.find_iset ~validity itvs offsetmap in V.join acc v in Zone.fold_i treat_offset loc V.bottom let fold_join_zone ~both ~conv ~empty_map ~join ~empty = let cache = Hptmap_sig.PersistentCache "Lmap_bitwise.fold_on_zone" in let empty_left _ = empty (* zone over which to fold is empty *) in let empty_right z = empty_map z in let both b itvs map_b = conv b (both itvs map_b) in let fmap = Zone.fold2_join_heterogeneous ~cache ~empty_left ~empty_right ~both ~join ~empty in fun z m -> fmap z (LBase.shape m) let shape = LBase.shape end (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_services/abstract_interp/offsetmap.ml0000644000175000017500000034047213113745012026052 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 (*let dkey_caches = Kernel.register_category "offsetmap:caches"*) let msg_emitter = Lattice_messages.register "Offsetmap" (** Offsetmaps are unbalanced trees that map intervals to values, with the additional properties that the shape of the tree is entirely determined by the intervals that are mapped. The intervals are contiguous (offsetmaps cannot contain holes), and sorted from left to right in the tree. In this file, offsetmaps are represented in a relative way to maximise sharing. An offsetmap alone does not "know" which intervals it represents. When iterating on it, it is necessary to maintain a *current offset*, which is the lower index of the interval at the top of the tree. ( *Not* of the leftmost interval, which is the smallest binding.) *) type 'a offsetmap = | Empty | Node of Integer.t * (** Relative, upper index of the interval. Thus the interval has length [max+1]. The relative lower index of the interval is always zero by definition. *) Integer.t * 'a offsetmap * (** subtree on the left: the offset [offl] of its root (relative to 0), and the tree [subl]. If [subl] is not empty, it maps at least one interval, and [offl] is strictly negative. If [subl] is empty, then [offl] is zero. *) Integer.t * 'a offsetmap (** subtree on the right: the offset [offr] of its root (relative to 0), and the tree [subr]. [offr] is greater than [max+1] by definition, and equal to it if [subr] is empty. ([offr] may also be equal to [max+1] with a non-empty [subr], when the interval at the root of [subr] starts exactly at [max+1].) *) * Rel.t * Integer.t * 'a (** rem * size * value, ie. the value, its size [size] and its alignment [rem] relative to the start of the interval. [size] can be: - strictly more than [max+1], in which case the value is truncated - equal to [max+1]: * if [rem] is zero, the value is stored exactly once in the interval * otherwise, two truncated instances of the value are stored consecutively. - strictly less than [max+1]: the value is stored more than once, and implicitly repeats itself to fill the entire interval. *) * int (** tag: hash-consing id of the node, plus an additional boolean. Not related to the contents of the tree. *) (** plevel-related operation: value + hooks to call when the value is modified*) let plevel = ref 200 let plevel_hook = ref [] let set_plevel i = List.iter (fun f -> f ()) !plevel_hook; plevel := i let add_plevel_hook f = plevel_hook := f :: !plevel_hook let get_plevel () = !plevel let debug = false module Make (V : module type of Offsetmap_lattice_with_isotropy) = struct open Format type v = V.t type widen_hint = V.generic_widen_hint type alarm = bool let empty = Empty (** All high-level functions of this module must handle a size of 0, in which case it is sometimes necessary to return Empty. In the current implementation, sizes 0 are handled by the outer (exported) functions, while the inner functions assume that the arguments [size] are strictly positive. *) let equal (t1:V.t offsetmap) (t2:V.t offsetmap) = 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 (* Does not depend on keys. Exported here for convenience for the users *) let size_from_validity = function | Base.Invalid -> `Bottom | Base.Empty -> `Value Int.zero | Base.Known (_, m) | Base.Unknown (_, _, m) -> `Value (Int.succ m) | Base.Variable { Base.max_allocable } -> `Value (Int.succ max_allocable) (** 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 "@[@ %a@]" pretty_int off (pretty_offset_aux "r" off) t; ;; let pretty fmt t = Format.fprintf fmt "@[%a@]" (pretty_offset_aux "r" Integer.zero) t; ;; let pretty_debug_offset fmt (curr_off, tree) = let rec aux_pdebug fmt (curr_off, tree) = match tree with | Empty -> Format.fprintf fmt "empty" | Node (max, offl, subl, offr, subr, rem, modu, v, tag) -> Format.fprintf fmt "@[@[[%a..%a]@ (%a, %a,@ %a){%d,%x}@]@\n@[-- \ %a -->@\n%a@]@\n@[-- %a -->@\n%a@]@]" pretty_int curr_off pretty_int (curr_off +~ max) Rel.pretty rem pretty_int modu V.pretty v tag (Extlib.address_of_value tree) pretty_int offl aux_pdebug (curr_off +~ offl, subl) pretty_int offr aux_pdebug (curr_off +~ offr, subr) in aux_pdebug fmt (curr_off, tree); Format.fprintf fmt "@\n"; ;; let pretty_debug fmt m = pretty_debug_offset fmt (Integer.zero, m);; 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 = V.t offsetmap let name = Printf.sprintf "Offsetmap(%s)" V.name let reprs = [ Empty ] open Structural_descr let r = Recursive.create () let structural_descr = let p_bint = Datatype.Integer.packed_descr in t_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 m_empty = Empty (* Empty is not exported, and we cannot make it private. Instead, we use m_empty to track the places where we create something 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 = if debug then assert (Integer.ge cur Integer.zero); 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 "Offsetmap(%s): internal maximum exeeded" V.name; 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 = V.t offsetmap val m_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 * V.t offsetmap 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, m_empty end let clear_caches_ref = 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 "@[ [%a,%a] R@\n%a@]" pretty_int o pretty_int (o +~ max) aux z | Left (o, Node(max, _, _, _, _subr, _, _, _, _),z ) -> fprintf ppf "@[ [%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; ;; (* Minimum and maximum bit bounds in the offsetmap (inclusively), assuming that [m] starts at [curr_off]. Usually not required, as we use [validity] arguments, that give the size of the offsetmap. Beware that this function must not be called on empty offsetmaps. *) let bounds_offset curr_off m = let rec min curr_off = function | Empty -> curr_off (* This bit is bound, unless [m] itself is empty *) | Node (_, offl, subl, _, _, _, _, _, _) -> min (curr_off +~ offl) subl and max curr_off = function | Empty -> pred curr_off (* [curr_off] is not bound, [curr_off-1] is. *) | Node (_, _, _, offr, subr, _, _, _, _) -> max (curr_off +~ offr) subr in assert (m != Empty); (min curr_off m, max curr_off m) let _bounds m = bounds_offset Int.zero m (** 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 acc = if t = Empty then acc else 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 let no, nt, nz = try move_right o t z with End_reached -> (* Use match ... with exception in 4.02 *) abs_max, Empty, z (* End the recursion at next iteration *) in aux_fold no nt nz now in aux_fold o n z acc ;; let fold f t = fold_offset f Integer.zero t ;; let iter_offset f o t = if t <> Empty then 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); let no, nt, nz = try move_right o t z with End_reached -> abs_max, Empty, z (* End the recursion at next iteration *) in aux_iter no nt nz end in aux_iter o n z ;; let iter f t = iter_offset f Integer.zero t ;; (* Same as iter, but does not compute offsets (hence more efficient). *) let rec iter_on_values f t = match t with | Empty -> () | Node (_, _, left, _, right, _, _, v, _) -> iter_on_values f left; f v; iter_on_values f right ;; let rec fold_on_values f t acc = match t with | Empty -> acc | Node (_, _, left, _, right, _, _, v, _) -> fold_on_values f right (f v ((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 if debug then assert (Integer.ge max Integer.zero); 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 && (V.cardinal_zero_or_one v || (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 ;; (* Creates the tree representing the interval [curr_off..cur_off+span], bound to [v] *) let interval_aux curr_off span rem modu v = let remrel, modu = if V.is_isotropic v then Rel.zero, Integer.one else Rel.pos_rem (Rel.sub_abs rem curr_off) modu, modu in curr_off, nNode span Integer.zero m_empty (succ span) m_empty remrel modu v (* creates a fresh tree that binds [0..size-1] to the isotropic value [v]. if [size] if 0, returns [Empty]. *) let isotropic_interval size v = if Int.(equal size zero) then Empty else nNode (pred size) Integer.zero m_empty size m_empty Rel.zero Integer.one 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 = if debug then assert (min <=~ max); let rec aux_add curr_off tree = match tree with | Empty -> interval_aux min (max -~ min) 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 m_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) m_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 ;; (* Bind the interval [min..max] to [v], and append it to the zero-rooted map [t]. [rem] and [modu] are inferred by considering that [min..max] binds a single value (unless [v] is isotropic) *) let append_basic_itv ~min ~max ~v m = if V.is_isotropic v then snd (add_node ~min ~max Integer.zero Integer.one v Integer.zero(*co*) m) else let size = Integer.length min max in let v = V.anisotropic_cast ~size v in let rem = min %~ size in snd (add_node ~min ~max rem size v Integer.zero(*co*) m) (** Checks that [tree] is sanely built *) let rec check_aux 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_aux (curr_off +~ offl) subl; check_aux (curr_off +~ offr) subr; ;; let _check curr_off tree = try check_aux curr_off tree with Assert_failure _ as e -> Kernel.error "INVALID@.%a@." _pretty_offset (curr_off, tree); raise e (** Inclusion functions *) (* Auxiliary function for inclusion: check that, between [mabs_min] and [mabs_max], the values (r1, m1, v1) and (r2, m2, v2), respectively bound between (amin1, amax1) and (amin2, amax2), are included. *) let is_included_nodes_values (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 V.is_included 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 V.is_included v1 v2 else false (* Functional for inclusion test. For this function, the equality [bounds o1 t1 = bounds o2 t2] does not need to hold. We test the inclusion for the range that is common to both trees. *) let is_included_aux_cache cache (o1, t1) (o2, t2) = match t1, t2 with | Empty, _ | _, Empty -> true (* no common range. By definition, the inclusion holds *) | 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 (if (r1 =~ r2 && m1 =~ m2) || V.is_isotropic v1 || V.is_isotropic v2 then V.is_included v1 v2 else false) && cache (or1, subr1) (or2, subr2) end else if amax1 >~ amax2 then begin is_included_nodes_values amin1 amax1 r1 m1 v1 amin2 amax2 r2 m2 v2 mabs_min amax2 && cache (o1, t1) (or2, subr2) end else begin (* amax1 <~ amax2 *) is_included_nodes_values 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 (* treat the common interval and the right parts of the trees. The common interval starts at [mabs_min] and goes up to [min amax1 amax2]. *) let treat_current_right_nodes mabs_min = if amax1 =~ amax2 then begin is_included_nodes_values 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_nodes_values amin1 amax1 r1 m1 v1 amin2 amax2 r2 m2 v2 mabs_min amax2 && cache (o1, t1) (or2, subr2) end else begin (* amax1 <~ amax2 *) is_included_nodes_values amin1 amax1 r1 m1 v1 amin2 amax2 r2 m2 v2 mabs_min amax1 && cache (or1, subr1) (o2, t2) end; in (* Find the beginning of the common part of the two intervals (ie. [mabs_min] above, which is by definition [max amin1 amin2]), and treat this interval and the right trees. Then, check the inclusion of the subtree that starts just before [mabs_min] with the entire other tree. *) if amin1 >~ amin2 then begin treat_current_right_nodes amin1 && cache (ol1, subl1) (o2, t2) end else begin (* amin1 <~ amin2 *) treat_current_right_nodes amin2 && cache (o1, t1) (ol2, subl2) end end ;; module IsIncludedCache = Binary_cache.Binary_Predicate(Cacheable)(Cacheable) let () = clear_caches_ref := IsIncludedCache.clear :: !clear_caches_ref;; let rec is_included_aux t1 t2 = Cacheable.equal t1 t2 || is_included_aux_cache (IsIncludedCache.merge is_included_aux) t1 t2 let is_included t1 t2 = is_included_aux (Integer.zero, t1) (Integer.zero, t2) ;; (** 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, t1 | 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) = if debug then (* the two trees must span the exact same range. *) assert ((t1 == Empty && t2 == Empty && o1 =~ o2) || let ib1, ie1 = bounds_offset o1 t1 in let ib2, ie2 = bounds_offset o2 t2 in ib1 =~ ib2 && ie1 =~ ie2); match t1, t2 with | Empty, Empty -> o1, t1 | 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 and rem1 = (Rel.add_abs o1 rem1rel) %~ modu1 and rem2 = (Rel.add_abs o2 rem2rel) %~ modu2 in if debug then assert (abs_min2 <=~ abs_max1 && abs_min1 <=~ abs_max2); (* here n1 \inter n2 <> \emptyset, given the invariants on offsetmaps shape and the fact that both trees cover the same range. -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 ~min:abs_min1 ~max:(pred abs_min2) rem1 modu1 v1 abs_offl1 subl1 in cache (new_offl1, new_subl1) (abs_offl2, subl2), abs_min2 else begin (* abs_min1 >~ abs_min2 *) let new_offl2, new_subl2 = add_node ~min:abs_min2 ~max:(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 ~min:(succ abs_max1) ~max:abs_max2 rem2 modu2 v2 abs_offr2 subr2 in cache (abs_offr1, subr1) (new_offr2, new_subr2), abs_max1 else begin (* abs_max1 >~ abs_max2 *) let min = (succ abs_max2) in let new_offr1, new_subr1 = add_node ~min ~max: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 ~min:middle_abs_min ~max:middle_abs_max rem modu v curr_offl left_t in union curr_offl left_t curr_offr right_t ;; let rec map_on_values_aux f curr_off t = match t with | Empty -> curr_off, t | Node (max, offl, subl, offr, subr, relrem, modu, v, _) -> let v' = f v in let offl', l' = map_on_values_aux f (curr_off +~ offl) subl in let offr', r' = map_on_values_aux f (curr_off +~ offr) subr in if l' == subl && r' == subr && V.equal v v' then curr_off, t else let rem = (Rel.add_abs curr_off relrem) %~ modu in make_node curr_off max (offl' -~ curr_off) l' (offr' -~ curr_off) r' rem modu v' ;; let map_on_values f t = snd (map_on_values_aux f Int.zero 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 ~topify ~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 ~topify ~conflate_bottom ~offset ~value acc else V.big_endian_merge_bits ~topify ~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 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 ; *) (* we ignore the 'inform' information here (and everywhere else in this module, since we do not propagate it), because it is mostly redundant with the 'origin' information in garbled mix *) let _inform, read_bits = extract_bits ~topify ~start ~stop ~modu v in (* Format.printf "After single step: read bits %a@." V.pretty read_bits; *) 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 (* Format.printf "After merge_bits: result %a@." V.pretty result; *) 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@ %a@ size %a\ coff %a abs_max -- val %a@\n acc %a res %a@." pretty_int offset pretty_int size pretty_int curr_off (\* pretty_int (curr_off +~ (get_max node)) *\) V.pretty v V.pretty acc V.pretty r; *) r ;; (** Auxiliary function to join 2 trees with {!merge} above. 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. When [merge_v] is narrow, it is important that [extract_bits_and_stitch] be canonical enough -- or that {!V.narrow} handles differences in representations soundly. *) let f_aux_merge_generic merge_v abs_min abs_max rem1 modu1 v1 rem2 modu2 v2 = if rem1 =~ rem2 && modu1 =~ modu2 then rem1, modu1, V.anisotropic_cast modu1 (merge_v modu1 v1 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 ; *) else let topify = Origin.K_Merge 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 v1 else extract_bits_and_stitch ~topify ~conflate_bottom:false ~offset ~size offset (rem1, modu1, v1) abs_max V.merge_neutral_element in let v2' = if modu2 =~ size && ((rem2 %~ size) =~ rem) then v2 else extract_bits_and_stitch ~topify ~conflate_bottom:false ~offset ~size offset (rem2, modu2, v2) abs_max V.merge_neutral_element 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 size v1' v2' ;; (* similar to [f_aux_merge_generic], but we perform a reinterpretation in all cases. This is to ensure that [V.narrow] can be applied soundly. *) let f_aux_merge_narrow merge_v abs_min abs_max rem1 modu1 v1 rem2 modu2 v2 = let topify = Origin.K_Merge in let offset = abs_min in let size = Integer.length abs_min abs_max in let rem = abs_min %~ size in let v1' = extract_bits_and_stitch ~topify ~conflate_bottom:false ~offset ~size offset (rem1, modu1, v1) abs_max V.merge_neutral_element in let v2' = extract_bits_and_stitch ~topify ~conflate_bottom:false ~offset ~size offset (rem2, modu2, v2) abs_max V.merge_neutral_element in rem, size, (merge_v size v1' v2': v) ;; (** More efficient version of {!f_aux_merge_generic}, specialized for join-like functions. When one of the values is isotropic, we do not concretize the other one with {!extract_stitch_and_bits}. Instead, we implicitly "extend" the isotropic value to the full range, and merge on the whole range. This does not work with narrow, because [narrow {0} {1,2}] on the first bit is {0}, but the intersection of the two sets is bottom. *) let f_aux_merge_join merge_v abs_min abs_max rem1 modu1 v1 rem2 modu2 v2 = let joined size v1 v2 = V.anisotropic_cast size (merge_v size v1 v2) in if 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 f_aux_merge_generic merge_v abs_min abs_max rem1 modu1 v1 rem2 modu2 v2 ;; module JoinCache = Binary_cache.Symmetric_Binary(Cacheable)(Cacheable) let () = clear_caches_ref := JoinCache.clear :: !clear_caches_ref;; (** Joining two trees that cover the same range *) let join t1 t2 = let f_join = f_aux_merge_join (fun _size v1 v2 -> V.join v1 v2) in let rec aux_cache t1 t2 = if Cacheable.equal t1 t2 then t1 else JoinCache.merge (merge aux_cache f_join) t1 t2 in let _, r = aux_cache (Integer.zero, t1) (Integer.zero, t2) in r ;; module Make_Narrow(X: sig include Lattice_type.With_Top with type t := V.t include Lattice_type.With_Narrow with type t := V.t end) = struct module NarrowCache = Binary_cache.Symmetric_Binary(Cacheable)(Cacheable) module NarrowReinterpretCache = Binary_cache.Symmetric_Binary(Cacheable)(Cacheable) let () = clear_caches_ref := NarrowReinterpretCache.clear :: NarrowCache.clear :: !clear_caches_ref;; let is_top = function | Node (_, _, Empty, _, Empty, _ , _, v, _) -> V.equal v X.top | _ -> false (** Narrowing two trees that cover the same range *) let narrow t1 t2 = let f_join = f_aux_merge_generic (fun _size v1 v2 -> X.narrow v1 v2) in let rec aux_cache t1 t2 = if Cacheable.equal t1 t2 || is_top (snd t2) then t1 else if is_top (snd t1) then t2 else NarrowCache.merge (merge aux_cache f_join) t1 t2 in let _, r = aux_cache (Integer.zero, t1) (Integer.zero, t2) in r ;; let narrow_reinterpret t1 t2 = let f_join = f_aux_merge_narrow (fun _size v1 v2 -> X.narrow v1 v2) in let rec aux_cache t1 t2 = if Cacheable.equal t1 t2 || is_top (snd t2) then t1 else if is_top (snd t1) then t2 else NarrowReinterpretCache.merge (merge aux_cache f_join) t1 t2 in let _, r = aux_cache (Integer.zero, t1) (Integer.zero, t2) in r ;; end let join_and_is_included t1 t2 = let r = join t1 t2 in r, equal r t2 let widen wh t1 t2 = (* Due to the way f_aux_merge is designed, we can obtain intervals on which the two bindings do not verify [is_included v1 v2]. The widening operations require this, so we correct the arguments here. *) let widen size v1 v2 = let v2 = if not (V.is_included v1 v2) then V.join v1 v2 else v2 in V.widen (size,wh) v1 v2 in let f_widen = f_aux_merge_join widen in let rec aux t1 t2 = if Cacheable.equal t1 t2 then t1 else merge aux f_widen t1 t2 in let _, r = aux (Integer.zero, t1) (Integer.zero, t2) in r ;; type map2_decide = ReturnLeft | ReturnRight | ReturnConstant of V.t | Recurse let map2_on_values_offset cache decide (f: V.t -> V.t -> V.t) = let merge_cache = match cache with | Hptmap_sig.PersistentCache _ | Hptmap_sig.TemporaryCache _ -> let module Map2Cache = Binary_cache.Arity_Two(Cacheable)(Cacheable)(Cacheable) in (match cache with | Hptmap_sig.PersistentCache _ -> clear_caches_ref := Map2Cache.clear :: !clear_caches_ref | _ -> ()); Map2Cache.merge | Hptmap_sig.NoCache -> fun f x y -> f x y in let f' _abs_min _abs_max _rem1 _modu1 v1 _rem2 _modu2 v2 = Int.zero, Int.one, f v1 v2 in (* See the invariants a the top of {!merge}: [bounds o1 n1 = bounds o2 n2] holds *) let rec aux (o1, n1 as t1) (_o2, n2 as t2) = match decide n1 n2 with | Recurse -> merge_cache (merge aux f') t1 t2 | ReturnLeft -> t1 | ReturnRight -> t2 | ReturnConstant v -> if n1 == Empty then begin (o1, n1) (* [n2 == Empty] and [o1 =~ o2] hold. *) end else begin (* build an interval mapped to [v], of the same width as t1 and t2 *) let ib1, ie1 = bounds_offset o1 n1 in interval_aux ib1 (ie1 -~ ib1) Int.zero Int.one v end in aux let map2_on_values cache decide (f: V.t -> V.t -> V.t) = let map2_on_values_cached = map2_on_values_offset cache decide f in fun t1 t2 -> snd (map2_on_values_cached (Int.zero, t1) (Int.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_between (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 let origin = Origin.(current K_Misalign_read) in V.topify_with_origin origin v in V.join subl_value (V.join subr_value current_node_value) in aux Integer.zero tree (* Query the offsetmap for the interval [start, start + size - 1], which is supposed to fit in the offsetmap. Assumes the offsetmap is rooted at offset 0 *) let find_itv ~conflate_bottom ~start ~size tree period_read_ahead = let z, cur_off, root = find_bit start tree in let topify = Origin.K_Misalign_read 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 read_ahead, v end else let acc = ref V.merge_neutral_element in let impz = { node = root; offset = cur_off; zipper = z; } in while impz.offset <=~ isize do let 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 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; None, !acc ;; (* Finds the value associated to some offsets represented as an ival. *) let find ~validity ?(conflate_bottom=true) ~offsets ~size tree = let alarm, filtered_by_bound = Tr_offset.trim_by_validity offsets size validity 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 read_ahead, v = find_itv ~conflate_bottom ~start:!mn ~size tree m in 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 -> List.fold_left (fun acc offset -> let _, new_value = find_itv ~conflate_bottom ~start:offset ~size tree Int.zero in V.join acc new_value ) V.bottom s | Tr_offset.Overlap (mn, mx, _origin) -> find_imprecise_between (mn, mx) tree | Tr_offset.Invalid -> V.bottom with Bit_Not_found -> assert false(*does not happen with proper validity*) in alarm, r ;; (* Keep the part of the tree strictly under (i.e. strictly on the left) of a given offset. *) let rec keep_below ~offset curr_off tree = match tree with | Empty -> offset, tree | 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 ~min:curr_off ~max:(new_max +~ curr_off) ((Rel.add_abs curr_off rrel) %~ m) m v (curr_off +~ offl ) subl ;; (* Keep the part of the tree strictly above (e.g. strictly on the right) of a given offset. *) let rec keep_above ~offset curr_off tree = match tree with | Empty -> (succ offset), tree | 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 ~min:(succ offset) ~max:abs_max new_reml m v new_offr subr ;; let update_itv_with_rem ~exact ~offset ~abs_max ~size ~rem v curr_off tree = if Int.(equal size zero) then curr_off, tree else 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 ~min:offset ~max: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 origin = Origin.(current K_Merge) in let new_value = V.topify_with_origin 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 ~min:(Integer.max impz.offset offset) ~max: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 should be in Int_Intervals, but is currently needed here. Returns an interval with reversed bounds when the intersection is empty. *) let clip_by_validity = function | Base.Empty | Base.Invalid -> (fun _-> Int.one, Int.zero (* reversed interval -> no intersection*)) | Base.Known (min, max) | Base.Unknown (min, _, max) -> (fun (min', max') -> Integer.max min min', Integer.min max max') | Base.Variable variable_v -> (fun (min', max') -> Integer.max Int.zero min', Integer.min variable_v.Base.max_alloc max') (** 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]. *) (* TODO: the convention to write bottom on non-valid locations is strange, and only useful for the NULL base in Lmap.ml. It would be simpler an more elegant to keep the existing value on non-valid ranges instead. This function should also be written as a call to fold_between *) let update_imprecise_everywhere ~validity o v offsm = let v = V.topify_with_origin o v in if Base.Validity.equal validity Base.Invalid then `Bottom else let clip = clip_by_validity validity in let r = fold (fun (min, max as itv) (bound_v, _, _) acc -> let new_v = V.join (V.topify_with_origin o bound_v) v in let new_min, new_max = clip itv in if new_min <=~ new_max then (* [min..max] and validity intersect *) let acc = if min <~ new_min (* Before validity *) then append_basic_itv ~min ~max:(pred new_min) ~v:V.bottom acc else acc in let acc = append_basic_itv ~min:new_min ~max:new_max ~v:new_v acc in let acc = if new_max <~ max (* After validity *) then append_basic_itv ~min:(succ new_max) ~max ~v:V.bottom acc else acc in acc else append_basic_itv ~min ~max ~v:V.bottom acc ) offsm m_empty in `Value r ;; (** 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 curr_off tree = assert(mx >=~ mn); let r = mn %~ period in let rec aux_update mn mx curr_off tree = match tree with | Empty -> curr_off, tree | 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 ~min:curr_off ~max:(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 v curr_off 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 v !o !t in o := o'; t := t'; offset := !offset +~ period; done; !o, !t; end | Some _, None | None, Some _ | None, None -> curr_off, tree in aux_update mn mx curr_off tree ;; let imprecise_write_msg = ref "locations to update in array" exception Update_Result_is_bottom (* Returns [true] iff [update_aux_tr_offsets] will approximate the set of offsets written *) let update_aux_tr_offsets_approximates offsets size = match offsets with | Tr_offset.Overlap _ -> false | Tr_offset.Interval(mn, mx, period) -> let number = succ ((mx -~ mn) /~ period) in let plevel = !plevel in if number <=~ Integer.of_int plevel || period =~ size then false else true | Tr_offset.Set _ | Tr_offset.Invalid -> false (* Update [t] by writing [v] of size [size] every offsets. Make sure that this function over-approximates the set of location written iff [update_aux_approximates] returns [true] *) let update_aux_tr_offsets ~exact ~offsets ~size v curr_off t = match offsets with | Tr_offset.Overlap (mn, mx, origin) -> let origin = if origin = Origin.Unknown then Origin.(current K_Misalign_read) else origin in let v = V.topify_with_origin origin v in (* TODO: check *) update_itv ~exact ~offset:mn ~abs_max:mx ~size:Integer.one v curr_off t | Tr_offset.Interval(mn, mx, period) -> let number = succ ((mx -~ mn) /~ period) in let plevel = !plevel in assert (period >=~ size); (* Checked by Tr_offset *) if number <=~ Integer.of_int plevel || period =~ size then update_itvs ~exact ~mn ~mx ~period ~size v curr_off t else begin if size <~ period then (* We are going to write the locations that are between [size+1] and [period] unnecessarily, warn the user *) Lattice_messages.emit_approximation msg_emitter "more than %d(%a) %s. Approximating." plevel pretty_int number !imprecise_write_msg; let abs_max = pred (mx +~ size) in let v = if Int.is_zero (period %~ size) then v else let origin = Origin.(current K_Misalign_read) in let v' = V.topify_with_origin origin v in if not (V.equal v v') then Lattice_messages.emit_approximation msg_emitter "approximating value to write."; v' in update_itv ~exact:false ~offset:mn ~abs_max ~size v curr_off t end | Tr_offset.Set s -> List.fold_left (fun (curr_off, m) offset -> update_itv ~exact ~offset ~size ~abs_max:(pred (offset +~ size)) v curr_off m ) (curr_off, t) s | Tr_offset.Invalid -> raise Update_Result_is_bottom (* High-level update function (roughly of type [Ival.t -> v -> offsetmap -> offsetmap]. This function does not suppose that offsetmaps are zero-rooted. When too many locations must be updated, the result is approximated w.r.t the memory zones written. *) let update_aux ?origin ~validity ~exact ~offsets ~size v curr_off t = let v = V.anisotropic_cast ~size v in let alarm, reduced = Tr_offset.trim_by_validity ?origin offsets size validity in let exact = exact && not (Base.is_weak_validity validity) in let r = update_aux_tr_offsets ~exact ~offsets:reduced ~size v curr_off t in alarm, r (* Same as update_aux, but on zero-rooted offsetmaps. *) let update ?origin ~validity ~exact ~offsets ~size v t = try let alarm, (_curr_off, r) = update_aux ?origin ~validity ~exact ~offsets ~size v Int.zero t in alarm, `Value r with Update_Result_is_bottom -> true, `Bottom (* High-level update function (roughly of type [Ival.t -> v -> offsetmap -> offsetmap]) that *under*-approximate the set of written locations, when there are too many of them. *) let update_under ~validity ~exact ~offsets ~size v t = let v = V.anisotropic_cast ~size v in let alarm, offsets = Tr_offset.trim_by_validity offsets size validity in if Base.is_weak_validity validity || update_aux_tr_offsets_approximates offsets size then alarm, `Value t else try let _, t = update_aux_tr_offsets ~exact ~offsets ~size v Int.zero t in alarm, `Value t with Update_Result_is_bottom -> true, `Bottom 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 (* different 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 m_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 ~min:nbeg ~max: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; (* [!acc <> Empty] because the Node case executes at least once *) read_ahead, !acc ;; let is_single_interval o = match o with | Node(_, _, Empty, _, Empty, _, _, _, _) -> true | _ -> false let single_interval_value o = match o with | Node(_, _, Empty, _, Empty, _, _, v, _) -> Some v | _ -> None let is_same_value o v = match o with | Empty -> true | Node(_, _, Empty, _, Empty, _, _, v', _) -> V.equal v v' | _ -> false let copy_slice ~validity ~offsets ~size tree = let alarm, filtered_by_bound = Tr_offset.trim_by_validity offsets size validity in if Int.(equal size zero) then alarm, `Value Empty else let init = isotropic_interval size V.bottom 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; `Value !acc_tree | Tr_offset.Set s -> let m = List.fold_left (fun acc_tree offset -> let _, t = copy_single offset tree size Integer.zero in join acc_tree t ) init s in `Value m | Tr_offset.Overlap(mn, mx, _origin) -> let v = find_imprecise_between (mn, mx) tree in `Value (isotropic_interval size v) | Tr_offset.Invalid -> `Bottom in alarm, result ;; let fold_between ?(direction=`LTR) ~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 (* fold on the left subtree *) let acc_left acc = if imin <~ curr_off then ( aux (offl +~ curr_off) subl acc) else acc in let acc_middle 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 (* fold on the right subtree *) let acc_right acc = if imax >~ abs_max then aux (offr +~ curr_off) subr acc else acc in match direction with | `LTR -> acc_right (acc_middle (acc_left acc)) | `RTL -> acc_left (acc_middle (acc_right acc)) in aux Integer.zero t acc ;; (* weak validity should be handled caller *) let paste_slice_itv ~exact from stop start_dest to_ = let update = update_itv_with_rem ~exact in let treat_interval (imin, imax) (v, modu, rem) acc = let dmin, dmax = imin +~ start_dest, imax +~ start_dest in snd (update ~offset:dmin ~abs_max:dmax ~rem:rem ~size:modu v Integer.zero acc) in fold_between ~entire:false (Int.zero, stop) treat_interval from to_ ;; (** pastes [from] (of size [size]) at all [offsets] in [dst]. Optimisations for the case where [size] and the periodicity of [offsets] match are treated in [paste_slice] below. [size] is supposed to be strictly positive. *) let paste_slice_not_contiguous ~validity ~exact ~from:src ~size ~offsets dst = try let plevel = !plevel in let stop_src = Int.pred size in ignore (Ival.cardinal_less_than offsets plevel); (* See explanations at the end of [Tr_offset] for what is computed here.*) let min_valid, max_sure_valid, max_maybe_valid = match validity with | Base.Invalid | Base.Empty (* size > 0 *) -> Int.zero, Int.minus_one, Int.minus_one | Base.Known (b,e) -> b, e, e | Base.Unknown (b, k, e) -> let max_sure = Extlib.opt_conv Int.minus_one k in b, max_sure, e | Base.Variable { Base.min_alloc; Base.max_alloc } -> Int.zero, min_alloc, max_alloc in let aux start_to (acc_offsm, acc_alarm, acc_success) = let stop_to = Int.pred (Int.add start_to size) in (* check if at least one access is possibly valid *) if Int.lt start_to min_valid || Int.gt stop_to max_maybe_valid then (* at least one bit cannot be written => invalid access *) acc_offsm, true, acc_success else let exact = exact && not (Base.is_weak_validity validity) in let alarm = acc_alarm || Int.gt stop_to max_sure_valid in paste_slice_itv ~exact src stop_src start_to acc_offsm, alarm, true in (* 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, using a zipper *) let res, alarm, success = Ival.fold_int aux offsets (dst, false, false) in if success then alarm, `Value res else true, `Bottom with Not_less_than -> (* Value to paste, since we cannot be precise *) let v = (* Under this size, this may be an integer. Try to be a bit precise when doing 'find' *) if size <=~ Integer.of_int 128 then let validity_src = Base.validity_from_size size in let _, v = find ~validity:validity_src ~conflate_bottom:false ~offsets:Ival.zero ~size src in v else (* This is a struct or an array. Either the result will be imprecise because catenating semi-imprecise values through merge_bits will result in something really imprecise at the end, or we will build very big integers, which is not really helpful either. *) find_imprecise_between (Int.zero, Int.pred size) src in (* Have we produced an imprecision when calling 'find' ? *) let imprecise = match src with | Node (_, _, Empty, _, Empty, _, _, v', _) -> not (V.equal v v') | _ -> true (* at least two nodes *) in if imprecise then Lattice_messages.emit_approximation msg_emitter "too many locations to update in array. Approximating."; update ~validity ~exact ~offsets ~size v dst (** pastes [from] (of size [size]) at all [offsets] in [dst] *) let paste_slice ~validity ~exact ~from:src ~size ~offsets dst = if Int.(equal size zero) then (* nothing to do *) false, `Value dst else match offsets, src with (*Special case: [from] contains a single (aligned) binding [v], and [size] matches the periodicity of [offsets] and the size of [v]. In this case, it is more efficient to perform an interval update instead of an offsetmap copy. *) | Ival.Top (_,_,_, offperiod), Node(_,_, Empty,_, Empty, vrem, vsize, v,_) when Rel.is_zero vrem && size =~ offperiod && (size =~ vsize || V.is_isotropic v) -> update ~validity ~exact ~offsets ~size v dst | _ -> paste_slice_not_contiguous ~validity ~exact ~from:src ~size ~offsets dst let skip_v v = V.equal V.bottom v let pretty_generic ?typ ?(pretty_v=V.pretty_typ) ?(skip_v=skip_v) ?(sep=Unicode.inset_string ()) () fmt m = let is_first = ref true in let pretty_binding fmt (bk, ek) (v, modu, rel_offs) = if not (skip_v v) then begin 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@ @[%a@]" sep (pretty_v printed_type) 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 EMPTY@]" sep else begin Format.fprintf fmt "@["; iter (pretty_binding fmt) m; if !is_first then Format.fprintf fmt "%s@ %s" sep (Unicode.emptyset_string ()); Format.fprintf fmt "@]"; end let create_isotropic ~size v = assert (Int.ge size Int.zero); if Int.(equal size zero) then Empty else begin assert (V.is_isotropic v); isotropic_interval size v end let create ~size v ~size_v = assert (Int.ge size Int.zero); if Int.(equal size zero) then Empty else snd (interval_aux Int.zero (pred size) Int.zero size_v v) let cardinal_zero_or_one offsetmap = (singleton_tag offsetmap) <> 0 let of_list fold l size_elt = let s = pred size_elt in let n = ref Integer.zero in let addw acc v = let e = !n +~ s in let r = append_basic_itv ~min:!n ~max:e ~v acc in n := succ e; r in let r = fold addw m_empty l in assert (!n >~ Int.zero); (* implies that r <> Empty *) r let add ?(exact=true) (min, max) (v, modu, rem) m = snd (update_itv_with_rem ~exact ~offset:min ~abs_max:max ~rem ~size:modu v Integer.zero m) let find_imprecise ~validity m = match validity with | Base.Known (min, max) | Base.Unknown (min, _, max) -> find_imprecise_between (min, max) m | Base.Variable variable_v -> find_imprecise_between (Int.zero, variable_v.Base.max_alloc) m | Base.Invalid | Base.Empty -> V.bottom let find_imprecise_everywhere m = match m with | Empty -> V.bottom | Node _ -> let bounds = bounds_offset Int.zero m in find_imprecise_between bounds m let clear_caches () = List.iter (fun f -> f ()) !clear_caches_ref end (* Generic implementation of {Offsetmap_lattice_with_isotropy} for values that are all isotropic. *) module FullyIsotropic = struct let is_isotropic _ = true let anisotropic_cast ~size:_ v = v let topify_with_origin _o v = v let extract_bits ~topify:_ ~start:_ ~stop:_ ~size:_ m = false, m let little_endian_merge_bits ~topify:_ ~conflate_bottom:_ ~value:_ ~offset:_ v = v let big_endian_merge_bits ~topify:_ ~conflate_bottom:_ ~total_length:_ ~length:_ ~value:_ ~offset:_ v = v let cardinal_zero_or_one _ = false let widen _wh _ m = m type generic_widen_hint = unit type size_widen_hint = Integer.t type widen_hint = size_widen_hint * generic_widen_hint end (* -------------------------------------------------------------------------- *) (* --- Intervals --- *) (* -------------------------------------------------------------------------- *) module Int_Intervals_Map = struct include Make(struct include Datatype.Bool let bottom = false let join = (||) let is_included b1 b2 = b2 || not b1 let join_and_is_included b1 b2 = let r = b1 || b2 in r, r = b2 let merge_neutral_element = bottom let pretty_typ _ fmt v = pretty fmt v include FullyIsotropic end) include Make_Narrow(struct let top = true let narrow = (&&) end) let () = imprecise_write_msg := "elements to enumerate" (* In this auxiliary module, intervals are pairs [(curr_off, m)] where [m] has type [bool Offsetmap.t]. However, in order to avoid boxing, functions sometimes take two arguments: first the current offset, then the map. *) type itvs = Int.t * t let join : itvs -> itvs -> itvs = let stop_join m1 m2 = if m1 == m2 then ReturnLeft (* idempotency *) (* true everywhere leads to true everywhere. false everywhere leads to the other tree. *) else match m1 with | Node (_, _, Empty, _, Empty, _ , _, b, _) -> if b then ReturnLeft else ReturnRight | _ -> match m2 with | Node (_, _, Empty, _, Empty, _ , _, b, _) -> if b then ReturnRight else ReturnLeft | _ -> Recurse in let cache = Hptmap_sig.PersistentCache "Int_Intervals.join" in map2_on_values_offset cache stop_join (||) let narrow : itvs -> itvs -> itvs = let stop_narrow m1 m2 = if m1 == m2 then ReturnLeft (* idempotency *) (* false everywhere leads to false everywhere. true everywhere leads to the other tree. *) else match m1 with | Node (_, _, Empty, _, Empty, _ , _, b, _) -> if b then ReturnRight else ReturnLeft | _ -> match m2 with | Node (_, _, Empty, _, Empty, _ , _, b, _) -> if b then ReturnLeft else ReturnRight | _ -> Recurse in let cache = Hptmap_sig.PersistentCache "Int_Intervals.narrow" in map2_on_values_offset cache stop_narrow (&&) let diff : itvs -> itvs -> itvs = let stop_diff m1 m2 = if m1 == m2 then ReturnConstant false else match m2 with | Node (_, _, Empty, _, Empty, _ , _, false, _) -> ReturnLeft (* diff with empty *) | _ -> Recurse in let cache = Hptmap_sig.PersistentCache "Int_Intervals.diff" in map2_on_values_offset cache stop_diff (fun b1 b2 -> if b2 then false else b1) (* Auxiliary function that binds [b] to the interval [min..max], which is assumed not to be bound in [m] *) let add_itv ~min ~max b co m : itvs = add_node ~min ~max Int.zero Int.one b co m (* enlarges the offsetmap [m] from range [prev_min..prev_max] to [new_min..new_max], by adding an interval bound to [false] at the left and right ends. The inclusion [prev_min..prev_max \subset new_min..new_max] must hold *) let enlarge_itv co m ~prev_min ~new_min ~prev_max ~new_max : itvs = let co, m as i = if new_max >~ prev_max then add_itv ~min:(succ prev_max) ~max:new_max false co m else co, m in if new_min <~ prev_min then add_itv ~min:new_min ~max:(pred prev_min) false co m else i (* shrinks the offsetmap [m] from range [prev_min..prev_max] to [new_min..new_max], by dropping the superfluous intervals. The inclusion [new_min..new_max \subset prev_min..prev_max] must hold *) let shrink_itv co m ~prev_min ~new_min ~prev_max ~new_max : itvs = let co, m as i = if new_max <~ prev_max then keep_below (succ new_max) co m else co, m in if new_min >~ prev_min then keep_above (pred new_min) co m else i (* Resize size [m] to size [new_min..new_max], by enlarging or shrinking it on both ends. *) let resize_itv co m ~prev_min ~new_min ~prev_max ~new_max : itvs = let co, m as i = if new_max =~ prev_max then co, m else if new_max >~ prev_max then add_itv ~min:(succ prev_max) ~max:new_max false co m else (* new_max <~ prev_max *) keep_below (succ new_max) co m in if new_min =~ prev_min then i else if new_min <~ prev_min then add_itv ~min:new_min ~max:(pred prev_min) false co m else (* new_min >~ prev_min *) keep_above (pred new_min) co m (* normalizes a non-empty offsetmap [m], by removing an eventual rightmost interval bound to false. Returns the new rightmost bit bound to [true].*) let rec drop_righmost_false curr_off node = match node with | Empty -> assert false | Node (max, _, _, _, Empty, _, _, true, _) -> (* we are the rightmost interval, and not equal to false: no change *) curr_off, node, curr_off +~ max | Node (_, offl, subl, _, Empty, _, _, false, _) -> (* we are the rightmost interval, and false; keep only the left tree *) curr_off +~ offl, subl, pred curr_off | Node (max, offl, subl, offr, (Node _ as subr), _, _, v, _) -> (* Normalize the right tree and rebuild. *) let new_rcurr_off, new_rtree, rbit = drop_righmost_false (curr_off +~ offr) subr in (* We cannot have [v = false] and [new_rtree = empty]: [subr] would need contain only [false], and it should have been merged with us. *) if new_rtree == subr then curr_off, node, rbit else let curr_off', node' = make_node curr_off max offl subl (new_rcurr_off -~ curr_off) new_rtree Integer.zero Integer.one v in curr_off', node', rbit (* normalizes a non-empty offsetmap [m], by removing an eventual leftmost interval bound to false. Returns the new leftmost bit bound to [true].*) let rec drop_leftmost_false curr_off node = match node with | Empty -> assert false | Node (_, _, Empty, _, _, _, _, true, _) -> (* we are the leftmost interval, and not equal to false: no change *) curr_off, node, curr_off | Node (max, _, Empty, offr, subr, _, _, false, _) -> (* we are the leftmost interval, and false; keep only the right tree *) curr_off +~ offr, subr, succ (curr_off +~ max) | Node (max, offl, (Node _ as subl), offr, subr, _, _, v, _) -> (* normalize the left subtree and rebuild *) let new_lcurr_off, new_ltree, lbit = drop_leftmost_false (curr_off +~ offl) subl in if new_ltree == subl then curr_off, node, lbit else let curr_off', node' = make_node curr_off max (new_lcurr_off -~ curr_off) new_ltree offr subr Integer.zero Integer.one v in curr_off', node', lbit end module Int_Intervals = struct exception Error_Top type itv = Int.t * Int.t type intervals = | Top | Intervals of Int.t * Int_Intervals_Map.t * Int.t * Int.t (* The arguments of {!Intervals} are [curr_off, m, min, max] in this order. [min] and [max] are the the first and last bit bound to true in the map, which is supposed to be non-empty. All operations must maintain those two invariants. *) | Bottom let pretty_debug fmt t = match t with | Top -> Format.pp_print_string fmt "TopISet" | Bottom -> Format.pp_print_string fmt "BottomISet" | Intervals (curr_off, i, min, max) -> Format.fprintf fmt "@[I(%a-%a, @[%a])@]" Int.pretty min Int.pretty max Int_Intervals_Map.pretty_debug_offset (curr_off, i) include Datatype.Make(struct type t = intervals let name = "Int_Intervals.t" let pretty fmt t = match t with | Top -> Format.pp_print_string fmt "TopISet" | Bottom -> Format.pp_print_string fmt "BottomISet" | Intervals (curr_off, i, _, _) -> let first = ref true in Format.fprintf fmt "@[{"; Int_Intervals_Map.iter_offset (fun (b, e) (v, _, _) -> if v then begin if !first then first := false else Format.pp_print_space fmt (); Format.fprintf fmt "[%a..%a]" Int.pretty b Int.pretty e end ) curr_off i; Format.fprintf fmt "}@]" let hash = function | Top -> 37 | Bottom -> 73 | Intervals (curr_off, i, _, _) -> (* Ignore min and max, which are redundant with curr_off + i *) Int.hash curr_off + 143 * Int_Intervals_Map.hash i let equal i1 i2 = match i1, i2 with | Top, Top | Bottom, Bottom -> true | Intervals (curr_off1, i1, _, _), Intervals (curr_off2, i2, _, _) -> curr_off1 =~ curr_off2 && Int_Intervals_Map.equal i1 i2 | (Top | Bottom | Intervals _), _ -> false let compare i1 i2 = match i1, i2 with | Bottom, Bottom | Top, Top -> 0 | Intervals (curr_off1, i1, _, _), Intervals (curr_off2, i2, _, _) -> let c = Int.compare curr_off1 curr_off2 in if c = 0 then Int_Intervals_Map.compare i1 i2 else c | Bottom, (Intervals _ | Top) | Intervals _, Top -> -1 | Intervals _, Bottom | Top, (Bottom | Intervals _) -> 1 let reprs = [Bottom; Top] let rehash = Datatype.identity (* type intervals = Top | Intervals of Int.t * Int_Intervals_Map.t * Int.t * Int.t| Bottom *) let structural_descr = Structural_descr.t_sum [| [| Int.packed_descr; Int_Intervals_Map.packed_descr; Int.packed_descr; Int.packed_descr |] |] let mem_project = Datatype.never_any_project let varname _ = "i" let internal_pretty_code = Datatype.undefined let copy = Datatype.undefined end) let top = Top let bottom = Bottom let is_top = function | Top -> true | _ -> false let aux_create_interval ~min ~max v = (* Use [min] as current offset *) Int_Intervals_Map.add_itv ~min ~max v min Int_Intervals_Map.m_empty let inject_bounds min max = if Int.gt min max then Bottom else let curr_off, i = aux_create_interval ~min ~max true in Intervals (curr_off, i, min, max) let inject_itv (b, e) = inject_bounds b e let is_included i1 i2 = match i1, i2 with | Bottom, Bottom | Top, Top | Bottom, (Intervals _ | Top) | Intervals _, Top -> true | Intervals (co1, i1, min1, max1), Intervals (co2, i2, min2, max2) -> min1 >=~ min2 && max1 <=~ max2 && Int_Intervals_Map.is_included_aux (co1, i1) (co2, i2) | Intervals _, Bottom | Top, (Bottom | Intervals _) -> false let join m1 m2 = match m1, m2 with | Top, _ | _, Top -> Top | Bottom, i | i, Bottom -> i | Intervals (co1, i1, min1, max1), Intervals (co2, i2, min2, max2) -> let new_min = Int.min min1 min2 in let new_max = Int.max max1 max2 in (* Enlarge both intervals to the largest bounds. *) let coi1' = Int_Intervals_Map.enlarge_itv co1 i1 ~prev_min:min1 ~new_min ~prev_max:max1 ~new_max in let coi2' = Int_Intervals_Map.enlarge_itv co2 i2 ~prev_min:min2 ~new_min ~prev_max:max2 ~new_max in (* No need to normalize, the leftmost and rightmost bits are still there*) let co, i = Int_Intervals_Map.join coi1' coi2' in Intervals (co, i, new_min, new_max) let link = join (* all constructors but Top, which is never returned, are exact. *) let join_and_is_included t1 t2 = let r = join t1 t2 in r, equal r t2 (* Drop the leftmost and rightmost intervals if they are equal to [false], and detect if the result is [Bottom] *) let normalize_itv curr_off m = match m with | Empty | Node (_, _, Empty, _, Empty, _ ,_, false, _) -> Bottom | Node _ -> let curr_off, m, right_bit = Int_Intervals_Map.drop_righmost_false curr_off m in let curr_off, m, left_bit = Int_Intervals_Map.drop_leftmost_false curr_off m in if m == Empty then Bottom else (Intervals (curr_off, m, left_bit, right_bit)) let narrow m1 m2 = match m1, m2 with | Bottom, _ | _, Bottom -> Bottom | Top, i | i, Top -> i | Intervals (co1, i1, min1, max1), Intervals (co2, i2, min2, max2) -> if min1 >~ max2 || min2 >~ max1 then Bottom else (* Keep only the part common to both intervals *) let new_min = Int.max min1 min2 in let new_max = Int.min max1 max2 in let coi1' = Int_Intervals_Map.shrink_itv co1 i1 ~prev_min:min1 ~new_min ~prev_max:max1 ~new_max in let coi2' = Int_Intervals_Map.shrink_itv co2 i2 ~prev_min:min2 ~new_min ~prev_max:max2 ~new_max in let co, i = Int_Intervals_Map.narrow coi1' coi2' in (* Normalize *) normalize_itv co i let meet = narrow (* all constructors but Top, which is never returned, are exact. *) let intersects_map = let rec aux (o1, t1) (o2, t2) = match t1, t2 with | Empty, Empty | Empty, _ | _, Empty -> false | Node (_, offl1, subl1, offr1, subr1, _, _, false, _), Node _ -> aux (o1 +~ offl1, subl1) (o2, t2) || aux (o1 +~ offr1, subr1) (o2, t2) | Node _, Node (_, offl2, subl2, offr2, subr2, _, _, false, _) -> aux (o1, t1) (o2 +~ offl2, subl2) || aux (o1, t1) (o2 +~ offr2, subr2) | Node (max1, offl1, subl1, offr1, subr1, _, _, true, _), Node (max2, offl2, subl2, offr2, subr2, _, _, true, _) -> if max1 +~ o1 <~ o2 then aux (o1, t1) (o2 +~ offl2, subl2) || aux (o1 +~ offr1, subr1) (o2, t2) else if o1 >~ max2 +~ o2 then aux (o1, t1) (o2 +~ offr2, subr2) || aux (o1 +~ offl1, subl1) (o2, t2) else true (* the two intervals have a non-empty intersection *) in aux ;; let intersects i1 i2 = match i1, i2 with | Top, Top | Top, Intervals _ | Intervals _, Top -> true | Bottom, Bottom | Bottom, (Top | Intervals _) | (Top | Intervals _), Bottom -> false | Intervals (co1, i1, min1, max1), Intervals (co2, i2, min2, max2) -> min1 <=~ max2 && min2 <=~ max1 && intersects_map (co1, i1) (co2, i2) let diff m1 m2 = match m1, m2 with | Bottom, _ -> Bottom | Top, (Bottom | Intervals _ | Top) -> Top | Intervals _, Top -> Bottom | Intervals _, Bottom -> m1 | Intervals (co1, i1, min1, max1), Intervals (co2, i2, min2, max2) -> if max1 >~ max2 && min1 <~ min2 then (* The last bits of i1 will not be unset; grow i2 to the size of i1, then no need to renormalize afterwards . *) let coi2' = Int_Intervals_Map.enlarge_itv co2 i2 ~prev_min:min2 ~new_min:min1 ~prev_max:max2 ~new_max:max1 in let co, i = Int_Intervals_Map.diff (co1, i1) coi2' in Intervals (co, i, min1, max1) else (* The result cannot be bigger than i1: resize i2 to the same of i1. But some bits may be diffed to false, we need to renormalize *) let coi2' = Int_Intervals_Map.resize_itv co2 i2 ~prev_min:min2 ~new_min:min1 ~prev_max:max2 ~new_max:max1 in let co, i = Int_Intervals_Map.diff (co1, i1) coi2' in normalize_itv co i let fold f m acc = match m with | Bottom -> acc | Top -> raise Error_Top | Intervals (curr_off, i, _, _) -> let aux_itv itv (v, _, _) acc = if v then f itv acc else acc in Int_Intervals_Map.fold_offset aux_itv curr_off i acc (* Could be slightly improved *) let inject l = List.fold_left (fun acc itv -> join (inject_itv itv) acc) Bottom l let iter f m = match m with | Bottom -> () | Top -> raise Error_Top | Intervals (curr_off, i, _, _) -> let aux_itv itv (v, _, _) = if v then f itv in Int_Intervals_Map.iter_offset aux_itv curr_off i let project_set i = List.rev (fold (fun x y -> x :: y) i []) let project_singleton m = match m with | Bottom | Top -> None | Intervals (curr_offset, i, _, _) -> match i with | Node (max, _, Empty, _, Empty, _, _, true, _) -> Some (curr_offset, curr_offset +~ max) | _ -> None let pretty_typ typ fmt i = let typ = match typ with | Some t -> t | None -> Cil_types.(TArray (TInt(IUChar,[]), None, Cil.empty_size_cache (), [])) in match i with | Top -> Format.pp_print_string fmt "[..]" | Bottom -> Format.fprintf fmt "[%s]" (Unicode.emptyset_string ()) | Intervals _ -> 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 match project_singleton i with | Some itv -> pp_one fmt itv | None -> Pretty_utils.pp_iter ~pre:"@[{" ~sep:";@ " ~suf:"}@]" iter pp_one fmt i ;; (* Conversion from ival+size to integers. The result is cached, and over-approximated when the ival points to too many locations. *) let from_ival_size_over_cached = (* This function uses an internal cache *) let module Arg1 = struct include Ival let sentinel = bottom end in let module Arg2 = struct include Integer let sentinel = zero end in let module Result = struct type t = intervals let sentinel = bottom end in let module Cache = Binary_cache.Arity_Two(Arg1)(Arg2)(Result) in Int_Intervals_Map.(clear_caches_ref := Cache.clear :: !clear_caches_ref); add_plevel_hook Cache.clear; (* Uncached version *) let from_ival_size_aux ival size = (* Auxiliary function when [ival] is precise. The result will be contained in [min..start_max+size-1]. Create an englobing offsetmap, then update it for all intervals. *) let aux_min_max min start_max = if Int.(equal size zero) then Bottom else let max = pred (start_max +~ size) in let curr_off, ifalse = aux_create_interval ~min ~max false in let validity = Base.Known (min, max) in let _alarm, (curr_off', i) = try Int_Intervals_Map.update_aux ~validity ~exact:true ~offsets:ival ~size true curr_off ifalse with Int_Intervals_Map.Update_Result_is_bottom -> assert false (* in bounds by construction *) in Intervals (curr_off', i, min, max) in match ival with | Ival.Top(None, _, _, _) | Ival.Top(_, None, _, _) | Ival.Float _ -> top | Ival.Top(Some mn, Some mx, _r, _m) -> aux_min_max mn mx | Ival.Set(s) -> if Array.length s > 0 then aux_min_max s.(0) s.(Array.length s - 1) else bottom in Cache.merge from_ival_size_aux (* Over-approximation of the conversion of an ival+size to a set of intervals *) let from_ival_size ival size = match size with | Int_Base.Top -> top | Int_Base.Value size -> from_ival_size_over_cached ival size (* Under-approximation of the conversion of an ival+size to a set of intervals. Basically, we see if we are going to over-approximate (in which case we return Bottom). Otherwise, we use the over-approximating function, which is by definition exact in this case, and has a cache *) let from_ival_size_under ival size = match size with | Int_Base.Top -> Bottom (* imprecise *) | Int_Base.Value size -> match ival with | Ival.Top(None, _, _, _) | Ival.Top(_, None, _, _) | Ival.Float _ -> Bottom (* imprecise *) | Ival.Set _ -> from_ival_size_over_cached ival size (* precise *) | Ival.Top (Some min, Some start_max, _, _) -> (* See if using [from_ival_size] would cause an approximation *) let max = pred (start_max +~ size) in let validity = Base.Known (min, max) in let _, offsets = Tr_offset.trim_by_validity ival size validity in if Int_Intervals_Map.update_aux_tr_offsets_approximates offsets size then bottom (* imprecise *) else from_ival_size_over_cached ival size (* precise *) let range_covers_whole_type typ itvs = match 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 (s-1)) with Cil.SizeOfError _ -> false) | None -> false (* Interval bound in a zero-rooted offsetmap, expressed as a value of this module. Not currently exported *) let bounds_as_itv map = match map with | Empty -> bottom | Node _ -> let min, max = Int_Intervals_Map.bounds_offset Int.zero map in inject_bounds min max (* Although interval functions do not depend on the AST itself, there are numerous problems with not clearing the caches when the AST is reset. Hence, the weak hash table for boolean offsetmaps depends on Ast.self, and the caches are reset on an ast update. *) let () = Ast.add_hook_on_update (fun () -> (* Kernel.debug ~dkey:dkey_caches "Clearing interval caches"; *) Int_Intervals_Map.clear_caches ()) end (* -------------------------------------------------------------------------- *) (* --- Bitwise offsetmaps --- *) (* -------------------------------------------------------------------------- *) module Make_bitwise(V: sig include Lattice_type.Bounded_Join_Semi_Lattice include Lattice_type.With_Narrow with type t := t include Lattice_type.With_Top with type t := t end) = struct include Make(struct include V include FullyIsotropic let merge_neutral_element = bottom let pretty_typ _ fmt v = pretty fmt v end) type intervals = Int_Intervals.intervals let create = create_isotropic let v_size_mod v = (v, Int.one, Rel.zero) let add_binding_intervals ~validity ~exact itvs v m = try match Base.valid_range validity with | Base.Invalid_range -> `Bottom | Base.Valid_range None -> (* empty validity *) `Value m | Base.Valid_range (Some _) -> let clip = clip_by_validity validity in let aux_itv itv m = let itv = clip itv in if Int.le (fst itv) (snd itv) then add ~exact itv (v_size_mod v) m else m in `Value (Int_Intervals.fold aux_itv itvs m) with Int_Intervals.Error_Top -> update_imprecise_everywhere ~validity Origin.top v m let add_binding_ival ~validity ~exact offsets ~size v m = match size with | Int_Base.Value size -> snd (update ~validity ~exact ~offsets ~size v m) | Int_Base.Top -> update_imprecise_everywhere ~validity Origin.top v m let fold_itv ?direction ~entire f itv m acc = let f' itv (v, _, _) acc = f itv v acc in fold_between ?direction ~entire itv f' m acc let find = find_imprecise_between let find_iset ~validity itvs m = try let aux_itv i acc = V.join acc (find i m) in Int_Intervals.fold aux_itv itvs V.bottom with Int_Intervals.Error_Top -> find_imprecise ~validity m module V_Hashtbl = FCHashtbl.Make(V) (* Map indexed by sorted lists of integers. Used by function [fold_fuse_same] below, to sort bound values by increasing intervals. *) module MapIntervals = Map.Make(struct type t = (Int.t * Int.t) list let compare_itv (b1, e1) (b2, e2) = let c = Integer.compare b1 b2 in if c = 0 then Integer.compare e1 e2 else c let compare = Extlib.list_compare compare_itv end) let fold_fuse_same f m acc = let h = V_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_Hashtbl.find h v with Not_found -> [] in V_Hashtbl.replace h v (itv :: cur) in fold sort_by_content m (); (* Now sort the contents of h by increasing intervals *) let m = V_Hashtbl.fold (fun v itvs acc -> MapIntervals.add (List.rev itvs) v acc) h MapIntervals.empty in (* Call f on those intervals *) MapIntervals.fold (fun itvs v acc -> f (Int_Intervals.inject itvs) v acc) m acc let fold f m acc = let f' (ib, ie) (v, _, _) acc = let itv = Int_Intervals.inject_bounds ib ie in f itv v acc in fold f' m acc let default_skip _ = false let pretty_generic ?typ ?(pretty_v=V.pretty) ?(skip_v=default_skip) ?(sep="<:") () fmt m = let range_covers_whole_type itvs = match typ with | None -> false | Some typ -> Int_Intervals.range_covers_whole_type typ itvs in let pp_itv = Int_Intervals.pretty_typ typ in let first = ref true in let pretty_binding fmt itvs v () = if not (skip_v v) then begin if !first then first := false else Format.fprintf fmt "@," ; Format.fprintf fmt "@[@[%a@]%(%)@[%s @[%a@]@]@]" pp_itv itvs (if range_covers_whole_type itvs then (" ": (unit,Format.formatter,unit) format) else "@ ") sep pretty_v v end in Format.fprintf fmt "@["; fold_fuse_same (pretty_binding fmt) m (); if !first then Format.fprintf fmt "%s@ %s" sep (Unicode.emptyset_string ()); Format.fprintf fmt "@]" let map = map_on_values let map2 = map2_on_values (* Simultaneous recursive descent on an offsetmap bitwise and on an interval map. This function handles the case where the intervals and the offsetmap do not cover the same range. *) let fold_join_itvs_map_offset cache (type r) f join empty = let module R = struct type t = r let sentinel = empty end in let merge = match cache with | Hptmap_sig.PersistentCache _ | Hptmap_sig.TemporaryCache _ -> let module Cache = Binary_cache.Arity_Two(Cacheable)(Int_Intervals_Map.Cacheable)(R) in (match cache with | Hptmap_sig.PersistentCache _ -> clear_caches_ref := Cache.clear :: !clear_caches_ref | _ -> ()); Cache.merge | Hptmap_sig.NoCache -> fun f x y -> f x y in let rec aux cache (o1, t1) (o2, t2) = match t1, t2 with | Empty, _ | _, Empty | _, Node (_, _, Empty, _, Empty, _, _, false, _) -> empty (* Notice that we do not present to [f] the intervals that are present in [o2] but not in [o1] (i.e. in the zone but not in the map). For the current users of this module, the map is always of the size of the validity of the base, hence this is not a problem. *) | _, Node (_, _, Empty, offr2, (Node _ as subr2), _, _, false, _) -> aux cache (o1, t1) (o2 +~ offr2, subr2) | _, Node (_, offl2, (Node _ as subl2), _, Empty, _, _, false, _) -> aux cache (o1, t1) (o2 +~ offl2, subl2) | _, Node (_, offl2, (Node _ as subl2), offr2, (Node _ as subr2), _, _, false, _) -> (* This special case seems redundant with the ones above and the next one, but it speeds up dramatically this function. Otherwise, we would recurse on t1 until the interval bound to false is split in many small parts, without never adding anything. *) join (cache (o1, t1) (o2 +~ offl2, subl2)) (cache (o1, t1) (o2 +~ offr2, subr2)) | Node (max1, offl1, subl1, offr1, subr1, _, _, v, _), Node (max2, offl2, subl2, offr2, subr2, _, _, true, _) -> 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 if amax1 <~ amin2 then begin join (cache (o1, t1) (ol2, subl2)) (cache (or1, subr1) (o2, t2)) end else if amin1 >~ amax2 then begin join (cache (o1, t1) (or2, subr2)) (cache (ol1, subl1) (o2, t2)) end else begin if amin1 =~ amin2 then begin let foo = if amax1 =~ amax2 then begin join (f amin1 amax1 v) (cache (or1, subr1) (or2, subr2)) end else if amax1 >~ amax2 then begin join (f amin1 amax2 v) (cache (o1, t1) (or2, subr2)) end else begin join (f amin1 amax1 v) (cache (or1, subr1) (o2, t2)) end in join foo (cache (ol1, subl1) (ol2, subl2)) end else let treat_right_nodes mabs_min = if amax1 =~ amax2 then begin join (f mabs_min amax1 v) (cache (or1, subr1) (or2, subr2)) end else if amax1 >~ amax2 then begin join (f mabs_min amax2 v) (cache (o1, t1) (or2, subr2)) end else begin join (f mabs_min amax1 v) (cache (or1, subr1) (o2, t2)) end in if amin1 >~ amin2 then begin join (treat_right_nodes amin1) (cache (ol1, subl1) (o2, t2)) end else begin join (treat_right_nodes amin2) (cache (o1, t1) (ol2, subl2)) end end and compute (_, t1 as v1) (_, t2 as v2) = if t1 == Empty || t2 == Empty then empty else merge (aux compute) v1 v2 in compute ;; (* Simultaneous recursive descent on an offsetmap bitwise and on an interval. *) let fold_join_itvs ~cache f join empty = (* fold_join on non-degenerate intervals. Partial application is important*) let aux_intervals = fold_join_itvs_map_offset cache f join empty in fun itvs m -> match itvs with | Int_Intervals.Bottom -> empty | Int_Intervals.Intervals (curr_off, itvs, _, _) -> aux_intervals (Int.zero, m) (curr_off, itvs) | Int_Intervals.Top -> (* Find the range that is bound in [m], and use this as interval. We would not return anything outside anyway. *) match Int_Intervals.bounds_as_itv m with | Int_Intervals.Bottom -> empty | Int_Intervals.Intervals (curr_off, itvs, _, _) -> aux_intervals (Int.zero, m) (curr_off, itvs) | Int_Intervals.Top -> assert false end [@@@warning "-60"] (* The module below is template destined to be copy-pasted. We need to silence the warning about unused modules. *) module Aux (V1 : module type of Offsetmap_lattice_with_isotropy) (V2 : module type of Offsetmap_lattice_with_isotropy) = struct module M1 = Make(V1) module M2 = Make(V2) (* This function is there as a template for people wanting to write a fold-like iterator on two offsetmaps simultaneously. [bounds o1 t1 = bounds o2 t2] need not to hold; the function returns [empty] when the maps have no overlap. Currently, this functor is not exported. *) let _map_fold2 (type s) (type t) f join empty o1 (t1: s offsetmap) o2 (t2: t offsetmap) = let rec aux (o1, t1) (o2, t2) = match t1, t2 with | Empty, Empty -> empty | Empty, _ | _, Empty -> assert false | Node (max1, offl1, subl1, offr1, subr1, _, _, v1, _), Node (max2, offl2, subl2, offr2, subr2, _, _, 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 if amax1 <~ amin2 then begin join (aux (o1, t1) (ol2, subl2)) (aux (or1, subr1) (o2, t2)) end else if amin1 >~ amax2 then begin join (aux (o1, t1) (or2, subr2)) (aux (ol1, subl1) (o2, t2)) end else begin if amin1 =~ amin2 then begin let foo = if amax1 =~ amax2 then begin join (f amin1 amax1 v1 v2) (aux (or1, subr1) (or2, subr2)) end else if amax1 >~ amax2 then begin join (f amin1 amax2 v1 v2) (aux (o1, t1) (or2, subr2)) end else begin join (f amin1 amax1 v1 v2) (aux (or1, subr1) (o2, t2)) end in join foo (aux (ol1, subl1) (ol2, subl2)) end else let treat_right_nodes mabs_min = if amax1 =~ amax2 then begin join (f mabs_min amax1 v1 v2) (aux (or1, subr1) (or2, subr2)) end else if amax1 >~ amax2 then begin join (f mabs_min amax2 v1 v2) (aux (o1, t1) (or2, subr2)) end else begin join (f mabs_min amax1 v1 v2) (aux (or1, subr1) (o2, t2)) end; in if amin1 >~ amin2 then begin join (treat_right_nodes amin1) (aux (ol1, subl1) (o2, t2)) end else begin join (treat_right_nodes amin2) (aux (o1, t1) (ol2, subl2)) end end in aux (o1, t1) (o2, t2) ;; end [@@@warning "+60"] (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/0000755000175000017500000000000013113744777017150 5ustar mehdimehdiframa-c-Phosphorus-20170501/src/libraries/project/0000755000175000017500000000000013113745012020575 5ustar mehdimehdiframa-c-Phosphorus-20170501/src/libraries/project/state_selection.mli0000644000175000017500000001567213113745005024502 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 @plugin development guide *) 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 @plugin development guide *) 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 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. @since Carbon-20101201 *) val pretty_witness: Format.formatter -> t -> unit (** Display a selection in a more concise form. (Using the atomic operations that were used to create it.) @since Aluminium-20160501 *) (** {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-Phosphorus-20170501/src/libraries/project/project.ml0000644000175000017500000007273613113745002022613 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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_with_collections (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 "@[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: Datatype.S_no_copy with type t = Project_skeleton.t) 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 ?(iter=State_selection.iter) ?(selection=State_selection.full) f x = current_selection := 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 = (* since the developer may add hooks on update which may depend on each others, iterating in the dependencies order is required. *) iter_on_selection ~iter:State_selection.iter_in_order ?selection (fun s -> (private_ops s).update) let clear ?(selection=State_selection.full) p = debug ~dkey ~level:2 "clearing following selection:@. @[%a@]@.%a" State_selection.pretty_witness selection State_selection.pretty selection; 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 -> fatal "unexpected 'Not_found' when unserializing; \ possibly an issue with a hook" | 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 ~dkey ~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 ~dkey ~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 last_created_by_copy_ref: t option ref = ref None let () = Cmdline.last_project_created_by_copy := (fun () -> match !last_created_by_copy_ref with | None -> None | Some p -> Some p.unique_name) 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 exception Unknown_project let from_unique_name uname = try Q.find (fun p -> p.unique_name = uname) projects with Not_found -> raise Unknown_project module Mem = struct let mem s = try ignore (from_unique_name s); true with Unknown_project -> false end module Setter = Make_setter(Mem) let unjournalized_set_name p s = feedback ~dkey ~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 ~dkey ~level:2 "creating project %S" name; let p = Setter.make name in feedback ~dkey ~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 (** Indicates if we should keep [p] as the current project when calling {!on p}. *) let keep_current: bool ref = ref false let unjournalized_set_keep_current b = keep_current := b let set_keep_current = Journal.register "Project.set_keep_current" (Datatype.func Datatype.bool Datatype.unit) unjournalized_set_keep_current let on ?selection p f x = let old_current = current () in if old_current == p then f x else let set p = set_current ~on:true ?selection p in let set_to_old () = if not !keep_current then try (* if someone asks for keeping [p] as current during the execution of [f], do not restore [old_current] at the end. *) set old_current with Invalid_argument _ -> (* the old current project has been remove: replace it by the previous one, if any *) if Q.length projects < 2 then warning "cannot restore project '%s'. Keep '%s' as default project." old_current.unique_name (current ()).unique_name else Q.move_at_top (Q.nth 1 projects) projects in let go () = set p; let r = f x in set_to_old (); r in if debug_atleast 1 then go () else begin try go () with e -> set_to_old (); 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 ~dkey ~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; (* if we removed the last created_by_copy project, there is no last one *) Extlib.may (fun p -> if equal project p then last_created_by_copy_ref := None) !last_created_by_copy_ref; (* 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 ~dkey ~level:2 "removing all existing projects"; try iter_on_projects Before_remove.apply; States_operations.clean (); Q.clear projects; last_created_by_copy_ref := None; 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 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. !last_created_by_copy_ref must be saved at the same time to share the project on disk *) output_value cout (List.rev states, !last_created_by_copy_ref); 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) -> (* if we provide an explicit name different of the current one, rename project [p] *) (match name with Some s when s <> p.name -> 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_pair (Descr.t_list final_one_state) (Descr.t_option D.descr) (* the last saved project *) 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 | End_of_file -> close_in cin; abort "unexpected end of file while loading '%s'" filename | 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, last_created = gen_read (fun c -> Descr.input_val c (Descr.global_state name selection)) cin in close_in cin; last_created_by_copy_ref := last_created; 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 last 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; if last then last_created_by_copy_ref := Some prj; 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.func2 ~label1:("last", None) Datatype.bool Datatype.string ty))) unjournalized_create_by_copy let create_by_copy ?(selection=State_selection.full) ?(src=current()) ~last name = journalized_create_by_copy selection src last 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 ~dkey "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-Phosphorus-20170501/src/libraries/project/state_dependency_graph.ml0000644000175000017500000000776313113745006025646 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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_vertex graph v = assert (not (State.is_dummy v)); Dependency_graph.add_vertex graph v let add_edge graph v1 v2 = assert (Dependency_graph.(mem_vertex graph v1 && mem_vertex graph v2)); Dependency_graph.add_edge graph v1 v2 let add_dependencies ~from deps = List.iter (add_edge graph from) deps let add_codependencies ~onto codeps = List.iter (fun c -> 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 = 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-Phosphorus-20170501/src/libraries/project/state_selection.ml0000644000175000017500000002272613113745001024323 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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) (* Set of the states in a selection *) type concrete_state_selection = | Full | Subset of Selection.t (* Reification of the atomic operations that are used to create a selection *) type witness = | WAll | WEmpty | WSingleton of State.t | WOfStateList of State.t list | WDependencies of State.t | WStrictDependencies of State.t | WCoDependencies of State.t | WStrictCoDependencies of State.t | WUnion of witness * witness | WDiff of witness * witness | WOfList of witness list let rec pretty_witness fmt = function | WAll -> Format.pp_print_string fmt "*" | WEmpty -> Format.pp_print_string fmt "<>" | WSingleton s -> pretty_state fmt s | WOfStateList l -> Pretty_utils.pp_list ~pre:"[@[" ~suf:"@]]" ~sep:",@ " pretty_state fmt l | WDependencies s -> Format.fprintf fmt "Deps(%a)" pretty_state s | WStrictDependencies s -> Format.fprintf fmt "StrictDeps(%a)" pretty_state s | WCoDependencies s -> Format.fprintf fmt "CoDeps(%a)" pretty_state s | WStrictCoDependencies s -> Format.fprintf fmt "StrictCoDeps(%a)" pretty_state s | WUnion (w1, w2) -> Format.fprintf fmt "@[Union(%a,@ %a)@]" pretty_witness w1 pretty_witness w2 | WDiff (w1, w2) -> Format.fprintf fmt "@[Diff(%a,@ %a)@]" pretty_witness w1 pretty_witness w2 | WOfList l -> Pretty_utils.pp_list ~pre:"[@[" ~suf:"@]]" ~sep:",@ " pretty_witness fmt l and pretty_state fmt s = Format.pp_print_string fmt (State.get_name s) type state_selection = concrete_state_selection * witness let empty = Subset Selection.empty, WEmpty let full = Full, WAll let singleton s = Subset (Selection.add_vertex Selection.empty s), WSingleton s let of_list l = Subset (List.fold_left Selection.add_vertex Selection.empty l), WOfStateList l let is_empty (sel, _) = sel = Subset Selection.empty let is_full (sel, _) = sel = 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 (s, _) = match s with | 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 "@[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 "@[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 diff: t -> t -> t val cardinal: t -> int val to_list: t -> State.t list val pretty: Format.formatter -> t -> unit val pretty_witness: 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), WDependencies s let with_codependencies s = Subset (transitive_closure State_dependency_graph.G.fold_pred s), WCoDependencies s let only_dependencies s = let g = transitive_closure State_dependency_graph.G.fold_succ s in Subset (Selection.remove_vertex g s), WStrictDependencies s let only_codependencies s = let g = transitive_closure State_dependency_graph.G.fold_pred s in Subset (Selection.remove_vertex g s), WStrictCoDependencies s let diff (sel1, w1) (sel2, w2 as selw2) = let sel = match sel1, sel2 with | _, Full -> Subset Selection.empty | Full, _sel2 when is_empty selw2 -> 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) in sel, WDiff (w1, w2) module Operations = Graph.Oper.P(Selection) let union (sel1, w1) (sel2, w2) = let sel = match sel1, sel2 with | Full, _ | _, Full -> Full | Subset sel1, Subset sel2 -> Subset (Operations.union sel1 sel2) in sel, WUnion (w1, w2) let list_union l = let sel, _ = List.fold_left union empty l in let w = WOfList (List.map snd l) in sel, w let cardinal (sel, _) = match sel with | 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 (sel, _) = match sel with | Full -> State_dependency_graph.G.iter_vertex f State_dependency_graph.graph | Subset sel -> Selection.iter_vertex f sel let fold f (sel, _) acc = match sel 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 (sel, _) = match sel with | Full -> TG.iter f State_dependency_graph.graph | Subset sel -> TS.iter f sel let fold_in_order f (sel, _) acc = match sel 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 () let pretty_witness fmt (_, w) = pretty_witness fmt w end include Static (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/project/state_dependency_graph.mli0000644000175000017500000000673313113745004026011 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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-Phosphorus-20170501/src/libraries/project/project.mli0000644000175000017500000003243113113745011022750 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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_collections 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 *) exception Unknown_project val from_unique_name: string -> t (** Return a project based on {!unique_name}. @raise Unknown_project if no project has this unique name. @modify Sodium-20150201 *) 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 set_keep_current: bool -> unit (** [set_keep_current b] keeps the current project forever (even after the end of the current {!on}) iff [b] is [true]. @since Aluminium-20160501 *) 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 -> last:bool -> 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}). If [last], then remember that the returned project is the last created one (see {!last_created_by_copy}). @modify Carbon-20101201 replace the optional arguments [only] and [except] by a single one [selection]. @modify Sodium-20150201 add the labeled argument [last]. *) 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_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-Phosphorus-20170501/src/libraries/project/project_skeleton.ml0000644000175000017500000000545413113745012024511 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 Cmdline.Kernel_log 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-Phosphorus-20170501/src/libraries/project/project_skeleton.mli0000644000175000017500000000602513113745007024661 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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: Log.category (** @since Fluorine-20130401 *) 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-Phosphorus-20170501/src/libraries/project/state.ml0000644000175000017500000001610713113745003022254 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 () } include Datatype.Make_with_collections (struct type t = state let name = "State" let structural_descr = Structural_descr.t_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 "@[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); assert (Project_skeleton.Output.verify (uname <> "") "state should have a non-empty name"); 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-Phosphorus-20170501/src/libraries/project/state_topological.mli0000644000175000017500000000565113113745002025022 0ustar mehdimehdi(**************************************************************************) (* *) (* Ocamlgraph: a generic graph library for ocaml *) (* Copyright (C) 2004-2012 *) (* Sylvain Conchon, Jean-Christophe Filliâtre 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 licenses/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 state 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-Phosphorus-20170501/src/libraries/project/state_builder.mli0000644000175000017500000004542413113745010024135 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 functions [(marshal, unmarshal)] to be used for serialization. Default functions are identities. In particular, 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 [Option_ref]. Note that [get] will raise [Not_found] if the stored data is [None]. Use [get_option] if you want to have access to the option. *) 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 (** Signature for the creation of projectified hashconsing tables.. @since Aluminium-20160501 *) module type Hashconsing_tbl = functor (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) -> functor (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 @modify Aluminium-20160501, renamed *) module Hashconsing_tbl_weak: Hashconsing_tbl (** Hash table for hashconsing, but the internal table is _not_ weak (it is a regular hash table). This module should be used only in case perfect reproducibility matters, as the table will never be emptied by the GC. @since Aluminium-20160501 *) module Hashconsing_tbl_not_weak: Hashconsing_tbl (** Weak or non-weak hashconsing tables, depending on variable {!Cmdline.deterministic}. @since Aluminium-20160501 *) module Hashconsing_tbl: Hashconsing_tbl (* ************************************************************************* *) (** {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 remove: elt -> unit (** @since Neon-20140301 *) 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 self: State.t 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 Array} *) (* ************************************************************************* *) module type Array = sig type elt val length: unit -> int val set_length: int -> unit val get: int -> elt val set: int -> elt -> unit val iter : (elt -> unit) -> unit val iteri : (int -> elt -> unit) -> unit val fold_left: ('a -> elt -> 'a) -> 'a -> 'a val fold_right: (elt -> 'a -> 'a) -> 'a -> 'a end module Array(Data: Datatype.S)(Info: sig include Info val default: Data.t end) : Array 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 (* ****************************************************************************) (** {2 Generic functor to hashcons an arbitrary type } *) (* ****************************************************************************) (** Output signature of [Hashcons] below. *) module type Hashcons = sig type elt (** The type of the elements that are hash-consed *) include Datatype.S_with_collections (** hashconsed version of {!elt} *) val hashcons: elt -> t (** Injection as an hashconsed value. *) val get: t -> elt (** Projection out of hashconsing. *) val id: t -> int (** Id of an hashconsed value. Unique: [id x = id y] is equivalent to equality on {!elt}. *) val self: State.t end (** Hashconsed version of an arbitrary datatype *) module Hashcons (Data: Datatype.S)(Info: Info) : Hashcons with type elt = Data.t (* ************************************************************************* *) (** {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-Phosphorus-20170501/src/libraries/project/state_topological.ml0000644000175000017500000000605213113745003024646 0ustar mehdimehdi(**************************************************************************) (* *) (* Ocamlgraph: a generic graph library for ocaml *) (* Copyright (C) 2004-2012 *) (* Sylvain Conchon, Jean-Christophe Filliâtre 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 licenses/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-Phosphorus-20170501/src/libraries/project/state_builder.ml0000644000175000017500000007230013113745007023763 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 FCDatatype = Datatype 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 if Datatype.copy == FCDatatype.undefined then abort "cannot copy project: unimplemented `copy' function in datatype \ `%s' for state `%s'" Datatype.name !internal_name; 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 *) try (find p).state, false with Not_found -> fatal "unknown project '%s' in state '%s'" (Project.get_unique_name p) !internal_name 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 remove: 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 remove x = set (apply (S.remove 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 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 type Sub_caml_weak_hashtbl = sig include Datatype.Sub_caml_weak_hashtbl val clear: t -> unit val merge: t -> data -> data val add: t -> data -> unit val count: t -> int val iter: (data->unit) -> t -> unit val fold: (data->'a->'a) -> t -> 'a -> 'a val find: t -> data -> data val find_all: t -> data -> data list val mem: t -> data -> bool val remove: t -> data -> unit end module Weak_hashtbl (W: Sub_caml_weak_hashtbl) (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_weak (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 module Hashconsing_tbl_not_weak (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 module HW = FCHashtbl.Make (struct include Data let equal = Data.equal_internal let hash = Data.hash_internal end) type data = Data.t type t = data HW.t let merge h v = try HW.find h v with Not_found -> HW.add h v v; v let count = HW.length let add_initial_values h = List.iter (fun vi -> let _r = merge h vi in ()) Data.initial_values let create size = let h = HW.create size in add_initial_values h; h let clear t = HW.clear t; add_initial_values t let fold f = HW.fold_sorted (fun v _ acc -> f v acc) let iter f = HW.iter_sorted (fun v _ -> f v) let mem = HW.mem let find_all = HW.find_all let find = HW.find let remove = HW.remove let add h v = HW.replace h v v end include Weak_hashtbl(W)(Data)(Info) end module type Hashconsing_tbl = functor (Data: sig include Datatype.S val equal_internal: t -> t -> bool val hash_internal: t -> int val initial_values: t list end) -> functor (Info: Info_with_size) -> Weak_hashtbl with type data = Data.t module Hashconsing_tbl = (val if Cmdline.deterministic then (module Hashconsing_tbl_not_weak: Hashconsing_tbl) else (module Hashconsing_tbl_weak: Hashconsing_tbl)) (* ************************************************************************* *) (** {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 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 self: State.t 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 Arrays} *) (* ************************************************************************* *) module type Array = sig type elt val length: unit -> int val set_length: int -> unit val get: int -> elt val set: int -> elt -> unit val iter : (elt -> unit) -> unit val iteri : (int -> elt -> unit) -> unit val fold_left: ('a -> elt -> 'a) -> 'a -> 'a val fold_right: (elt -> 'a -> 'a) -> 'a -> 'a end module Array(Data: Datatype.S)(Info: sig include Info val default: Data.t end)= struct type elt = Data.t let state = ref (Array.make 0 Info.default) include Register (Datatype.Array(Data)) (struct type t = elt array let create () = Array.make 0 Info.default let clear v = Array.iteri (fun i _ -> v.(i) <- Info.default) v 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 let removed = ref false in Array.iteri (fun i x -> if Data.mem_project f x then begin !state.(i) <- Info.default; removed := true; end ) q; !removed end) (struct include Info let unique_name = name end) let length () = Array.length !state let set_length i = state := Array.make i Info.default let get i = !state.(i) let set i v = !state.(i) <- v let iter f = Array.iter f !state let iteri f = Array.iteri f !state let fold_left f acc = Array.fold_left f acc !state let fold_right f acc = Array.fold_right f !state acc 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 (* ****************************************************************************) (** {3 Generic hashconsing} *) (* ****************************************************************************) module type Hashcons = sig type elt include Datatype.S_with_collections val hashcons: elt -> t val get: t -> elt val id: t -> int val self: State.t end module Hashcons (Data: Datatype.S)(Info: Info) = struct type elt = Data.t type hashconsed = { key : Data.t; id : int; } let rehash_ref = ref (fun _ -> assert false) module D = Datatype.Make_with_collections (struct include Datatype.Serializable_undefined type t = hashconsed let name = "Hashconsed(" ^ Data.name ^ "," ^ Info.name ^ ")" let reprs = [ { key = List.hd Data.reprs; id = 0 } ] let structural_descr = Structural_descr.t_record [| Data.packed_descr; Structural_descr.p_int |] let equal = ( == ) let compare { id = t1 } { id = t2 } = Datatype.Int.compare t1 t2 let pretty fmt { key } = Data.pretty fmt key let hash { id } = id let copy c = c let rehash x = !rehash_ref x end) include D module HashConsTbl = Hashconsing_tbl (struct include D let hash_internal a = Data.hash a.key let equal_internal a b = Data.equal a.key b.key let initial_values = [] (* TODO? *) end) (struct let name = "Hashconstable(" ^ Data.name ^ "," ^ Info.name ^ ")" let dependencies = Info.dependencies let size = 128 end) let self = HashConsTbl.self let counter = ref 0 let hashcons key = let id = !counter in let hashed_atom = { key; id } in let hashconsed_atom = HashConsTbl.merge hashed_atom in if hashconsed_atom.id = !counter then (* Fresh new atom. this counter id is used. *) counter := succ !counter; hashconsed_atom let () = rehash_ref := fun x -> hashcons x.key let get { key } = key let id { id } = id end (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/project/state.mli0000644000175000017500000001566213113745004022433 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 observationally 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-Phosphorus-20170501/src/libraries/utils/0000755000175000017500000000000013113745012020267 5ustar mehdimehdiframa-c-Phosphorus-20170501/src/libraries/utils/indexer.mli0000644000175000017500000000515713113745005022442 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 is_empty : t -> bool 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-Phosphorus-20170501/src/libraries/utils/hptmap.ml0000644000175000017500000013441413113745006022124 0ustar mehdimehdi(**************************************************************************) (* *) (* This file was originally part of Menhir *) (* *) (* François Pottier and Yann Régis-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 licenses/Q_MODIFIED_LICENSE. *) (* *) (* File modified by CEA (Commissariat à l'énergie atomique et aux *) (* énergies alternatives). *) (* *) (**************************************************************************) (* Set to true to see which caches are created *) let debug_cache = false type prefix = int * int let sentinel_prefix = (-1) , (-1) 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 val pretty: Format.formatter -> t -> unit 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 let pretty fmt x = Format.fprintf fmt "%x" x end type tag = Tag_comp.t module Comp_unused = struct let e = false let f _ _ = false let compose _ _ = false end type ('key, 'value) tree = | Empty | Leaf of 'key * 'value * tag | Branch of int (** prefix *) * Big_Endian.mask * ('key, 'value) tree * ('key, 'value) tree * tag let id tr = match tr with | Empty -> 0 | Leaf (_, _, tag) | Branch (_, _, _, _, tag) -> Tag_comp.get_tag tag let hash_generic = id module type Id_Datatype = sig include Datatype.S val id: t -> int end module type V = sig include Datatype.S val pretty_debug: t Pretty_utils.formatter end module Shape(Key: Id_Datatype) = struct type 'b t = (Key.t, 'b) tree end module Make (Key: Id_Datatype) (V : V) (Compositional_bool : sig val e: bool val f : Key.t -> V.t -> bool val compose : bool -> bool -> 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 v = V.t type 'a shape = 'a Shape(Key).t type prefix = int * int (* 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 t = (Key.t, V.t) tree type hptmap = t (* Alias needed later *) let rec pretty_debug fmt = function | Empty -> Format.fprintf fmt "Empty" | Leaf (k, v, comp) as t -> Format.fprintf fmt "L@[@[(A %x, T %a)@]@ @[(AK %x)%a@]@ @[ -> (AV %x)@]@ @[%a@]@]" (Extlib.address_of_value t) Tag_comp.pretty comp (Extlib.address_of_value k) Key.pretty k (Extlib.address_of_value v) V.pretty_debug v | Branch (prefix, mask, t1, t2, tag) as t -> Format.fprintf fmt "B@[@[(A %x, T %a, P %x, M %x)@]@ @[%a@]@ @[ %a@]@]" (Extlib.address_of_value t) Tag_comp.pretty tag prefix mask pretty_debug t1 pretty_debug t2 let compare = if Key.compare == Datatype.undefined || V.compare == Datatype.undefined then ( Cmdline.Kernel_log.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 compositional_bool t = match t with Empty -> Compositional_bool.e | Leaf (_,_,tc) | 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 pretty fmt tree = Pretty_utils.pp_iter2 ~pre:"@[{[ " ~suf:" ]}@]" ~sep:"@ " ~between:" -> " iter Key.pretty (fun fmt v -> Format.fprintf fmt "@[%a@]" V.pretty v) fmt tree let empty = Empty (* Tags must be > 0, as we use 0 for the id of Empty. *) let current_tag_before_initial_values = 1 let current_tag = ref current_tag_before_initial_values let initial_values = let tc k v = let b = Compositional_bool.f k v in let tag = !current_tag in incr current_tag; Tag_comp.encode tag b in List.map (function [k,v] -> Leaf (k, v, tc k v) | [] -> Empty | _ -> assert false) Initial_Values.v let rehash_ref = ref (fun _ -> assert false) module D = Datatype.Make_with_collections (struct type t = hptmap let name = "(" ^ Key.name ^ ", " ^ V.name ^ ") ptmap" open Structural_descr let r = Recursive.create () let structural_descr = t_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 = hash_generic 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 D.ty None include (D: Datatype.S_with_collections with type t := t) module PatriciaHashconsTbl = State_builder.Hashconsing_tbl (struct include D (* At this stage, the root of the tree is _not_ hashconsed. The functions below cannot rely on the tags for it, only for the subtrees. *) let hash_internal tr = match tr with | Empty -> 37 | Leaf (k, v, _) -> Key.id k + 547 * V.hash v | Branch(p,m,l,r, _tag) -> m + 3 * p + 2017 * (hash_generic l) + (hash_generic r) (* here, only one of the arguments is hash-consed *) let equal_internal htr1 htr2 = 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 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 id = hash_generic let wrap_Leaf k v = (* The test k < p+m and the implementation of [highest_bit] do not work with negative keys. *) assert (Key.id k >= 0); let b = Compositional_bool.f k v in let tag = !current_tag in let new_tr = Leaf (k, v, Tag_comp.encode tag b) in let result = PatriciaHashconsTbl.merge new_tr in if result == new_tr then current_tag := (succ tag) land max_int ; result let wrap_Branch p m l r = let b = Compositional_bool.compose (compositional_bool l) (compositional_bool r) in let tag = !current_tag in let new_tr = Branch (p, m, l, r, Tag_comp.encode tag b) in let result = PatriciaHashconsTbl.merge new_tr in if result == new_tr then current_tag := (succ tag) land max_int ; result (* This reference will contain a list of functions that will clear all the transient caches used in this module *) let clear_caches = ref [] (* 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] below, 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 (* [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 (* Similar to [find], but checks the prefix found at the current node *) let find_check_missing 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 (prefix, mask, tree0, tree1, _) -> if match_prefix id prefix mask then find (if (id land mask) = 0 then tree0 else tree1) else raise Not_found in find htr let find_key key htr = let id = Key.id key in let rec find htr = match htr with | Empty -> raise Not_found | Leaf (key', _, _) -> if Key.equal key key' then key' else raise Not_found | Branch (prefix, mask, tree0, tree1, _) -> if match_prefix id prefix mask then find (if (id land mask) = 0 then tree0 else tree1) else raise Not_found 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 (prefix, mask, tree0, tree1, _) -> if match_prefix id prefix mask then find (if (id land mask) = 0 then tree0 else tree1) else false 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 let pretty_prefix (p,m) fmt tree = let prettykv fmt k v = Format.fprintf fmt "[@[%a@] -> @[%a@]@]@ " Key.pretty k V.pretty v in 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 = t exception Found_prefix of prefix * subtree * subtree let rec comp_prefixes t1 t2 = assert (t1 != t2); let all_comp = compositional_bool t1 && compositional_bool 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 && (Tag_comp.get_comp 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 = hash let equal_subtree = equal exception Unchanged let add 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 if d == d0 then raise Unchanged else wrap_Leaf k d else join id (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 try add m with Unchanged -> 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 on_singleton f htr = match htr with | Leaf (k, d, _) -> f k d | Empty | Branch _ -> false 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 match_prefix id prefix mask then if (id land mask) = 0 then let rtree0 = remove tree0 in match rtree0 with | Empty -> tree1 | _ -> if rtree0 == tree0 then htr else wrap_Branch prefix mask rtree0 tree1 else let rtree1 = remove tree1 in match rtree1 with | Empty -> tree0 | _ -> if rtree1 == tree1 then htr else wrap_Branch prefix mask tree0 rtree1 else raise Not_found 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 *) 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 rehash_node = function | Empty -> Empty | Leaf (k, v, _) -> wrap_Leaf k v | Branch (p,m,l,r,_) -> if Descr.is_abstract Key.descr then (* The keys id have not been modified during de-marshalling. The shapes of [l] and [r] are compatible, just merge them. *) wrap_Branch p m l r else (* The ids may have been modified, the trees can overlap. Rebuild everything from scratch. *) fold add l r let () = rehash_ref := rehash_node let rec for_all f m = match m with | Empty -> true | Leaf (key, data, _) -> f key data | Branch (_, _, tree0, tree1, _) -> for_all f tree0 && for_all f tree1 let rec exists f m = match m with | Empty -> false | Leaf (key, data, _) -> f key data | Branch (_, _, tree0, tree1, _) -> exists f tree0 || exists f tree1 let rec map f htr = match htr with | Empty -> Empty | Leaf (key, data, _) -> let data' = f data in if data == data' then htr else wrap_Leaf key data' | Branch (p, m, tree0, tree1, _) -> let tree0' = map f tree0 in let tree1' = map f tree1 in if tree0' == tree0 && tree1' == tree1 then htr else wrap_Branch p m tree0' tree1' let rec map' f htr = match htr with | Empty -> Empty | Leaf (key, data, _) -> begin match f key data with | Some data' -> if data == data' then htr else wrap_Leaf key data' | None -> Empty end | Branch (p, m, tree0, tree1, _) -> let tree0' = map' f tree0 and tree1' = map' f tree1 in if tree0' == tree0 && tree1' == tree1 then htr else if tree0' == Empty then tree1' else if tree1' == Empty then tree0' else wrap_Branch p m tree0' tree1' let rec filter f htr = match htr with | Empty -> Empty | Leaf (key, _data, _) -> if f key then htr else Empty | Branch (p, m, tree0, tree1, _) -> let tree0' = filter f tree0 and tree1' = filter f tree1 in if tree0' == tree0 && tree1' == tree1 then htr else if tree0' == Empty then tree1' else if tree1' == Empty then tree0' else wrap_Branch p m tree0' 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 rec inter_with_shape shape map = match shape, map with | Empty, _ | _, Empty -> Empty | Leaf (key1, _, _), Leaf (key2, _, _) -> if Key.equal key1 key2 then map else Empty | Leaf (key, _, _), Branch _ -> begin (* At most [key] will be in the result, search it in [t] *) try let value = find key map in wrap_Leaf key value with Not_found -> Empty end | Branch _, Leaf (key, _, _) -> (* Search key in [shape] *) if mem key shape then map else Empty | 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 = inter_with_shape s0 t0 and u1 = inter_with_shape s1 t1 in if t0 == u0 && t1 == u1 then map else if u0 == Empty then u1 else if u1 == Empty then u0 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 inter_with_shape s0 map else inter_with_shape s1 map 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 inter_with_shape shape t0 else inter_with_shape shape t1 else (* The prefixes disagree. *) Empty let rec from_shape f = function | Empty -> Empty | Leaf (key, value, _) -> wrap_Leaf key (f key value) | Branch (p, m, t1, t2, _) -> wrap_Branch p m (from_shape f t1) (from_shape f t2) module Cacheable = struct type t = hptmap let hash = hash let sentinel = Empty let equal = (==) end module R = struct type t = hptmap let sentinel = Empty end module type I = sig val clear : unit -> unit val merge : (Cacheable.t -> Cacheable.t -> R.t) -> Cacheable.t -> Cacheable.t -> Cacheable.t end (* A (too ?) generic merge. *) let generic_merge ~(cache: Hptmap_sig.cache_type) ~(symmetric: bool) ~(idempotent: bool) ~(increasing: bool) ~(decide_both: key -> v -> t -> v -> t -> t) ~(decide_left: t -> t) ~(decide_right: t -> t) = (* Cache of the merges, depending on [cache] and [symmetric].*) let cache_merge = match cache with | Hptmap_sig.NoCache -> (fun f x y -> f x y) | Hptmap_sig.PersistentCache _name | Hptmap_sig.TemporaryCache _name -> if debug_cache then Format.eprintf "CACHE generic_merge %s@." _name; let module Cache = (val if symmetric then (module Binary_cache.Symmetric_Binary (Cacheable) (R) : I) else (module Binary_cache.Arity_Two (Cacheable) (Cacheable) (R) : I) : I) in if cache = Hptmap_sig.PersistentCache _name then clear_caches := Cache.clear :: !clear_caches; Cache.merge in (* Rewrap of branches. The initials branches and tree are provided in order to avoid the wrapping if the two branches have not been modified. If the merge is increasing, we don't need to test whether the branches are not empty. *) let rewrap p m u orig_u v orig_v orig_tree = if u == orig_u && v == orig_v then orig_tree else wrap_Branch p m u v in let rewrap = if increasing then rewrap else fun p m u orig_u v orig_v orig_tree -> if u == Empty then v else if v == Empty then u else rewrap p m u orig_u v orig_v orig_tree in (* Join two distinct branches. If the merge is increasing, we don't need to test their emptiness. *) let rejoin = if increasing then join else fun p u q v -> if u == Empty then v else if v == Empty then u else join p u q v in (* Called when one of the trees is a leaf [leaf] binding [key] to [data]; the other side is [tree]. [right] is true if the leaf come from the right tree. *) let merge_leaf right = (* [decide_leaf] and [decide_tree] are the actions to perform respectively on the [leaf] and on the [tree] when they are disjoint. If the merge is not symmetric, they depend on the side the leaf comes froms, and similarly for [decide_both] and [cache]. *) let decide_leaf = if right then decide_right else decide_left and decide_tree = if right then decide_left else decide_right and decide_both = if right || symmetric then decide_both else fun k v1 t1 v2 t2 -> decide_both k v2 t2 v1 t1 and cache = if right && not symmetric then fun f s t -> cache_merge (fun t s -> f s t) t s else cache_merge in (* Reminder: [leaf] bind [key] to [data]. *) fun key data leaf tree -> let k_id = Key.id key in let rec merge_leaf tree = cache add leaf tree and add leaf tree = match tree with | Empty -> decide_leaf leaf | Leaf (key', data', _) -> if idempotent && leaf == tree then leaf else if Key.equal key key' then decide_both key data' tree data leaf else let tree' = decide_tree tree and leaf' = decide_leaf leaf in rejoin k_id leaf' (Key.id key') tree' | Branch (p, m, t0, t1, _) -> if match_prefix k_id p m then if (k_id land m) = 0 then let t0' = merge_leaf t0 and t1' = decide_tree t1 in rewrap p m t0' t0 t1' t1 tree else let t1' = merge_leaf t1 and t0' = decide_tree t0 in rewrap p m t0' t0 t1' t1 tree else let tree' = decide_tree tree and leaf' = decide_leaf leaf in rejoin k_id leaf' p tree' in merge_leaf tree in let merge_right_leaf = merge_leaf true and merge_left_leaf = merge_leaf false in let rec merge s t = if idempotent && s == t then s else match s, t with | Empty, Empty -> Empty | Empty, _ -> decide_right t | _, Empty -> decide_left s | Leaf (key, v, _), _ -> merge_left_leaf key v s t | _, Leaf (key, v, _) -> merge_right_leaf key v t s | Branch (p, m, s0, s1, _), Branch (q, n, t0, t1, _) -> let descend = fun s t -> merge_branches s (p, m, s0, s1) t (q, n, t0, t1) in cache_merge descend s t (* Called for the recursive descend in two trees. [s] is [Branch (p, m, s0, s1)] and [t] is [Branch (q, n, t0, t1)]. *) and merge_branches s (p, m, s0, s1) t (q, n, t0, t1) = if (p = q) && (m = n) then (* The trees have the same prefix. Merge their sub-trees. *) let u0 = merge s0 t0 and u1 = merge s1 t1 in rewrap p m u0 s0 u1 s1 s 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 = merge s0 t in let s1_e = decide_left s1 in rewrap p m s0_t s0 s1_e s1 s else let s0_e = decide_left s0 in let s1_t = merge s1 t in rewrap p m s0_e s0 s1_t s1 s 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 = merge s t0 in let e_t1 = decide_right t1 in rewrap q n s_t0 t0 e_t1 t1 t else let s_t1 = merge s t1 in let e_t0 = decide_right t0 in rewrap q n e_t0 t0 s_t1 t1 t else (* The prefixes disagree. *) let u0 = decide_left s and u1 = decide_right t in rejoin p u0 q u1 in merge type empty_action = Neutral | Absorbing | Traversing of (key -> v -> v option) let merge = (* Called when one of the tree is empty *) let decide_none = function | Neutral -> fun t -> t | Absorbing -> fun _ -> Empty | Traversing f -> fun t -> map' f t (* TODO: add a cache? *) in fun ~cache ~symmetric ~idempotent ~decide_both ~decide_left ~decide_right -> let decide_both key value leaf value' leaf' = match decide_both key value value' with | Some v -> if v == value then leaf else if v == value' then leaf' else wrap_Leaf key v | None -> Empty in generic_merge ~cache ~symmetric ~idempotent ~increasing:false ~decide_both ~decide_left:(decide_none decide_left) ~decide_right:(decide_none decide_right) let generic_join ~cache ~symmetric ~idempotent ~decide = let decide_both key value leaf value' leaf' = let v = decide key (Some value) (Some value') in if v == value then leaf else if v == value' then leaf' else wrap_Leaf key v and decide_right = endo_map (fun k v -> decide k None (Some v)) and decide_left = endo_map (fun k v -> decide k (Some v) None) in generic_merge ~cache ~symmetric ~idempotent ~increasing:true ~decide_both ~decide_left ~decide_right let join ~cache ~symmetric ~idempotent ~decide = let decide_both key value leaf value' leaf' = let v = decide key value value' in if v == value then leaf else if v == value' then leaf' else wrap_Leaf key v and decide_none = fun t -> t in generic_merge ~cache ~symmetric ~idempotent ~increasing:true ~decide_both ~decide_left:decide_none ~decide_right:decide_none let inter ~cache ~symmetric ~idempotent ~decide = let decide_both key value leaf value' leaf' = match decide key value value' with | Some v -> if v == value then leaf else if v == value' then leaf' else wrap_Leaf key v | None -> Empty and decide_none = fun _ -> Empty in generic_merge ~cache ~symmetric ~idempotent ~increasing:false ~decide_both ~decide_left:decide_none ~decide_right:decide_none let fold2_join_heterogeneous (type arg) (type result) ~cache ~empty_left ~empty_right ~both ~join ~empty = let cache_merge = match cache with | Hptmap_sig.NoCache -> (fun f x y -> f x y) | Hptmap_sig.PersistentCache _name | Hptmap_sig.TemporaryCache _name -> if debug_cache then Format.eprintf "CACHE fold2_join_heterogeneous %s@." _name; let module Arg = struct type t = (Key.t, arg) tree let hash : t -> int = hash_generic let sentinel : t = Empty let equal : t -> t -> bool = (==) end in let module Result = struct type t = result let sentinel : t = empty end in let module Cache = Binary_cache.Arity_Two(Cacheable)(Arg)(Result) in (match cache with | Hptmap_sig.PersistentCache _ -> clear_caches := Cache.clear :: !clear_caches | _ -> ()); Cache.merge in let rec compute s t = cache_merge aux s t and aux s t = match s, t with | Empty, Empty -> empty | Empty, t -> empty_left t | s, Empty -> empty_right s | Leaf (ks, vs, _), Leaf (kt, vt, _) -> if Key.equal ks kt then both ks vs vt else join (empty_left t) (empty_right s) | Branch (p, m, s0, s1, _), Leaf(kt, _, _) -> let k_id = Key.id kt in if match_prefix k_id p m then if (k_id land m) = 0 then join (compute s0 t) (empty_right s1) else join (compute s1 t) (empty_right s0) else join (empty_right s) (empty_left t) | Leaf (ks, _, _), Branch(q, n, t0, t1, _) -> let k_id = Key.id ks in if match_prefix k_id q n then if (k_id land n) = 0 then join (compute s t0) (empty_left t1) else join (compute s t1) (empty_left t0) else join (empty_right s) (empty_left t) | Branch(p, m, s0, s1, _), Branch(q, n, t0, t1, _) -> if (p = q) && (m = n) then (* The trees have the same prefix. recurse on the sub-trees *) join (compute s0 t0) (compute s1 t1) 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 join (compute s0 t) (empty_right s1) else join (compute s1 t) (empty_right s0) 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 join (compute s t0) (empty_left t1) else join (compute s t1) (empty_left t0) else (* The prefixes disagree. *) join (empty_right s) (empty_left t) in fun s t -> compute s t type decide_fast = Done | Unknown let make_predicate cache_merge exn ~decide_fast ~decide_fst ~decide_snd ~decide_both = let rec aux s t = if decide_fast s t = Unknown 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 aux s l; aux Empty r; end else begin aux Empty l; aux s r; end | Branch (p,m,l,r,_) , Leaf(key, _value, _) -> let i = Key.id key in if i < p+m then begin aux l t; aux r Empty; end else begin aux l Empty; aux r t; end | Branch _, Branch _ -> (* Beware that [cache_merge compute] may swap the order of its arguments compared to [aux]. Do not use the result of the match in [aux] directly inside [compute]. *) 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.*) aux s0 t0; aux 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 aux s0 t; aux s1 Empty; end else begin aux s0 Empty; aux 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 aux s t0; aux Empty t1 end else begin aux s t1; aux Empty t0 end else begin (* The prefixes disagree. *) aux s Empty; aux 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 aux let generic_predicate exn ~cache ~decide_fast ~decide_fst ~decide_snd ~decide_both = if debug_cache then Format.eprintf "CACHE generic_predicate %s@." (fst cache); let module Cache = Binary_cache.Binary_Predicate(Cacheable)(Cacheable) in clear_caches := Cache.clear :: !clear_caches; make_predicate Cache.merge exn ~decide_fast ~decide_fst ~decide_snd ~decide_both let generic_symmetric_predicate exn ~decide_fast ~decide_one ~decide_both = if debug_cache then Format.eprintf "CACHE generic_symmetric_predicate@."; let module Cache = Binary_cache.Symmetric_Binary_Predicate(Cacheable) in clear_caches := Cache.clear :: !clear_caches; make_predicate Cache.merge exn ~decide_fast ~decide_fst:decide_one ~decide_snd:decide_one ~decide_both type predicate_type = ExistentialPredicate | UniversalPredicate type predicate_result = PTrue | PFalse | PUnknown let decide_fast_intersection s t = match s, t with | Empty, _ | _, Empty -> PFalse | _ -> if s == t then PTrue else PUnknown let decide_fast_inclusion s t = if s == t || s == Empty then PTrue else PUnknown let make_binary_predicate cache_merge pt ~decide_fast ~decide_fst ~decide_snd ~decide_both = (** We cannot use [&&] and [||] under another name, as functions are not lazy in OCaml. Instead, we defer the evaluation of the right part by calling a function. Due to typing issues, we must actually define two functions... *) let comb1, comb2 = match pt with | UniversalPredicate -> let f b f v1 v2 = b && f v1 v2 in f, f | ExistentialPredicate -> let f b f v1 v2 = b || f v1 v2 in f, f in let rec aux s t = match s, t with | Empty, Empty -> (match pt with | ExistentialPredicate -> false | UniversalPredicate -> true) | Leaf (key, data, _), Empty -> decide_fst key data | Empty, Leaf (key, data, _) -> decide_snd key data | Empty, Branch (_, _, tl, tr, _) -> comb1 (aux' Empty tl) aux' Empty tr | Branch (_, _, tl, tr, _), Empty -> comb1 (aux' tl Empty) aux' tr Empty | Leaf(k1, v1, _), Leaf(k2, v2, _) -> if Key.id k1 = Key.id k2 then decide_both k1 v1 v2 else comb2 (decide_fst k1 v1) decide_snd k2 v2 | Leaf(key, _value, _), Branch(p,m,l,r,_) -> let i = Key.id key in if i < p+m then comb1 (aux' Empty r) aux' s l else comb1 (aux' Empty l) aux' s r | Branch (p,m,l,r,_) , Leaf(key, _value, _) -> let i = Key.id key in if i < p+m then comb1 (aux' r Empty) aux' l t else comb1 (aux' l Empty) aux' r t | Branch(p, m, s0, s1, _), Branch(q, n, t0, t1, _) -> if (p = q) && (m = n) then (*The trees have the same prefix. Compare their sub-trees.*) comb1 (aux' s0 t0) aux' s1 t1 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 comb1 (aux' s1 Empty) aux' s0 t else comb1 (aux' s0 Empty) aux' s1 t 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 comb1 (aux' s t0) aux' Empty t1 else comb1 (aux' s t1) aux' Empty t0 else (* The prefixes disagree. *) comb1 (aux' s Empty) aux' Empty t and aux' s t = match decide_fast s t with | PFalse -> false | PTrue -> true | PUnknown -> cache_merge aux s t in aux' let binary_predicate ct pt ~decide_fast ~decide_fst ~decide_snd ~decide_both = let cache_merge = match ct with | Hptmap_sig.NoCache -> (fun f x y -> f x y) | Hptmap_sig.PersistentCache _name | Hptmap_sig.TemporaryCache _name -> if debug_cache then Format.eprintf "CACHE binary_predicate %s@." _name; let module Cache = Binary_cache.Binary_Predicate(Cacheable)(Cacheable) in (match ct with | Hptmap_sig.PersistentCache _ -> clear_caches := Cache.clear :: !clear_caches | _ -> ()); Cache.merge in make_binary_predicate cache_merge pt ~decide_fast ~decide_fst ~decide_snd ~decide_both let symmetric_binary_predicate ct pt ~decide_fast ~decide_one ~decide_both = let cache_merge = match ct with | Hptmap_sig.NoCache -> (fun f x y -> f x y) | Hptmap_sig.PersistentCache _name | Hptmap_sig.TemporaryCache _name -> if debug_cache then Format.eprintf "CACHE symmetric_binary_predicate %s@." _name; let module Cache = Binary_cache.Symmetric_Binary_Predicate(Cacheable) in (match ct with | Hptmap_sig.PersistentCache _ -> clear_caches := Cache.clear :: !clear_caches | _ -> ()); Cache.merge in make_binary_predicate cache_merge pt ~decide_fast ~decide_fst:decide_one ~decide_snd:decide_one ~decide_both let cached_fold ~cache_name ~temporary ~f ~joiner ~empty = if debug_cache then Format.eprintf "CACHE cached_fold %s@." cache_name; let cache_size = Binary_cache.cache_size in let cache = Array.make cache_size (Empty, empty) in let hash t = abs (hash t mod cache_size) in let reset () = Array.fill cache 0 cache_size (Empty, empty) in if not temporary then clear_caches := reset :: !clear_caches; fun m -> let rec traverse t = let mem result = cache.(hash t) <- (t, result); result in let find () = let t', r = cache.(hash t) in if equal t t' then r else raise Not_found in match t with | Empty -> empty | Leaf(key, value, _) -> (try find () with Not_found -> mem (f key value) ) | Branch(_p, _m, s0, s1, _) -> try find () with Not_found -> let result0 = traverse s0 in let result1 = traverse s1 in mem (joiner result0 result1) 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 (** [union m1 m2] returns the union of the maps [m1] and [m2]. Bindings in [m2] take precedence over those in [m1]. *) let union = join ~cache:Hptmap_sig.NoCache ~symmetric:false ~idempotent:true ~decide:(fun _ _ d -> d) 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, _) -> (* TODO: this function is suboptimal because it recurses even when the key will never be found: missing [if match_prefix id prefix mask then] *) 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 shape x = ((x : t) :> V.t shape) let clear_caches () = List.iter (fun f -> f ()) !clear_caches end (* Local Variables: compile-command: "make -C .." End: *) frama-c-Phosphorus-20170501/src/libraries/utils/bitvector.ml0000644000175000017500000002456213113745001022631 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 --- *) (* ------------------------------------------------------------------------ *) (* Notes: - Bits are counted from 0, in string order, then from least to most significant. For instance the value of bit 11 is tested with (s.[1] land (1 lsl 3) == 0) - Strings can store more bits than the bitvector they represent; for instance a bitvector of size 11 is stored in a 2-bytes string. We (currently) do not store the actual size of the bitvector, which has to be provided in some informations (such as concat). We rely on the invariant that the extra bits are set to 0 (this is important e.g. for equality testing). An alternative design could have been not to explicitly ignore these extra bits in operations that are sensitive to them, but this seems more error-prone. *) type t = bytes let max_size = 1 lsl 20 let ( <-< ) a b = char_of_int (((int_of_char a) lsl b) land 255);; let ( >-> ) a b = char_of_int ((int_of_char a) lsr b);; let ( ||| ) a b = char_of_int ((int_of_char a) lor (int_of_char b));; let ( &&& ) a m = char_of_int ((int_of_char a) land m);; (* Imperatively unset the extra trailing bits *) let clean_trail size bv = let last = (size + 7) / 8 - 1 in assert (last < Bytes.length bv); let r = size land 7 in if r > 0 then (let mask = 1 lsl r - 1 in Bytes.set bv last (Bytes.get bv last &&& mask)) ; for i = last + 1 to Bytes.length bv - 1 do Bytes.set bv i '\000' ; done ; bv ;; let capacity s = Bytes.length s * 8 let create n = let s = (n + 7) lsr 3 in (* rounded-up division *) if s > max_size then raise (Invalid_argument "Bitvector.create") ; Bytes.make s '\000' let resize n s = let u = create n in Bytes.blit s 0 u 0 (min (Bytes.length s) (Bytes.length u)) ; clean_trail n u let create_set n = let s = (n + 7) lsr 3 in (* rounded-up division *) if s > max_size then raise (Invalid_argument "Bitvector.create") ; let copy = Bytes.make s (char_of_int 255) in let r = n land 7 in (* Set only the last r bits in the last byte. *) if r != 0 then Bytes.set copy (s-1) (char_of_int ((1 lsl r) - 1)); copy ;; 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 Bytes.length s - 1 do if i > 0 then Format.pp_print_space fmt () ; pp_elts fmt (int_of_char (Bytes.get s i)) ; done let is_empty s = try for i=0 to Bytes.length s - 1 do if Bytes.get s i <> '\000' then raise Exit ; done ; true with Exit -> false let set s k = let p = k lsr 3 in if p >= Bytes.length s then raise (Invalid_argument "Bitvector.set") ; let r = k land 7 in let b = int_of_char (Bytes.get s p) lor (1 lsl r) in Bytes.set s p (char_of_int b) let clear s k = let p = k lsr 3 in if p >= Bytes.length s then raise (Invalid_argument "Bitvector.clear") ; let r = k land 7 in let b = int_of_char (Bytes.get s p) land (lnot (1 lsl r)) in Bytes.set s p (char_of_int b) let mem s k = let p = k lsr 3 in if p >= Bytes.length s then raise (Invalid_argument "Bitvector.mem") ; let r = k land 7 in int_of_char (Bytes.get s p) land (1 lsl r) <> 0 let once s k = let p = k lsr 3 in if p >= Bytes.length s then raise (Invalid_argument "Bitvector.once") ; let r = k land 7 in let b0 = int_of_char (Bytes.get s p) in let b1 = b0 lor (1 lsl r) in if b0 = b1 then false else (Bytes.set s p (char_of_int b1); true) let bnot size s = let len = (size + 7) / 8 in let copy = Bytes.make (Bytes.length s) '\000' in for i = 0 to len-1 do Bytes.set copy i (char_of_int ((lnot (int_of_char (Bytes.get s i))) land 255)) done; clean_trail size copy ;; (* Internal; this function does not clean the trail for operations that do not need it. *) let bitwise_bop bop a b = assert ((Bytes.length a) = (Bytes.length b)); let copy = Bytes.make (Bytes.length a) '\000' in for i = 0 to (Bytes.length a) - 1 do Bytes.set copy i (char_of_int (255 land (bop (int_of_char (Bytes.get a i)) (int_of_char (Bytes.get b i))))); done; copy let band _ = bitwise_bop (land);; let bor _ = bitwise_bop (lor);; let bxor _ = bitwise_bop (lxor);; let beq size a b = let bv = bitwise_bop (fun x y -> lnot (x lxor y)) a b in clean_trail size bv ;; let bitwise_op2 size op2 a b = let len = Bytes.length a in assert (len = (Bytes.length b)); let copy = Bytes.make len '\000' in for i = 0 to len - 1 do Bytes.set copy i (char_of_int (255 land (op2 (int_of_char (Bytes.get a i)) (int_of_char (Bytes.get b i))))) done; clean_trail size copy ;; let bitwise_op3 size op3 a b c = let len = Bytes.length a in assert (len = (Bytes.length b)); assert (len = (Bytes.length c)); let copy = Bytes.make len '\000' in for i = 0 to len - 1 do Bytes.set copy i (char_of_int (255 land (op3 (int_of_char (Bytes.get a i)) (int_of_char (Bytes.get b i)) (int_of_char (Bytes.get c i))))); done; clean_trail size copy ;; let bitwise_op4 size op4 a b c d = let len = Bytes.length a in assert (len = (Bytes.length b)); assert (len = (Bytes.length c)); assert (len = (Bytes.length d)); let copy = Bytes.make len '\000' in for i = 0 to len - 1 do Bytes.set copy i (char_of_int (255 land (op4 (int_of_char (Bytes.get a i)) (int_of_char (Bytes.get b i)) (int_of_char (Bytes.get c i)) (int_of_char (Bytes.get d i))))); done; clean_trail size copy ;; let equal = (=);; (* String equality. *) let compare = Pervasives.compare let hash = Hashtbl.hash let concat bv1 size1 bv2 size2 = let len1 = size1 / 8 in let str1 = (size1 + 7) / 8 in let str2 = (size2 + 7) / 8 in assert (str1 <= Bytes.length bv1); assert (str2 <= Bytes.length bv2); let newlen = (size1 + size2 + 7) / 8 in let copy = Bytes.create newlen in Bytes.blit bv1 0 copy 0 len1 ; let fst_bits = size1 land 7 in let snd_bits = 8 - fst_bits in (* Byte-aligned case. *) if fst_bits = 0 then (Bytes.blit bv2 0 copy len1 str2; copy) (* Not aligned. *) else let rec loop prev_byte i = let j = len1 + i in if i <= str2 - 1 then (Bytes.set copy j (prev_byte ||| (Bytes.get bv2 i <-< fst_bits)); loop (Bytes.get bv2 i >-> snd_bits) (i+1)) else if j < newlen then Bytes.set copy j (Bytes.get bv2 (str2-1) >-> snd_bits) else () in loop (Bytes.get bv1 len1) 0; clean_trail (size1+size2) copy;; let iter_true f s = for p = 0 to Bytes.length s - 1 do let x = int_of_char (Bytes.get s p) in if x <> 0 then let q = p lsl 3 in for r = 0 to 7 do if x land (1 lsl r) <> 0 then f (q+r) done done let fold_true f init s = let r = ref init in iter_true (fun i -> r := f !r i) s; !r exception Result of int let find_next_true s k = let p = k lsr 3 in if p >= Bytes.length s then raise Not_found; let x = int_of_char (Bytes.get s p) in let r = k land 7 in try begin for r' = r to 7 do if x land (1 lsl r') <> 0 then raise (Result ((p lsl 3) lor r')) done; for p' = (p+1) to (Bytes.length s - 1) do let x = int_of_char (Bytes.get s p') in if x <> 0 then for r' = 0 to 7 do if x land (1 lsl r') <> 0 then raise (Result ((p' lsl 3) lor r')) done done; raise Not_found end with Result res -> res ;; 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 (Bytes.get s p0) lor high.(i-1) in Bytes.set 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 (Bytes.get s q0) lor low.(j) in Bytes.set s q0 (char_of_int x) ; pred q0 in for i=p to q do Bytes.set s i '\255' done ;; frama-c-Phosphorus-20170501/src/libraries/utils/c_bindings.c0000644000175000017500000001507513113745007022546 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2017 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* you can redistribute it and/or modify it under the terms of the GNU */ /* Lesser General Public License as published by the Free Software */ /* Foundation, version 2.1. */ /* */ /* It is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Lesser General Public 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/fail.h" #include #include #include #include #include // Some BSD flavors do not implement all of C99 #if defined(__OpenBSD__) || defined(__NetBSD__) # include # 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 #endif #include #include // Must be synchronized with Floating_point.c_rounding_mode typedef enum { FE_ToNearest, FE_Upward, FE_Downward, FE_TowardZero } c_rounding_mode_t; value c_round(value d) { return caml_copy_double(round(Double_val(d))); } value c_trunc(value d) { return caml_copy_double(trunc(Double_val(d))); } /* NOTE: The single-precision functions below (expf, logf, etc.) need the 'volatile' modifier due to odd behaviors detected in Ubuntu 12.04 (precise32), with gcc 4.6.3 and glibc 2.15. In those machines, the absence of volatile leads gcc to optimize the call to a double-precision result and, despite the use of 'float' and casts (which should force the result to be truncated to 32 bits), the 64-bit result is propagated back to OCaml, leading to non-zero bits beyond the 32-bit range, which cause FRange.check_representability to fail, leading to errors in tests/float/math_builtins.c. This behavior has not been observed in more recent distributions. */ value c_expf(value d) { float f = Double_val(d); volatile float res = expf(f); // see remarks above return caml_copy_double(res); } value c_logf(value d) { float f = Double_val(d); volatile float res = logf(f); // see remarks above return caml_copy_double(res); } value c_log10f(value d) { float f = Double_val(d); volatile float res = log10f(f); // see remarks above return caml_copy_double(res); } value c_powf(value x, value y) { float fx = Double_val(x); float fy = Double_val(y); volatile float res = powf(fx, fy); // see remarks above return caml_copy_double(res); } value c_sqrtf(value d) { float f = Double_val(d); volatile float res = sqrtf(f); // see remarks above return caml_copy_double(res); } value compare_strings(value v1, value v2, value vlen) { if (memcmp(String_val(v1), String_val(v2), Long_val(vlen)) == 0) return Val_true; else return Val_false; } 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; } value set_round_toward_zero(value dummy) { fesetround(FE_TOWARDZERO); return Val_unit; } value get_rounding_mode(value dummy) { switch (fegetround()) { case FE_TONEAREST: return Val_int(FE_ToNearest); case FE_DOWNWARD: return Val_int(FE_Downward); case FE_UPWARD: return Val_int(FE_Upward); case FE_TOWARDZERO: return Val_int(FE_TowardZero); } caml_failwith("illegal rounding mode (should never happen)"); } value set_rounding_mode(value rm) { int new_rm; switch (Int_val(rm)) { case FE_ToNearest: new_rm = FE_TONEAREST; break; case FE_Downward: new_rm = FE_DOWNWARD; break; case FE_Upward: new_rm = FE_UPWARD; break; case FE_TowardZero: new_rm = FE_TOWARDZERO; break; default: caml_invalid_argument("set_rounding_mode"); } fesetround(new_rm); return Val_unit; } value float_compare_total(value x, value y) { union { double d; int64_t i; } ux, uy; ux.d = Double_val(x); uy.d = Double_val(y); if (ux.i == uy.i) return Val_int(0); ux.i = ux.i ^ (((uint64_t)(ux.i >> 63))>>1); uy.i = uy.i ^ (((uint64_t)(uy.i >> 63))>>1); if (ux.i < uy.i) return Val_int(-1); else return Val_int(1); } value float_is_negative(value v) { union { double d; uint64_t i; } uv; uv.d = Double_val(v); return (Val_int((int)((uv.i) >> 63))); } /* Some compilers apply the C90 standard strictly 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 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; } value ml_usleep(value v) { usleep( Int_val(v) ); return Val_unit ; } frama-c-Phosphorus-20170501/src/libraries/utils/escape.mli0000644000175000017500000001222713113745010022234 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-Phosphorus-20170501/src/libraries/utils/vector.ml0000644000175000017500000001014613113745011022124 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Extensible Array --- *) (* -------------------------------------------------------------------------- *) type 'a t = { dumb : 'a ; mutable elt : 'a array ; mutable top : int ; } let create () = { dumb = Obj.magic (ref ()) ; top = 0 ; (* Invariant top <= length elt *) elt = [| |] ; (* Invariant elt.(k) == dump for top <= k *) } (* Requires n > length elt *) let do_grow w n = begin let elt = Array.make n w.dumb in Array.blit w.elt 0 elt 0 w.top ; w.elt <- elt ; end (* Requires 0 <= n < length elt *) let do_shrink w n = begin w.elt <- Array.sub w.elt 0 n ; if n < w.top then w.top <- n ; end let resize w n = let m = Array.length w.elt in if 0 <= n && n < m then do_shrink w n else if n > m then do_grow w n let shrink w = resize w w.top let size w = w.top let length w = w.top let capacity w = Array.length w.elt let get w k = if 0 <= k && k < w.top then w.elt.(k) else raise Not_found let set w k e = if 0 <= k && k < w.top then w.elt.(k) <- e else raise Not_found let addi w e = let k = w.top in let s = Array.length w.elt in if s <= k then do_grow w (max 1 (2*s)) ; w.top <- succ w.top ; w.elt.(k) <- e ; k let add w e = ignore (addi w e) let clear w = begin w.top <- 0 ; Array.fill w.elt 0 (Array.length w.elt) w.dumb ; end let iter f w = for k = 0 to w.top - 1 do f w.elt.(k) done let iteri f w = for k = 0 to w.top - 1 do f k w.elt.(k) done let map f w = { dumb = Obj.magic w.dumb ; top = w.top ; elt = Array.init w.top (fun i -> f w.elt.(i)) ; } let mapi f w = { dumb = Obj.magic w.dumb ; top = w.top ; elt = Array.init w.top (fun i -> f i w.elt.(i)) ; } let find w ?default ?(exn=Not_found) k = if 0 <= k && k < w.top then w.elt.(k) else match default with | None -> raise exn | Some e -> e let update w ?default k e = let exn = Invalid_argument "Vector.update" in if k < 0 then raise exn ; if k >= w.top then begin let n = succ k in let s = Array.length w.elt in if s <= k then do_grow w (max n (2*s)) ; if k > w.top then begin match default with | None -> raise exn | Some e -> Array.fill w.elt w.top (k-w.top) e ; end ; w.top <- n ; end ; w.elt.(k) <- e let of_array e = { dumb = Obj.magic (ref ()) ; elt = Array.copy e ; top = Array.length e ; } let to_array w = Array.sub w.elt 0 w.top frama-c-Phosphorus-20170501/src/libraries/utils/bag.ml0000644000175000017500000001321413113745001021351 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 [] let rec sort cmp = function | Empty -> [] | Elt x -> [x] | Add(x,t) -> List.merge cmp [x] (sort cmp t) | App(t,x) -> List.merge cmp (sort cmp t) [x] | List ys -> List.stable_sort cmp ys | Concat(a,b) -> List.merge cmp (sort cmp a) (sort cmp b) frama-c-Phosphorus-20170501/src/libraries/utils/wto.ml0000644000175000017500000001632713113745012021443 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 'n component = | Component of 'n * 'n partition | Node of 'n and 'n partition = 'n component list let node n = Node(n) (* Bourdoncle's WTO algorithm builds on Tarjan's SCC algorithm. In Tarjan: - We visit every node once, starting from root, by following the successors; this creates a spanning tree of the graph. SCCs are subtrees of this spanning tree, whose root is the head of the SCC (although in non-natural SCCs, it is possible to enter into a SCC without going through the head). - This spanning tree is obtained using DFS. What DFS guarantees is that there is no path from a child c of a node n to other children of n, provided that there is no path from c to an ancestor of n. Thus when we visit other children of n, we know that they are no path to them from the descendants of c. - We assign consecutive numbers to each node in the order in which they have been visited. As the iteration is depth-first search, this gives a depth-first numbering (DFN). - Each time we visit a node n, we push it on a stack. After the visit, n is popped, unless a path exists from n to an element earlier on the stack. So the stack contains elements currently visited or that belongs to a non-trivial scc. Moreover, they are in topological order. About the proof of Tarjan: http://ls2-www.cs.uni-dortmund.de/~wegener/papers/connected.pdf *) module Make(N:sig type t (* = int *) val equal: t -> t -> bool val hash: t -> int val pretty: Format.formatter -> t -> unit (* val succ: t -> t list *) end) = struct module DFN = Hashtbl.Make(N);; type state = { dfn: int DFN.t; (* Mapping from nodes to its dfn, depth-first numbering. Note that we replaced the DFN=0 test by presence in the Hashtable. *) mutable num: int; (* Number of visited nodes. *) succs: N.t -> (N.t list); (* Successors transition. *) stack: N.t Stack.t } (* Visit [vertex], and all the vertices reachable from [vertex] which have not been explored yet (this is a depth-first search). Also gives [partition], which is the partition built so far Returns a pair (lowlink,partition) where - [lowlink] is the deepest node in the stack, that is the successor of an explored node (i.e. a node which is below than [vertex] in the spanning tree built by the DFS); - [partition] is returned completed. Except for the call to component, and changing the DFN of vertex to max_int, this function exactly performs Tarjan's SCC algorithm. *) let rec visit state vertex partition = Stack.push vertex state.stack; let n = state.num + 1 in state.num <- n; DFN.replace state.dfn vertex n; let succs = state.succs vertex in let (head,loop,partition) = List.fold_left (fun (head,loop,partition) succ -> let (min,partition) = (* If already visited. *) if DFN.mem state.dfn succ (* Is another branch, which can have been visited before or after [vertex]. *) then (succ,partition) else visit state succ partition in (* OPTIM: On doit pouvoir sauvegarder le dfn de head et min pour gagner des lookups. *) assert (DFN.mem state.dfn min); assert (DFN.mem state.dfn head); (* If an element below in the spanning tree links to deepest in the stack than [vertex]. *) if (DFN.find state.dfn min) <= (DFN.find state.dfn head) then (min,true,partition) else (head,loop,partition) ) (vertex,false,partition) succs in (* If no element below in the spanning tree link to deepest than [vertex]. *) if N.equal head vertex then begin (* Makes edges to [vertex] invisible in the second visit. *) DFN.replace state.dfn vertex max_int; let element = Stack.pop state.stack in (* If an element below in the spanning tree links to [vertex], which is the head of the SCC. *) if loop then begin let rec loop element = if not @@ N.equal element vertex then begin (* Remove from DFN for a second visit. *) DFN.remove state.dfn element; loop (Stack.pop state.stack) end else () in loop element; (head,component state vertex::partition) end else (head,node vertex::partition) end (* [vertex] is part of a strongly connected component, and is not the root. Do not update partition; the vertex will be added in the next call to [component]. *) else (head,partition) (* We found a SCC; revisit it with the [edge] to its head made invisible. *) and component state vertex = let succs = state.succs vertex in let partition = List.fold_left (fun partition succ -> (* Select only the branches of the spanning tree which are in a SCC with [vertex]; and which have been removed from the DFN by [visit]. *) if DFN.mem state.dfn succ then partition else let (_,part) = visit state succ partition in part ) [] succs in Component(vertex,partition) ;; let partition ~init ~succs = let state = {dfn = DFN.create 17; num = 0; succs; stack = Stack.create () } in snd @@ visit state init [] ;; (* Follow's Bourdoncle convention *) let rec pretty_partition fmt part = List.iter (fun x -> Format.fprintf fmt "@ %a" pretty_component x) part and pretty_component fmt = function | Node n -> N.pretty fmt n | Component(head,part) -> Format.fprintf fmt "@[(%a%a)@]" N.pretty head pretty_partition part end frama-c-Phosphorus-20170501/src/libraries/utils/unicode.ml0000644000175000017500000000340513113745004022252 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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" let emptyset_string () = if Kernel.Unicode.get () then Utf8_logic.emptyset else "EMPTY_SET" frama-c-Phosphorus-20170501/src/libraries/utils/qstack.ml0000644000175000017500000001036113113745002022107 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/utils/command.mli0000644000175000017500000001355313113745006022422 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. *) (* ************************************************************************* *) (** {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 : bytes -> 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. Recommended size is [2048]. @modify Silicon-20161101 [buffer] has now type [bytes] instead of [string] *) 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 elapsed 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-Phosphorus-20170501/src/libraries/utils/utf8_logic.ml0000644000175000017500000000627313113745005022676 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* 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 Bytes.unsafe_set s pos (Char.unsafe_chr c) else begin Bytes.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 Bytes.unsafe_set s (pos+i) (Char.unsafe_chr (((c lsr ((len-1-i)*6)) land 0x3f) lor 0x80)) done ; end ; len in let s = Bytes.create 6 in let len = write_unichar s ~pos:0 n in Bytes.sub s 0 len |> Bytes.to_string 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 emptyset = from_unichar 0x2205 let boolean = from_unichar 0x1D539 let integer = from_unichar 0x2124 let real = from_unichar 0x211D (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/utils/escape.ml0000644000175000017500000001203613113745007022067 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-Phosphorus-20170501/src/libraries/utils/rgmap.ml0000644000175000017500000001140413113745002021726 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 entry = int * int * 'a (* Entries are stored in slices of increasing width. In a given slice, all entries have the same width, hence a total order is available for each slice. Lookup for any entry applying to some range inside a given slice only needs to check for subset _vs_ disjoint ranges. This can be implemented by a comparison order over ranges making included ranges equal: if two ranges are not included one in the other, they can be ordered. Finding entries covering a range in the entire map can then be performed by looking for the first applying entry in increasing width. The global complexity for lookup is around [log(n)^2], whereas insertion is only [log(n)]. To evaluate complexity, take for instance the full binary tree of integers in range [0..n], with [n=2^N]. Consider one entry for each node of the tree, ranging all the integers it contains. There are [N] slices, with slice [i] having [2^(N-i)] entries of width [2^i]. Lookup in each slice has logarithmic time, ie. [n-i]. Hence, global lookup has complexity [N^2]. *) module Wmap = Map.Make (struct type t = int let compare (a:t) (b:t) = Pervasives.compare a b end) module Rmap = Map.Make (struct type t = int * int (* makes included ranges equal *) let compare (a,b:t) (c,d:t) = (* Six cases to consider: 1. [a;b;c;d] -1 2. [a;c;b;d] -1 3. [a;c;d;b] =0 4. [c;a;b;d] =0 5. [c;a;d;b] +1 6. [c;d;a;b] +1 *) if a < c then (* 1-2-3 *) if b < d then (* 1-2 *) -1 else (* 3 *) 0 else if c < a then (* 4-5-6 *) if d < b then (* 5-6 *) 1 else (* 4 *) 0 else (* have a=c ; then b <= d -> 4, and d <= b -> 3 *) 0 end) type 'a t = 'a entry Rmap.t Wmap.t let range (p,q,_) = (p,q) let width (p,q,_) = q-p (* interval width minus one *) let empty = Wmap.empty let add ?(overlap=false) entry rmap = let w = width entry in if 0 <= w then let rg = range entry in let offsets = try let m = Wmap.find w rmap in if overlap && w > 1 then let (a,b) = rg in Rmap.remove (a,a) (Rmap.remove (b,b) m) else m with Not_found -> Rmap.empty in Wmap.add w (Rmap.add rg entry offsets) rmap else rmap exception Found ;; let find a b rmap = let rg = a,b in let width = b-a in let found = ref None in begin try Wmap.iter (fun w offsets -> if width <= w then try found := Some (Rmap.find rg offsets) ; raise Found with Not_found -> ()) rmap with Found -> () end ; match !found with | None -> raise Not_found | Some entry -> entry let find_all a b rmap = let rg = a,b in let width = b-a in let found = ref [] in begin try Wmap.iter (fun w offsets -> if width <= w then try let e = Rmap.find rg offsets in found := e :: !found with Not_found -> ()) rmap with Found -> () end ; List.rev !found let iter f rmap = Wmap.iter (fun _ ofs -> Rmap.iter (fun _ e -> f e) ofs) rmap frama-c-Phosphorus-20170501/src/libraries/utils/floating_point.mli0000644000175000017500000001136513113745003024014 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. *) (** Rounding modes defined in the C99 standard. *) type c_rounding_mode = FE_ToNearest | FE_Upward | FE_Downward | FE_TowardZero val string_of_c_rounding_mode : c_rounding_mode -> string (* replace "noalloc" with [@@noalloc] for OCaml version >= 4.03.0 *) [@@@ warning "-3"] external set_round_downward : unit -> unit = "set_round_downward" "noalloc" external set_round_upward : unit -> unit = "set_round_upward" "noalloc" external set_round_nearest_even : unit -> unit = "set_round_nearest_even" "noalloc" external set_round_toward_zero : unit -> unit = "set_round_toward_zero" "noalloc" external get_rounding_mode: unit -> c_rounding_mode = "get_rounding_mode" "noalloc" external set_rounding_mode: c_rounding_mode -> unit = "set_rounding_mode" "noalloc" [@@@ warning "+3"] external round_to_single_precision_float: float -> float = "round_to_float" val max_single_precision_float: float val most_negative_single_precision_float: float val min_denormal: float val neg_min_denormal: float val min_single_precision_denormal: float val neg_min_single_precision_denormal: 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 parse_kind: Cil_types.fkind -> string -> parsed_float val pretty_normal : use_hex : bool -> Format.formatter -> float -> unit val pretty : Format.formatter -> float -> unit type sign = Neg | Pos exception Float_Non_representable_as_Int64 of sign 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. *) (** binary representation of -DBL_MAX and DBL_MAX as 64 bits signed integers *) val bits_of_max_double : Integer.t val bits_of_most_negative_double : Integer.t (** binary representation of -FLT_MAX and FLT_MAX as 32 bits signed integers *) val bits_of_max_float : Integer.t val bits_of_most_negative_float : Integer.t (** Rounds to nearest integer, away from zero (like round() in C). *) external fround: float -> float = "c_round" (** Rounds to integer, toward zero (like trunc() in C). *) external trunc: float -> float = "c_trunc" (** Single-precision (32-bit) floating-point wrappers *) external expf: float -> float = "c_expf" external logf: float -> float = "c_logf" external log10f: float -> float = "c_log10f" external powf: float -> float -> float = "c_powf" external sqrtf: float -> float = "c_sqrtf" (** Auxiliary functions similar to the ones in the C math library *) val isnan : float -> bool val isfinite : float -> bool val nextafter : float -> float -> float val nextafterf : float -> float -> float (* Local Variables: compile-command: "make -C ../../.. byte" End: *) frama-c-Phosphorus-20170501/src/libraries/utils/floating_point.ml0000644000175000017500000003440213113745012023640 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 c_rounding_mode = FE_ToNearest | FE_Upward | FE_Downward | FE_TowardZero let string_of_c_rounding_mode = function | FE_ToNearest -> "FE_NEAREST" | FE_Upward -> "FE_UPWARD" | FE_Downward -> "FE_DOWNWARD" | FE_TowardZero -> "FE_TOWARDZERO" (* replace "noalloc" with [@@noalloc] for OCaml version >= 4.03.0 *) [@@@ warning "-3"] external set_round_downward: unit -> unit = "set_round_downward" "noalloc" external set_round_upward: unit -> unit = "set_round_upward" "noalloc" external set_round_nearest_even: unit -> unit = "set_round_nearest_even" "noalloc" external set_round_toward_zero : unit -> unit = "set_round_toward_zero" "noalloc" external get_rounding_mode: unit -> c_rounding_mode = "get_rounding_mode" "noalloc" external set_rounding_mode: c_rounding_mode -> unit = "set_rounding_mode" "noalloc" [@@@ warning "+3"] external round_to_single_precision_float: float -> float = "round_to_float" external sys_single_precision_of_string: string -> float = "single_precision_of_string" (* TODO two functions above: declare "float", must have separate version for bytecode, see OCaml manual *) 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); (* Format.printf "make_float: num den exp:@\n%a@\n@\n%a@\n@\n%d@.min_exp:%d max_exp:%d@." Datatype.Integer.pretty num Datatype.Integer.pretty den exp min_exp max_exp; *) 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) || !exp < min_exp 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 (* Format.printf "make_float2: num den exp:@\n%a@\n@\n%a@\n@\n%d@." Datatype.Integer.pretty num Datatype.Integer.pretty den exp; *) if exp > max_exp - man_size 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-round: num den man rem:@\n%a@\n@\n%a@\n@\n%Ld@\n@\n%a@." Datatype.Integer.pretty num Datatype.Integer.pretty den man Datatype.Integer.pretty 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 reg_exp = "[eE][+]?\\(-?[0-9]+\\)" let reg_dot = "[.]" let reg_numopt = "\\([0-9]*\\)" let reg_num = "\\([0-9]+\\)" let numdotfrac = Str.regexp (reg_numopt ^ reg_dot ^ reg_numopt) let numdotfracexp = Str.regexp (reg_numopt ^ reg_dot ^ reg_numopt ^ reg_exp) let numexp = Str.regexp (reg_num ^ reg_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 parse_kind kind string = match kind with | Cil_types.FFloat -> single_precision_of_string string | Cil_types.FDouble | Cil_types.FLongDouble -> double_precision_of_string string 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 || (firstdigit = 0 && decdigits = 0L && exp = -1022) 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 (* should always arrive here with nearest_even *) if get_rounding_mode () <> FE_ToNearest then begin Kernel.failure "pretty: rounding mode (%s) <> FE_TONEAREST" (string_of_c_rounding_mode (get_rounding_mode ())); set_round_nearest_even(); end; 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 type sign = Neg | Pos exception Float_Non_representable_as_Int64 of sign (* 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 = -9.22337203685477581e+18 (* Int64.to_float (-0x8000000000000000L) *) in let max_64_float = 9.22337203685477478e+18 (* let open Int64 in float_of_bits (pred (bits_of_float (to_float max_int))) *) in fun x -> let max_64_float = Extlib.id max_64_float in if x < min_64_float then raise (Float_Non_representable_as_Int64 Neg); if x > (max_64_float +. max_64_float) then raise (Float_Non_representable_as_Int64 Pos); if x <= max_64_float then Integer.of_int64 (Int64.of_float x) else Integer.add (Integer.of_int64 (Int64.of_float (x +. min_64_float))) (Integer.two_power_of_int 63) let bits_of_max_double = Integer.of_int64 (Int64.bits_of_float max_float) let bits_of_most_negative_double = Integer.of_int64 (Int64.bits_of_float (-. max_float)) (** See e.g. http://www.h-schmidt.net/FloatConverter/IEEE754.html *) let bits_of_max_float = Integer.of_int64 0x7F7FFFFFL let bits_of_most_negative_float = let v = Int64.of_int32 0xFF7FFFFFl in(* cast to int32 to get negative value *) Integer.of_int64 v external fround: float -> float = "c_round" external trunc: float -> float = "c_trunc" (** Single-precision (32-bit) functions. We round the result computed as a double, since float32 functions are rarely precise. *) external expf: float -> float = "c_expf" external logf: float -> float = "c_logf" external log10f: float -> float = "c_log10f" external powf: float -> float -> float = "c_powf" external sqrtf: float -> float = "c_sqrtf" (** C math-like functions *) let isnan f = match classify_float f with | FP_nan -> true | _ -> false let isfinite f = match classify_float f with | FP_nan | FP_infinite -> false | _ -> true let min_denormal = Int64.float_of_bits 1L let neg_min_denormal = -. min_denormal let min_single_precision_denormal = Int32.float_of_bits 1l let neg_min_single_precision_denormal = -. min_single_precision_denormal (* auxiliary functions for nextafter/nextafterf *) let min_denormal_float ~is_f32 = if is_f32 then min_single_precision_denormal else min_denormal let nextafter_aux ~is_f32 fincr fdecr x y = if x = y (* includes cases "(0.0, -0.0) => -0.0" and its symmetric *) then y else if isnan x || isnan y then nan else if x = 0.0 (* or -0.0 *) then if x < y then min_denormal_float is_f32 else -. (min_denormal_float is_f32) (* the following conditions might be simpler if we had unsigned ints (uint32/uint64) *) else if x = neg_infinity (* && y = neg_infinity *) then fdecr x else if (x < y && x > 0.0) || (x > y && x < 0.0) then fincr x else fdecr x let incr_f64 f = Int64.float_of_bits (Int64.succ (Int64.bits_of_float f)) let decr_f64 f = if f = infinity then max_float else Int64.float_of_bits (Int64.pred (Int64.bits_of_float f)) let incr_f32 f = if f = neg_infinity then most_negative_single_precision_float else Int32.float_of_bits (Int32.succ (Int32.bits_of_float f)) let decr_f32 f = if f = infinity then max_single_precision_float else Int32.float_of_bits (Int32.pred (Int32.bits_of_float f)) let nextafter x y = nextafter_aux ~is_f32:false incr_f64 decr_f64 x y let nextafterf x y = nextafter_aux ~is_f32:true incr_f32 decr_f32 x y (* Local Variables: compile-command: "make -C ../../.. byte" End: *) frama-c-Phosphorus-20170501/src/libraries/utils/hook.mli0000644000175000017500000001052713113745012021737 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. @modify Oxygen-20120901 no more [once] optional arg (see [extend_once]) *) val extend_once: (param -> result) -> unit (** Same as [extend], but the hook is added only if it 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 Comparable = sig type t val equal: t -> t -> bool val hash: t -> int val compare: t -> t -> int end (** hook with a notion of priority. @since Neon-20140301 *) module type S_ordered = sig include S type key type id val register_key: key -> id val extend: id -> (param->result)->unit val extend_once: id -> (param->result) -> unit val add_dependency: id -> id -> unit (** [add_dependency hook1 hook2] indicates that [hook1] must be executed before [hook2]. In case of a cycle, all hooks will be executed, but an arbitrary order will be chosen among the elements of the cycle. *) 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 (** @since Neon-20140301 *) module Build_ordered (P: sig module Id:Comparable type t end): S_ordered with type key = P.Id.t and type param = P.t and type result = unit (** @since Neon-20140301 *) module Make_ordered(P:sig module Id:Comparable end): S_ordered with type key = P.Id.t and type param = unit and type result = unit (** @since Neon-20140301 *) module Fold_ordered(P: sig module Id:Comparable type t end): S_ordered with type key = P.Id.t and type param = P.t and type result = P.t (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/utils/hptset.mli0000644000175000017500000000677413113745002022316 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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). *) (** Output signature of the functor {!Set.Make}. *) module type S = sig include Datatype.S_with_collections include FCSet.S_Basic_Compare with type t := t (** The datatype of sets. *) val contains_single_elt: t -> elt option val intersects: t -> t -> bool (** [intersects s1 s2] returns [true] if and only if [s1] and [s2] have an element in common *) type action = Neutral | Absorbing | Traversing of (elt -> bool) val merge : cache:Hptmap_sig.cache_type -> symmetric:bool -> idempotent:bool -> decide_both:(elt -> bool) -> decide_left:action -> decide_right:action -> t -> t -> t type 'a shape (** Shape of the set, ie. the unique shape of its OCaml value. *) val shape: t -> unit shape (** Export the shape of the set. *) val from_shape: 'a shape -> t (** Build a set from another [elt]-indexed map or set. *) val fold2_join_heterogeneous: cache:Hptmap_sig.cache_type -> empty_left:('a shape -> 'b) -> empty_right:(t -> 'b) -> both:(elt -> 'a -> 'b) -> join:('b -> 'b -> 'b) -> empty:'b -> t -> 'a shape -> 'b (** 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 val pretty_debug: t Pretty_utils.formatter end module Make(X: Hptmap.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 and type 'a shape = 'a Hptmap.Shape(X).t val self : State.t end (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/utils/bitvector.mli0000644000175000017500000001006013113745004022771 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (* ------------------------------------------------------------------------ *) (** Bitvectors. @since Carbon-20101201 *) (* ------------------------------------------------------------------------ *) type t val create : int -> t (** Create a vector of [n] bits, with all bits unset. *) val create_set : int -> t (** Create a vector of [n] bits, with all bits set.*) val capacity : t -> int (** Maximum number of bits in the bitvector. *) val resize : int -> t -> t (** A copy of the bitvector up-to or down-to [n] bits. Extra bits up to final bitvector capacity are set to zero. *) val mem : t -> int -> bool val set : t -> int -> unit val clear : t -> int -> unit val once : t -> int -> bool (** return [true] if unset, then set the bit. *) val set_range : t -> int -> int -> unit val is_empty : t -> bool val equal: t -> t -> bool val compare: t -> t -> int val hash: t -> int (** {2 Bitwise Binary Operations} The first argument is the size of the vectors. *) val bnot: int -> t -> t val band: int -> t -> t -> t val bor: int -> t -> t -> t val bxor: int -> t -> t -> t (* bitwise difference *) val beq: int -> t -> t -> t (* bitwise equivalence/equality *) (** {2 Generic Bitwise Operations}. Prefer using these rather than create intermediary bitvectors. *) val bitwise_op2: int -> (int -> int -> int) -> t -> t -> t val bitwise_op3: int -> (int -> int -> int -> int) -> t -> t -> t -> t val bitwise_op4: int -> (int -> int -> int -> int -> int) -> t -> t -> t -> t -> t (** {2 Sized Concatenation} *) val concat: t -> int -> t -> int -> t (** [concat b1 s1 b2 s2] concatenates the [s1] first bits of [b1] with the [s2] first bits of [b2]. *) (** {2 Misc} *) val iter_true : (int -> unit) -> t -> unit (** Iterates on all indexes of the bitvector with their bit set. *) val fold_true : ('a -> int -> 'a) -> 'a -> t -> 'a (** Iterates on all indexes of the bitvector with their bit set. *) val find_next_true: t -> int -> int (** [find_next_true i a] returns the first index greater or equal to [i] with its bit set. To find the first true element, call [find_next_true -1 a]. If no next true element exists, or [i] is larger than the array, then raise [Not_found]. *) 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-Phosphorus-20170501/src/libraries/utils/pretty_utils.ml0000644000175000017500000001717413113745007023406 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 ksfprintf f fmt = let b = Buffer.create 20 in let return fmt = Format.pp_print_flush fmt (); f (Buffer.contents b) in Format.kfprintf return (Format.formatter_of_buffer b) fmt let sfprintf = Format.asprintf let to_string ?margin pp x = let b = Buffer.create 20 in let f = Format.formatter_of_buffer b in Extlib.may (Format.pp_set_margin f) margin; 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 "@]") ?(empty=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 | [] -> Format.fprintf f "%(%)" empty | _ :: _ 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 "@]") ?(empty=format_of_string "") pp_elt f xs = match xs with | [| |] -> Format.fprintf f "%(%)" empty | 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_iter2 ?(pre=format_of_string "@[") ?(sep=format_of_string "") ?(suf=format_of_string "@]") ?(between=format_of_string "@ ") iter pp_key pp_v fmt v = let need_sep = ref false in Format.fprintf fmt pre; iter (fun key v -> if !need_sep then Format.fprintf fmt sep else need_sep := true; Format.fprintf fmt "%a%(%)%a" pp_key key between pp_v v ) v; Format.fprintf fmt suf; ;; let pp_opt ?(pre=format_of_string "@[") ?(suf=format_of_string "@]") ?(none=format_of_string "") pp_elt f = function | None -> Format.fprintf f "%(%)" 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 pp_pair ?(pre=format_of_string "@[") ?(sep=format_of_string ",@,") ?(suf=format_of_string "@]") pp_a pp_b fmt (a, b) = Format.fprintf fmt "%(%)%a%(%)%a%(%)" pre pp_a a sep pp_b b suf 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 "@[%(%)%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 "@[%(%)@[" 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 ("@[@[" ^^ msg) let pp_close_block out msg = Format.fprintf out ("@]@ " ^^ msg ^^ "@]") let pp_trail pp fmt x = begin Format.fprintf fmt "@[(**" ; 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 (* -------------------------------------------------------------------------- *) (* --- Margins --- *) (* -------------------------------------------------------------------------- *) type marger = int ref let marger () = ref 0 let add_margin marger ?(margin=0) ?(min=0) ?(max=80) text = let size = String.length text + margin in let n = Pervasives.min max (Pervasives.max min size) in if n > !marger then marger := n type align = [ `Center | `Left | `Right ] let pp_margin ?(align=`Center) ?(pp=Format.pp_print_string) marger fmt text = let n = String.length text in let m = !marger in if n > m then if m < 8 then pp fmt (String.sub text 0 m) else pp fmt (String.sub text 0 (m-3) ^ "...") else let space fmt s = if s > 0 then Format.pp_print_string fmt (String.make s ' ') in let w = m-n in match align with | `Center -> let l = w / 2 in let r = w - l in space fmt l ; pp fmt text ; space fmt r ; | `Left -> pp fmt text ; space fmt w | `Right -> space fmt w ; pp fmt text let pp_items ?align ?margin ?min ?max ~title ~iter ?pp_title ~pp_item fmt = let m = marger () in iter (fun e -> add_margin m ?margin ?min ?max (title e)) ; let pp = pp_margin ?align ?pp:pp_title m in iter (pp_item pp fmt) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/utils/leftistheap.mli0000644000175000017500000000372313113745007023313 0ustar mehdimehdi(**************************************************************************) (* *) (* Copyright (C) Jean-Christophe Filliatre *) (* *) (* This software is free software; you can redistribute it and/or *) (* modify it under the terms of the GNU Library General Public *) (* License version 2.1, with the special exception on linking *) (* described in file LICENSE. *) (* *) (* This software is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) (* *) (* File modified by CEA (Commissariat à l'énergie atomique et aux *) (* énergies alternatives). *) (* *) (**************************************************************************) (** Leftist heaps. See for instance Chris Okasaki's "Purely Functional Data Structures" *) exception Empty module Make(X: Set.OrderedType) : sig type t val empty: t val is_empty: t -> bool (** runs in O(1) *) val insert: X.t -> t -> t (** runs in O(log n) *) val min: t -> X.t (** runs in O(1) *) val extract_min: t -> X.t * t (** runs in O(log n) *) val merge: t -> t -> t (** runs in O(log max(n1, n2)) *) (* Added by CEA *) val fold: (X.t -> 'a -> 'a) -> t -> 'a -> 'a (** elements are presented in an arbitrary order *) val elements: t -> X.t list (** the returned list is not sorted *) val of_list: X.t list -> t end frama-c-Phosphorus-20170501/src/libraries/utils/json.mli0000644000175000017500000001136413113745006021753 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** Json Library Remarks: - UTF-8 escaping is not supported; - Parsers are less {i strict} than Json format; - Printers are supposed to {i strictly} conforms to Json format; - [Number] can be used to encode non OCaml-primitive numbers, for instance Zarith. *) (** Json Objects *) type t = | Null | True | False | String of string | Number of string | Int of int | Float of float | Array of t list | Assoc of (string * t) list val equal : t -> t -> bool (** Pervasives *) val compare : t -> t -> int (** Pervasives *) val pp : Format.formatter -> t -> unit exception Error of string * int * string (** file, line, message *) (** {2 Constructors} *) val of_bool : bool -> t val of_int : int -> t val of_string : string -> t val of_float : float -> t val of_list : t list -> t val of_array : t array -> t val of_fields : (string * t) list -> t (** {2 Parsers} Parsing raise [Error] in case of error. *) val load_lexbuf : Lexing.lexbuf -> t (** Consumes the entire buffer. *) val load_channel : in_channel -> t (** Parses the stream until EOF. *) val load_string : string -> t (** Parses the Json in the string. *) val load_file : string -> t (** May also raise system exception. *) (** {2 Printers} Printers use formatting unless [~pretty:false]. *) val save_string : ?pretty:bool -> t -> string val save_buffer : ?pretty:bool -> Buffer.t -> t -> unit val save_channel : ?pretty:bool -> out_channel -> t -> unit val save_file : ?pretty:bool -> string -> t -> unit (** {2 Accessors} Accessors raise exception [Invalid_argument] in case of wrong format. *) val bool : t -> bool (** Extract [True] and [False] only. @raise Invalid_argument when the conversion fails. *) val int : t -> int (** Convert [Null], [Int], [Float], [Number] and [String] to an [int]. Floats are truncated with [int_of_float] and [Null] to 0. @raise Invalid_argument when the conversion fails. *) val string : t -> string (** Convert [Null], [Int], [Float], [Number] and [String] to a [string]. Floats are truncated with [string_of_float] and [Null] to [""]. @raise Invalid_argument when the conversion fails. *) val float : t -> float (** Convert [Null], [Int], [Float], [Number] and [String] to [float] and [Null] to [0.0]. @raise Invalid_argument when the conversion fails. *) val array : t -> t array (** Extract the array of an [Array] object. [Null] is considered an empty array. @raise Invalid_argument if the object is not an array. *) val list : t -> t list (** Extract the list of an [Array] object. [Null] is considered an empty list. @raise Invalid_argument if the object is not a list. *) val fold : (string -> t -> 'a -> 'a) -> t -> 'a -> 'a (** Fold over all fields of the object. [Null] is considered an empty object. Typical usage is [fold M.add t M.empty] where [M=Map.Make(String)]. @raise Invalid_argument if the object is not an [Assoc] or [Null] object. *) val field : string -> t -> t (** Lookup a field in an object. [Null] is considered an empty object. @raise Not_found if the field is absent from the object. @raise Invalid_argument if the object is not an [Assoc] or [Null] object. *) frama-c-Phosphorus-20170501/src/libraries/utils/command.ml0000644000175000017500000002173313113745007022251 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 Sys_error _ -> () let safe_close_in inc = try close_in inc with Sys_error _ -> () (* -------------------------------------------------------------------------- *) (* --- 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_flush fout () ; safe_close_out cout with err -> 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 = Bytes.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 let finally () = safe_close_in inc in Extlib.try_finally ~finally job inc let on_out file job = let out = open_out file in let finally () = safe_close_out out in Extlib.try_finally ~finally job out let copy src tgt = on_inc src (fun inc -> on_out tgt (fun out -> bincopy (Bytes.create 2048) inc out)) let read_file file job = let inc = open_in file in let finally () = safe_close_in inc in Extlib.try_finally ~finally job inc 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 let finally () = flush out; safe_close_out out in Extlib.try_finally ~finally job out let print_file file job = write_file file (fun out -> let fmt = Format.formatter_of_out_channel out in let finally () = Format.pp_print_flush fmt () in Extlib.try_finally ~finally job fmt) (* -------------------------------------------------------------------------- *) (* --- 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 _pp_status fmt = function | Unix.WEXITED s -> Format.fprintf fmt "exit[%d]" s | Unix.WSIGNALED s -> Format.fprintf fmt "sig[%d]" s | Unix.WSTOPPED s -> Format.fprintf fmt "stop[%d]" s 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 flush b f = match b with | None -> () | Some b -> try read_lines f (fun line -> Buffer.add_string b line ; Buffer.add_char b '\n') ; with Sys_error _ -> () (*[LC] return the cancel function *) let cancelable_at_exit job = let later = ref (Some job) in Extlib.safe_at_exit (fun () -> match !later with None -> () | Some job -> job ()) ; fun () -> later := None 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 delete () = begin Extlib.safe_remove inf; Extlib.safe_remove outf; Extlib.safe_remove errf; end in let deleted = cancelable_at_exit delete in let pid = Unix.create_process cmd (Array.append [|cmd|] args) (Unix.descr_of_out_channel inc) (Unix.descr_of_out_channel outc) (Unix.descr_of_out_channel errc) in let killed = cancelable_at_exit begin fun () -> Extlib.terminate_process pid ; Unix.(try ignore (waitpid [] pid) with Unix_error _ -> ()) ; end in safe_close_out inc; safe_close_out outc; safe_close_out errc; let kill () = Extlib.terminate_process pid in let last_result= ref (Not_ready kill) in let wait_flags = if async then [Unix.WNOHANG; Unix.WUNTRACED] else [Unix.WUNTRACED] in begin fun () -> match !last_result with | Result _p as r -> r | Not_ready _ as r -> let child_id,status = Unix.waitpid wait_flags pid in if child_id = 0 then (assert async;r) else begin let result = Result status in flush stdout outf ; flush stderr errf ; delete () ; deleted () ; killed () ; result end end 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 ftimeout = float_of_int timeout in let start = ref (Unix.gettimeofday ()) in let running () = match f () with | Not_ready terminate -> begin try !Db.progress () ; if timeout > 0 && Unix.gettimeofday () -. !start > ftimeout then raise Db.Cancel ; true with Db.Cancel as e -> terminate (); raise e end | Result r -> res := r; false in while running () do Extlib.usleep 100000 (* 0.1s *) 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-Phosphorus-20170501/src/libraries/utils/unicode.mli0000644000175000017500000000327613113745007022434 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 val emptyset_string : unit -> string frama-c-Phosphorus-20170501/src/libraries/utils/wto.mli0000644000175000017500000000610213113745001021600 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** Weak topological orderings (WTOs) are a hierarchical decomposition of the a graph where each layer is topologically ordered and strongly connected components are aggregated and ordered recursively. This is a very convenient representation to describe an evaluation order to reach a fixpoint. *) (** Each component of the graph is either an individual node of the graph (without) self loop, or a strongly connected component where a node is designed as the head of the component and the remaining nodes are given by a list of components topologically ordered. *) type 'n component = | Component of 'n * 'n partition (** A strongly connected component, described by its head node and the remaining sub-components topologically ordered *) | Node of 'n (** A single node without self loop *) (** A list of strongly connected components, sorted topologically *) and 'n partition = 'n component list (** This functor provides the partitioning algorithm constructing a WTO. *) module Make(Node:sig type t val equal: t -> t -> bool val hash: t -> int val pretty: Format.formatter -> t -> unit end):sig (** Implements Bourdoncle "Efficient chaotic iteration strategies with widenings" algorithm to compute a WTO. *) val partition: init:Node.t -> succs:(Node.t -> Node.t list) -> Node.t partition val pretty_partition: Format.formatter -> Node.t partition -> unit val pretty_component: Format.formatter -> Node.t component -> unit end frama-c-Phosphorus-20170501/src/libraries/utils/json.mll0000644000175000017500000002173213113745005021755 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Json Parser/Lexer --- *) (* -------------------------------------------------------------------------- *) { type t = | Null | True | False | String of string | Number of string | Int of int | Float of float | Array of t list | Assoc of (string * t) list let equal = (=) let compare = Pervasives.compare type token = EOF | TRUE | FALSE | NULL | KEY of char | STR of string | INT of string | DEC of string } rule token = parse '\n' { Lexing.new_line lexbuf ; token lexbuf } | [ ' ' '\t' '\r' ] { token lexbuf } | '"' { let buffer = Buffer.create 80 in string buffer lexbuf ; STR(Buffer.contents buffer) } | '-'? [ '0'-'9' ]+ { INT(Lexing.lexeme lexbuf) } | '-'? [ '0'-'9' ]* '.' ['0'-'9']* ( ['e' 'E'] ['-' '+']? ['0'-'9']+ )? { DEC(Lexing.lexeme lexbuf) } | [ '[' ']' '{' '}' ':' ',' ] as c { KEY c } | "true" { TRUE } | "false" { FALSE } | "null" { NULL } | eof { EOF } | _ { failwith "un-recognised token" } and string buffer = parse | '"' { () } | "\\\\" { Buffer.add_char buffer '\\' ; string buffer lexbuf } | "\\n" { Buffer.add_char buffer '\n' ; string buffer lexbuf } | "\\t" { Buffer.add_char buffer '\t' ; string buffer lexbuf } | "\\r" { Buffer.add_char buffer '\r' ; string buffer lexbuf } | "\\\"" { Buffer.add_char buffer '"' ; string buffer lexbuf } | '\n' | eof { failwith "non-terminated string" } | _ as c { Buffer.add_char buffer c ; string buffer lexbuf } { type input = { lexbuf : Lexing.lexbuf ; mutable token : token ; } let skip input = if input.token <> EOF then input.token <- token input.lexbuf (* Termination hints: - unless EOF, parse_value always eat a token - parse_array always eat a token or call parse_value with non-EOF input - parse_object always eat a token - parse_entry always eat a token or call parse_value with non-EOF input *) let rec parse_value input = match input.token with | EOF -> Null | TRUE -> skip input ; True | FALSE -> skip input ; False | NULL -> skip input ; Null | STR a -> skip input ; String a | INT a -> skip input ; (try Int(int_of_string a) with _ -> Number a) | DEC a -> skip input ; (try Float(float_of_string a) with _ -> Number a) | KEY '[' -> skip input ; Array (parse_array [] input) | KEY '{' -> skip input ; Assoc (parse_object [] input) | _ -> failwith "unexpected token" and parse_array es input = match input.token with | EOF -> failwith "non-terminated array" | KEY ']' -> skip input ; List.rev es | KEY ',' -> skip input ; parse_array es input | _ -> let e = parse_value input in parse_array (e::es) input and parse_object es input = match input.token with | EOF -> failwith "non-terminated record" | KEY '}' -> skip input ; List.rev es | KEY ',' -> skip input ; parse_object es input | STR a -> skip input ; let e = parse_entry a input in parse_object (e::es) input | _ -> failwith "missing name" and parse_entry a input = match input.token with | EOF -> failwith "non-terminated record" | KEY ':' -> skip input ; parse_entry a input | _ -> a , parse_value input let parse_file input = let content = parse_value input in if input.token <> EOF then failwith "unexpected end-of-file" ; content exception Error of string * int * string let error lexbuf msg = let open Lexing in let position = Lexing.lexeme_start_p lexbuf in let token = Lexing.lexeme lexbuf in Error(position.pos_fname,position.pos_lnum, Printf.sprintf "%s (at %S)" msg token) let load_lexbuf lexbuf = try let token = token lexbuf in parse_file { lexbuf ; token } with Failure msg -> raise (error lexbuf msg) let load_string text = load_lexbuf (Lexing.from_string text) let load_channel inc = load_lexbuf (Lexing.from_channel inc) let load_file file = let inc = open_in file in try let content = load_channel inc in close_in inc ; content with e -> close_in inc ; raise e let rec pp fmt v = let open Format in match v with | Null -> pp_print_string fmt "null" | True -> pp_print_string fmt "true" | False -> pp_print_string fmt "false" | String s -> fprintf fmt "%S" s | Number s -> pp_print_string fmt s | Int a -> pp_print_int fmt a | Float f -> pp_print_float fmt f | Array [] -> pp_print_string fmt "[]" | Array (e::es) -> Format.fprintf fmt "@[[ %a" pp e ; List.iter (fun e -> Format.fprintf fmt ",@ %a" pp e) es ; Format.fprintf fmt " ]@]" | Assoc [] -> pp_print_string fmt "{}" | Assoc (e::es) -> Format.fprintf fmt "@[{ %a" pp_entry e ; List.iter (fun e -> Format.fprintf fmt ",@ %a" pp_entry e) es ; Format.fprintf fmt " }@]" and pp_entry fmt (a,v) = Format.fprintf fmt "@[%S: %a@]" a pp v let dump_string f s = let quote = "\"" in f quote ; f (String.escaped s) ; f quote let rec dump f = function | Null -> f "null" | True -> f "true" | False -> f "false" | String s -> dump_string f s | Number s -> f s | Int a -> f (string_of_int a) | Float x -> f (string_of_float x) | Array [] -> f "[]" | Array (e::es) -> f "[" ; dump f e ; List.iter (fun e -> f "," ; dump f e) es ; f "]" | Assoc [] -> f "{}" | Assoc (e::es) -> f "{" ; dump_entry f e ; List.iter (fun e -> f "," ; dump_entry f e) es ; f "}" and dump_entry f (a,v) = dump_string f a ; f ":" ; dump f v let save_buffer ?(pretty=true) buffer v = if pretty then let fmt = Format.formatter_of_buffer buffer in pp fmt v ; Format.pp_print_flush fmt () else dump (Buffer.add_string buffer) v let save_channel ?(pretty=true) out v = if pretty then let fmt = Format.formatter_of_out_channel out in pp fmt v ; Format.pp_print_flush fmt () else dump (output_string out) v ; flush out let save_string ?(pretty=true) v = let buffer = Buffer.create 80 in save_buffer ~pretty buffer v ; Buffer.contents buffer let save_file ?(pretty=true) file v = let out = open_out file in try save_channel ~pretty out v ; close_out out with e -> close_out out ; raise e let invalid name = raise (Invalid_argument ("Json." ^ name)) let bool = function | True -> true | False -> false | _ -> invalid "bool" let int = function | Null -> 0 | Int n -> n | Float f -> (try int_of_float f with _ -> invalid "int") | Number s | String s -> (try int_of_string s with _ -> invalid "int") | _ -> invalid "int" let float = function | Null -> 0.0 | Float f -> f | Int n -> (try float_of_int n with _ -> invalid "float") | Number s | String s -> (try float_of_string s with _ -> invalid "float") | _ -> invalid "float" let string = function | Null -> "" | Int n -> string_of_int n | Float f -> string_of_float f | Number s | String s -> s | _ -> invalid "string" let list = function | Null -> [] | Array es -> es | _ -> invalid "list" let array = function | Null -> [| |] | Array es -> Array.of_list es | _ -> invalid "array" let field f = function | Null -> raise Not_found | Assoc fs -> List.assoc f fs | _ -> invalid "field" let fold f v w = match v with | Null -> w | Assoc fs -> List.fold_left (fun w (e,v) -> f e v w) w fs | _ -> invalid "fold" let of_bool b = if b then True else False let of_int k = Int k let of_string s = String s let of_float f = Float f let of_list xs = Array xs let of_array xs = Array (Array.to_list xs) let of_fields m = Assoc m } frama-c-Phosphorus-20170501/src/libraries/utils/hptmap.mli0000644000175000017500000000740413113745006022273 0ustar mehdimehdi(**************************************************************************) (* *) (* This file was originally part of Menhir *) (* *) (* François Pottier and Yann Régis-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 licenses/Q_MODIFIED_LICENSE. *) (* *) (* File modified by CEA (Commissariat à l'énergie atomique et aux *) (* énergies alternatives). *) (* *) (**************************************************************************) (** Efficient maps from hash-consed trees to values, implemented as Patricia trees. *) (** This implementation of big-endian Patricia trees follows Chris Okasaki's paper at the 1998 ML Workshop in Baltimore. 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. *) (**/**) (* Undocumented. Needed for advanced users only *) type prefix val sentinel_prefix : prefix (**/**) type tag (** Type of the keys of the map. *) module type Id_Datatype = sig include Datatype.S val id: t -> int (** Identity of a key. Must verify [id k >= 0] and [equal k1 k2 ==> id k1 = id k2] *) end (** Values stored in the map *) module type V = sig include Datatype.S val pretty_debug: t Pretty_utils.formatter end (** This functor exports the {i shape} of the maps indexed by keys [Key]. Those shapes can be used by various functions to efficiently build new maps whose shape are already known. *) module Shape (Key : Id_Datatype): sig type 'value t end module Make (Key : Id_Datatype) (V : V) (Compositional_bool : sig (** A boolean information is maintained for each tree, by composing the boolean on the subtrees and the value information present on each leaf. See {!Comp_unused} for a default implementation. *) val e: bool (** Value for the empty tree *) val f : Key.t -> V.t -> bool (** Value for a leaf *) val compose : bool -> bool -> bool (** Composition of the values of two subtrees *) end) (Initial_Values : sig val v : (Key.t*V.t) list list (** List of the maps that must be shared between all instances of Frama-C (the maps being described by the list of their elements). Must include all maps that are exported at Caml link-time when the functor is applied. This usually includes at least the empty map, hence [v] nearly always contains [[]]. *) end) (Datatype_deps: sig val l : State.t list (** Dependencies of the hash-consing table. The table will be cleared whenever one of those dependencies is cleared. *) end) : Hptmap_sig.S with type key = Key.t and type v = V.t and type 'a shape = 'a Shape(Key).t and type prefix = prefix (** Default implementation for the [Compositional_bool] argument of the functor {!Make}. To be used when no interesting compositional bit can be computed. *) module Comp_unused : sig val e : bool val f : 'a -> 'b -> bool val compose : bool -> bool -> bool end (* Local Variables: compile-command: "make -C .." End: *) frama-c-Phosphorus-20170501/src/libraries/utils/hptmap_sig.mli0000644000175000017500000003350013113745006023131 0ustar mehdimehdi(**************************************************************************) (* *) (* This file was originally part of Menhir *) (* *) (* François Pottier and Yann Régis-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 licenses/Q_MODIFIED_LICENSE. *) (* *) (* File modified by CEA (Commissariat à l'énergie atomique et aux *) (* énergies alternatives). *) (* *) (**************************************************************************) (** Signature for the {!Hptmap} module *) (** Some functions of this module may optionally use internal caches. It is the responsibility of the use to choose whether or not to use a cache, and whether this cache will be garbage-collectable by OCaml. *) type cache_type = | NoCache (** The results of the function will not be cached. *) | PersistentCache of string (** The results of the function will be cached, and the function that uses the cache is a permanent closure (at the toplevel of an OCaml module).*) | TemporaryCache of string (** The results of the function will be cached, but the function itself is a local function which is garbage-collectable. *) (** Signature for hptmaps from hash-consed trees to values *) module type S = sig type key (** type of the keys *) type v (** type of the values *) type 'a shape type prefix include Datatype.S_with_collections (** Bijective function. The ids are positive. *) val id: t -> int val self : State.t val empty : t (** the empty map *) 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 (** [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 val find_check_missing: key -> t -> v (** Both [find key m] and [find_check_missing key m] return the value bound to [key] in [m], or raise [Not_found] is [key] is unbound. [find] is optimised for the case where [key] is bound in [m], whereas [find_check_missing] is more efficient for the cases where [m] is big and [key] is missing. *) val find_key : key -> t -> key (** This function is useful where there are multiple distinct keys that are equal for [Key.equal]. *) val remove : key -> t -> t (** [remove k m] returns the map [m] deprived from any binding involving [k]. *) val mem : key -> t -> bool (** [mem k m] returns true if [k] is bound in [m], and false otherwise. *) val iter : (key -> v -> unit) -> t -> unit (** [iter f m] applies [f] to all bindings of the map [m]. *) val map : (v -> v) -> 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 map': (key -> v -> v option) -> t -> t (** Same as [map], except if [f k v] returns [None]. In this case, [k] is not bound in the resulting map. *) val filter: (key -> bool) -> t -> t (** [filter f t] keep only the bindings of [m] whose key verify [f]. *) val fold : (key -> v -> '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 -> v -> 'b -> 'b) -> t -> 'b -> 'b (** [fold_rev] performs exactly the same job as [fold], but presents keys to [f] in the opposite order. *) val for_all: (key -> v -> bool) -> t -> bool (** [for_all p m] returns true if all the bindings of the map [m] satisfy the predicate [p]. *) val exists: (key -> v -> bool) -> t -> bool (** [for_all p m] returns true if at least one binding of the map [m] satisfies the predicate [p]. *) type empty_action = Neutral | Absorbing | Traversing of (key -> v -> v option) val merge : cache:cache_type -> symmetric:bool -> idempotent:bool -> decide_both:(key -> v -> v -> v option) -> decide_left:empty_action -> decide_right:empty_action -> t -> t -> t (** Merge of two trees, parameterized by a merge function. If [symmetric] holds, the function must verify [merge x y = merge y x]. If [idempotent] holds, the function must verify [merge x x = x]. For each key [k] present in both trees, and bound to [v1] and [v2] in the left and the right tree respectively, [decide_both k v1 v2] is called. If the decide function returns [None], the key will not be in the resulting map; otherwise, the new value computed will be bound to [k]. The [decide_left] action is performed to the left subtree [t] when a right subtree is empty (and conversely for the [decide_right] action when a left subtree is empty): - Neutral returns the subtree [t] unchanged; - Absorbing returns the empty tree; - (Traversing f) applies the function [f] to each binding of the remaining subtree [t] (see [map']). The results of the function may be cached, depending on [cache]. If a cache is used, then the merge functions must be pure. *) val generic_join : cache:cache_type -> symmetric:bool -> idempotent:bool -> decide:(key -> v option -> v option -> v) -> t -> t -> t (** Merge of two trees, parameterized by the [decide] function. If [symmetric] holds, the function must verify [decide key v1 v2 = decide key v2 v1]. If [idempotent] holds, the function must verify [decide k (Some x) (Some x) = x]. *) val join : cache:cache_type -> symmetric:bool -> idempotent:bool -> decide:(key -> v -> v -> v) -> t -> t -> t (** Same as [generic_merge], but we assume that [decide key None (Some v) = decide key (Some v) None = v] holds. *) val inter : cache:cache_type -> symmetric:bool -> idempotent:bool -> decide:(key -> v -> v -> v option) -> t -> t -> t (** Intersection of two trees, parameterized by the [decide] function. If the [decide] function returns [None], the key will not be in the resulting map. Keys present in only one map are similarly unmapped in the result. *) val inter_with_shape: 'a shape -> t -> t (** [inter_with_shape s m] keeps only the elements of [m] that are also bound in the map [s]. No caching is used, but this function is more efficient than successive calls to {!remove} or {!add} to build the resulting map. *) (** {2 Binary predicates} *) type decide_fast = Done | Unknown (** Shortcut for functions that decide whether a predicate holds on a tree. [Done] means that the function returns its default value, which is usually [unit]. [Unknown] means that the evaluation must continue in the subtrees. *) val generic_predicate : exn -> cache:(string * 'a) -> decide_fast:(t -> t -> decide_fast) -> decide_fst:(key -> v -> unit) -> decide_snd:(key -> v -> unit) -> decide_both:(v -> v -> unit) -> t -> t -> unit (** [generic_is_included e (cache_name, cache_size) ~decide_fast ~decide_fst ~decide_snd ~decide_both t1 t2] decides whether some relation holds between [t1] and [t2]. All [decide] functions must raise [e] when the relation does not hold, and do nothing otherwise. [decide_fst] (resp. [decide_snd]) is called when one key is present only in [t1] (resp. [t2]). [decide_both] is called when a key is present in both trees. [decide_fast] is called on entire keys. As its name implies, it must be fast; in doubt, returning [Unknown] is always correct. Raising [e] means that the relation does not hold. Returning [Done] means that the relation holds. The computation of this relation cached. [cache_name] is used to identify the cache when debugging. [cache_size] is currently unused. *) (** Existential ([||]) or universal ([&&]) predicates. *) type predicate_type = ExistentialPredicate | UniversalPredicate (** Does the given predicate hold or not. [PUnknown] indicates that the result is uncertain, and that the more aggressive analysis should be used. *) type predicate_result = PTrue | PFalse | PUnknown val binary_predicate: cache_type -> predicate_type -> decide_fast:(t -> t -> predicate_result) -> decide_fst:(key -> v -> bool) -> decide_snd:(key -> v -> bool) -> decide_both:(key -> v -> v -> bool) -> t -> t -> bool (** Same functionality as [generic_predicate] but with a different signature. All decision functions return a boolean that are combined differently depending on whether the predicate is existential or universal. *) val generic_symmetric_predicate : exn -> decide_fast:(t -> t -> decide_fast) -> decide_one:(key -> v -> unit) -> decide_both:(v -> v -> unit) -> t -> t -> unit (** Same as [generic_predicate], but for a symmetric relation. [decide_fst] and [decide_snd] are thus merged into [decide_one]. *) val symmetric_binary_predicate: cache_type -> predicate_type -> decide_fast:(t -> t -> predicate_result) -> decide_one:(key -> v -> bool) -> decide_both:(key -> v -> v -> bool) -> t -> t -> bool (** Same as [binary_predicate], but for a symmetric relation. [decide_fst] and [decide_snd] are thus merged into [decide_one]. *) val decide_fast_inclusion: t -> t -> predicate_result (** Function suitable for the [decide_fast] argument of [binary_predicate], when testing for inclusion of the first map into the second. If the two arguments are equal, or the first one is empty, the relation holds. *) val decide_fast_intersection: t -> t -> predicate_result (** Function suitable for the [decide_fast] argument of [symmetric_binary_predicate] when testing for a non-empty intersection between two maps. If one map is empty, the intersection is empty. Otherwise, if the two maps are equal, the intersection is non-empty. *) val cached_fold : cache_name:string -> temporary:bool -> f:(key -> v -> 'b) -> joiner:('b -> 'b -> 'b) -> empty:'b -> t -> 'b val cached_map : cache:string * int -> temporary:bool -> f:(key -> v -> v) -> t -> t val singleton: key -> v -> t (** [singleton k d] returns a map whose only binding is from [k] to [d]. *) val is_singleton: t -> (key * v) option (** [is_singleton m] returns [Some (k, d)] if [m] is a singleton map that maps [k] to [d]. Otherwise, it returns [None]. *) val on_singleton: (key -> v -> bool) -> t -> bool (** [on_singleton f m] returns [f k d] if [m] is a singleton map that maps [k] to [d]. Otherwise, it returns false. *) 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 val max_binding: t -> key * v val split: key -> t -> t * v option * t val compositional_bool: t -> bool (** Value of the compositional boolean associated to the tree, as computed by the {!Compositional_bool} argument of the functor. *) val clear_caches: unit -> unit (** Clear all the persistent caches used internally by the functions of this module. Those caches are not project-aware, so this function must be called at least each time a project switch occurs. *) val from_shape: (key -> 'a -> v) -> 'a shape -> t (** Build an entire map from another map indexed by the same keys. More efficient than just performing successive {!add} the elements of the other map *) val shape: t -> v shape (** Export the map as a value suitable for functions {!inter_with_shape} and {!from_shape} *) val fold2_join_heterogeneous: cache:cache_type -> empty_left:('a shape -> 'b) -> empty_right:(t -> 'b) -> both:(key -> v -> 'a -> 'b) -> join:('b -> 'b -> 'b) -> empty:'b -> t -> 'a shape -> 'b (** [fold2_join_heterogeneous ~cache ~empty_left ~empty_right ~both ~join ~empty m1 m2] iterates simultaneously on [m1] and [m2]. If a subtree [t] is present in [m1] but not in [m2] (resp. in [m2] but not in [m1]), [empty_right t] (resp. [empty_left t]) is called. If a key [k] is present in both trees, and bound to [v1] and [v2] respectively, [both k v1 v2] is called. If both trees are empty, [empty] is returned. The values of type ['b] returned by the auxiliary functions are merged using [join], which is called in an unspecified order. The results of the function may be cached, depending on [cache]. *) (**/**) (* Undocumented. *) val pretty_debug: Format.formatter -> t -> unit (* Prefixes. *) 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 end frama-c-Phosphorus-20170501/src/libraries/utils/task.mli0000644000175000017500000002247013113745011021740 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 *) (* ************************************************************************* *) (** {2 Task} *) (* ************************************************************************* *) type 'a task type 'a status = | Timeout of int | Canceled | Result of 'a | Failed of exn val error : exn -> string (** Extract error message form exception *) val wait : 'a task -> 'a status (** Blocks until termination. *) 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 Synchronous 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]. Otherwise, further instances will return [Failed] status. *) val share : 'a shared -> 'a task (** New instance of shared task. *) (* ************************************************************************* *) (** {2 Task Thread} *) (* ************************************************************************* *) type thread val thread : 'a task -> thread val cancel : thread -> unit val running : thread -> bool val run : thread -> unit (** Runs one single task in the background. Typically using [on_idle]. *) (* ************************************************************************* *) (** {2 Task Pool} *) (* ************************************************************************* *) type pool val pool : unit -> pool val add : pool -> thread -> unit (** Auto-flush *) val iter : (thread -> unit) -> pool -> unit (** Auto-flush *) val flush : pool -> unit (** Clean all terminated tasks *) val size : pool -> int (** Auto-flush. Number of living tasks *) (* ************************************************************************* *) (** {2 Task Server} *) (* ************************************************************************* *) 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 -> ?pool:pool -> ?stage:int -> thread -> 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 on_server_wait : server -> (unit -> unit) -> unit (** On-wait server callback (all tasks are scheduled) *) val scheduled : server -> int (** Number of scheduled process *) val terminated : server -> int (** Number of terminated process *) val waiting : server -> int option (** All task scheduled and server is waiting for termination *) (* ************************************************************************* *) (** {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-Phosphorus-20170501/src/libraries/utils/filepath.mli0000644000175000017500000000733713113745012022600 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. In these functions, references to the present working directory refer to the result given by function Sys.getcwd. *) (** Returns an absolute path leading to the given file. The result is similar to [realpath --no-symlinks]. Some special behaviors include: - [normalize ""] (empty string) raises [Invalid_argument] (realpath returns an error); - [normalize] preserves multiple sequential '/' characters, unlike [realpath]; - non-existing directories in [realpath] may lead to ENOTDIR errors, but [normalize] may accept them. @modify Aluminium-20160501 optional base. *) val normalize: ?base:string -> string -> string (** [relativize base file] returns a (strict) relative path of [file] w.r.t. [base], if [base] is a prefix of [file]; otherwise, returns [file] unchanged. The default base is the present working directory. @since Aluminium-20160501 *) val relativize: ?base:string -> string -> string (** returns true if the file is strictly relative to [base] (that is, it is prefixed by [base]), or to the present working directory if no base is specified. @since Aluminium-20160501 *) val is_relative: ?base:string -> string -> bool (** Pretty-print a path according to these rules: - relative filenames are kept, except for leading './', which are stripped; - absolute filenames are relativized if their prefix is included in the present working directory; also, symbolic names are resolved, i.e. the result may be prefixed by known aliases (e.g. FRAMAC_SHARE). See {!add_symbolic_dir} for more details. Therefore, the result of this function may not designate a valid name in the filesystem. @since Neon-20140301 *) val pretty: string -> string (** [add_symbolic_dir name dir] indicates that the (absolute) path [dir] must be replaced by [name] when pretty-printing paths. This alias ensures that system-dependent paths such as FRAMAC_SHARE are printed identically in different machines. *) val add_symbolic_dir: string -> string -> unit (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/utils/rangemap.ml0000644000175000017500000004422713113745011022423 0ustar mehdimehdi(**************************************************************************) (* *) (* 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 = t_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-Phosphorus-20170501/src/libraries/utils/vector.mli0000644000175000017500000000654613113745002022306 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (** Extensible Arrays *) (* -------------------------------------------------------------------------- *) type 'a t val create : unit -> 'a t val length : 'a t -> int val size : 'a t -> int (** Same as [length] *) val get : 'a t -> int -> 'a (** Raise [Not_found] if out-of-bounds. *) val set : 'a t -> int -> 'a -> unit (** Raise [Not_found] if out-of-bounds. *) val add : 'a t -> 'a -> unit (** Element will be added at index [size]. After addition, it is at index [size-1]. *) val addi : 'a t -> 'a -> int (** Return index of added (last) element. *) val clear : 'a t -> unit (** Do not modify actual capacity. *) val iter : ('a -> unit) -> 'a t -> unit val iteri : (int -> 'a -> unit) -> 'a t -> unit val map : ('a -> 'b) -> 'a t -> 'b t (** Result is shrunk. *) val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t (** Result is shrunk. *) val find : 'a t -> ?default:'a -> ?exn:exn -> int -> 'a (** Default exception is [Not_found]. If a [default] value is provided, no exception is raised. *) val update : 'a t -> ?default:'a -> int -> 'a -> unit (** Set value at index. If the updated index is greater of equal to the vector size, empty cells are inserted with the default value. @raise Invalid_argument if the index is negative or when it exceeds the the vector size but the default value is not provided. *) val to_array : 'a t -> 'a array (** Makes a copy. *) val of_array : 'a array -> 'a t (** Makes a copy. *) (** Low-level interface. Internal capacity. *) val capacity : 'a t -> int (** Low-level interface. Sets internal capacity. Extra elements are removed. *) val resize : 'a t -> int -> unit (** Low-level interface. Sets capacity to content. *) val shrink : 'a t -> unit frama-c-Phosphorus-20170501/src/libraries/utils/utf8_logic.mli0000644000175000017500000000424213113745006023042 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* 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 emptyset : string val minus: string val boolean: string val integer: string val real: string (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/utils/leftistheap.ml0000644000175000017500000000522413113745011023133 0ustar mehdimehdi(**************************************************************************) (* *) (* Copyright (C) Jean-Christophe Filliatre *) (* *) (* This software is free software; you can redistribute it and/or *) (* modify it under the terms of the GNU Library General Public *) (* License version 2.1, with the special exception on linking *) (* described in file LICENSE. *) (* *) (* This software is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) (* *) (* File modified by CEA (Commissariat à l'énergie atomique et aux *) (* énergies alternatives). *) (* *) (**************************************************************************) (* Leftist heaps. See for instance Chris Okasaki's "Purely Functional Data Structures" *) exception Empty module Make(X: Set.OrderedType) : sig type t val empty : t val is_empty : t -> bool val insert : X.t -> t -> t val min : t -> X.t val extract_min : t -> X.t * t val merge : t -> t -> t val fold: (X.t -> 'a -> 'a) -> t -> 'a -> 'a val elements: t -> X.t list val of_list: X.t list -> t end = struct type t = E | T of int * X.t * t * t let rank = function E -> 0 | T (r,_,_,_) -> r let make x a b = let ra = rank a and rb = rank b in if ra >= rb then T (rb + 1, x, a, b) else T (ra + 1, x, b, a) let empty = E let is_empty = function E -> true | T _ -> false let rec merge h1 h2 = match h1,h2 with | E, h | h, E -> h | T (_,x,a1,b1), T (_,y,a2,b2) -> if X.compare x y <= 0 then make x a1 (merge b1 h2) else make y a2 (merge h1 b2) let insert x h = merge (T (1, x, E, E)) h let min = function E -> raise Empty | T (_,x,_,_) -> x let extract_min = function | E -> raise Empty | T (_,x,a,b) -> x, merge a b (* Added by CEA *) let rec fold f h acc = match h with | E -> acc | T (_, x, h1, h2) -> fold f h2 (f x (fold f h1 acc)) let elements h = fold (fun e l -> e :: l) h [] (* can probably be improved *) let of_list l = List.fold_left (fun h x -> insert x h) E l end frama-c-Phosphorus-20170501/src/libraries/utils/hook.ml0000644000175000017500000001336713113745002021572 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 Comparable = sig type t val equal: t -> t -> bool val hash: t -> int val compare: t -> t -> int end module type S_ordered = sig include S type key type id (** identifier of the hook *) val register_key: key -> id val extend: id -> (param->result)->unit val extend_once: id -> (param->result) -> unit val add_dependency: id -> id -> unit 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): Iter_hook with type param = P.t = 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): S with type param=P.t and type result = P.t = 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) module Make_graph (P: sig module Id:Comparable type param type result end) = struct type key = P.Id.t type param = P.param type result = P.result module Nodes = struct type t = key * (param -> result) Queue.t let equal (id1,_) (id2,_) = P.Id.equal id1 id2 let hash (id,_) = P.Id.hash id let compare (id1,_) (id2,_) = P.Id.compare id1 id2 end module Hooks = Graph.Imperative.Digraph.Concrete(Nodes) type id = Hooks.V.t let hooks = Hooks.create () (* No find in OCamlgraph API... *) let find_vertex v1 = let module F = struct exception Found of Nodes.t end in try Hooks.iter_vertex (fun v2 -> if Nodes.equal v1 v2 then raise (F.Found v2)) hooks; raise Not_found with F.Found v -> v let register_key k = let empty_node = k, Queue.create() in try find_vertex empty_node with Not_found -> Hooks.add_vertex hooks empty_node; empty_node module Apply = Graph.Topological.Make_stable(Hooks) let extend (_,q) f = Queue.add f q let extend_once (_,q) f = add_once f q let add_dependency v1 v2 = Hooks.add_edge hooks v1 v2 let empty_nodes () = let module F = struct exception Full end in let empty_node (_,q) = if not (Queue.is_empty q) then raise F.Full in try Hooks.iter_vertex empty_node hooks; true with F.Full -> false let is_empty () = Hooks.is_empty hooks || empty_nodes () let clear () = Hooks.clear hooks let length () = Hooks.fold_vertex (fun (_,q) l -> Queue.length q + l) hooks 0 end module Build_ordered (P: sig module Id:Comparable type t end): S_ordered with type key = P.Id.t and type param = P.t and type result = unit = struct include Make_graph( struct module Id = P.Id type param = P.t type result = unit end) let apply v = let apply_queue (_,q) = Queue.iter (fun f -> f v) q in Apply.iter apply_queue hooks end module Make_ordered(P: sig module Id:Comparable end) = Build_ordered(struct include P type t = unit end) module Fold_ordered(P: sig module Id:Comparable type t end) = struct include Make_graph( struct module Id = P.Id type param = P.t type result = P.t end) let apply v = let apply_queue (_,q) v = Queue.fold (fun v f -> f v) v q in Apply.fold apply_queue hooks v end (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/utils/qstack.mli0000644000175000017500000001105213113745002022256 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/utils/pretty_utils.mli0000644000175000017500000002437113113745002023547 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. @plugin development guide *) (* ********************************************************************** *) (** {2 pretty-printing to a string} *) (* ********************************************************************** *) val sfprintf: ('a,Format.formatter,unit,string) format4 -> 'a (** Equivalent to Format.asprintf. Used for compatibility with OCaml < 4.01. @deprecated Silicon-20161101 use Format.asprintf *) val ksfprintf: (string -> 'b) -> ('a, Format.formatter, unit, 'b) format4 -> 'a (** similar to Format.kfprintf, but the continuation is given the result string instead of a formatter. @since Magnesium-20151001 *) val to_string: ?margin:int -> (Format.formatter -> 'a -> unit) -> 'a -> string (** pretty-prints the supplied value into a string. [margin] is the maximal width of the box before a line-break is inserted. See {!Format.set_margin} *) (** {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 -> ?empty:sformat -> 'a formatter -> 'a list formatter (** 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) - what to print if the list is empty (default: nothing) @modify Silicon-20161101 new optional argument [empty] *) val pp_array: ?pre:sformat -> ?sep:sformat -> ?suf:sformat -> ?empty:sformat -> (int,'a) formatter2 -> 'a array formatter (** pretty prints an array. The optional arguments stands for - the prefix to output before a non-empty array (default: open a box) - the separator between two elements (default: nothing) - the suffix to output after a non-empty array (default: close box) - what to print if the array is empty (default: nothing) @modify Silicon-20161101 new optional argument [empty] *) 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 between two calls to the ['a formatter]. Default: open a box for [pre], close a box for [suf], nothing for [sep]. *) val pp_iter2: ?pre:sformat -> ?sep:sformat -> ?suf:sformat -> ?between:sformat -> (('key -> 'v -> unit) -> 'a -> unit) -> 'key formatter -> 'v formatter -> 'a formatter (** pretty prints any map-like 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 between two calls to the ['a formatter]. The optional argument [between] is output between the key and the value. Default: open a box for [pre], close a box for [suf], nothing for [sep], break-space for [between]. *) val pp_opt: ?pre:sformat -> ?suf:sformat -> ?none:sformat -> 'a formatter -> 'a option formatter (** pretty-prints an optional value. Prefix and suffix default to "@[" and "@]" respectively. If the value is [None], pretty-print using [none]. @modify Silicon-20161101 new optional argument [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_pair: ?pre:sformat -> ?sep:sformat -> ?suf:sformat -> 'a formatter -> 'b formatter -> ('a * 'b) formatter (** [pp_pair ?pre ?sep ?suf pp_a pp_b (a,b)] pretty prints the pair [(a,b)], using the pretty printers [pp_a] and [pp_b], with optional prefix/separator/suffix, whose default values are: - pre: open a box - sep: print a comma character - suf: close a box. @since Magnesium-20151001 *) 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 '*' *) (* ********************************************************************** *) (** {2 Description Lists (margins)} *) (* ********************************************************************** *) type align = [`Center | `Left | `Right] val pp_items : ?align:align -> ?margin:int -> ?min:int -> ?max:int -> title:('a -> string) -> iter:(('a -> unit) -> unit) -> ?pp_title:string formatter -> pp_item:(string formatter -> 'a formatter) -> Format.formatter -> unit (** Prints a collection of elements, with the possibility of aligning {i titles} with each others. The collection of ['a] to print is provided by iterator [~iter] which is called twice: one for computing the maximal size of {i titles}, obtained {i via} function [~title] for each item. The second pass pretty-print each item using [~pp_item pp] where the passed [pp] printer can be used to pretty-print titles with alignment. A typical usage for printing [values], a list of [(string*int)] items: {[ pp_items ~title:(fun (a,_) -> a) ~iter:(fun f -> List.iter f values) ~pp_title:(fun fmt a -> Format.fprintf fmt "%s:" a) ~pp_item:(fun pp fmt (a,n) -> Format.fprintf fmt "%a %d@\n" pp a n) fmt ]} Alignment of titles can be centered, right or left justified. This is rendered by adding spaces around each title. A min and max size can also be specified and a margin can be added to all title sizes. Titles will be truncated if necessary. The pretty-printer for titles will render each (possibly truncated) title with [~pp_title]. Surrounding spaces are {i not} printed via [~pp_title]. The (optional) parameters have the following meaning: - [?align] alignment mode (default is [`Center]) - [?margin] is added to text size (default [0]) - [?min] minimum size ([~margin] included, default [0]) - [?max] maximum size ([~margin] included, default [80]) - [~title] returns the {i title} for each element (only size is relevant) - [~iter] iterate over the elements to be printed - [?pp_title] pretty-printer used to the (possibly truncated) title (default is [Format.pp_print_string]) - [~pp_item] pretty-printer to print each element. There is also a low-level API to this feature, provided by {!marger}, {!pp_margin} and {!add_margin} below. *) type marger (** Margin accumulator (low-level API to [pp_items]). *) val marger : unit -> marger (** Create an empty marger *) val add_margin : marger -> ?margin:int -> ?min:int -> ?max:int -> string -> unit (** Updates the marger with new text dimension. The marger width is updated with the width of the provided text. The optional parameters are used to adjust the text width as follows: - [?margin] is added to text size (default [0]) - [?min] minimum size ([~margin] included, default [0]) - [?max] maximum size ([~margin] included, default [80]) *) val pp_margin : ?align:align -> ?pp:string formatter -> marger -> string formatter (** Prints a text with margins {i wrt} to marger. If the text does not fit the marger, it would be truncated and/or ellipsed. - [?align] alignment mode (default is [`Center]) - [?pp] pretty-printer used to the (possibly truncated) title (default is [Format.pp_print_string]) Typical usage: {[ begin (* first, collect title margins *) let m = marger () in List.iter (fun (a,_) -> add_margin m ~margins:2 a) data ; (* second, print aligned data *) List.iter (fun (a,d) -> Format.printf "[%a] %s@\n" (pp_margin m) a d) data ; end ]} *) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/utils/bag.mli0000644000175000017500000000530013113745001021517 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 (** Might have [n^2] complexity in worst cases. It might be better to use a Vector to reach linear complexity. *) val sort : ('a -> 'a -> int) -> 'a t -> 'a list (** The returned list preserves duplicates and order of equals elements. Uses Merge Sort (from standard List module), but might have [n^2] complexity in worst cases. It might be better to use a Vector to reach linear complexity. *) frama-c-Phosphorus-20170501/src/libraries/utils/task.ml0000644000175000017500000003665713113745004021605 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 of int | Canceled | Result of 'a | Failed of exn let map f = function | Timeout n -> Timeout n | 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) (* -------------------------------------------------------------------------- *) (* --- Monadic Engine --- *) (* -------------------------------------------------------------------------- *) type coin = Coin | Kill type 'a async = | Yield | Wait of int | Return of 'a module Monad : sig type 'a t val unit : 'a -> 'a t val bind : 'a t -> ('a -> 'b t) -> 'b t val progress : 'a t -> 'a t val cancel : 'a t -> 'a t val yield : (coin -> 'a t) -> 'a t val async : (coin -> 'a async) -> 'a t val wait : 'a t -> 'a val finished : 'a t -> 'a option val waiting : 'a t -> bool end = struct type 'a t = | UNIT of 'a | WAIT of int * (coin -> 'a t) | YIELD of (coin -> 'a t) let unit a = UNIT a let rec bind m f = match m with | UNIT a -> f a | WAIT(d,m) -> WAIT (d, fun c -> bind (m c) f) | YIELD m -> YIELD (fun c -> bind (m c) f) let put c m = match m with | UNIT _ -> m | WAIT(_,f) | YIELD f -> f c let progress m = put Coin m let cancel m = put Kill m let yield f = YIELD f let rec ping f coin = match f coin with | Wait d -> WAIT(d,ping f) | Yield -> YIELD(ping f) | Return a -> UNIT a let async f = YIELD (ping f) let rec wait = function | UNIT a -> a | YIELD f -> !Db.progress() ; wait (f Coin) | WAIT(ms,f) -> !Db.progress() ; Extlib.usleep ms ; wait (f Coin) let finished = function UNIT a -> Some a | YIELD _ | WAIT _ -> None let waiting = function UNIT _ -> false | YIELD _ | WAIT _ -> true end (* ------------------------------------------------------------------------ *) (* --- Monadic Constructors --- *) (* ------------------------------------------------------------------------ *) type 'a task = 'a status Monad.t let wait = Monad.wait let status = Monad.unit let return r = Monad.unit (Result r) let raised e = Monad.unit (Failed e) let canceled () = Monad.unit Canceled let failed text = let buffer = Buffer.create 80 in Format.kfprintf (fun fmt -> Format.pp_print_flush fmt () ; Monad.unit (Failed(Failure (Buffer.contents buffer)))) (Format.formatter_of_buffer buffer) text let bind = Monad.bind let sequence a k = Monad.bind a (function | Result r -> k r | Failed e -> Monad.unit (Failed e) | Timeout n -> Monad.unit (Timeout n) | Canceled -> Monad.unit Canceled) let nop = return () let later f x = Monad.yield begin function | Coin -> (try f x with e -> raised e) | Kill -> canceled () end let call f x = Monad.yield begin function | Coin -> (try return (f x) with e -> raised e) | Kill -> canceled () end let todo f = later f () let job t = sequence t (fun _ -> nop) let finally t cb = Monad.bind t (fun s -> cb s ; Monad.unit 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 rec lock m = if !m then later lock m else (m := true ; return ()) let unlock m = if not !m then (invalid_arg "Invalid lock on mutex") else m := false let sync m t = lock m >>= t >>? fun _ -> unlock m (* ------------------------------------------------------------------------ *) (* --- System Commands --- *) (* ------------------------------------------------------------------------ *) type cmd = { name : string ; timed : bool ; timeout : int ; time_start : float ; time_stop : float ; mutable time_killed : bool ; chrono : float ref option ; async : (unit -> Command.process_result) ; } let set_chrono cmd = match cmd.chrono with | None -> () | Some r -> r := max !r (Unix.gettimeofday () -. 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.gettimeofday () 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 ; time_killed = false ; chrono = time ; async = async ; } end let ping_command cmd coin = try match cmd.async () with | Command.Not_ready kill -> if coin = Kill then (kill () ; Wait 100) else let time_now = if cmd.timed then Unix.gettimeofday () 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 ; cmd.time_killed <- true ; kill () ; end ; Wait 100 | Command.Result (Unix.WEXITED s|Unix.WSIGNALED s|Unix.WSTOPPED s) when cmd.time_killed -> set_chrono cmd ; Kernel.debug ~dkey "timeout '%s' [%d]" cmd.name s ; Return (Timeout cmd.timeout) | Command.Result (Unix.WEXITED s) -> set_chrono cmd ; Kernel.debug ~dkey "exit '%s' [%d]" cmd.name s ; Return (Result s) | Command.Result (Unix.WSIGNALED s|Unix.WSTOPPED s) -> set_chrono cmd ; Kernel.debug ~dkey "signal '%s' [%d]" cmd.name s ; Return Canceled with e -> set_chrono cmd ; Kernel.debug ~dkey "failure '%s' [%s]" cmd.name (Printexc.to_string e) ; Return (Failed e) let command ?(timeout=0) ?time ?stdout ?stderr cmd args = todo begin fun () -> let cmd = start_command ~timeout ?time ?stdout ?stderr cmd args in Monad.async (ping_command cmd) end (* ------------------------------------------------------------------------ *) (* --- Shared Tasks --- *) (* ------------------------------------------------------------------------ *) type 'a shared = { descr : string ; retry : bool ; mutable builder : (unit -> 'a task) ; mutable shared : 'a task ; mutable clients : int ; } let shared ~descr ~retry builder = { descr ; retry ; builder ; shared = todo builder ; clients = 0 } let retry_shared sh = function | Failed _ -> sh.retry | Timeout _ | Canceled -> true | Result _ -> false let ping_shared sh = function | Coin -> begin match Monad.finished sh.shared with | Some r -> if retry_shared sh r then sh.shared <- todo sh.builder ; Return r | None -> sh.shared <- Monad.progress sh.shared ; Yield end | Kill -> if sh.clients > 1 then begin sh.clients <- pred sh.clients ; Return Canceled end else ( if sh.clients = 1 then begin sh.clients <- 0 ; sh.shared <- Monad.cancel sh.shared ; end ; Yield ) let share sh = todo begin fun () -> sh.clients <- succ sh.clients ; Monad.async (ping_shared sh) end (* -------------------------------------------------------------------------- *) (* --- IDLE --- *) (* -------------------------------------------------------------------------- *) let on_idle = ref (fun f -> try while f () do Extlib.usleep 50000 (* wait for 50ms *) done with Db.Cancel -> ()) (* -------------------------------------------------------------------------- *) (* --- Task thread --- *) (* -------------------------------------------------------------------------- *) type thread = { mutable task : unit task ; mutable lock : bool ; } let thread task = { task = (task >>= fun _ -> nop) ; lock = false } let cancel th = th.task <- Monad.cancel th.task let running th = th.lock || begin try th.lock <- true ; let t = Monad.progress th.task in th.task <- t ; th.lock <- false ; Monad.waiting t with e -> th.lock <- false ; raise e end let run th = !on_idle (fun () -> (running th)) (* -------------------------------------------------------------------------- *) (* --- Task Pool --- *) (* -------------------------------------------------------------------------- *) type pool = thread list ref let pool () = ref [] let iter f p = let rec walk f = function | [] -> [] | t::ts -> if running t then f t ; let ts = walk f ts in if running t then t :: ts else ts in p := walk f !p let add p t = let ps = List.filter running !p in p := if running t then t :: ps else ps let flush p = p := List.filter running !p let size p = flush p ; List.length !p (* -------------------------------------------------------------------------- *) (* --- Task Server --- *) (* -------------------------------------------------------------------------- *) type callbacks = (unit -> unit) list (* Invariant: terminated + (length running) + Sum ( length queue.(i) ) == scheduled *) type server = { queue : thread Queue.t array ; mutable scheduled : int ; mutable terminated : int ; mutable running : thread list ; mutable procs : int ; mutable waiting : bool ; mutable wait : callbacks ; mutable activity : callbacks ; mutable start : callbacks ; mutable stop : callbacks ; } let fire callbacks = List.iter (fun f -> f ()) callbacks let server ?(stages=1) ?(procs=4) () = { queue = Array.init stages (fun _ -> Queue.create ()) ; running = [] ; procs = procs ; scheduled = 0 ; terminated = 0 ; activity = [] ; start = [] ; stop = [] ; wait = [] ; waiting = false ; } let set_procs s p = s.procs <- p let on_server_activity s cb = s.activity <- s.activity @ [cb] let on_server_wait s cb = s.wait <- s.wait @ [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 ?pool ?(stage=0) thread = begin (match pool with None -> () | Some pool -> add pool thread) ; Queue.push thread server.queue.(stage) ; (* queue(i) ++ *) server.scheduled <- succ server.scheduled ; (* scheduled ++ *) server.waiting <- false ; end (* invariant holds *) let scheduled s = s.scheduled let terminated s = s.terminated let waiting s = if s.waiting || s.running = [] then None else Some (List.length s.running) let is_empty server = try Array.iter (fun q -> if not (Queue.is_empty q) then raise Exit) server.queue ; true with Exit -> false 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 running 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 begin if not server.waiting && is_empty server then begin fire server.wait ; server.waiting <- true ; end ; true end 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) ) frama-c-Phosphorus-20170501/src/libraries/utils/cilconfig.mli0000644000175000017500000001201413113745012022725 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-Phosphorus-20170501/src/libraries/utils/filepath.ml0000644000175000017500000001445513113745012022426 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 path = { hash : int ; path : string ; (* full path *) name : string ; (* Filename.basename *) dir : path option ; (* Filename.dirname *) mutable symbol : string ; (* Symbolic name, or "" *) } let dummy = {path="";hash=0;name="";dir=None;symbol=""} (* re_drive and re_root match drive expressions to deal with non-Cygwin Windows-like paths (e.g. with MinGW) *) let re_drive = Str.regexp "[A-Za-z]:" let re_path = Str.regexp "[/\\\\]" let re_root = Str.regexp "/\\|\\([A-Za-z]:\\\\\\)\\|\\([A-Za-z]:/\\)" (* -------------------------------------------------------------------------- *) (* --- H-Consing --- *) (* -------------------------------------------------------------------------- *) (* Can not use Weak, since the internal [path] representation is not returned. Use a weak-cache, however. *) module W = struct module H = Hashtbl.Make (struct type t = path let hash p = p.hash let equal p q = p.path = q.path end) let find = H.find let create = H.create let merge h p = try H.find h p with Not_found -> H.add h p p ; p end let hcons = W.create 128 let cache = Weak.create 256 let root path = W.merge hcons { dummy with path ; hash = Hashtbl.hash path } let make dir name = let path = Printf.sprintf "%s/%s" dir.path name in let hash = Hashtbl.hash path in W.merge hcons { dummy with path ; hash ; name ; dir = Some dir } let getdir p = match p.dir with | None -> (* the parent of the root directory is itself *) dummy | Some d -> d let rec norm path = function | [] -> path | ".."::fs -> norm (getdir path) fs | "."::fs -> norm path fs | f::fs -> norm (make path f) fs let insert pwd file = let hash = Hashtbl.hash file in match Weak.get cache (hash land 255) with | Some (f0,p0) when file = f0 -> p0 | _ -> let p0 = { dummy with path = file ; hash } in try W.find hcons p0 with Not_found -> let base = if Str.string_match re_root file 0 then root (String.sub file 0 (Str.group_end 0 - 1)) else pwd in let parts = Str.split re_path file in (* Windows paths may start with ':'. If so, remove it *) let parts = if List.length parts > 0 && Str.string_match re_drive (List.nth parts 0) 0 then List.tl parts else parts in let path = norm base parts in Weak.set cache (hash land 255) (Some(file,path)) ; path let pwd = insert dummy (Sys.getcwd()) let normalize ?base p = if p = "" then raise (Invalid_argument "Filepath.normalize"); let base = match base with None -> pwd | Some p -> insert pwd p in let res = (insert base p).path in if res = "" then "/" else res (* -------------------------------------------------------------------------- *) (* --- Symboling Names --- *) (* -------------------------------------------------------------------------- *) let add_symbolic_dir name dir = (insert pwd dir).symbol <- name let rec add_path buffer p = let open Buffer in if p.symbol <> "" then add_string buffer p.symbol else match p.dir with | None -> add_string buffer p.path | Some d -> if d != pwd (* hconsed *) then ( add_path buffer d ; add_char buffer '/' ) ; add_string buffer p.name let rec skip_dot f = if Extlib.string_prefix "./" f then skip_dot (String.sub f 2 (String.length f - 2)) else f let pretty file = if Filename.is_relative file then skip_dot file else let path = insert pwd file in let file = path.path in let pwd = pwd.path in if Extlib.string_prefix ~strict:true pwd file then let n = 1 + String.length pwd in String.sub file n (String.length file - n) else let buffer = Buffer.create 80 in add_path buffer path ; Buffer.contents buffer (* -------------------------------------------------------------------------- *) (* --- Relative Paths --- *) (* -------------------------------------------------------------------------- *) let relativize ?base file = let file = (insert pwd file).path in let base = match base with | None -> pwd.path | Some base -> (insert pwd base).path in if Extlib.string_prefix ~strict:true base file then let n = 1 + String.length base in String.sub file n (String.length file - n) else file let is_relative ?base file = let file = (insert pwd file).path in let base = match base with | None -> pwd.path | Some base -> (insert pwd base).path in Extlib.string_prefix ~strict:true base file (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/utils/binary_cache.ml0000644000175000017500000003211713113745003023234 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 memory_footprint_var_name = "FRAMA_C_MEMORY_FOOTPRINT" let memory_footprint = let error () = Cmdline.Kernel_log.error "@[Bad value for environment variable@ %s.@ Expected value: \ integer between@ 1 and 10.@ Using@ default value@ of 2.@]" memory_footprint_var_name; 2 in try let i = int_of_string (Sys.getenv memory_footprint_var_name) in if i <= 0 || i > 10 then error () else i with | Not_found -> 2 | Failure _ -> error () let cache_size = 1 lsl (8 + memory_footprint) (** The caches of this module are lazy, for two reasons: - some caches are never used, because the function that created them is never called. This typically happens for functors implementing generic datastructures, where not all functions are used in every module (but every function with a static cache creates its cache nevertheless) - Caches must be cleared as soon as some states change, in order to remain coherent (for example, when the current project changes). When setting multiple command-line options, the caches may be cleared after each option. When caches are big, this becomes very time-consuming. To avoid this, the functions [clear] do nothing when the caches have not been forced yet. (This is not perfect: once a lazy cache has been forced, each 'clear' operation becomes costly again.) *) let (!!) = Lazy.force 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_4 = struct type ('a, 'b, 'c, 'd) t let (clear : ('a , 'b , 'c , 'd) t -> 'a -> 'b -> 'c -> 'd -> unit) = fun t a b c d -> let t = Obj.repr t in let size4 = Obj.size t in let i = ref 0 in while (!i < size4) 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); i := base + 7; done let (make : int -> 'a -> 'b -> 'c -> 'd -> ('a , 'b , 'c , 'd) t) = fun size a b c d -> let size4 = 4 * size in let t = Obj.obj (Obj.new_block 0 size4) in clear t a b c d; t let (set : ('a, 'b, 'c, 'd) t -> int -> 'a -> 'b -> 'c -> 'd -> unit) = fun t i a b c d -> let t = Obj.repr t in let base = 4 * 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); ;; let (get0 : ('a, 'b, 'c, 'd) t -> int -> 'a) = fun t i -> let t = Obj.repr t in let base = 4 * i in Obj.obj (Obj.field t (base)) let (get1 : ('a, 'b, 'c, 'd) t -> int -> 'b) = fun t i -> let t = Obj.repr t in let base = 4 * i in Obj.obj (Obj.field t (base+1)) let (get2 : ('a, 'b, 'c, 'd) t -> int -> 'c) = fun t i -> let t = Obj.repr t in let base = 4 * i in Obj.obj (Obj.field t (base+2)) let (get3 : ('a, 'b, 'c, 'd) t -> int -> 'd) = fun t i -> let t = Obj.repr t in let base = 4 * i in Obj.obj (Obj.field t (base+3)) end module Symmetric_Binary (H: Cacheable) (R: Result) = struct let size = cache_size let cache = lazy (Array_3.make size H.sentinel H.sentinel R.sentinel) let mask = pred size let clear () = if Lazy.is_val cache then 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 Arity_One (H: Cacheable) (R: Result) = struct let size = cache_size let cache = lazy (Array_2.make size H.sentinel R.sentinel) let mask = pred size let clear () = if Lazy.is_val cache then Array_2.clear !!cache H.sentinel R.sentinel let merge f a0 = let h0 = H.hash a0 in let has = h0 land mask in if H.equal (Array_2.get0 !!cache has) a0 then begin (* Format.printf "Cache O@."; *) Array_2.get1 !!cache has end else let result = f a0 in (* Format.printf "Cache N@."; *) Array_2.set !!cache has a0 result; result end module Arity_Two (H0: Cacheable) (H1: Cacheable) (R: Result) = struct let size = cache_size let cache = lazy (Array_3.make size H0.sentinel H1.sentinel R.sentinel) let mask = pred size let clear () = if Lazy.is_val cache then Array_3.clear !!cache H0.sentinel H1.sentinel R.sentinel let merge f a0 a1 = let h0 = H0.hash a0 in let h1 = H1.hash a1 in let has = h1 lsl 5 - h1 + h0 in let has = has land mask in if H0.equal (Array_3.get0 !!cache has) a0 && H1.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 Arity_Three (H0: Cacheable) (H1: Cacheable) (H2: Cacheable) (R: Result) = struct let size = cache_size let cache = lazy (Array_4.make size H0.sentinel H1.sentinel H2.sentinel R.sentinel) let mask = pred size let clear () = if Lazy.is_val cache then Array_4.clear !!cache H0.sentinel H1.sentinel H2.sentinel R.sentinel let merge f a0 a1 a2 = let h0 = H0.hash a0 in let h1 = H1.hash a1 in let h2 = H2.hash a2 in let has = h0 + 117 * h1 + 2375 * h2 in let has = has land mask in if H0.equal (Array_4.get0 !!cache has) a0 && H1.equal (Array_4.get1 !!cache has) a1 && H2.equal (Array_4.get2 !!cache has) a2 then begin (* Format.printf "Cache O@."; *) Array_4.get3 !!cache has end else let result = f a0 a1 a2 in (* Format.printf "Cache N@."; *) Array_4.set !!cache has a0 a1 a2 result; result end module Array_Bit = struct let make size = let size = (size + 7) lsr 3 in Bytes.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 (Bytes.get 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 (Bytes.get s c) in let newcontents = if v then b lor oldcontents else let mask = lnot b in oldcontents land mask in Bytes.set s c (Char.chr newcontents) let clear s = let zero = char_of_int 0 in Bytes.fill s 0 (Bytes.length s) zero end module Binary_Predicate (H0: Cacheable) (H1: Cacheable) = struct let size = cache_size let cache = lazy (Array_2.make size H0.sentinel H1.sentinel) let result = lazy (Array_Bit.make size) let mask = pred size let clear () = if Lazy.is_val cache then Array_2.clear !!cache H0.sentinel H1.sentinel; if Lazy.is_val result then 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 Symmetric_Binary_Predicate (H0: Cacheable) = struct let size = cache_size let cache = lazy (Array_2.make size H0.sentinel H0.sentinel) let result = lazy (Array_Bit.make size) let mask = pred size let clear () = if Lazy.is_val cache then Array_2.clear !!cache H0.sentinel H0.sentinel; if Lazy.is_val result then 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 (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/utils/binary_cache.mli0000644000175000017500000000605513113745012023407 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. *) val memory_footprint_var_name: string val cache_size: int (** Size of the caches. Controlled by environment variable [memory_footprint_var_name]. *) 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 Symmetric_Binary(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 Binary_Predicate(H0 : Cacheable)(H1 : Cacheable): sig val clear : unit -> unit val merge : (H0.t -> H1.t -> bool) -> H0.t -> H1.t -> bool end module Symmetric_Binary_Predicate(H0 : Cacheable): sig val clear : unit -> unit val merge : (H0.t -> H0.t -> bool) -> H0.t -> H0.t -> bool end module Arity_One(H : Cacheable)(R : Result): sig val clear : unit -> unit val merge : (H.t -> R.t) -> H.t -> R.t end module Arity_Two(H0 : Cacheable)(H1 : Cacheable)(R : Result): sig val clear : unit -> unit val merge : (H0.t -> H1.t -> R.t) -> H0.t -> H1.t -> R.t end module Arity_Three(H0 : Cacheable)(H1 : Cacheable)(H2 : Cacheable)(R : Result): sig val clear : unit -> unit val merge : (H0.t -> H1.t -> H2.t -> R.t) -> H0.t -> H1.t -> H2.t -> R.t end (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/utils/rgmap.mli0000644000175000017500000000671713113745006022116 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** Associative maps for _ranges_ to _values_ with overlapping. The maps register a collection of entries, and looks for all entries containing some specified range. For instance, this data structure is well suited to attach tags to AST-nodes in GUI, where each node is associated to buffer offset ranges. When several entries cover a range, precedence goes to the tightest ones. When overlapping entries with the same width applies, the result of lookup is not specified. Remark that for AST-based ranges, overlapping ranges are always included one in the order. Current implementation has average [log(n)] complexity for adding [n] entries, and [log(n)^2] for lookup ranges, which is far from better than current implementation used in [Pretty_source] for instance. *) type 'a t (** The type of range maps, containing of collection of ['a entry]. *) type 'a entry = int * int * 'a (** Entry [(a,b,v)] maps range [a..b] (both included) to value [v] in the map. *) val empty : 'a t (** The empty map. *) val add : ?overlap:bool -> 'a entry -> 'a t -> 'a t (** Returns a new map with the added entry. When [~overlap:true] is specified, overlapping entries with the same width are removed first, avoiding under-specified results. It is safe to ignore this attribute for AST-based maps. *) val find : int -> int -> 'a t -> 'a entry (** Find the tightest entry containing the specified range. @raise Not_found if no entry applies *) val find_all : int -> int -> 'a t -> 'a entry list (** Find all entries containing the specified range. Returns the empty list is none applies. When overlapping entries with the same width are present in the map, only one for each width is returned. *) val iter : ('a entry -> unit) -> 'a t -> unit (** Iter over all entries present in the map. Entries are present in increasing order of width. *) frama-c-Phosphorus-20170501/src/libraries/utils/cilconfig.ml0000644000175000017500000002313113113745010022554 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 _ -> 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 _ -> 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-Phosphorus-20170501/src/libraries/utils/indexer.ml0000644000175000017500000001317413113745005022267 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 is_empty = function Empty -> true | Node _ -> false 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 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-Phosphorus-20170501/src/libraries/utils/hptset.ml0000644000175000017500000001501413113745007022135 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 Datatype.S_with_collections include FCSet.S_Basic_Compare with type t := t val contains_single_elt: t -> elt option val intersects: t -> t -> bool type action = Neutral | Absorbing | Traversing of (elt -> bool) val merge : cache:Hptmap_sig.cache_type -> symmetric:bool -> idempotent:bool -> decide_both:(elt -> bool) -> decide_left:action -> decide_right:action -> t -> t -> t type 'a shape val shape: t -> unit shape val from_shape: 'a shape -> t val fold2_join_heterogeneous: cache:Hptmap_sig.cache_type -> empty_left:('a shape -> 'b) -> empty_right:(t -> 'b) -> both:(elt -> 'a -> 'b) -> join:('b -> 'b -> 'b) -> empty:'b -> t -> 'a shape -> 'b val clear_caches: unit -> unit val pretty_debug: t Pretty_utils.formatter end module Make(X: Hptmap.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 and type 'a shape = 'a Hptmap.Shape(X).t val self : State.t end = struct type elt = X.t module M = Hptmap.Make (X) (struct include Datatype.Unit let pretty_debug = pretty end) (Hptmap.Comp_unused) (struct let v = List.map (List.map (fun k -> k, ())) Initial_Values.v end) (Datatype_deps) include M let add k s = add k () s let iter f s = iter (fun x () -> f x) s let fold f s = fold (fun x () -> f x) s 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 choose s = fst (min_binding s) 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 find x s = find_key x s let inter = let name = Format.sprintf "Hptset(%s).inter" X.name in inter ~cache:(Hptmap_sig.PersistentCache name) ~symmetric:true ~idempotent:true ~decide:(fun _ () () -> Some ()) (* Test that implementation of function inter in Hptmap is correct *) let _test_inter s1 s2 = let i1 = fold (fun x acc -> if mem x s1 then add x acc else acc) s2 empty in let i2 = inter s1 s2 in if not (i1 == i2) then Cmdline.Kernel_log.error "%a@./@.%a@.->@.%a@./@.%a" pretty_debug s1 pretty_debug s2 pretty_debug i1 pretty_debug i2; i1 let union = let name = Format.sprintf "Hptset(%s).union" X.name in join ~cache:(Hptmap_sig.PersistentCache name) ~decide:(fun _ () () -> ()) ~symmetric:true ~idempotent:true let singleton x = add x empty let exists f s = exists (fun k () -> f k) s let for_all f s = for_all (fun k () -> f k) s let subset = let name = Format.sprintf "Hptset(%s).subset" X.name in binary_predicate (Hptmap_sig.PersistentCache name) UniversalPredicate ~decide_fast:decide_fast_inclusion ~decide_fst:(fun _ () -> false) ~decide_snd:(fun _ () -> true) ~decide_both:(fun _ () () -> true) let pretty = if X.pretty == Datatype.undefined then Datatype.undefined else Pretty_utils.pp_iter ~pre:"@[{" ~sep:",@ " ~suf:"}@]" iter X.pretty let split key t = let l, pres, r = split key t in l, pres <> None, r let intersects = let name = Format.asprintf "Hptset(%s).intersects" X.name in symmetric_binary_predicate (Hptmap_sig.PersistentCache name) ExistentialPredicate ~decide_fast:decide_fast_intersection ~decide_one:(fun _ () -> false) ~decide_both:(fun _ () () -> true) let of_list l = List.fold_left (fun acc key -> add key acc) empty l type action = Neutral | Absorbing | Traversing of (elt -> bool) let translate_action = function | Neutral -> M.Neutral | Absorbing -> M.Absorbing | Traversing f -> M.Traversing (fun k () -> if f k then Some () else None) let merge ~cache ~symmetric ~idempotent ~decide_both ~decide_left ~decide_right = let decide_both = fun k () () -> if decide_both k then Some () else None and decide_left = translate_action decide_left and decide_right = translate_action decide_right in merge ~cache ~symmetric ~idempotent ~decide_both ~decide_left ~decide_right let diff = let name = Format.sprintf "Hptset(%s).diff" X.name in merge ~cache:(Hptmap_sig.PersistentCache name) ~symmetric:false ~idempotent:false ~decide_both:(fun _ -> false) ~decide_left:Neutral ~decide_right:Absorbing let from_shape m = from_shape (fun _ _ -> ()) m (* Partial application is needed because of caches *) let fold2_join_heterogeneous ~cache ~empty_left ~empty_right ~both ~join ~empty = let both k () v = both k v in fold2_join_heterogeneous ~cache ~empty_left ~empty_right ~both ~join ~empty end (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/utils/rangemap.mli0000644000175000017500000002444513113745005022577 0ustar mehdimehdi(**************************************************************************) (* *) (* 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 library, 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. *) 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 (** Intervals that match the given key. The resulting list is sorted in decreasing order. *) 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-Phosphorus-20170501/src/libraries/datatype/0000755000175000017500000000000013113745013020743 5ustar mehdimehdiframa-c-Phosphorus-20170501/src/libraries/datatype/type.ml0000644000175000017500000006063413113745006022271 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 = { mutable 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.t_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 _ _ -> ()) exception No_abstract_type of string module Abstract(T: sig val name: string end) = struct type t let ty = if !use_obj then try (Hashtbl.find types T.name).ty with Not_found -> raise (No_abstract_type T.name) 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 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 = Format.asprintf "%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 set_name ty name = let full_ty = try Hashtbl.find types ty.name with Not_found -> assert false in Hashtbl.remove types ty.name; ty.name <- name; Hashtbl.add types name full_ty 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 = Format.asprintf "%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 (type a) (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 = Format.asprintf "%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 (type a) (type b) (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 (type a) (type b) (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 (type a) (type b) (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 = Format.asprintf "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): ('a, 'b) poly t * bool = 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.t_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 = Format.asprintf "%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 (type a) (type b) (type c) (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 = Format.asprintf "%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 (type a) (type b) (type c) (type d) (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 (type a) tbl (ty:a ty) (x:a Info.t) = Tbl.add tbl ty (Obj.repr x) let find (type a) 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 invocation). *) 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-Phosphorus-20170501/src/libraries/datatype/unmarshal_hashtbl_test.ml0000644000175000017500000001156613113745007026047 0ustar mehdimehdi(**************************************************************************) (* *) (* 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 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 ''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 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-Phosphorus-20170501/src/libraries/datatype/datatype.ml0000644000175000017500000020360013113745002023107 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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.t_unknown let rehash = undefined end module Serializable_undefined = struct include Partial_undefined let structural_descr = Structural_descr.t_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 Transitioning.String.uncapitalize_ascii 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] = Transitioning.Char.uppercase_ascii 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 FCSet.S include S with type t := t end module type Map = sig include FCMap.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 FCHashtbl.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 = Format.asprintf "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 = Format.asprintf "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 = Format.asprintf "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 "@[%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 (** warning is unsound in that case: http://caml.inria.fr/mantis/view.php?id=7314#c16232 *) [@@@ warning "-60"] 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 [@@@ warning "+60"] 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_gen(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 = Format.asprintf "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_gen(X: S)(R: sig val rehash: X.t poly -> X.t poly end) = 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 = R.rehash 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 module Polymorphic(P: Polymorphic_input) = struct include Polymorphic_gen(P) module Make(X: S) = Make_gen (X) (struct let rehash = if Descr.is_unmarshable X.descr then undefined else identity 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 "@[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 "@[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 "@[[ %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 Arrays} *) (* ****************************************************************************) let () = poly_name_ref := "array" module Poly_array = Polymorphic (struct type 'a t = 'a array let name ty = Type.par_ty_name is_function_or_pair ty ^ " array" let module_name = "Datatype.Array" let reprs ty = [ [| ty |] ] let structural_descr = Structural_descr.t_array exception Early_exit of int let mk_equal f a1 a2 = let size = Array.length a1 in if Array.length a2 != size then false else try for i = 0 to size - 1 do if not (f a1.(i) a2.(i)) then raise (Early_exit 0) done; true with Early_exit _ -> false ;; let mk_compare f a1 a2 = if a1 == a2 then 0 else let size1 = Array.length a1 and size2 = Array.length a2 in if size1 < size2 then -1 else if size2 > size1 then 1 else try for i = 0 to size1 do let n = f a1.(i) a2.(i) in if n != 0 then raise (Early_exit n) done; 0 with Early_exit n -> n ;; (* Do not spend too much time hashing long arrays... *) let mk_hash f a = let max = max 15 ((Array.length a) - 1) in let acc = ref 1 in for i = 0 to max do acc := 257 * !acc + f a.(i) done; !acc ;; let map = Array.map let mk_internal_pretty_code f p fmt a = let pp fmt = Format.fprintf fmt "@[[| %t |]@]" (fun fmt -> let length = Array.length a in match length with | 0 -> () | _ -> (Format.fprintf fmt "%a" (f Type.List) a.(0); for i = 1 to (length - 1) do Format.fprintf fmt ";@;%a" (f Type.List) a.(i) done)) in Type.par p Type.Basic fmt pp (* Never enclose arrays 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 a = try for i = 0 to (Array.length a - 1) do if mem f a.(i) then raise (Early_exit 0) done; false with Early_exit _ -> true end) module Array = Poly_array.Make let array (type typ) (ty: typ Type.t) = let module L = Array(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 (* OCaml functors are generative *) module Set (S: FCSet.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 = if Descr.is_unmarshable E.descr then undefined else if Descr.is_abstract E.descr then identity else fun s -> (* The key changed, rebalance the tree *) S.fold S.add s S.empty 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 "@[%s.singleton@;%a@]" Info.module_name (E.internal_pretty_code Type.Call) (Caml_list.hd (S.elements s)) else Format.fprintf fmt "@[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 = let pp_elt pp fmt v = Format.fprintf fmt "@[%a@]" pp v in Pretty_utils.pp_iter ~pre:"@[{@ " ~sep:";@ " ~suf:"@ }@]" S.iter (pp_elt E.pretty) fmt 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 Map (M: FCMap.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_gen = Polymorphic_gen (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 "@[@[let map =@;%t@;<1 -2>in@]" pp_empty; M.iter (fun k v -> Format.fprintf fmt "@[let map =@;%s.add@;@[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) module P = struct include P_gen module Make(X:S) = Make_gen (X) (struct let rehash = if Descr.is_unmarshable Key.descr || Descr.is_unmarshable X.descr then undefined else if Descr.is_abstract Key.descr then identity else (* the key changed: rebuild the map *) fun m -> M.fold M.add m M.empty; end) end include M module Key = Key module Make = P.Make end (* ****************************************************************************) (** {3 Hashtbl} *) (* ****************************************************************************) (* 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_gen = Polymorphic_gen (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) module P = struct include P_gen module Make(X:S) = Make_gen (X) (struct let rehash = if Descr.is_unmarshable Key.descr || Descr.is_unmarshable X.descr then undefined else if Descr.is_abstract Key.descr then identity else (* the key changed: rebuild the hashtbl *) fun h -> let h' = H.create (H.length h) in H.iter (H.add h') h; h' end) 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 (FCSet.Make(D)) (D) (struct let module_name = Info.module_name ^ ".Set" end) module Map = Map (FCMap.Make(D)) (D) (struct let module_name = Info.module_name ^ ".Map" end) module Hashtbl = Hashtbl (struct include FCHashtbl.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 = Transitioning.String.capitalize_ascii 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." ^ Transitioning.String.capitalize_ascii X.name include With_collections (Make(struct type t = X.t let name = X.name let reprs = X.reprs let structural_descr = Structural_descr.t_abstract let equal = X.equal let compare = X.compare let hash = FCHashtbl.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 = Extlib.id (* immutable strings do not need 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.t_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 Integer = Make_with_collections (struct type t = Integer.t let name = "Datatype.Integer" let reprs = [ Integer.zero ] let structural_descr = Structural_descr.t_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 "Integer.of_string %S" (Integer.to_string n) in Type.par par Type.Call fmt pp (* TODO: this should take into account kernel's option -big-ints-hex *) let pretty = Integer.pretty ~hexa:false let varname _ = "integer_n" let mem_project = never_any_project end) let integer = Integer.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 "@[%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 (** warning is unsound in that case: http://caml.inria.fr/mantis/view.php?id=7314#c16232 *) [@@@ warning "-60"] 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) [@@@warning "+60"] 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 "@[%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 (** warning is unsound in that case: http://caml.inria.fr/mantis/view.php?id=7314#c16232 *) [@@@ warning "-60"] 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 [@@@ warning "+60"] 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) module Array_with_collections(T:S)(Info:Functor_info) = With_collections (Array(T))(Info) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/datatype/type.mli0000644000175000017500000003537113113745010022435 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. *) exception No_abstract_type of string (** Apply this functor to access to the abstract type of the given name. @raise No_abstract_type if no such abstract type was registered. @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 val set_name: 'a t -> string -> unit (** @since Neon-20140301 *) (* ****************************************************************************) (** {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 = 'a -> 'b 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 labeled parameter [p]; - [~label:(p,Some f)] for an optional labeled parameter [p], with default value [f ()]. *) val is_instance_of: 'a t -> bool val get_instance: ('a -> 'b) t -> 'a t * 'b t * string option val get_optional_argument: ('a -> 'b) 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 (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/datatype/unmarshal_z.mli0000644000175000017500000000312513113745002023770 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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-Phosphorus-20170501/src/libraries/datatype/structural_descr.mli0000644000175000017500000001504013113745012025035 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 = private | 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 = private | 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_unknown: t (** @since Neon-20140301 *) val t_abstract: t (** @since Neon-20140301 *) 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 val t_sum: pack array array -> t (** @since Neon-20140301 *) (** 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 of_pack: single_pack -> t val cleanup: t -> t val are_consistent: t -> t -> bool (** Not symmetrical: check that the second argument is a correct refinement of the first one. *) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/datatype/datatype.mli0000644000175000017500000005637513113745001023276 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 representants 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 = ... let mem_project = ... (* Usually, Datatype.never_any_project *) (* define only useful functions for this datatype *) end] *) module Undefined: Undefined (** Same as {!Undefined}, but the type is supposed to be marshallable 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 FCSet.S include S with type t := t end (** A standard OCaml map signature extended with datatype operations. *) module type Map = sig include FCMap.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 FCHashtbl.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 *) (** @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 *) (** @deprecated use Integer instead. *) module Integer: S_with_collections with type t = Integer.t val integer: Integer.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 @plugin development guide *) 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 @plugin development guide *) 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_array: Polymorphic with type 'a poly = 'a array (** @since Neon-20140301 *) module Array(T: S) : S with type t = T.t array (** @since Neon-20140301 *) module Array_with_collections(T:S)(Info:Functor_info): S_with_collections with type t = T.t array (** @since Neon-20140301 *) val array: 'a Type.t -> 'a array Type.t (** @since Neon-20140301 *) 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: FCSet.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: FCMap.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-Phosphorus-20170501/src/libraries/datatype/unmarshal.mli0000644000175000017500000001721413113745004023445 0ustar mehdimehdi(**************************************************************************) (* *) (* 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 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 ''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 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. *) (** {2 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 (** {2 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-Phosphorus-20170501/src/libraries/datatype/descr.mli0000644000175000017500000001344313113745010022550 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 power as {!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 unmarshallable types. @since Carbon-20101201 *) val is_unmarshable: 'a t -> bool (** @since Carbon-20101201 *) val is_abstract: 'a t -> bool (** @since Neon-20140301 *) (* ********************************************************************** *) (** {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-Phosphorus-20170501/src/libraries/datatype/unmarshal_test.ml0000644000175000017500000002011713113745011024325 0ustar mehdimehdi(**************************************************************************) (* *) (* 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 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 ''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 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;; (* 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-Phosphorus-20170501/src/libraries/datatype/structural_descr.ml0000644000175000017500000003146413113745011024673 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 of_pack p = T_pack p 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_abstract = Abstract let t_unknown = Unknown 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 = function | Abstract -> Abstract | Unknown -> Unknown | Structure _ | T_pack _ as a -> try from_unmarshal (f (to_unmarshal a)) with Cannot_pack -> Unknown (* would be better to put it in Extlib, but no access to this library here *) let array_for_all f a = try Array.iter (fun x -> if not (f x) then raise Exit) a; true with Exit -> false let is_abstract_array a = array_for_all (fun x -> x = Pack Unmarshal.Abstract) a let poly_arr f a = if is_abstract_array a then Abstract else 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 = match a, b with | Abstract, Abstract -> Abstract | _, _ -> (* no special case for [Unknown]: sometimes, even if one part of the container is unknown, it can be unmarshaled. *) 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) let t_sum a = if array_for_all (is_abstract_array) a then Abstract else Structure (Sum a) (* ********************************************************************** *) (** {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) | Unmarshal.Abstract, Unmarshal.Structure _ -> true (* we provide a more precise version: accept it *) | _, _ -> 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 | Abstract, Structure _ -> true (* we provide a more precise version: accept it *) | Structure _, Abstract -> false | _, _ -> 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-Phosphorus-20170501/src/libraries/datatype/descr.ml0000644000175000017500000001563013113745013022402 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 t_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 let is_abstract x = x = uncheck_pack Unmarshal.Abstract (* ********************************************************************** *) (** {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 -> t_unknown | Pack p -> of_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-Phosphorus-20170501/src/libraries/datatype/unmarshal_z.ml0000644000175000017500000000531713113745005023627 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** unmarshal zarith custom blocks *) open Unmarshal;; let readz ch = let sign = read8u ch in let charlen = read32u ch in let str = Bytes.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 (Bytes.to_string 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-Phosphorus-20170501/src/libraries/datatype/unmarshal.ml0000644000175000017500000005514013113745007023277 0ustar mehdimehdi(**************************************************************************) (* *) (* 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 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 ''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 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 reason = let msg = "input_value: ill-formed message" in failwith (if false(*debug*) then Printf.sprintf "%s (%s)" msg reason else msg) 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 : bytes) ofs len ;; let readblock_rev ch dest ofs len = for i = len - 1 + ofs downto ofs do Bytes.unsafe_set (Obj.obj dest : bytes) 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. *) (* Not used by Frama-C, causing problems with ARM, see: http://lists.gforge.inria.fr/pipermail/frama-c-discuss/2013-August/003702.html 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 = Bytes.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 Bytes.sub buf 0 i else begin let res = Bytes.concat Bytes.empty (List.rev (Bytes.sub buf 0 i :: !bufs)) in bufs := []; res end end else if i >= buflen then begin assert (i = buflen); bufs := Bytes.copy buf :: !bufs; loop 0 end else begin Bytes.set buf i c; loop (i + 1) end in loop 0 |> Bytes.to_string ;; 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 *) -> assert false (* NOT USED BY Frama-C 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 | _ -> ill_formed (Printf.sprintf "code %x" code) 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 ill_formed "dep pair" end | Structure (Sum a) -> if tag >= Array.length a || size != Array.length a.(tag) then begin let s = Format.sprintf "structure sum tag=%d size=%d len=%d len-tag=%d" tag size (Array.length a) (Array.length a.(tag)) in ill_formed s 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 (Bytes.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 ill_formed "shared" 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 ge_ocaml ~major ?(minor=0) ?(rev=0) () = let test x y z = x > major || (x = major && (y > minor || y = minor && z >= rev)) in Scanf.sscanf Sys.ocaml_version "%d.%d.%d" test let ge_ocaml_4 = ge_ocaml ~major:4 () let ge_ocaml_403 = ge_ocaml ~major:4 ~minor:3 () 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 = if ge_ocaml_403 then (* queue cells are only a list-like structure, but there is no distinguishable difference at this level. *) t_record [| t_int; t_list a; t_list a |] else 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 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-Phosphorus-20170501/src/libraries/stdlib/0000755000175000017500000000000013113745012020410 5ustar mehdimehdiframa-c-Phosphorus-20170501/src/libraries/stdlib/FCMap.ml0000644000175000017500000000743113113745002021674 0ustar mehdimehdi(**************************************************************************) (* *) (* 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). *) (* *) (**************************************************************************) module type S = sig type key type +'a t val empty: 'a t val is_empty: 'a t -> bool val mem: key -> 'a t -> bool val add: key -> 'a -> 'a t -> 'a t val singleton: key -> 'a -> 'a t val remove: key -> 'a t -> 'a t val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val iter: (key -> 'a -> unit) -> 'a t -> unit val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val for_all: (key -> 'a -> bool) -> 'a t -> bool val exists: (key -> 'a -> bool) -> 'a t -> bool val filter: (key -> 'a -> bool) -> 'a t -> 'a t val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t val cardinal: 'a t -> int val bindings: 'a t -> (key * 'a) list val min_binding: 'a t -> (key * 'a) val max_binding: 'a t -> (key * 'a) val choose: 'a t -> (key * 'a) val split: key -> 'a t -> 'a t * 'a option * 'a t val find: key -> 'a t -> 'a val map: ('a -> 'b) -> 'a t -> 'b t val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t end module Make = Map.Make frama-c-Phosphorus-20170501/src/libraries/stdlib/transitioning.mli0000644000175000017500000000523213113745001024003 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 contains functions that uses features that are deprecated in current OCaml version, but whose replacing feature is not available in the oldest OCaml version officially supported by Frama-C. Be sure to update it when support for a given version is dropped. Functions are grouped according to the version in which the replacing feature did appear. *) (** {1 4.03.0} *) (** In OCaml 4.03, many functions [f] from String have been deprecated in favor of [f_ascii], which operate only on the ASCII charset, while the deprecated [f] knew about iso-8859-1. We use the new names here, so that when support of 4.02.3 is dropped, client code will just have to erase [Transitioning.] to use directly the stdlib version *) module String: sig val uppercase_ascii: string -> string val capitalize_ascii: string -> string val uncapitalize_ascii: string -> string val lowercase_ascii: string -> string end (** See above documentation for [String] *) module Char: sig val uppercase_ascii: char -> char val lowercase_ascii: char -> char end frama-c-Phosphorus-20170501/src/libraries/stdlib/extlib.ml0000644000175000017500000003277513113745011022246 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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.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 follows: 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 let uncurry f x = f (fst x) (snd x) let iter_uncurry2 iter f v = iter (fun a b -> f (a, b)) v (* ************************************************************************* *) (** {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 replace cmp x l = let rec aux = function | [] -> [x] | y::l -> if cmp x y then x::l else y :: aux l in aux l 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 (* Remove duplicates from a sorted list *) let list_unique cmp l = let rec aux acc = function | [] -> acc | [e] -> e :: acc | e1 :: (e2 :: _ as q) -> if cmp e1 e2 = 0 then aux acc q else aux (e1 :: acc) q in List.rev (aux [] l) (* Remove once OCaml 4.02 is mandatory *) let sort_unique cmp l = list_unique cmp (List.sort cmp l) let subsets k l = let rec aux k l len = if k = 0 then [[]] else if len < k then [] else if len = k then [l] else match l with | h :: t -> let l1 = List.map (fun sl -> h :: sl) (aux (k-1) t (len-1)) in let l2 = aux k t (len-1) in l1 @ l2 | [] -> assert false in aux k l (List.length l) (* ************************************************************************* *) (** {2 Arrays} *) (* ************************************************************************* *) let array_exists f a = try for i = 0 to Array.length a - 1 do if f a.(i) then raise Exit done; false with Exit -> true let array_existsi f a = try for i = 0 to Array.length a - 1 do if f i a.(i) then raise Exit done; false with Exit -> true (* ************************************************************************* *) (** {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 ?exn = function | None -> begin match exn with | None -> invalid_arg "Extlib.the" | Some exn -> raise exn end | 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 let opt_hash hash v = match v with | None -> 31179 | Some v -> hash v (* ************************************************************************* *) (** Booleans *) (* ************************************************************************* *) let xor x y = if x then not y else y (* ************************************************************************* *) (** {2 Performance} *) (* ************************************************************************* *) (* replace "noalloc" with [@@noalloc] for OCaml version >= 4.03.0 *) [@@@ warning "-3"] external address_of_value: 'a -> int = "address_of_value" "noalloc" [@@@ warning "+3"] (* ************************************************************************* *) (** {2 Exception catcher} *) (* ************************************************************************* *) let try_finally ~finally f x = let r = try f x with e -> finally () ; raise e in finally () ; r (* ************************************************************************* *) (** System commands *) (* ************************************************************************* *) (*[LC] due to Unix.exec calls, at_exit might be cloned into child process and executed when they are canceled early. The alternative, such as registering an daemon that raises an exception, hence interrupting the process, might not work: child processes still need to run some daemons, such as [Pervasives.flush_all] which is registered by default. *) let pid = Unix.getpid () let safe_at_exit f = Pervasives.at_exit begin fun () -> let child = Unix.getpid () in if child = pid then f () end 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 = safe_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 _ -> ()); safe_at_exit begin fun () -> if debug then begin if Sys.file_exists file then Format.printf "[extlib] Debug: not removing file %s@." file; end else safe_remove file end ; file let temp_dir_cleanup_at_exit ?(debug=false) 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 safe_remove file; try Unix.mkdir dir 0o700 ; safe_at_exit begin fun () -> if debug then begin if Sys.file_exists dir then Format.printf "[extlib] Debug: not removing dir %s@." dir; end else safe_remove_dir dir end ; dir with Unix.Unix_error(err,_,_) -> if limit < 0 then raise (Temp_file_error (Unix.error_message err)) else try_dir_cleanup_at_exit (pred limit) base in try_dir_cleanup_at_exit 10 base (* replace "noalloc" with [@@noalloc] for OCaml version >= 4.03.0 *) [@@@ warning "-3"] external terminate_process: int -> unit = "terminate_process" "noalloc" [@@deprecated "Use Unix.kill instead"] (* In ../utils/c_binding.c ; can be replaced by Unix.kill in OCaml >= 4.02 *) external usleep: int -> unit = "ml_usleep" "noalloc" (* In ../utils/c_bindings.c ; man usleep for details. *) (* ************************************************************************* *) (** Strings *) (* ************************************************************************* *) external compare_strings: string -> string -> int -> bool = "compare_strings" "noalloc" [@@@ warning "+3"] let string_prefix ?(strict=false) prefix s = let add = if strict then 1 else 0 in String.length s >= String.length prefix + add && compare_strings prefix s (String.length 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_suffix ?(strict=false) suffix s = let len = String.length s in let suf_len = String.length suffix in let strict_len = if strict then suf_len + 1 else suf_len in len >= strict_len && compare_strings suffix (String.sub s (len - suf_len) suf_len) suf_len let string_del_suffix ?(strict=false) suffix s = if string_suffix ~strict suffix s then Some (String.sub s 0 (String.length s - String.length suffix)) 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 compare_ignore_case s1 s2 = String.compare (Transitioning.String.lowercase_ascii s1) (Transitioning.String.lowercase_ascii s2) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/stdlib/FCSet.mli0000644000175000017500000002026413113745006022066 0ustar mehdimehdi(**************************************************************************) (* *) (* 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). *) (* *) (**************************************************************************) (** Sets over ordered types. This signatures is a partial copy of the signature of OCaml's [Set.S], which we extend with new operations. *) module type S_Basic_Compare = sig type elt (** The type of the set elements. *) type t (** The type 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 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 equal: t -> t -> bool (** [equal s1 s2] tests whether the sets [s1] and [s2] are equal, that is, contain equal elements. *) 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 elements: t -> elt list (** Return the list of all elements of the given set. The returned list is sorted in increasing order with respect to the ordering [Ord.compare], where [Ord] is the argument given to {!Set.Make}. *) 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 find: elt -> t -> elt (** [find x s] returns the element of [s] equal to [x] (according to [Ord.compare]), or raise [Not_found] if no such element exists. @since 4.01.0 *) val of_list: elt list -> t (** [of_list l] creates a set from a list of elements. This is usually more efficient than folding [add] over the list, except perhaps for lists with many duplicated elements. @since 4.02.0 *) end (** Standard operations on sets. This signature does not assume any particular property on the [compare] function used to compare elements, except that it implements a total order. These are the functions that make sense for an usage of [Set] where only the algorithmic complexity is interesting to the user. *) module type S = sig include S_Basic_Compare 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 {min_elt}, but returns the largest element of the given set. *) (* Frama-C- additions *) val nearest_elt_le: elt -> t -> elt (** [nearest_elt_le v s] returns the largest element of [s] that is smaller or equal to [v]. @raise Not_found if no such element exists. *) val nearest_elt_ge: elt -> t -> elt (** [nearest_elt_ge v s] returns the smallest element of [s] that is bigger or equal to [v]. @raise Not_found if no such element exists. *) end (** Output signature of the functor {!FCSet.Make}. This signature add functions that assume that the [compare] function between elements implements a specific order. In this case, the layout of the tree might be interesting to the user. *) module Make (Ord : Set.OrderedType) : 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-Phosphorus-20170501/src/libraries/stdlib/FCBuffer.mli0000644000175000017500000002104213113745002022533 0ustar mehdimehdi(**************************************************************************) (* *) (* 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). *) (* *) (**************************************************************************) (** Extensible buffers. This module implements buffers that automatically expand as necessary. It provides accumulative concatenation of strings in quasi-linear time (instead of quadratic time when strings are concatenated pairwise). *) type t (** The abstract type of buffers. *) val create : int -> t (** [create n] returns a fresh buffer, initially empty. The [n] parameter is the initial size of the internal byte sequence that holds the buffer contents. That byte sequence is automatically reallocated when more than [n] characters are stored in the buffer, but shrinks back to [n] characters when [reset] is called. For best performance, [n] should be of the same order of magnitude as the number of characters that are expected to be stored in the buffer (for instance, 80 for a buffer that holds one output line). Nothing bad will happen if the buffer grows beyond that limit, however. In doubt, take [n = 16] for instance. If [n] is not between 1 and {!Sys.max_string_length}, it will be clipped to that interval. *) val contents : t -> string (** Return a copy of the current contents of the buffer. The buffer itself is unchanged. *) val to_bytes : t -> bytes (** Return a copy of the current contents of the buffer. The buffer itself is unchanged. @since 4.02 *) val sub : t -> int -> int -> string (** [Buffer.sub b off len] returns (a copy of) the bytes from the current contents of the buffer [b] starting at offset [off] of length [len] bytes. May raise [Invalid_argument] if out of bounds request. The buffer itself is unaffected. *) val sub_bytes : t -> int -> int -> bytes (** Same as [sub] but return a byte sequence instead of a string. @since 4.05 *) val blit : t -> int -> bytes -> int -> int -> unit (** [Buffer.blit src srcoff dst dstoff len] copies [len] characters from the current contents of the buffer [src], starting at offset [srcoff] to [dst], starting at character [dstoff]. Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid range of [src], or if [dstoff] and [len] do not designate a valid range of [dst]. @since 3.11.2 *) val blit_buffer : t -> int -> t -> int -> int -> unit (** Similar to [blit], but copies to a buffer, and allows the destination buffer to grow, that is, [dstoff + len] can be larger than the length of [dst]. However, there cannot be any holes, i.e. [dstoff] must be smaller than the original length of [dst]. @since 4.05 *) val blit_substring : string -> int -> t -> int -> int -> unit (** Same as [blit_buffer], but copies from a string to a buffer. @since 4.05 *) val blit_subbytes : bytes -> int -> t -> int -> int -> unit (** Same as [blit_buffer], but copies from bytes to a buffer. @since 4.05 *) val nth : t -> int -> char (** get the n-th character of the buffer. Raise [Invalid_argument] if index out of bounds *) val length : t -> int (** Return the number of characters currently contained in the buffer. *) val clear : t -> unit (** Empty the buffer. *) val reset : t -> unit (** Empty the buffer and deallocate the internal byte sequence holding the buffer contents, replacing it with the initial internal byte sequence of length [n] that was allocated by {!Buffer.create} [n]. For long-lived buffers that may have grown a lot, [reset] allows faster reclamation of the space used by the buffer. *) val truncate : t -> int -> unit (** [truncate b c] truncates the length of [b] to be no larger than [c]. Does nothing if the length of [b] is already smaller than or equal [c]. In particular, it does not change the size of the underlying buffer. Raise [Invalid_argument] if [c < 0]. @since 4.05 *) val add_char : t -> char -> unit (** [add_char b c] appends the character [c] at the end of the buffer [b]. *) val add_string : t -> string -> unit (** [add_string b s] appends the string [s] at the end of the buffer [b]. *) val add_bytes : t -> bytes -> unit (** [add_string b s] appends the string [s] at the end of the buffer [b]. @since 4.02 *) val add_substring : t -> string -> int -> int -> unit (** [add_substring b s ofs len] takes [len] characters from offset [ofs] in string [s] and appends them at the end of the buffer [b]. *) val add_subbytes : t -> bytes -> int -> int -> unit (** [add_substring b s ofs len] takes [len] characters from offset [ofs] in byte sequence [s] and appends them at the end of the buffer [b]. @since 4.02 *) val add_substitute : t -> (string -> string) -> string -> unit (** [add_substitute b f s] appends the string pattern [s] at the end of the buffer [b] with substitution. The substitution process looks for variables into the pattern and substitutes each variable name by its value, as obtained by applying the mapping [f] to the variable name. Inside the string pattern, a variable name immediately follows a non-escaped [$] character and is one of the following: - a non empty sequence of alphanumeric or [_] characters, - an arbitrary sequence of characters enclosed by a pair of matching parentheses or curly brackets. An escaped [$] character is a [$] that immediately follows a backslash character; it then stands for a plain [$]. Raise [Not_found] if the closing character of a parenthesized variable cannot be found. *) val add_buffer : t -> t -> unit (** [add_buffer b1 b2] appends the current contents of buffer [b2] at the end of buffer [b1]. [b2] is not modified. *) val add_channel : t -> in_channel -> int -> unit (** [add_channel b ic n] reads at most [n] characters from the input channel [ic] and stores them at the end of buffer [b]. Raise [End_of_file] if the channel contains fewer than [n] characters. In this case the characters are still added to the buffer, so as to avoid loss of data. *) val output_buffer : out_channel -> t -> unit (** [output_buffer oc b] writes the current contents of buffer [b] on the output channel [oc]. *) frama-c-Phosphorus-20170501/src/libraries/stdlib/integer.mli0000644000175000017500000001211513113745001022546 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 exception Too_big (** Produced by values whose physical representation is too costly (e.g. in terms of memory usage). *) 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 (** Remainder of the Euclidean division (always positive) *) val pos_div : t -> t -> t (** Euclidean division. Equivalent to C division if both operands are positive. Equivalent to a floored division if b > 0 (rounds downwards), otherwise rounds upwards. Note: it is possible that pos_div (-a) b <> pos_div a (-b). *) val divexact: t -> t -> t (** Faster, but produces correct results only when b evenly divides a. *) val c_div : t -> t -> t (** Truncated division towards 0 (like in C99) *) val c_rem : t -> t -> t (** Remainder of the truncated division towards 0 (like in C99) *) 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 (** [pgcd v 0 == pgcd 0 v == abs v]. Result is always positive *) val ppcm : t -> t -> t (** [ppcm v 0 == ppcm 0 v == 0]. Result is always positive *) 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 of_float : float -> t (** Converts from a floating-point value. The value is truncated. Raises [Overflow] on infinity and NaN arguments. (Or on big values with Big_int.) *) 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 (** Remainder of the Euclidean division (always positive) *) 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 two_power : t -> t (* [two_power x] computes 2^x. Can raise [Too_big]. *) val two_power_of_int : int -> t (* Similar to [two_power x], but x is an OCaml int. *) val extract_bits : start:t -> stop:t -> t -> t val small_nums : t array val zero : t val eight : t val sixteen : t val thirtytwo : t val div : t -> t -> t (** Euclidean division (that returns a positive rem) *) val billion_one : t val hash : t -> int val shift_right_logical : t -> t -> t val two_power_64 : t val max_int64 : t val min_int64 : t val of_string : string -> t (** @raise Failure _ when the string cannot be parsed. *) (* Beware that non-decimal integers cannot be parsed when OCaml's Big_int implementation is used. Zarith handles them, but we cannot assume it is present. *) val to_string : t -> string val add_2_64 : t -> t val add_2_32 : 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-Phosphorus-20170501/src/libraries/stdlib/FCSet.ml0000644000175000017500000003722113113745011021712 0ustar mehdimehdi(**************************************************************************) (* *) (* 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). *) (* *) (**************************************************************************) module type S_Basic_Compare = sig type elt 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 choose: t -> elt val split: elt -> t -> t * bool * t val find: elt -> t -> elt val of_list: elt list -> t end module type S = sig include S_Basic_Compare val min_elt: t -> elt val max_elt: t -> elt val nearest_elt_le: elt -> t -> elt val nearest_elt_ge: elt -> t -> elt end module Make(Ord: Set.OrderedType) = struct type elt = Ord.t type t = Empty | Node of t * elt * t * 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) let singleton x = Node(Empty, x, Empty, 1) (* Beware: those two functions assume that the added v is *strictly* smaller (or bigger) than all the present elements in the tree; it does not test for equality with the current min (or max) element. Indeed, they are only used during the "join" operation which respects this precondition. *) let rec add_min_element v = function | Empty -> singleton v | Node (l, x, r, _) -> bal (add_min_element v l) x r let rec add_max_element v = function | Empty -> singleton v | Node (l, x, r, _) -> bal l x (add_max_element v r) (* Same as create and bal, but no assumptions are made on the relative heights of l and r. *) let rec join l v r = match (l, r) with (Empty, _) -> add_min_element v r | (_, Empty) -> add_max_element 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, _, _) -> v | Node(l, _, _, _) -> min_elt l let rec max_elt = function Empty -> raise Not_found | Node(_, v, Empty, _) -> v | Node(_, _, 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, _, 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 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, _) -> Empty | (_, 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, _) -> 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 * t * 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 rec filter p = function Empty -> Empty | Node(l, v, r, _) -> (* call [p] in the expected left-to-right order *) let l' = filter p l in let pv = p v in let r' = filter p r in if pv then join l' v r' else concat l' r' let rec partition p = function Empty -> (Empty, Empty) | Node(l, v, r, _) -> (* call [p] in the expected left-to-right order *) let (lt, lf) = partition p l in let pv = p v in let (rt, rf) = partition p r in if pv then (join lt v rt, concat lf rf) else (concat lt rt, join lf v rf) let rec cardinal = function Empty -> 0 | Node(l, _, 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 let rec find x = function Empty -> raise Not_found | Node(l, v, r, _) -> let c = Ord.compare x v in if c = 0 then v else find x (if c < 0 then l else r) (* Auxiliary function for function {!of_list} below *) let sort_unique l = let l = List.sort Ord.compare l in let rec remove_duplicates l = match l with | [_] | [] -> l | e1 :: (e2 :: _ as q) -> if Ord.compare e1 e2 = 0 then remove_duplicates q else let q' = remove_duplicates q in if q' == q then l else e1 :: q' in remove_duplicates l let of_sorted_list l = let rec sub n l = match n, l with | 0, l -> Empty, l | 1, x0 :: l -> Node (Empty, x0, Empty, 1), l | 2, x0 :: x1 :: l -> Node (Node(Empty, x0, Empty, 1), x1, Empty, 2), l | 3, x0 :: x1 :: x2 :: l -> Node (Node(Empty, x0, Empty, 1), x1, Node(Empty, x2, Empty, 1), 2), l | n, l -> let nl = n / 2 in let left, l = sub nl l in match l with | [] -> assert false | mid :: l -> let right, l = sub (n - nl - 1) l in create left mid right, l in fst (sub (List.length l) l) let of_list l = match l with | [] -> empty | [x0] -> singleton x0 | [x0; x1] -> add x1 (singleton x0) | [x0; x1; x2] -> add x2 (add x1 (singleton x0)) | [x0; x1; x2; x3] -> add x3 (add x2 (add x1 (singleton x0))) | [x0; x1; x2; x3; x4] -> add x4 (add x3 (add x2 (add x1 (singleton x0)))) | _ -> of_sorted_list (sort_unique l) 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 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 (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/stdlib/FCHashtbl.mli0000644000175000017500000000673613113745005022727 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 OCaml's [Hashtbl] module. *) (* No need to expand OCaml's [Hashtbl.S] here: we do not provide an alternative implementation of [Hashtbl]. Hence, we will always be compatible with the stdlib. *) 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 on keys induced by [cmp]. Use [Pervasives.compare] if [cmp] not given. If the table contains several bindings for the same key, they are passed to [f] in reverse order of introduction, that is, the most recent binding is passed first. *) val fold_sorted: ?cmp:(key -> key -> int) -> (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** Fold on the hashtbl, but respecting the order on keys induced by [cmp]. Use [Pervasives.compare] if [cmp] not given. If the table contains several bindings for the same key, they are passed to [f] in reverse order of introduction, that is, the most recent binding is passed first. *) val iter_sorted_by_entry: cmp:((key * 'a) -> (key * 'a) -> int) -> (key -> 'a -> unit) -> 'a t -> unit val fold_sorted_by_entry: cmp:((key * 'a) -> (key * 'a) -> int) -> (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** Iter or fold on the hashtable, respecting the order on entries given by [cmp]. The table may contains several bindings for the same key. *) val iter_sorted_by_value: cmp:('a -> 'a -> int) -> (key -> 'a -> unit) -> 'a t -> unit val fold_sorted_by_value: cmp:('a -> 'a -> int) -> (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** Iter or fold on the hashtable, respecting the order on entries given by [cmp]. The relative order for entries whose values is equal according to cmp, is not specified. *) 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-Phosphorus-20170501/src/libraries/stdlib/transitioning.ml0000644000175000017500000000363013113745011023633 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 "-3"] module String = struct let uppercase_ascii = String.uppercase let capitalize_ascii = String.capitalize let uncapitalize_ascii = String.uncapitalize let lowercase_ascii = String.lowercase end module Char = struct let uppercase_ascii = Char.uppercase let lowercase_ascii = Char.lowercase end frama-c-Phosphorus-20170501/src/libraries/stdlib/integer.ml0000644000175000017500000001560713113745011022407 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 exception Too_big let equal = Z.equal let compare = Z.compare let two_power_of_int k = Z.shift_left Z.one k let two_power y = try let k = Z.to_int y in if k > 1024 then (* avoid memory explosion *) raise Too_big else two_power_of_int k with Z.Overflow -> raise Too_big let popcount = Z.popcount (* To export *) let small_nums = Array.init 33 (fun i -> Z.of_int i) let zero = Z.zero let one = Z.one let minus_one = Z.minus_one let two = Z.of_int 2 let four = Z.of_int 4 let eight = Z.of_int 8 let sixteen = Z.of_int 16 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_32 = two_power_of_int 32 let two_power_60 = two_power_of_int 60 let two_power_64 = two_power_of_int 64 let is_zero v = Z.equal v Z.zero let add = Z.add let sub = Z.sub let succ = Z.succ let pred = Z.pred let neg = Z.neg let rem = Z.erem let div = Z.ediv let mul = Z.mul let abs = Z.abs let hash = Z.hash let shift_left x y = Z.shift_left x (Z.to_int y) let shift_right x y = Z.shift_right x (Z.to_int y) let shift_right_logical x y = (* no meaning for negative value of x *) if (Z.lt x Z.zero) then failwith "log_shift_right_big_int" else Z.shift_right x (Z.to_int y) let logand = Z.logand let lognot = Z.lognot let logor = Z.logor let logxor = Z.logxor let le a b = Z.compare a b <= 0 let ge a b = Z.compare a b >= 0 let lt a b = Z.compare a b < 0 let gt a b = Z.compare a b > 0 let of_int = Z.of_int let of_int64 = Z.of_int64 let of_int32 = Z.of_int32 (* Return the same exceptions as [Big_int] *) let to_int = Big_int_Z.int_of_big_int let to_int64 = Big_int_Z.int64_of_big_int let of_string s = try Z.of_string s with Invalid_argument _ -> (* We intentionally do NOT specify a string in the .mli, as Big_int raises multiple [Failure _] exceptions *) failwith "Integer.of_string" let max_int64 = of_int64 Int64.max_int let min_int64 = of_int64 Int64.min_int let to_string = Z.to_string let to_float = Z.to_float let of_float = Z.of_float let add_2_64 x = add two_power_64 x let add_2_32 x = add two_power_32 x let pretty ?(hexa=false) fmt v = let rec aux v = if gt v two_power_60 then let quo, rem = Z.ediv_rem 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 (Z.neg 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_div u v = let res = _c_div u v in let res2 = Z.div u v in if not (equal res res2) then failwith (Printf.sprintf "division of %a %a c_div %a div %a" Z.sprint u Z.sprint v Z.sprint res Z.sprint res2) else res2 let c_div = Z.div let _c_rem u v = sub u (mul v (c_div u v)) let _c_rem u v = let res = _c_rem u v in let res2 = Z.rem u v in if not (equal res res2) then failwith (Printf.sprintf "division of %a %a c_rem %a rem %a" Z.sprint u Z.sprint v Z.sprint res Z.sprint res2) else res2 let c_rem = Z.rem 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) let pgcd u v = if is_zero v then abs u (* Zarith raises an exception on zero arguments *) else if is_zero u then abs v else Z.gcd u v let ppcm u v = if u = zero || v = zero then zero else Z.lcm u v let min = Z.min let max = Z.max 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)) let power_int_positive_int = Big_int_Z.power_int_positive_int frama-c-Phosphorus-20170501/src/libraries/stdlib/FCBuffer.ml0000644000175000017500000002267613113745011022400 0ustar mehdimehdi(**************************************************************************) (* *) (* 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). *) (* *) (**************************************************************************) (* Extensible buffers *) type t = {mutable buffer : bytes; mutable position : int; mutable length : int; initial_buffer : bytes} let create n = let n = if n < 1 then 1 else n in let n = if n > Sys.max_string_length then Sys.max_string_length else n in let s = Bytes.create n in {buffer = s; position = 0; length = n; initial_buffer = s} let contents b = Bytes.sub_string b.buffer 0 b.position let to_bytes b = Bytes.sub b.buffer 0 b.position let sub b ofs len = if ofs < 0 || len < 0 || ofs > b.position - len then invalid_arg "Buffer.sub" else Bytes.sub_string b.buffer ofs len ;; let sub_bytes b ofs len = if ofs < 0 || len < 0 || ofs > b.position - len then invalid_arg "Buffer.sub_bytes" else Bytes.sub b.buffer ofs len ;; let blit src srcoff dst dstoff len = if len < 0 || srcoff < 0 || srcoff > src.position - len || dstoff < 0 || dstoff > (Bytes.length dst) - len then invalid_arg "Buffer.blit" else Bytes.unsafe_blit src.buffer srcoff dst dstoff len ;; (* [calc_size cur_len req_len] computes the new size for a buffer having [cur_len] bytes, to ensure that it can contain at least [req_len] bytes. Used by [add_*] and [blit_*] functions. Raise [Failure] if the new size is too large. *) let calc_size cur_len req_len = let new_len = ref cur_len in while req_len > !new_len do new_len := 2 * !new_len done; if !new_len > Sys.max_string_length then begin if req_len <= Sys.max_string_length then new_len := Sys.max_string_length else failwith "Buffer.add: cannot grow buffer" end; !new_len (* [resize_aux b len] resizes buffer [b] to ensure it may contain at least [len] bytes. *) let resize_aux b len = let new_len = calc_size b.length len in let new_buffer = Bytes.create new_len in b.buffer <- new_buffer; b.length <- new_len let resize b len = let old_buffer = b.buffer in resize_aux b len; (* PR#6148: let's keep using [blit] rather than [unsafe_blit] in this tricky function that is slow anyway. *) Bytes.blit old_buffer 0 b.buffer 0 b.position let blit_substring_aux src srclen srcoff dst dstoff len = if len < 0 || srcoff < 0 || srcoff > srclen - len || dstoff < 0 || dstoff > dst.position then invalid_arg "Buffer.blit_*/add_*" else let new_pos = dstoff + len in let new_len = calc_size dst.length new_pos in if new_len > dst.length then begin let old_buffer = dst.buffer in resize_aux dst new_len; (* dst points to a new buffer now *) Bytes.blit old_buffer 0 dst.buffer 0 dstoff; Bytes.blit_string src srcoff dst.buffer dstoff len; end else Bytes.blit_string src srcoff dst.buffer dstoff len; if new_pos > dst.position then dst.position <- new_pos ;; let blit_buffer src srcoff dst dstoff len = blit_substring_aux (Bytes.unsafe_to_string src.buffer) src.position srcoff dst dstoff len let blit_substring src srcoff dst dstoff len = blit_substring_aux src (String.length src) srcoff dst dstoff len let blit_subbytes src srcoff dst dstoff len = blit_substring_aux (Bytes.unsafe_to_string src) (Bytes.length src) srcoff dst dstoff len let nth b ofs = if ofs < 0 || ofs >= b.position then invalid_arg "Buffer.nth" else Bytes.unsafe_get b.buffer ofs ;; let length b = b.position let clear b = b.position <- 0 let reset b = b.position <- 0; b.buffer <- b.initial_buffer; b.length <- Bytes.length b.buffer let truncate b c = if c < 0 then invalid_arg "Buffer.truncate" else if b.position > c then b.position <- c let add_char b c = let pos = b.position in if pos >= b.length then resize b (pos + 1); Bytes.unsafe_set b.buffer pos c; b.position <- pos + 1 let add_substring b s offset len = if offset < 0 || len < 0 || offset + len > String.length s then invalid_arg "Buffer.add_substring/add_subbytes"; blit_substring_aux s (String.length s) offset b b.position len let add_subbytes b s offset len = add_substring b (Bytes.unsafe_to_string s) offset len let add_string b s = let len = String.length s in blit_substring_aux s len 0 b b.position len let add_bytes b s = add_string b (Bytes.unsafe_to_string s) let add_buffer b bs = add_subbytes b bs.buffer 0 bs.position (* read up to [len] bytes from [ic] into [b]. *) let rec add_channel_rec b ic len = if len > 0 then ( let n = input ic b.buffer b.position len in b.position <- b.position + n; if n = 0 then raise End_of_file else add_channel_rec b ic (len-n) (* n <= len *) ) let add_channel b ic len = if len < 0 || len > Sys.max_string_length then (* PR#5004 *) invalid_arg "Buffer.add_channel"; if b.position + len > b.length then resize b (b.position + len); add_channel_rec b ic len let output_buffer oc b = output oc b.buffer 0 b.position let closing = function | '(' -> ')' | '{' -> '}' | _ -> assert false;; (* opening and closing: open and close characters, typically ( and ) k: balance of opening and closing chars s: the string where we are searching start: the index where we start the search. *) let advance_to_closing opening closing k s start = let rec advance k i lim = if i >= lim then raise Not_found else if s.[i] = opening then advance (k + 1) (i + 1) lim else if s.[i] = closing then if k = 0 then i else advance (k - 1) (i + 1) lim else advance k (i + 1) lim in advance k start (String.length s);; let advance_to_non_alpha s start = let rec advance i lim = if i >= lim then lim else match s.[i] with | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> advance (i + 1) lim | _ -> i in advance start (String.length s);; (* We are just at the beginning of an ident in s, starting at start. *) let find_ident s start lim = if start >= lim then raise Not_found else match s.[start] with (* Parenthesized ident ? *) | '(' | '{' as c -> let new_start = start + 1 in let stop = advance_to_closing c (closing c) 0 s new_start in String.sub s new_start (stop - start - 1), stop + 1 (* Regular ident *) | _ -> let stop = advance_to_non_alpha s (start + 1) in String.sub s start (stop - start), stop;; (* Substitute $ident, $(ident), or ${ident} in s, according to the function mapping f. *) let add_substitute b f s = let lim = String.length s in let rec subst previous i = if i < lim then begin match s.[i] with | '$' as current when previous = '\\' -> add_char b current; subst ' ' (i + 1) | '$' -> let j = i + 1 in let ident, next_i = find_ident s j lim in add_string b (f ident); subst ' ' next_i | current when previous == '\\' -> add_char b '\\'; add_char b current; subst ' ' (i + 1) | '\\' as current -> subst current (i + 1) | current -> add_char b current; subst current (i + 1) end else if previous = '\\' then add_char b previous in subst ' ' 0;; frama-c-Phosphorus-20170501/src/libraries/stdlib/extlib.mli0000644000175000017500000003401413113745012022404 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. *) 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 follows: 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 uninitialized 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. *) val uncurry: ('a -> 'b -> 'c) -> ('a * 'b) -> 'c val iter_uncurry2: (('a -> 'b -> unit) -> 'c -> unit) -> (('a * 'b -> unit) -> 'c -> unit) (* ************************************************************************* *) (** {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 replace: ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list (** [replace cmp x l] replaces the first element [y] of [l] such that [cmp x y] is true by [x]. If no such element exists, [x] is added at the tail of [l]. @since Neon-20140301 *) 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 *) 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 *) val sort_unique: ('a -> 'a -> int) -> 'a list -> 'a list (** Same as List.sort , but also remove duplicates. *) val subsets: int -> 'a list -> 'a list list (** [subsets k l] computes the combinations of [k] elements from list [l]. E.g. subsets 2 [1;2;3;4] = [[1;2];[1;3];[1;4];[2;3];[2;4];[3;4]]. This function preserves the order of the elements in [l] when computing the sublists. [l] should not contain duplicates. @since Aluminium-20160501 *) (* ************************************************************************* *) (** {2 Arrays} *) (* ************************************************************************* *) val array_exists: ('a -> bool) -> 'a array -> bool val array_existsi: (int -> 'a -> bool) -> 'a array -> bool (* ************************************************************************* *) (** {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 (** [may f v] applies [f] to [x] if [v = Some(x)] *) 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: ?exn:exn -> 'a option -> 'a (** @raise Exn if the value is [None] and [exn] is specified. @raise Invalid_argument if the value is [None] and [exn] is not specified. @return v if the value is [Some v]. @modify Magnesium-20151001 add optional argument [exn] @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 *) val opt_hash: ('a -> int) -> 'a option -> int (** @since Sodium-20150201 *) (* ************************************************************************* *) (** {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_suffix: ?strict:bool -> string -> string -> bool (** [string_suffix ~strict suf s] returns [true] iff [suf] is a suffix of string [s]. [strict], which defaults to [false], indicates whether [s] should be strictly longer than [p]. @since Aluminium-20160501 *) val string_del_suffix: ?strict:bool -> string -> string -> string option (** [string_del_suffix ~strict suf s] returns [Some s1] when [s = s1 ^ suf] and None of [suf] is not a suffix of [s]. @since Aluminium-20160501 *) 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} *) (* ************************************************************************* *) (* replace "noalloc" with [@@noalloc] for OCaml version >= 4.03.0 *) [@@@ warning "-3"] external address_of_value: 'a -> int = "address_of_value" "noalloc" [@@@ warning "+3"] (* ************************************************************************* *) (** {2 Exception catcher} *) (* ************************************************************************* *) val try_finally: finally:(unit -> unit) -> ('a -> 'b) -> 'a -> 'b (* ************************************************************************* *) (** System commands *) (* ************************************************************************* *) val safe_at_exit : (unit -> unit) -> unit (** Register function to call with [Pervasives.at_exit], but only for non-child process (fork). The order of execution is preserved {i wrt} ordinary calls to [Pervasives.at_exit]. *) 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: ?debug:bool -> string -> string (** @raise Temp_file_error if the temp dir cannot be created. @modify Nitrogen-20111001 may now raise Temp_file_error @modify Neon-20130301 add optional debug flag *) 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" (** Case-insensitive string comparison. Only ISO-8859-1 accents are handled. @since Silicon-20161101 *) val compare_ignore_case: string -> string -> int (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/stdlib/FCHashtbl.ml0000644000175000017500000000705413113745012022546 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 val iter_sorted_by_entry: cmp:((key * 'a) -> (key * 'a) -> int) -> (key -> 'a -> unit) -> 'a t -> unit val fold_sorted_by_entry: cmp:((key * 'a) -> (key * 'a) -> int) -> (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val iter_sorted_by_value: cmp:('a -> 'a -> int) -> (key -> 'a -> unit) -> 'a t -> unit val fold_sorted_by_value: cmp:('a -> 'a -> 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 = FCMap.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 () let fold_sorted_by_entry (type value) ~cmp f h acc = let module Aux = struct type t = (key*value) let compare = cmp end in let module S = FCSet.Make(Aux) in let add k v s = S.add (k,v) s in let set = fold add h S.empty in S.fold (fun (k,v) -> f k v) set acc let iter_sorted_by_entry ~cmp f h = fold_sorted_by_entry ~cmp (fun k v () -> f k v) h () let fold_sorted_by_value ~cmp f h acc = fold_sorted_by_entry ~cmp:(fun (_ka,va) (_kb,vb) -> cmp va vb) f h acc let iter_sorted_by_value ~cmp f h = iter_sorted_by_entry ~cmp:(fun (_ka,va) (_kb,vb) -> cmp va vb) f h end (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/libraries/stdlib/FCMap.mli0000644000175000017500000002051713113745004022047 0ustar mehdimehdi(**************************************************************************) (* *) (* 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 signatures is a partial copy of the signature of [Map.S] of OCaml's standard library, which we extend with some new functions. *) module type S = sig type key (** The type of the map keys. *) type (+'a) t (** The type of maps from type [key] to type ['a]. *) val empty: 'a t (** The empty map. *) val is_empty: 'a t -> bool (** Test whether a map is empty or not. *) val mem: key -> 'a t -> bool (** [mem x m] returns [true] if [m] contains a binding for [x], and [false] otherwise. *) val add: key -> 'a -> 'a t -> 'a t (** [add x y m] returns a map containing the same bindings as [m], plus a binding of [x] to [y]. If [x] was already bound in [m], its previous binding disappears. *) val singleton: key -> 'a -> 'a t (** [singleton x y] returns the one-element map that contains a binding [y] for [x]. @since 3.12.0 *) val remove: key -> 'a t -> 'a t (** [remove x m] returns a map containing the same bindings as [m], except for [x] which is unbound in the returned map. *) val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1] and of [m2]. The presence of each such binding, and the corresponding value, is determined with the function [f]. @since 3.12.0 *) val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int (** Total ordering between maps. The first argument is a total ordering used to compare data associated with equal keys in the two maps. *) val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, that is, contain equal keys and associate them with equal data. [cmp] is the equality predicate used to compare the data associated with the keys. *) val iter: (key -> 'a -> unit) -> 'a t -> unit (** [iter f m] applies [f] to all bindings in map [m]. [f] receives the key as first argument, and the associated value as second argument. The bindings are passed to [f] in increasing order with respect to the ordering over the type of the keys. *) val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], where [k1 ... kN] are the keys of all bindings in [m] (in increasing order), and [d1 ... dN] are the associated data. *) val for_all: (key -> 'a -> bool) -> 'a t -> bool (** [for_all p m] checks if all the bindings of the map satisfy the predicate [p]. @since 3.12.0 *) val exists: (key -> 'a -> bool) -> 'a t -> bool (** [exists p m] checks if at least one binding of the map satisfy the predicate [p]. @since 3.12.0 *) val filter: (key -> 'a -> bool) -> 'a t -> 'a t (** [filter p m] returns the map with all the bindings in [m] that satisfy predicate [p]. @since 3.12.0 *) val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t (** [partition p m] returns a pair of maps [(m1, m2)], where [m1] contains all the bindings of [s] that satisfy the predicate [p], and [m2] is the map with all the bindings of [s] that do not satisfy [p]. @since 3.12.0 *) val cardinal: 'a t -> int (** Return the number of bindings of a map. @since 3.12.0 *) val bindings: 'a t -> (key * 'a) list (** Return the list of all bindings of the given map. The returned list is sorted in increasing order with respect to the ordering [Ord.compare], where [Ord] is the argument given to {!Map.Make}. @since 3.12.0 *) val min_binding: 'a t -> (key * 'a) (** Return the smallest binding of the given map (with respect to the [Ord.compare] ordering), or raise [Not_found] if the map is empty. @since 3.12.0 *) val max_binding: 'a t -> (key * 'a) (** Same as {!min_binding}, but returns the largest binding of the given map. @since 3.12.0 *) val choose: 'a t -> (key * 'a) (** Return one binding of the given map, or raise [Not_found] if the map is empty. Which binding is chosen is unspecified, but equal bindings will be chosen for equal maps. @since 3.12.0 *) val split: key -> 'a t -> 'a t * 'a option * 'a t (** [split x m] returns a triple [(l, data, r)], where [l] is the map with all the bindings of [m] whose key is strictly less than [x]; [r] is the map with all the bindings of [m] whose key is strictly greater than [x]; [data] is [None] if [m] contains no binding for [x], or [Some v] if [m] binds [v] to [x]. @since 3.12.0 *) val find: key -> 'a t -> 'a (** [find x m] returns the current binding of [x] in [m], or raises [Not_found] if no such binding exists. *) val map: ('a -> 'b) -> 'a t -> 'b t (** [map f m] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been replaced by the result of the application of [f] to [a]. The bindings are passed to [f] in increasing order with respect to the ordering over the type of the keys. *) val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t (** Same as {!map}, but the function receives as arguments both the key and the associated value for each binding of the map. *) end module Make (Ord : Map.OrderedType) : S with type key = Ord.t (** Functor building an implementation of the map structure given a totally ordered type. *) frama-c-Phosphorus-20170501/src/kernel_internals/0000755000175000017500000000000013113744777020533 5ustar mehdimehdiframa-c-Phosphorus-20170501/src/kernel_internals/typing/0000755000175000017500000000000013113745013022025 5ustar mehdimehdiframa-c-Phosphorus-20170501/src/kernel_internals/typing/translate_lightweight.ml0000644000175000017500000001734613113745007026771 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* 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 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) exception No_recovery 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 -> raise 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 _ -> raise 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 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 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 | GFunDecl(_,v,_) -> if not v.vdefined then annotate_fun v; SkipChildren | GAnnot _ -> DoChildren | GCompTag _ | GType _ | GCompTagDecl _ | GEnumTagDecl _ | GEnumTag _ | GAsm _ | GPragma _ | GText _ | GVar _ | GVarDecl _ -> SkipChildren end let interpret file = let visitor = new annotateFunFromDeclspec in Visitor.visitFramacFile visitor file let lightweight_transform = File.register_code_transformation_category "lightweight spec" let () = File.add_code_transformation_after_cleanup lightweight_transform interpret (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_internals/typing/logic_builtin.ml0000644000175000017500000003174413113745011025211 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* 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 string_type = Ctype Cil.charConstPtrType let long_double_type = Ctype Cil.longDoubleType let object_ptr = Ctype Cil.voidPtrType let fun_ptr = Ctype (TPtr(TFun(Cil.voidType,None,false,[]),[])) let polymorphic_type name = name, Lvar name 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; lt_attr=[] } in let set = { lt_name = "set"; lt_params=["elem"]; lt_def=None; lt_attr=[] } in let typetag = { lt_name = "typetag"; lt_params = []; lt_def = None; lt_attr = [] } in let sign = {lt_name = "sign"; lt_params = []; lt_def = None; lt_attr = [] } in let float_format = {lt_name = "float_format"; lt_params = []; lt_def = None; lt_attr=[]} in let rounding_mode = {lt_name = "rounding_mode"; lt_params = []; lt_def = None; lt_attr=[]} 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" ]; ]; (* logic types used by the builtins *) let a_name, a_type = polymorphic_type "a" in let boolean = Ltype(boolean,[]) in let sign = Ltype(sign,[]) in let float_format = Ltype(float_format,[]) in let rounding_mode = Ltype(rounding_mode,[]) in let set_of_integer = Ltype (set, [Linteger]) in let set_of_a_type = Ltype (set, [a_type]) in (* "\list" logic type with its constructors *) let list = { lt_name="\\list"; lt_params=[a_name]; lt_def=None; lt_attr=[]} in Logic_env.add_builtin_logic_type list.lt_name list ; let list_of_a_type = Ltype (list, [a_type]) in let nil = { ctor_name = "\\Nil"; ctor_type = list; ctor_params = [] } in let cons = { ctor_name = "\\Cons"; ctor_type = list; ctor_params = [a_type; list_of_a_type] } in let ctors = [nil ; cons] in List.iter (fun c -> Logic_env.add_builtin_logic_ctor c.ctor_name c) ctors ; list.lt_def <- Some (LTsum ctors); let _list_of_integer = Ltype (list, [Linteger]) in (* predicates *) List.iter (fun (f,tparams,labels,params) -> add { bl_name = f; bl_params = tparams; bl_profile = params; bl_type = None; bl_labels = 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_name], [], ["s1", set_of_a_type; "s2", set_of_a_type]; "\\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)]; "\\points_to_valid_string", [], [], ["p", object_ptr]; "\\warning", [], [LogicLabel (None, "L")], [("str", string_type)]; ]; (* functions *) List.iter (fun (f,tparams,params,ret_type) -> add { bl_name = f; bl_params = tparams; 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 ; (* transcendental 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],boolean))], Linteger ; (* for floats special values *) "\\round_float", [], ["f", float_format; "m", rounding_mode; "x", Lreal], Lreal ; "\\sign", [], ["x",float_type], sign ; "\\sign", [], ["x",double_type], sign ; "\\sign", [], ["x",long_double_type], 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;*) "\\min", [], ["s", set_of_integer], Linteger; "\\max", [], ["s", set_of_integer], Linteger; "\\nth", [a_name], ["l", list_of_a_type; "n", Linteger], a_type; "\\length", [a_name], ["l", list_of_a_type], Linteger; "\\concat", [a_name], ["l1", list_of_a_type; "l2", list_of_a_type], list_of_a_type; "\\repeat", [a_name], ["l", list_of_a_type; "n", Linteger], list_of_a_type; ] end (* Local Variables: compile-command: "make -j -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_internals/typing/oneret.ml0000644000175000017500000003706313113745005023665 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.fatal "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 visitCilPredicate vis p in let assert_of_returns ca = match ca.annot_content with | AAssert _ | AInvariant _ | AVariant _ | AAssigns _ | AAllocation _ | APragma _ | AExtended _ -> ptrue | AStmtSpec (_bhvs,s) -> let res = List.fold_left (fun acc bhv -> pand (acc, pimplies (pands (List.map (fun p -> pold ~loc:p.ip_content.pred_loc (Logic_const.pred_of_id_pred p)) bhv.b_assumes), pands (List.fold_left (fun acc (kind,p) -> match kind with Returns -> Logic_const.pred_of_id_pred 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.fatal ~current:true "Found return without value in function %s" fname; if not hasRet && retval <> None then Kernel.fatal ~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 *) ); (* See if this is the last statement in function, and we don't have a statement contract above us. In that last case, it is best to keep a small block with a goto the actual return statement, so as to preserve the fact that we don't fall through the return statement. In particular, the following contract holds, and so should its normalization: /*@ returns \true; ensures \false; */ returns 0; *) if mainbody && rests == [] && popstack = 0 then begin (* last statement, no contract, we can just fall through. *) scanStmts (s :: acc) mainbody 0 rests end else begin (* Add a Goto and put everything into a block on which the statement contract(s) will apply. *) let sgref = ref (getRetStmt ()) in let sg = mkStmt (Goto (sgref, loc)) in haveGoto := true; let b_stmts = match !returns_assert with | { pred_content = Ptrue } -> [s; sg] | p -> let a = Logic_const.new_code_annotation (AAssert ([],p)) in let sta = mkStmt (Instr (Code_annot (a,loc))) in [ s; sta; sg ] in let s = mkStmt (Block (mkBlock b_stmts)) in popn popstack; scanStmts (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] when popstack = 0 -> (* if we have a statement contract just above (i.e popstack<>0), don't consider that we are in the main body. Depending on the semantics we want to give to ACSL contracts wrt control flow that jumps in the middle of a block over which a statement contract applies, this might lead to incorrect contract in the end. For now, it's safer to ensure that the goto is directed outside of such a block. *) 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] when popstack = 0 -> (* see above. *) 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 ({ annot_content = AStmtSpec _ } as 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 = Instr (Code_annot _) } as s :: rests -> scanStmts (s::acc) mainbody popstack rests | { skind = TryCatch(t,c,l) } as s :: rests -> let scan_one_catch (e,b) = (e,scanBlock false b) in let t = scanBlock false t in let c = List.map scan_one_catch c in s.skind <- TryCatch(t,c,l); popn popstack; scanStmts (s::acc) mainbody 0 rests | ({skind=(Goto _ | Instr _ | Continue _ | Break _ | TryExcept _ | TryFinally _ | Throw _)} 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-Phosphorus-20170501/src/kernel_internals/typing/cabs2cil.mli0000644000175000017500000003041013113745011024206 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 val register_new_global_hook: (Cil_types.varinfo -> bool -> unit) -> unit (** Hook called when a new global is created. The varinfo [vi] is the one corresponding to the global, while the boolean is [true] iff [vi] was already existing (it is [false] if this is the first declaration/definition of [vi] in the file). @since Silicon-20161101 *) (** 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 (** @plugin development guide *) 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 (** Name of the attribute used to store the function that should be called when the corresponding variable exits its scope. *) val frama_c_destructor: 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 explanation if the two types are not compatible @since Oxygen-20120901 *) val areCompatibleTypes: Cil_types.typ -> Cil_types.typ -> bool (** Check that the two given types are compatible (C99, 6.2.7) @since Neon-20140301 @modify Phosphorus-20170501-beta1 *) val stmtFallsThrough: Cil_types.stmt -> bool (** returns [true] if the given statement can fall through the next syntactical one. @since Phosphorus-20170501-beta1 exported *) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_internals/typing/cabs2cil.ml0000644000175000017500000135670313113745005024061 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). *) (****************************************************************************) (* Modified by TrustInSoft *) (* 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 open Pretty_utils open Cabs open Cabshelper open Cil let valid_sid = false (* All statements generated here must have an invalid sid. Use this variable for the valid_sid label of Cil.mkStmt*. *) open Cil_types open Cil_datatype open Lexing let category_global = Kernel.register_category "cabs2cil:createGlobal" let category_initializer = Kernel.register_category "cabs2cil:initializers" let category_chunk = Kernel.register_category "cabs2cil:chunk" let category_cast = Kernel.register_category "cabs2cil:cast" let category_pragma = Kernel.register_category "cabs2cil:pragma" let frama_c_keep_block = "FRAMA_C_KEEP_BLOCK" let () = Cil_printer.register_shallow_attribute frama_c_keep_block let () = Cil_printer.register_shallow_attribute "fc_stdlib" let frama_c_destructor = "__fc_destructor" let () = Cil_printer.register_shallow_attribute frama_c_destructor (** 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 } let abort_context msg = let pos = fst (Cil.CurrentLoc.get ()) in let append fmt = Format.pp_print_newline fmt (); Errorloc.pp_context_from_file fmt pos in Kernel.abort ~current:true ~append msg 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 NewGlobalHook = Hook.Build(struct type t = varinfo * bool end) let register_new_global_hook f = NewGlobalHook.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 (fi, o) -> Cil.typeHasAttribute "volatile" (Cil.unrollType fi.ftype) || 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.vtemp) || Cil.hasAttribute "volatile" v.vattr || Cil.typeHasAttribute "volatile" (Cil.unrollType v.vtype) -> 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 **********) (* fc_stdlib pragma. Delimits blocks of globals that are declared in a given std lib header. By default, they will not be pretty-printed by frama-c -print, which will emit #include "header.h" instead *) let current_stdheader = ref [] let pop_stdheader () = match !current_stdheader with | s::l -> Kernel.debug ~dkey:category_pragma "Popping fc_stdlib %s" s; current_stdheader := l | [] -> Kernel.warning "#pragma fc_stdlib pop does not match a push" let push_stdheader s = Kernel.debug ~dkey:category_pragma "Pushing fc_stdlib %s@." s; current_stdheader := s::!current_stdheader (* Returns the topmost (latest) header that is not internal to Frama-C, unless it is the only one. This prevents the pretty-printing function from including Frama-C internal files, unless they were directly specified by the user. *) let get_current_stdheader () = let rec aux = function | [] -> "" | [ s ] -> s | s :: l when Extlib.string_prefix ~strict:true "__fc_" s -> aux l | s :: _ -> s in aux !current_stdheader (* there are several pragmas that we process directly here and remove from the globals list, by returning None. We bind their respective processing functions with the operator below. *) let (>>?) opt f = match opt with | Some (Attr(name, args)) -> f name args | _ -> opt let process_stdlib_pragma name args = if name = "fc_stdlib" then begin match args with | [ ACons ("pop",_) ] -> pop_stdheader (); None | [ ACons ("push",_); AStr s ] -> let base = Config.datadir ^ "/libc" in let relative_name = Filepath.relativize ~base s in push_stdheader relative_name; None | _ -> Some (Attr(name, args)) end else Some (Attr(name, args)) let fc_stdlib_attribute attrs = let s = get_current_stdheader () in if s = "" then attrs else Cil.addAttribute (Attr ("fc_stdlib", [AStr s])) attrs (* 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 Cil.msvcMode () || Cil.gccMode () 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, which emulates most of MSVC's behaviors. Some of it has been tested using MSVC 2010. Note that #pragma pack directives are emulated by translating them into GCC-style attributes, which in turn are not supported by MSVC. Therefore some combinations of attributes may be impossible to produce in MSVC, which means that Frama-C on an MSVC machdep may accept more programs that MSVC would. *) (* The pack pragma stack *) let packing_pragma_stack = Stack.create () (* The current pack pragma *) let current_packing_pragma = ref None let pretty_current_packing_pragma fmt = let align = Extlib.opt_conv (Integer.of_int theMachine.theMachine.alignof_aligned) !current_packing_pragma in (Integer.pretty ~hexa:false) fmt align (* Checks if [n] is a valid alignment for #pragma pack, and emits a warning if it is not the case. Returns the value to be set as current packing pragma. From the MSDN reference (msdn.microsoft.com/en-us/library/2e70t5y1(v=vs.100).aspx): Valid values are 1, 2, 4, 8, and 16. NOTE: GCC seems to consider '#pragma pack(0)' as equivalent to '#pragma pack()', but this is not specified in their documentation. To avoid rejecting programs with such pragmas, we emulate GCC's current behavior but emit a warning. This is the only case when this function returns [None]. *) let get_valid_pragma_pack_alignment n = if Integer.is_zero n && Cil.gccMode () then begin Kernel.warning ~current:true "GCC accepts pack(0) but does not specify its \ behavior; considering it equivalent to pack()"; true, None end else begin let valid = Integer.(equal n one || equal n two || equal n four || equal n eight || equal n sixteen) in if not valid then Kernel.warning ~current:true "ignoring invalid packing alignment (%a)" (Integer.pretty ~hexa:false) n; valid, Some n end let process_pack_pragma name args = begin match name with | "pack" -> begin match args with | [ACons ("",[])] (* #pragma pack() *) -> Kernel.feedback ~dkey:category_pragma ~current:true "packing pragma: restoring alignment to default (%d)" theMachine.theMachine.alignof_aligned; current_packing_pragma := None; None | [AInt n] (* #pragma pack(n) *) -> let is_valid, new_pragma = get_valid_pragma_pack_alignment n in if is_valid then begin Kernel.feedback ~dkey:category_pragma ~current:true "packing pragma: setting alignment to %a" (Integer.pretty ~hexa:false) n; current_packing_pragma := new_pragma; None end else Some (Attr (name, args)) | [ACons ("push",[])] (* #pragma pack(push) *) -> Kernel.feedback ~dkey:category_pragma ~current:true "packing pragma: pushing alignment %t" pretty_current_packing_pragma; Stack.push !current_packing_pragma packing_pragma_stack; None | [ACons ("push",[]); AInt n] (* #pragma pack(push,n) *) -> let is_valid, new_pragma = get_valid_pragma_pack_alignment n in if is_valid then begin Kernel.feedback ~dkey:category_pragma ~current:true "packing pragma: pushing alignment %t, setting alignment to %a" pretty_current_packing_pragma (Integer.pretty ~hexa:false) n; Stack.push !current_packing_pragma packing_pragma_stack; current_packing_pragma:= new_pragma; None end else Some (Attr (name, args)) | [ACons ("pop",[])] (* #pragma pack(pop) *) -> begin try current_packing_pragma := Stack.pop packing_pragma_stack; Kernel.feedback ~dkey:category_pragma ~current:true "packing pragma: popped alignment %t" pretty_current_packing_pragma; None with Stack.Empty -> (* GCC/Clang/MSVC seem to ignore the directive when a pop() is called with an empty stack, so we emulate their behavior. *) Kernel.warning ~current:true "ignoring #pragma pack(pop) with empty stack"; None end | [ACons ("show",[])] (* #pragma pack(show) *) -> Some (Attr (name, args)) | _ -> Kernel.warning ~current:true "Unsupported packing pragma not honored by Frama-C: #pragma pack(%a)" (Pretty_utils.pp_list ~sep:", " ~empty:"" Cil_printer.pp_attrparam) args; 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 is_power_of_two i = i > 0 && i land (i-1) = 0 (* Computes the numeric value corresponding to an 'aligned' attribute: - if 'aligned' (without integer), then use the maximum machine alignment; - else, try to const-fold the expression to an integer value. Returns [Some n] in case of success, [None] otherwise. Note that numeric values that are not powers of two are invalid and also return [None]. *) let eval_aligned_attrparams aps = match aps with | [] -> Some (Integer.of_int theMachine.theMachine.alignof_aligned) | [ap] -> begin match Cil.intOfAttrparam ap with | None -> None | Some n -> if is_power_of_two n then Some (Integer.of_int n) else None end | _ -> (* 'aligned(m,n,...)' is not a valid syntax *) None let warn_invalid_align_attribute aps = Kernel.warning ~current:true ~once:true "ignoring invalid aligned attribute: %a" Cil_printer.pp_attribute (Attr("aligned", aps)) (* If there is more than one 'aligned' attribute, GCC's behavior is to consider the maximum among them. This function computes this value and also emits warnings for invalid attributes. *) let combine_aligned_attributes attrs = match filterAttributes "aligned" attrs with | [] -> None | aligned_attrs -> List.fold_left (fun acc attr -> match attr with | Attr("aligned", aps) -> begin let align = eval_aligned_attrparams aps in if align = None then begin warn_invalid_align_attribute aps; acc end else match acc, align with | None, a | a, None -> a | Some old_n, Some new_n -> Some (Integer.max old_n new_n) end | _ -> assert false (* attributes were previously filtered by name *) ) None aligned_attrs let warn_incompatible_pragmas_attributes apragma has_attrs = if apragma <> None then Kernel.warning ~current:true ~once:true "ignoring 'align' pragma due to presence of 'pack' pragma.@ \ No compiler was supposed to accept both syntaxes."; if Cil.msvcMode () && has_attrs then (* MSVC does not allow attributes *) Kernel.warning ~current:true ~once:true "field attributes should not be present in MSVC-compatible sources" (* checks [attrs] for invalid aligned() attributes *) let check_aligned attrs = List.fold_right (fun attr acc -> match attr with | Attr("aligned", aps) -> if eval_aligned_attrparams aps = None then (warn_invalid_align_attribute aps; acc) else attr :: acc | _ -> attr :: acc ) attrs [] (* Takes into account the possible effect of '#pragma pack' directives on component [ci], and checks the alignment of aligned() attributes. This function is complemented by [process_pragmas_pack_align_field_attributes]. *) let process_pragmas_pack_align_comp_attributes ci cattrs = match !current_packing_pragma, align_pragma_for_struct ci.corig_name with | None, None -> check_aligned cattrs | Some n, apragma -> warn_incompatible_pragmas_attributes apragma (cattrs <> []); let with_aligned_attributes = match combine_aligned_attributes cattrs with | None -> (* No valid aligned attributes in this field. - if the composite type has a packed attribute, then add the alignment given by the pack pragma; - otherwise, no alignment attribute is necessary. Drop existing "aligned" attributes, if there are invalid ones. *) if Cil.hasAttribute "packed" cattrs then (dropAttribute "aligned" cattrs) else begin Kernel.feedback ~dkey:category_pragma ~current:true "adding aligned(%a) attribute to comp '%s' due to packing pragma" (Integer.pretty ~hexa:false) n ci.cname; addAttribute (Attr("aligned",[AInt n])) (dropAttribute "aligned" cattrs) end | Some local -> (* The largest aligned wins with GCC. Don't know with other compilers. *) let align = Integer.max n local in Kernel.feedback ~dkey:category_pragma ~current:true "setting aligned(%a) attribute to comp '%s' due to packing pragma" (Integer.pretty ~hexa:false) align ci.cname; addAttribute (Attr("aligned",[AInt align])) (dropAttribute "aligned" cattrs) in force_packed_attribute with_aligned_attributes | None, Some true -> dropAttribute "aligned" cattrs | None, Some false -> force_packed_attribute (addAttribute (Attr("aligned",[AInt Integer.one])) (dropAttribute "aligned" cattrs)) (* Takes into account the possible effect of '#pragma pack' directives on field [fi], and checks the alignment of aligned() attributes. Because we emulate them using GCC attributes, this transformation is complex and depends on several factors: - if the struct inside the pragma is packed, then ignore alignment constraints given by the pragma; - otherwise, each struct field should have the alignment given by the pack directive, unless that field already has an align attribute, in which case the minimum of both is taken into account (note that, in GCC, if a field has 2 alignment directives, it is the maximum of those that is taken). *) let process_pragmas_pack_align_field_attributes fi fattrs cattr = match !current_packing_pragma, align_pragma_for_struct fi.forig_name with | None, None -> check_aligned fattrs | Some n, apragma -> begin warn_incompatible_pragmas_attributes apragma (fattrs <> []); match combine_aligned_attributes fattrs with | None -> (* No valid aligned attributes in this field. - if the composite type has a packed attribute, nothing needs to be done (the composite will have the "packed" attribute anyway); - otherwise, align on min(n,sizeof(fi.ftyp)). Drop existing "aligned" attributes, if there are invalid ones. *) if Cil.hasAttribute "packed" cattr then (dropAttribute "aligned" fattrs) else begin let align = Integer.(min n (of_int (Cil.bytesSizeOf fi.ftype))) in Kernel.feedback ~dkey:category_pragma ~current:true "adding aligned(%a) attribute to field '%s.%s' due to packing pragma" (Integer.pretty ~hexa:false) align fi.fcomp.cname fi.fname; addAttribute (Attr("aligned",[AInt align])) (dropAttribute "aligned" fattrs) end | Some local -> (* There is an alignment attribute in this field. This may be smaller than the field type alignment, so we get the maximum of both. Then, we apply the pragma pack: the final alignment will be the minimum between what we had and [n]. *) let align = Integer.min n (Integer.max (Integer.of_int (Cil.bytesSizeOf fi.ftype)) local) in Kernel.feedback ~dkey:category_pragma ~current:true "setting aligned(%a) attribute to field '%s.%s' due to packing pragma" (Integer.pretty ~hexa:false) align fi.fcomp.cname fi.fname; addAttribute (Attr("aligned",[AInt align])) (dropAttribute "aligned" fattrs) end | None, Some true -> dropAttribute "aligned" fattrs | None, Some false -> (addAttribute (Attr("aligned",[AInt Integer.one])) (dropAttribute "aligned" fattrs)) (***** 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 detonation 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 typeHasAttribute "transparent_union" t then begin match comp.cfields with | [] -> abort_context "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 Cil.msvcMode () then n = "va_alist" else n = "__builtin_va_alist" let isOldStyleVarArgTypeName n = if Cil.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 | (GFunDecl _ 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 | GFunDecl (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},_) | GFunDecl(_,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}, _) | GFunDecl (_, 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 encountered * 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, _) :: rest when IH.mem mustTurnIntoDef vi.vid -> IH.remove mustTurnIntoDef vi.vid; (* Use the location of vi instead of the one carried by GVarDecl. Maybe we found in the same file a declaration and then a tentative definition. In this case, both are GVarDecl, but the location carried by [vi] is the location of the tentative definition, which is more useful. *) if vi.vstorage = Extern then vi.vstorage <- NoStorage; vi.vdefined <- true; revonto (GVar (vi, {init = None}, vi.vdecl) :: 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 Alpha.alphaTableData ref * location Alpha.alphaTableData | UndoRemoveFromAlphaTable of string let scopes : undoScope list ref list ref = ref [] (* tries to estimate if the name 's' was declared in the current scope; note that this may not work in all cases *) let declared_in_current_scope s = match !scopes with | [] -> (* global scope: check if present in genv *) H.mem genv s | cur_scope :: _ -> let names_declared_in_current_scope = Extlib.filter_map (fun us -> match us with | UndoRemoveFromEnv _ | UndoRemoveFromAlphaTable _ -> true | UndoResetAlphaCounter _ -> false) (fun us -> match us with | UndoRemoveFromEnv s | UndoRemoveFromAlphaTable s -> s | UndoResetAlphaCounter _ -> assert false (* already filtered *) ) !cur_scope in List.mem s names_declared_in_current_scope (* 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 | _ -> H.add genv n (d,CurrentLoc.get()) (* 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 Alpha.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 (Alpha.newAlphaName alphaTable 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 = (* typedefs live in the same namespace as normal identifiers. *) if kind = "" || kind = "type" then origname else kind ^ " " ^ origname let stripKind (kind: string) (kindplusname: string) : string = let kind = if kind = "type" then "" else kind in let l = 1 + String.length kind in if l > 1 then String.sub kindplusname l (String.length kindplusname - l) else kindplusname let is_same_kind kind info = match kind, info with | "", EnvEnum _ | "enum", EnvTyp _ | "type", EnvTyp _ | "struct", EnvTyp _ | "union", EnvTyp _ | "label", EnvLabel _ | "", EnvVar _ -> true | _, _ -> false let find_identifier_decl name info = match info with | UndoRemoveFromEnv name' -> name = name' | _ -> false 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 = Alpha.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 = Alpha.newAlphaName alphaTable lookupname (CurrentLoc.get ()) in if newname <> lookupname then begin try let info = if !scopes = [] then begin fst (H.find genv lookupname) end else if List.exists (find_identifier_decl lookupname) !(List.hd !scopes) then fst (H.find env lookupname) else raise Not_found in if not (Kernel.C11.get () && kind = "type") then (* in C11, typedefs can be redefined under some conditions (which are checked in doTypedef); this test catches other kinds of errors, such as redefined enumeration constants *) Kernel.error ~current:true "redefinition of '%s'%s in the same scope.@ \ Previous declaration was at %a" origname (if is_same_kind kind info then "" else " with different kind") Cil_datatype.Location.pretty oldloc with | Not_found -> () (* no clash of identifiers *) | Failure _ -> Kernel.fatal "finding a fresh identifier in local scope with empty scopes stack" end; 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 -> abort_context "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). *) if not vi.vglob && not vi.vformal 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 let get_temp_name () = let undolist = ref [] in let data = CurrentLoc.get() in let name, _ = Alpha.newAlphaName ~alphaTable ~undolist ~lookupname:"tmp" ~data in let undolist = !undolist in Alpha.undoAlphaChanges ~alphaTable ~undolist; name (* 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 let name = get_temp_name () in let vi = makeVarinfo ~temp:true false false name t' in vi.vdescr <- Some 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 _ ->[]) (fc_stdlib_attribute []) 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 = fc_stdlib_attribute []; 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 searches 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 (* C99 6.3.2.1:2: l-values used as r-values lose their qualifier. By default, we drop qualifiers, and recover them for the few operators that are exceptions, also listed in 6.3.2.1:2 *) let dropQualifiers = Cil.type_remove_qualifier_attributes (* 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 ) = Kernel.debug ~dkey:category_cast "@[%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:category_cast "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 abort_context s 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:category_cast "@[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:category_cast "Casting %a to __builtin_va_list" Cil_printer.pp_typ ot ; result | TPtr _, TEnum _ -> Kernel.debug ~dkey:category_cast "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 (* Evaluate constants to CTrue (non-zero) or CFalse (zero) *) let rec isConstTrueFalse c: [ `CTrue | `CFalse ] = match c with | CInt64 (n,_,_) -> if Integer.equal n Integer.zero then `CFalse else `CTrue | CChr c -> if Char.code c = 0 then `CFalse else `CTrue | CStr _ | CWStr _ -> `CTrue | CReal(f, _, _) -> if f = 0.0 then `CFalse else `CTrue | CEnum {eival = e} -> match isExpTrueFalse e with | `CTrue | `CFalse as r -> r | `CUnknown -> Kernel.fatal ~current:true "Non-constant enum" (* Evaluate expressions to `CTrue, `CFalse or `CUnknown *) and isExpTrueFalse e: [ `CTrue | `CFalse | `CUnknown ] = match e.enode with | Const c -> (isConstTrueFalse c :> [ `CTrue | `CFalse | `CUnknown ]) | CastE _ -> begin (* Do not ignore the cast, because of possible overflows. However, calling constFoldToInt might make some UB disappear... *) match Cil.constFoldToInt e with | None -> `CUnknown | Some i -> if Integer.(equal zero i) then `CFalse else `CTrue end | _ -> `CUnknown 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 loc_of_chunk c = match c.stmts with | [] -> (match c.locals with | [] -> Cabshelper.cabslu | v :: _ -> v.vdecl) | (s,_,_,_,_) :: _ -> Cil_datatype.Stmt.loc s let empty = { stmts = []; cases = []; locals = []; unspecified_order = false; } let empty_stmts l = let rec is_empty_stmt s = match s.skind with | Instr (Skip _) -> s.labels = [] | 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 _ | Local_init(_, ConsInit _, _)) -> [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 (* Don't remove all current label at once, as there might be some labels on nested statements. See bts 1536. *) let reset_current_label () = label_current:= List.tl !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 (* just a placeholder that will never be used. no need to check for ghost status here. *) ~ghost:false ~valid_sid ~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 begin let b = Cil.mkBlock [mkStmt ~ghost ~valid_sid (UnspecifiedSequence (List.rev c.stmts))] in b.blocals <- c.locals; b end else match c.stmts with | [{ skind = Block b } as s,_,_,_,_] when collapse_block && s.labels = [] -> b.blocals <- c.locals @ b.blocals; b | stmts -> let stmts = List.rev_map (fun (s,_,_,_,_) -> s) stmts in let b = Cil.mkBlock stmts in b.blocals <- c.locals; b (* 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 begin let b = Cil.mkBlock [mkStmt ~ghost ~valid_sid kind] in b.blocals <- c.locals; Block b end else kind else let block = c2block ~ghost c in Block block in mkStmt ~ghost ~valid_sid 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 _ | Local_init (_, ConsInit _, _)) -> [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 | [] -> (match c2.locals with | [] -> c1 | l -> { c1 with locals = c1.locals @ l }) | [{skind = UnspecifiedSequence l},_,_,_,_] when c1.unspecified_order -> { stmts = List.rev_append l c1.stmts; cases = c1.cases @ c2.cases; locals = c1.locals @ c2.locals; unspecified_order = c1.unspecified_order; } | [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 Kernel.debug ~dkey:category_chunk "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 = Kernel.debug ~dkey:category_chunk "Removing %a from chunk@\n%a@." Cil_printer.pp_lval lv d_chunk c; let remove_list = List.filter (fun x -> not (LvalStructEq.equal 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 ~valid_sid (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 ~valid_sid (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 loc = let fundec = !currentFunctionFDEC in let s = Cil.mkPureExpr ~ghost ~fundec ~loc e in match s.skind with | Block b -> { empty with stmts = List.map (fun s -> (s,[],[],[],[])) b.bstmts; locals = b.blocals } | _ ->i2c (s,[],[],[]) (* 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 _ | TryCatch _ | Throw _ | 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 _ | Local_init (_, ConsInit _, _)) -> [ref s'] | Instr _ | TryExcept _ | TryFinally _ | TryCatch _ | Throw _ | 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 ~valid_sid (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 ~valid_sid (Break l),[],[],[],[] ]; cases = []; unspecified_order = false; locals = []; } (* can be ghost inside a ghost loop *) let continueChunk ~ghost (l: location) : chunk = { stmts = [ mkStmt ~ghost ~valid_sid (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 ~valid_sid ~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 ~valid_sid (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 true in let e'' = if theMachine.lowerConstants then constFold e' else e' in (match constFoldToInt e, constFoldToInt e'' with | Some i1, Some i2 when not (Integer.equal i1 i2) -> Kernel.feedback ~once:true ~source:(fst e.eloc) "Case label %a exceeds range of %a for switch expression. \ Nothing to worry." Cil_printer.pp_exp e Cil_printer.pp_typ t; | _ -> () ); 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 ~valid_sid (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 ghost = s.ghost in 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 ~ghost ~valid_sid ~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 _ | Throw _ | TryCatch _ -> 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 ~ghost loc r c = match r with | [] -> c | _ :: _ -> c +++ (mkEmptyStmt ~ghost ~valid_sid ~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 | [] -> abort_context "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 abort_context "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,_,_) -> Alpha.registerAlphaName alphaTable (kindPlusName "label" lbl) currentLoc | _ -> ()); DoChildren end (* 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 Cil.gccMode () && oldk = IInt && bytesSizeOf 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 (Format.asprintf "different integer types:@ '%a' and '%a'" Cil_printer.pp_ikind oldk Cil_printer.pp_ikind k))) 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 Cil.gccMode () && 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 ~level:2 "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) = ExpStructEq.equal (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 (Format.asprintf "different type constructors:@ %a and %a" Cil_printer.pp_typ oldt Cil_printer.pp_typ t)) let cleanup_isomorphicStructs () = H.clear isomorphicStructs let same_qualifiers t1 t2 = let attrs1 = Cil.filter_qualifier_attributes (Cil.typeAttrs t1) in let attrs2 = Cil.filter_qualifier_attributes (Cil.typeAttrs t2) in attrs1 = attrs2 let compatibleTypes t1 t2 = try let r = combineTypes CombineOther t1 t2 in (* C99, 6.7.3 §9: "... to be compatible, both shall have the identically qualified version of a compatible type;" *) if not (same_qualifiers t1 t2) then raise (Failure "different qualifiers"); (* Note: different non-qualifier attributes will be silently dropped. *) cleanup_isomorphicStructs (); r with Failure _ as e -> cleanup_isomorphicStructs (); raise e let areCompatibleTypes t1 t2 = try ignore (compatibleTypes t1 t2); true with Failure _ -> false (* 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 = let res = 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. *) Kernel.debug ~dkey:category_global "makeGlobalVarinfo isadef=%B vi.vname=%s(%d)" isadef vi.vname vi.vid; (* This may throw an exception Not_found *) let oldvi, oldloc = lookupGlobalVar vi.vname in Kernel.debug ~dkey:category_global " %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, NoStorage when isadef -> NoStorage (* the case above is not strictly C standard, but will not accept more program and is more compatible with old implicit quasi-invariant that Extern == not defined. *) | Extern, (Extern | NoStorage) -> Extern | NoStorage, Extern -> if oldvi.vdefined then NoStorage else Extern | NoStorage, NoStorage -> NoStorage | Static, Extern -> Static (* 6.2.2§4 *) | Static, NoStorage when Cil.isFunctionType vi.vtype -> Static | _ -> if vi.vstorage != oldvi.vstorage then Kernel.error ~current:true "Inconsistent storage specification for %s. \ Previous declaration: %a" vi.vname Cil_printer.pp_location oldloc; vi.vstorage in (* if _all_ declaration have the inline specifier, and none is extern we'll end up with an inline definition which must have a special treatment (see C11 6.7.4§7) *) oldvi.vinline <- oldvi.vinline && vi.vinline; (* 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); Cil.update_var_type oldvi mytype; with Failure reason -> Kernel.debug ~dkey:category_global "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; (* Update the storage and vdecl if useful. Do so only after the hooks have been applied, as they may need to read those fields *) if oldvi.vstorage <> newstorage then begin oldvi.vstorage <- newstorage; (* Also update the location; [vi.vdecl] is a better declaration/definition site for [vi]. *) 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 ~dkey:category_global "replacing formal %s with %s" old.vname name; old.vname <- name; Cil.update_var_type old typ; old.vattr <- attr; (match old.vlogic_var_assoc with | None -> () | Some old_lv -> old_lv.lv_name <- name) end) old_formals_env formals; with | Invalid_argument _ -> abort_context "Inconsistent formals" ; | Not_found -> Cil.setFormalsDecl oldvi vi.vtype) | _ -> () end ; (* if [isadef] is true, [vi] is a definition. *) if isadef then begin (* always favor the location of the definition.*) oldvi.vdecl <- vi.vdecl; oldvi.vdefined <- true; end; (* notice that [vtemp] is immutable, and cannot be updated. Hopefully, temporaries have sufficiently fresh names that this is not a problem *) oldvi, true with Not_found -> begin (* A new one. *) Kernel.debug ~level:2 ~dkey:category_global " %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.vattr <- fc_stdlib_attribute vi.vattr; vi, false end in NewGlobalHook.apply res; res (* Register a builtin function *) let setupBuiltin ?(force_keep=false) name (resTyp, argTypes, isva) = let args = Some (List.map (fun at -> ("", at, [])) argTypes) in let typ = TFun(resTyp, args, isva, []) in let v = makeGlobalVar name typ in ignore (alphaConvertVarAndAddToEnv true v); (* Add it to the file as well *) cabsPushGlobal (GFunDecl (empty_funspec (), v, Cil.builtinLoc)); Cil.setFormalsDecl v v.vtype; if force_keep then v.vattr <- Cil.addAttribute (Attr ("FC_BUILTIN",[])) v.vattr; v ;; let memoBuiltin ?force_keep name proto = try fst (lookupGlobalVar name) with Not_found -> setupBuiltin ?force_keep name proto let vla_alloc_fun () = memoBuiltin "__fc_vla_alloc" (voidPtrType, [theMachine.typeOfSizeOf], false) let vla_free_fun () = memoBuiltin ~force_keep:true "__fc_vla_free" (voidType, [voidPtrType], false) 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 different types, 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 utilities for doing initializers *) type preInit = | NoInitPre | SinglePre of exp * Cil_datatype.Lval.Set.t (* lval reads by the expression*) | CompoundPre of int ref (* the maximum used index *) * preInit array ref (* an array with initializers *) (* internal pretty-printing function for debugging purposes *) let rec _pp_preInit fmt = function | NoInitPre -> Format.fprintf fmt "NoInitPre" | SinglePre (e,_) -> Format.fprintf fmt "SinglePre(%a)" Cil_printer.pp_exp e | CompoundPre (int_ref, preInit_a_ref) -> Format.fprintf fmt "CompoundPre(%d,@[%a@])" !int_ref (Pretty_utils.pp_array ~sep:",@ " (fun fmt index e -> Format.fprintf fmt "@[[%d -> %a]@]" index _pp_preInit e)) !preInit_a_ref (* special case for treating GNU extension on empty compound initializers. *) let empty_preinit() = if Cil.gccMode () || Cil.msvcMode () then CompoundPre (ref (-1), ref [| |]) else abort_context "empty initializers only allowed for GCC/MSVC" (* Set an initializer *) let rec setOneInit this o preinit = match o with | NoOffset -> preinit | _ -> 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 | [] -> (* We have managed to build a fieldinfo whose fcomp field is a compinfo that does not include the corresponding field. This is not a typechecking error, but an internal failure of cabs2cil *) Kernel.fatal ~current:true "Cannot find field %s for initialization of type %s" f.fname (Cil.compFullName f.fcomp) | f' :: _ when f'.fname = f.fname -> idx | _ :: restf -> loop (idx + 1) restf in loop 0 f.fcomp.cfields, off | _ -> abort_context "setOneInit: non-constant index" in let pMaxIdx, pArray = match this with | NoInitPre -> (* No initializer so far here *) ref idx, ref (Array.make (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 preinit 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). * Finally, we return the set of lvals that are read for the evaluation of * the initializer (for unspecified sequences) *) let rec collectInitializer reads (* lval already read by the rest of the initializer. *) (this: preInit) (thistype: typ) ~(parenttype: typ) : (init * typ * Cil_datatype.Lval.Set.t) = (* parenttype is used to identify a tentative flexible array member initialization *) let dkey = category_initializer in let loc = CurrentLoc.get() in if this = NoInitPre then begin Kernel.debug ~dkey "zero-initializing object of type %a" Cil_printer.pp_typ thistype; (makeZeroInit ~loc thistype), thistype, reads end else match unrollType thistype, this with | _ , SinglePre (e, r) -> Kernel.debug ~dkey "Initializing object of type %a to %a" Cil_printer.pp_typ thistype Cil_printer.pp_exp e; SingleInit e, thistype, Cil_datatype.Lval.Set.union r reads | TArray (bt, leno, _, at), CompoundPre (pMaxIdx, pArray) -> Kernel.debug ~dkey "Initialization of an array object of type %a with index max %d" Cil_printer.pp_typ thistype !pMaxIdx; let len, initializer_len_used = (* normal case: use array's declared length, newtype=thistype *) match leno with | Some len -> begin match constFoldToInt len with | Some 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 abort_context "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,reads,len_used) = match v with | NoInitPre -> (idx-1,init,typ,reads,len_used) | _ -> let (vinit,typ', reads') = collectInitializer reads v typ ~parenttype: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', Cil_datatype.Lval.Set.union reads' reads, len_used) in let (_,init,typ, reads, len_used) = Array.fold_right collect_one_init !pArray (Array.length !pArray - 1, [], bt, reads,initializer_len_used) in let newtype = (* detect flexible array member initialization *) match thistype, Cil.unrollType parenttype with | TArray (_, None, _, _), TComp (comp, _, _) when comp.cstruct && len > 0 -> (* incomplete array type inside a struct => FAM, with a non-empty initializer (len > 0) *) Kernel.debug ~dkey:category_initializer "Detected initialization of a flexible array member \ (length %d, parenttype %a)" len Cil_printer.pp_typ parenttype; Kernel.error ~once:true ~current:true "static initialization of flexible array members is an \ unsupported GNU extension"; TArray (typ, None, empty_size_cache (), at) | _ -> (* not a flexible array member *) if len = 0 && not (Cil.gccMode() || Cil.msvcMode ()) then Kernel.error ~once:true ~current:true "arrays of size zero not supported in C99@ \ (only allowed as compiler extensions)"; 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), reads | TComp (comp, _, _), CompoundPre (pMaxIdx, pArray) when comp.cstruct -> Kernel.debug ~dkey "Initialization of an object of type %a with at least %d components" Cil_printer.pp_typ thistype !pMaxIdx; let rec collect (idx: int) reads = function [] -> [], reads | f :: restf -> if f.fname = missingFieldName then collect (idx + 1) reads restf else let thisi, reads' = if idx > !pMaxIdx then makeZeroInit ~loc f.ftype, reads else collectFieldInitializer reads !pArray.(idx) f ~parenttype:thistype in let rest, reads' = collect (idx+1) reads' restf in (Field(f, NoOffset), thisi) :: rest, reads' in let init, reads = collect 0 reads comp.cfields in CompoundInit (thistype, init), thistype, reads | TComp (comp, _, _), CompoundPre (pMaxIdx, pArray) when not comp.cstruct -> Kernel.debug ~dkey "Initialization of an object of type %a with at least %d components" Cil_printer.pp_typ thistype !pMaxIdx; (* Find the field to initialize *) let rec findField (idx: int) = function | [] -> abort_context "collectInitializer: union" | _ :: rest when idx < !pMaxIdx && !pArray.(idx) = NoInitPre -> findField (idx + 1) rest | f :: _ when idx = !pMaxIdx -> let init, reads = collectFieldInitializer reads !pArray.(idx) f ~parenttype:thistype in (Field(f, NoOffset), init), reads | _ -> Kernel.fatal ~current:true "Can initialize only one field for union" in if Cil.msvcMode () && !pMaxIdx != 0 then Kernel.warning ~current:true "On MSVC we can initialize only the first field of a union"; let init, reads = findField 0 comp.cfields in CompoundInit (thistype, [ init ]), thistype, reads | _ -> Kernel.fatal ~current:true "collectInitializer" and collectFieldInitializer reads (this: preInit) (f: fieldinfo) ~(parenttype: typ) = (* collect, and rewrite type *) let init,newtype,reads = (collectInitializer reads this f.ftype ~parenttype) in f.ftype <- newtype; init, reads 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 | GFunDecl(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 *) Kernel.debug ~dkey:category_initializer "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 *) Kernel.debug ~dkey:category_initializer "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 abort_context "advanceSubobj past end"; match so.stack with | [] -> Kernel.debug ~dkey:category_initializer "Setting eof to true"; so.eof <- true | InArray (_, _, _, current) :: _ -> Kernel.debug ~dkey:category_initializer " 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 -> Kernel.debug ~dkey:category_initializer "Advancing past .%s" (List.hd nextflds).fname; let flds' = try List.tl nextflds with Failure _ -> abort_context "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 *)) | _ -> abort_context "unnamed field type is not a struct/union" end | _ :: rest -> search rest in search fidlist let findField n comp = try find_field_offset (fun x -> x.fname = n) comp.cfields with Not_found -> abort_context "Cannot find field %s in type %s" n (Cil.compFullName comp) (* 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 tcallres f = match unrollType (typeOf f) with | TFun (rt, _, _, _) -> rt | _ -> abort_context "Function call to a non-function" let can_collapse vi vi' destlv cast f = let tf = tcallres f in 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 cast (typeOfLval destlv) && (* Depending on circumstances, temp var might either have the type of the destination variable or the returned type of f. We collapse in both cases. *) (Cil_datatype.Typ.equal vi.vtype cast || Cil_datatype.Typ.equal vi.vtype tf) && allow_return_collapse ~tf ~tlv:cast 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 can_collapse vi vi' destlv newt f 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 can_collapse vi vi' destlv (typeOfLval destlv) f then begin s1.skind <- Instr(Call(Some destlv, f, args, l)); Some [ s1 ] end else None | Instr (Call (Some (Var vi, NoOffset), ({ enode = Lval (Var f, NoOffset)} as ef), args, l)), Instr ( Local_init( destv, AssignInit( SingleInit { enode = CastE(newt, { enode = Lval(Var vi', NoOffset)})}),_))-> if can_collapse vi vi' (Cil.var destv) newt ef then begin s1.skind <- Instr(Local_init(destv, ConsInit(f,args,Plain_func),l)); Some [s1] end else None | Instr (Call (Some (Var v1, NoOffset), ({ enode = Lval (Var f, NoOffset)} as ef), args, l)), Instr ( Local_init( v2, AssignInit(SingleInit { enode = Lval (Var v1', NoOffset) }),_)) -> if can_collapse v1 v1' (Cil.var v2) v2.vtype ef then begin s1.skind <- Instr(Local_init(v2, ConsInit(f,args,Plain_func),l)); Some [ s1 ]; end else None | _ -> None 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 block = c2block ~ghost ~collapse_block:false c in let sl = if Kernel.DoCollapseCallCast.get () then peepHole2 ~aggressive: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 (Format.asprintf "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)) (* Exception raised by the instance of Logic_typing local to this module. See document of [error] below. *) exception LogicTypeError of location * string 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_field info s = findField s info let find_type namespace s = match namespace with | Logic_typing.Typedef -> let t,_ = lookupTypeNoError "type" s in t | Logic_typing.Union -> findCompType "union" s [] | Logic_typing.Struct -> findCompType "struct" s [] | Logic_typing.Enum -> findCompType "enum" s [] 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 (* This function raises a non-recoverable when [-continue-annot-error] is not set, and [LogicTypeError] otherwise. This exception must *not* escape Cabs2cil. Hence, each call to a function of module [Ltyping] below must catch it. *) let error (source,_ as loc) msg = if Kernel.ContinueOnAnnotError.get () then Pretty_utils.ksfprintf (fun e -> raise (LogicTypeError (loc,e))) msg else Kernel.abort ~source msg 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 | Local_init _ -> true | 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 _ | Throw _ -> 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 | TryCatch (b, l, _) -> List.fold_left (fun acc (_,b) -> acc || blockFallsThrough b) (blockFallsThrough b) l | 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 _ | Throw _ -> 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 | TryCatch (b,l,_) -> List.fold_left (fun acc (_,b) -> acc || blockCanBreak b) (blockCanBreak b) l | 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 has_local_init chunk = List.exists (fun (s,_,_,_,_) -> match s.skind with Instr (Local_init _) -> true | _ -> false) chunk.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. *) | _ -> if has_local_init current_chunk then begin (* See if we can collapse the statements of the chunk into a single one. Otherwise, we can't handle the combination, as putting the Local_init into a new block would change the scope of the local variable, at least in the pretty-printed code. Furthermore, the usefulness of such annotations is dubious at best. *) let res = match current_chunk.stmts with | [(s1, m1, w1, r1, c1); (s2, m2, w2, r2, c2)] -> Extlib.swap Extlib.opt_bind (collapseCallCast (s2,s1)) (* the chunk list is reversed.*) (function | [ s1' ] -> Some (s1', m1 @ m2, w1 @ w2, r1 @ r2, c1 @ c2) | _ -> None (* should not happen. *)) | _ -> None in match res with | Some s -> annot_chunk @@ ({current_chunk with stmts = [s]}, ghost) | None -> if Kernel.ContinueOnAnnotError.get() then begin Kernel.warning "Statement contract and ACSL pragmas over a local definition \ are not implemented. Ignoring annotation"; current_chunk end else begin Format.eprintf "Chunk is:@\n%a@." d_chunk current_chunk; (* more accurate context if possible *) if not (isEmpty annot_chunk) then CurrentLoc.set (loc_of_chunk annot_chunk); abort_context "Statement contract and ACSL pragmas over a local definition \ are not implemented." end end else begin let b = c2block ~ghost current_chunk in (* The statement may contain some local variable declarations (but no definitions) 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 ~valid_sid (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) end 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 ~valid_sid (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 ~valid_sid (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 ~valid_sid (Instr (Set (lv, (Cil.kinteger ~loc ikind 0),loc)))) | TFloat (fkind,_) -> let lv = (Var vi,off) in s2c (Cil.mkStmt ~ghost ~valid_sid (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 ~valid_sid (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.constFoldToInt e with | Some 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 ~valid_sid (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.Integer.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 _ -> voidType | TInt(k,_) when Cil.rank k < Cil.rank IInt -> if intTypeIncluded k IInt then intType else (* This may happen when char or short have the same size as int *) uintType | TInt(k,_) -> TInt(k,[]) | TFloat(FFloat,_) -> doubleType | 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 _ -> abort_context "implicit prototype cannot have variadic arguments" | TNamed _ -> assert false (* unrollType *) in (* if we make a promotion, take it explicitly into account in the argument itself *) let (_,e) = castTo arg_type typ exp in (name,typ,[]), e (* Promote variadic arguments with standard argument promotions.*) let promote_variadic_arguments (chunk,args) = let args = Extlib.mapi (fun i arg -> snd (default_argument_promotion i arg)) args in (chunk,args) let rec evaluate_cond_exp = function | CEExp (_,e) -> (match Cil.constFoldToInt e with | None -> `CUnknown | Some z when Integer.is_zero z -> `CFalse | Some _ -> `CTrue) | CEAnd (e1,e2) -> let r = evaluate_cond_exp e1 in if r = `CTrue then evaluate_cond_exp e2 else r | CEOr(e1,e2) -> let r = evaluate_cond_exp e1 in if r = `CFalse then evaluate_cond_exp e2 else r | CENot e -> match evaluate_cond_exp e with | `CTrue -> `CFalse | `CFalse -> `CTrue | `CUnknown -> `CUnknown (* The way formals are handled now might generate incorrect types, in the sense that they refer to a varinfo (in the case of VLA depending on a previously declared formal) that exists only during the call to doType. We replace them here with the definitive version of the formals' varinfos. A global refactoring of cabs2cil would be welcome, though. *) let fixFormalsType formals = let table = Hashtbl.create 5 in let vis = object inherit Cil.nopCilVisitor method! vvrbl v = if v.vformal then begin try ChangeTo (Hashtbl.find table v.vname) with Not_found -> Kernel.fatal "Formal %a not tied to a varinfo" Cil_printer.pp_varinfo v; end else SkipChildren end in let treat_one_formal v = v.vtype <- Cil.visitCilType vis v.vtype; Hashtbl.add table v.vname v; in List.iter treat_one_formal formals (* Map from standard int type names like [uint16_t] to their expected sizes, and a flag whether the given size is exact (or a lower bound). That is, [uint16_t] maps to [(16, true)], and [uint_least16_t] to [(16, false)]. Used by [checkTypedefSize] below. *) let stdIntegerSizes = Hashtbl.create 5 (* Initialize the stdIntegerSizes table. *) let initStdIntegerSizes () = let bases = ["int"; "uint"] in let sizes = [8; 16; 32; 64] in let add_std_type base size = let add_variant (variant, exact) = let key = base ^ variant ^ (string_of_int size) ^ "_t" in Hashtbl.add stdIntegerSizes key (size, exact) in (* Store exact "normal" variant, inexact "fast" and "least" variants. *) List.iter add_variant [("", true); ("_fast", false); ("_least", false)] in List.iter (fun b -> List.iter (add_std_type b) sizes) bases; (* Also store variants of [intptr_t] using the size of [void *], and [intmax_t] variants using the size of [long long]. *) let add_special_types name size = let add base = Hashtbl.add stdIntegerSizes (base ^ name ^ "_t") (size, true) in List.iter add bases in add_special_types "ptr" (Cil.bitsSizeOf Cil.voidPtrType); add_special_types "max" (Cil.bitsSizeOf Cil.longLongType) (* [checkTypedefSize name typ] checks if [name] is acceptable as a typedef name for type [typ]. If [name] is one of the standard integer type names like [uint16_t] but [typ] has the wrong bit size, emits a warning. *) let checkTypedefSize name typ = if Hashtbl.length stdIntegerSizes = 0 then initStdIntegerSizes (); if Cil.isIntegralType typ then begin let size = Cil.bitsSizeOf typ in try let intended_size, exact = Hashtbl.find stdIntegerSizes name in if (exact && size <> intended_size) || (not exact && size < intended_size) then Kernel.warning ~current:true "bad type '%a' (%d bits) for typedef '%s';@ \ check for mismatch between -machdep flag and headers used" Typ.pretty typ size name with (* Not a standard integer type, ignore it. *) Not_found -> () end 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 _ -> abort_context "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 Cil.gccMode () -> (* 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 "__builtin_va_list"] when Cil.theMachine.theMachine.has__builtin_va_list -> TBuiltin_va_list [] | [A.Tnamed "__fc_builtin_size_t"] -> Cil.theMachine.typeOfSizeOf | [A.Tnamed n] -> (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 Cil.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 constFoldToInt 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 ~kind: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 *) 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 AExpLeaveArrayFun in let t' = match e'.enode with (* 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 (), []) | _ -> abort_context "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 ~temp:isgenerated isglobal isformal n t in vi.vstorage <- sto; vi.vattr <- nattr; vi.vdecl <- ldecl; vi.vghost <- ghost; vi.vdefined <- not (isFunctionType vtype) && isglobal && (sto = NoStorage || sto = Static); (* 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 (Cil.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 constFoldToInt 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 *) ?(allowZeroSizeArrays=false) ?(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 (Cil.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) -> if Cil.isFunctionType bt then Kernel.error ~once:true ~current:true "declaration of array of function type '%a`" Cil_printer.pp_typ bt else if not (Cil.isCompleteType ~allowZeroSizeArrays:true bt) then Kernel.error ~once:true ~current:true "declaration of array of incomplete type '%a`" Cil_printer.pp_typ bt else if not allowZeroSizeArrays && not (Cil.isCompleteType ~allowZeroSizeArrays:false bt) then (* because we tested previously for incomplete types and now tested again forbidding zero-length arrays, bt is necessarily a zero-length array *) if Cil.gccMode () || Cil.msvcMode () then Kernel.warning ~once:true ~current:true "declaration of array of 'zero-length arrays' ('%a`);@ \ zero-length arrays are a compiler extension" Cil_printer.pp_typ bt else Kernel.error ~once:true ~current:true "declaration of array of 'zero-length arrays' ('%a`);@ \ zero-length arrays are not allowed in C99" Cil_printer.pp_typ bt; 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" | _ -> 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 ~once:true ~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 != [] && Cil.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. *) let real_type = turnArrayIntoPointer bt lo attr in Cil.update_var_type a real_type | TFun _ -> Cil.update_var_type a (TPtr(a.vtype, [])) | TComp (_, _,_) -> begin match isTransparentUnion a.vtype with | None -> () | Some fstfield -> transparentUnionArgs := (argidx, a.vtype) :: !transparentUnionArgs; Cil.update_var_type a 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 -> (* Checks whether the expression is an integer constant expression, that is: - it contains no side-effect - it can be evaluated at compile-time Note that we should not pass true as asconst argument for doExp, since we are precisely trying to determine whether the expression is a constant or not. *) let (_, se, e', _) = doExp (ghost_local_env ghost) false 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 is_last_field (((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 allowZeroSizeArrays = true in let ftype, nattr = doType ~allowZeroSizeArrays ghost false (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in (* check for fields whose type is incomplete. In particular, this rules out circularity: struct C1 { struct C2 c2; }; //This line is now an error. struct C2 { struct C1 c1; int dummy; }; *) if not (Cil.isCompleteType ~allowZeroSizeArrays ftype) || Cil.isFunctionType ftype then (match Cil.unrollType ftype with | TArray(_,None,_,_) when is_last_field -> () | _ -> Kernel.error ~current:true "field %s is declared with incomplete type %a" n Cil_printer.pp_typ ftype); 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 let rec is_circular t = match Cil.unrollType t with | TArray(bt,_,_,_) -> is_circular bt | TComp (comp',_,_) -> if Cil_datatype.Compinfo.equal comp comp' then begin (* abort and not error, as this circularity could lead to infinite recursion... *) Kernel.abort "type %s %s is circular" (if comp.cstruct then "struct" else "union") comp.cname; end else List.iter (fun f -> is_circular f.ftype) comp'.cfields; | _ -> () in is_circular ftype; { 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 let rec map_but_last l = match l with | [] -> [] | [f] -> [makeFieldInfo true f] | f::l -> makeFieldInfo false f :: map_but_last l in map_but_last 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 thorough 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 begin comp.cfields <- flds; let fields_with_pragma_attrs = List.map (fun fld -> (* note: in the call below, we CANNOT use fld.fcomp.cattr because it has not been filled in yet, so we need to pass the list of attributes [a] to it *) {fld with fattr = (process_pragmas_pack_align_field_attributes fld fld.fattr a)} ) comp.cfields in comp.cfields <- fields_with_pragma_attrs end; (* ignore (E.log "makeComp: %s: %a\n" comp.cname d_attrlist a); *) let a = Cil.addAttributes comp.cattr a in comp.cattr <- process_pragmas_pack_align_comp_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(charConstToIntConstant 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 and isIntegerConstant ghost (aexp) : int option = match doExp (ghost_local_env ghost) true aexp (AExp None) with | (_, c, e, _) when isEmpty c -> begin match Cil.constFoldToInt 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 occurring 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 ~valid_sid (Set(lv, e'', CurrentLoc.get ())), writes,writes, List.filter (fun x -> not (LvalStructEq.equal x lv)) r @ reads), e'', t'') end in let result = 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 (* Always allow to read the address of an array, as it will never be written to: no read/write interference is possible. *) Cil.isArrayType vi.vtype || 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)) (dropQualifiers 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 exactly one pointer type in array access %a[%a] (%a \ and %a)" Cil_printer.pp_exp e1' Cil_printer.pp_exp e2' 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)) (dropQualifiers 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)) (dropQualifiers 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 | _ -> Kernel.fatal ~current:true "expecting a struct with field %s" str in let lv' = addOffsetLval field_offset lv in let field_type = typeOfLval 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')) (dropQualifiers 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 | 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 = typeOfLval 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')) (dropQualifiers 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 = Transitioning.String.uppercase_ascii (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 buried __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 ~kind:theMachine.wcharKind (Integer.of_int64 value) in finishExp [] (unspecified_chunk empty) result (typeOf result) | A.CONST_FLOAT str -> begin (* Maybe it ends in F or L. 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 open Floating_point in let basefloat = parse_kind kind baseint 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 | _ -> abort_context "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.feedback ~once:true ~current:true "Dropping side-effect in sizeof. \ Nothing to worry, this is by the book."; 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 (* 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 Cil.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 (* Recover type qualifiers that were dropped by dropQualifiers when the l-value was created *) let tres = match e'.enode with | Lval x -> Cil.typeOfLval x | _ -> t in finishExp reads se (mkAddrOfAndMark loc x) (TPtr(tres, [])) | 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 ~valid_sid (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 = Format.asprintf "%a%s" Cil_descriptive_printer.pp_exp e' (if uop = A.POSINCR then "++" else "--") in let tmp = newTempVar descr true t in ([var tmp], local_var_chunk se' tmp +++ (mkStmtOneInstr ~ghost:local_env.is_ghost ~valid_sid (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 ~valid_sid (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 = Format.asprintf "%a" Cil_descriptive_printer.pp_lval lv in let tmp = newTempVar descr true lvt in let chunk = i2c (mkStmtOneInstr ~ghost:local_env.is_ghost ~valid_sid (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 ~valid_sid (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 c;eloc=loc})) -> finishExp [] se (match isConstTrueFalse c with | `CTrue -> one ~loc | `CFalse -> 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 "" true intType in let condChunk = compileCondExp ~ghost ce (empty +++ (mkStmtOneInstr ~ghost ~valid_sid (Set(var tmp, integer ~loc 1,loc)),[],[],[])) (empty +++ (mkStmtOneInstr ~ghost ~valid_sid (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) -> 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 (* First look for polymorphic builtins. The typing rule is luckily always the same one. *) let n = match n with | "__sync_add_and_fetch" | "__sync_sub_and_fetch" | "__sync_or_and_fetch" | "__sync_and_and_fetch" | "__sync_xor_and_fetch" | "__sync_nand_and_fetch" | "__sync_fetch_and_add" | "__sync_fetch_and_sub" | "__sync_fetch_and_or" | "__sync_fetch_and_and" | "__sync_fetch_and_xor" | "__sync_fetch_and_nand" | "__sync_bool_compare_and_swap" | "__sync_val_compare_and_swap" | "__sync_lock_release" | "__sync_lock_test_and_set" -> begin match args with | a1::_ -> (* The available prototypes are typ' f(typ* a1,typ a2,typ a3,...); typ' f(typ* a1,typ a2,...); typ' f(typ* a1,...); Hence we just infer the right type looking at the first argument. *) let _,_,_,t = doExp local_env false a1 AType in let t = typeOf_pointed t in Format.sprintf "%s_%sint%d_t" n (if isSignedInteger t then "" else "u") (bitsSizeOf t) | [] -> Kernel.error ~once:true ~current:true "Too few arguments for builtin %s" n; n end | _ -> n in 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 ~temp: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 (GFunDecl (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 (Format.asprintf "%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 ~valid_sid (Local_init(tmp, AssignInit (SingleInit 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 ~ghost:local_env.is_ghost 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 _,_ -> if isvar then begin (* use default argument promotion to infer the type of the variadic actuals, see C11:6.5.2.2:7 *) promote_variadic_arguments res end else res | None, Lval (Var f, NoOffset) when not isSpecialBuiltin -> begin (* use default argument promotion to infer the type of the function, see 6.5.2.2.6 *) assert (not isvar); (* No nullary variadics see C11:6.7.6 *) let (prm_types,args) = List.split (Extlib.mapi default_argument_promotion args) in let typ = TFun (resType, Some prm_types, false,attrs) in Cil.update_var_type f typ; Cil.setFormalsDecl f typ; (chunk,args) end | 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 match fv.vname with | "__builtin_va_arg" -> 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 "vararg" 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 | "__builtin_stdarg_start" | "__builtin_va_start" -> 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 | "__builtin_varargs_start" -> begin (* Lookup the prototype for the replacement *) let v, _ = try lookupGlobalVar "__builtin_stdarg_start" with Not_found -> abort_context "Cannot find __builtin_stdarg_start to replace %s" fv.vname in pf := new_exp ~loc (Lval (var v)) end | "__builtin_next_arg" -> 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 | "__builtin_va_arg_pack" -> begin (match !pargs with | [ ] -> begin piscall := false; pres := new_exp ~loc:e.expr_loc (SizeOfE !pf); prestype := theMachine.typeOfSizeOf end | _ -> Kernel.warning ~current:true "Invalid call to builtin_va_arg_pack"); end | "__builtin_constant_p" -> 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 | "__builtin_types_compatible_p" -> begin (* Constant-fold the argument and see if it is a constant *) (match !pargs with | [ {enode = SizeOf t1}; {enode = SizeOf t2}] -> begin (* Drop the side-effects *) prechunk := empty; piscall := false; let compatible = try ignore(combineTypes CombineOther t1 t2); true with Failure _ -> false in if compatible then pres := integer ~loc 1 else pres := integer ~loc 0; prestype := intType end | _ -> Kernel.warning ~once:true ~current:true "Invalid call to builtin_types_compatible_p"); end | "__builtin_expect" -> begin match !pargs with | [ arg;_ ] -> (* Keep all side-effects, including those stemming from the second argument. This is quite strange but compliant with GCC's behavior. *) piscall := false; pres := arg | _ -> Kernel.warning ~once:true ~current:true "Invalid call to builtin_expect" end (* TODO: Only keep the side effects of the 1st or 2nd argument | "__builtin_choose_expr" -> begin match !pargs with | [ arg; e1; e2 ] -> begin let constfolded = constFold true arg in match constfolded.enode with | Const _ -> piscall := false; if isZero constfolded then begin (* Keep only 3rd arg side effects *) (*TODO: prechunk := sf @@ (List.nth sargsl 2);*) pres := e2; prestype := typeOf e2 end else begin (* Keep only 2nd arg side effects *) (*TODO prechunk := sf @@ (List.nth sargsl 1);*) pres := e1; prestype := typeOf e1 end | _ -> Kernel.warning ~once:true ~current:true "builtin_choose_expr expects a constant first argument" end | _ -> Kernel.warning ~once:true ~current:true "Invalid call to builtin_choose_expr: 3 arguments are \ expected but %d are provided." (List.length !pargs) end*) | _ -> if asconst then (* last special case: we cannot allow a function call at this point.*) begin piscall := false; abort_context "Call to %a in constant." Cil_printer.pp_varinfo fv; 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 ~valid_sid (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 = Format.asprintf "%a(%a)" Cil_descriptive_printer.pp_exp !pf (Pretty_utils.pp_list ~sep:", " Cil_descriptive_printer.pp_exp) !pargs in let tmp = newTempVar descr false restype'' in tmp.vdecl <- loc; 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"; (* We must ignore AExpLeaveArrayFun (a.k.a. 'do not decay pointers') if the expression at hand is a sequence with strictly more than one expression, because the exception for sizeof and typeof only apply when the expression is directly the argument of the operators. See C99 and C11 6.3.2.1§3.) *) let what = if what <> AExpLeaveArrayFun || List.length el = 1 then what else (AExp None) in 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 (* if we are evaluating a constant expression, e1 is supposed to evaluate to either true or false statically, and we can type-check only the appropriate branch. In fact, 6.6§3 seems to indicate that the dead branch can contain sub-expressions that are normally forbidden in a constant expression context, such as function calls. *) let is_true_cond = evaluate_cond_exp ce1 in if asconst && is_true_cond = `CTrue then begin match e2.expr_node with | A.NOTHING -> (match ce1 with | CEExp (_,e) -> finishExp [] empty e (Cil.typeOf e) | _ -> finishExp [] empty (Cil.one ~loc:e2.expr_loc) Cil.intType (* e1 is the result of logic operations that by definition of this branch evaluate to one. *)) | _ -> let _,_,e2,t2 = doExp local_env asconst e2 what' in finishExp [] empty e2 t2 end else if asconst && is_true_cond = `CFalse then begin let _,_,e3,t3 = doExp local_env asconst e3 what' in finishExp [] empty e3 t3 end else begin (* 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 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 isExpTrueFalse e1' = `CFalse && canDrop se2 -> finishExp r3 ((empty @@ (se1, ghost)) @@ (se3, ghost)) (snd (castTo t3 tresult e3')) tresult | CEExp (se1, e1') when isExpTrueFalse e1' = `CTrue && 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. *) (* dummy result, that will be ultimately be dropped *) let res = Cil.zero ~loc in (match e2'o with | None when is_dangerous e3' || not (isEmpty se3) -> let descr = Format.asprintf "%a" Cprint.print_expression e1 in let tmp = newTempVar descr 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 tresult | 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 tresult | 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 ce1 se2 se3 in finishExp (r2@r3) cond res tresult | 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 tresult) | _ -> (* Use a conditional *) begin match e2'o with | None -> (* has form "e1 ? : e3" *) let descr = Format.asprintf "%a" Cprint.print_expression e1 in let tmp = newTempVar descr 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 newWhat = ASet(false,tmp_var, [], tresult) in let r3,se3,_,_ = finishExp ~newWhat 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 descr = Format.asprintf "%a?%a:%a" Cprint.print_expression e1 Cil_descriptive_printer.pp_exp e2' Cil_descriptive_printer.pp_exp e3' in let tmp = newTempVar descr 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 ce1 se2 se3 in finishExp (r2@r3) (scope_chunk @@ (cond, ghost)) (new_exp ~loc (Lval lv)) tresult end 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 -> abort_context "Cannot find COMPUTATION in GNU.body" | Some (e, t) -> let se, e = match se.stmts with | [ { skind = Block b},_, _, _, _ ] -> let vi = newTempVar "GNU.body" true t in b.bstmts <- b.bstmts @ [Cil.mkStmtOneInstr ~ghost:local_env.is_ghost ~valid_sid (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 locally 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 _ -> abort_context "EXPR_PATTERN in cabs2cil input" 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 arithmetic *) 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 non-integer type %a" Cil_printer.pp_binop bop Cil_printer.pp_typ tres in (* Invariant: t1 and t2 are pointers types *) let pointerComparison e1 t1 e2 t2 = if false then Kernel.debug "%a %a %a %a" Cil_printer.pp_exp e1 Cil_printer.pp_typ t1 Cil_printer.pp_exp e2 Cil_printer.pp_typ t2; let t1p = Cil.(unrollType (typeOf_pointed t1)) in let t2p = Cil.(unrollType (typeOf_pointed t2)) in (* We are more lenient than the norm here (C99 6.5.8, 6.5.9), and cast arguments with incompatible types to a common type *) let e1', e2' = if not (areCompatibleTypes t1p t2p) then makeCastT e1 t1 Cil.voidPtrType, makeCastT e2 t2 Cil.voidPtrType 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 Cil.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 -> if areCompatibleTypes (* C99 6.5.6:3 *) (Cil.type_remove_qualifier_attributes t1) (Cil.type_remove_qualifier_attributes t2) then theMachine.ptrdiffType, optConstFoldBinOp loc false MinusPP e1 e2 theMachine.ptrdiffType else abort_context "incompatible types in pointer subtraction" (* Two special cases for comparisons with the NULL pointer. We are a bit more permissive. *) | (Le|Lt|Ge|Gt|Eq|Ne) when isPointerType t1 && isZero e2 -> pointerComparison e1 t1 (makeCast e2 t1) t1 | (Le|Lt|Ge|Gt|Eq|Ne) when isPointerType t2 && isZero e1 -> pointerComparison (makeCast e1 t2) t2 e2 t2 | (Le|Lt|Ge|Gt|Eq|Ne) when isPointerType t1 && isPointerType t2 -> pointerComparison e1 t1 e2 t2 | (Eq|Ne|Le|Lt|Ge|Gt) when (isPointerType t1 && isArithmeticType t2 || isArithmeticType t1 && isPointerType t2 ) -> Kernel.fatal ~current:true "comparison between pointer and non-pointer: %a" Cil_printer.pp_exp (dummy_exp(BinOp(bop,e1,e2,intType))) | _ -> 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 ci1})), _ -> (match isConstTrueFalse ci1 with | `CTrue -> addChunkBeforeCE se1 ce2 | `CFalse -> (* 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 ci1})), _ -> (match isConstTrueFalse ci1 with | `CFalse -> addChunkBeforeCE se1 ce2 | `CTrue -> (* 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, 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'); CEExp (add_reads ~ghost e.expr_loc r se, if asconst || theMachine.lowerConstants then constFold asconst e' else e') in result and compileCondExp ~ghost 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 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 ce1 st' sf') @@ gotostmt @@ sf2 @@ labstmt else let sf' = sf2 in compileCondExp ~ghost 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 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 ce1 st' sf') @@ gotostmt @@ st2 @@ labstmt else let st' = st1 in let sf' = compileCondExp ~ghost ce2 st2 sf in (*Format.eprintf "result:@\nchunk then:@\n @[%a@]@\nchunk else: @[%a@]@." d_chunk st d_chunk sf;*) compileCondExp ~ghost ce1 st' sf' | CENot ce1 -> compileCondExp ~ghost 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 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 = if isEmpty st && isEmpty sf(*TODO: ignore attribute FRAMA_C_KEEP_BLOCK*) then begin let (_, se,e,_) = doExp local_env false e ADrop in if is_dangerous e then begin let ghost = local_env.is_ghost in se @@ (keepPureExpr ~ghost e e.eloc, ghost) end else begin if (isEmpty se) then begin let name = !currentFunctionFDEC.svar.vorig_name in IgnorePureExpHook.apply (name, e) end; se end end else begin let ce = doCondExp local_env isconst e in let chunk = compileCondExp ~ghost:local_env.is_ghost ce st sf in chunk end 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 ~ghost:local_env.is_ghost 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), together with the lvals read during evaluation of * the initializer (for local intialization) *) : chunk * init * typ * Cil_datatype.Lval.Set.t = Kernel.debug ~dkey:category_initializer "@\nStarting a new initializer for %s : %a@\n" vi.vname Cil_printer.pp_typ vi.vtype; let acc, preinit, restl = let so = makeSubobj vi vi.vtype NoOffset in doInit local_env vi.vglob Extlib.nop NoInitPre 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 Kernel.debug ~dkey:category_initializer "Collecting the initializer for %s@\n" vi.vname; let (init, typ'', reads) = collectInitializer Cil_datatype.Lval.Set.empty preinit typ' typ' in Kernel.debug ~dkey:category_initializer "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'', reads (* Kept purely for compatibility with Jessie. *) 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 (* Consume some initializers. This is used by both global and local variables initialization. - local_env is the current environment - isconst is used to indicate that expressions must be compile-time constant (i.e. we are in a global initializer) - add_implicit_ensures is a callback to add an ensures clause to contracts above current initialized part when it is partially initialized. Does nothing initially. Useful only for initialization of locals - preinit corresponds to the initializers seen previously (for globals) - so contains the information about the current subobject currently being initialized - acc is the chunk corresponding to initializations seen previously (for locals) - initl is the current list of initializers to be processed doInit returns a triple: - chunk performing initialization - preinit corresponding to the complete initialization - the list of unused initializers if any (should be empty most of the time) *) and doInit local_env isconst add_implicit_ensures preinit so acc initl = let ghost = local_env.is_ghost in 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 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 ghost specs dt (A.COMPOUND_INIT ci) in let typ = doOnlyType 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 Kernel.debug ~dkey:category_initializer "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)]) ); match unrollType so.soTyp, allinitl with (* No more initializers return *) | _, [] -> acc, preinit, [] (* No more subobjects to initialize *) | _, (A.NEXT_INIT, _) :: _ when so.eof -> acc, preinit, 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)) || ((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', preinit', initl' = doInit local_env isconst add_implicit_ensures preinit 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 preinit' 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', preinit', initl' = doInit local_env isconst add_implicit_ensures preinit 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 preinit' 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 preinit so acc allinitl (* An incomplete structure with any initializer is an error. *) | TComp (comp, _, _), _ :: restil when not comp.cdefined -> Kernel.error ~current:true ~once:true "variable `%s' has initializer but incomplete type" so.host.vname; doInit local_env isconst add_implicit_ensures preinit so acc restil (* 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 r = Cil_datatype.Lval.Set.of_list r in if (match unrollType t' with | TComp (comp', _, _) when comp'.ckey = comp.ckey -> true | _ -> false) then begin (* Initialize the whole struct *) let preinit = setOneInit preinit so.soOff (SinglePre (oneinit', r)) in (* Advance to the next subobject *) advanceSubobj so; let se = acc @@ (se, ghost) in doInit local_env isconst add_implicit_ensures preinit 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 preinit 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 r = Cil_datatype.Lval.Set.of_list r in Kernel.debug ~dkey:category_initializer "oneinit'=%a, t'=%a, so.soTyp=%a" Cil_printer.pp_exp oneinit' Cil_printer.pp_typ t' Cil_printer.pp_typ so.soTyp; let init_expr = if theMachine.insertImplicitCasts then snd (castTo t' so.soTyp oneinit') else oneinit' in let preinit' = setOneInit preinit so.soOff (SinglePre (init_expr,r)) in (* Move on *) advanceSubobj so; let se = acc @@ (se,ghost) in doInit local_env isconst add_implicit_ensures preinit' 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 len = integerArrayLength leno in so'.stack <- [InArray(so'.curOff, bt, len, ref 0)]; normalSubobj so'; let acc', preinit', initl' = match initl with | [] -> (* we must actually indicate that there is some initializer, albeit empty, to our parent. This is in particular important if said parent is an array of indeterminate size, as the number of initializers of its children matters. *) let preinit' = setOneInit preinit so'.curOff (empty_preinit()) in (* zero initialization will be done anyway, no need to change the chunk.*) acc, preinit', [] | _ -> doInit local_env isconst add_implicit_ensures preinit 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 *) doInit local_env isconst add_implicit_ensures preinit' so acc' restil (* 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 preinit 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 preinit 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', preinit', initl' = match initl with | [] -> (* empty initializer, a GNU extension to indicate 0-initialization. We must indicate to our parent that we are here, though. *) let preinit' = setOneInit preinit so'.curOff (empty_preinit()) in acc, preinit', [] | _ -> doInit local_env isconst add_implicit_ensures preinit 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 preinit' 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 r = Cil_datatype.Lval.Set.of_list r in let init_expr = makeCastT oneinit' t' so.soTyp in let preinit' = setOneInit preinit so.soOff (SinglePre (init_expr, r)) in (* Move on *) advanceSubobj so; let se = acc @@ (se, ghost) in doInit local_env isconst add_implicit_ensures preinit' so se restil with Not_found -> abort_context "scalar value (of type %a) initialized by compound initializer" 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 ~ghost idxe'.eloc r doidx in match constFoldToInt idxe', isNotEmpty doidx with | Some x, false -> Integer.to_int x, doidx | _ -> abort_context "INDEX initialization designator is not a constant" in if nextidx' < 0 || nextidx' >= ilen then abort_context "INDEX designator is outside bounds"; so.stack <- InArray(so.soOff, bt, ilen, ref nextidx') :: so.stack; normalSubobj so; address whatnext (acc @@ (doidx, ghost)) | _ -> abort_context "INDEX designator for a non-array" end | A.ATINDEXRANGE_INIT _ -> abort_context "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 ~ghost idxs'.eloc rs doidxs in let doidxe = add_reads ~ghost idxe'.eloc re doidxe in if isNotEmpty doidxs || isNotEmpty doidxe then Kernel.fatal ~current:true "Range designators are not constants"; let first, last = match constFoldToInt idxs', constFoldToInt idxe' with | Some s, Some 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 preinit 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 preinit so acc' ((A.NEXT_INIT, ie) :: restil) in expandRange (fun x -> x) what | t, (_what, _ie) :: _ -> abort_context "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 = Kernel.debug ~dkey:category_global ~level:2 "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; end else if Extlib.has_some logic_spec then begin let emit,msg = if Kernel.ContinueOnAnnotError.get () then Kernel.warning, " (ignoring)." else Kernel.error, "." in emit ~current:true ~once:true "Global variable %s is not a function. It cannot have a contract%s" vi.vname msg end; let isadef = not (isFunctionType vi.vtype) && (inite != A.NO_INIT || (* tentative definition, but definition nevertheless. *) vi.vstorage = NoStorage || vi.vstorage = Static) in let vi, alreadyInEnv = makeGlobalVarinfo isadef 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 Cil.update_var_type vi 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; Kernel.debug ~dkey:category_global ~level:2 " 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; try 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 with LogicTypeError ((source,_),msg) -> Kernel.warning ~source "%s. Ignoring specification of function %s" msg vi.vname end ; vi with Not_found -> begin (* Not already defined *) Kernel.debug ~dkey:category_global ~level:2 " 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) && (vi.vstorage = NoStorage || vi.vstorage = Static) && 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 then begin if not vi.vdefined then setFormalsDecl vi vi.vtype; let spec = match logic_spec with | None -> empty_funspec () | Some (spec,loc) -> begin CurrentLoc.set loc; try (* it can not have old behavior names, since this is the first time we see the declaration. *) Ltyping.funspec [] vi None vi.vtype spec with LogicTypeError ((source,_),msg) -> Kernel.warning ~source "%s. Ignoring specification of function %s" msg vi.vname; empty_funspec () end in cabsPushGlobal (GFunDecl (spec, vi, CurrentLoc.get ())); end else cabsPushGlobal (GVarDecl (vi, CurrentLoc.get ())); vi end else begin Kernel.debug ~dkey:category_global ~level:2 " already in env %s" vi.vname; (match logic_spec with | None -> () | Some (spec,loc) -> CurrentLoc.set loc; let merge_spec = function | GFunDecl(old_spec, _, _) -> let behaviors = List.map (fun b -> b.b_name) old_spec.spec_behavior in let spec = try Ltyping.funspec behaviors vi None vi.vtype spec with LogicTypeError ((source,_),msg) -> Kernel.warning ~source "%s. Ignoring specification of function %s" msg vi.vname; empty_funspec () 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 (* 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) *) (* it can happen that the variable to be initialized appears in the auxiliary statements that contribute to its initialization (and thus are meant to occur before the corresponding Local_init statement. In that case, this function creates an auxiliary variable that is never defined as a placeholder. Note that in any case, if the execution attempts to evaluate the variable (either original or placeholder), the behavior is undefined. There are some cases where the evaluation will succeed, though, e.g. with size_t x = sizeof(x) > 6 ? sizeof(x): 6; *) and cleanup_autoreference vi chunk = let temp = ref None in let calls = ref [] in let extract_calls () = let res = !calls in calls := []; res in let vis = object(self) inherit Cil.nopCilVisitor method! vinst = function | Call _ | Local_init(_,ConsInit _,_) -> calls := ref (Extlib.the self#current_stmt) :: !calls; DoChildren | _ -> DoChildren method! vvrbl v = if Cil_datatype.Varinfo.equal v vi then begin match !temp with | Some v' -> ChangeTo v' | None -> let v' = newTempVar (vi.vname ^ " initialization") true vi.vtype in temp := Some v'; ChangeTo v' end else SkipChildren end in let transform_lvals l = List.map (visitCilLval vis) l in let treat_one (s, m, w, r, _) = let s' = visitCilStmt vis s in let m' = transform_lvals m in let w' = transform_lvals w in let r' = transform_lvals r in let c' = extract_calls () in (s', m', w', r', c') in let stmts = List.map treat_one chunk.stmts in match !temp with | None -> chunk | Some v -> local_var_chunk { chunk with stmts } v (* 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 -> Kernel.debug ~dkey:category_global ~level:2 "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. *) Cil.update_var_type vi (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 Cil.update_var_type vi et; if isNotEmpty se then Kernel.error ~once:true ~current:true "global static initializer"; (* Check that no locals are referred 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 (GFunDecl (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 *) if isvarsize then begin let free = vla_free_fun () in let destructor = AStr free.vname in let attr = Attr (frama_c_destructor, [destructor]) in vi.vdefined <- true; vi.vattr <- Cil.addAttribute attr vi.vattr; end; 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 allocation size *) let elt_size = new_exp ~loc (SizeOf (Cil.typeOf_pointed vi.vtype)) in let alloca_size = new_exp ~loc (BinOp(Mult, elt_size, new_exp ~loc (Lval (var savelen)), theMachine.typeOfSizeOf)) in (* Register the length *) IH.add varSizeArrays vi.vid alloca_size; (* 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 se0 = (* add an assertion to ensure the given size is correctly bound: assert alloca_bounds: 0 < elt_size * array_size <= max_bounds *) (se0 +++ ( let castloc = CurrentLoc.get () in let talloca_size = let telt_size = Logic_utils.expr_to_term ~cast:false elt_size in let tlen = Logic_utils.expr_to_term ~cast:false len in Logic_const.term (TBinOp (Mult,telt_size,tlen)) telt_size.term_type in let pos_size = let zero = Logic_const.tinteger ~loc:castloc 0 in Logic_const.prel ~loc:castloc (Rlt, zero, talloca_size) in let max_size = let szTo = Cil.bitsSizeOf theMachine.typeOfSizeOf in let max_bound = Logic_const.tint ~loc:castloc (Cil.max_unsigned_number szTo) in Logic_const.prel ~loc:castloc (Rle, talloca_size, max_bound) in let alloca_bounds = Logic_const.pand ~loc:castloc (pos_size, max_size) in let alloca_bounds = { alloca_bounds with pred_name = ["alloca_bounds"] } in let annot = Logic_const.new_code_annotation (AAssert ([], alloca_bounds)) in (mkStmtOneInstr ~ghost ~valid_sid (Code_annot (annot, castloc)), [],[],[]))) in let setlen = se0 +++ (mkStmtOneInstr ~ghost ~valid_sid (Set(var savelen, makeCast len savelen.vtype, CurrentLoc.get ())), [],[],[]) in (* Initialize the variable *) let alloca: varinfo = vla_alloc_fun () in if Kernel.DoCollapseCallCast.get () then (* do it in one step *) setlen +++ (mkStmtOneInstr ~ghost ~valid_sid (Local_init (vi, ConsInit(alloca,[ alloca_size ],Plain_func),loc)), [],[var vi],[]) else begin (* do it in two *) let rt, _, _, _ = splitFunctionType alloca.vtype in let tmp = newTempVar (Format.asprintf "alloca(%a)" Cil_printer.pp_exp alloca_size) false rt in tmp.vdefined <- true; (local_var_chunk setlen tmp) +++ (mkStmtOneInstr ~ghost ~valid_sid (Local_init (tmp,ConsInit(alloca,[alloca_size],Plain_func),loc)), [],[],[]) +++ (mkStmtOneInstr ~ghost ~valid_sid (Local_init (vi,AssignInit (SingleInit (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 (* TODO: if vi occurs in se4, this is not a real initialization. *) vi.vdefined <- true; let se4, ie', et, r = doInitializer (ghost_local_env ghost) vi inite in let se4 = cleanup_autoreference vi se4 in (* Fix the length *) (match vi.vtype, ie', et with (* We have a length now *) | TArray(_,None, _, _), _, TArray(_, Some _, _, _) -> Cil.update_var_type vi et (* Initializing a local array *) | TArray(TInt((IChar|IUChar|ISChar), _) as bt, None, l, a), SingleInit({enode = Const(CStr s);eloc=loc}), _ -> Cil.update_var_type vi (TArray(bt, Some (integer ~loc (String.length s + 1)), l, a)) | _, _, _ -> ()); (* Now create assignments instead of the initialization *) (se1 @@ (se4, ghost)) @@ (i2c (Cil.mkStmtOneInstr ~ghost ~valid_sid (Local_init(vi,AssignInit ie',loc)), [], [(Var vi,NoOffset)], Cil_datatype.Lval.Set.elements r), 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 -> abort_context "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 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 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 try let spec = Ltyping.code_annot loc' local_env.known_behaviors (Ctype !currentReturnType) (Logic_ptree.AStmtSpec ([],spec)) in append_chunk_to_annot ~ghost (s2c (mkStmtOneInstr ~ghost ~valid_sid (Code_annot (spec,loc')))) res with LogicTypeError ((source,_),msg) -> Kernel.warning ~source "%s. Ignoring code annotation" msg; res 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_stdlib_pragma s args >>? process_pack_pragma | _ -> (* 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 | 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 Kernel.debug ~dkey:category_global ~level:2 "Definition of %s at %a\n" n Cil_printer.pp_location idloc; CurrentLoc.set idloc; 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 ~temp: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; (* 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 := []; 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; *) Cil.update_var_type !currentFunctionFDEC.svar ftyp; !currentFunctionFDEC.svar.vattr <- funattr; !currentFunctionFDEC.svar.vstorage <- sto; 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 ~temp: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 (* in case of formals referred to in types of others, doType has put dummy varinfos. We need to fix them now that we have proper bindings. TODO: completely refactor the way formals' typechecking is done. *) let () = fixFormalsType formals 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 *) Cil.update_var_type !currentFunctionFDEC.svar 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 Cil.update_var_type a 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) -> CurrentLoc.set loc; (try !currentFunctionFDEC.sspec <- Ltyping.funspec behaviors !currentFunctionFDEC.svar (Some !currentFunctionFDEC.sformals) !currentFunctionFDEC.svar.vtype spec with LogicTypeError ((source,_),msg) -> Kernel.warning ~source "%s. Ignoring logic specification of function %s" msg !currentFunctionFDEC.svar.vname) | None -> () end; (* Merge pre-existing spec if needed. *) if has_decl then begin let merge_spec = function | GFunDecl(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 ~valid_sid (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 !currentFunctionFDEC.slocals <- (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 ~valid_sid (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 loc = endloc in let protect_return,retval = (* Guard the [return] instructions we add with an [\assert \false]*) let pfalse = Logic_const.unamed ~loc Pfalse in let pfalse = { pfalse with pred_name = ["missing_return"] } in let assert_false () = let annot = Logic_const.new_code_annotation (AAssert ([], pfalse)) in Cil.mkStmt ~ghost ~valid_sid (Instr(Code_annot(annot,loc))) in match unrollType !currentReturnType with | TVoid _ -> [], None | (TInt _ | TEnum _ | TFloat _ | TPtr _) as rt -> let res = Some (makeCastT (zero ~loc) 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 | rt -> (* 0 is not an admissible value for the return type. On the other hand, *( T* )0 is. We're not supposed to get there anyway. *) let null_ptr = makeCastT (zero ~loc) intType (TPtr(rt,[])) in let res = Some (new_exp ~loc (Lval (mkMem null_ptr NoOffset))) in Kernel.warning ~current:true "Body of function %s falls-through. \ Adding a return statement" !currentFunctionFDEC.svar.vname; [assert_false ()], res in if not (hasAttribute "noreturn" !currentFunctionFDEC.svar.vattr) then !currentFunctionFDEC.sbody.bstmts <- !currentFunctionFDEC.sbody.bstmts @ protect_return @ [mkStmt ~ghost ~valid_sid (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 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 abort_context "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; try let tdecl = Ltyping.annot decl in let attr = fc_stdlib_attribute [] in let tdecl = List.fold_left (Extlib.swap Logic_utils.add_attribute_glob_annot) tdecl attr in cabsPushGlobal (GAnnot(tdecl,CurrentLoc.get ())) with LogicTypeError ((source,_),msg) -> Kernel.warning ~source "%s. Ignoring global annotation" msg) decl; end; empty | A.CUSTOM (custom, name, location) when isglobal -> begin let loc = convLoc location in CurrentLoc.set loc; try let tcustom = Ltyping.custom custom in let attr = fc_stdlib_attribute [] in cabsPushGlobal (GAnnot(Dcustom_annot(tcustom, name, attr,loc),loc)) with LogicTypeError ((source,_),msg) -> Kernel.warning ~source "%s. Ignoring custom annotation" msg end; empty | A.CUSTOM _ | A.GLOBANNOT _ | A.PRAGMA _ | A.GLOBASM _ | A.FUNDEF _ -> Kernel.fatal ~current:true "this form of declaration must be global" and doTypedef ghost ((specs, nl): A.name_group) = (* 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") *) let newTyp, tattr = doType ghost false AttrType bt (A.PARENTYPE(attrs, ndt, a)) in checkTypedefSize n newTyp; let tattr = fc_stdlib_attribute tattr in let newTyp' = cabsTypeAddAttributes tattr newTyp in if H.mem typedefs n && H.mem env n then (* check if type redefinition is allowed (C11 only); in all cases, do not create a new type. TODO: if local typedef redefinitions are to be supported, then the new type must be created if the definition is syntactically valid. *) begin if !scopes <> [] then Kernel.failure ~current:true "redefinition of a typedef in a non-global scope is currently unsupported"; let typeinfo = H.find typedefs n in let _, oldloc = lookupType "type" n in if areCompatibleTypes typeinfo.ttype newTyp' then begin let error_conflicting_types () = Kernel.error ~current:true "redefinition of type '%s' in the same scope with conflicting type.@ \ Previous declaration was at %a" n Cil_datatype.Location.pretty oldloc in let error_c11_redefinition () = Kernel.error ~current:true "redefinition of type '%s' in the same scope is only allowed in C11 \ (option %s).@ Previous declaration was at %a" n Kernel.C11.name Cil_datatype.Location.pretty oldloc in (* Tested with GCC+Clang: redefinition of compatible types in same scope: - enums are NOT allowed; - composite types are allowed only if the composite type itself is not redefined (complex rules; with some extra tag checking performed in compatibleTypesp, we use tags here to detect redefinitions, which are invalid) - redefinition via a typedef of a struct/union/enum IS allowed; - other types are allowed. *) if declared_in_current_scope n then begin match newTyp' with (* do NOT unroll type here, redefinitions of typedefs are ok *) | TComp (newci, _, _) -> (* Composite types with different tags may be compatible, but here we use the tags to try and detect if the type is being redefined, which is NOT allowed. *) begin match unrollType typeinfo.ttype with | TComp (ci, _, _) -> if ci.cname <> newci.cname then (* different tags => we consider that the type is being redefined *) error_conflicting_types () else (* redeclaration in same scope valid only in C11 *) if not (Kernel.C11.get ()) then error_c11_redefinition () | _ -> (* because of the compatibility test, this should not happen *) Kernel.fatal ~current:true "typeinfo.ttype (%a) should be TComp" Cil_printer.pp_typ typeinfo.ttype end | TEnum _ -> (* GCC/Clang: "conflicting types" *) error_conflicting_types () | _ -> (* redeclaration in same scope valid only in C11 *) if not (Kernel.C11.get ()) then error_c11_redefinition () end end else if declared_in_current_scope n then Kernel.error ~current:true "redefinition of type '%s' in the same scope with incompatible type.@ \ Previous declaration was at %a" n Cil_datatype.Location.pretty oldloc; end else (* effectively create new type *) begin let n', _ = newAlphaName true "type" 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 ())) end in List.iter createTypedef nl and doOnlyTypedef ghost (specs: A.spec_elem list) : unit = 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" 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 ~valid_sid (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 occurrence 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.Integer.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.constFoldToInt i with | Some v -> known_idx := Datatype.Integer.Set.add v !known_idx | _ -> abort_context "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 ~valid_sid (Instr (Code_annot (code_annot,Errorloc.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. This is only needed for statement contracts and pragmas. Other (non-loop, as they have special treatment) annotations operate purely at current point and do not care about what happens to the next statement. *) let new_behaviors, keep_next = match s.stmt_node with | CODE_ANNOT(Logic_ptree.AStmtSpec (_,s),_) | CODE_SPEC (s,_) -> List.map (fun x -> x.Logic_ptree.b_name) s.Logic_ptree.spec_behavior, true | CODE_ANNOT(Logic_ptree.APragma _,_) -> [], 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 ~valid_sid (Block b)) in { res with cases = bodychunk.cases } end and doStatement local_env (s : A.statement) : chunk = let mk_loop_annot a loc = try List.map (Ltyping.code_annot loc local_env.known_behaviors (Ctype !currentReturnType)) a with LogicTypeError ((source,_),msg) -> Kernel.warning ~source "%s. Ignoring loop annotation" msg; [] in let ghost = s.stmt_ghost in let local_env = { local_env with is_ghost = ghost } in match s.stmt_node with | A.NOP loc -> { empty with stmts = [mkEmptyStmt ~ghost ~valid_sid ~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 ~valid_sid (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 local_env false e st' sf' | A.WHILE(a,e,s,loc) -> startLoop true; let a = mk_loop_annot a loc in 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 local_env false e skipChunk break_cond) @@ (s', ghost)) | A.DOWHILE(a, e,s,loc) -> startLoop false; let a = mk_loop_annot a loc in 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 into '' instead. Only active when -simplify-trivial-loops is set (default), as it impact plugins that compare the shape of the Cabs and of the Cil files. *) if Kernel.SimplifyTrivialLoops.get() && 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 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 (se3, _, _) = doFullExp local_env false e3 ADrop in startLoop false; let a = mk_loop_annot a loc in 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 local_env false e2 skipChunk break_cond) @@ (s', ghost)) @@ (s'', ghost)), ghost) in exitScope (); if has_decl then begin let chunk = s2c (mkStmt ~ghost ~valid_sid (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.error ~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.error ~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"; let chunk = caseRangeChunk ~ghost [if theMachine.lowerConstants then constFold false e' else e'] loc' (doStatement local_env s) in (* se has no statement, but can contain local variables, in particular in the case of a sizeof with side-effects. *) se @@ (chunk,ghost) | 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 constFoldToInt el', constFoldToInt eh' with | Some il, Some 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 (sel @@ (seh,ghost)) @@ (caseRangeChunk ~ghost (mkAll il) loc' (doStatement local_env s), ghost) | 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 ~valid_sid (Set (var switchv, makeCast e' intType, loc')), [],[],[]), ghost)) @@ (s2c(mkStmt ~ghost ~valid_sid (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 -> abort_context "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 ~valid_sid (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 ~valid_sid (Set (var switchv, makeCast e' intType, loc')),[],[],[]), ghost)) @@ (s2c switch, ghost) end end | A.DEFINITION d -> doDecl local_env false d | 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', ext_asm) = match details with | None -> let tmpls' = if Cil.msvcMode () then tmpls else let pattern = Str.regexp "%" in let escape = Str.global_replace pattern "%%" in List.map escape tmpls in (tmpls', None) | Some { aoutputs; ainputs; aclobbers; alabels} -> let asm_outputs = 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 if not (isEmpty se) then stmts := !stmts @@ (se, ghost); (id, c, lv)) aoutputs in (* Get the side-effects out of expressions *) let asm_inputs = List.map (fun (id, c, e) -> let (r, se, e', _) = doExp local_env false e (AExp None) in let se = add_reads ~ghost e'.eloc r se in if not (isEmpty se) then stmts := !stmts @@ (se, ghost); (id, c, e')) ainputs in let asm_clobbers = aclobbers in let asm_gotos = List.map (fun label -> let label = lookupLabel label in let gref = ref dummyStmt in addGoto label gref; gref) alabels in (tmpls, Some { asm_outputs; asm_inputs; asm_clobbers; asm_gotos }) in !stmts @@ (i2c(mkStmtOneInstr ~ghost:local_env.is_ghost ~valid_sid (Asm(attr', tmpls', ext_asm, loc')),[],[],[]), ghost) | THROW (e,loc) -> let loc' = convLoc loc in CurrentLoc.set loc'; (match e with | None -> s2c (mkStmt ~ghost ~valid_sid (Throw (None,loc'))) | Some e -> let se,e,t = doFullExp local_env false e (AExp None) in se @@ (s2c (mkStmt ~ghost ~valid_sid (Throw (Some (e,t),loc'))),ghost)) | TRY_CATCH(stry,l,loc) -> let loc' = convLoc loc in CurrentLoc.set loc'; let chunk_try = doStatement local_env stry in let type_one_catch (var,scatch) = enterScope(); let vi = match var with | None -> Catch_all | Some (t,(n,ndt,a,ldecl)) -> let spec = doSpecList ghost n t in let vi = makeVarInfoCabs ~ghost ~isformal:false ~isglobal:false ldecl spec (n,ndt,a) in addLocalToEnv n (EnvVar vi); !currentFunctionFDEC.slocals <- vi :: !currentFunctionFDEC.slocals; Catch_exn(vi,[]) in let chunk_catch = doStatement local_env scatch in exitScope(); (vi,c2block ~ghost chunk_catch) in let catches = List.map type_one_catch l in s2c (mkStmt ~ghost ~valid_sid (TryCatch(c2block ~ghost chunk_try,catches,loc'))) | 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 ~valid_sid (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 ~valid_sid (TryExcept (c2block ~ghost b',(il', e'), c2block ~ghost h', loc'))) | CODE_ANNOT (a, loc) -> let loc' = convLoc loc in begin try let typed_annot = Ltyping.code_annot loc' local_env.known_behaviors (Ctype !currentReturnType) a in s2c (mkStmtOneInstr ~ghost ~valid_sid (Code_annot (typed_annot,loc'))) with LogicTypeError ((source,_),msg) -> Kernel.warning ~source "%s. Ignoring code annotation" msg; BlockChunk.empty end | CODE_SPEC (a, loc) -> let loc' = convLoc loc in begin try let spec = Ltyping.code_annot loc' local_env.known_behaviors (Ctype !currentReturnType) (Logic_ptree.AStmtSpec ([],a)) in s2c (mkStmtOneInstr ~ghost ~valid_sid (Code_annot (spec,loc'))) with LogicTypeError ((source,_),msg) -> Kernel.warning ~source "%s. Ignoring code annotation" msg; BlockChunk.empty 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 let copy_spec (old_f,new_f) formals_map spec = let obj = object inherit Cil.genericCilVisitor (Cil.refresh_visit (Project.current())) method! vlogic_var_use lv = match lv.lv_origin with | None -> DoChildren | Some v -> if Cil_datatype.Varinfo.equal v old_f then ChangeTo (Cil.cvar_to_lvar new_f) else begin try let _,new_v = List.find (fun (x,_) -> Cil_datatype.Varinfo.equal v x) formals_map in ChangeTo (Cil.cvar_to_lvar new_v) with Not_found -> DoChildren end end in Cil.visitCilFunspec obj spec let split_extern_inline_def acc g = match g with | GFun ( { svar; sformals; sspec }, loc) when svar.vinline && svar.vstorage = NoStorage -> (* we have an inline definition, which is also an implicit external _declaration_ (see C11 6.7.4§7). Just rename its uses in the current translation unit, and leave a new, unrelated, external declaration for the link phase. If a spec exists, the external declaration will inherit it. *) let new_v = Cil_const.copy_with_new_vid svar in svar.vname <- svar.vname ^ "__fc_inline"; (* inline definition is restricted to this translation unit. *) svar.vstorage <- Static; let new_formals = List.map Cil_const.copy_with_new_vid sformals in Cil.unsafeSetFormalsDecl new_v new_formals; let formals_map = List.combine sformals new_formals in let new_spec = copy_spec (svar, new_v) formals_map sspec in GFunDecl (new_spec, new_v, loc) :: g :: acc | GFun ({ svar },_) when svar.vinline && svar.vstorage = Extern -> (* The definition is a real external definition. We may as well remove the inline specification. *) svar.vinline <- false; g :: acc | _ -> g::acc (* Translate a file *) let convFile (f : A.file) : Cil_types.file = (* remove parentheses from the Cabs *) let fname,dl = stripParenFile f in Errorloc.clear_errors(); (* Clean up the global types *) initGlobals(); startFile (); IH.clear noProtoFunctions; H.clear compInfoNameEnv; H.clear enumInfoNameEnv; IH.clear mustTurnIntoDef; H.clear alreadyDefined; H.clear staticLocals; H.clear typedefs; cleanup_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" ; Cil.Builtin_functions.iter_sorted (fun name def -> ignore (setupBuiltin name def)); 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 abort_context "doDecl returns non-empty statement for global"; in List.iter doOneGlobal dl; let globals = fileGlobals () in let globals = List.fold_left split_extern_inline_def [] globals in let globals = List.rev globals 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; cleanup_isomorphicStructs (); H.clear staticLocals; H.clear typedefs; H.clear env; H.clear genv; IH.clear callTempVars; H.clear alpha_renaming; constrExprId := 0; if false then Kernel.debug "Cabs2cil converted %d globals" !globalidx; (* We are done *) { fileName = fname; globals; globinit = None; globinitcalled = false; } (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_internals/typing/rmtmps.ml0000644000175000017500000006462013113745004023711 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 dkey = Kernel.register_category "parse:rmtmps" 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, _) -> info.treferenced <- false | GEnumTag (info, _) | GEnumTagDecl (info, _) -> Kernel.debug ~dkey "clearing mark: %a" Cil_printer.pp_global global; info.ereferenced <- false | GCompTag (info, _) | GCompTagDecl (info, _) -> info.creferenced <- false | GVar (vi, _, _) | GFunDecl (_, vi, _) | GVarDecl (vi, _) -> vi.vreferenced <- false | GFun ({svar = info} as func, _) -> info.vreferenced <- false; let clearMark local = 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 | GFunDecl (_,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}, _) | GFunDecl (_,{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 name, result, reason = match global with | GVar ({vstorage = Static} as v, _, _) when Cil.hasAttribute "FC_BUILTIN" v.vattr -> v.vname, true, "FC_BUILTIN attribute" | GVar ({vstorage = Static; vname}, _, _) -> vname, false, "static variable" | GVar (v,_,_) -> v.vname, true, "non-static variable" | GFun ({svar = v}, _) -> begin if hasExportingAttribute v then v.vname,true, "constructor or destructor function" else if v.vstorage = Static then v.vname, not !rmUnusedStatic, "static function" else if v.vinline && v.vstorage != Extern && (Cil.msvcMode () || !rmUnusedInlines) then v.vname, false, "inline function" else v.vname, true, "other function" end | GFunDecl(_,v,_) when hasAttribute "alias" v.vattr -> v.vname, true, "has GCC alias attribute" | GFunDecl(_,v,_) | GVarDecl(v,_) when hasAttribute "FC_BUILTIN" v.vattr -> v.vname, true, "has FC_BUILTIN attribute" | GAnnot _ -> "", true, "global annotation" | GType (t, _) when Cil.hasAttribute "FC_BUILTIN" (Cil.typeAttr t.ttype) -> t.tname, true, "has FC_BUILTIN attribute" | GCompTag (c,_) | GCompTagDecl (c,_) when Cil.hasAttribute "FC_BUILTIN" c.cattr -> c.cname, true, "has FC_BUILTIN attribute" | GEnumTag (e, _) | GEnumTagDecl (e,_) when Cil.hasAttribute "FC_BUILTIN" e.eattr -> e.ename, true, "has FC_BUILTIN attribute" | _ -> "", false, "neither function nor variable nor annotation" in Kernel.debug ~dkey "isExportedRoot %s -> %B, %s" name 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, _) | GFunDecl (_,varinfo, _) | GFun ({svar = varinfo}, _) -> if not (hasAttribute "FC_BUILTIN" varinfo.vattr) then varinfo.vreferenced <- true; DoChildren | GAnnot _ -> DoChildren | _ -> SkipChildren method! vstmt s = match s.skind with | TryCatch(_,c,_) -> List.iter (fun (decl,_) -> match decl with | Catch_exn(v,l) -> (* treat all variables declared in exn clause as used. *) ignore (self#vvrbl v); List.iter (fun (v,_) -> ignore (self#vvrbl v)) l | Catch_all -> ()) c; DoChildren | _ -> DoChildren method! vinst = function | Asm (_, tmpls, _, _) when Cil.msvcMode () -> (* If we have inline assembly on MSVC, we cannot tell which locals * are referenced. Keep them 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 | _ -> DoChildren method! vvrbl v = if not v.vreferenced then begin let name = v.vname in if v.vglob then Kernel.debug ~dkey "marking transitive use: global %s" name else Kernel.debug ~dkey "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 ~dkey "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 ~dkey "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 ~dkey "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 ~dkey "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 ~dkey "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, _, _) | GFunDecl (_,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_node 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 (v, _) | GFunDecl (_,v, _)-> v.vreferenced || 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 ~dkey "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 ~dkey "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-Phosphorus-20170501/src/kernel_internals/typing/rmtmps.mli0000644000175000017500000001307013113745007024056 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-Phosphorus-20170501/src/kernel_internals/typing/allocates.mli0000644000175000017500000000411713113745011024500 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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-Phosphorus-20170501/src/kernel_internals/typing/mergecil.ml0000644000175000017500000035547513113745011024167 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 open Logic_utils let dkey = Kernel.register_category "mergecil" 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 (* The default value has been changed to false after Boron to fix bts#524. But this behavior is very convenient to parse the Linux kernel. *) let mergeInlinesWithAlphaConvert () = mergeInlines && Kernel.AggressiveMerging.get () (* 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 compare: t -> t -> int 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 module Elts = 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 let compare (d1,x1) (d2,x2) = let res = compare d1 d2 in if res = 0 then H.compare x1 x2 else res end (* Find the representative for a node and compress the paths in the process *) module Heq = Hashtbl.Make (Elts) module Iter_sorted = FCMap.Make(Elts) 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 f t = let sorted = Heq.fold Iter_sorted.add t Iter_sorted.empty in Iter_sorted.iter f sorted (* 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 "mergecil: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 "mergecil: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 dkey = Kernel.register_category "mergecil:getNode" in let level = 2 in Kernel.debug ~dkey ~level "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 | _, _ -> ()); Kernel.debug ~dkey ~level " node already found"; find false res (* No path compression *) with Not_found -> begin let res = mkSelfNode eq syn fidx name data l in Kernel.debug ~dkey ~level " 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. No need to use ~dkey, this function is never called unless we are in proper debug mode. *) let dumpGraph what eq : unit = Kernel.debug "Equivalence graph for %s is:" what; iter_eq_table (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 Alpha.alphaTableData ref) H.t = H.create 57 (* Variables and * types *) let sAlpha : (string, location Alpha.alphaTableData ref) H.t = H.create 57 (* Structures and * unions have * the same name * space *) let eAlpha : (string, location Alpha.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 compare = compare let merge_synonym name = not (prefix "__anon" name) let output = Format.pp_print_string end) type volatile_kind = R | W let equal_volatile_kind v1 v2 = match v1, v2 with | R, R | W, W -> true | (R | W), _ -> false let compare_volatile_kind v1 v2 = match v1, v2 with | R, W -> 1 | R, R -> 0 | W, W -> 0 | W, R -> -1 let pretty_volatile_kind fmt v = let s = match v with | R -> "reads" | W -> "writes" in Format.pp_print_string fmt s module VolatileMerging = Merging (struct type t = identified_term * volatile_kind let hash_term it = Logic_utils.hash_term it.it_content let hash = function | ts,R -> 1 + 5 * hash_term ts | ts,W -> 2 + 5 * hash_term ts let equal (t1,v1) (t2,v2) = equal_volatile_kind v1 v2 && Logic_utils.is_same_identified_term t1 t2 let compare (t1,v1) (t2,v2) = let cmp = compare_volatile_kind v1 v2 in if cmp <> 0 then cmp else Logic_utils.compare_term t1.it_content t2.it_content let merge_synonym _ = true let output fmt (hs,kind) = Format.fprintf fmt "%a function for %a volatile location" pretty_volatile_kind kind Cil_printer.pp_identified_term hs 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 compare (s1,t1) (s2, t2) = let res = String.compare s1 s2 in if res = 0 then Cil_datatype.TypByName.compare t1 t2 else res 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 constFoldToInt e1, constFoldToInt e2 with | Some i, Some i' -> Integer.equal i i' | _ -> false let compare_int e1 e2 = match (constFold true e1), (constFold true e2) with | {enode = Const(CInt64(i, _, _))}, {enode = Const(CInt64(i', _, _))} -> Integer.compare i i' | e1,e2 -> Cil_datatype.Exp.compare e1 e2 (* not strictly accurate, but should do the trick anyway *) 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 compare_enum_item e1 e2 = let res = String.compare e1.einame e2.einame in if res = 0 then compare_int e1.eival e2.eival else res 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 (Alpha.newAlphaName aeAlpha e2.ename Cil_datatype.Location.unknown); false)) )) || e1.ename = e2.ename let compare e1 e2 = if is_anonymous_enum e1 then if is_anonymous_enum e2 then Extlib.list_compare compare_enum_item e1.eitems e2.eitems else -1 else if is_anonymous_enum e2 then 1 else String.compare 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 entries *) 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 Kernel.debug ~dkey "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 Kernel.debug ~dkey "Renaming spec of function %a" Cil_datatype.Varinfo.pretty vi_disc; Kernel.debug ~dkey "original spec is %a" Cil_printer.pp_funspec spec; try let res = Cil.visitCilFunspec alpha spec in Kernel.debug ~dkey "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 Kernel.debug ~dkey "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 () (* Ignores some attributes that are irrelevant for mergecil, e.g. fc_stdlib *) let drop_attributes_for_merge attrs = Cil.dropAttributes ["fc_stdlib"] attrs let equal_attributes_for_merge attrs1 attrs2 = Cil_datatype.Attributes.equal (drop_attributes_for_merge attrs1) (drop_attributes_for_merge attrs2) let logic_type_info_without_irrelevant_attributes lti = { lt_name = lti.lt_name; lt_params = lti.lt_params; lt_attr = drop_attributes_for_merge lti.lt_attr; lt_def = lti.lt_def } let rec global_annot_without_irrelevant_attributes ga = match ga with | Dvolatile(vi,rd,wr,attr,loc) -> Dvolatile(vi,rd,wr,drop_attributes_for_merge attr,loc) | Dcustom_annot (c,n,attr,loc) -> Dcustom_annot (c,n,drop_attributes_for_merge attr,loc) | Daxiomatic(n,l,attr,loc) -> Daxiomatic(n,List.map global_annot_without_irrelevant_attributes l, drop_attributes_for_merge attr,loc) | Dlemma (id,ax,labs,typs,st,attr,loc) -> Dlemma (id,ax,labs,typs,st,drop_attributes_for_merge attr,loc) | Dtype (lti,loc) -> Dtype (logic_type_info_without_irrelevant_attributes lti, loc) | Dfun_or_pred _ | Dtype_annot _ | Dmodel_annot _ | Dinvariant _ -> ga let rec global_annot_pass1 g = match g with | Dvolatile(hs,rvi,wvi,_,loc) -> CurrentLoc.set loc; let process_term_kind (t,k as id) = let node = VolatileMerging.getNode lvEq lvSyn !currentFidx id (id, g) (Some (loc, !currentFidx)) in let g = global_annot_without_irrelevant_attributes g in let g' = global_annot_without_irrelevant_attributes (snd node.ndata) in if not (Logic_utils.is_same_global_annotation g g') then Kernel.warning ~source:(fst loc) "Overlapping volatile specification: \ volatile location %a already associated to a %a function in \ annotation at loc %a. Ignoring new binding." Cil_printer.pp_identified_term t pretty_volatile_kind k Cil_printer.pp_location (fst (Extlib.the node.nloc)) in List.iter (fun x -> if Extlib.has_some rvi then process_term_kind (x,R); if Extlib.has_some wvi then process_term_kind (x,W)) hs | 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,attr,l) -> CurrentLoc.set l; ignore (PlainMerging.getNode llEq llSyn !currentFidx n (n,(is_ax,labs,typs,st,attr,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 machdep 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 Cil.gccMode () && 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 = Format.asprintf "different type constructors: %a vs. %a" Cil_printer.pp_typ oldt Cil_printer.pp_typ t in raise (Failure msg)) (* When comparing composite types for equality, we tolerate some differences related to packed/aligned attributes: if the offsets of each field are the same regardless of these attributes, we allow them to merge (arbitrarily choosing whether to keep or to drop such attributes). *) and equalModuloPackedAlign attrs1 attrs2 = let drop = Cil.dropAttributes ["packed"; "aligned"] in equal_attributes_for_merge (drop attrs1) (drop attrs2) (* Checks if fields [f1] and [f2] (contained in the composite types [typ_ci1] and [typ_ci2] respectively) are equal except for alignment-related attributes. Raises [Failure] if the fields are not equivalent. If [mustCheckOffsets] is true, then there is already a difference in the composite type, so each field must be checked. *) and checkFieldsEqualModuloPackedAlign ~mustCheckOffsets typ_ci1 typ_ci2 f1 f2 = if f1.fbitfield <> f2.fbitfield then raise (Failure "different bitfield info"); if mustCheckOffsets || not (equal_attributes_for_merge f1.fattr f2.fattr) then (* different attributes: check if the difference is only due to aligned/packed attributes, and if the offsets are the same, in which case the difference may be safely ignored *) begin try let offs1, width1 = Cil.bitsOffset typ_ci1 (Field (f1, NoOffset)) in let offs2, width2 = Cil.bitsOffset typ_ci2 (Field (f2, NoOffset)) in if not (equalModuloPackedAlign f1.fattr f2.fattr) || offs1 <> offs2 || width1 <> width2 then if mustCheckOffsets then let err = "incompatible attributes in composite types " ^ "and/or field " ^ f1.fname in raise (Failure err) else let err = "incompatible attributes for field " ^ f1.fname in raise (Failure err) with Not_found -> Kernel.fatal "field offset not found in table: %a or %a" Printer.pp_field f1 Printer.pp_field f2 end (* 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 (* must_check_offsets indicates that composite type attributes are different, which may impact field offsets *) let mustCheckOffsets = if equal_attributes_for_merge ci.cattr oldci.cattr then false else if equalModuloPackedAlign ci.cattr oldci.cattr then true else raise (Failure (let attrs = drop_attributes_for_merge ci.cattr in let oldattrs = drop_attributes_for_merge oldci.cattr in (* we do not use Cil_datatype.Attributes.pretty because it may not print some relevant attributes *) let pp_attrs = Pretty_utils.pp_list ~sep:", " Printer.pp_attribute in Format.asprintf "different/incompatible composite type attributes: \ [%a] vs [%a]" pp_attrs attrs pp_attrs oldattrs)) in let typ_ci = TComp(ci, {scache = Not_Computed}, []) in let typ_oldci = TComp(oldci, {scache = Not_Computed}, []) in List.iter2 (fun oldf f -> checkFieldsEqualModuloPackedAlign ~mustCheckOffsets typ_ci typ_oldci f oldf; (* Make sure the types are compatible *) (* Note: 6.2.7 §1 states that the names of the fields should be the same. We do not force this for now, but could do it. *) 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 = Format.asprintf "%a" Cil_printer.pp_global (GCompTag(oldci, Cil_datatype.Location.unknown)) in let fields = Format.asprintf "%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 -> Format.asprintf "Definitions of %s are not isomorphic. Reason follows:@\n@?%s" fullname_old reason | false, true -> Format.asprintf "%s and %s are not isomorphic. Reason follows:@\n@?%s" fullname_old fullname reason | true, false -> Format.asprintf "Definitions of %s are not isomorphic. \ Reason follows:@\n@?%s@\n@?%s@?%s" fullname_old reason fields_old fields | false, false -> Format.asprintf "%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 let oldinfo = logic_type_info_without_irrelevant_attributes oldinfo in let info = logic_type_info_without_irrelevant_attributes info 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 (* ignores irrelevant attributes such as __fc_stdlib *) 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 let ax = List.map global_annot_without_irrelevant_attributes ax in let oldax = List.map global_annot_without_irrelevant_attributes oldax 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,oldattr,oldloc)) = oldlnode.ndata in let oldfidx = oldlnode.nfidx in let (id,(ax,labs,typs,st,attr,loc)) = lnode.ndata in let fidx = lnode.nfidx in let oldattr = drop_attributes_for_merge oldattr in let attr = drop_attributes_for_merge attr in if Logic_utils.is_same_global_annotation (Dlemma (oldid,oldax,oldlabs,oldtyps,oldst,oldattr,oldloc)) (Dlemma (id,ax,labs,typs,st,attr,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, oldannot as oldnode) fidx (id, annot 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 oldannot = global_annot_without_irrelevant_attributes oldannot in let annot = global_annot_without_irrelevant_attributes annot in if Logic_utils.is_same_global_annotation oldannot annot then begin if oldfidx < fidx then lnode.nrep <- oldlnode.nrep else oldlnode.nrep <- lnode.nrep end else let (loc, kind) = oldid in Kernel.error ~current:true "invalid multiple volatile %a function for locations %a" pretty_volatile_kind kind Cil_printer.pp_identified_term loc 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 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 Kernel.debug ~dkey "Merging %s(%d) to %s(%d)" vi.vname vi.vid oldvi.vname oldvi.vid; (* 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 newrep.ndata.vdefined <- vi.vdefined || oldvi.vdefined; (* 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 typeHasAttribute "const" vi.vtype != typeHasAttribute "const" oldvi.vtype then begin Cil.update_var_type newrep.ndata (typeRemoveAttributes ["const"] newtype); end else Cil.update_var_type newrep.ndata newtype; (* clean up the storage. *) let newstorage = match oldvi.vstorage, vi.vstorage with | Static, (Static | Extern) -> Static | NoStorage, NoStorage -> NoStorage | NoStorage, Extern -> if oldvi.vdefined then NoStorage else Extern | Extern, NoStorage when vi.vdefined -> NoStorage | Extern, (Extern | NoStorage) -> Extern | _ -> Kernel.abort ~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 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) | GFunDecl (_, 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 (Alpha.newAlphaName aeAlpha 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 *) Cil.update_var_type oldi (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) -> Kernel.debug ~dkey "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 -> Kernel.debug ~level:2 ~dkey "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) -> Kernel.debug ~dkey "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 -> Kernel.debug ~level:2 ~dkey "Using logic function %s(%a)(%d)" li.l_var_info.lv_name pp_profiles li !currentFidx; DoChildren | Some(li',oldfidx) -> Kernel.debug ~level:2 ~dkey "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 -> Kernel.debug ~level:2 ~dkey "Using logic type %s(%d)" lt.lt_name !currentFidx; DoChildren | Some(lt',oldfidx) -> Kernel.debug ~dkey "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 -> Kernel.debug ~level:2 ~dkey "Using logic type %s(%d)" lt.lt_name !currentFidx; DoChildren | Some(lt',oldfidx) -> Kernel.debug ~dkey "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 -> Kernel.debug ~level:2 ~dkey "Using logic constructor %s(%d)" lc.ctor_name !currentFidx; DoChildren | Some(lc',oldfidx) -> Kernel.debug ~dkey "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 -> Kernel.debug ~dkey ~level:2 "Using logic constructor %s(%d)" lc.ctor_name !currentFidx; DoChildren | Some(lc',oldfidx) -> Kernel.debug ~dkey ~level:2 "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 -> Kernel.debug ~dkey "No renaming needed %s(%d)" ci.cname !currentFidx; DoChildren | Some (ci', oldfidx) -> Kernel.debug ~dkey "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,_,_) -> Kernel.debug ~dkey "%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) -> Kernel.debug ~dkey "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 | GFunDecl(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 [GFunDecl (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 -> if in_axiomatic then Kernel.abort ~current:true "nested axiomatics are not allowed in ACSL"; 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 begin mergePushGlobals [GAnnot (Dmodel_annot(mf',l),l)]; end; 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,rd,wr,attr,loc) -> let is_representative id = not (Extlib.has_some (VolatileMerging.findReplacement true lvEq !currentFidx id)) in let push_volatile l rd wr = match l with | [] -> () | _ -> let annot = Dvolatile(l,rd,wr,attr,loc) in mergePushGlobals (visitCilGlobal renameVisitor (GAnnot (annot,loc))) in CurrentLoc.set loc; (* check whether some volatile location clashes with a previous annotation. Warnings about that have been generated during pass 1 *) let check_one_location (no_drop, full_representative, only_reads, only_writes) v = (* if there's only one function, only full_representative list will be filled. If both are provided, we maintain three lists of volatile locations: - the ones which take both their reads and writes function from current annotation - the ones which only use rd - the ones which only use wr Additionally, we maintain a boolean flag indicating whether the annotation can be used as is (i.e. does not overlap with a preceding annotation. *) let reads = not (Extlib.has_some rd) || is_representative (v,R) in let writes = not (Extlib.has_some wr) || is_representative (v,W) in if reads then if writes then no_drop, v::full_representative, only_reads, only_writes else false, full_representative, v::only_reads, only_writes else if writes then false, full_representative, only_reads, v::only_writes else false, full_representative, only_reads, only_writes in let no_drop, full_representative, only_reads, only_writes = List.fold_left check_one_location (true,[],[],[]) vi in if no_drop then mergePushGlobals (visitCilGlobal renameVisitor g) else begin push_volatile full_representative rd wr; if Extlib.has_some rd then push_volatile only_reads rd None; if Extlib.has_some wr then push_volatile only_writes None wr end | Daxiomatic(n,l,_,loc) -> begin CurrentLoc.set loc; match PlainMerging.findReplacement true laEq !currentFidx n with None -> if in_axiomatic then Kernel.abort ~current:true "nested axiomatics are not allowed in ACSL"; 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) | Throw(_,_) -> 137 | TryCatch (b,l,_) -> 139 + 149*(stmtListSum b.bstmts) + 151 * (List.fold_left (fun acc (_,b) -> acc + stmtListSum b.bstmts) 0 l) 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, _ = Alpha.newAlphaName vtAlpha vi.vname (CurrentLoc.get ()) in let formals_decl = try Some (Cil.getFormalsDecl vi) with Not_found -> None in (* Remember the original name *) H.add originalVarNames newName vi.vname; Kernel.debug ~dkey "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; (match formals_decl with | Some formals -> Cil.unsafeSetFormalsDecl vi formals | None -> ()); 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 (vi, l) as g -> CurrentLoc.set l; incr currentDeclIdx; let vi' = processVarinfo vi l in if vi == vi' && not (H.mem emittedVarDecls vi'.vname) then begin H.add emittedVarDecls vi'.vname true; (* Remember that we emitted * it *) mergePushGlobals (visitCilGlobal renameVisitor g) end | GFunDecl (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 occurrence 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 Kernel.debug ~dkey "%s: %d -> %d" vi.vname fdec.svar.vid vi.vid; (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 [], false end in let defn_formals = try Some (Cil.getFormalsDecl fdec.svar) with Not_found -> None 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 mergeInlinesWithAlphaConvert = mergeInlinesWithAlphaConvert () in let printout = (* Temporarily turn of printing of lines *) let oldprintln = Cil_printer.state.Printer_api.line_directive_style in Cil_printer.state.Printer_api.line_directive_style <- 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 = Format.asprintf "%a" Cil_printer.pp_global g' in Cil_printer.state.Printer_api.line_directive_style <- 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 *) Cil.update_var_type fdec'.svar 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 (* restore old binding for vi, as we are about to drop the new definition and its formals. *) Cil_datatype.Varinfo.Hashtbl.remove formals_renaming vi; (* Restore the formals from the old definition. We always have Some l from getFormalsDecl in case of a defined function. *) Cil.setFormals fdec (Extlib.the defn_formals); (* 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, _ = Alpha.newAlphaName sAlpha 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, _ = Alpha.newAlphaName eAlpha 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,_ = Alpha.newAlphaName vtAlpha 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, _ = Alpha.newAlphaName vtAlpha 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(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 ~dkey "Merging global %a" Cil_printer.pp_global g; let rename v spec = try let alpha = Cil_datatype.Varinfo.Hashtbl.find formals_renaming v in ignore (visitCilFunspec alpha spec) with Not_found -> () in match g with | GFun(fdec,loc) -> (try Kernel.debug ~dkey "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 ~dkey "Found spec to merge %a" Cil_printer.pp_funspec s; rename fdec.svar s; Kernel.debug ~dkey "After renaming:@\n%a" Cil_printer.pp_funspec s) specs; Kernel.debug ~dkey "Merging with %a" Cil_printer.pp_funspec fdec.sspec ; Cil.CurrentLoc.set loc; rename fdec.svar fdec.sspec; merge_specs fdec.sspec specs with Not_found -> Kernel.debug ~dkey "No spec_to_merge"; rename fdec.svar fdec.sspec) | GFunDecl(spec,v,loc) -> Kernel.debug ~dkey "Merging global declaration %a" Cil_printer.pp_global g; (try let specs = Cil_datatype.Varinfo.Hashtbl.find spec_to_merge v in List.iter (fun s -> Kernel.debug ~dkey "Found spec to merge %a" Cil_printer.pp_funspec s) specs; Kernel.debug ~dkey "Renaming %a" Cil_printer.pp_funspec spec ; rename v spec; (* The registered specs might also need renaming up to definition's formals instead of declaration's ones. *) List.iter (rename v) specs; Kernel.debug ~dkey "Renamed to %a" Cil_printer.pp_funspec spec; Cil.CurrentLoc.set loc; merge_specs spec specs; Kernel.debug ~dkey "Merged into %a" Cil_printer.pp_funspec spec ; with Not_found -> Kernel.debug ~dkey "No spec_to_merge for declaration" ; rename v spec; Kernel.debug ~dkey "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 | GFunDecl (_,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 (GFunDecl(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 GFunDecl(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 (); Errorloc.clear_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 false 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; if Errorloc.had_errors () then Kernel.abort "error encountered during linking@." ; res (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_internals/typing/allocates.ml0000644000175000017500000000567013113745005024337 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 behavior = Cil.default_behavior_name in let all_default _ alloc r = r && alloc = FreeAllocAny in let all_default = Annotations.fold_allocates all_default kf behavior true in if all_default then Annotations.add_allocates Emitter.kernel kf ~behavior (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-Phosphorus-20170501/src/kernel_internals/typing/frontc.ml0000644000175000017500000001070413113745004023654 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). *) (****************************************************************************) (* Signal that we are in MS VC mode *) (* BY: never called *) let setMSVCMode () = Cprint.msvcMode := true let parse_to_cabs (fname : string) = try Kernel.feedback ~level:2 "Parsing %s" fname ; Errorloc.clear_errors () ; let lexbuf = Clexer.init fname in let cabs = Cparser.file Clexer.initial lexbuf in (* Cprint.print_defs cabs;*) Clexer.finish (); if Errorloc.had_errors () then begin Kernel.debug "There were parsing errors in %s" fname ; raise Parsing.Parse_error end; (fname, cabs) with | Sys_error msg -> Clexer.finish () ; Kernel.abort "Cannot open %s : %s" fname msg ; | Parsing.Parse_error -> Clexer.finish (); raise Parsing.Parse_error ; 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 (* 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 cil,cabs frama-c-Phosphorus-20170501/src/kernel_internals/typing/unroll_loops.ml0000644000175000017500000006375713113745001025125 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 Visitor let dkey = Kernel.register_category "ulevel" type loop_pragmas_info = { unroll_number: int option; total_unroll: Emitter.t option; ignore_unroll: bool } let empty_info = { unroll_number = None; total_unroll = None; ignore_unroll = false } let update_info global_find_init emitter info spec = match spec with | {term_type=typ} when Logic_typing.is_integral_type typ -> if Extlib.has_some info.unroll_number && not info.ignore_unroll then begin Kernel.warning ~once:true ~current:true "ignoring unrolling directive (directive already defined)"; info end else begin try begin let t = Cil.visitCilTerm (new Logic_utils.simplify_const_lval global_find_init) spec in let i = Logic_utils.constFoldTermToInt t in match i with | Some i -> { info with unroll_number = Some (Integer.to_int i) } | None -> Kernel.warning ~once:true ~current:true "ignoring unrolling directive (not an understood constant \ expression)"; info end with Invalid_argument s -> Kernel.warning ~once:true ~current:true "ignoring unrolling directive (%s)" s; info end | {term_node=TConst (LStr "done") } -> { info with ignore_unroll = true } | {term_node=TConst (LStr "completely") } -> if Extlib.has_some info.total_unroll then begin Kernel.warning ~once:true ~current:true "found two total unroll pragmas"; info end else { info with total_unroll = Some emitter } | _ -> Kernel.warning ~once:true ~current:true "ignoring invalid unrolling directive"; info let extract_from_pragmas global_find_init s = let filter _ a = Logic_utils.is_loop_pragma a in let pragmas = Annotations.code_annot_emitter ~filter s in let get_infos info (a,e) = match a.annot_content with | APragma (Loop_pragma (Unroll_specs specs)) -> List.fold_left (update_info global_find_init e) info specs | APragma (Loop_pragma _) -> info | _ -> assert false (* should have been filtered above. *) in List.fold_left get_infos empty_info 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 (* [VP] I fail too see the purpose of this argument instead of changing the counter at each variable's copy: copy_var () is called once per copy of block with local variables, bearing no relationship with the number of unrolling. counter could thus be an arbitrary integer as well. *) 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 old_var new_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 fun b -> ignore (Visitor.visitFramacBlock visit b) (* 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! 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 (break_continue_must_change, 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 been 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 filter_annotation a = (* Special cases for some "breaks" and "continues" clauses. *) (* Note: it would be preferable to do that job in the visitor of 'fresh_annotation'... *) Kernel.debug ~dkey "Copying an annotation to stmt %d from stmt %d@." stmt_dst.sid stmt_src.sid; (* TODO: transforms 'breaks' and 'continues' clauses into unimplemented 'gotos' clause (still undefined clause into ACSL!). *) (* WORKS AROUND: since 'breaks' and 'continues' clauses have not be preserved into the unrolled stmts, and are not yet transformed into 'gotos' (see. TODO), they are not copied. *) match break_continue_must_change, a with | (None, None), _ -> Some a (* 'breaks' and 'continues' can be kept *) | _, { annot_content=AStmtSpec (s,spec) } -> let filter_post_cond = function | Breaks, _ when (fst break_continue_must_change) != None -> Kernel.debug ~dkey "Uncopied 'breaks' clause to stmt %d@." stmt_dst.sid; false | Continues, _ when (snd break_continue_must_change) != None -> Kernel.debug ~dkey "Uncopied 'continues' clause to stmt %d@." stmt_dst.sid; false | _ -> true in let filter_behavior acc bhv = let bhv = { bhv with b_post_cond = List.filter filter_post_cond bhv.b_post_cond } in (* The default behavior cannot be removed if another behavior remains... *) if (Cil.is_empty_behavior bhv) && not (Cil.is_default_behavior bhv) then acc else bhv::acc in let filter_behaviors bhvs = (*... so the default behavior is removed there if it is alone. *) match List.fold_left filter_behavior [] bhvs with | [bhv] when Cil.is_empty_behavior bhv -> [] | bhvs -> List.rev bhvs in let spec = { spec with spec_behavior = filter_behaviors spec.spec_behavior } in if Cil.is_empty_funspec spec then None (* No statement contract will be added *) else Some { a with annot_content=AStmtSpec (s,spec) } | _, _ -> Some a in let new_annots = Annotations.fold_code_annot (fun emitter annot acc -> match filter_annotation annot with | None -> acc | Some filtred_annot -> (emitter, fresh_annotation filtred_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 [] (* for copying the annotations later. *) and labelled_stmt_tbl = Cil_datatype.Stmt.Map.empty and calls_tbl = Cil_datatype.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 = Cil_datatype.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 _ | Local_init(_,ConsInit _,_)) -> Cil_datatype.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 := (break_continue_must_change, 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 _ | Throw _) 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, 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 (Cil_datatype.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 (* kept *) | (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 (* kept *) | _,(Some (continue_lbl_stmt)) -> Goto ((ref continue_lbl_stmt),loc)), labelled_stmt_tbl, calls_tbl | Switch (e,block,stmts,loc) -> (* from now on break only can be kept *) let new_block,new_labelled_stmt_tbl,calls_tbl = copy_block (None, (snd break_continue_must_change)) labelled_stmt_tbl calls_tbl block in let stmts' = List.map (fun s -> Cil_datatype.Stmt.Map.find s new_labelled_stmt_tbl) stmts in Switch(e,new_block,stmts',loc),new_labelled_stmt_tbl,calls_tbl | TryCatch(t,c,loc) -> let t', labs, calls = copy_block break_continue_must_change labelled_stmt_tbl calls_tbl t in let treat_one_extra_binding mv mv' (bindings, labs, calls) (v,b) = let v' = copy_var () v in assoc := (v,v')::!assoc; let b', labs', calls' = copy_block break_continue_must_change labs calls b in refresh_vars [mv; v] [mv'; v'] b'; (v',b')::bindings, labs', calls' in let treat_one_catch (catches, labs, calls) (v,b) = let v', vorig, vnew, labs', calls' = match v with | Catch_all -> Catch_all, [], [], labs, calls | Catch_exn(v,l) -> let v' = copy_var () v in assoc:=(v,v')::!assoc; let l', labs', calls' = List.fold_left (treat_one_extra_binding v v') ([],labs, calls) l in Catch_exn(v', List.rev l'), [v], [v'], labs', calls' in let (b', labs', calls') = copy_block break_continue_must_change labs' calls' b in refresh_vars vorig vnew b'; (v', b')::catches, labs', calls' in let c', labs', calls' = List.fold_left treat_one_catch ([],labs, calls) c in TryCatch(t',List.rev c',loc), labs', calls' | 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 new_stmts) in refresh_vars bl.blocals new_locals new_block; 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 let ast_has_changed = ref false (* Update to take into account annotations*) class do_it global_find_init ((force:bool),(times:int)) = object(self) inherit Visitor.frama_c_inplace initializer ast_has_changed := false; (* 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 begin 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; File.must_recompute_cfg id; ast_has_changed:=true end; 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 infos = extract_from_pragmas global_find_init s in let number = Extlib.opt_conv times infos.unroll_number in let total_unrolling = infos.total_unroll in let is_ignored_unrolling = not force && infos.ignore_unroll 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. *) (* Note: a goto from outside a loop to inside that loop will still goes into the remaining loop. *) (* 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),(Some !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 = (* Adds "loop invariant \false;" to the remaining loop when "completely" unrolled. *) (* Note: since a goto from outside the loop to inside the loop still goes into the remaining loop...*) match total_unrolling with | None -> new_stmts | Some emitter -> 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 h sloop new_stmts = (* To indicate that the unrolling has been done *) let specs = Unroll_specs [(Logic_const.term (TConst (LStr "done")) (Ctype Cil.charPtrType)) ; Logic_const.tinteger number ] in let annot = Logic_const.new_code_annotation (APragma (Loop_pragma specs)) in Annotations.add_code_annot Emitter.end_user ~kf:(Extlib.the self#current_kf) sloop annot; new_stmts in let fgh sloop = h sloop (g sloop (f sloop)) in let fgh = if (number > 0) && not is_ignored_unrolling then fgh else (fun s -> s) in ChangeDoChildrenPost (s, fgh) | _ -> DoChildren end (* Performs unrolling transformation without using -ulevel option. Do not forget to apply [transformations_closure] afterwards. *) let apply_transformation ?(force=true) nb file = (* [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 global_find_init vi = try (Globals.Vars.find vi).init with Not_found -> None in let visitor = new do_it global_find_init (force, nb) in Kernel.debug ~dkey "Using -ulevel %d option and UNROLL loop pragmas@." nb; visitFramacFileSameGlobals (visitor:>Visitor.frama_c_visitor) file; if !ast_has_changed then Ast.mark_as_changed () else begin Kernel.debug ~dkey "No unrolling is done; all UNROLL loop pragmas are ignored@." end (* Performs and closes all syntactic transformations *) let compute file = let nb = Kernel.UnrollingLevel.get () in let force = Kernel.UnrollingForce.get () in apply_transformation ~force nb file let unroll_transform = File.register_code_transformation_category "loop unrolling" let () = File.add_code_transformation_after_cleanup ~deps:[(module Kernel.UnrollingLevel:Parameter_sig.S); (module Kernel.UnrollingForce:Parameter_sig.S)] unroll_transform compute (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_internals/typing/mergecil.mli0000644000175000017500000001215413113745011024320 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-Phosphorus-20170501/src/kernel_internals/typing/oneret.mli0000644000175000017500000001225413113745006024032 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-Phosphorus-20170501/src/kernel_internals/typing/infer_annotations.ml0000644000175000017500000002357113113745007026112 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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; Emitter.Property_status] [] [] 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 args of type pointer to pointer *) let pointer_args = List.filter (fun vi -> not (isPointerType (typeOf_pointed vi.vtype))) pointer_args in (* Convert void* pointers to char* *) let pointer_args = List.map (fun vi -> let loc = vi.vdecl in let t = tvar (cvar_to_lvar vi) in let typ = vi.vtype in if Cil.isVoidPtrType typ then let const = typeHasAttribute "const" (Cil.typeOf_pointed typ) in let typ' = if const then Cil.charConstPtrType else Cil.charPtrType in (Logic_utils.mk_cast ~loc typ' t, typ') else (t, typ) ) pointer_args in (* Generate the term [*(t+(0..))] with the appropriate array bounds (if they are known), and possibly add some [[..]] if v has points to one or more arrays *) let mk_star (t, typ) = let loc = t.term_loc in let zero = Logic_const.tinteger ~loc 0 in (* Range [0..length-1], or [0..] if length is not known *) let make_range length = match length with | None -> Logic_const.trange ~loc (Some zero, None) | Some length -> let high = Logic_const.tint ~loc (Integer.pred length) in Logic_const.trange ~loc (Some zero, Some high) in (* Generate the required numbers of [[..]] until with find a non-array type *) let rec mk_offset set typ = match Cil.unrollType typ with | TArray (typ_elem, size, _, _) -> let range = match size with | None -> make_range None | Some size -> make_range (Cil.constFoldToInt size) in let offs, typ = mk_offset true typ_elem in TIndex (range, offs), typ | _ -> TNoOffset, (if set then make_set_type (Ctype typ) else (Ctype typ)) in (* make_set_type (Ctype typ_pointed) *) let typ_pointed = Cil.typeOf_pointed typ in (* Generate the initial term: [*(t+(0..))] for array types or char* pointers, *t for other pointer types. It would have been better to recognize formals with type [typ[]] instead of [typ *], but this information is lost during normalization *) let t_range_node, set = match findAttribute "arraylen" (typeAttr typ) with | [AInt length] -> TBinOp (PlusPI, t, make_range (Some length)), true | _ -> if Cil.isCharPtrType typ then TBinOp (PlusPI, t, make_range None), true else t.term_node, false in let offset_arrays, typ_with_offset = mk_offset true typ_pointed in let t_range = Logic_const.term ~loc t_range_node (if set then make_set_type (Ctype typ) else Ctype typ) in Logic_const.new_identified_term (term ~loc (TLval (TMem t_range, offset_arrays)) typ_with_offset) in let to_assign = List.map mk_star (List.filter (fun (_t, typ) -> let pointed_type = typeOf_pointed typ in not (typeHasAttribute "const" pointed_type) ) pointer_args) in let pointer_args_content = List.map mk_star 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 let result = Logic_const.(new_identified_term (tresult ~loc rtyp)) in (result, From inputs):: arguments let is_frama_c_builtin name = Ast_info.is_frama_c_builtin name (* Put an 'Unknown' status on all 'assigns' and 'from' clauses that we generate. *) let emit_unknown_status_on_assigns kf bhv assigns = let emit ip = Property_status.emit emitter [] ip Property_status.Dont_know in let pptopt = Property.ip_of_assigns kf Kglobal (Property.Id_contract (Datatype.String.Set.empty,bhv)) assigns in Extlib.may emit pptopt; match assigns with | WritesAny -> () | Writes froms -> let emit from = let pptopt = Property.ip_of_from kf Kglobal (Property.Id_contract (Datatype.String.Set.empty,bhv)) from in Extlib.may emit pptopt in List.iter emit froms module Is_populated = State_builder.Hashtbl (Kernel_function.Hashtbl) (Datatype.Unit) (struct let size = 17 let dependencies = [ Annotations.funspec_state ] let name = "Infer_annotations.Is_populated" end) let () = Ast.add_linked_state Is_populated.self let populate_funspec_aux kf spec = 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 ~current: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 ]; emit_unknown_status_on_assigns kf bhv assigns | _ :: _ -> (* 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 unguarded 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 ~current: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 ~behavior:bhv.b_name assigns; emit_unknown_status_on_assigns kf bhv assigns let populate_funspec kf spec = if Is_populated.mem kf then false (* No need to add the spec again *) else ( Is_populated.add kf (); populate_funspec_aux kf spec; true ) let () = Annotations.populate_spec_ref := populate_funspec (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_internals/typing/unroll_loops.mli0000644000175000017500000000361313113745002025260 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. Uses code transformation hook mechanism (after-cleanup phase) of {!File} and exports nothing. Name of the transformation is "loop unrolling" *) val unroll_transform: File.code_transformation_category (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_internals/typing/cfg.ml0000644000175000017500000007455013113745012023130 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 (* All the nodes of the function visited, in a flat list *) let nodeList : stmt list ref = ref [] 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 (* we might need to add a Skip statement at the end of a block in order to avoid that a break close too many blocks, in particular when one of such blocks is the scope of a VLA. *) type cfg_env = { parent_block: block; (* either the main function block or the innermost block containing a VLA.*) is_last: bool list; (* is the current statement the last of the block? we actually keep a stack indicating, for each block containing the VLA, if the statement is the last of that block. *) } let init_env parent_block = { parent_block; is_last = [false] } let is_last env = List.fold_left (&&) true env.is_last let innermost_last env = match env.is_last with | [] -> assert false (* we always have at least one element. *) | _ :: tl -> { env with is_last = true :: tl } let innermost_nonlast env = match env.is_last with | [] -> assert false (* we always have at least one element. *) | _ :: tl -> { env with is_last = false :: tl } let update_env env block = if List.exists (fun v -> Cil.hasAttribute Cabs2cil.frama_c_destructor v.vattr) block.blocals then init_env block else { env with is_last = false :: env.is_last } let requires_new_stmt env = is_last env && List.exists (fun v -> Cil.hasAttribute Cabs2cil.frama_c_destructor v.vattr) env.parent_block.blocals let make_break_stmt loc env next = if requires_new_stmt env then Some (Cil.mkStmtOneInstr ~valid_sid:false (Skip loc)) else next (** Compute a control flow graph for fd. All the stmts in fd have their preds and succs fields filled in. The summary fields of fundec are also filled. *) let rec cfgFun (fd : fundec) = nodeList := []; cfgBlock (init_env fd.sbody) fd.sbody None None None; fd.smaxstmtid <- Some(Cil.Sid.next ()); fd.sallstmts <- List.rev !nodeList; nodeList := [] (* 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 [] *) and cfgStmts env (ss: stmt list) next break cont = match ss with [] -> (); | [s] -> cfgStmt (innermost_last env) s next break cont | hd::tl -> cfgStmt env hd (Some (List.hd tl)) break cont; cfgStmts env tl next break cont (* 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. *) and cfgBlock env (blk: block) next break cont = cfgStmts (update_env env blk) 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 env (s: stmt) next break cont = if s.sid = -1 then s.sid <- Cil.Sid.next (); nodeList := s :: !nodeList; 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) = s.succs <- n::s.succs; (* We might have duplicate in succs here. This is important to preserve the invariant that If has exactly two successors (in case of [if(e);L:...], both branches will have [L:] as successor). *) 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 cfgCatch env c next break cont = match c with | Catch_all -> () | Catch_exn(_,l) -> let cfg_aux_clause (_,b) = cfgBlock env b next break cont in List.iter cfg_aux_clause l in let add_stmt_if_needed env s = if requires_new_stmt env then begin match s with | None -> assert false (* we have explicitly created a statement as target of break *) | Some stmt -> match stmt.preds with | [] -> () | _ -> (* we have used this statement as target of a break. Let's add it properly in the block. *) env.parent_block.bstmts <- env.parent_block.bstmts @ [ stmt ]; cfgStmt env stmt next break cont end 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 (typeHasAttribute "noreturn" (typeOf f)) | _ -> true in match s.skind with Instr il -> if instrFallsThrough il then addOptionSucc next else () | Return _ | Throw _ -> () | Goto (p,_) -> addSucc !p | Break _ -> addOptionSucc break | Continue _ -> addOptionSucc cont | If (_, blk1, blk2, _) -> (* The succs of If is [true branch;false branch]. Do the 'else' block first. *) addBlockSucc blk2; addBlockSucc blk1; cfgBlock env blk1 next break cont; cfgBlock env blk2 next break cont | UnspecifiedSequence seq -> addBlockSucc (block_from_unspecified_sequence seq); cfgBlock env (block_from_unspecified_sequence seq) next break cont | Block b -> addBlockSucc b; cfgBlock env b next break cont | Switch(_,blk,_l,loc) -> let break = make_break_stmt loc env next in let bl = findCaseLabeledStmts blk in (* 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; (* Then add cases, that will come first in final 'succs' list. bl is already reversed, so the order is ok. *) List.iter addSucc bl; (* we are ready to add a statement when needed. Hence we're not the last statement of a block with VLA scope. *) cfgBlock (innermost_nonlast env) blk next break cont; add_stmt_if_needed env break; | Loop(_,blk,loc,_,_) -> let break = make_break_stmt loc env next in addBlockSuccFull s blk; (* see above. *) cfgBlock (innermost_nonlast env) blk (Some s) break (Some s); add_stmt_if_needed env break (* Since all loops have terminating condition true, we don't put any direct successor to stmt following the loop *) | TryCatch(t,c,_) -> (* we enter the try block, and perform cfg in all the catch blocks, but there's no edge leading to a catch-block. This has to be taken into account by inter-procedural analyses directly, even if there is a throw directly in the function. See cil_types.mli for more information. *) addBlockSucc t; cfgBlock env t next break cont; (* If there are some auxiliary types caught by the clause, the cfg goes from the conversion block to the main block of the catch clause *) List.iter (fun (c,b) -> let n = match b.bstmts with | [] -> next | s::_ -> Some s in cfgCatch env c n break cont; cfgBlock env b next break cont) c; | 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) 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 | _ -> ()) (* 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 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 _ | AExtended _ -> Logic_const.ptrue | AStmtSpec (_bhv,s) -> let open Logic_const in List.fold_left (fun acc bhv -> pand (acc, pimplies (pands (List.map (fun p -> pold ~loc:p.ip_content.pred_loc (Logic_const.pred_of_id_pred p)) bhv.b_assumes), pands (List.fold_left (fun acc (kind,p) -> if f kind then Logic_const.pred_of_id_pred 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 _ | Throw _ -> 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 Logic_const.ptrue in Stack.iter (fun p -> assertion := Logic_const.pand (p,!assertion)) breaks; (match !assertion with { pred_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 Logic_const.ptrue in Stack.iter (fun p -> assertion := Logic_const.pand(p,!assertion)) continues; (match !assertion with { pred_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 b.bstmts <- cont_stmt :: b.bstmts ; let my_break_dest () = ref break_stmt in let use_continue = ref false in let my_cont_dest () = use_continue := true; 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 if !use_continue then cont_stmt.labels <- [Label (freshLabel (Printf.sprintf "while_%d_continue" label_index),l,false)] ; 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 | TryCatch (t,c,l) -> let t' = xform_switch_block t break_dest cont_dest label_index in let c' = List.map (fun (e,b) -> (e, xform_switch_block b break_dest cont_dest label_index)) c in s.skind <- TryCatch(t',c',l); popn popstack; 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 name () | _ -> ()) labels; DoChildren end method! vexpr _ = SkipChildren method! vtype _ = SkipChildren method! vinst _ = SkipChildren method! vcode_annot _ = SkipChildren (* via Loop stmt *) method! vlval _ = SkipChildren (* via UnspecifiedSequence stmt *) method! vattr _ = SkipChildren (* via block stmt *) 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 (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_internals/typing/frontc.mli0000644000175000017500000000724313113745013024031 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 (** add a syntactic transformation that will be applied to all freshly parsed C files. @plugin development guide *) 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-Phosphorus-20170501/src/kernel_internals/typing/translate_lightweight.mli0000644000175000017500000000416713113745002027132 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* 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). *) (* *) (**************************************************************************) (** Annotate files interpreting lightweight annotations. *) (** Code transformation that interprets __declspec annotations. Done after cleanup (see {! File.add_code_transformation_after_cleanup}). Name of the transformation is "lightweight spec" *) val lightweight_transform: File.code_transformation_category (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_internals/typing/alpha.mli0000644000175000017500000001330413113745007023621 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 -> 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 -> 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-Phosphorus-20170501/src/kernel_internals/typing/asm_contracts.mli0000644000175000017500000000370513113745011025373 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** Code transformation for inferring contracts from information given in GNU's extended assembly syntax. Registered as a transformation occurring after annotations table are filled. *) (** the corresponding code transformation category. *) val category: File.code_transformation_category (** emitter for the generated annotations. *) val emitter: Emitter.t frama-c-Phosphorus-20170501/src/kernel_internals/typing/asm_contracts.ml0000644000175000017500000001633013113745011025220 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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 category = File.register_code_transformation_category "asm contracts" let dkey = Kernel.register_category "asm:contracts" let emitter = Emitter.( create "asm_contracts" [ Code_annot; Property_status ] ~correctness:[] ~tuning:[Kernel.AsmContractsAutoValidate.parameter]) let find_out_lval l = let treat_one_lval (output, input) (_,constr, lv) = let tlv = Logic_utils.lval_to_term_lval ~cast:false lv in match constr with | "" -> tlv :: output, input | _ -> (* '+' indicates that the lval is used both as input and as output. GNU syntax allows it only at the beginning of the constraint, but actual implementation is more liberal and emits only a warning. *) if String.contains constr '+' then begin if constr.[0] <> '+' then Kernel.warning "output constraint '+' is not at the beginning in output operand"; tlv::output, (* avoid sharing ids *) Visitor.visitFramacTermLval (new Visitor.frama_c_refresh(Project.current())) tlv :: input end else tlv::output, input in let output, input = List.fold_left treat_one_lval ([],[]) l in List.rev output, List.rev input let extract_term_lval acc (_,_,e) = let res = ref acc in let vis = object inherit Visitor.frama_c_inplace method! vlval lv = res := Logic_utils.lval_to_term_lval ~cast:false lv :: !res; Cil.SkipChildren end in ignore (Visitor.visitFramacExpr vis e); !res let find_input_lval l = (* constraints on input are not interesting for us. They only concern the placement of the given expression (register, memory, ...) *) List.rev (List.fold_left extract_term_lval [] l) class visit_assembly = object(self) inherit Visitor.frama_c_inplace method! vinst i = let stmt = Extlib.the self#current_stmt in let kf = Extlib.the self#current_kf in match i with | Asm(_, _, Some { asm_outputs; asm_inputs; asm_clobbers }, loc) -> let lv_out, lv_from = find_out_lval asm_outputs in let lv_from = lv_from @ find_input_lval asm_inputs in (* the only interesting information for clobbers is the presence of the "memory" keyword, which indicates that memory may have been accessed (read or write) outside of the locations explicitly referred to as output or input. We can't do much more than emitting a warning and considering that nothing is touched beyond normally specified outputs and inputs. *) let mem_clobbered = List.mem "memory" asm_clobbers in if mem_clobbered then begin let source = fst (Cil_datatype.Instr.loc i) in let once = true in Kernel.warning ~once ~source "Clobber list contain \"memory\" argument. Assuming no \ side-effect beyond those mentioned in output operands." end; let to_id_term lv = Logic_const.new_identified_term (Logic_const.term ~loc (TLval lv) (Cil.typeOfTermLval lv)) in let assigns () = Writes (List.map (fun x -> (to_id_term x, From (List.map to_id_term lv_from))) lv_out) in let filter ca = match ca.annot_content with (* search for a statement contract that applies to all cases. *) | AStmtSpec ([],_) -> true | _ -> false in let contracts = Annotations.code_annot ~filter stmt in (match contracts with | [] -> let assigns = assigns () in let bhv = Cil.mk_behavior ~assigns () in let spec = Cil.empty_funspec () in spec.spec_behavior <- [ bhv ]; let ca = Logic_const.new_code_annotation (AStmtSpec ([],spec)) in Annotations.add_code_annot emitter ~kf stmt ca; if not mem_clobbered && Kernel.AsmContractsAutoValidate.get() then begin let ips = Property.ip_of_code_annot kf stmt ca in List.iter Property_status.( fun x -> emit emitter ~hyps:[] x True) ips end | [ { annot_content = AStmtSpec ([], spec) } ] -> (* Already existing contracts. Just add assigns clause for behaviors that do not already have one. *) List.iter (fun bhv -> match bhv.b_assigns with | WritesAny -> let behavior = bhv.b_name in let assigns = assigns () in let keep_empty = false in Annotations.add_assigns ~keep_empty emitter kf ~stmt ~behavior assigns; | Writes _ -> ()) spec.spec_behavior | _ -> Kernel.fatal "Several contracts found for the same statement %a" Printer.pp_stmt stmt ); Cil.SkipChildren | Asm(_,_,None,_) -> Kernel.feedback ~dkey "Ignoring basic assembly instruction"; Cil.SkipChildren | _ -> Cil.SkipChildren end let transform file = if Kernel.AsmContractsGenerate.get() then Visitor.visitFramacFileSameGlobals (new visit_assembly) file let () = File.add_code_transformation_after_cleanup ~deps:[(module Kernel.AsmContractsGenerate); (module Kernel.AsmContractsAutoValidate) ] category transform frama-c-Phosphorus-20170501/src/kernel_internals/typing/infer_annotations.mli0000644000175000017500000000340113113745012026245 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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-Phosphorus-20170501/src/kernel_internals/typing/cfg.mli0000644000175000017500000001104413113745001023264 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 nearly always automatically done by the kernel. You only need those functions if you build {!Cil_types.fundec} yourself. *) 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 statement in a function *) val clearCFGinfo: ?clear_id:bool -> fundec -> unit (* [VP] This function was initially in Cil, but now depends on stuff in Logic_utils. Put there to avoid circular dependencies. *) (** 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 (**/**) val clear_sid_info_ref: (unit -> unit) ref frama-c-Phosphorus-20170501/src/kernel_internals/typing/alpha.ml0000644000175000017500000002373613113745012023456 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 associated 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 ~(lookupname: string) ~(data: 'a) : string * 'a = alphaWorker ~alphaTable:alphaTable ?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 ~(lookupname: string) ~(data: 'a) : unit = ignore (alphaWorker ~alphaTable:alphaTable ?undolist ~lookupname:lookupname ~data:data false) and alphaWorker ~(alphaTable: (string, 'a alphaTableData ref) H.t) ?undolist ~(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-Phosphorus-20170501/src/kernel_internals/typing/logic_builtin.mli0000644000175000017500000000347613113745006025367 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* 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-Phosphorus-20170501/src/kernel_internals/runtime/0000755000175000017500000000000013113745012022175 5ustar mehdimehdiframa-c-Phosphorus-20170501/src/kernel_internals/runtime/machdeps.mli0000644000175000017500000000711213113745007024471 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). *) (****************************************************************************) (** Some predefined {!Cil_types.mach} which specifies machine-dependent data about C programs. *) val x86_16: Cil_types.mach val gcc_x86_16: Cil_types.mach val x86_32: Cil_types.mach val gcc_x86_32: Cil_types.mach val x86_64: Cil_types.mach val gcc_x86_64: Cil_types.mach val ppc_32: Cil_types.mach val msvc_x86_64: Cil_types.mach frama-c-Phosphorus-20170501/src/kernel_internals/runtime/gui_init.mli0000644000175000017500000000336513113745007024522 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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. *) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Phosphorus-20170501/src/kernel_internals/runtime/toplevel_config.ml0000644000175000017500000000320213113745011025702 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public 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-Phosphorus-20170501/src/kernel_internals/runtime/frama_c_config.ml.in0000644000175000017500000000526113113745004026056 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2017 *) (* CEA (Commissariat à l'énergie atomique et aux énergies *) (* alternatives) *) (* *) (* you can redistribute it and/or modify it under the terms of the GNU *) (* Lesser General Public License as published by the Free Software *) (* Foundation, version 2.1. *) (* *) (* It is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Lesser General Public License for more details. *) (* *) (* See the GNU Lesser General Public License version 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) # 24 "src/kernel_internals/runtime/frama_c_config.ml.in" (** This file is *not* linked in Frama-C. Instead, is it is concatenated to Config, to create a standalone executable *) let version _ = Format.printf "Frama-C %s@\n\ Environment:@\n \ FRAMAC_SHARE = %S@\n \ FRAMAC_LIB = %S@\n \ FRAMAC_PLUGIN = %S@." Config.version Config.datadir Config.libdir Config.plugin_path ; exit 0 let options = Arg.([ "-print-share-path", Unit (fun _ -> Format.printf "%s%!" Config.datadir; exit 0), " Print the path of Frama-C share directory"; "-print-libpath", Unit (fun _ -> Format.printf "%s%!" Config.libdir; exit 0), " Print the path of Frama-C kernel library"; "-print-plugin-path", Unit (fun _ -> Format.printf "%s%!" Config.plugin_path; exit 0), " Print the path where Frama-C dynamic plug-ins are searched for"; "-version", Unit version, " Display Frama-C version"; ]) let usage = "\ Usage: frama-c-config