diff --git a/.github/workflows/tests.yml b/.github/workflows/tests.yml new file mode 100644 index 000000000..a8472a718 --- /dev/null +++ b/.github/workflows/tests.yml @@ -0,0 +1,56 @@ +name: build and run tests +# https://github.com/avsm/setup-ocaml + +on: + - push + - pull_request + +jobs: + tests: + strategy: + fail-fast: false + matrix: + os: + - macos-latest + - ubuntu-latest + # - windows-latest + ocaml-version: + - 4.04.2 + - 4.05.0 + - 4.06.1 + - 4.07.1 + - 4.08.1 + - 4.09.1 + - 4.10.1 + - 4.11.2 + - 4.12.0 + + + runs-on: ${{ matrix.os }} + + steps: + - name: Checkout code + uses: actions/checkout@v2 + + - name: Cache # https://github.com/marketplace/actions/cache + uses: actions/cache@v2.0.0 + with: + # A list of files, directories, and wildcard patterns to cache and restore + path: | + ~/.opam + _opam + # An explicit key for restoring and saving the cache + key: ${{ runner.os }}-new-${{ matrix.ocaml-version }} + + - name: Setup OCaml ${{ matrix.ocaml-version }} + uses: avsm/setup-ocaml@v1 + with: + ocaml-version: ${{ matrix.ocaml-version }} + + - run: opam pin add goblint-cil.dev . --no-action + - run: opam depext goblint-cil --yes + - run: opam depext goblint-cil --yes --with-doc + - run: opam depext goblint-cil --yes --with-test + - run: opam install . --deps-only --with-doc --with-test + - run: opam exec -- dune build + - run: opam exec -- dune runtest diff --git a/.gitignore b/.gitignore index d6af8738b..f373db45f 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,5 @@ +_opam/ +src/.merlin # / /camlprim0.obj /*.a @@ -92,6 +94,7 @@ # /lib/cil /lib/cil +/lib/goblint-cil # /share /share/cil/ocamlpath @@ -390,4 +393,26 @@ /test/small2/funcptr3 /test/small2/merge-ar /test/small2/libmerge.a - +/test/small2/*.o +.vscode/settings.json +src/ext/blockinggraph/.merlin +src/ext/callgraph/.merlin +src/ext/zrapp/.merlin +src/ext/simplify/.merlin +src/ext/simplemem/.merlin +src/ext/sfi/.merlin +src/ext/pta/.merlin +src/ext/partial/.merlin +src/ext/oneret/.merlin +src/ext/logwrites/.merlin +src/ext/logcalls/.merlin +src/ext/llvm/.merlin +src/ext/liveness/.merlin +src/ext/inliner/.merlin +src/ext/heapify/.merlin +src/ext/epicenter/.merlin +src/ext/dataslicing/.merlin +src/ext/ccl/.merlin +src/ext/canonicalize/.merlin +src/ext/cqualann/.merlin +src/ext/syntacticsearch/.merlin diff --git a/.merlin b/.merlin index 1dde20971..286dbbc8a 100644 --- a/.merlin +++ b/.merlin @@ -2,11 +2,11 @@ S src/ S src/ext/ S src/ext/pta/ S src/frontc/ -S ocamlutil/ +S src/ocamlutil/ B _build/ B _build/src/ B _build/src/ext/ B _build/src/ext/pta/ B _build/src/frontc/ -B _build/ocamlutil/ +B _build/src/ocamlutil/ PKG findlib diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 1e9c9b91a..000000000 --- a/.travis.yml +++ /dev/null @@ -1,10 +0,0 @@ -language: c -sudo: required -install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh -script: bash -ex .travis-opam.sh -env: - - OCAML_VERSION=4.00 - - OCAML_VERSION=4.01 - - OCAML_VERSION=4.02 -os: - - linux diff --git a/LICENSE b/LICENSE index d746e2e4d..538452d37 100644 --- a/LICENSE +++ b/LICENSE @@ -1,10 +1,12 @@ -Copyright (c) 2001-2013, +Copyright (c) 2001-2020, George C. Necula Scott McPeak Wes Weimer Ben Liblit Matt Harren Gabriel Kerneis + Ralf Vogler + Michael Schwarz All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/META.goblint-cil.template b/META.goblint-cil.template new file mode 100644 index 000000000..5a5e1d0c6 --- /dev/null +++ b/META.goblint-cil.template @@ -0,0 +1,11 @@ +# DUNE_GEN + +package "default-features" ( +requires="goblint-cil.dataslicing goblint-cil.liveness goblint-cil.pta goblint-cil.makecfg goblint-cil.syntacticsearch" +version = "1.7.8" +) + +package "all-features" ( +requires="goblint-cil.dataslicing goblint-cil.liveness goblint-cil.pta goblint-cil.makecfg goblint-cil.zrapp goblint-cil.syntacticsearch" +version = "1.7.8" +) diff --git a/Makefile.in b/Makefile.in index 9e6b59d24..a684a6a1f 100644 --- a/Makefile.in +++ b/Makefile.in @@ -57,10 +57,10 @@ CILLIB_TARGETS= CILLY_EXE_FILES= CIL_PLUGINS_DIR = src/ext -CIL_EXCLUDE_PLUGINS = +CIL_EXCLUDE_PLUGINS = dune CIL_PLUGINS = $(addprefix $(OBJDIR)/,$(filter-out $(addprefix $(CIL_PLUGINS_DIR)/, $(CIL_EXCLUDE_PLUGINS)),$(wildcard $(CIL_PLUGINS_DIR)/*))) -CIL_DEFAULT_PLUGINS = $(patsubst $(CIL_PLUGINS_DIR)/%/default,cil.%,$(wildcard $(CIL_PLUGINS_DIR)/*/default)) +CIL_DEFAULT_PLUGINS = $(patsubst $(CIL_PLUGINS_DIR)/%/default,goblint-cil.%,$(wildcard $(CIL_PLUGINS_DIR)/*/default)) ifneq ($(OCAMLC),no) CILLIB_TARGETS += $(OBJDIR)/src/cil.cma @@ -106,7 +106,7 @@ ocamlbuild: META: @rm -f $@ @printf "description = \"C Intermediate Language\"\n" >>$@ - @printf "requires = \"unix str num dynlink\"\n" >>$@ + @printf "requires = \"unix str zarith dynlink\"\n" >>$@ @printf "version = \"$(CIL_VERSION)\"\n\n" >>$@ @printf "archive(byte) = \"cil.cma\"\n" >>$@ @printf "archive(native) = \"cil.cmxa\"\n\n" >>$@ @@ -115,7 +115,7 @@ META: @printf "version = \"$(CIL_VERSION)\"\n" >>$@ @printf ")\n\n" >>$@ @printf "package \"all-features\" (\n" >>$@ - @printf "requires=\"$(patsubst $(OBJDIR)/$(CIL_PLUGINS_DIR)/%,cil.%,$(CIL_PLUGINS))\"\n" >>$@ + @printf "requires=\"$(patsubst $(OBJDIR)/$(CIL_PLUGINS_DIR)/%,goblint-cil.%,$(CIL_PLUGINS))\"\n" >>$@ @printf "version = \"$(CIL_VERSION)\"\n" >>$@ @printf ")\n\n" >>$@ @$(foreach plugin,$(patsubst $(OBJDIR)/$(CIL_PLUGINS_DIR)/%,%,$(CIL_PLUGINS)),\ @@ -167,6 +167,9 @@ $(OBJDIR)/machdep.ml : src/machdep-ml.c configure.ac Makefile.in @echo " sizeof_float: int; (* Size of \"float\" *)" >> $@ @echo " sizeof_double: int; (* Size of \"double\" *)" >> $@ @echo " sizeof_longdouble: int; (* Size of \"long double\" *)" >> $@ + @echo " sizeof_floatcomplex: int; (* Size of \"float _Complex\" *)" >> $@ + @echo " sizeof_doublecomplex: int; (* Size of \"double _Complex\" *)" >> $@ + @echo " sizeof_longdoublecomplex: int; (* Size of \"long double _Complex\" *)" >> $@ @echo " sizeof_void: int; (* Size of \"void\" *)" >> $@ @echo " sizeof_fun: int; (* Size of function *)" >> $@ @echo " size_t: string; (* Type of \"sizeof(T)\" *)" >> $@ @@ -181,6 +184,9 @@ $(OBJDIR)/machdep.ml : src/machdep-ml.c configure.ac Makefile.in @echo " alignof_float: int; (* Alignment of \"float\" *)" >> $@ @echo " alignof_double: int; (* Alignment of \"double\" *)" >> $@ @echo " alignof_longdouble: int; (* Alignment of \"long double\" *)" >> $@ + @echo " alignof_floatcomplex: int; (* Alignment of \"float _Complex\" *)" >> $@ + @echo " alignof_doublecomplex: int; (* Alignment of \"double _Complex\" *)" >> $@ + @echo " alignof_longdoublecomplex: int; (* Alignment of \"long double _Complex\" *)" >> $@ @echo " alignof_str: int; (* Alignment of strings *)" >> $@ @echo " alignof_fun: int; (* Alignment of function *)" >> $@ @echo " alignof_aligned: int; (* Alignment of anything with the \"aligned\" attribute *)" >> $@ @@ -277,7 +283,7 @@ distclean: clean clean: $(CILLYDIR)/Makefile rm -rf $(OBJDIR) rm -f $(BINDIR)/$(CILLY).* - rm -rf lib/cil share/ + rm -rf lib/goblint-cil share/ rm -f META rm -rf doc/html/ rm -rf doc/cilcode.tmp/ @@ -346,10 +352,10 @@ endif install-findlib: META $(CILLIB_FILES) $(CILLIB_TARGETS) uninstall-findlib mkdir -p $(OCAMLFIND_INSTALLDIR) OCAMLFIND_DESTDIR=$(OCAMLFIND_INSTALLDIR) \ - $(OCAMLFIND) install cil META $(CILLIB_TARGETS) `cat $(CILLIB_FILES)` + $(OCAMLFIND) install goblint-cil META $(CILLIB_TARGETS) `cat $(CILLIB_FILES)` uninstall-findlib: - OCAMLFIND_DESTDIR=$(OCAMLFIND_INSTALLDIR) $(OCAMLFIND) remove cil + OCAMLFIND_DESTDIR=$(OCAMLFIND_INSTALLDIR) $(OCAMLFIND) remove goblint-cil .PHONY: install-data uninstall-data install-data: diff --git a/README.md b/README.md index 608fec202..226829c36 100644 --- a/README.md +++ b/README.md @@ -1,45 +1,64 @@ C Intermediate Language (CIL) ============================ -Linux [![Linux build Status](https://travis-ci.org/cil-project/cil.svg?branch=develop)](https://travis-ci.org/cil-project/cil) -Windows [![Windows build status](https://ci.appveyor.com/api/projects/status/jtgf72r03jnge7jw/branch/develop?svg=true)](https://ci.appveyor.com/project/kerneis/cil/branch/develop) - - CIL is a front-end for the C programming language that facilitates program analysis and transformation. CIL will parse and typecheck a program, and compile it into a simplified subset of C. -CIL supports ANSI C as well as most of the extensions of the GNU C and -Microsoft C compilers. A Perl script acts as a drop in replacement for -either gcc or Microsoft's cl, and allows merging of the source files in -your project. Other features include support for control-flow and -points-to analyses. +`goblint-cil` is a fork of CIL that supports C99 as well as most of the +extensions of the GNU C. It makes many changes to the original CIL in an effort +to modernize it and keep up with the latest versions of the C language. Here is +an incomplete list of some of the ways `goblint-cil` improves upon CIL: +- Proper support for C99, ([#9][i9]) and VLAs in particular ([#5][i5], [#7][pr7]) +- It uses [Zarith][zarith] instead of the deprecated [Num][num] +- Support for more recent OCaml versions (≥ 4.06) +- Large integer constants that do not fit in an OCaml `int` are represented as a + `string` instead of getting truncated +- Syntactic search extension ([#21][pr21]) +- Some warnings were made optional +- Unmaintained extensions ([#30][pr30]) were removed +- Many bug fixes + +[zarith]: https://github.com/ocaml/Zarith +[num]: https://github.com/ocaml/num +[i5]: https://github.com/goblint/cil/issues/5 +[pr7]: https://github.com/goblint/cil/pull/7 +[i9]: https://github.com/goblint/cil/issues/9 +[pr21]: https://github.com/goblint/cil/pull/21 +[pr30]: https://github.com/goblint/cil/pull/30 + +Quickstart +---------- + +Install the latest release of `goblint-cil` with [opam][]: -Quick start ------------ + opam install goblint-cil -Install the latest release of CIL with [opam][]: +Read the excellent [CIL tutorial][tuto] by Zachary Anderson, much of which +still applies to `goblint-cil`. - opam install cil +**ATTENTION:** Don't install the `cil` package. This is the unmaintained +original version of CIL. -Read the excellent [CIL tutorial][tuto] by Zachary Anderson, and -check out the accompanying [project template][template]. +[tuto]: https://web.eecs.umich.edu/~weimerw/2011-6610/reading/ciltut.pdf -[tuto]: https://bitbucket.org/zanderso/cil-template/downloads/ciltut.pdf -[template]: https://bitbucket.org/zanderso/cil-template +Installation from Source +------------------------ -Installation ------------ +Prerequisites: +- opam +- Some C compiler (preferably `gcc`) +- Perl -To build and install CIL, you need the OCaml compiler, perl, and -[ocamlfind][findlib]. (Of course, you also need some C compiler, -preferably gcc.) +First create a local opam switch and install all dependencies: -Run the following commands to build and install CIL: + opam switch create . + +Then, run the following commands to build and install `goblint-cil`: ./configure make - make test # regression test suite, optionnal + make test # runs the regression test suite, optional make install # as root or using sudo If you want to install to some other directory, you can tweak the prefix @@ -48,17 +67,26 @@ directory: ./configure --prefix=`opam config var prefix` -[findlib]: http://projects.camlcity.org/projects/findlib.html -[opam]: http://opam.ocamlpro.com/ +[opam]: https://opam.ocaml.org/ + +Build with Dune +--------------- +Alternatively, you can use [dune] to build `goblint-cil`. Run the following +commands to build and test `goblint-cil`: + + dune build + dune runtest # runs the regression test suite + +[dune]: https://github.com/ocaml/dune Usage ----- -You can use cilly (installed in /usr/local/bin by default) as a drop-in -replacement for gcc to compile and link your programs. +You can use cilly (installed in `/usr/local/bin` by default) as a drop-in +replacement for `gcc` to compile and link your programs. -You can also use CIL as a library to write your own programs. For -instance in the OCaml toplevel using [findlib][]: +You can also use `goblint-cil` as a library to write your own programs. For +instance in the OCaml toplevel using [Findlib][findlib]: $ ocaml Objective Caml version 4.00.1 @@ -67,29 +95,20 @@ instance in the OCaml toplevel using [findlib][]: [...] # #require "cil";; [...] - # Cil.cilVersion;; + # Cil.cilVersion;; - : string = "1.7.3" +[findlib]: http://projects.camlcity.org/projects/findlib.html -More documentation ------------------- - -The documentation is located in the doc/html/cil directory. The API -documentation (generated by ocamldoc) is in the api subdirectory. - -To (re)build the doc, you need [Hevea][] and run: - - make doc - -You can also [browse the documentation online][doc]. +TODO +---- -[hevea]: http://hevea.inria.fr/ "Hevea - LaTex to HTML translator" -[doc]: http://cil-project.github.io/cil/doc/html/cil/ "Cil online doc" +- C11 support ([#13][i13]) -Ressources ----------- +[i13]: https://github.com/goblint/cil/issues/13 -* [Mailing list](https://lists.sourceforge.net/lists/listinfo/cil-users) -* [Bug tracker](http://sourceforge.net/p/cil/bugs/) +License +------- +`goblint-cil` is licensed under the BSD license. See [LICENSE][license]. -CIL is maintained by Gabriel Kerneis +[license]: https://github.com/goblint/cil/blob/develop/LICENSE diff --git a/_tags b/_tags index 59986cee7..46bacf5f4 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # Traverse only subdirectories containing source code -true: -traverse +true: -traverse, package(zarith), package(stdlib-shims), package(batteries), package(yojson), package(ppx_deriving_yojson) : include # build every cmo in debug mode (for cil.cma) <**/*.cmo>: debug diff --git a/appveyor.yml b/appveyor.yml deleted file mode 100644 index e581ca45d..000000000 --- a/appveyor.yml +++ /dev/null @@ -1,13 +0,0 @@ -platform: - - x86 - -environment: - CYG_ROOT: "C:\\cygwin" - CYG_BASH: "%CYG_ROOT%\\bin\\bash -lc" - -install: - - appveyor DownloadFile https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/appveyor-opam.sh - - "%CYG_ROOT%\\setup-x86.exe -qnNdO -R %CYG_ROOT% -s http://cygwin.mirror.constant.com -l C:/cygwin/var/cache/setup -P rsync -P patch -P diffutils -P curl -P make -P unzip -P git -P m4 -P perl -P mingw64-x86_64-gcc-core" - -build_script: - - "%CYG_BASH% '${APPVEYOR_BUILD_FOLDER}/appveyor-opam.sh'" diff --git a/configure b/configure index 2560ede45..f12f807d2 100755 --- a/configure +++ b/configure @@ -659,14 +659,6 @@ target_os target_vendor target_cpu target -host_os -host_vendor -host_cpu -host -build_os -build_vendor -build_cpu -build INSTALL_DATA INSTALL_SCRIPT INSTALL_PROGRAM @@ -677,6 +669,14 @@ CPPFLAGS LDFLAGS CFLAGS CC +host_os +host_vendor +host_cpu +host +build_os +build_vendor +build_cpu +build target_alias host_alias build_alias @@ -696,6 +696,7 @@ infodir docdir oldincludedir includedir +runstatedir localstatedir sharedstatedir sysconfdir @@ -766,6 +767,7 @@ datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' +runstatedir='${localstatedir}/run' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE}' @@ -1018,6 +1020,15 @@ do | -silent | --silent | --silen | --sile | --sil) silent=yes ;; + -runstatedir | --runstatedir | --runstatedi | --runstated \ + | --runstate | --runstat | --runsta | --runst | --runs \ + | --run | --ru | --r) + ac_prev=runstatedir ;; + -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ + | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ + | --run=* | --ru=* | --r=*) + runstatedir=$ac_optarg ;; + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ @@ -1155,7 +1166,7 @@ fi for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ - libdir localedir mandir + libdir localedir mandir runstatedir do eval ac_val=\$$ac_var # Remove trailing slashes. @@ -1308,6 +1319,7 @@ Fine tuning of the installation directories: --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] @@ -2193,7 +2205,7 @@ ac_config_files="$ac_config_files stamp-h" # Assign here the CIL version numbers CIL_VERSION_MAJOR=1 CIL_VERSION_MINOR=7 -CIL_VERSION_REV=3 +CIL_VERSION_REV=8 CIL_VERSION=$CIL_VERSION_MAJOR.$CIL_VERSION_MINOR.$CIL_VERSION_REV # make sure I haven't forgotten to run autoconf @@ -2206,203 +2218,129 @@ fi # for @CC@ in output files; you have to do this even if you don't # care about @CC@, because system feature tests later on in # the ./configure script will expect $CC to be set right -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu -if test -n "$ac_tool_prefix"; then - # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. -set dummy ${ac_tool_prefix}gcc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_CC+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$CC"; then - ac_cv_prog_CC="$CC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_CC="${ac_tool_prefix}gcc" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 + +# AC_CANONICAL_HOST is needed to access the 'host_os' variable +ac_aux_dir= +for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do + if test -f "$ac_dir/install-sh"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install-sh -c" + break + elif test -f "$ac_dir/install.sh"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install.sh -c" + break + elif test -f "$ac_dir/shtool"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/shtool install -c" + break fi done - done -IFS=$as_save_IFS - -fi -fi -CC=$ac_cv_prog_CC -if test -n "$CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 -$as_echo "$CC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } +if test -z "$ac_aux_dir"; then + as_fn_error $? "cannot find install-sh, install.sh, or shtool in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" "$LINENO" 5 fi +# These three variables are undocumented and unsupported, +# and are intended to be withdrawn in a future Autoconf release. +# They can cause serious problems if a builder's source tree is in a directory +# whose full name contains unusual characters. +ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var. +ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var. +ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. -fi -if test -z "$ac_cv_prog_CC"; then - ac_ct_CC=$CC - # Extract the first word of "gcc", so it can be a program name with args. -set dummy gcc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_CC+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$ac_ct_CC"; then - ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_CC="gcc" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -ac_ct_CC=$ac_cv_prog_ac_ct_CC -if test -n "$ac_ct_CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 -$as_echo "$ac_ct_CC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - if test "x$ac_ct_CC" = x; then - CC="" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - CC=$ac_ct_CC - fi -else - CC="$ac_cv_prog_CC" -fi +# Make sure we can run config.sub. +$SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 || + as_fn_error $? "cannot run $SHELL $ac_aux_dir/config.sub" "$LINENO" 5 -if test -z "$CC"; then - if test -n "$ac_tool_prefix"; then - # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. -set dummy ${ac_tool_prefix}cc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_CC+:} false; then : +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking build system type" >&5 +$as_echo_n "checking build system type... " >&6; } +if ${ac_cv_build+:} false; then : $as_echo_n "(cached) " >&6 else - if test -n "$CC"; then - ac_cv_prog_CC="$CC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_CC="${ac_tool_prefix}cc" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS + ac_build_alias=$build_alias +test "x$ac_build_alias" = x && + ac_build_alias=`$SHELL "$ac_aux_dir/config.guess"` +test "x$ac_build_alias" = x && + as_fn_error $? "cannot guess build type; you must specify one" "$LINENO" 5 +ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` || + as_fn_error $? "$SHELL $ac_aux_dir/config.sub $ac_build_alias failed" "$LINENO" 5 fi -fi -CC=$ac_cv_prog_CC -if test -n "$CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 -$as_echo "$CC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_build" >&5 +$as_echo "$ac_cv_build" >&6; } +case $ac_cv_build in +*-*-*) ;; +*) as_fn_error $? "invalid value of canonical build" "$LINENO" 5;; +esac +build=$ac_cv_build +ac_save_IFS=$IFS; IFS='-' +set x $ac_cv_build +shift +build_cpu=$1 +build_vendor=$2 +shift; shift +# Remember, the first character of IFS is used to create $*, +# except with old shells: +build_os=$* +IFS=$ac_save_IFS +case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac - fi -fi -if test -z "$CC"; then - # Extract the first word of "cc", so it can be a program name with args. -set dummy cc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_CC+:} false; then : +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking host system type" >&5 +$as_echo_n "checking host system type... " >&6; } +if ${ac_cv_host+:} false; then : $as_echo_n "(cached) " >&6 else - if test -n "$CC"; then - ac_cv_prog_CC="$CC" # Let the user override the test. + if test "x$host_alias" = x; then + ac_cv_host=$ac_cv_build else - ac_prog_rejected=no -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then - ac_prog_rejected=yes - continue - fi - ac_cv_prog_CC="cc" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -if test $ac_prog_rejected = yes; then - # We found a bogon in the path, so make sure we never use it. - set dummy $ac_cv_prog_CC - shift - if test $# != 0; then - # We chose a different compiler from the bogus one. - # However, it has the same basename, so the bogon will be chosen - # first if we set CC to just the basename; use the full file name. - shift - ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" - fi -fi -fi + ac_cv_host=`$SHELL "$ac_aux_dir/config.sub" $host_alias` || + as_fn_error $? "$SHELL $ac_aux_dir/config.sub $host_alias failed" "$LINENO" 5 fi -CC=$ac_cv_prog_CC -if test -n "$CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 -$as_echo "$CC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_host" >&5 +$as_echo "$ac_cv_host" >&6; } +case $ac_cv_host in +*-*-*) ;; +*) as_fn_error $? "invalid value of canonical host" "$LINENO" 5;; +esac +host=$ac_cv_host +ac_save_IFS=$IFS; IFS='-' +set x $ac_cv_host +shift +host_cpu=$1 +host_vendor=$2 +shift; shift +# Remember, the first character of IFS is used to create $*, +# except with old shells: +host_os=$* +IFS=$ac_save_IFS +case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac -fi -if test -z "$CC"; then - if test -n "$ac_tool_prefix"; then - for ac_prog in cl.exe + +# Detect the target system +case "${host_os}" in + *darwin*) + list_of_compilers="gcc-9 gcc-8 gcc-7 gcc clang" + ;; + *macos*) + list_of_compilers="gcc-9 gcc-8 gcc-7 gcc clang" + ;; + *) + list_of_compilers="gcc cl cc" + ;; +esac + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +if test -n "$ac_tool_prefix"; then + for ac_prog in $list_of_compilers do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 @@ -2446,7 +2384,7 @@ fi fi if test -z "$CC"; then ac_ct_CC=$CC - for ac_prog in cl.exe + for ac_prog in $list_of_compilers do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 @@ -2501,8 +2439,6 @@ esac fi fi -fi - test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} @@ -2996,34 +2932,6 @@ ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $ ac_compiler_gnu=$ac_cv_c_compiler_gnu -ac_aux_dir= -for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do - if test -f "$ac_dir/install-sh"; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install-sh -c" - break - elif test -f "$ac_dir/install.sh"; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install.sh -c" - break - elif test -f "$ac_dir/shtool"; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/shtool install -c" - break - fi -done -if test -z "$ac_aux_dir"; then - as_fn_error $? "cannot find install-sh, install.sh, or shtool in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" "$LINENO" 5 -fi - -# These three variables are undocumented and unsupported, -# and are intended to be withdrawn in a future Autoconf release. -# They can cause serious problems if a builder's source tree is in a directory -# whose full name contains unusual characters. -ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var. -ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var. -ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. - # Find a good install program. We prefer a C program (faster), # so one script is as good as another. But avoid the broken or @@ -3122,77 +3030,6 @@ test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' # find system type (using this macro means we must include # the files install-sh, config.sub, and config.guess (all from # the autoconf distribution) in our source tree!) -# Make sure we can run config.sub. -$SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 || - as_fn_error $? "cannot run $SHELL $ac_aux_dir/config.sub" "$LINENO" 5 - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking build system type" >&5 -$as_echo_n "checking build system type... " >&6; } -if ${ac_cv_build+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_build_alias=$build_alias -test "x$ac_build_alias" = x && - ac_build_alias=`$SHELL "$ac_aux_dir/config.guess"` -test "x$ac_build_alias" = x && - as_fn_error $? "cannot guess build type; you must specify one" "$LINENO" 5 -ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` || - as_fn_error $? "$SHELL $ac_aux_dir/config.sub $ac_build_alias failed" "$LINENO" 5 - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_build" >&5 -$as_echo "$ac_cv_build" >&6; } -case $ac_cv_build in -*-*-*) ;; -*) as_fn_error $? "invalid value of canonical build" "$LINENO" 5;; -esac -build=$ac_cv_build -ac_save_IFS=$IFS; IFS='-' -set x $ac_cv_build -shift -build_cpu=$1 -build_vendor=$2 -shift; shift -# Remember, the first character of IFS is used to create $*, -# except with old shells: -build_os=$* -IFS=$ac_save_IFS -case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking host system type" >&5 -$as_echo_n "checking host system type... " >&6; } -if ${ac_cv_host+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test "x$host_alias" = x; then - ac_cv_host=$ac_cv_build -else - ac_cv_host=`$SHELL "$ac_aux_dir/config.sub" $host_alias` || - as_fn_error $? "$SHELL $ac_aux_dir/config.sub $host_alias failed" "$LINENO" 5 -fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_host" >&5 -$as_echo "$ac_cv_host" >&6; } -case $ac_cv_host in -*-*-*) ;; -*) as_fn_error $? "invalid value of canonical host" "$LINENO" 5;; -esac -host=$ac_cv_host -ac_save_IFS=$IFS; IFS='-' -set x $ac_cv_host -shift -host_cpu=$1 -host_vendor=$2 -shift; shift -# Remember, the first character of IFS is used to create $*, -# except with old shells: -host_os=$* -IFS=$ac_save_IFS -case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking target system type" >&5 $as_echo_n "checking target system type... " >&6; } if ${ac_cv_target+:} false; then : @@ -4286,9 +4123,9 @@ if test "$OCAMLC" = "no"; then as_fn_error $? "You must install the OCaml compiler" "$LINENO" 5 fi -if test "$OCAMLBUILD" = "no"; then - as_fn_error $? "You must install ocamlbuild" "$LINENO" 5 -fi +# if test "$OCAMLBUILD" = "no"; then +# AC_MSG_ERROR([You must install ocamlbuild]) +# fi # checking for ocamllex if test -n "$ac_tool_prefix"; then diff --git a/configure.ac b/configure.ac index e89778ff1..f01db5f21 100644 --- a/configure.ac +++ b/configure.ac @@ -33,7 +33,7 @@ AC_PREREQ([2.69]) # Assign here the CIL version numbers CIL_VERSION_MAJOR=1 CIL_VERSION_MINOR=7 -CIL_VERSION_REV=3 +CIL_VERSION_REV=8 CIL_VERSION=$CIL_VERSION_MAJOR.$CIL_VERSION_MINOR.$CIL_VERSION_REV # make sure I haven't forgotten to run autoconf @@ -46,7 +46,25 @@ fi # for @CC@ in output files; you have to do this even if you don't # care about @CC@, because system feature tests later on in # the ./configure script will expect $CC to be set right -AC_PROG_CC + +# AC_CANONICAL_HOST is needed to access the 'host_os' variable +AC_CANONICAL_HOST + +# Detect the target system +case "${host_os}" in + *darwin*) + list_of_compilers="gcc-9 gcc-8 gcc-7 gcc clang" + ;; + *macos*) + list_of_compilers="gcc-9 gcc-8 gcc-7 gcc clang" + ;; + *) + list_of_compilers="gcc cl cc" + ;; +esac + +AC_PROG_CC([$list_of_compilers]) + AC_PROG_INSTALL @@ -92,9 +110,9 @@ if test "$OCAMLC" = "no"; then AC_MSG_ERROR([You must install the OCaml compiler]) fi -if test "$OCAMLBUILD" = "no"; then - AC_MSG_ERROR([You must install ocamlbuild]) -fi +# if test "$OCAMLBUILD" = "no"; then +# AC_MSG_ERROR([You must install ocamlbuild]) +# fi AC_PROG_OCAMLLEX if test "$OCAMLLEX" = "no"; then diff --git a/doc/cilcode.pl b/doc/cilcode.pl index 51bec58a7..3a2d2692d 100644 --- a/doc/cilcode.pl +++ b/doc/cilcode.pl @@ -45,12 +45,12 @@ my $lineno = 0; while(<>) { $lineno ++; - if(! $incode && $_ =~ m|^\\begin{cilcode}\[(.*)\](.*)$|) { + if(! $incode && $_ =~ m|^\\begin\{cilcode}\[(.*)\](.*)$|) { $opt = $1; $cil_options = $2; $incode = 1; print STDERR "\n***Found CIL code at line $lineno\n"; - open(TSTSRC, ">$tmpdir/ex$testnr.c") + open(TSTSRC, ">$tmpdir/ex$testnr.c") || die "Cannot create source $testnr"; if($opt eq 'local') { print TSTSRC $preambleLocal; @@ -60,7 +60,7 @@ print "\\begin{code}\n"; next; } - if($incode && $_ =~ m|^\\end{cilcode}$|) { + if($incode && $_ =~ m|^\\end\{cilcode}$|) { $incode = 0; if($opt eq 'local') { print TSTSRC $postambleLocal; @@ -96,7 +96,6 @@ } if($incode) { print TSTSRC $_; - } + } print $_; } - diff --git a/dune-project b/dune-project new file mode 100644 index 000000000..19ce20ace --- /dev/null +++ b/dune-project @@ -0,0 +1,35 @@ +(lang dune 2.00) +(name goblint-cil) +(implicit_transitive_deps false) +(generate_opam_files true) +(version 1.7.8) +(source (github goblint/cil)) +(homepage "https://cil-project.github.io/cil/") +; (documentation "https://goblint.github.io/cil") +(authors "gabriel@kerneis.info") +(maintainers "Michael Schwarz " "Ralf Vogler ") +(license BSD) + +(package + (name goblint-cil) + (synopsis "A front-end for the C programming language that facilitates program analysis and transformation") + (description "\ +This is a fork of the 'cil' package needed to build 'goblint'. +Changes: +- some warnings are made optional +- truncated integer constants have a string representation +- compiles with OCaml >=4.06.0, use zarith instead of num") + (depends + (ocaml (>= 4.02.3)) + ocamlfind + zarith + (hevea :with-doc) + (dune (>= 2.3.0)) + (odoc :with-doc) + stdlib-shims + ppx_deriving_yojson + yojson + (batteries (>= 3.2.0)) + ) + (conflicts cil) +) diff --git a/goblint-cil.opam b/goblint-cil.opam new file mode 100644 index 000000000..493762e13 --- /dev/null +++ b/goblint-cil.opam @@ -0,0 +1,47 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "1.7.8" +synopsis: + "A front-end for the C programming language that facilitates program analysis and transformation" +description: """ +This is a fork of the 'cil' package needed to build 'goblint'. +Changes: +- some warnings are made optional +- truncated integer constants have a string representation +- compiles with OCaml >=4.06.0, use zarith instead of num""" +maintainer: [ + "Michael Schwarz " + "Ralf Vogler " +] +authors: ["gabriel@kerneis.info"] +license: "BSD" +homepage: "https://cil-project.github.io/cil/" +bug-reports: "https://github.com/goblint/cil/issues" +depends: [ + "ocaml" {>= "4.02.3"} + "ocamlfind" + "zarith" + "hevea" {with-doc} + "dune" {>= "2.3.0"} + "odoc" {with-doc} + "stdlib-shims" + "ppx_deriving_yojson" + "yojson" + "batteries" {>= "3.2.0"} +] +conflicts: ["cil"] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/goblint/cil.git" diff --git a/goblint-cil.opam.locked b/goblint-cil.opam.locked new file mode 100644 index 000000000..cc4daad6a --- /dev/null +++ b/goblint-cil.opam.locked @@ -0,0 +1,75 @@ +opam-version: "2.0" +version: "1.7.8" +synopsis: + "A front-end for the C programming language that facilitates program analysis and transformation" +description: """ +This is a fork of the 'cil' package needed to build 'goblint'. +Changes: +- some warnings are made optional +- truncated integer constants have a string representation +- compiles with OCaml >=4.06.0, use zarith instead of num""" +maintainer: [ + "Michael Schwarz " + "Ralf Vogler " +] +authors: ["gabriel@kerneis.info"] +license: "BSD" +homepage: "https://cil-project.github.io/cil/" +bug-reports: "https://github.com/goblint/cil/issues" +depends: [ + "astring" {= "0.8.5"} + "base-bigarray" {= "base"} + "base-threads" {= "base"} + "base-unix" {= "base"} + "batteries" {= "3.2.0"} + "biniou" {= "1.2.1"} + "cmdliner" {= "1.0.4"} + "conf-gmp" {= "3"} + "conf-m4" {= "1"} + "conf-perl" {= "1"} + "cppo" {= "1.6.6"} + "dune" {= "2.7.1"} + "easy-format" {= "1.3.2"} + "fpath" {= "0.7.3"} + "hevea" {= "2.32"} + "num" {= "1.4"} + "ocaml" {= "4.10.0"} + "ocaml-compiler-libs" {= "v0.12.3"} + "ocaml-migrate-parsetree" {= "2.1.0"} + "ocaml-system" {= "4.10.0"} + "ocamlbuild" {= "0.14.0"} + "ocamlfind" {= "1.8.1"} + "odoc" {= "1.5.2"} + "ppx_derivers" {= "1.2.1"} + "ppx_deriving" {= "5.2"} + "ppx_deriving_yojson" {= "3.6.1"} + "ppxlib" {= "0.20.0"} + "re" {= "1.9.0"} + "result" {= "1.5"} + "seq" {= "base"} + "sexplib0" {= "v0.14.0"} + "stdlib-shims" {= "0.1.0"} + "topkg" {= "1.0.3"} + "tyxml" {= "4.4.0"} + "uchar" {= "0.0.2"} + "uutf" {= "1.0.2"} + "yojson" {= "1.7.0"} + "zarith" {= "1.11"} +] +conflicts: ["cil"] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/goblint/cil.git" +name: "goblint-cil" diff --git a/lib/perl5/App/Cilly.pm.in b/lib/perl5/App/Cilly.pm.in index 2bf420835..adfd5dbf7 100644 --- a/lib/perl5/App/Cilly.pm.in +++ b/lib/perl5/App/Cilly.pm.in @@ -1,11 +1,11 @@ # # -# Copyright (c) 2001-2002, +# 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: @@ -148,7 +148,7 @@ sub new { $self->{$key} = $compiler->{$key}; } - # For MSVC we have to use --save-temps because otherwise the + # For MSVC we have to use --save-temps because otherwise the # temporary files get deleted somehow before CL gets at them ! if($mode ne "GNUCC" && $mode ne "AR") { $self->{SAVE_TEMPS} = '.'; @@ -189,11 +189,11 @@ sub collectArgumentList { # Scan and process the arguments while($#args >= 0) { my $arg = $self->fetchNextArg(\@args); - + if(! defined($arg)) { last; } - if($arg eq "") { next; } + if($arg eq "") { next; } #print("arg: $arg\n"); # @@ -220,8 +220,8 @@ sub collectOneArgument { if($self->compilerArgument($self->{OPTIONS}, $arg, $pargs)) { return 1; } if($arg eq "--help" || $arg eq "-help") { - $self->printVersion(); - $self->printHelp(); + $self->printVersion(); + $self->printHelp(); exit 1; } if($arg eq "--version" || $arg eq "-version") { @@ -274,7 +274,7 @@ sub collectOneArgument { return 1; } if($arg =~ m|--leavealone=(.+)$|) { - push @{$self->{LEAVEALONE}}, $1; + push @{$self->{LEAVEALONE}}, $1; return 1; } if($arg =~ m|--includedir=(.+)$|) { @@ -311,7 +311,7 @@ sub collectOneArgument { if($middle ne "") { # Sometimes we have multiple arguments in one line :-() if($middle =~ m|\s| && - $middle !~ m|[\"]|) { + $middle !~ m|[\"]|) { # Contains spaces and no quotes my @middles = split(/\s+/, $middle); push @respArgs, @middles; @@ -358,7 +358,7 @@ sub collectOneArgument { sub printVersion { - system ($App::Cilly::CilCompiler::compiler, '--version'); + system ($App::Cilly::CilCompiler::compiler, '--version'); } sub printHelp { @@ -386,7 +386,7 @@ Options: --verbose Prints a lot of information about what is being done. --save-temps Keep temporary files in the current directory. --save-temps=xxx Keep temporary files in the given directory. - + --nomerge Apply CIL separately to each source file as they are compiled.$nomergeisDefault --merge Apply CIL to the merged program.$mergeisDefault --keepmerged Save the merged file. Only useful if --nomerge is not given. @@ -399,8 +399,8 @@ Options: they are not merged and not processed with CIL. --includedir=xxx Adds a new include directory to replace existing ones --bytecode Invoke the bytecode (as opposed to native code) system - --stdoutpp For MSVC only, use the "preprocess to stdout" mode. This - is for some versions of MSVC that do not support + --stdoutpp For MSVC only, use the "preprocess to stdout" mode. This + is for some versions of MSVC that do not support well the /P file EOF @@ -455,17 +455,17 @@ sub linktolib { if($self->{VERBOSE}) { print STDERR "Linking into library $dest\n"; } # Now collect the files to be merged - my ($tomerge, $trueobjs, $ccargs) = + my ($tomerge, $trueobjs, $ccargs) = $self->separateTrueObjects($psrcs, $ccargs); if($self->{SEPARATE} || @{$tomerge} == 0) { # Not merging. Regular linking. - return $self->straight_linktolib($psrcs, $dest, + return $self->straight_linktolib($psrcs, $dest, $ppargs, $ccargs, $ldargs); } # We are merging. Merge all the files into a single one - + if(@{$trueobjs} > 0) { # We have some true objects. Save them into an additional file my $trueobjs_file = "$dest" . "_trueobjs"; @@ -490,7 +490,7 @@ sub linktolib { # # Prepare the name of the CIL output file based on dest my ($base, $dir, $ext) = fileparse($dest, "(\\.[^.]+)"); - + # Now prepare the command line for invoking cilly my ($aftercil, @cmd) = $self->MergeCommand ($psrcs, $dir, $base); die unless $cmd[0]; @@ -505,13 +505,13 @@ sub linktolib { push @cmd, @{$self->{CILARGS}}; } # Eliminate duplicates - + # Add the arguments if(@{$tomerge} > 20) { my $extraFile = "___extra_files"; open(TOMERGE, ">$extraFile") || die $!; #FRANJO added the following on February 15th, 2005 - #REASON: extrafiles was TempFIle=HASH(0x12345678) + #REASON: extrafiles was TempFIle=HASH(0x12345678) # instead of actual filename my @normalized = @{$tomerge} ; $_ = (ref $_ ? $_->filename : $_) foreach @normalized; @@ -549,7 +549,7 @@ sub preprocess_compile { return $self->straight_compile($src, $dest, [@{$early_ppargs}, @{$ppargs}], $ccargs); } my $out = $self->preprocessOutputFile($src); - $out = $self->preprocess($src, $out, + $out = $self->preprocess($src, $out, [@{$early_ppargs}, @{$ppargs}, "$self->{DEFARG}CIL=1"]); return $self->compile($out, $dest, $ppargs, $ccargs); @@ -584,7 +584,7 @@ sub preprocessAfterOutputFile { # When we use CIL we have two separate preprocessing stages. First is the # preprocessing before the CIL sees the code and the is the preprocessing # after CIL sees the code - + sub preprocess_before_cil { my ($self, $src, $dest, $ppargs) = @_; Carp::confess "bad dest: $dest" unless $dest->isa('App::Cilly::OutputFile'); @@ -651,7 +651,7 @@ sub straight_preprocess { my @cmd = (@{$self->{CPP}}, @{$ppargs}, $src, $self->makeOutArguments($self->{OUTCPP}, $dest)); $self->runShell(@cmd); - + } return $dest; } @@ -667,12 +667,12 @@ sub straight_preprocess { sub compile { my($self, $src, $dest, $ppargs, $ccargs) = @_; &mydebug("Cilly.compile(src=$src, dest=$dest->{filename})\n"); - Carp::confess "bad dest: $dest->{filename}" + Carp::confess "bad dest: $dest->{filename}" unless $dest->isa('App::Cilly::OutputFile'); - + if($self->{SEPARATE}) { # Now invoke CIL and compile afterwards - return $self->applyCilAndCompile([$src], $dest, $ppargs, $ccargs); + return $self->applyCilAndCompile([$src], $dest, $ppargs, $ccargs); } # We are merging # If we are merging then we just save the preprocessed source @@ -682,7 +682,7 @@ sub compile { } else { # Do the real compilation $res = $self->straight_compile($src, $dest, $ppargs, $ccargs); - # Now stat the result + # Now stat the result my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime_1,$ctime,$blksize,$blocks) = stat($dest->{filename}); if(! defined($mtime_1)) { @@ -691,12 +691,12 @@ sub compile { $mtime = $mtime_1; $outfile = $dest->{filename} . $App::Cilly::savedSourceExt; } - my $srcname = ref $src ? $src->filename : $src; - if($self->{VERBOSE}) { + my $srcname = ref $src ? $src->filename : $src; + if($self->{VERBOSE}) { print STDERR "Saving source $srcname into $outfile\n"; } open(OUT, ">$outfile") || die "Cannot create $outfile"; - my $toprintsrc = $srcname; + my $toprintsrc = $srcname; $toprintsrc =~ s|\\|/|g; print OUT "#pragma merger(\"$mtime\",\"$toprintsrc\",\"" . join(',', @{$ccargs}), "\")\n"; @@ -707,14 +707,14 @@ sub compile { close(OUT); close(IN); return $res; -} +} -sub makeOutArguments { +sub makeOutArguments { my ($self, $which, $dest) = @_; $dest = $dest->{filename} if ref $dest; - if($self->{MODENAME} eq "MSVC" || + if($self->{MODENAME} eq "MSVC" || $self->{MODENAME} eq "MSLINK" || - $self->{MODENAME} eq "MSLIB") { + $self->{MODENAME} eq "MSLIB") { # A single argument return ("$which$dest"); } else { @@ -722,14 +722,14 @@ sub makeOutArguments { } } # This is the actual invocation of the underlying compiler. You should not -# override this +# override this sub straight_compile { my ($self, $src, $dest, $ppargs, $ccargs) = @_; - if($self->{VERBOSE}) { - print STDERR 'Compiling ', ref $src ? $src->filename : $src, ' into ', - $dest->filename, "\n"; + if($self->{VERBOSE}) { + print STDERR 'Compiling ', ref $src ? $src->filename : $src, ' into ', + $dest->filename, "\n"; } - my @dest = + my @dest = $dest eq "" ? () : $self->makeOutArguments($self->{OUTOBJ}, $dest); my @forcec = @{$self->{FORCECSOURCE}}; my @cmd = (@{$self->{CC}}, @{$ppargs}, @{$ccargs}, @@ -749,7 +749,7 @@ sub compile_cil { sub assemble { my ($self, $src, $dest, $ppargs, $ccargs) = @_; if($self->{VERBOSE}) { print STDERR "Assembling $src\n"; } - my @dest = + my @dest = $dest eq "" ? () : $self->makeOutArguments($self->{OUTOBJ}, $dest); my @cmd = (@{$self->{CC}}, @{$ppargs}, @{$ccargs}, @dest, $src); @@ -764,7 +764,7 @@ sub assemble { sub straight_link { my ($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_; my @sources = ref($psrcs) ? @{$psrcs} : ($psrcs); - my @dest = + my @dest = $dest eq "" ? () : $self->makeOutArguments($self->{OUTEXE}, $dest); # Pass the linkargs last because some libraries must be passed after # the sources @@ -786,7 +786,7 @@ sub expandLibraries { while($#tolink >= 0) { my $src = shift @tolink; # print "Looking at $src\n"; - # See if the source is a library. Then maybe we should get instead the + # See if the source is a library. Then maybe we should get instead the # list of files if($src =~ m|\.$self->{LIBEXT}$| && -f "$src.files") { open(FILES, "<$src.files") || die "Cannot read $src.files"; @@ -830,7 +830,7 @@ sub separateTrueObjects { } else { $combsrcname = $srcname . $App::Cilly::savedSourceExt; $combsrc = $combsrcname; - if(-f $combsrcname) { + if(-f $combsrcname) { my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime_1,$ctime,$blksize,$blocks) = stat($srcname); $mtime = $mtime_1; @@ -844,7 +844,7 @@ sub separateTrueObjects { close(IN); if($fstline =~ m|CIL|) { goto ToMerge; - } + } if($fstline =~ m|^\#pragma merger\(\"(\d+)\",\".*\",\"(.*)\"\)$|) { my $mymtime = $1; # Get the CC flags @@ -860,11 +860,11 @@ sub separateTrueObjects { if($mymtime == $mtime) { # It is ours # See if we have this already if(! grep { $_ eq $srcname } @tomerge) { # It is ours - push @tomerge, $combsrc; + push @tomerge, $combsrc; # See if there is a a trueobjs file also my $trueobjs = $combsrcname . "_trueobjs"; if(-f $trueobjs) { - open(TRUEOBJS, "<$trueobjs") + open(TRUEOBJS, "<$trueobjs") || die "Cannot read $trueobjs"; while() { chop; @@ -896,31 +896,31 @@ sub link { if (!defined($ENV{CILLY_DONT_LINK_AFTER_MERGE})) { if($self->{VERBOSE}) { print STDERR "Linking into $destname\n"; } # Not merging. Regular linking. - return $self->link_after_cil($psrcs, $dest, + return $self->link_after_cil($psrcs, $dest, $ppargs, $ccargs, $ldargs); } else { return 0; # sm: is this value used?? } } - my $outname = ($self->{OPERATION} eq "TOASM") ? $destname + my $outname = ($self->{OPERATION} eq "TOASM") ? $destname : "${destname}_comb.$self->{OBJEXT}"; my $mergedobj = new App::Cilly::OutputFile($destname, $outname); # We must merge - if($self->{VERBOSE}) { - print STDERR "Merging saved sources into $mergedobj->{filename} (in process of linking $destname)\n"; + if($self->{VERBOSE}) { + print STDERR "Merging saved sources into $mergedobj->{filename} (in process of linking $destname)\n"; } - + # Now collect the files to be merged - my ($tomerge, $trueobjs, $ccargs) = + my ($tomerge, $trueobjs, $ccargs) = $self->separateTrueObjects($psrcs, $ccargs); if($self->{VERBOSE}) { - print STDERR "Will merge the following: ", + print STDERR "Will merge the following: ", join(' ', @{$tomerge}), "\n"; - print STDERR "Will just link the genuine object files: ", + print STDERR "Will just link the genuine object files: ", join(' ', @{$trueobjs}), "\n"; print STDERR "After merge compile flags: @{$ccargs}\n"; } @@ -930,7 +930,7 @@ sub link { my $canReuse = 1; my $combFile = new App::Cilly::OutputFile($destname, "${destname}_comb.c"); - my @tmp = stat($combFile); + my @tmp = stat($combFile); my $combFileMtime = $tmp[9] || 0; foreach my $mrg (@{$tomerge}) { my @tmp = stat($mrg); my $mtime = $tmp[9]; @@ -939,12 +939,12 @@ sub link { if($self->{VERBOSE}) { print STDERR "Reusing merged file $combFile\n"; } - $self->applyCilAndCompile([$combFile], $mergedobj, $ppargs, $ccargs); - } else { + $self->applyCilAndCompile([$combFile], $mergedobj, $ppargs, $ccargs); + } else { DoMerge: $self->applyCilAndCompile($tomerge, $mergedobj, $ppargs, $ccargs); } - + if ($self->{OPERATION} eq "TOASM") { if (@{$trueobjs} != ()) { die "Error: binary file passed as input when assembly desired". @@ -976,16 +976,16 @@ sub link { sub applyCil { my ($self, $ppsrc, $dest) = @_; - + # The input files my @srcs = @{$ppsrc}; # Now prepare the command line for invoking cilly my ($aftercil, @cmd) = $self->CillyCommand ($ppsrc, $dest); - Carp::confess "$self produced bad output file: $aftercil" + Carp::confess "$self produced bad output file: $aftercil" unless $aftercil->isa('App::Cilly::OutputFile'); - if($self->{MODENAME} eq "MSVC" || + if($self->{MODENAME} eq "MSVC" || $self->{MODENAME} eq "MSLINK" || $self->{MODENAME} eq "MSLIB") { push @cmd, '--MSVC'; @@ -1033,7 +1033,7 @@ sub applyCilAndCompile { # Now run cilly my $aftercil = $self->applyCil($ppsrc, $dest); - Carp::confess "$self produced bad output file: $aftercil" + Carp::confess "$self produced bad output file: $aftercil" unless $aftercil->isa('App::Cilly::OutputFile'); # Now preprocess @@ -1081,27 +1081,27 @@ sub doit { # Then we do not do anything my @cmd = (@{$self->{CPP}}, @{$self->{EARLY_PPARGS}}, - @{$self->{PPARGS}}, @{$self->{CCARGS}}, + @{$self->{PPARGS}}, @{$self->{CCARGS}}, @{$self->{CFILES}}, @{$self->{SFILES}}); push @cmd, @{$self->{OUTARG}} if defined $self->{OUTARG}; return $self->runShell(@cmd); } - # We expand some libraries names. Maybe they just contain some + # We expand some libraries names. Maybe they just contain some # new object files $self->expandLibraries(); - # Try to guess whether to run in the separate mode. In that case - # we can go ahead with the compilation, without having to save + # Try to guess whether to run in the separate mode. In that case + # we can go ahead with the compilation, without having to save # files if(! $self->{SEPARATE} && # Not already separate mode $self->{OPERATION} eq "TOEXE" && # We are linking to an executable @{$self->{CFILES}} + @{$self->{IFILES}} <= 1) { # At most one source - # If we have object files, we should keep merging if at least one + # If we have object files, we should keep merging if at least one # object file is a disguised source my $turnOffMerging = 0; if(@{$self->{OFILES}}) { - my ($tomerge, $trueobjs, $mergedccargs) = + my ($tomerge, $trueobjs, $mergedccargs) = $self->separateTrueObjects($self->{OFILES}, $self->{CCARGS}); $self->{CCARGS} = $mergedccargs; $turnOffMerging = (@{$tomerge} == 0); @@ -1113,7 +1113,7 @@ sub doit { print STDERR "Turn off merging because the program contains one file\n"; } - $self->{SEPARATE} = 1; + $self->{SEPARATE} = 1; } } @@ -1130,8 +1130,8 @@ sub doit { # Now do the assembly language file foreach $file (@{$self->{SFILES}}) { $out = $self->assembleOutputFile($file); - $self->assemble($file, $out, - $self->{EARLY_PPARGS}, + $self->assemble($file, $out, + $self->{EARLY_PPARGS}, $self->{PPARGS}, $self->{CCARGS}); push @tolink, $out; } @@ -1152,20 +1152,20 @@ sub doit { if (!$self->{TRUELIB}) { # zf: Creating a library containing merged source $out = $self->linkOutputFile(@tolink); - $self->linktolib(\@tolink, $out, - $self->{PPARGS}, $self->{CCARGS}, + $self->linktolib(\@tolink, $out, + $self->{PPARGS}, $self->{CCARGS}, $self->{LINKARGS}); return; } else { # zf: Linking to a true library. Do real curing. - # Only difference from TOEXE is that we use "partial linking" of the + # Only difference from TOEXE is that we use "partial linking" of the # underlying linker if ($self->{VERBOSE}) { print STDERR "Linking to a true library!"; } push @{$self->{CCARGS}}, "-r"; $out = $self->linkOutputFile(@tolink); - $self->link(\@tolink, $out, + $self->link(\@tolink, $out, $self->{PPARGS}, $self->{CCARGS}, $self->{LINKARGS}); return; } @@ -1175,7 +1175,7 @@ sub doit { # Now link all of the files into an executable if($self->{OPERATION} eq "TOEXE" || $self->{OPERATION} eq "TOASM") { $out = $self->linkOutputFile(@tolink); - $self->link(\@tolink, $out, + $self->link(\@tolink, $out, $self->{PPARGS}, $self->{CCARGS}, $self->{LINKARGS}); return; } @@ -1241,12 +1241,12 @@ sub compilerArgument { push @{$self->{CCARGS}}, @fullarg; return 1; } elsif($action->{TYPE} eq "LINKCC") { - push @{$self->{CCARGS}}, @fullarg; + push @{$self->{CCARGS}}, @fullarg; push @{$self->{LINKARGS}}, @fullarg; return 1; } elsif($action->{TYPE} eq "ALLARGS") { push @{$self->{PPARGS}}, @fullarg; - push @{$self->{CCARGS}}, @fullarg; + push @{$self->{CCARGS}}, @fullarg; push @{$self->{LINKARGS}}, @fullarg; return 1; } elsif($action->{TYPE} eq "LINK") { @@ -1282,7 +1282,7 @@ sub compilerArgument { print " Do not understand TYPE\n"; return 1; } if($argument_done) { return 1; } - print "Don't know what to do with option $arg\n"; + print "Don't know what to do with option $arg\n"; return 0; } } @@ -1299,7 +1299,7 @@ sub runShell { # from cygwin names to the actual Windows names if($^O eq "cygwin") { my $arg = $_; - if ($arg =~ m|^/| && -f $arg) { + if ($arg =~ m|^/| && -f $arg) { my $mname = `cygpath -m $arg`; chop $mname; if($mname ne "") { $_ = $mname; } @@ -1328,7 +1328,7 @@ sub runShell { $code >>= 8; # extract exit code portion exit $code; - } + } return $code; } @@ -1377,12 +1377,12 @@ use strict; use File::Basename; use Data::Dumper; -# For MSVC we remember which was the first source, because we use that to +# For MSVC we remember which was the first source, because we use that to # determine the name of the output file sub setFirstSource { my ($self, $src) = @_; - - if(! defined ($self->{FIRST_SOURCE})) { + + if(! defined ($self->{FIRST_SOURCE})) { $self->{FIRST_SOURCE} = $src; } } @@ -1392,7 +1392,7 @@ sub new { my $class = ref($proto) || $proto; # Create $self - my $self = + my $self = { NAME => 'Microsoft cl compiler', MODENAME => 'MSVC', CC => ['cl', '/nologo', '/D_MSVC', '/c'], @@ -1411,13 +1411,13 @@ sub new { FORCECSOURCE => ['/Tc'], LINEPATTERN => "^#line\\s+(\\d+)\\s+\"(.+)\"", - OPTIONS => -# Describe the compiler options as a list of patterns and associated actions. + OPTIONS => +# Describe the compiler options as a list of patterns and associated actions. # The patterns are matched in order against the _begining_ of the argument. # # If the action contains ONEMORE => 1 then the argument is expected to be # parameterized by a following word. The word can be attached immediately to -# the end of the argument or in a separate word. +# the end of the argument or in a separate word. # # If the action contains TYPE => "..." then the argument is put into # one of several lists, as follows: "PREPROC" in ppargs; "CC" in @@ -1433,7 +1433,7 @@ sub new { # given subroutine is invoked with the self, the argument and the (possibly # empty) additional word and a pointer to the list of remaining arguments # - ["^[^/\\-@].*\\.($::cilbin|c|cpp|cc)\$" => + ["^[^/\\-@].*\\.($::cilbin|c|cpp|cc)\$" => { TYPE => 'CSOURCE', RUN => sub { &MSVC::setFirstSource(@_); } }, "[^/].*\\.(asm)\$" => { TYPE => 'ASMSOURCE' }, @@ -1451,14 +1451,14 @@ sub new { "[/\\-]FI" => { TYPE => "PREPROC" }, "[/\\-][CXu]" => { TYPE => "PREPROC" }, "[/\\-]U" => { ONEMORE => 1, TYPE => "PREPROC" }, - "[/\\-](E|EP|P)" => { RUN => sub { push @{$stub->{PPARGS}}, $_[1]; + "[/\\-](E|EP|P)" => { RUN => sub { push @{$stub->{PPARGS}}, $_[1]; $stub->{OPERATION} = "PREPROC"; }}, "[/\\-]c" => { RUN => sub { $stub->{OPERATION} = "TOOBJ"; }}, "[/\\-](Q|Z|J|nologo|w|W|Zm)" => { TYPE => "CC" }, "[/\\-]Y(u|c|d|l|X)" => { TYPE => "CC" }, "[/\\-]T(C|P)" => { TYPE => "PREPROC" }, - "[/\\-]Tc(.+)\$" => - { RUN => sub { + "[/\\-]Tc(.+)\$" => + { RUN => sub { my $arg = $_[1]; my ($fname) = ($arg =~ m|[/\\-]Tc(.+)$|); $fname = &normalizeFileName($fname); @@ -1467,11 +1467,11 @@ sub new { "[/\\-]v(d|m)" => { TYPE => "CC" }, "[/\\-]F" => { TYPE => "CC" }, "[/\\-]M" => { TYPE => 'LINKCC' }, - "/link" => { RUN => sub { push @{$stub->{LINKARGS}}, "/link", + "/link" => { RUN => sub { push @{$stub->{LINKARGS}}, "/link", @{$_[3]}; @{$_[3]} = (); } }, "-cbstring" => { TYPE => "CC" }, - "/" => { RUN => + "/" => { RUN => sub { print "Unimplemented MSVC argument $_[1]\n";}}, ], }; @@ -1484,10 +1484,10 @@ sub msvc_preprocess { my($self, $src, $dest, $ppargs) = @_; my $res; my $srcname = ref $src ? $src->filename : $src; - my ($sbase, $sdir, $sext) = - fileparse($srcname, + my ($sbase, $sdir, $sext) = + fileparse($srcname, "(\\.c)|(\\.cc)|(\\.cpp)|(\\.i)"); - # If this is a .cpp file we still hope it is C. Pass the /Tc argument to + # If this is a .cpp file we still hope it is C. Pass the /Tc argument to # cl to force this file to be interpreted as a C one my @cmd = @{$ppargs}; @@ -1498,10 +1498,10 @@ sub msvc_preprocess { # puts it in the current directory my $msvcout = "./$sbase.i"; if($self->{STDOUTPP}) { - @cmd = ('cmd', '/c', 'cl', '/nologo', '/E', ">$msvcout", '/D_MSVC', + @cmd = ('cmd', '/c', 'cl', '/nologo', '/E', ">$msvcout", '/D_MSVC', @cmd); - - } else { + + } else { @cmd = ('cl', '/nologo', '/P', '/D_MSVC', @cmd); } $res = $self->runShell(@cmd, $srcname); @@ -1527,7 +1527,7 @@ sub msvc_preprocess { return $res; } -sub forceIncludeArg { +sub forceIncludeArg { my($self, $what) = @_; return "/FI$what"; } @@ -1539,7 +1539,7 @@ sub fixupCsources { my @mod_csources = (); my $src; foreach $src (@csources) { - my ($sbase, $sdir, $sext) = fileparse($src, + my ($sbase, $sdir, $sext) = fileparse($src, "\\.[^.]+"); if($sext eq ".i") { push @mod_csources, "/Tc"; @@ -1563,10 +1563,10 @@ sub compileOutputFile { die "compileOutputFile: not a C source file: $src\n" unless $src =~ /\.($::cilbin|c|cc|cpp|i|asm)$/; - Carp::carp ("compileOutputFile: $self->{OPERATION}, $src", + Carp::carp ("compileOutputFile: $self->{OPERATION}, $src", Dumper($self->{OUTARG})) if 0; if ($self->{OPERATION} eq 'TOOBJ') { - if(defined $self->{OUTARG} + if(defined $self->{OUTARG} && "@{$self->{OUTARG}}" =~ m|[/\\-]Fo(.+)|) { my $dest = $1; # Perhaps $dest is a directory @@ -1636,7 +1636,7 @@ sub new { # Create $self - my $self = + my $self = { NAME => 'Microsoft linker', MODENAME => 'MSLINK', CC => $msvc->{CC}, @@ -1653,12 +1653,12 @@ sub new { OUTOBJ => $msvc->{OUTOBJ}, OUTEXE => "-out:", # Keep this form because build.exe looks for it WARNISERROR => "/WX", - LINEPATTERN => "", + LINEPATTERN => "", FORCECSOURCE => $msvc->{FORCECSOURCE}, MSVC => $msvc, - OPTIONS => + OPTIONS => ["[^/\\-@]" => { TYPE => 'OSOURCE' }, "[/\\-](OUT|out):" => { TYPE => 'OUT' }, "^((/)|(\\-[^\\-]))" => { TYPE => 'LINK' }, @@ -1679,7 +1679,7 @@ sub forceIncludeArg { # Same as for CL sub linkOutputFile { my($self, $src) = @_; # print Dumper($self); - Carp::confess "Cannot compute the linker output file" + Carp::confess "Cannot compute the linker output file" if ! defined $self->{OUTARG}; if("@{$self->{OUTARG}}" =~ m|.+:(.+)|) { @@ -1764,7 +1764,7 @@ sub new { my $class = ref($proto) || $proto; # Create $self - my $self = + my $self = { NAME => 'Archiver', MODENAME => 'ar', CC => ['no_compiler_in_ar_mode'], @@ -1779,9 +1779,9 @@ sub new { EXEEXT => "", # Executable extension (with the .) OUTOBJ => "??OUTOBJ", OUTLIB => "", # But better be first - LINEPATTERN => "", + LINEPATTERN => "", - OPTIONS => + OPTIONS => ["^[^-]" => { RUN => \&arArguments } ] }; @@ -1796,7 +1796,7 @@ sub arArguments { if($arg =~ m|^--|) { return 0; } - # We got here for the first non -- argument. + # We got here for the first non -- argument. # Will handle all arguments at once if($self->{VERBOSE}) { print "AR called with $arg @{$pargs}\n"; @@ -1823,13 +1823,13 @@ sub arArguments { } else { - # if the command is "r" alone, we should add to the current library, + # if the command is "r" alone, we should add to the current library, # not replace it, unless the library does not exist - + # Get the name of the library my $out = shift @{$pargs}; $self->{OUTARG} = [$out]; - + #The library is both an input and an output. #To avoid problems with reading and writing the same file, move the #current version of the library out of the way first. @@ -1853,7 +1853,7 @@ sub arArguments { } } - + # The rest of the arguments must be object files push @{$self->{OFILES}}, @{$pargs}; $self->{OPERATION} = 'TOLIB'; @@ -1894,7 +1894,7 @@ sub new { my @native_cc = Text::ParseWords::shellwords($ENV{CILLY_NATIVE_CC} || $::cc); - my $self = + my $self = { NAME => 'GNU CC', MODENAME => 'GNUCC', # do not change this since it is used in code # sm: added -O since it's needed for inlines to be merged instead of causing link errors @@ -1918,8 +1918,8 @@ sub new { WARNISERROR => "-Werror", FORCECSOURCE => [], LINEPATTERN => "^#\\s+(\\d+)\\s+\"(.+)\"", - - OPTIONS => + + OPTIONS => [ # Files "[^-].*\\.($::cilbin|c|cpp|cc)\$" => { TYPE => 'CSOURCE' }, "[^-].*\\.(s|S)\$" => { TYPE => 'ASMSOURCE' }, @@ -1939,7 +1939,7 @@ sub new { "-v" => { TYPE => 'ALLARGS', RUN => sub { $stub->{TRACE_COMMANDS} = 1; } }, # skipping -###, --help, --target-help, --version - + # C Language Options "-ansi" => { TYPE => 'ALLARGS' }, '-std=' => { TYPE => 'ALLARGS' }, @@ -1956,11 +1956,11 @@ sub new { '-Wp,' => { TYPE => 'EARLY_PREPROC' }, '-Wl,--(no-)?whole-archive$' => { TYPE => 'OSOURCE' }, '-Wl,' => { TYPE => 'LINK' }, - + # Warning Options "-pedantic\$" => { TYPE => 'ALLARGS' }, "-pedantic-errors\$" => { TYPE => 'ALLARGS' }, - "-Wall" => { TYPE => 'CC', + "-Wall" => { TYPE => 'CC', RUN => sub { push @{$stub->{CILARGS}},"--warnall";}}, "-W[-a-z0-9=]*\$" => { TYPE => 'CC' }, "-w\$" => { TYPE => 'ALLARGS' }, @@ -2004,7 +2004,7 @@ sub new { '-MT$' => { TYPE => 'EARLY_PREPROC', ONEMORE => 1 }, '-MQ$' => { TYPE => 'EARLY_PREPROC', ONEMORE => 1 }, '-MD$' => { TYPE => 'EARLY_PREPROC' }, - '-MMD$' => { TYPE => 'EARLY_PREPROC' }, + '-MMD$' => { TYPE => 'EARLY_PREPROC' }, '-P$' => { TYPE => 'EARLY_PREPROC'}, '-nostdinc$' => { TYPE => 'PREPROC' }, '-remap$' => { TYPE => 'PREPROC' }, @@ -2033,8 +2033,8 @@ sub new { # Directory Options "-B" => { ONEMORE => 1, TYPE => 'ALLARGS' }, "-specs=" => { TYPE => 'ALLARGS' }, - "-L" => - { RUN => sub { + "-L" => + { RUN => sub { # Remember these directories in LIBDIR my ($dir) = ($_[1] =~ m|-L(.+)$|); push @{$stub->{LIBDIR}}, $dir; @@ -2071,7 +2071,7 @@ sub new { "--start-group" => { RUN => sub { } }, "--end-group" => { RUN => sub { }}, ], - + }; bless $self, $class; return $self; @@ -2081,12 +2081,12 @@ sub new { my $linker_script_debug = 0; sub parseLinkerScript { my($self, $filename, $onemore, $pargs) = @_; - + if(! defined($self->{FLATTEN_LINKER_SCRIPTS}) || $filename !~ /\.o$/) { NotAScript: warn "$filename is not a linker script\n" if $linker_script_debug; - push @{$self->{OFILES}}, $filename; + push @{$self->{OFILES}}, $filename; return 1; } warn "parsing OBJECT FILE:$filename ****************\n" if @@ -2112,7 +2112,7 @@ sub parseLinkerScript { if($endcomment < 0) { # No end on this line next; # next line } else { - $line = substr($line, $endcomment + 2); + $line = substr($line, $endcomment + 2); $incomment = 0; } } @@ -2128,21 +2128,21 @@ sub parseLinkerScript { # the separators will be tokens as well push @tokens, split(/([(),\s])/, $line); } - print "Found tokens:", join(':', @tokens), "\n" + print "Found tokens:", join(':', @tokens), "\n" if $linker_script_debug; # Now parse the file my $state = 0; foreach my $token (@tokens) { if($token eq "" || $token =~ /\s+/) { next; } # Skip spaces if($state == 0) { - if($token eq "INPUT") { $state = 1; next; } + if($token eq "INPUT") { $state = 1; next; } else { die "Error in script: expecting INPUT"; } } - if($state == 1) { - if($token eq "(") { $state = 2; next; } + if($state == 1) { + if($token eq "(") { $state = 2; next; } else { die "Error in script: expecting ( after INPUT"; } - } - if($state == 2) { + } + if($state == 2) { if($token eq ")") { $state = 0; next; } if($token eq ",") { next; } # Comma could be a separator # Now we better see a filename @@ -2154,13 +2154,13 @@ sub parseLinkerScript { warn "LISTED FILE:$token.\n" if $linker_script_debug; $self->parseLinkerScript($token, $onemore, $pargs); next; - } + } die "Invalid linker script parser state\n"; - + } } -sub forceIncludeArg { +sub forceIncludeArg { my($self, $what) = @_; return ('-include', $what); } @@ -2178,10 +2178,10 @@ sub compileOutputFile { die "objectOutputFile: not a C source file: $src\n" unless $src =~ /\.($::cilbin|c|cc|cpp|i|s|S)$/; - + if ($self->{OPERATION} eq 'TOOBJ' || ($self->{OPERATION} eq 'TOASM')) { - if (defined $self->{OUTARG} + if (defined $self->{OUTARG} && "@{$self->{OUTARG}}" =~ m|^-o\s*(\S.+)$|) { return new App::Cilly::OutputFile($src, $1); } else { @@ -2208,11 +2208,11 @@ sub linkOutputFile { sub setVersion { my($self) = @_; my $cversion = ""; - open(VER, "@{$self->{CC}} -dumpversion " - . join(' ', @{$self->{PPARGS}}) ." |") + open(VER, "@{$self->{CC}} -dumpversion " + . join(' ', @{$self->{PPARGS}}) ." |") || die "Cannot start GNUCC"; while() { - if($_ =~ m|^(\d+\S+)| || $_ =~ m|^(egcs-\d+\S+)|) { + if($_ =~ m|^(\d+\S*)| || $_ =~ m|^(egcs-\d+\S*)|) { $cversion = "gcc_$1"; close(VER) || die "Cannot start GNUCC\n"; $self->{CVERSION} = $cversion; @@ -2226,6 +2226,3 @@ sub setVersion { __END__ - - - diff --git a/opam b/opam deleted file mode 100644 index b203083e4..000000000 --- a/opam +++ /dev/null @@ -1,29 +0,0 @@ -opam-version: "1.2" -authors: ["gabriel@kerneis.info"] -maintainer: "gabriel@kerneis.info" -homepage: "https://cil-project.github.io/cil/" -bug-reports: "https://github.com/cil-project/cil/issues/" -dev-repo: "git+https://github.com/cil-project/cil/" -build: [ - ["env" "FORCE_PERL_PREFIX=1" "./configure" "--prefix" prefix] - [make] -] -build-test: [ - ["env" "VERBOSE=1" make "test"] -] -build-doc: [ - [make "doc"] -] -install: [ - make "install" -] -remove: [ - ["env" "FORCE_PERL_PREFIX=1" "./configure" "--prefix" prefix] - [make "uninstall"] -] -depends: [ - "ocamlfind" - "ocamlbuild" {build} - "hevea" {build & doc} - "hevea" {build & test} -] diff --git a/src/_tags b/src/_tags index 646cc2d47..79664d550 100644 --- a/src/_tags +++ b/src/_tags @@ -1,4 +1,4 @@ or or or : include : package(findlib) -: use_unix, use_str, use_nums, use_dynlink, use_cil, linkall, package(findlib) +: use_dynlink, use_cil, linkall, package(findlib) diff --git a/src/cfg.ml b/src/cfg.ml index 0a609ba23..a5d93cc7b 100644 --- a/src/cfg.ml +++ b/src/cfg.ml @@ -1,13 +1,13 @@ (* * - * Copyright (c) 2001-2003, + * Copyright (c) 2001-2003, * George C. Necula * Scott McPeak * Wes Weimer * Simon Goldsmith * S.P Rahul, Aman Bhargava * All rights reserved. - * + * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: @@ -48,7 +48,7 @@ module E=Errormsg (* entry points: cfgFun, printCfgChannel, printCfgFilename *) (* known issues: - * -sucessors of if somehow end up with two edges each + * -sucessors of if somehow end up with two edges each *) (*------------------------------------------------------------*) @@ -76,8 +76,8 @@ let start_id = ref 0 (* for unique ids across many functions *) class caseLabeledStmtFinder slr = object(self) inherit nopCilVisitor - - method vstmt s = + + method! vstmt s = if List.exists (fun l -> match l with | Case _ | CaseRange _ | Default _ -> true | _ -> false) s.labels @@ -100,7 +100,7 @@ let findCaseLabeledStmts (b : block) : stmt list = class addrOfLabelFinder slr = object(self) inherit nopCilVisitor - method vexpr e = match e with + method! vexpr e = match e with | AddrOfLabel sref -> slr := !sref :: (!slr); SkipChildren @@ -118,7 +118,7 @@ let findAddrOfLabelStmts (b : block) : stmt list = (** Compute a control flow graph for fd. Stmts in fd have preds and succs filled in *) -let rec cfgFun (fd : fundec): int = +let rec cfgFun (fd : fundec): int = begin let initial_id = !start_id in let nodeList = ref [] in @@ -133,7 +133,7 @@ let rec cfgFun (fd : fundec): int = end -and cfgStmts (ss: stmt list) +and cfgStmts (ss: stmt list) (next:stmt option) (break:stmt option) (cont:stmt option) (nodeList:stmt list ref) (rlabels: stmt list) = match ss with @@ -143,7 +143,7 @@ and cfgStmts (ss: stmt list) cfgStmt hd (Some (List.hd tl)) break cont nodeList rlabels; cfgStmts tl next break cont nodeList rlabels -and cfgBlock (blk: block) +and cfgBlock (blk: block) (next:stmt option) (break:stmt option) (cont:stmt option) (nodeList:stmt list ref) (rlabels: stmt list) = cfgStmts blk.bstmts next break cont nodeList rlabels @@ -180,15 +180,15 @@ and cfgStmt (s: stmt) (next:stmt option) (break:stmt option) (cont:stmt option) | hd::_ -> addSucc hd in let instrFallsThrough (i : instr) : bool = match i with - Call (_, Lval (Var vf, NoOffset), _, _) -> + Call (_, Lval (Var vf, NoOffset), _, _) -> (* See if this has the noreturn attribute *) not (hasAttribute "noreturn" vf.vattr) - | Call (_, f, _, _) -> + | Call (_, f, _, _) -> not (hasAttribute "noreturn" (typeAttrs (typeOf f))) | _ -> true in match s.skind with - Instr il -> + Instr il -> if List.for_all instrFallsThrough il then addOptionSucc next else @@ -204,19 +204,19 @@ and cfgStmt (s: stmt) (next:stmt option) (break:stmt option) (cont:stmt option) addBlockSucc blk1 next; cfgBlock blk1 next break cont nodeList rlabels; cfgBlock blk2 next break cont nodeList rlabels - | Block b -> + | Block b -> addBlockSucc b next; cfgBlock b next break cont nodeList rlabels | Switch(_,blk,l,_) -> let bl = findCaseLabeledStmts blk in List.iter addSucc (List.rev bl(*l*)); (* Add successors in order *) (* sfg: if there's no default, need to connect s->next *) - if not (List.exists - (fun stmt -> List.exists + if not (List.exists + (fun stmt -> List.exists (function Default _ -> true | _ -> false) - stmt.labels) - bl) - then + stmt.labels) + bl) + then addOptionSucc next; cfgBlock blk next next cont nodeList rlabels | Loop(blk, loc, s1, s2) -> @@ -225,7 +225,7 @@ and cfgStmt (s: stmt) (next:stmt option) (break:stmt option) (cont:stmt option) cfgBlock blk (Some s) next (Some s) nodeList rlabels (* Since all loops have terminating condition true, we don't put any direct successor to stmt following the loop *) - | TryExcept _ | TryFinally _ -> + | TryExcept _ | TryFinally _ -> E.s (E.unimp "try/except/finally") (*------------------------------------------------------------*) @@ -233,7 +233,7 @@ and cfgStmt (s: stmt) (next:stmt option) (break:stmt option) (cont:stmt option) (**************************************************************) (* do something for all stmts in a fundec *) -let rec forallStmts (todo) (fd : fundec) = +let rec forallStmts (todo) (fd : fundec) = begin fasBlock todo fd.sbody; end @@ -261,7 +261,7 @@ let d_cfgnodename () (s : stmt) = dprintf "%d" s.sid let d_cfgnodelabel () (s : stmt) = - let label = + let label = begin match s.skind with | If (e, _, _, _) -> "if" (*sprint ~width:999 (dprintf "if %a" d_exp e)*) @@ -284,7 +284,7 @@ let d_cfgedge (src) () (dest) = d_cfgnodename dest let d_cfgnode () (s : stmt) = - dprintf "%a [label=\"%a\"]\n\t%a" + dprintf "%a [label=\"%a\"]\n\t%a" d_cfgnodename s d_cfgnodelabel s (d_list "\n\t" (d_cfgedge s)) s.succs diff --git a/src/check.ml b/src/check.ml index b7366d135..faa54075e 100644 --- a/src/check.ml +++ b/src/check.ml @@ -1,11 +1,11 @@ -(* +(* * - * Copyright (c) 2001-2002, + * 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: @@ -43,16 +43,16 @@ open Pretty (* A few parameters to customize the checking *) -type checkFlags = - NoCheckGlobalIds (* Do not check that the global ids have the proper +type checkFlags = + NoCheckGlobalIds (* Do not check that the global ids have the proper * hash value *) | IgnoreInstructions of (instr -> bool) (* Ignore the specified instructions *) - + let checkGlobalIds = ref true let ignoreInstr = ref (fun i -> false) (* Attributes must be sorted *) -type ctxAttr = +type ctxAttr = CALocal (* Attribute of a local variable *) | CAGlobal (* Attribute of a global variable *) | CAType (* Attribute of a type *) @@ -67,10 +67,10 @@ let warnContext fmt = valid := false; Cil.warnContext fmt -let checkAttributes (attrs: attribute list) : unit = +let checkAttributes (attrs: attribute list) : unit = let rec loop lastname = function [] -> () - | Attr(an, _) :: resta -> + | Attr(an, _) :: resta -> if an < lastname then ignore (warn "Attributes not sorted"); loop an resta @@ -85,25 +85,25 @@ let typeDefs : (string, typ) H.t = H.create 117 (* Keep track of all variables names, enum tags and type names *) let varNamesEnv : (string, unit) H.t = H.create 117 - (* We also keep a map of variables indexed by id, to ensure that only one + (* We also keep a map of variables indexed by id, to ensure that only one * varinfo has a given id *) let varIdsEnv: (int, varinfo) H.t = H.create 117 - (* And keep track of all varinfo's to check the uniqueness of the + (* And keep track of all varinfo's to check the uniqueness of the * identifiers *) let allVarIds: (int, varinfo) H.t = H.create 117 - (* Also keep a list of environments. We place an empty string in the list to + (* Also keep a list of environments. We place an empty string in the list to * mark the start of a local environment (i.e. a function) *) let varNamesList : (string * int) list ref = ref [] -let defineName s = +let defineName s = if s = "" then - E.s (bug "Empty name\n"); + E.s (bug "Empty name\n"); if H.mem varNamesEnv s then ignore (warn "Multiple definitions for %s" s); H.add varNamesEnv s () -let defineVariable vi = +let defineVariable vi = (* E.log "saw %s: %d\n" vi.vname vi.vid; *) defineName vi.vname; varNamesList := (vi.vname, vi.vid) :: !varNamesList; @@ -115,7 +115,7 @@ let defineVariable vi = H.add varIdsEnv vi.vid vi (* Check that a varinfo has already been registered *) -let checkVariable vi = +let checkVariable vi = try (* Check in the current scope only *) let old = H.find varIdsEnv vi.vid in @@ -126,14 +126,14 @@ let checkVariable vi = ignore (warnContext "variables %s and %s share id %d" vi.vname old.vname vi.vid ) end - with Not_found -> + with Not_found -> ignore (warn "Unknown id (%d) for %s" vi.vid vi.vname) -let startEnv () = +let startEnv () = varNamesList := ("", -1) :: !varNamesList -let endEnv () = +let endEnv () = let rec loop = function [] -> E.s (bug "Cannot find start of env") | ("", _) :: rest -> varNamesList := rest @@ -144,9 +144,9 @@ let endEnv () = end in loop !varNamesList - - + + (* The current function being checked *) let currentReturnType : typ ref = ref voidType @@ -160,19 +160,20 @@ let statements: stmt list ref = ref [] let gotoTargets: (string * stmt) list ref = ref [] (*** TYPES ***) -(* Cetain types can only occur in some contexts, so keep a list of context *) -type ctxType = +(* Certain types can only occur in some contexts, so keep a list of context *) +type ctxType = CTStruct (* In a composite type *) | CTUnion | CTFArg (* In a function argument type *) | CTFRes (* In a function result type *) | CTArray (* In an array type *) | CTPtr (* In a pointer type *) - | CTExp (* In an expression, as the type of - * the result of binary operators, or + | CTExp (* In an expression, as the type of + * the result of binary operators, or * in a cast *) | CTSizeof (* In a sizeof *) | CTDecl (* In a typedef, or a declaration *) + | CTNumeric (* As an argument to __real__ or __imag__ *) let d_context () = function CTStruct -> text "CTStruct" @@ -184,23 +185,24 @@ let d_context () = function | CTExp -> text "CTExp" | CTSizeof -> text "CTSizeof" | CTDecl -> text "CTDecl" + | CTNumeric -> text "CTNumeric" -(* Keep track of all tags that we use. For each tag remember also the info - * structure and a flag whether it was actually defined or just used. A +(* Keep track of all tags that we use. For each tag remember also the info + * structure and a flag whether it was actually defined or just used. A * forward declaration acts as a definition. *) -type defuse = +type defuse = Defined (* We actually have seen a definition of this tag *) - | Forward (* We have seen a forward declaration for it. This is done using + | Forward (* We have seen a forward declaration for it. This is done using * a GType with an empty type name *) | Used (* Only uses *) let compUsed : (int, compinfo * defuse ref) H.t = H.create 117 let enumUsed : (string, enuminfo * defuse ref) H.t = H.create 117 let typUsed : (string, typeinfo * defuse ref) H.t = H.create 117 - + (* For composite types we also check that the names are unique *) let compNames : (string, unit) H.t = H.create 17 - + let typeSigIgnoreConst (t : typ) : typsig = let attrFilter (attr : attribute) : bool = @@ -212,39 +214,44 @@ let typeSigIgnoreConst (t : typ) : typsig = (* Check a type *) -let rec checkType (t: typ) (ctx: ctxType) = +let rec checkType (t: typ) (ctx: ctxType) = (* Check that it appears in the right context *) let rec checkContext = function TVoid _ -> ctx = CTPtr || ctx = CTFRes || ctx = CTDecl || ctx = CTSizeof | TNamed (ti, a) -> checkContext ti.ttype - | TArray _ -> - (ctx = CTStruct || ctx = CTUnion + | TArray _ -> + (ctx = CTStruct || ctx = CTUnion || ctx = CTSizeof || ctx = CTDecl || ctx = CTArray || ctx = CTPtr) - | TFun _ -> + | TFun _ -> if ctx = CTSizeof && !msvcMode then (ignore(warn "sizeof(function) is not defined in MSVC."); false) else ctx = CTPtr || ctx = CTDecl || ctx = CTSizeof - | _ -> true + | TInt _ -> true + | TFloat _ -> true + | _ -> ctx <> CTNumeric in - if not (checkContext t) then + if not (checkContext t) then ignore (warn "Type (%a) used in wrong context. Expected context: %a" d_plaintype t d_context ctx); match t with (TVoid a | TBuiltin_va_list a) -> checkAttributes a | TInt (ik, a) -> checkAttributes a - | TFloat (_, a) -> checkAttributes a + | TFloat (_, a) -> + checkAttributes a; + if hasAttribute "complex" a then + E.s (E.bug "float type has attribute complex, this should never be the case as there are fkinds for this"); | TPtr (t, a) -> checkAttributes a; checkType t CTPtr | TNamed (ti, a) -> checkAttributes a; - if ti.tname = "" then + if ti.tname = "" then ignore (warnContext "Using a typeinfo for an empty-named type"); checkTypeInfo Used ti | TComp (comp, a) -> checkAttributes a; - (* Mark it as a forward. We'll check it later. If we try to check it + (* Mark it as a forward. We'll check it later. If we try to check it * now we might encounter undefined types *) checkCompInfo Used comp @@ -254,51 +261,50 @@ let rec checkType (t: typ) (ctx: ctxType) = checkEnumInfo Used enum end - | TArray(bt, len, a) -> + | TArray(bt, len, a) -> checkAttributes a; checkType bt CTArray; (match len with None -> () - | Some l -> begin - let t = checkExp true l in + | Some l -> + let t = typeOf l in if not (isIntegralType t) then - E.s (bug "Type of array length is not integer") - end) + E.s (bug "Type of array length is not integer")) - | TFun (rt, targs, isva, a) -> + | TFun (rt, targs, isva, a) -> checkAttributes a; checkType rt CTFRes; - List.iter - (fun (an, at, aa) -> + List.iter + (fun (an, at, aa) -> checkType at CTFArg; checkAttributes aa) (argsToList targs) (* Check that a type is a promoted integral type *) -and checkIntegralType (t: typ) = +and checkIntegralType (t: typ) = checkType t CTExp; if not (isIntegralType t) then ignore (warn "Non-integral type") (* Check that a type is a promoted arithmetic type *) -and checkArithmeticType (t: typ) = +and checkArithmeticType (t: typ) = checkType t CTExp; if not (isArithmeticType t) then ignore (warn "Non-arithmetic type") (* Check that a type is a pointer type *) -and checkPointerType (t: typ) = +and checkPointerType (t: typ) = checkType t CTExp; if not (isPointerType t) then ignore (warn "Non-pointer type") (* Check that a type is a scalar type *) -and checkScalarType (t: typ) = +and checkScalarType (t: typ) = checkType t CTExp; if not (isScalarType t) then ignore (warn "Non-scalar type") -and typeMatch (t1: typ) (t2: typ) = +and typeMatch (t1: typ) (t2: typ) = if !Cil.insertImplicitCasts then begin (* Allow mismatches in const-ness, so that string literals can be used as char*s *) @@ -307,7 +313,7 @@ and typeMatch (t1: typ) (t2: typ) = (* Allow free interchange of TInt and TEnum *) TInt (ik, _), TEnum (ei, _) when ik = ei.ekind -> () | TEnum (ei, _), TInt (ik, _) when ik = ei.ekind -> () - + (* Allow unspecified array lengths - this happens with * flexible array members *) | TArray (t, None, _), TArray (t', _, _) @@ -318,15 +324,15 @@ and typeMatch (t1: typ) (t2: typ) = (* Many casts are missing. For now, just skip this check. *) end -and checkCompInfo (isadef: defuse) comp = +and checkCompInfo (isadef: defuse) comp = let fullname = compFullName comp in try let oldci, olddef = H.find compUsed comp.ckey in (* Check that it is the same *) - if oldci != comp then + if oldci != comp then ignore (warnContext "compinfo for %s not shared" fullname); - (match !olddef, isadef with - | Defined, Defined -> + (match !olddef, isadef with + | Defined, Defined -> ignore (warnContext "Multiple definition of %s" fullname) | _, Defined -> olddef := Defined | Defined, _ -> () @@ -334,7 +340,7 @@ and checkCompInfo (isadef: defuse) comp = | _, _ -> ()) with Not_found -> begin (* This is the first time we see it *) (* Check that the name is not empty *) - if comp.cname = "" then + if comp.cname = "" then E.s (bug "Compinfo with empty name"); (* Check that the name is unique *) if H.mem compNames fullname then @@ -342,26 +348,26 @@ and checkCompInfo (isadef: defuse) comp = (* Add it to the map before we go on *) H.add compUsed comp.ckey (comp, ref isadef); H.add compNames fullname (); - (* Do not check the compinfo unless this is a definition. Otherwise you + (* Do not check the compinfo unless this is a definition. Otherwise you * might run into undefined types. *) if isadef = Defined then begin checkAttributes comp.cattr; let fctx = if comp.cstruct then CTStruct else CTUnion in - let rec checkField f = - if not - (f.fcomp == comp && (* Each field must share the self cell of + let checkField f = + if not + (f.fcomp == comp && (* Each field must share the self cell of * the host *) f.fname <> "") then - ignore (warn "Self pointer not set in field %s of %s" + ignore (warn "Self pointer not set in field %s of %s" f.fname fullname); checkType f.ftype fctx; (* Check the bitfields *) (match unrollType f.ftype, f.fbitfield with - | TInt (ik, a), Some w -> + | TInt (ik, a), Some w -> checkAttributes a; if w < 0 || w > bitsSizeOf (TInt(ik, a)) then ignore (warn "Wrong width (%d) in bitfield" w) - | _, Some w -> + | _, Some w -> ignore (E.error "Bitfield on a non integer type") | _ -> ()); checkAttributes f.fattr @@ -371,16 +377,16 @@ and checkCompInfo (isadef: defuse) comp = end -and checkEnumInfo (isadef: defuse) enum = - if enum.ename = "" then +and checkEnumInfo (isadef: defuse) enum = + if enum.ename = "" then E.s (bug "Enuminfo with empty name"); try let oldei, olddef = H.find enumUsed enum.ename in (* Check that it is the same *) - if oldei != enum then + if oldei != enum then ignore (warnContext "enuminfo for %s not shared" enum.ename); - (match !olddef, isadef with - Defined, Defined -> + (match !olddef, isadef with + Defined, Defined -> ignore (warnContext "Multiple definition of enum %s" enum.ename) | _, Defined -> olddef := Defined | Defined, _ -> () @@ -393,19 +399,19 @@ and checkEnumInfo (isadef: defuse) enum = List.iter (fun (tn, _, _) -> defineName tn) enum.eitems; end -and checkTypeInfo (isadef: defuse) ti = +and checkTypeInfo (isadef: defuse) ti = try let oldti, olddef = H.find typUsed ti.tname in (* Check that it is the same *) - if oldti != ti then + if oldti != ti then ignore (warnContext "typeinfo for %s not shared" ti.tname); - (match !olddef, isadef with - Defined, Defined -> + (match !olddef, isadef with + Defined, Defined -> ignore (warnContext "Multiple definition of type %s" ti.tname) | Defined, Used -> () - | Used, Defined -> + | Used, Defined -> ignore (warnContext "Use of type %s before its definition" ti.tname) - | _, _ -> + | _, _ -> ignore (warnContext "Bug in checkTypeInfo for %s" ti.tname)) with Not_found -> begin (* This is the first time we see it *) if ti.tname = "" then @@ -415,13 +421,13 @@ and checkTypeInfo (isadef: defuse) ti = H.add typUsed ti.tname (ti, ref isadef); end -(* Check an lvalue. If isconst then the lvalue appears in a context where - * only a compile-time constant can appear. Return the type of the lvalue. +(* Check an lvalue. If isconst then the lvalue appears in a context where + * only a compile-time constant can appear. Return the type of the lvalue. * See the typing rule from cil.mli *) -and checkLval (isconst: bool) (forAddrof: bool) (lv: lval) : typ = +and checkLval (isconst: bool) (forAddrof: bool) (lv: lval) : typ = match lv with - Var vi, off -> - checkVariable vi; + Var vi, off -> + checkVariable vi; checkOffset vi.vtype off | Mem addr, off -> begin @@ -433,12 +439,12 @@ and checkLval (isconst: bool) (forAddrof: bool) (lv: lval) : typ = | _ -> E.s (bug "Mem on a non-pointer") end -(* Check an offset. The basetype is the type of the object referenced by the - * base. Return the type of the lvalue constructed from a base value of right +(* Check an offset. The basetype is the type of the object referenced by the + * base. Return the type of the lvalue constructed from a base value of right * type and the offset. See the typing rules from cil.mli *) and checkOffset basetyp : offset -> typ = function NoOffset -> basetyp - | Index (ei, o) -> + | Index (ei, o) -> checkIntegralType (checkExp false ei); begin match unrollType basetyp with @@ -446,31 +452,31 @@ and checkOffset basetyp : offset -> typ = function | t -> E.s (bug "typeOffset: Index on a non-array: %a" d_plaintype t) end - | Field (fi, o) -> + | Field (fi, o) -> (* Now check that the host is shared propertly *) checkCompInfo Used fi.fcomp; (* Check that this exact field is part of the host *) if not (List.exists (fun f -> f == fi) fi.fcomp.cfields) then - ignore (warn "Field %s not part of %s" + ignore (warn "Field %s not part of %s" fi.fname (compFullName fi.fcomp)); checkOffset fi.ftype o - + and checkExpType (isconst: bool) (e: exp) (t: typ) = let t' = checkExp isconst e in (* compute the type *) (* ignore(E.log "checkType %a %a\n" d_plainexp e d_plaintype t); *) typeMatch t' t -(* Check an expression. isconst specifies if the expression occurs in a - * context where only a compile-time constant can occur. Return the computed +(* Check an expression. isconst specifies if the expression occurs in a + * context where only a compile-time constant can occur. Return the computed * type of the expression *) -and checkExp (isconst: bool) (e: exp) : typ = - E.withContext - (fun _ -> dprintf "check%s: %a" +and checkExp (isconst: bool) (e: exp) : typ = + E.withContext + (fun _ -> dprintf "check%s: %a" (if isconst then "Const" else "Exp") d_exp e) (fun _ -> match e with | Const(_) -> typeOf e - | Lval(lv) -> + | Lval(lv) -> if isconst then ignore (warn "Lval in constant"); checkLval isconst false lv @@ -479,7 +485,7 @@ and checkExp (isconst: bool) (e: exp) : typ = (* Sizeof cannot be applied to certain types *) checkType t CTSizeof; (match unrollType t with - (TFun _ ) -> + (TFun _ ) -> ignore (warn "Invalid operand for sizeof") | _ ->()); typeOf e @@ -492,6 +498,12 @@ and checkExp (isconst: bool) (e: exp) : typ = | SizeOfStr s -> typeOf e + | Real e -> + let te = checkExp isconst e in + typeOfRealAndImagComponents te + | Imag e -> + let te = checkExp isconst e in + typeOfRealAndImagComponents te | AlignOf(t) -> begin (* Sizeof cannot be applied to certain types *) checkType t CTSizeof; @@ -503,13 +515,13 @@ and checkExp (isconst: bool) (e: exp) : typ = checkType te CTSizeof; typeOf e - | UnOp (Neg, e, tres) -> + | UnOp (Neg, e, tres) -> checkArithmeticType tres; checkExpType isconst e tres; tres - | UnOp (BNot, e, tres) -> + | UnOp (BNot, e, tres) -> checkIntegralType tres; checkExpType isconst e tres; tres - | UnOp (LNot, e, tres) -> + | UnOp (LNot, e, tres) -> let te = checkExp isconst e in checkScalarType te; checkIntegralType tres; (* Must check that t is well-formed *) @@ -520,30 +532,30 @@ and checkExp (isconst: bool) (e: exp) : typ = let t1 = checkExp isconst e1 in let t2 = checkExp isconst e2 in match bop with - (Mult | Div) -> - typeMatch t1 t2; checkArithmeticType tres; + (Mult | Div) -> + typeMatch t1 t2; checkArithmeticType tres; typeMatch t1 tres; tres - | (Eq|Ne|Lt|Le|Ge|Gt) -> - typeMatch t1 t2; checkArithmeticType t1; + | (Eq|Ne|Lt|Le|Ge|Gt) -> + typeMatch t1 t2; checkArithmeticType t1; typeMatch tres intType; tres - | Mod|BAnd|BOr|BXor -> + | Mod|BAnd|BOr|BXor -> typeMatch t1 t2; checkIntegralType tres; typeMatch t1 tres; tres - | LAnd | LOr -> + | LAnd | LOr -> checkScalarType t1; checkScalarType t2; typeMatch tres intType; tres - | Shiftlt | Shiftrt -> - typeMatch t1 tres; checkIntegralType t1; + | Shiftlt | Shiftrt -> + typeMatch t1 tres; checkIntegralType t1; checkIntegralType t2; tres - | (PlusA | MinusA) -> + | (PlusA | MinusA) -> typeMatch t1 t2; typeMatch t1 tres; checkArithmeticType tres; tres - | (PlusPI | MinusPI | IndexPI) -> + | (PlusPI | MinusPI | IndexPI) -> checkPointerType tres; typeMatch t1 tres; checkIntegralType t2; tres - | MinusPP -> + | MinusPP -> checkPointerType t1; checkPointerType t2; typeMatch t1 t2; typeMatch tres !ptrdiffType; @@ -564,10 +576,10 @@ and checkExp (isconst: bool) (e: exp) : typ = let tlv = checkLval isconst true lv in (* Only certain types can be in AddrOf *) match unrollType tlv with - | TVoid _ -> + | TVoid _ -> E.s (bug "AddrOf on improper type"); - - | (TInt _ | TFloat _ | TPtr _ | TComp _ | TFun _ | TArray _ ) -> + + | (TInt _ | TFloat _ | TPtr _ | TComp _ | TFun _ | TArray _ ) -> TPtr(tlv, []) | TEnum (ei, _) -> TPtr(TInt(ei.ekind, []), []) @@ -594,7 +606,7 @@ and checkExp (isconst: bool) (e: exp) : typ = TArray (t,_, _) -> TPtr(t, []) | _ -> E.s (bug "StartOf on a non-array") end - + | CastE (tres, e) -> begin let et = checkExp isconst e in checkType tres CTExp; @@ -609,8 +621,8 @@ and checkExp (isconst: bool) (e: exp) : typ = end) () (* The argument of withContext *) -and checkInit (i: init) : typ = - E.withContext +and checkInit (i: init) : typ = + E.withContext (fun _ -> dprintf "checkInit: %a" d_init i) (fun _ -> match i with @@ -618,7 +630,7 @@ and checkInit (i: init) : typ = (* | ArrayInit (bt, len, initl) -> begin checkType bt CTSizeof; - if List.length initl > len then + if List.length initl > len then ignore (warn "Too many initializers in array"); List.iter (fun i -> checkInitType i bt) initl; TArray(bt, Some (integer len), []) @@ -627,98 +639,98 @@ and checkInit (i: init) : typ = | CompoundInit (ct, initl) -> begin checkType ct CTSizeof; (match unrollType ct with - TArray(bt, elen, _) -> + TArray(bt, elen, _) -> let len = match elen with | None -> 0L | Some e -> (ignore (checkExp true e); match isInteger (constFold true e) with Some len -> len - | None -> + | None -> ignore (warn "Array length is not a constant"); 0L) in let rec loopIndex i = function - [] -> - if i > len then + [] -> + if i > len then ignore (warn "Wrong number of initializers in array") - | (Index(Const(CInt64(i', _, _)), NoOffset), ei) :: rest -> - if i' <> i then + | (Index(Const(CInt64(i', _, _)), NoOffset), ei) :: rest -> + if i' <> i then ignore (warn "Initializer for index %s when %s was expected" (Int64.format "%d" i') (Int64.format "%d" i)); checkInitType ei bt; loopIndex (Int64.succ i) rest - | _ :: rest -> + | _ :: rest -> ignore (warn "Malformed initializer for array element") in loopIndex Int64.zero initl - | TComp (comp, _) -> + | TComp (comp, _) -> if comp.cstruct then - let rec loopFields - (nextflds: fieldinfo list) - (initl: (offset * init) list) : unit = - match nextflds, initl with + let rec loopFields + (nextflds: fieldinfo list) + (initl: (offset * init) list) : unit = + match nextflds, initl with [], [] -> () (* We are done *) - | f :: restf, (Field(f', NoOffset), i) :: resti -> - if f.fname <> f'.fname then + | f :: restf, (Field(f', NoOffset), i) :: resti -> + if f.fname <> f'.fname then ignore (warn "Expected initializer for field %s and found one for %s" f.fname f'.fname); checkInitType i f.ftype; loopFields restf resti - | [], _ :: _ -> + | [], _ :: _ -> ignore (warn "Too many initializers for struct") - | _ :: _, [] -> + | _ :: _, [] -> ignore (warn "Too few initializers for struct") - | _, _ -> + | _, _ -> ignore (warn "Malformed initializer for struct") in loopFields - (List.filter (fun f -> f.fname <> missingFieldName) - comp.cfields) + (List.filter (fun f -> f.fname <> missingFieldName) + comp.cfields) initl else (* UNION *) if comp.cfields == [] then begin - if initl != [] then + if initl != [] then ignore (warn "Initializer for empty union not empty"); end else begin - match initl with - [(Field(f, NoOffset), ei)] -> - if f.fcomp != comp then + match initl with + [(Field(f, NoOffset), ei)] -> + if f.fcomp != comp then ignore (bug "Wrong designator for union initializer"); if !msvcMode && f != List.hd comp.cfields then ignore (warn "On MSVC you can only initialize the first field of a union"); checkInitType ei f.ftype - - | _ -> + + | _ -> ignore (warn "Malformed initializer for union") end - | _ -> + | _ -> E.s (warn "Type of Compound is not array or struct or union")); ct end) () (* The arguments of withContext *) -and checkInitType (i: init) (t: typ) : unit = +and checkInitType (i: init) (t: typ) : unit = let it = checkInit i in typeMatch it t - -and checkStmt (s: stmt) = - E.withContext - (fun _ -> + +and checkStmt (s: stmt) = + E.withContext + (fun _ -> (* Print context only for certain small statements *) - match s.skind with + match s.skind with Loop _ | If _ | Switch _ -> nil | _ -> dprintf "checkStmt: %a" d_stmt s) - (fun _ -> + (fun _ -> (* Check the labels *) let checkLabel = function - Label (ln, l, _) -> + Label (ln, l, _) -> if H.mem labels ln then ignore (warn "Multiply defined label %s" ln); H.add labels ln () - | Case (e, _) -> + | Case (e, _) -> let t = checkExp true e in if not (isIntegralType t) then E.s (bug "Type of case expression is not integer"); @@ -733,20 +745,20 @@ and checkStmt (s: stmt) = in List.iter checkLabel s.labels; (* See if we have seen this statement before *) - if List.memq s !statements then + if List.memq s !statements then ignore (warn "Statement is shared"); (* Remember that we have seen this one *) statements := s :: !statements; match s.skind with Break _ | Continue _ -> () - | Goto (gref, l) -> + | Goto (gref, l) -> currentLoc := l; (* Find a label *) - let lab = - match List.filter (function Label _ -> true | _ -> false) + let lab = + match List.filter (function Label _ -> true | _ -> false) !gref.labels with Label (lab, _, _) :: _ -> lab - | _ -> + | _ -> ignore (warn "Goto to block without a label"); "" in @@ -766,13 +778,13 @@ and checkStmt (s: stmt) = end | Loop (b, l, _, _) -> checkBlock b | Block b -> checkBlock b - | If (e, bt, bf, l) -> + | If (e, bt, bf, l) -> currentLoc := l; let te = checkExp false e in checkScalarType te; checkBlock bt; checkBlock bf - | Switch (e, b, cases, l) -> + | Switch (e, b, cases, l) -> currentLoc := l; let t = checkExp false e in if not (isIntegralType t) then @@ -784,16 +796,16 @@ and checkStmt (s: stmt) = and that no case is listed twice. *) let casesVisited : stmt list ref = ref [] in List.iter - (fun c -> + (fun c -> (if List.memq c !casesVisited then - ignore (warnContext + ignore (warnContext "Duplicate stmt in \"cases\" list of Switch.") else casesVisited := c::!casesVisited); (* Make sure it is in there *) let rec findCase = function | l when l == prevStatements -> (* Not found *) - ignore (warnContext + ignore (warnContext "Cannot find target of switch statement") | [] -> E.s (E.bug "Check: findCase") | c' :: rest when c == c' -> () (* Found *) @@ -801,12 +813,12 @@ and checkStmt (s: stmt) = in findCase !statements) cases; - | TryFinally (b, h, l) -> + | TryFinally (b, h, l) -> currentLoc := l; checkBlock b; checkBlock h - | TryExcept (b, (il, e), h, l) -> + | TryExcept (b, (il, e), h, l) -> currentLoc := l; checkBlock b; List.iter checkInstr il; @@ -816,15 +828,15 @@ and checkStmt (s: stmt) = | Instr il -> List.iter checkInstr il) () (* argument of withContext *) -and checkBlock (b: block) : unit = +and checkBlock (b: block) : unit = List.iter checkStmt b.bstmts -and checkInstr (i: instr) = +and checkInstr (i: instr) = if !ignoreInstr i then () else - match i with - | Set (dest, e, l) -> + match i with + | Set (dest, e, l) -> currentLoc := l; let t = checkLval false false dest in (* Not all types can be assigned to *) @@ -834,10 +846,10 @@ and checkInstr (i: instr) = | TVoid _ -> ignore (warn "Assignment to a void type") | _ -> ()); checkExpType false e t - - | Call(dest, what, args, l) -> + + | Call(dest, what, args, l) -> currentLoc := l; - let (rt, formals, isva, fnAttrs) = + let (rt, formals, isva, fnAttrs) = match unrollType (checkExp false what) with TFun(rt, formals, isva, fnAttrs) -> rt, formals, isva, fnAttrs | _ -> E.s (bug "Call to a non-function") @@ -849,7 +861,7 @@ and checkInstr (i: instr) = | Some _, TVoid [Attr ("overloaded", [])] -> () | Some _, TVoid _ -> ignore (warn "void value is assigned") | None, _ -> () (* "Call of function is not assigned" *) - | Some destlv, rt' -> + | Some destlv, rt' -> let desttyp = checkLval false false destlv in if typeSig desttyp <> typeSig rt then begin if not !Cabs2cil.doCollapseCallCast then @@ -867,28 +879,32 @@ and checkInstr (i: instr) = | TFun _ -> ignore (warn "Cast of a function type") | TComp _ -> ignore (warn "Cast of a composite type") | TVoid _ -> ignore (warn "Cast of a void type") - + | _ -> ()) end); (* Now check the arguments *) - let rec loopArgs formals args = + let rec loopArgs formals args = match formals, args with [], _ when (isva || args = []) -> () - | (fn,ft,_) :: formals, a :: args -> + | (fn,ft,_) :: formals, a :: args -> checkExpType false a ft; loopArgs formals args | _, _ -> ignore (warn "Not enough arguments") in if formals <> None then loopArgs (argsToList formals) args - + + | VarDecl (v,_) -> + if not v.vhasdeclinstruction then + E.s (bug "Encountered a VarDecl, but vhasdeclinstruction for the varinfo is not set") + | Asm _ -> () (* Not yet implemented *) - + let rec checkGlobal = function GAsm _ -> () | GPragma _ -> () | GText _ -> () - | GType (ti, l) -> + | GType (ti, l) -> currentLoc := l; E.withContext (fun _ -> dprintf "GType(%s)" ti.tname) (fun _ -> @@ -896,33 +912,33 @@ let rec checkGlobal = function if ti.tname <> "" then defineName ti.tname) () - | GCompTag (comp, l) -> + | GCompTag (comp, l) -> currentLoc := l; checkCompInfo Defined comp; - | GCompTagDecl (comp, l) -> + | GCompTagDecl (comp, l) -> currentLoc := l; checkCompInfo Forward comp; - | GEnumTag (enum, l) -> + | GEnumTag (enum, l) -> currentLoc := l; checkEnumInfo Defined enum - | GEnumTagDecl (enum, l) -> + | GEnumTagDecl (enum, l) -> currentLoc := l; checkEnumInfo Forward enum - | GVarDecl (vi, l) -> + | GVarDecl (vi, l) -> currentLoc := l; (* We might have seen it already *) E.withContext (fun _ -> dprintf "GVarDecl(%s)" vi.vname) - (fun _ -> - (* If we have seen this vid already then it must be for the exact + (fun _ -> + (* If we have seen this vid already then it must be for the exact * same varinfo *) if H.mem varIdsEnv vi.vid then checkVariable vi else begin - defineVariable vi; + defineVariable vi; checkAttributes vi.vattr; checkType vi.vtype CTDecl; if not (vi.vglob && @@ -930,12 +946,12 @@ let rec checkGlobal = function E.s (bug "Invalid declaration of %s" vi.vname) end) () - - | GVar (vi, init, l) -> + + | GVar (vi, init, l) -> currentLoc := l; (* Maybe this is the first occurrence *) E.withContext (fun _ -> dprintf "GVar(%s)" vi.vname) - (fun _ -> + (fun _ -> checkGlobal (GVarDecl (vi, l)); (* Check the initializer *) if vi.vinit != init then @@ -949,7 +965,7 @@ let rec checkGlobal = function E.s (bug "GVar for a function (%s)\n" vi.vname); ) () - + | GFun (fd, l) -> begin currentLoc := l; @@ -957,29 +973,29 @@ let rec checkGlobal = function let vi = fd.svar in let fname = vi.vname in E.withContext (fun _ -> dprintf "GFun(%s)" fname) - (fun _ -> + (fun _ -> checkGlobal (GVarDecl (vi, l)); - (* Check that the argument types in the type are identical to the + (* Check that the argument types in the type are identical to the * formals *) - let rec loopArgs targs formals = + let rec loopArgs targs formals = match targs, formals with [], [] -> () - | (fn, ft, fa) :: targs, fo :: formals -> - if fn <> fo.vname then - ignore (warnContext - "Formal %s not shared (expecting name %s) in %s" + | (fn, ft, fa) :: targs, fo :: formals -> + if fn <> fo.vname then + ignore (warnContext + "Formal %s not shared (expecting name %s) in %s" fo.vname fn fname); E.withContext (fun () -> text "formal "++ text fo.vname) (fun () -> typeMatch ft fo.vtype) (); - if fa != fo.vattr then - ignore (warnContext - "Formal %s not shared (different attrs) in %s" + if fa != fo.vattr then + ignore (warnContext + "Formal %s not shared (different attrs) in %s" fo.vname fname); loopArgs targs formals - | _ -> - E.s (bug "Type has different number of formals for %s" + | _ -> + E.s (bug "Type has different number of formals for %s" fname) in begin match unrollType vi.vtype with @@ -987,7 +1003,7 @@ let rec checkGlobal = function currentReturnType := rt; loopArgs (argsToList args) fd.sformals end - | _ -> E.s (bug "Function %s does not have a function type" + | _ -> E.s (bug "Function %s does not have a function type" fname) end; ignore (fd.smaxid >= 0 || E.s (bug "smaxid < 0 for %s" fname)); @@ -995,7 +1011,7 @@ let rec checkGlobal = function begin try startEnv (); (* Do the locals *) - let doLocal tctx v = + let doLocal tctx v = if v.vglob then ignore (warnContext "Local %s has the vglob flag set" v.vname); @@ -1014,8 +1030,8 @@ let rec checkGlobal = function checkBlock fd.sbody; H.clear labels; (* Now verify that we have scanned all targets *) - List.iter - (fun (lab, t) -> if not (List.memq t !statements) then + List.iter + (fun (lab, t) -> if not (List.memq t !statements) then ignore (warnContext "Target of \"goto %s\" statement does not appear in function body" lab)) !gotoTargets; @@ -1023,7 +1039,7 @@ let rec checkGlobal = function gotoTargets := []; (* Done *) endEnv () - with e -> + with e -> endEnv (); raise e end; @@ -1032,10 +1048,10 @@ let rec checkGlobal = function end -let checkFile flags fl = +let checkFile flags fl = if !E.verboseFlag then ignore (E.log "Checking file %s\n" fl.fileName); valid := true; - List.iter + List.iter (function NoCheckGlobalIds -> checkGlobalIds := false | IgnoreInstructions f -> ignoreInstr := f @@ -1043,22 +1059,22 @@ let checkFile flags fl = flags; iterGlobals fl (fun g -> try checkGlobal g with _ -> ()); (* Check that for all struct/union tags there is a definition *) - H.iter - (fun k (comp, isadef) -> - if !isadef = Used then + H.iter + (fun k (comp, isadef) -> + if !isadef = Used then begin valid := false; - ignore (E.warn "Compinfo %s is referenced but not defined" + ignore (E.warn "Compinfo %s is referenced but not defined" (compFullName comp)) end) compUsed; (* Check that for all enum tags there is a definition *) - H.iter - (fun k (enum, isadef) -> - if !isadef = Used then + H.iter + (fun k (enum, isadef) -> + if !isadef = Used then begin valid := false; - ignore (E.warn "Enuminfo %s is referenced but not defined" + ignore (E.warn "Enuminfo %s is referenced but not defined" enum.ename) end) enumUsed; @@ -1072,7 +1088,6 @@ let checkFile flags fl = H.clear enumUsed; H.clear typUsed; varNamesList := []; - if !E.verboseFlag then + if !E.verboseFlag then ignore (E.log "Finished checking file %s\n" fl.fileName); !valid - diff --git a/src/cil.ml b/src/cil.ml index 63da92793..40f16c2ce 100755 --- a/src/cil.ml +++ b/src/cil.ml @@ -6,7 +6,7 @@ * 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: @@ -51,7 +51,7 @@ module IH = Inthash * *) -(* The module Cilversion is generated automatically by Makefile from +(* The module Cilversion is generated automatically by Makefile from * information in configure.in *) let cilVersion = Cilversion.cilVersion let cilVersionMajor = Cilversion.cilVersionMajor @@ -59,11 +59,17 @@ let cilVersionMinor = Cilversion.cilVersionMinor let cilVersionRevision = Cilversion.cilVersionRev (* A few globals that control the interpretation of C source *) -let msvcMode = ref false (* Whether the pretty printer should - * print output for the MS VC +let msvcMode = ref false (* Whether the pretty printer should + * print output for the MS VC * compiler. Default is GCC *) -let c99Mode = ref false (* True to handle ISO C 99 vs 90 changes. - So far only affects integer parsing. *) +let c99Mode = ref true (* True to handle ISO C 99 vs 90 changes. + c99mode only affects parsing of decimal integer constants without suffix + a) on machines where long and long long do not have the same size + (e.g. 32 Bit machines, 64 Bit Windows, not 64 Bit MacOS or (most? all?) 64 Bit Linux): + giving constants that are bigger than max long type long long in c99mode vs. unsigned long + if c99mode is off. + b) for constants bigger than long long producing a "Unimplemented: Cannot represent the integer" + warning in C99 mode vs. unsigned long long if c99mode is off. *) (* Set this to true to get old-style handling of gcc's extern inline C extension: old-style: the extern inline definition is used until the actual definition is @@ -90,6 +96,7 @@ let envMachine : M.mach option ref = ref None let lowerConstants: bool ref = ref true (** Do lower constants (default true) *) + let insertImplicitCasts: bool ref = ref true (** Do insert implicit casts (default true) *) @@ -99,26 +106,26 @@ let char_is_unsigned = ref false let underscore_name = ref false type lineDirectiveStyle = - | LineComment (** Before every element, print the line - * number in comments. This is ignored by - * processing tools (thus errors are reproted - * in the CIL output), but useful for + | LineComment (** Before every element, print the line + * number in comments. This is ignored by + * processing tools (thus errors are reproted + * in the CIL output), but useful for * visual inspection *) - | LineCommentSparse (** Like LineComment but only print a line + | LineCommentSparse (** Like LineComment but only print a line * directive for a new source line *) | LinePreprocessorInput (** Use #line directives *) | LinePreprocessorOutput (** Use # nnn directives (in gcc mode) *) let lineDirectiveStyle = ref (Some LinePreprocessorInput) - + let print_CIL_Input = ref false - + let printCilAsIs = ref false let lineLength = ref 80 let warnTruncate = ref true - + (* sm: return the string 's' if we're printing output for gcc, suppres * it if we're printing for CIL to parse back in. the purpose is to * hide things from gcc that it complains about, but still be able @@ -132,147 +139,147 @@ let debugConstFold = false (** The Abstract Syntax of CIL *) -(** The top-level representation of a CIL source file. Its main contents is +(** The top-level representation of a CIL source file. Its main contents is the list of global declarations and definitions. *) -type file = +type file = { mutable fileName: string; (** The complete file name *) - mutable globals: global list; (** List of globals as they will appear + 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} + 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 + 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. *) - } + } and comment = location * string -(** 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 +(** 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. *) and global = - | GType of typeinfo * location - (** A typedef. All uses of type names (through the [TNamed] constructor) - must be preceeded in the file by a definition of the name. The string + | 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 + | 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 + (** 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 + (** 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 + (** 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). If the variable has a - function type then this is a prototype. There can be several - declarations and at most one definition for a given variable. If both - forms appear then they must share the same varinfo structure. A - prototype shares the varinfo with the fundec of the definition. Either + (** A variable declaration (not a definition). If the variable has a + function type then this is a prototype. There can be several + declarations and at most one definition for a given variable. If both + forms appear then they must share the same varinfo structure. A + prototype shares the varinfo with the fundec of the definition. Either has storage Extern or there must be a definition in this file *) | GVar of varinfo * initinfo * location - (** A variable definition. Can have an initializer. The initializer is - * updateable so that you can change it without requiring to recreate - * the list of globals. There can be at most one definition for a - * variable in an entire program. Cannot have storage Extern or function + (** 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 + | GFun of fundec * location (** A function definition. *) - | GAsm of string * location (** Global asm statement. These ones + | 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 + | 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 + | GText of string (** Some text (printed verbatim) at + top level. E.g., this way you can put comments in the output. *) -(** The various types available. 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} to see through the uses +(** The various types available. 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} to see through the uses * of named types. *) and typ = TVoid of attributes (** Void type *) - | TInt of ikind * attributes (** An integer type. The kind specifies + | TInt of ikind * attributes (** An integer type. The kind specifies the sign and width. *) - | TFloat of fkind * attributes (** A floating-point type. The kind + | TFloat of fkind * attributes (** A floating-point type. The kind specifies the precision. *) - | TPtr of typ * attributes + | TPtr of typ * attributes (** Pointer type. *) | TArray of typ * exp option * 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 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. *) - | TNamed of typeinfo * attributes - (** The use of a named type. All uses of the same type name must - * share the typeinfo. Each such type name must be preceeded - * in the file by a [GType] global. This is printed as just the - * type name. The actual referred type is not printed here and is - * carried only to simplify processing. To see through a sequence - * of named type references, use {!Cil.unrollType}. The attributes + | 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 * attributes - (** A reference to a struct or a union type. All references to the - same struct or union must share the same compinfo among them and - with a [GCompTag] global that preceeds all uses (except maybe - those that are pointers to the composite type). The attributes - given are those pertaining to this use of the type and are in - addition to the attributes that were given at the definition of + (** 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 - preceeds all uses. The attributes refer to this use of the - enumeration and are in addition to the attributes of the + 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 = +and ikind = IChar (** [char] *) | ISChar (** [signed char] *) | IUChar (** [unsigned char] *) @@ -284,14 +291,17 @@ and ikind = | ILong (** [long] *) | IULong (** [unsigned long] *) | ILongLong (** [long long] (or [_int64] on Microsoft Visual C) *) - | IULongLong (** [unsigned long long] (or [unsigned _int64] on Microsoft + | 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] *) +and fkind = + FFloat (** [float] *) + | FDouble (** [double] *) + | FLongDouble (** [long double] *) + | FComplexFloat (** [float _Complex] *) + | FComplexDouble (** [double _Complex] *) + | FComplexLongDouble (** [long double _Complex]*) (** An attribute has a name and some optional parameters *) and attribute = Attr of string * attrparam list @@ -300,13 +310,13 @@ and attribute = Attr of string * attrparam list and attributes = attribute list (** The type of parameters in attributes *) -and attrparam = +and attrparam = | AInt of int (** 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 + | 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 @@ -325,47 +335,47 @@ and attrparam = | AQuestion of attrparam * attrparam * attrparam (** a1 ? a2 : a3 **) -(** Information about a composite type (a struct or a union). Use - {!Cil.mkCompInfo} - to create non-recursive or (potentially) recursive versions of this. Make +(** Information about a composite type (a struct or a union). Use + {!Cil.mkCompInfo} + to create non-recursive or (potentially) recursive versions of this. Make sure you have a [GCompTag] for each one of these. *) and compinfo = { mutable cstruct: bool; (** True if struct, False if union *) - mutable cname: string; (** The name. Always non-empty. Use - * {!Cil.compFullName} to get the - * full name of a comp (along with + 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 constructed from - * the name. Use {!Hashtbl.hash} on - * the string returned by - * {!Cil.compFullName}. All compinfo + mutable ckey: int; (** A unique integer constructed from + * the name. Use {!Hashtbl.hash} on + * the string returned by + * {!Cil.compFullName}. All compinfo * for a given key are shared. *) - mutable cfields: fieldinfo list; (** Information about the fields *) + mutable cfields: fieldinfo list; (** Information about the fields *) mutable cattr: attributes; (** The attributes that are defined at the same time as the composite type *) - mutable cdefined: bool; (** Whether this is a defined + mutable cdefined: bool; (** Whether this is a defined * compinfo. *) - mutable creferenced: bool; (** True if used. Initially set to + mutable creferenced: bool; (** True if used. Initially set to * false *) } (** Information about a struct/union field *) -and fieldinfo = { - mutable fcomp: compinfo; (** The compinfo of the host. Note - that this must be shared with the - host since there can be only one +and fieldinfo = { + mutable fcomp: compinfo; (** The compinfo of the host. Note + that this must be shared with the + host since there can be only one compinfo for a given id *) - 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 + 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 *) - mutable fbitfield: int option; (** If a bitfield then ftype should be + mutable fbitfield: int option; (** If a bitfield then ftype should be an integer type *) - mutable fattr: attributes; (** The attributes for this field + mutable fattr: attributes; (** The attributes for this field * (not for its type) *) mutable floc: location; (** The location where this field * is defined *) @@ -383,7 +393,7 @@ and enuminfo = { non-empty. The item values must be compile-time - constants. *) + constants. *) mutable eattr: attributes; (** Attributes *) mutable ereferenced: bool; (** True if used. Initially set to false*) mutable ekind: ikind; @@ -393,36 +403,35 @@ and enuminfo = { (** Information about a defined type *) and typeinfo = { - mutable tname: string; - (** The name. Can be empty only in a [GType] when introducing a composite - * or enumeration tag. If empty cannot be refered to from the file *) + mutable 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. *) - mutable treferenced: bool; + mutable treferenced: bool; (** True if used. Initially set to false*) } -(** Information about a variable. These structures are shared by all - * references to the variable. So, you can change the name easily, for - * example. Use one of the {!Cil.makeLocalVar}, {!Cil.makeTempVar} or +(** Information about a variable. These structures are shared by all + * references to the variable. So, you can change the name easily, for + * example. Use one of the {!Cil.makeLocalVar}, {!Cil.makeTempVar} or * {!Cil.makeGlobalVar} to create instances of this data structure. *) -and varinfo = { - mutable vname: string; (** The name of the variable. Cannot +and varinfo = { + mutable vname: string; (** The name of the variable. Cannot * be empty. *) - mutable vtype: typ; (** The declared type of the + mutable vtype: typ; (** The declared type of the * variable. *) - mutable vattr: attributes; (** A list of attributes associated + mutable vattr: attributes; (** A list of attributes associated * with the variable. *) mutable vstorage: storage; (** The storage-class *) - (* The other fields are not used in varinfo when they appear in the formal + (* The other fields are not used in varinfo when they appear in the formal * argument list in a [TFun] type *) mutable vglob: bool; (** True if this is a global variable*) - (** Whether this varinfo is for an inline function. *) - mutable vinline: bool; + mutable vinline: bool; (** Whether this varinfo is for an inline function. *) mutable vdecl: location; (** Location of variable declaration *) @@ -433,15 +442,15 @@ and varinfo = { mutable vid: int; (** A unique integer identifier. *) 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 + 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 + mutable vreferenced: bool; (** True if this variable is ever + referenced. This is computed by + [removeUnusedVars]. It is safe to just initialize this to False *) mutable vdescr: doc; (** For most temporary variables, a @@ -459,43 +468,54 @@ and varinfo = { Printing a non-pure vdescr more than once may yield incorrect results. *) + mutable vhasdeclinstruction: bool; (** Indicates whether a VarDecl instruction + was generated for this variable. + Only applies to local variables. + Currently, this is relevant for when to + print the declaration. If this is + true, it might be incorrect to print the + declaration at the beginning of the + function, rather than were the VarDecl + instruction is. This was originally + introduced to handle VLAs. *) } (** Storage-class information *) -and storage = - NoStorage | (** The default storage. Nothing is +and storage = + NoStorage (** The default storage. Nothing is * printed *) - Static | - Register | - Extern + | Static + | Register + | Extern (** Expressions (Side-effect free)*) and exp = 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 + | 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 *) - + | Real of exp (** __real__() *) + | Imag of exp (** __imag__() *) | 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 + (** 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 (** Has [unsigned int] type *) - | AlignOfE of exp + | AlignOfE of exp - - | UnOp of unop * exp * typ (** Unary operation. Includes + + | 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 arithemtic + (** Binary operation. Includes the + type of the result. The arithmetic conversions are made explicit for the arguments *) | Question of exp * exp * exp * typ @@ -503,29 +523,29 @@ and exp = the type of the result *) | 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 + | 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)] *) | AddrOfLabel of stmt ref - | StartOf of lval (** There is no C correspondent for this. C has - * implicit coercions from an array to the address - * of the first element. [StartOf] is used in CIL to - * simplify type checking and is just an explicit - * form of the above mentioned implicit conversion. - * It is not printed. Given an lval of type - * [TArray(T)] produces an expression of type + | StartOf of lval (** There is no C correspondent for this. C has + * implicit coercions from an array to the address + * of the first element. [StartOf] is used in CIL to + * simplify type checking and is just an explicit + * form of the above mentioned implicit conversion. + * It is not printed. Given an lval of type + * [TArray(T)] produces an expression of type * [TPtr(T)]. *) (** Literal constants *) and constant = - | CInt64 of int64 * ikind * string option - (** Integer constant. Give the ikind (see ISO9899 6.1.3.2) - * and the textual representation, if available. Use - * {!Cil.integer} or {!Cil.kinteger} to create these. Watch - * out for integers that cannot be represented on 64 bits. + | CInt64 of int64 * ikind * string option + (** Integer constant. Give the ikind (see ISO9899 6.1.3.2) + * and the textual representation, if available. Use + * {!Cil.integer} or {!Cil.kinteger} to create these. Watch + * out for integers that cannot be represented on 64 bits. * OCAML does not give Overflow exceptions. *) | CStr of string (** String constant (of pointer type) *) | CWStr of int64 list (** Wide string constant (of type "wchar_t *") *) @@ -537,9 +557,9 @@ and constant = also the textual representation, if available *) | CEnum of exp * string * enuminfo - (** An enumeration constant with the given value, name, from the given - * enuminfo. This is not used if {!Cil.lowerEnum} is false (default). - * Use {!Cillower.lowerEnumVisitor} to replace these with integer + (** An enumeration constant with the given value, name, from the given + * enuminfo. This is not used if {!Cil.lowerEnum} is false (default). + * Use {!Cillower.lowerEnumVisitor} to replace these with integer * constants. *) (** Unary operators *) @@ -552,12 +572,12 @@ and unop = 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 + | 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 *) @@ -569,11 +589,11 @@ and binop = | Shiftrt (** shift right *) | Lt (** < (arithmetic comparison) *) - | Gt (** > (arithmetic comparison) *) + | Gt (** > (arithmetic comparison) *) | Le (** <= (arithmetic comparison) *) | Ge (** > (arithmetic comparison) *) | Eq (** == (arithmetic comparison) *) - | Ne (** != (arithmetic comparison) *) + | Ne (** != (arithmetic comparison) *) | BAnd (** bitwise and *) | BXor (** exclusive-or *) | BOr (** inclusive-or *) @@ -584,48 +604,48 @@ and binop = -(** 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 +(** 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.*) and lval = lhost * offset (** The host part of an {!Cil.lval}. *) -and lhost = - | Var of varinfo +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 + | Mem of exp + (** The host is an object of type [T] when the expression has pointer * [TPtr(T)]. *) -(** The offset part of an {!Cil.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 +(** The offset part of an {!Cil.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. *) -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 +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 + | 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 + (** 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 *) @@ -635,94 +655,94 @@ and offset = (* Mem(AddrOf(Var v, aoff)), off = Var v, aoff + off *) (* AddrOf (Mem a, NoOffset) = a *) -(** Initializers for global variables. You can create an initializer with +(** Initializers for global variables. You can create an initializer with * {!Cil.makeZeroInit}. *) -and init = +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 + (** 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 + * 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 +(** 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; - } + } (** Function definitions. *) and fundec = - { mutable svar: varinfo; - (** Holds the name and type as a variable, so we can refer to it - * easily from the program. All references to this function either - * in a function call or in a prototype must point to the same + { 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 shared with the formals that appear 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. + mutable sformals: varinfo list; + (** Formals. These must be shared with the formals that appear 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 + 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. *) 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 + 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 * {!Cil.computeCFGInfo}. *) - mutable sallstmts: stmt list; (** After you call {!Cil.computeCFGInfo} - * this field is set to contain all + mutable sallstmts: stmt list; (** After you call {!Cil.computeCFGInfo} + * this field is set to contain all * statements in the function *) } -(** A block is a sequence of statements with the control falling through from +(** A block is a sequence of statements with the control falling through from one element to the next *) -and block = +and block = { mutable battrs: attributes; (** Attributes for the block *) mutable bstmts: stmt list; (** The statements comprising the block*) - } + } -(** Statements. - The statement is the structural unit in the control flow graph. Use mkStmt +(** Statements. + The statement is the structural unit in the control flow graph. Use mkStmt to make a statement and then fill in the fields. *) and stmt = { - mutable labels: label list; (** Whether the statement starts with - some labels, case statements or + mutable labels: label list; (** Whether the statement starts with + some labels, case statements or default statement *) mutable skind: stmtkind; (** The kind of statement *) - (* Now some additional control flow information. Initially this is not + (* Now some additional control flow information. Initially this is not * filled in. *) - mutable sid: int; (** A number (>= 0) that is unique + mutable sid: int; (** A number (>= 0) that is unique in a function. *) - mutable succs: stmt list; (** The successor statements. They can - always be computed from the skind - and the context in which this + mutable succs: stmt list; (** The successor statements. They can + always be computed from the skind + and the context in which this statement appears *) mutable preds: stmt list; (** The inverse of the succs function*) - } + } (** 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 +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 *) | CaseRange of exp * exp * location (** A case statement corresponding to a @@ -732,133 +752,137 @@ and label = (* The various kinds of statements *) -and stmtkind = - | Instr of instr list (** A group of instructions that do not +and stmtkind = + | Instr of instr list (** A group of instructions that do not contain control flow. Control implicitly falls through. *) - | Return of exp option * location (** The return statement. This is a + | Return of exp option * location (** The return statement. This is a leaf in the CFG. *) - | Goto of stmt ref * location (** A goto statement. Appears from + | Goto of stmt ref * location (** A goto statement. Appears from actual goto's in the code. *) - | ComputedGoto of exp * location + | ComputedGoto of exp * location - | Break of location (** A break to the end of the nearest + | Break of location (** A break to the end of the nearest enclosing Loop or Switch *) - | Continue of location (** A continue to the start of the + | Continue of location (** A continue to the start of the nearest enclosing [Loop] *) - | If of exp * block * block * location (** A conditional. - Two successors, the "then" and - the "else" branches. Both - branches fall-through to the + | If of exp * block * block * location (** A conditional. + Two successors, the "then" and + the "else" branches. Both + branches fall-through to the successor of the If statement *) - | Switch of exp * block * (stmt list) * location - (** A switch statement. The block - contains within all of the cases. - We also have direct pointers to the - statements that implement the - cases. Which cases they implement - you can get from the labels of the + | Switch of exp * block * (stmt list) * location + (** A switch statement. The block + contains within all of the cases. + We also have direct pointers to the + statements that implement the + cases. Which cases they implement + you can get from the labels of the statement *) - | Loop of 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 - * 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 + | Loop of 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 + * prepareCFG has been called, the + * first stmt option will point to + * the stmt containing the + * continue label for this loop + * and the second will point to + * the stmt containing the break * label for this loop. *) - | Block of block (** Just a block of statements. Use it - as a way to keep some attributes + | Block of block (** Just a block of statements. Use it + as a way to keep some attributes local *) - (** 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. The location - * corresponds to the try keyword. *) | TryFinally of block * block * location - - (** On MSVC we support structured exception handling. The try/except - * statement is a bit tricky: - __try { blk } + (** 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. The location + * corresponds to the try keyword. *) + | TryExcept of block * (instr list * exp) * block * location + (** On MSVC we support structured exception handling. The try/except + * statement is a bit tricky: + __try { blk } __except (e) { handler } - 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. - *) - | TryExcept of block * (instr list * exp) * block * location - + The argument to __except must be an expression. However, we keep a + list of instructions AND an expression in case you need to make + function calls. We'll print those as a comma expression. The control + can get to the __except expression only if an exception is thrown. + After that, depending on the value of the expression the control + goes to the handler, propagates the exception, or retries the + exception !!! The location corresponds to the try keyword. + *) (** Instructions. They may cause effects directly but may not have control flow.*) and instr = - Set of lval * exp * location (** An assignment. A cast is present - if the exp has different type + Set of lval * exp * location (** An assignment. A cast is present + if the exp has different type from lval *) + | VarDecl of varinfo * location (** "Instruction" in the location where a varinfo was declared. + All varinfos for which such a VarDecl instruction exists have + vhasdeclinstruction set to true. + The motivation for the addition of this instruction was to + support VLAs for which declarations can not be pulled up like + CIL used to do. *) | 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. If the function is declared then - casts are inserted for those arguments that - correspond to declared formals. (The actual - number of arguments might be smaller or larger - than the declared number of arguments. C allows - this.) If the type of the result variable is not - the same as the declared type of the function + (** 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. If the function is declared then + casts are inserted for those arguments that + correspond to declared formals. (The actual + number of arguments might be smaller or larger + than the declared number of arguments. C allows + this.) If the type of the result variable is not + the same as the declared type of the function result then an implicit cast exists. *) - (* See the GCC specification for the meaning of ASM. - * If the source is MS VC then only the templates + (* 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 + | Asm of attributes * (* Really only const and volatile can appear * here *) string list * (* templates (CR-separated) *) - (string option * string * lval) list * - (* outputs must be lvals with - * optional names and constraints. - * I would like these - * to be actually variables, but I - * run into some trouble with ASMs + (string option * string * lval) list * + (* outputs must be lvals with + * optional names and constraints. + * I would like these + * to be actually variables, but I + * run into some trouble with ASMs * in the Linux sources *) - (string option * string * exp) list * + (string option * string * exp) list * (* inputs with optional names and constraints *) string list * (* register clobbers *) location - (** An inline assembly instruction. The arguments are (1) a list of - attributes (only const and volatile can appear here and only for - GCC), (2) templates (CR-separated), (3) a list of - outputs, each of which is an lvalue with a constraint, (4) a list - of input expressions along with constraints, (5) clobbered + (** An inline assembly instruction. The arguments are (1) a list of + attributes (only const and volatile can appear here and only for + GCC), (2) templates (CR-separated), (3) a list of + outputs, each of which is an lvalue with a constraint, (4) a list + of input expressions along with constraints, (5) clobbered registers, and (5) location information *) (** Describes a location in a source file *) -and location = { +and location = { line: int; (** The line number. -1 means "do not know" *) file: string; (** The name of the source file*) byte: int; (** The byte position in the source file *) } -(* Type signatures. Two types are identical iff they have identical +(* Type signatures. Two types are identical iff they have identical * signatures *) -and typsig = +and typsig = TSArray of typsig * int64 option * attribute list | TSPtr of typsig * attribute list | TSComp of bool * string * attribute list @@ -866,8 +890,8 @@ and typsig = | TSEnum of string * attribute list | TSBase of typ -let locUnknown = { line = -1; - file = ""; +let locUnknown = { line = -1; + file = ""; byte = -1;} (* A reference to the current location *) @@ -879,123 +903,129 @@ let currentGlobal: global ref = ref (GText "dummy") let compareLoc (a: location) (b: location) : int = let namecmp = compare a.file b.file in - if namecmp != 0 + if namecmp != 0 then namecmp else let linecmp = a.line - b.line in - if linecmp != 0 + if linecmp != 0 then linecmp else a.byte - b.byte -let argsToList : (string * typ * attributes) list option - -> (string * typ * attributes) list +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 pd_exp : (unit -> exp -> doc) ref = +let pd_exp : (unit -> exp -> doc) ref = ref (fun _ -> E.s (E.bug "pd_exp not initialized")) -let pd_type : (unit -> typ -> doc) ref = +let pd_type : (unit -> typ -> doc) ref = ref (fun _ -> E.s (E.bug "pd_type not initialized")) -let pd_attr : (unit -> attribute -> doc) ref = +let pd_attr : (unit -> attribute -> doc) ref = ref (fun _ -> E.s (E.bug "pd_attr not initialized")) (** Different visiting actions. 'a will be instantiated with [exp], [instr], etc. *) -type 'a visitAction = - SkipChildren (** Do not visit the children. Return +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 + | DoChildren (** Continue with the children of this + node. Rebuild the node on return + if any of the children changes (use == test) *) - | ChangeTo of 'a (** Replace the expression with the + | ChangeTo of 'a (** Replace the expression with the given one *) - | 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 + | 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 *) (* 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 +(* 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 +(** A visitor interface for traversing CIL trees. Create instantiations of * this type by specializing the class {!Cil.nopCilVisitor}. *) class type cilVisitor = object - 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 + 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 + method vvrbl: varinfo -> varinfo visitAction + (** Invoked on each variable use. Here only the [SkipChildren] and + * [ChangeTo] actions make sense since there are no subtrees. Note that + * the type and attributes of the variable are not traversed for a * variable use *) - method vexpr: exp -> exp visitAction - (** Invoked on each expression occurence. The subtrees are the - * subexpressions, the types (for a [Cast] or [SizeOf] expression) or the + 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 occurence *) + method vlval: lval -> lval visitAction + (** Invoked on each lvalue occurrence *) - method voffs: offset -> offset visitAction + 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 + (** 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 + 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 + method vstmt: stmt -> stmt visitAction (** Control-flow statement. *) - method vblock: block -> block visitAction (** Block. Replaced in + method vblock: block -> block visitAction (** Block. Replaced in place. *) - method vfunc: fundec -> fundec visitAction (** Function definition. + + 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 + + method vinit: varinfo -> offset -> init -> init visitAction + (** Initializers for globals, + * pass the global where this * occurs, and the offset *) - method vtype: typ -> typ visitAction (** Use of some type. Note - * that for structure/union - * and enumeration types the - * definition of the - * composite type is not - * visited. Use [vglob] to + + 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 vattr: attribute -> attribute list visitAction + + method vattr: attribute -> attribute list visitAction (** Attribute. Each attribute can be replaced by a list *) - method vattrparam: attrparam -> attrparam visitAction + + method vattrparam: attrparam -> attrparam visitAction (** Attribute parameters. *) - (** Add here instructions while visiting to queue them to - * preceede the current statement or instruction being processed *) + (** 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 *) @@ -1007,15 +1037,15 @@ end (* not stop; hence they return true *) class nopCilVisitor : cilVisitor = object method vvrbl (v:varinfo) = DoChildren (* variable *) - method vvdec (v:varinfo) = DoChildren (* variable + method vvdec (v:varinfo) = DoChildren (* variable * declaration *) - method vexpr (e:exp) = DoChildren (* expression *) - method vlval (l:lval) = DoChildren (* lval (base is 1st + method vexpr (e:exp) = DoChildren (* expression *) + method vlval (l:lval) = DoChildren (* lval (base is 1st * field) *) method voffs (o:offset) = DoChildren (* lval or recursive offset *) method vinitoffs (o:offset) = DoChildren (* initializer offset *) method vinst (i:instr) = DoChildren (* imperative instruction *) - method vstmt (s:stmt) = DoChildren (* constrol-flow statement *) + method vstmt (s:stmt) = DoChildren (* control-flow statement *) method vblock (b: block) = DoChildren method vfunc (f:fundec) = DoChildren (* function definition *) method vglob (g:global) = DoChildren (* global (vars, types, etc.) *) @@ -1025,11 +1055,11 @@ class nopCilVisitor : cilVisitor = object method vattrparam (a: attrparam) = DoChildren val mutable instrQueue = [] - - method queueInstr (il: instr list) = + + method queueInstr (il: instr list) = List.iter (fun i -> instrQueue <- i :: instrQueue) il - method unqueueInstr () = + method unqueueInstr () = let res = List.rev instrQueue in instrQueue <- []; res @@ -1037,7 +1067,7 @@ class nopCilVisitor : cilVisitor = object end let assertEmptyQueue vis = - if vis#unqueueInstr () <> [] then + 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. *) @@ -1055,13 +1085,13 @@ let startsWith (prefix: string) (s: string) : bool = (String.sub s 0 prefixLen) = prefix ) -let endsWith (suffix: string) (s: string) : bool = +let endsWith (suffix: string) (s: string) : bool = let suffixLen = String.length suffix in let sLen = String.length s in - sLen >= suffixLen && + sLen >= suffixLen && (String.sub s (sLen - suffixLen) suffixLen) = suffix -let stripUnderscores (s: string) : string = +let stripUnderscores (s: string) : string = if (startsWith "__" s) && (endsWith "__" s) then String.sub s 2 ((String.length s) - 4) else @@ -1072,22 +1102,23 @@ let get_instrLoc (inst : instr) = Set(_, _, loc) -> loc | Call(_, _, _, loc) -> loc | Asm(_, _, _, _, _, loc) -> loc + | VarDecl(_,loc) -> loc let get_globalLoc (g : global) = match g with | GFun(_,l) -> (l) | GType(_,l) -> (l) - | GEnumTag(_,l) -> (l) - | GEnumTagDecl(_,l) -> (l) - | GCompTag(_,l) -> (l) - | GCompTagDecl(_,l) -> (l) - | GVarDecl(_,l) -> (l) + | GEnumTag(_,l) -> (l) + | GEnumTagDecl(_,l) -> (l) + | GCompTag(_,l) -> (l) + | GCompTagDecl(_,l) -> (l) + | GVarDecl(_,l) -> (l) | GVar(_,_,l) -> (l) | GAsm(_,l) -> (l) - | GPragma(_,l) -> (l) + | GPragma(_,l) -> (l) | GText(_) -> locUnknown let rec get_stmtLoc (statement : stmtkind) = - match statement with + match statement with Instr([]) -> lu | Instr(hd::tl) -> get_instrLoc(hd) | Return(_, loc) -> loc @@ -1098,7 +1129,7 @@ let rec get_stmtLoc (statement : stmtkind) = | If(_, _, _, loc) -> loc | Switch (_, _, _, loc) -> loc | Loop (_, loc, _, _) -> loc - | Block b -> if b.bstmts == [] then lu + | Block b -> if b.bstmts == [] then lu else get_stmtLoc ((List.hd b.bstmts).skind) | TryFinally (_, _, l) -> l | TryExcept (_, _, _, l) -> l @@ -1107,93 +1138,93 @@ let rec get_stmtLoc (statement : stmtkind) = (* The next variable identifier to use. Counts up *) let nextGlobalVID = ref 1 -(* The next compindo identifier to use. Counts up. *) +(* The next compinfo identifier to use. Counts up. *) let nextCompinfoKey = ref 1 (* Some error reporting functions *) -let d_loc (_: unit) (loc: location) : doc = +let d_loc (_: unit) (loc: location) : doc = text loc.file ++ chr ':' ++ num loc.line let d_thisloc (_: unit) : doc = d_loc () !currentLoc -let error (fmt : ('a,unit,doc) format) : 'a = - let f d = - E.hadErrors := true; - ignore (eprintf "%t: Error: %a@!" +let error (fmt : ('a,unit,doc) format) : 'a = + let f d = + E.hadErrors := true; + ignore (eprintf "%t: Error: %a@!" d_thisloc insert d); nil in Pretty.gprintf f fmt -let unimp (fmt : ('a,unit,doc) format) : 'a = - let f d = - E.hadErrors := true; - ignore (eprintf "%t: Unimplemented: %a@!" +let unimp (fmt : ('a,unit,doc) format) : 'a = + let f d = + E.hadErrors := true; + ignore (eprintf "%t: Unimplemented: %a@!" d_thisloc insert d); nil in Pretty.gprintf f fmt -let bug (fmt : ('a,unit,doc) format) : 'a = - let f d = - E.hadErrors := true; - ignore (eprintf "%t: Bug: %a@!" +let bug (fmt : ('a,unit,doc) format) : 'a = + let f d = + E.hadErrors := true; + ignore (eprintf "%t: Bug: %a@!" d_thisloc insert d); E.showContext (); nil in Pretty.gprintf f fmt -let errorLoc (loc: location) (fmt : ('a,unit,doc) format) : 'a = - let f d = - E.hadErrors := true; - ignore (eprintf "%a: Error: %a@!" +let errorLoc (loc: location) (fmt : ('a,unit,doc) format) : 'a = + let f d = + E.hadErrors := true; + ignore (eprintf "%a: Error: %a@!" d_loc loc insert d); E.showContext (); nil in Pretty.gprintf f fmt -let warn (fmt : ('a,unit,doc) format) : 'a = +let warn (fmt : ('a,unit,doc) format) : 'a = let f d = - ignore (eprintf "%t: Warning: %a@!" + ignore (eprintf "%t: Warning: %a@!" d_thisloc insert d); nil in Pretty.gprintf f fmt -let warnOpt (fmt : ('a,unit,doc) format) : 'a = +let warnOpt (fmt : ('a,unit,doc) format) : 'a = let f d = - if !E.warnFlag then - ignore (eprintf "%t: Warning: %a@!" + if !E.warnFlag then + ignore (eprintf "%t: Warning: %a@!" d_thisloc insert d); nil in Pretty.gprintf f fmt -let warnContext (fmt : ('a,unit,doc) format) : 'a = +let warnContext (fmt : ('a,unit,doc) format) : 'a = let f d = - ignore (eprintf "%t: Warning: %a@!" + ignore (eprintf "%t: Warning: %a@!" d_thisloc insert d); E.showContext (); nil in Pretty.gprintf f fmt -let warnContextOpt (fmt : ('a,unit,doc) format) : 'a = +let warnContextOpt (fmt : ('a,unit,doc) format) : 'a = let f d = - if !E.warnFlag then - ignore (eprintf "%t: Warning: %a@!" + if !E.warnFlag then + ignore (eprintf "%t: Warning: %a@!" d_thisloc insert d); E.showContext (); nil in Pretty.gprintf f fmt -let warnLoc (loc: location) (fmt : ('a,unit,doc) format) : 'a = +let warnLoc (loc: location) (fmt : ('a,unit,doc) format) : 'a = let f d = - ignore (eprintf "%a: Warning: %a@!" + ignore (eprintf "%a: Warning: %a@!" d_loc loc insert d); E.showContext (); nil @@ -1205,27 +1236,27 @@ let zero = Const(CInt64(Int64.zero, IInt, None)) (** Given the character c in a (CChr c), sign-extend it to 32 bits. (This is the official way of interpreting character constants, according to ISO C 6.4.4.4.10, which says that character constants are chars cast to ints) - Returns CInt64(sign-extened c, IInt, None) *) + Returns CInt64(sign-extended c, IInt, None) *) let charConstToInt (c: char) : constant = let c' = Char.code c in - let value = - if c' < 128 + let value = + if c' < 128 then Int64.of_int c' else Int64.of_int (c' - 256) in CInt64(value, IInt, None) - - + + (** Convert a 64-bit int to an OCaml int, or raise an exception if that can't be done. *) -let i64_to_int (i: int64) : int = +let i64_to_int (i: int64) : int = let i': int = Int64.to_int i in (* i.e. i' = i mod 2^31 *) if i = Int64.of_int i' then i' else E.s (E.unimp "%a: Int constant too large: %Ld\n" d_loc !currentLoc i) -let cilint_to_int (i: cilint) : int = - try int_of_cilint i - with _ -> E.s (E.unimp "%a: Int constant too large: %s\n" +let cilint_to_int (i: cilint) : int = + try int_of_cilint i + with _ -> E.s (E.unimp "%a: Int constant too large: %s\n" d_loc !currentLoc (string_of_cilint i)) let voidType = TVoid([]) @@ -1249,14 +1280,14 @@ let doubleType = TFloat(FDouble, []) (* An integer type that fits pointers. Initialized by initCIL *) -let upointType = ref voidType +let upointType = ref voidType (* An integer type that fits a pointer difference. Initialized by initCIL *) let ptrdiffType = ref voidType (* An integer type that fits wchar_t. Initialized by initCIL *) let wcharKind = ref IChar -let wcharType = ref voidType +let wcharType = ref voidType (* An integer type that is the type of sizeof. Initialized by initCIL *) @@ -1283,12 +1314,12 @@ let isSigned = function | IChar -> not !M.theMachine.M.char_is_unsigned -let mkStmt (sk: stmtkind) : stmt = +let mkStmt (sk: stmtkind) : stmt = { skind = sk; labels = []; sid = -1; succs = []; preds = [] } -let mkBlock (slst: stmt list) : block = +let mkBlock (slst: stmt list) : block = { battrs = []; bstmts = slst; } let mkEmptyStmt () = mkStmt (Instr []) @@ -1297,32 +1328,32 @@ let mkStmtOneInstr (i: instr) = mkStmt (Instr [i]) let dummyInstr = (Asm([], ["dummy statement!!"], [], [], [], lu)) let dummyStmt = mkStmt (Instr [dummyInstr]) -let compactStmts (b: stmt list) : stmt list = - (* Try to compress statements. Scan the list of statements and remember - * the last instrunction statement encountered, along with a Clist of +let compactStmts (b: stmt list) : stmt list = + (* Try to compress statements. Scan the list of statements and remember + * the last instrunction statement encountered, along with a Clist of * instructions in it. *) let rec compress (lastinstrstmt: stmt) (* Might be dummStmt *) - (lastinstrs: instr Clist.clist) + (lastinstrs: instr Clist.clist) (body: stmt list) = - let finishLast (tail: stmt list) : stmt list = + let finishLast (tail: stmt list) : stmt list = if lastinstrstmt == dummyStmt then tail else begin lastinstrstmt.skind <- Instr (Clist.toList lastinstrs); lastinstrstmt :: tail end in - match body with + match body with [] -> finishLast [] - | ({skind=Instr il} as s) :: rest -> + | ({skind=Instr il; _} as s) :: rest -> let ils = Clist.fromList il in if lastinstrstmt != dummyStmt && s.labels == [] then compress lastinstrstmt (Clist.append lastinstrs ils) rest else finishLast (compress s ils rest) - | {skind=Block b;labels = []} :: rest when b.battrs = [] -> + | {skind=Block b;labels = []; _} :: rest when b.battrs = [] -> compress lastinstrstmt lastinstrs (b.bstmts@rest) - | s :: rest -> + | s :: rest -> let res = s :: compress dummyStmt Clist.empty rest in finishLast res in @@ -1330,29 +1361,29 @@ let compactStmts (b: stmt list) : stmt list = (** Construct sorted lists of attributes ***) -let rec addAttribute (Attr(an, _) as a: attribute) (al: attributes) = +let rec addAttribute (Attr(an, _) as a: attribute) (al: attributes) = let rec insertSorted = function [] -> [a] - | ((Attr(an0, _) as a0) :: rest) as l -> + | ((Attr(an0, _) as a0) :: rest) as l -> if an < an0 then a :: l else if Util.equals a a0 then l (* Do not add if already in there *) - else a0 :: insertSorted rest (* Make sure we see all attributes with + else a0 :: insertSorted rest (* Make sure we see all attributes with * this name *) in insertSorted al (** The second attribute list is sorted *) -and addAttributes al0 (al: attributes) : attributes = +and addAttributes al0 (al: attributes) : attributes = if al0 == [] then al else List.fold_left (fun acc a -> addAttribute a acc) al al0 -and dropAttribute (an: string) (al: attributes) = +and dropAttribute (an: string) (al: attributes) = List.filter (fun (Attr(an', _)) -> an <> an') al -and dropAttributes (anl: string list) (al: attributes) = +and dropAttributes (anl: string list) (al: attributes) = List.fold_left (fun acc an -> dropAttribute an acc) al anl - -and filterAttributes (s: string) (al: attribute list) : attribute list = + +and filterAttributes (s: string) (al: attribute list) : attribute list = List.filter (fun (Attr(an, _)) -> an = s) al (* sm: *) @@ -1360,28 +1391,28 @@ let hasAttribute s al = (filterAttributes s al <> []) -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 +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 + | 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 +(* 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) H.t = +let attributeHash: (string, attributeClass) H.t = let table = H.create 13 in List.iter (fun a -> H.add table a (AttrName false)) - [ "section"; "constructor"; "destructor"; "unused"; "used"; "weak"; + [ "section"; "constructor"; "destructor"; "unused"; "used"; "weak"; "no_instrument_function"; "alias"; "no_check_memory_usage"; "exception"; "model"; (* "restrict"; *) - "aconst"; "__asm__" (* Gcc uses this to specifiy the name to be used in + "aconst"; "__asm__" (* Gcc uses this to specify the name to be used in * assembly for a global *)]; (* Now come the MSVC declspec attributes *) @@ -1391,7 +1422,7 @@ let attributeHash: (string, attributeClass) H.t = "uuid"; "align" ]; List.iter (fun a -> H.add table a (AttrFunType false)) - [ "format"; "regparm"; "longcall"; + [ "format"; "regparm"; "longcall"; "noinline"; "always_inline"; "gnu_inline"; "leaf"; "artificial"; "warn_unused_result"; "nonnull"; ]; @@ -1402,19 +1433,19 @@ let attributeHash: (string, attributeClass) H.t = List.iter (fun a -> H.add table a AttrType) [ "const"; "volatile"; "restrict"; "mode" ]; table - + (* Partition the attributes into classes *) -let partitionAttributes - ~(default:attributeClass) +let partitionAttributes + ~(default:attributeClass) (attrs: attribute list) : - attribute list * attribute list * attribute list = + attribute list * attribute list * attribute list = let rec loop (n,f,t) = function [] -> n, f, t - | (Attr(an, _) as a) :: rest -> - match (try H.find attributeHash an with Not_found -> default) with + | (Attr(an, _) as a) :: rest -> + match (try H.find attributeHash an with Not_found -> default) with AttrName _ -> loop (addAttribute a n, f, t) rest - | AttrFunType _ -> + | AttrFunType _ -> loop (n, addAttribute a f, t) rest | AttrType -> loop (n, f, addAttribute a t) rest in @@ -1422,40 +1453,40 @@ let partitionAttributes (* Get the full name of a comp *) -let compFullName comp = +let compFullName comp = (if comp.cstruct then "struct " else "union ") ^ comp.cname - + let missingFieldName = "___missing_field_name" -(** Creates a a (potentially recursive) composite type. Make sure you add a +(** Creates a a (potentially recursive) composite type. Make sure you add a * GTag for it to the file! **) let mkCompInfo - (isstruct: bool) - (n: string) - (* 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 + (isstruct: bool) + (n: string) + (* 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) + location) list) (a: attribute list) : compinfo = (* make a new name for anonymous structs *) - if n = "" then + if n = "" then E.s (E.bug "mkCompInfo: missing structure name\n"); (* Make a new self cell and a forward reference *) - let comp = + let comp = { cstruct = isstruct; cname = ""; ckey = 0; cfields = []; - cattr = a; creferenced = false; + cattr = a; creferenced = false; (* Make this compinfo undefined by default *) - cdefined = false; } + cdefined = false; } in comp.cname <- n; comp.ckey <- !nextCompinfoKey; incr nextCompinfoKey; - let flds = - Util.list_map (fun (fn, ft, fb, fa, fl) -> + let flds = + Util.list_map (fun (fn, ft, fb, fa, fl) -> { fcomp = comp; ftype = ft; fname = fn; @@ -1467,8 +1498,8 @@ let mkCompInfo comp (** Make a copy of a compinfo, changing the name and the key *) -let copyCompInfo (ci: compinfo) (n: string) : compinfo = - let ci' = {ci with cname = n; +let copyCompInfo (ci: compinfo) (n: string) : compinfo = + let ci' = {ci with cname = n; ckey = !nextCompinfoKey; } in incr nextCompinfoKey; (* Copy the fields and set the new pointers to parents *) @@ -1526,9 +1557,9 @@ begin | TBuiltin_va_list a -> TBuiltin_va_list (add a) end -let typeRemoveAttributes (anl: string list) t = +let typeRemoveAttributes (anl: string list) t = let drop (al: attributes) = dropAttributes anl al in - match t with + match t with TVoid a -> TVoid (drop a) | TInt (ik, a) -> TInt (ik, drop a) | TFloat (fk, a) -> TFloat (fk, drop a) @@ -1540,81 +1571,106 @@ let typeRemoveAttributes (anl: string list) t = | TNamed (t, a) -> TNamed (t, drop a) | TBuiltin_va_list a -> TBuiltin_va_list (drop a) -let unrollType (t: typ) : typ = - let rec withAttrs (al: attributes) (t: typ) : typ = - match t with +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 rec unrollTypeDeep (t: typ) : typ = - let rec withAttrs (al: attributes) (t: typ) : typ = - match t with +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, a') -> TArray(unrollTypeDeep t, l, addAttributes al a') - | TFun(rt, args, isva, a') -> - TFun (unrollTypeDeep rt, - (match args with + | TFun(rt, args, isva, a') -> + TFun (unrollTypeDeep rt, + (match args with None -> None - | Some argl -> - Some (Util.list_map (fun (an,at,aa) -> - (an, unrollTypeDeep at, aa)) argl)), - isva, + | Some argl -> + Some (Util.list_map (fun (an,at,aa) -> + (an, unrollTypeDeep at, aa)) argl)), + isva, addAttributes al a') | x -> typeAddAttributes al x in withAttrs [] t -let isVoidType t = +let isVoidType t = match unrollType t with TVoid _ -> true | _ -> false -let isVoidPtrType t = +let isVoidPtrType t = match unrollType t with TPtr(tau,_) when isVoidType tau -> true | _ -> false +(* get the typ of __real__(e) or __imag__(e) for e of typ t*) +let typeOfRealAndImagComponents t = + match unrollType t with + | TInt _ -> t + | TFloat (fkind, attrs) -> + let newfkind = function + | FFloat -> FFloat (* [float] *) + | FDouble -> FDouble (* [double] *) + | FLongDouble -> FLongDouble (* [long double] *) + | FComplexFloat -> FFloat + | FComplexDouble -> FDouble + | FComplexLongDouble -> FLongDouble + in + TFloat (newfkind fkind, attrs) + | _ -> E.s (E.bug "unexpected non-numerical type for argument to __real__") + +(** for an fkind, return the corresponding complex fkind *) +let getComplexFkind = function + | FFloat -> FComplexFloat + | FDouble -> FComplexDouble + | FLongDouble -> FComplexLongDouble + | FComplexFloat -> FComplexFloat + | FComplexDouble -> FComplexDouble + | FComplexLongDouble -> FComplexLongDouble + let var vi : lval = (Var vi, NoOffset) (* let assign vi e = Instrs(Set (var vi, e), lu) *) let mkString s = Const(CStr s) -let mkWhile ~(guard:exp) ~(body: stmt list) : stmt list = +let mkWhile ~(guard:exp) ~(body: stmt list) : stmt list = (* Do it like this so that the pretty printer recognizes it *) - [ mkStmt (Loop (mkBlock (mkStmt (If(guard, - mkBlock [ mkEmptyStmt () ], + [ mkStmt (Loop (mkBlock (mkStmt (If(guard, + mkBlock [ mkEmptyStmt () ], mkBlock [ mkStmt (Break lu)], lu)) :: body), lu, None, None)) ] -let mkFor ~(start: stmt list) ~(guard: exp) ~(next: stmt list) - ~(body: stmt list) : stmt list = - (start @ - (mkWhile guard (body @ next))) +let mkFor ~(start: stmt list) ~(guard: exp) ~(next: stmt list) + ~(body: stmt list) : stmt list = + (start @ + (mkWhile ~guard:guard ~body:(body @ next))) + - -let mkForIncr ~(iter : varinfo) ~(first: exp) ~stopat:(past: exp) ~(incr: exp) - ~(body: stmt list) : stmt list = +let mkForIncr ~(iter : varinfo) ~(first: exp) ~stopat:(past: exp) ~(incr: exp) + ~(body: stmt list) : stmt list = (* See what kind of operator we need *) - let compop, nextop = + let compop, nextop = match unrollType iter.vtype with TPtr _ -> Lt, PlusPI | _ -> Lt, PlusA in - mkFor - [ mkStmt (Instr [(Set (var iter, first, lu))]) ] - (BinOp(compop, Lval(var iter), past, intType)) - [ mkStmt (Instr [(Set (var iter, + mkFor + ~start:[ mkStmt (Instr [(Set (var iter, first, lu))]) ] + ~guard:(BinOp(compop, Lval(var iter), past, intType)) + ~next:[ mkStmt (Instr [(Set (var iter, (BinOp(nextop, Lval(var iter), incr, iter.vtype)), - lu))])] - body - + lu))])] + ~body:body -let rec stripCasts (e: exp) = + +let rec stripCasts (e: exp) = match e with CastE(_, e') -> stripCasts e' | _ -> e @@ -1622,7 +1678,7 @@ let rec stripCasts (e: exp) = (* the name of the C function we call to get ccgr ASTs external parse : string -> file = "cil_main" *) -(* +(* Pretty Printing *) @@ -1637,16 +1693,19 @@ let d_ikind () = function | IUShort -> text "unsigned short" | ILong -> text "long" | IULong -> text "unsigned long" - | ILongLong -> + | ILongLong -> if !msvcMode then text "__int64" else text "long long" - | IULongLong -> - if !msvcMode then text "unsigned __int64" + | IULongLong -> + if !msvcMode then text "unsigned __int64" else text "unsigned long long" let d_fkind () = function FFloat -> text "float" | FDouble -> text "double" | FLongDouble -> text "long double" + | FComplexFloat -> text "_Complex float" + | FComplexDouble -> text "_Complex double" + | FComplexLongDouble -> text "_Complex long double" let d_storage () = function NoStorage -> nil @@ -1658,8 +1717,8 @@ let d_storage () = function let mostNeg32BitInt : int64 = (Int64.of_string "-0x80000000") let mostNeg64BitInt : int64 = (Int64.of_string "-0x8000000000000000") -let bytesSizeOfInt (ik: ikind): int = - match ik with +let bytesSizeOfInt (ik: ikind): int = + match ik with | IChar | ISChar | IUChar -> 1 | IBool -> !M.theMachine.M.sizeof_bool | IInt | IUInt -> !M.theMachine.M.sizeof_int @@ -1668,13 +1727,13 @@ let bytesSizeOfInt (ik: ikind): int = | ILongLong | IULongLong -> !M.theMachine.M.sizeof_longlong (* constant *) -let d_const () c = +let d_const () c = match c with CInt64(_, _, Some s) -> text s (* Always print the text if there is one *) - | CInt64(i, ik, None) -> - (** We must make sure to capture the type of the constant. For some + | CInt64(i, ik, None) -> + (* 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 : string = + let suffix : string = match ik with IUInt -> "U" | ILong -> "L" @@ -1683,12 +1742,12 @@ let d_const () c = | IULongLong -> if !msvcMode then "UL" else "ULL" | _ -> "" in - let prefix : string = - if suffix <> "" then "" + let prefix : string = + if suffix <> "" then "" else if ik = IInt then "" - else "(" ^ (sprint !lineLength (d_ikind () ik)) ^ ")" + else "(" ^ (sprint ~width:!lineLength (d_ikind () ik)) ^ ")" in - (* Watch out here for negative integers that we should be printing as + (* Watch out here for negative integers that we should be printing as * large positive ones *) if i < Int64.zero && (not (isSigned ik)) then if bytesSizeOfInt ik <> 8 then @@ -1713,12 +1772,12 @@ let d_const () c = ) | CStr(s) -> text ("\"" ^ escape_string s ^ "\"") - | CWStr(s) -> + | CWStr(s) -> (* text ("L\"" ^ escape_string s ^ "\"") *) - (List.fold_left (fun acc elt -> - acc ++ + (List.fold_left (fun acc elt -> + acc ++ if (elt >= Int64.zero && - elt <= (Int64.of_int 255)) then + elt <= (Int64.of_int 255)) then text (escape_char (Char.chr (Int64.to_int elt))) else ( text (Printf.sprintf "\\x%LX\"" elt) ++ break ++ @@ -1729,19 +1788,22 @@ let d_const () c = | CChr(c) -> text ("'" ^ escape_char c ^ "'") | CReal(_, _, Some s) -> text s - | CReal(f, fsize, None) -> + | CReal(f, fsize, None) -> text (string_of_float f) ++ (match fsize with FFloat -> chr 'f' | FDouble -> nil - | FLongDouble -> chr 'L') + | FLongDouble -> chr 'L' + | FComplexFloat -> text "iF" + | FComplexDouble -> chr 'i' + | FComplexLongDouble -> text "iL") | CEnum(_, s, ei) -> text s -(* 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 +(* 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! *) let derefStarLevel = 20 let indexLevel = 20 @@ -1751,8 +1813,8 @@ let additiveLevel = 60 let comparativeLevel = 70 let bitwiseLevel = 75 let questionLevel = 100 -let getParenthLevel (e: exp) = - match e with +let getParenthLevel (e: exp) = + match e with | Question _ -> questionLevel | BinOp((LAnd | LOr), _,_,_) -> 80 (* Bit operations. *) @@ -1761,17 +1823,19 @@ let getParenthLevel (e: exp) = (* Comparisons *) | BinOp((Eq|Ne|Gt|Lt|Ge|Le),_,_,_) -> comparativeLevel (* 70 *) - (* Additive. Shifts can have higher - * level than + or - but I want + (* Additive. Shifts can have higher + * level than + or - but I want * parentheses around them *) | BinOp((MinusA|MinusPP|MinusPI|PlusA| - PlusPI|IndexPI|Shiftlt|Shiftrt),_,_,_) + PlusPI|IndexPI|Shiftlt|Shiftrt),_,_,_) -> additiveLevel (* 60 *) (* Multiplicative *) | BinOp((Div|Mod|Mult),_,_,_) -> 40 (* Unary *) + | Real _ -> 30 + | Imag _ -> 30 | CastE(_,_) -> 30 | AddrOf(_) -> 30 | AddrOfLabel(_) -> 30 @@ -1779,7 +1843,7 @@ let getParenthLevel (e: exp) = | UnOp((Neg|BNot|LNot),_,_) -> 30 (* Lvals *) - | Lval(Mem _ , _) -> derefStarLevel (* 20 *) + | Lval(Mem _ , _) -> derefStarLevel (* 20 *) | Lval(Var _, (Field _|Index _)) -> indexLevel (* 20 *) | SizeOf _ | SizeOfE _ | SizeOfStr _ -> 20 | AlignOf _ | AlignOfE _ -> 20 @@ -1788,9 +1852,9 @@ let getParenthLevel (e: exp) = | Const _ -> 0 (* Constants *) -let getParenthLevelAttrParam (a: attrparam) = +let getParenthLevelAttrParam (a: attrparam) = (* Create an expression of the same shape, and use {!getParenthLevel} *) - match a with + match a with AInt _ | AStr _ | ACons _ -> 0 | ASizeOf _ | ASizeOfE _ | ASizeOfS _ -> 20 | AAlignOf _ | AAlignOfE _ | AAlignOfS _ -> 20 @@ -1802,9 +1866,9 @@ let getParenthLevelAttrParam (a: attrparam) = (* Separate out the storage-modifier name attributes *) -let separateStorageModifiers (al: attribute list) = +let separateStorageModifiers (al: attribute list) = let isstoragemod (Attr(an, _): attribute) : bool = - try + try match H.find attributeHash an with AttrName issm -> issm | _ -> false @@ -1814,26 +1878,26 @@ let separateStorageModifiers (al: attribute list) = if not !msvcMode then stom, rest else - (* Put back the declspec. Put it without the leading __ since these will + (* Put back the declspec. Put it without the leading __ since these will * be added later *) - let stom' = - Util.list_map (fun (Attr(an, args)) -> + let stom' = + Util.list_map (fun (Attr(an, args)) -> Attr("declspec", [ACons(an, args)])) stom in stom', rest -let isIntegralType t = +let isIntegralType t = match unrollType t with (TInt _ | TEnum _) -> true | _ -> false -let isArithmeticType t = +let isArithmeticType t = match unrollType t with (TInt _ | TEnum _ | TFloat _) -> true | _ -> false - -let isPointerType t = + +let isPointerType t = match unrollType t with TPtr _ -> true | _ -> false @@ -1841,13 +1905,13 @@ let isPointerType t = let isScalarType t = isArithmeticType t || isPointerType t -let isFunctionType t = +let isFunctionType t = match unrollType t with TFun _ -> true | _ -> false (**** Compute the type of an expression ****) -let rec typeOf (e: exp) : typ = +let rec typeOf (e: exp) : typ = match e with | Const(CInt64 (_, ik, _)) -> TInt(ik, []) @@ -1856,8 +1920,8 @@ let rec typeOf (e: exp) : typ = * 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 + (* 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) -> !stringLiteralType @@ -1866,7 +1930,8 @@ let rec typeOf (e: exp) : typ = | Const(CReal (_, fk, _)) -> TFloat(fk, []) | Const(CEnum(tag, _, ei)) -> typeOf tag - + | Real e -> typeOfRealAndImagComponents @@ typeOf e + | Imag e -> typeOfRealAndImagComponents @@ typeOf e | Lval(lv) -> typeOfLval lv | SizeOf _ | SizeOfE _ | SizeOfStr _ -> !typeOfSizeOf | AlignOf _ | AlignOfE _ -> !typeOfSizeOf @@ -1882,8 +1947,8 @@ let rec typeOf (e: exp) : typ = | _ -> E.s (E.bug "typeOf: StartOf on a non-array") end -and typeOfInit (i: init) : typ = - match i with +and typeOfInit (i: init) : typ = + match i with SingleInit e -> typeOf e | CompoundInit (t, _) -> t @@ -1897,7 +1962,7 @@ and typeOfLval = function and typeOffset basetyp = let blendAttributes baseAttrs = - let (_, _, contageous) = + let (_, _, contageous) = partitionAttributes ~default:(AttrName false) baseAttrs in typeAddAttributes contageous in @@ -1909,7 +1974,7 @@ and typeOffset basetyp = let elementType = typeOffset t o in blendAttributes baseAttrs elementType | t -> E.s (E.bug "typeOffset: Index on a non-array") - end + end | Field (fi, o) -> match unrollType basetyp with TComp (_, baseAttrs) -> @@ -1933,7 +1998,7 @@ let unsignedVersionOf (ik:ikind): ikind = | IInt -> IUInt | ILong -> IULong | ILongLong -> IULongLong - | _ -> ik + | _ -> ik let signedVersionOf (ik:ikind): ikind = match ik with @@ -1945,7 +2010,7 @@ let signedVersionOf (ik:ikind): ikind = | _ -> ik (* Return the integer conversion rank of an integer kind *) -let intRank (ik:ikind) : int = +let intRank (ik:ikind) : int = match ik with | IBool -> 0 | IChar | ISChar | IUChar -> 1 @@ -1964,7 +2029,7 @@ let commonIntKind (ik1:ikind) (ik2:ikind) : ikind = if r1 > r2 then ik1 else ik2 end else begin - let signedKind, unsignedKind, signedRank, unsignedRank = + 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. @@ -1973,12 +2038,12 @@ let commonIntKind (ik1:ikind) (ik2:ikind) : ikind = if unsignedRank >= signedRank then unsignedKind else if (bytesSizeOfInt signedKind) > (bytesSizeOfInt unsignedKind) then signedKind - else + else unsignedVersionOf signedKind end let intKindForSize (s:int) (unsigned:bool) : ikind = - if unsigned then + if unsigned then (* Test the most common sizes first *) if s = 1 then IUChar else if s = !M.theMachine.M.sizeof_int then IUInt @@ -1995,7 +2060,7 @@ let intKindForSize (s:int) (unsigned:bool) : ikind = else if s = !M.theMachine.M.sizeof_longlong then ILongLong else raise Not_found -let floatKindForSize (s:int) = +let floatKindForSize (s:int) = if s = !M.theMachine.M.sizeof_double then FDouble else if s = !M.theMachine.M.sizeof_float then FFloat else if s = !M.theMachine.M.sizeof_longdouble then FLongDouble @@ -2004,8 +2069,8 @@ let floatKindForSize (s:int) = (* Represents an integer as for a given kind. Returns a flag saying whether any "interesting" bits were lost during truncation. By "interesting", we mean that the lost bits were not all-0 or all-1. *) -let truncateCilint (k: ikind) (i: cilint) : cilint * truncation = - (* Truncations to _Bool are special: they behave like "!= 0" +let truncateCilint (k: ikind) (i: cilint) : cilint * truncation = + (* Truncations to _Bool are special: they behave like "!= 0" ISO C99 6.3.1.2 *) if k = IBool then if is_zero_cilint i then @@ -2019,34 +2084,43 @@ let truncateCilint (k: ikind) (i: cilint) : cilint * truncation = else truncate_unsigned_cilint i nrBits -let mkCilint (ik:ikind) (i:int64) : cilint = +let mkCilint (ik:ikind) (i:int64) : cilint = fst (truncateCilint ik (cilint_of_int64 i)) (* Construct an integer constant with possible truncation *) -let kintegerCilint (k: ikind) (i: cilint) : exp = +let kintegerCilint (k: ikind) (i: cilint) : exp = let i', truncated = truncateCilint k i in - if truncated = BitTruncation && !warnTruncate then - ignore (warnOpt "Truncating integer %s to %s" + if truncated = BitTruncation && !warnTruncate then + ignore (warnOpt "Truncating integer %s to %s" (string_of_cilint i) (string_of_cilint i')); - Const (CInt64(int64_of_cilint i', k, None)) + let str = + let int64_min = cilint_of_int64 Int64.min_int in + let int64_max = cilint_of_int64 Int64.max_int in + (* if the resulting value can not be represented by an Int64, store its string representation *) + if Cilint.compare_cilint i' int64_min < 0 || Cilint.compare_cilint int64_max i' < 0 then ( + Some (string_of_cilint i') + ) + else None + in + Const (CInt64(int64_of_cilint i', k, str)) (* Construct an integer constant with possible truncation *) -let kinteger64 (k: ikind) (i: int64) : exp = +let kinteger64 (k: ikind) (i: int64) : exp = kintegerCilint k (cilint_of_int64 i) (* Construct an integer of a given kind. *) -let kinteger (k: ikind) (i: int) = +let kinteger (k: ikind) (i: int) = kintegerCilint k (cilint_of_int i) (** Construct an integer of kind IInt. On targets where C's 'int' is 16-bits, the integer may get truncated. *) let integer (i: int) = kinteger IInt i - + let one = integer 1 let mone = integer (-1) - + (* True if the integer fits within the kind's range *) -let fitsInInt (k: ikind) (i: cilint) : bool = +let fitsInInt (k: ikind) (i: cilint) : bool = let _, truncated = truncateCilint k i in truncated = NoTruncation @@ -2055,7 +2129,7 @@ let fitsInInt (k: ikind) (i: cilint) : bool = otherwise. Note that if the value doesn't fit in any of the available types, you will get ILongLong (2nd argument false) or IULongLong (2nd argument true). *) -let intKindForValue (i: cilint) (unsigned: bool) = +let intKindForValue (i: cilint) (unsigned: bool) = if unsigned then if fitsInInt IUChar i then IUChar else if fitsInInt IUShort i then IUShort @@ -2070,15 +2144,15 @@ let intKindForValue (i: cilint) (unsigned: bool) = else ILongLong (** If the given expression is an integer constant or a CastE'd - integer constant, return that constant's value as an ikint, int64 pair. + integer constant, return that constant's value as an ikind, int64 pair. Otherwise return None. *) -let rec getInteger (e:exp) : cilint option = +let rec getInteger (e:exp) : cilint option = match e with | Const(CInt64 (n, ik, _)) -> Some (mkCilint ik n) | Const(CChr c) -> getInteger (Const (charConstToInt c)) | Const(CEnum(v, _, _)) -> getInteger v | CastE(t, e) -> begin - (* Handle any truncation due to cast. We optimistically ignore + (* Handle any truncation due to cast. We optimistically ignore loss-of-precision due to floating-point casts. *) let mkInt ik n = Some (fst (truncateCilint ik n)) in match unrollType t, getInteger e with @@ -2094,30 +2168,30 @@ let rec getInteger (e:exp) : cilint option = end | _ -> None -let isZero (e: exp) : bool = +let isZero (e: exp) : bool = match getInteger e with | Some n -> is_zero_cilint n | _ -> false -type offsetAcc = +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 + 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 + 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 aligment in bytes for a given type *) -let rec alignOf_int t = + +(* Get the minimum alignment in bytes for a given type *) +let rec alignOf_int t = let alignOfType () = match t with | TInt((IChar|ISChar|IUChar), _) -> 1 @@ -2127,54 +2201,57 @@ let rec alignOf_int t = | TInt((ILong|IULong), _) -> !M.theMachine.M.alignof_long | TInt((ILongLong|IULongLong), _) -> !M.theMachine.M.alignof_longlong | TEnum(ei, _) -> alignOf_int (TInt(ei.ekind, [])) - | TFloat(FFloat, _) -> !M.theMachine.M.alignof_float + | TFloat(FFloat, _) -> !M.theMachine.M.alignof_float | TFloat(FDouble, _) -> !M.theMachine.M.alignof_double | TFloat(FLongDouble, _) -> !M.theMachine.M.alignof_longdouble + | TFloat(FComplexFloat, _) -> !M.theMachine.M.alignof_floatcomplex + | TFloat(FComplexDouble, _) -> !M.theMachine.M.alignof_doublecomplex + | TFloat(FComplexLongDouble, _) -> !M.theMachine.M.alignof_longdoublecomplex | TNamed (t, _) -> alignOf_int t.ttype | TArray (t, _, _) -> alignOf_int t | TPtr _ | TBuiltin_va_list _ -> !M.theMachine.M.alignof_ptr - + (* For composite types get the maximum alignment of any field inside *) | TComp (c, _) -> (* On GCC the zero-width fields do not contribute to the alignment. - * On MSVC only those zero-width that _do_ appear after other - * bitfields contribute to the alignment. So we drop those that - * do not occur after othe bitfields *) + * 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 the bitfields *) let rec dropZeros (afterbitfield: bool) = function - | f :: rest when f.fbitfield = Some 0 && not afterbitfield -> + | 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 + 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 -> !M.theMachine.M.alignof_fun - + | TFun _ as t -> raise (SizeOfError ("function", t)) | TVoid _ as t -> raise (SizeOfError ("void", t)) in match filterAttributes "aligned" (typeAttrs t) with - [] -> + [] -> (* no __aligned__ attribute, so get the default alignment *) alignOfType () - | _ when !ignoreAlignmentAttrs -> - ignore (warn "ignoring recursive align attributes on %a" + | _ when !ignoreAlignmentAttrs -> + ignore (warn "ignoring recursive align attributes on %a" (!pd_type) t); alignOfType () | (Attr(_, [a]) as at)::rest -> begin if rest <> [] then - ignore (warn "ignoring duplicate align attributes on %a" + ignore (warn "ignoring duplicate align attributes on %a" (!pd_type) t); match intOfAttrparam a with Some n -> n - | None -> - ignore (warn "alignment attribute \"%a\" not understood on %a" + | None -> + ignore (warn "alignment attribute \"%a\" not understood on %a" (!pd_attr) at (!pd_type) t); alignOfType () end @@ -2182,22 +2259,22 @@ let rec alignOf_int t = (* aligned with no arg means a power of two at least as large as any alignment on the system.*) if rest <> [] then - ignore(warn "ignoring duplicate align attributes on %a" + ignore(warn "ignoring duplicate align attributes on %a" (!pd_type) t); !M.theMachine.M.alignof_aligned | at::_ -> - ignore (warn "alignment attribute \"%a\" not understood on %a" + ignore (warn "alignment attribute \"%a\" not understood on %a" (!pd_attr) at (!pd_type) t); alignOfType () (* alignment of a possibly-packed struct field. *) and alignOfField (fi: fieldinfo) = - let fieldIsPacked = hasAttribute "packed" fi.fattr + let fieldIsPacked = hasAttribute "packed" fi.fattr || hasAttribute "packed" fi.fcomp.cattr in if fieldIsPacked then 1 else alignOf_int fi.ftype - -and intOfAttrparam (a:attrparam) : int option = + +and intOfAttrparam (a:attrparam) : int option = let rec doit a : int = match a with AInt(n) -> n @@ -2211,7 +2288,7 @@ and intOfAttrparam (a:attrparam) : int option = | _ -> raise (SizeOfError ("", voidType)) in (* Use ignoreAlignmentAttrs here to prevent stack overflow if a buggy - program does something like + program does something like struct s {...} __attribute__((aligned(sizeof(struct s)))) This is too conservative, but it's often enough. *) @@ -2229,87 +2306,87 @@ and intOfAttrparam (a:attrparam) : int option = (* GCC version *) (* Does not use the sofar.oaPrevBitPack *) and offsetOfFieldAcc_GCC - (fi: fieldinfo) - (sofar: offsetAcc) : offsetAcc = + (fi: fieldinfo) + (sofar: offsetAcc) : offsetAcc = (* field type *) let ftype = unrollType fi.ftype in let ftypeAlign = 8 * alignOfField fi in let ftypeBits = bitsSizeOf ftype in match ftype, fi.fbitfield with - (* A width of 0 means that we must end the current packing. It seems that - * GCC pads only up to the alignment boundary for the type of this field. + (* 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 -> + | _, 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 + (* 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 + | _, 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 -> + | _, Some wdthis -> { oaFirstFree = sofar.oaFirstFree + wdthis; - oaLastFieldStart = sofar.oaFirstFree; + oaLastFieldStart = sofar.oaFirstFree; oaLastFieldWidth = wdthis; oaPrevBitPack = None - } + } (* Non-bitfield *) - | _, None -> + | _, None -> (* Align this field *) let newStart = addTrailing sofar.oaFirstFree ftypeAlign in { oaFirstFree = newStart + ftypeBits; oaLastFieldStart = newStart; oaLastFieldWidth = ftypeBits; oaPrevBitPack = None; - } + } (* MSVC version *) -and offsetOfFieldAcc_MSVC (fi: fieldinfo) - (sofar: offsetAcc) : offsetAcc = +and offsetOfFieldAcc_MSVC (fi: fieldinfo) + (sofar: offsetAcc) : offsetAcc = (* field type *) let ftype = unrollType fi.ftype in let ftypeAlign = 8 * alignOf_int ftype in let ftypeBits = bitsSizeOf ftype in (* - ignore (E.log "offsetOfFieldAcc_MSVC(%s of %s:%a%a,firstFree=%d, pack=%a)\n" - fi.fname fi.fcomp.cname + ignore (E.log "offsetOfFieldAcc_MSVC(%s of %s:%a%a,firstFree=%d, pack=%a)\n" + fi.fname fi.fcomp.cname d_type ftype insert (match fi.fbitfield with None -> nil | Some wdthis -> dprintf ":%d" wdthis) - sofar.oaFirstFree + sofar.oaFirstFree insert - (match sofar.oaPrevBitPack with + (match sofar.oaPrevBitPack with None -> text "None" | Some (prevpack, _, wdpack) -> dprintf "Some(prev=%d,wd=%d)" prevpack wdpack)); *) match ftype, fi.fbitfield, sofar.oaPrevBitPack with (* Ignore zero-width bitfields that come after non-bitfields *) - | TInt (ikthis, _), Some 0, None -> + | 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 + (* 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 = + let firstFree = if sofar.oaFirstFree = packstart then packstart else packstart + wdpack in @@ -2320,8 +2397,8 @@ and offsetOfFieldAcc_MSVC (fi: fieldinfo) oaPrevBitPack = None } (* A width of 0 means that we must end the current packing. *) - | TInt (ikthis, _), Some 0, Some (packstart, _, wdpack) -> - let firstFree = + | TInt (ikthis, _), Some 0, Some (packstart, _, wdpack) -> + let firstFree = if sofar.oaFirstFree = packstart then packstart else packstart + wdpack in @@ -2331,20 +2408,20 @@ and offsetOfFieldAcc_MSVC (fi: fieldinfo) oaLastFieldWidth = 0; oaPrevBitPack = Some (firstFree, ikthis, ftypeBits) } - (* Check for a bitfield that fits in the current pack after some other + (* 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; + oaLastFieldStart = sofar.oaFirstFree; oaLastFieldWidth = wdthis; oaPrevBitPack = sofar.oaPrevBitPack - } + } - | _, _, Some (packstart, _, wdpack) -> (* Finish up the bitfield pack and + | _, _, Some (packstart, _, wdpack) -> (* Finish up the bitfield pack and * restart. *) - let firstFree = + let firstFree = if sofar.oaFirstFree = packstart then packstart else packstart + wdpack in @@ -2355,7 +2432,7 @@ and offsetOfFieldAcc_MSVC (fi: fieldinfo) oaPrevBitPack = None } (* No active bitfield pack. But we are seeing a bitfield. *) - | TInt(ikthis, _), Some wdthis, None -> + | TInt(ikthis, _), Some wdthis, None -> let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in { oaFirstFree = firstFree + wdthis; oaLastFieldStart = firstFree; @@ -2363,33 +2440,36 @@ and offsetOfFieldAcc_MSVC (fi: fieldinfo) oaPrevBitPack = Some (firstFree, ikthis, ftypeBits); } (* No active bitfield pack. Non-bitfield *) - | _, None, None -> + | _, None, None -> (* Align this field *) let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in { oaFirstFree = firstFree + ftypeBits; oaLastFieldStart = firstFree; oaLastFieldWidth = ftypeBits; oaPrevBitPack = None; - } + } | _, Some _, None -> E.s (E.bug "offsetAcc") -and offsetOfFieldAcc ~(fi: fieldinfo) - ~(sofar: offsetAcc) : offsetAcc = +and offsetOfFieldAcc ~(fi: fieldinfo) + ~(sofar: offsetAcc) : offsetAcc = if !msvcMode then offsetOfFieldAcc_MSVC fi sofar else offsetOfFieldAcc_GCC fi sofar -(* The size of a type, in bits. If a struct or array, then trailing padding is +(* The size of a type, in bits. If a struct or array, then trailing padding is * added *) -and bitsSizeOf t = - if not !initCIL_called then +and bitsSizeOf t = + if not !initCIL_called then E.s (E.error "You did not call Cil.initCIL before using the CIL library"); - match t with + match t with | TInt (ik,_) -> 8 * (bytesSizeOfInt ik) | TFloat(FDouble, _) -> 8 * !M.theMachine.M.sizeof_double | TFloat(FLongDouble, _) -> 8 * !M.theMachine.M.sizeof_longdouble - | TFloat _ -> 8 * !M.theMachine.M.sizeof_float + | TFloat(FFloat, _) -> 8 * !M.theMachine.M.sizeof_float + | TFloat(FComplexDouble, _) -> 8 * !M.theMachine.M.sizeof_doublecomplex + | TFloat(FComplexLongDouble, _) -> 8 * !M.theMachine.M.sizeof_longdoublecomplex + | TFloat(FComplexFloat, _) -> 8 * !M.theMachine.M.sizeof_floatcomplex | TEnum (ei, _) -> bitsSizeOf (TInt(ei.ekind, [])) | TPtr _ -> 8 * !M.theMachine.M.sizeof_ptr | TBuiltin_va_list _ -> 8 * !M.theMachine.M.sizeof_ptr @@ -2404,38 +2484,38 @@ and bitsSizeOf t = | TComp (comp, _) when comp.cstruct -> (* Struct *) (* Go and get the last offset *) - let startAcc = + let startAcc = { oaFirstFree = 0; oaLastFieldStart = 0; oaLastFieldWidth = 0; oaPrevBitPack = None; } in - let lastoff = - List.fold_left (fun acc fi -> offsetOfFieldAcc ~fi ~sofar:acc) - startAcc comp.cfields + let lastoff = + List.fold_left (fun acc fi -> offsetOfFieldAcc ~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 + (* On MSVC if we have just a zero-width bitfields then the length * is 32 and is not padded *) 32 else begin (* Drop e.g. the align attribute from t. For this purpose, consider only the attributes on comp itself.*) - let structAlign = 8 * alignOf_int + let structAlign = 8 * alignOf_int (TComp (comp, [])) in addTrailing lastoff.oaFirstFree structAlign end - + | TComp (comp, _) -> (* when not comp.cstruct *) (* Get the maximum of all fields *) - let startAcc = + let startAcc = { oaFirstFree = 0; oaLastFieldStart = 0; oaLastFieldWidth = 0; oaPrevBitPack = None; } in - let max = - List.fold_left (fun acc fi -> + let max = + List.fold_left (fun acc fi -> let lastoff = offsetOfFieldAcc ~fi ~sofar:startAcc in if lastoff.oaFirstFree > acc then lastoff.oaFirstFree else acc) 0 comp.cfields in @@ -2443,8 +2523,8 @@ and bitsSizeOf t = addTrailing max (8 * alignOf_int t) | TArray(bt, Some len, _) -> begin - match constFold true len with - Const(CInt64(l,lk,_)) -> + match constFold true len with + Const(CInt64(l,lk,_)) -> let sz = mul_cilint (mkCilint lk l) (cilint_of_int (bitsSizeOf bt)) in (* Check for overflow. There are other places in these cil.ml that overflow can occur, @@ -2462,32 +2542,32 @@ and bitsSizeOf t = | TFun _ when not !msvcMode -> (* On GCC the size of a function is defined *) 8 * !M.theMachine.M.sizeof_fun - | TArray (_, None, _) -> (* it seems that on GCC the size of such an - * array is 0 *) + | TArray (_, None, _) -> (* it seems that on GCC the size of such an + * array is 0 *) 0 | TFun _ -> raise (SizeOfError ("function", t)) -and addTrailing nrbits roundto = +and addTrailing nrbits roundto = (nrbits + roundto - 1) land (lnot (roundto - 1)) -and sizeOf t = +and sizeOf t = try integer ((bitsSizeOf t) lsr 3) with SizeOfError _ -> SizeOf(t) - -and bitsOffset (baset: typ) (off: offset) : int * int = + +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 = + let ei = match getInteger e with Some i -> cilint_to_int i | None -> raise (SizeOfError ("index not constant", baset)) in - let bt = + let bt = match unrollType baset with TArray(bt, _, _) -> bt | _ -> E.s (E.bug "bitsOffset: Index on a non-array") @@ -2495,15 +2575,15 @@ and bitsOffset (baset: typ) (off: offset) : int * int = let bitsbt = bitsSizeOf bt in loopOff bt bitsbt (start + ei * bitsbt) off end - | Field(f, off) when not f.fcomp.cstruct -> + | Field(f, off) when not f.fcomp.cstruct -> (* All union fields start at offset 0 *) loopOff f.ftype (bitsSizeOf f.ftype) start off - | Field(f, off) -> - (* Construct a list of fields preceeding and including this one *) - let prevflds = + | Field(f, off) -> + (* Construct a list of fields preceding and including this one *) + let prevflds = let rec loop = function - [] -> E.s (E.bug "bitsOffset: Cannot find field %s in %s\n" + [] -> E.s (E.bug "bitsOffset: Cannot find field %s in %s\n" f.fname f.fcomp.cname) | fi' :: _ when fi' == f -> [fi'] | fi' :: rest -> fi' :: loop rest @@ -2512,7 +2592,7 @@ and bitsOffset (baset: typ) (off: offset) : int * int = in let lastoff = List.fold_left (fun acc fi' -> offsetOfFieldAcc ~fi:fi' ~sofar:acc) - { oaFirstFree = 0; (* Start at 0 because each struct is done + { oaFirstFree = 0; (* Start at 0 because each struct is done * separately *) oaLastFieldStart = 0; oaLastFieldWidth = 0; @@ -2520,24 +2600,24 @@ and bitsOffset (baset: typ) (off: offset) : int * int = in (* ignore (E.log "Field %s of %s: start=%d, lastFieldStart=%d\n" f.fname f.fcomp.cname start lastoff.oaLastFieldStart); *) - loopOff f.ftype lastoff.oaLastFieldWidth + loopOff f.ftype lastoff.oaLastFieldWidth (start + lastoff.oaLastFieldStart) off in loopOff baset (bitsSizeOf baset) 0 off - -(** Do constant folding on an expression. If the first argument is true then + +(** 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 = + expressions in a given AST node.*) +and constFold (machdep: bool) (e: exp) : exp = match e with BinOp(bop, e1, e2, tres) -> constFoldBinOp machdep bop e1 e2 tres | UnOp(unop, e1, tres) -> begin try - let tk = + let tk = match unrollType tres with TInt(ik, _) -> ik | TEnum (ei, _) -> ei.ekind @@ -2546,7 +2626,7 @@ and constFold (machdep: bool) (e: exp) : exp = match constFold machdep e1 with Const(CInt64(i,ik,_)) -> begin let ic = mkCilint ik i in - match unop with + match unop with Neg -> kintegerCilint tk (neg_cilint ic) | BNot -> kintegerCilint tk (lognot_cilint ic) | LNot -> if is_zero_cilint ic then one else zero @@ -2567,34 +2647,34 @@ and constFold (machdep: bool) (e: exp) : exp = | SizeOfStr s when machdep -> kinteger !kindOfSizeOf (1 + String.length s) | AlignOf t when machdep -> kinteger !kindOfSizeOf (alignOf_int t) | AlignOfE e when machdep -> begin - (* The alignment of an expression is not always the alignment of its + (* The alignment of an expression is not always the alignment of its * type. I know that for strings this is not true *) - match e with - Const (CStr _) when not !msvcMode -> + match e with + Const (CStr _) when not !msvcMode -> kinteger !kindOfSizeOf !M.theMachine.M.alignof_str (* For an array, it is the alignment of the array ! *) | _ -> constFold machdep (AlignOf (typeOf e)) end - | CastE(it, - AddrOf (Mem (CastE(TPtr(bt, _), z)), off)) + | CastE(it, + AddrOf (Mem (CastE(TPtr(bt, _), z)), off)) when machdep && isZero z -> begin - try + try let start, width = bitsOffset bt off in - if start mod 8 <> 0 then + if start mod 8 <> 0 then E.s (error "Using offset of bitfield"); constFold machdep (CastE(it, (kinteger !kindOfSizeOf (start / 8)))) with SizeOfError _ -> e end - + | CastE (t, e) -> begin - match constFold machdep e, unrollType t with + match constFold machdep e, unrollType t with (* Might truncate silently *) | Const(CInt64(i,k,_)), TInt(nk,a) (* It's okay to drop a cast to const. If the cast has any other attributes, leave the cast alone. *) - when (dropAttributes ["const"] a) = [] -> + when (dropAttributes ["const"] a) = [] -> let i', _ = truncateCilint nk (mkCilint k i) in Const(CInt64(int64_of_cilint i', nk, None)) | e', _ -> CastE (t, e') @@ -2605,7 +2685,7 @@ and constFold (machdep: bool) (e: exp) : exp = | _ -> e and constFoldLval machdep (host,offset) = - let newhost = + let newhost = match host with | Mem e -> Mem (constFold machdep e) | Var _ -> host @@ -2618,12 +2698,12 @@ and constFoldLval machdep (host,offset) = in (newhost, constFoldOffset machdep offset) -and constFoldBinOp (machdep: bool) bop e1 e2 tres = +and constFoldBinOp (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 tk = + let newe = + let tk = match unrollType tres with TInt(ik, _) -> ik | TEnum (ei, _) -> ei.ekind @@ -2634,11 +2714,11 @@ and constFoldBinOp (machdep: bool) bop e1 e2 tres = 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 + Otherwise, the semantics are processor-dependent, so let the compiler sort it out. *) if machdep then try - compare_cilint i2 zero_cilint >= 0 && + compare_cilint i2 zero_cilint >= 0 && compare_cilint i2 (cilint_of_int (bitsSizeOf (typeOf e1'))) < 0 with SizeOfError _ -> false else false @@ -2653,7 +2733,7 @@ and constFoldBinOp (machdep: bool) bop e1 e2 tres = | Mult, Some i1, Some i2 -> kintegerCilint tk (mul_cilint i1 i2) | Mult, Some z, _ when is_zero_cilint z -> collapse0 () | Mult, _, Some z when is_zero_cilint z -> collapse0 () - | Mult, Some o, _ when compare_cilint o one_cilint = 0 -> collapse e2' + | Mult, Some o, _ when compare_cilint o one_cilint = 0 -> collapse e2' | Mult, _, Some o when compare_cilint o one_cilint = 0 -> collapse e1' | Div, Some i1, Some i2 -> begin try kintegerCilint tk (div0_cilint i1 i2) @@ -2662,7 +2742,7 @@ and constFoldBinOp (machdep: bool) bop e1 e2 tres = | Div, _, Some o when compare_cilint o one_cilint = 0 -> collapse e1' | Mod, Some i1, Some i2 -> begin try kintegerCilint tk (rem_cilint i1 i2) - with Division_by_zero -> BinOp(bop, e1', e2', tres) + with Division_by_zero -> BinOp(bop, e1', e2', tres) end | Mod, _, Some o when compare_cilint o one_cilint = 0 -> collapse0 () @@ -2670,17 +2750,17 @@ and constFoldBinOp (machdep: bool) bop e1 e2 tres = | BAnd, Some z, _ when is_zero_cilint z -> collapse0 () | BAnd, _, Some z when is_zero_cilint z -> collapse0 () | BOr, Some i1, Some i2 -> kintegerCilint tk (logor_cilint i1 i2) - | BOr, Some z, _ when is_zero_cilint z -> collapse e2' + | BOr, Some z, _ when is_zero_cilint z -> collapse e2' | BOr, _, Some z when is_zero_cilint z -> collapse e1' | BXor, Some i1, Some i2 -> kintegerCilint tk (logxor_cilint i1 i2) - | BXor, Some z, _ when is_zero_cilint z -> collapse e2' + | BXor, Some z, _ when is_zero_cilint z -> collapse e2' | BXor, _, Some z when is_zero_cilint z -> collapse e1' - | Shiftlt, Some i1, Some i2 when shiftInBounds i2 -> + | Shiftlt, Some i1, Some i2 when shiftInBounds i2 -> kintegerCilint tk (shift_left_cilint i1 (int_of_cilint i2)) | Shiftlt, Some z, _ when is_zero_cilint z -> collapse0 () | Shiftlt, _, Some z when is_zero_cilint z -> collapse e1' - | Shiftrt, Some i1, Some i2 when shiftInBounds i2 -> + | Shiftrt, Some i1, Some i2 when shiftInBounds i2 -> kintegerCilint tk (shift_right_cilint i1 (int_of_cilint i2)) | Shiftrt, Some z, _ when is_zero_cilint z -> collapse0 () | Shiftrt, _, Some z when is_zero_cilint z -> collapse e1' @@ -2699,37 +2779,68 @@ and constFoldBinOp (machdep: bool) bop e1 e2 tres = | _ -> BinOp(bop, e1', e2', tres) in - if debugConstFold then - ignore (E.log "Folded %a to %a\n" + if debugConstFold then + ignore (E.log "Folded %a to %a\n" (!pd_exp) (BinOp(bop, e1', e2', tres)) (!pd_exp) newe); newe end else BinOp(bop, e1', e2', tres) +let isArrayType t = + match unrollType t with + TArray _ -> true + | _ -> false +(** 6.3.2.3 subsection 3 + * An integer constant expr with value 0, or such an expr cast to void *, is called a null pointer constant. *) +let isNullPtrConstant = function + | CastE(TPtr(TVoid _,_), e) -> isZero @@ constFold true e + | e -> isZero @@ constFold true e -let parseInt (str: string) : exp = - let hasSuffix str = +let rec isConstant = function + | Const _ -> true + | UnOp (_, e, _) -> isConstant e + | BinOp (_, e1, e2, _) -> isConstant e1 && isConstant e2 + | Question (e1, e2, e3, _) -> isConstant e1 && isConstant e2 && isConstant e3 + | Lval (Var vi, NoOffset) -> + (vi.vglob && isArrayType vi.vtype || isFunctionType vi.vtype) + | Lval _ -> false + | Real e -> isConstant e + | Imag e -> isConstant e + | SizeOf _ | SizeOfE _ | SizeOfStr _ | AlignOf _ | AlignOfE _ -> true + | CastE (_, e) -> isConstant e + | AddrOf (Var vi, off) | StartOf (Var vi, off) + -> vi.vglob && isConstantOffset off + | AddrOf (Mem e, off) | StartOf(Mem e, off) + -> isConstant e && isConstantOffset off + | AddrOfLabel _ -> true +and isConstantOffset = function + NoOffset -> true + | Field(fi, off) -> isConstantOffset off + | Index(e, off) -> isConstant e && isConstantOffset off + +let parseInt (str: string) : exp = + let hasSuffix str = let l = String.length str in - fun s -> + fun s -> let ls = String.length s in - l >= ls && s = String.uppercase (String.sub str (l - ls) ls) + l >= ls && s = String.uppercase_ascii (String.sub str (l - ls) ls) in let l = String.length str in (* See if it is octal or hex *) - let octalhex = (l >= 1 && String.get str 0 = '0') in - (* The length of the suffix and a list of possible kinds. See ISO + let octalhex = (l >= 1 && String.get str 0 = '0') in + (* The length of the suffix and a list of possible kinds. See ISO * 6.4.4.1 *) let hasSuffix = hasSuffix str in - let suffixlen, kinds = - if hasSuffix "ULL" || hasSuffix "LLU" then + let suffixlen, kinds = + if hasSuffix "ULL" || hasSuffix "LLU" then 3, [IULongLong] else if hasSuffix "LL" then 2, if octalhex then [ILongLong; IULongLong] else [ILongLong] else if hasSuffix "UL" || hasSuffix "LU" then 2, [IULong; IULongLong] else if hasSuffix "L" then - 1, if octalhex then [ILong; IULong; ILongLong; IULongLong] + 1, if octalhex then [ILong; IULong; ILongLong; IULongLong] else [ILong; ILongLong] else if hasSuffix "U" then 1, [IUInt; IULong; IULongLong] @@ -2741,18 +2852,25 @@ let parseInt (str: string) : exp = 0, if octalhex then [IInt; IUInt; ILong; IULong; ILongLong; IULongLong] else if not !c99Mode then [ IInt; ILong; IULong; ILongLong; IULongLong] else [IInt; ILong; ILongLong] + (* c99mode only affects parsing of decimal integer constants without suffix + a) on machines where long and long long do not have the same size + (e.g. 32 Bit machines, 64 Bit Windows, not 64 Bit MacOS or (most? all?) 64 Bit Linux: + giving constants that are bigger than max long type long long in c99mode vs. unsigned long + if c99mode is off. + b) for constants bigger than long long producing a "Unimplemented: Cannot represent the integer" + warning in C99 mode vs. unsigned long long if c99mode is off. *) in (* Convert to integer. To prevent overflow we do the arithmetic on * cilints. We work only with positive integers since the lexer * takes care of the sign *) - let rec toInt (base: cilint) (acc: cilint) (idx: int) : cilint = - let doAcc (what: int) = + let rec toInt (base: cilint) (acc: cilint) (idx: int) : cilint = + let doAcc (what: int) = let acc' = add_cilint (mul_cilint base acc) (cilint_of_int what) in toInt base acc' (idx + 1) - in + in if idx >= l - suffixlen then begin acc - end else + end else let ch = String.get str idx in if ch >= '0' && ch <= '9' then doAcc (Char.code ch - Char.code '0') @@ -2761,12 +2879,12 @@ let parseInt (str: string) : exp = else if ch >= 'A' && ch <= 'F' then doAcc (10 + Char.code ch - Char.code 'A') else - E.s (bug "Invalid integer constant: %s (char %c at idx=%d)" + E.s (bug "Invalid integer constant: %s (char %c at idx=%d)" str ch idx) in - let i = + let i = if octalhex then - if l >= 2 && + if l >= 2 && (let c = String.get str 1 in c = 'x' || c = 'X') then toInt (cilint_of_int 16) zero_cilint 2 else @@ -2774,17 +2892,17 @@ let parseInt (str: string) : exp = else toInt (cilint_of_int 10) zero_cilint 0 in - (* Construct an integer of the first kinds that fits. i must be + (* Construct an integer of the first kinds that fits. i must be * POSITIVE *) - let res = + let res = let rec loop = function - k::rest -> + k::rest -> if fitsInInt k i then kintegerCilint k i else loop rest - | [] -> E.s (E.unimp "Cannot represent the integer %s\n" + | [] -> E.s (E.unimp "Cannot represent the integer %s\n" (string_of_cilint i)) in - loop kinds + loop kinds in res (* with e -> begin *) @@ -2825,14 +2943,14 @@ let d_binop () b = let invalidStmt = mkStmt (Instr []) (** Construct a hash with the builtins *) -let builtinFunctions : (string, typ * typ list * bool) H.t = +let builtinFunctions : (string, typ * typ list * bool) H.t = H.create 49 (* Initialize the builtin functions after the machine has been initialized. *) let initGccBuiltins () : unit = if not !initCIL_called then E.s (bug "Call initCIL before initGccBuiltins"); - if H.length builtinFunctions <> 0 then + if H.length builtinFunctions <> 0 then E.s (bug "builtins already initialized."); let h = builtinFunctions in (* See if we have builtin_va_list *) @@ -2867,7 +2985,7 @@ let initGccBuiltins () : unit = H.add h "__builtin_acosl" (longDoubleType, [ longDoubleType ], false); H.add h "__builtin_alloca" (voidPtrType, [ sizeType ], false); - + H.add h "__builtin_asin" (doubleType, [ doubleType ], false); H.add h "__builtin_asinf" (floatType, [ floatType ], false); H.add h "__builtin_asinl" (longDoubleType, [ longDoubleType ], false); @@ -2878,7 +2996,7 @@ let initGccBuiltins () : unit = H.add h "__builtin_atan2" (doubleType, [ doubleType; doubleType ], false); H.add h "__builtin_atan2f" (floatType, [ floatType; floatType ], false); - H.add h "__builtin_atan2l" (longDoubleType, [ longDoubleType; + H.add h "__builtin_atan2l" (longDoubleType, [ longDoubleType; longDoubleType ], false); let addSwap sizeInBits = @@ -2945,10 +3063,10 @@ let initGccBuiltins () : unit = H.add h "__builtin_infl" (longDoubleType, [], false); H.add h "__builtin_memcpy" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType ], false); H.add h "__builtin_mempcpy" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType ], false); - H.add h "__builtin_memset" (voidPtrType, + H.add h "__builtin_memset" (voidPtrType, [ voidPtrType; intType; intType ], false); H.add h "__builtin_bcopy" (voidType, [ voidConstPtrType; voidPtrType; sizeType ], false); - H.add h "__builtin_bzero" (voidType, + H.add h "__builtin_bzero" (voidType, [ voidPtrType; sizeType ], false); H.add h "__builtin_fmod" (doubleType, [ doubleType ], false); @@ -2957,12 +3075,12 @@ let initGccBuiltins () : unit = H.add h "__builtin_frexp" (doubleType, [ doubleType; intPtrType ], false); H.add h "__builtin_frexpf" (floatType, [ floatType; intPtrType ], false); - H.add h "__builtin_frexpl" (longDoubleType, [ longDoubleType; + H.add h "__builtin_frexpl" (longDoubleType, [ longDoubleType; intPtrType ], false); H.add h "__builtin_ldexp" (doubleType, [ doubleType; intType ], false); H.add h "__builtin_ldexpf" (floatType, [ floatType; intType ], false); - H.add h "__builtin_ldexpl" (longDoubleType, [ longDoubleType; + H.add h "__builtin_ldexpl" (longDoubleType, [ longDoubleType; intType ], false); H.add h "__builtin_log" (doubleType, [ doubleType ], false); @@ -2973,10 +3091,10 @@ let initGccBuiltins () : unit = H.add h "__builtin_log10f" (floatType, [ floatType ], false); H.add h "__builtin_log10l" (longDoubleType, [ longDoubleType ], false); - H.add h "__builtin_modff" (floatType, [ floatType; + H.add h "__builtin_modff" (floatType, [ floatType; TPtr(floatType,[]) ], false); - H.add h "__builtin_modfl" (longDoubleType, [ longDoubleType; - TPtr(longDoubleType, []) ], + H.add h "__builtin_modfl" (longDoubleType, [ longDoubleType; + TPtr(longDoubleType, []) ], false); H.add h "__builtin_nan" (doubleType, [ charConstPtrType ], false); @@ -3049,6 +3167,9 @@ let initGccBuiltins () : unit = H.add h "__builtin_ia32_unpcklps" (v4sfType, [v4sfType; v4sfType], false); H.add h "__builtin_ia32_maxps" (v4sfType, [v4sfType; v4sfType], false); + (* tgmath in newer versions of GCC *) + H.add h "__builtin_tgmath" (TVoid[Attr("overloaded",[])], [ ], true); + (* Atomic Builtins These builtins have an overloaded return type, hence the "magic" void type with __overloaded__ attribute, used to infer return type from parameters in @@ -3131,7 +3252,7 @@ let initGccBuiltins () : unit = if hasbva then begin H.add h "__builtin_va_end" (voidType, [ TBuiltin_va_list [] ], false); - H.add h "__builtin_varargs_start" + H.add h "__builtin_varargs_start" (voidType, [ TBuiltin_va_list [] ], false); (* When we parse builtin_{va,stdarg}_start, we drop the second argument *) H.add h "__builtin_va_start" (voidType, [ TBuiltin_va_list [] ], false); @@ -3158,16 +3279,16 @@ let initGccBuiltins () : unit = let initMsvcBuiltins () : unit = if not !initCIL_called then E.s (bug "Call initCIL before initGccBuiltins"); - if H.length builtinFunctions <> 0 then + if H.length builtinFunctions <> 0 then E.s (bug "builtins already initialized."); let h = builtinFunctions in - (** Take a number of wide string literals *) + (* Take a number of wide string literals *) H.add h "__annotation" (voidType, [ ], true); () (** This is used as the location of the prototypes of builtin functions. *) -let builtinLoc: location = { line = 1; - file = ""; +let builtinLoc: location = { line = 1; + file = ""; byte = 0;} @@ -3176,7 +3297,7 @@ let pTypeSig : (typ -> typsig) ref = ref (fun _ -> E.s (E.bug "pTypeSig not initialized")) -(** A printer interface for CIL trees. Create instantiations of +(** A printer interface for CIL trees. Create instantiations of * this type by specializing the class {!Cil.defaultCilPrinter}. *) class type cilPrinter = object @@ -3186,41 +3307,41 @@ class type cilPrinter = object method getPrintInstrTerminator : unit -> string method pVDecl: unit -> varinfo -> doc - (** Invoked for each variable declaration. Note that variable - * declarations are all the [GVar], [GVarDecl], [GFun], all the [varinfo] - * in formals of function types, and the formals and locals for function + (** Invoked for each variable declaration. Note that variable + * declarations are all the [GVar], [GVarDecl], [GFun], all the [varinfo] + * in formals of function types, and the formals and locals for function * definitions. *) method pVar: varinfo -> doc (** Invoked on each variable use. *) method pLval: unit -> lval -> doc - (** Invoked on each lvalue occurence *) + (** Invoked on each lvalue occurrence *) method pOffset: doc -> offset -> doc - (** Invoked on each offset occurence. The second argument is the base. *) + (** Invoked on each offset occurrence. The second argument is the base. *) method pInstr: unit -> instr -> doc (** Invoked on each instruction occurrence. *) method pStmt: unit -> stmt -> doc - (** Control-flow statement. This is used by + (** Control-flow statement. This is used by * {!Cil.printGlobal} and by {!Cil.dumpGlobal}. *) method dStmt: out_channel -> int -> stmt -> unit - (** Dump a control-flow statement to a file with a given indentation. This is used by + (** Dump a control-flow statement to a file with a given indentation. This is used by * {!Cil.dumpGlobal}. *) method dBlock: out_channel -> int -> block -> unit - (** Dump a control-flow block to a file with a given indentation. This is + (** Dump a control-flow block to a file with a given indentation. This is * used by {!Cil.dumpGlobal}. *) method pBlock: unit -> block -> Pretty.doc (** Print a block. *) method pGlobal: unit -> global -> doc - (** Global (vars, types, etc.). This can be slow and is used only by - * {!Cil.printGlobal} but by {!Cil.dumpGlobal} for everything else except + (** Global (vars, types, etc.). This can be slow and is used only by + * {!Cil.printGlobal} but by {!Cil.dumpGlobal} for everything else except * [GVar] and [GFun]. *) method dGlobal: out_channel -> global -> unit @@ -3229,20 +3350,20 @@ class type cilPrinter = object method pFieldDecl: unit -> fieldinfo -> doc (** A field declaration *) - method pType: doc option -> unit -> typ -> doc - (* Use of some type in some declaration. The first argument is used to print - * the declared element, or is None if we are just printing a type with no - * name being declared. Note that for structure/union and enumeration types - * the definition of the composite type is not visited. Use [vglob] to + method pType: doc option -> unit -> typ -> doc + (* Use of some type in some declaration. The first argument is used to print + * the declared element, or is None if we are just printing a type with no + * name being declared. Note that for structure/union and enumeration types + * the definition of the composite type is not visited. Use [vglob] to * visit it. *) method pAttr: attribute -> doc * bool - (** Attribute. Also return an indication whether this attribute must be + (** Attribute. Also return an indication whether this attribute must be * printed inside the __attribute__ list or not. *) - - method pAttrParam: unit -> attrparam -> doc - (** Attribute paramter *) - + + method pAttrParam: unit -> attrparam -> doc + (** Attribute parameter *) + method pAttrs: unit -> attributes -> doc (** Attribute lists *) @@ -3250,10 +3371,10 @@ class type cilPrinter = object (** Label *) method pLineDirective: ?forcefile:bool -> location -> Pretty.doc - (** Print a line-number. This is assumed to come always on an empty line. - * If the forcefile argument is present and is true then the file name - * will be printed always. Otherwise the file name is printed only if it - * is different from the last time time this function is called. The last + (** Print a line-number. This is assumed to come always on an empty line. + * If the forcefile argument is present and is true then the file name + * will be printed always. Otherwise the file name is printed only if it + * is different from the last time time this function is called. The last * file name is stored in a private field inside the cilPrinter object. *) method pStmtKind : stmt -> unit -> stmtkind -> Pretty.doc @@ -3264,14 +3385,14 @@ class type cilPrinter = object * statement printing in certain special cases. *) method pExp: unit -> exp -> doc - (** Print expressions *) + (** Print expressions *) method pInit: unit -> init -> doc - (** Print initializers. This can be slow and is used by + (** Print initializers. This can be slow and is used by * {!Cil.printGlobal} but not by {!Cil.dumpGlobal}. *) method dInit: out_channel -> int -> init -> unit - (** Dump a global to a file with a given indentation. This is used by + (** Dump a global to a file with a given indentation. This is used by * {!Cil.dumpGlobal}. *) end @@ -3279,9 +3400,9 @@ end class defaultCilPrinterClass : cilPrinter = object (self) val mutable currentFormals : varinfo list = [] method private getLastNamedArgument (s:string) : exp = - match List.rev currentFormals with + match List.rev currentFormals with f :: _ -> Lval (var f) - | [] -> + | [] -> E.s (bug "Cannot find the last named argument when printing call to %s\n" s) method private setCurrentFormals (fms : varinfo list) = @@ -3309,7 +3430,7 @@ class defaultCilPrinterClass : cilPrinter = object (self) | Mem e, Field(fi, o) -> self#pOffset ((self#pExpPrec arrowLevel () e) ++ text ("->" ^ fi.fname)) o - | Mem e, NoOffset -> + | Mem e, NoOffset -> text "*" ++ self#pExpPrec derefStarLevel () e | Mem e, o -> self#pOffset @@ -3318,30 +3439,30 @@ class defaultCilPrinterClass : cilPrinter = object (self) (** Offsets **) method pOffset (base: doc) = function | NoOffset -> base - | Field (fi, o) -> + | Field (fi, o) -> self#pOffset (base ++ text "." ++ text fi.fname) o | Index (e, o) -> self#pOffset (base ++ text "[" ++ self#pExp () e ++ text "]") o - method private pLvalPrec (contextprec: int) () lv = + method private pLvalPrec (contextprec: int) () lv = if getParenthLevel (Lval(lv)) >= contextprec then text "(" ++ self#pLval () lv ++ text ")" else self#pLval () lv (*** EXPRESSIONS ***) - method pExp () (e: exp) : doc = + method pExp () (e: exp) : doc = let level = getParenthLevel e in match e with Const(c) -> d_const () c | Lval(l) -> self#pLval () l - | UnOp(u,e1,_) -> + | UnOp(u,e1,_) -> (d_unop () u) ++ chr ' ' ++ (self#pExpPrec level () e1) - - | BinOp(b,e1,e2,_) -> - align + + | BinOp(b,e1,e2,_) -> + align ++ (self#pExpPrec level () e1) - ++ chr ' ' + ++ chr ' ' ++ (d_binop () b) ++ chr ' ' ++ (self#pExpPrec level () e2) @@ -3354,27 +3475,30 @@ class defaultCilPrinterClass : cilPrinter = object (self) ++ text " : " ++ (self#pExpPrec level () e3) - | CastE(t,e) -> - text "(" + | CastE(t,e) -> + text "(" ++ self#pType None () t ++ text ")" ++ self#pExpPrec level () e - | SizeOf (t) -> + | SizeOf (t) -> text "sizeof(" ++ self#pType None () t ++ chr ')' - | SizeOfE (Lval (Var fv, NoOffset)) when fv.vname = "__builtin_va_arg_pack" && (not !printCilAsIs) -> + | SizeOfE (Lval (Var fv, NoOffset)) when fv.vname = "__builtin_va_arg_pack" && (not !printCilAsIs) -> text "__builtin_va_arg_pack()" - | SizeOfE (e) -> + | SizeOfE (e) -> text "sizeof(" ++ self#pExp () e ++ chr ')' - - | SizeOfStr s -> + | Imag e -> + text "__imag__(" ++ self#pExp () e ++ chr ')' + | Real e -> + text "__real__(" ++ self#pExp () e ++ chr ')' + | SizeOfStr s -> text "sizeof(" ++ d_const () (CStr s) ++ chr ')' - | AlignOf (t) -> + | AlignOf (t) -> text "__alignof__(" ++ self#pType None () t ++ chr ')' - | AlignOfE (e) -> + | AlignOfE (e) -> text "__alignof__(" ++ self#pExp () e ++ chr ')' - | AddrOf(lv) -> + | AddrOf(lv) -> text "& " ++ (self#pLvalPrec addrOfLevel () lv) | AddrOfLabel(sref) -> begin (* Grab one of the labels *) @@ -3385,16 +3509,16 @@ class defaultCilPrinterClass : cilPrinter = object (self) in match pickLabel !sref.labels with Some lbl -> text ("&& " ^ lbl) - | None -> + | None -> ignore (error "Cannot find label for target of address of label"); text "&& __invalid_label" end - + | StartOf(lv) -> self#pLval () lv - (* Print an expression, given the precedence of the context in which it + (* Print an expression, given the precedence of the context in which it * appears. *) - method private pExpPrec (contextprec: int) () (e: exp) = + method private pExpPrec (contextprec: int) () (e: exp) = let thisLevel = getParenthLevel e in let needParens = if thisLevel >= contextprec then @@ -3410,67 +3534,67 @@ class defaultCilPrinterClass : cilPrinter = object (self) else self#pExp () e - method pInit () = function + method pInit () = function SingleInit e -> self#pExp () e - | CompoundInit (t, initl) -> + | CompoundInit (t, initl) -> (* We do not print the type of the Compound *) (* let dinit e = d_init () e in dprintf "{@[%a@]}" (docList ~sep:(chr ',' ++ break) dinit) initl *) - let printDesignator = + let printDesignator = if not !msvcMode then begin (* Print only for union when we do not initialize the first field *) match unrollType t, initl with - TComp(ci, _), [(Field(f, NoOffset), _)] -> - if not (ci.cstruct) && ci.cfields != [] && + TComp(ci, _), [(Field(f, NoOffset), _)] -> + if not (ci.cstruct) && ci.cfields != [] && (List.hd ci.cfields) != f then true else false | _ -> false - end else - false + end else + false in let d_oneInit = function - Field(f, NoOffset), i -> - (if printDesignator then - text ("." ^ f.fname ^ " = ") + Field(f, NoOffset), i -> + (if printDesignator then + text ("." ^ f.fname ^ " = ") else nil) ++ self#pInit () i - | Index(e, NoOffset), i -> - (if printDesignator then - text "[" ++ self#pExp () e ++ text "] = " else nil) ++ + | Index(e, NoOffset), i -> + (if printDesignator then + text "[" ++ self#pExp () e ++ text "] = " else nil) ++ self#pInit () i | _ -> E.s (unimp "Trying to print malformed initializer") in - chr '{' ++ (align - ++ ((docList ~sep:(chr ',' ++ break) d_oneInit) () initl) + chr '{' ++ (align + ++ ((docList ~sep:(chr ',' ++ break) d_oneInit) () initl) ++ unalign) ++ chr '}' (* - | ArrayInit (_, _, il) -> - chr '{' ++ (align - ++ ((docList (chr ',' ++ break) (self#pInit ())) () il) + | ArrayInit (_, _, il) -> + chr '{' ++ (align + ++ ((docList (chr ',' ++ break) (self#pInit ())) () il) ++ unalign) ++ chr '}' *) (* dump initializers to a file. *) - method dInit (out: out_channel) (ind: int) (i: init) = + method dInit (out: out_channel) (ind: int) (i: init) = (* Dump an array *) - let dumpArray (bt: typ) (il: 'a list) (getelem: 'a -> init) = + let dumpArray (bt: typ) (il: 'a list) (getelem: 'a -> init) = let onALine = (* How many elements on a line *) match unrollType bt with TComp _ | TArray _ -> 1 | _ -> 4 in let rec outputElements (isfirst: bool) (room_on_line: int) = function [] -> output_string out "}" - | (i: 'a) :: rest -> + | (i: 'a) :: rest -> if not isfirst then output_string out ", "; - let new_room_on_line = - if room_on_line == 0 then begin + let new_room_on_line = + if room_on_line == 0 then begin output_string out "\n"; output_string out (String.make ind ' '); onALine - 1 - end else + end else room_on_line - 1 in self#dInit out (ind + 2) (getelem i); @@ -3479,29 +3603,29 @@ class defaultCilPrinterClass : cilPrinter = object (self) output_string out "{ "; outputElements true onALine il in - match i with - SingleInit e -> - fprint out !lineLength (indent ind (self#pExp () e)) - | CompoundInit (t, initl) -> begin - match unrollType t with - TArray(bt, _, _) -> + match i with + SingleInit e -> + fprint out ~width:!lineLength (indent ind (self#pExp () e)) + | CompoundInit (t, initl) -> begin + match unrollType t with + TArray(bt, _, _) -> dumpArray bt initl (fun (_, i) -> i) - | _ -> + | _ -> (* Now a structure or a union *) - fprint out !lineLength (indent ind (self#pInit () i)) + fprint out ~width:!lineLength (indent ind (self#pInit () i)) end (* | ArrayInit (bt, len, initl) -> begin - (* If the base type does not contain structs then use the pInit - match unrollType bt with - TComp _ | TArray _ -> + (* If the base type does not contain structs then use the pInit + match unrollType bt with + TComp _ | TArray _ -> dumpArray bt initl (fun x -> x) | _ -> *) fprint out !lineLength (indent ind (self#pInit () i)) end *) - - (** What terminator to print after an instruction. sometimes we want to + + (** What terminator to print after an instruction. sometimes we want to * print sequences of instructions separated by comma *) val mutable printInstrTerminator = ";" @@ -3523,14 +3647,14 @@ class defaultCilPrinterClass : cilPrinter = object (self) ++ text (" ++" ^ printInstrTerminator) | BinOp((MinusA|MinusPI),Lval(lv'), - Const(CInt64(one,_,_)), _) + Const(CInt64(one,_,_)), _) when Util.equals lv lv' && one = Int64.one && not !printCilAsIs -> self#pLineDirective l ++ self#pLvalPrec indexLevel () lv - ++ text (" --" ^ printInstrTerminator) + ++ text (" --" ^ printInstrTerminator) | BinOp((PlusA|PlusPI|IndexPI),Lval(lv'),Const(CInt64(mone,_,_)),_) - when Util.equals lv lv' && mone = Int64.minus_one + when Util.equals lv lv' && mone = Int64.minus_one && not !printCilAsIs -> self#pLineDirective l ++ self#pLvalPrec indexLevel () lv @@ -3538,7 +3662,7 @@ class defaultCilPrinterClass : cilPrinter = object (self) | BinOp((PlusA|PlusPI|IndexPI|MinusA|MinusPP|MinusPI|BAnd|BOr|BXor| Mult|Div|Mod|Shiftlt|Shiftrt) as bop, - Lval(lv'),e,_) when Util.equals lv lv' + Lval(lv'),e,_) when Util.equals lv lv' && not !printCilAsIs -> self#pLineDirective l ++ self#pLval () lv @@ -3546,76 +3670,83 @@ class defaultCilPrinterClass : cilPrinter = object (self) ++ text "= " ++ self#pExp () e ++ text printInstrTerminator - + | _ -> self#pLineDirective l ++ self#pLval () lv ++ text " = " ++ self#pExp () e ++ text printInstrTerminator - + end - (* In cabs2cil we have turned the call to builtin_va_arg into a - * three-argument call: the last argument is the address of the + | VarDecl(v, l) -> + self#pLineDirective l + ++ self#pVDecl () v + ++ (match v.vinit.init with + | None -> text ";" + | Some i -> text " = " ++ + self#pInit () i ++ text ";") + (* 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, Lval(Var vi, NoOffset), [dest; SizeOf t; adest], l) - when vi.vname = "__builtin_va_arg" && not !printCilAsIs -> - let destlv = match stripCasts adest with + | Call(None, Lval(Var vi, NoOffset), [dest; SizeOf t; adest], l) + when vi.vname = "__builtin_va_arg" && not !printCilAsIs -> + let destlv = match stripCasts adest with AddrOf destlv -> destlv (* If this fails, it's likely that an extension interfered with the AddrOf *) - | _ -> E.s (E.bug - "%a: Encountered unexpected call to %s with dest %a\n" + | _ -> E.s (E.bug + "%a: Encountered unexpected call to %s with dest %a\n" d_loc l vi.vname self#pExp adest) in self#pLineDirective l ++ self#pLval () destlv ++ text " = " - + (* Now the function name *) ++ text "__builtin_va_arg" ++ text "(" ++ (align (* Now the arguments *) - ++ self#pExp () dest - ++ chr ',' ++ break + ++ self#pExp () dest + ++ chr ',' ++ break ++ self#pType None () t ++ unalign) ++ text (")" ^ printInstrTerminator) - (* In cabs2cil we have dropped the last argument in the call to + (* In cabs2cil we have dropped the last argument in the call to * __builtin_va_start and __builtin_stdarg_start. *) - | Call(None, Lval(Var vi, NoOffset), [marker], l) + | Call(None, Lval(Var vi, NoOffset), [marker], l) when ((vi.vname = "__builtin_stdarg_start" || - vi.vname = "__builtin_va_start") && not !printCilAsIs) -> + vi.vname = "__builtin_va_start") && not !printCilAsIs) -> if currentFormals <> [] then begin let last = self#getLastNamedArgument vi.vname in self#pInstr () (Call(None,Lval(Var vi,NoOffset),[marker; last],l)) end else begin - (* We can't print this call because someone called pInstr outside + (* We can't print this call because someone called pInstr outside of a pFunDecl, so we don't know what the formals of the current - function are. Just put in a placeholder for now; this isn't + function are. Just put in a placeholder for now; this isn't valid C. *) self#pLineDirective l - ++ dprintf + ++ dprintf "%s(%a, /* last named argument of the function calling %s */)" vi.vname self#pExp marker vi.vname ++ text printInstrTerminator end - (* In cabs2cil we have dropped the last argument in the call to + (* In cabs2cil we have dropped the last argument in the call to * __builtin_next_arg. *) - | Call(res, Lval(Var vi, NoOffset), [ ], l) + | Call(res, Lval(Var vi, NoOffset), [ ], l) when vi.vname = "__builtin_next_arg" && not !printCilAsIs -> begin let last = self#getLastNamedArgument vi.vname in self#pInstr () (Call(res,Lval(Var vi,NoOffset),[last],l)) end - (* In cparser we have turned the call to - * __builtin_types_compatible_p(t1, t2) into + (* 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. + * represent the types as expressions. * Remove the sizeofs when printing. *) - | Call(dest, Lval(Var vi, NoOffset), [SizeOf t1; SizeOf t2], l) - when vi.vname = "__builtin_types_compatible_p" && not !printCilAsIs -> + | Call(dest, Lval(Var vi, NoOffset), [SizeOf t1; SizeOf t2], l) + when vi.vname = "__builtin_types_compatible_p" && not !printCilAsIs -> self#pLineDirective l (* Print the destination *) ++ (match dest with @@ -3625,34 +3756,47 @@ class defaultCilPrinterClass : cilPrinter = object (self) ++ dprintf "%s(%a, %a)" vi.vname (self#pType None) t1 (self#pType None) t2 ++ text printInstrTerminator - | Call(_, Lval(Var vi, NoOffset), _, l) - when vi.vname = "__builtin_types_compatible_p" && not !printCilAsIs -> + | Call(_, Lval(Var vi, NoOffset), _, l) + when vi.vname = "__builtin_types_compatible_p" && not !printCilAsIs -> E.s (bug "__builtin_types_compatible_p: cabs2cil should have added sizeof to the arguments.") - + | Call(dest,e,args,l) -> + let rec patchTypeNotVLA t = + match t with + | TPtr(t, args) -> TPtr(patchTypeNotVLA t, args) + | TArray(t, None, args) -> TArray(patchTypeNotVLA t, None, args) + | TArray(t, Some exp, args) when isConstant exp -> TArray(patchTypeNotVLA t, Some exp, args) + | TArray(t, Some exp, args) -> TArray(patchTypeNotVLA t, None, args) + | _ -> t + in + let patchArgNotUseVLACast exp = + match exp with + | CastE(t, e) -> CastE(patchTypeNotVLA t, e) + | e -> e + in self#pLineDirective l ++ (match dest with None -> nil - | Some lv -> + | Some lv -> self#pLval () lv ++ text " = " ++ (* Maybe we need to print a cast *) (let destt = typeOfLval lv in match unrollType (typeOf e) with - TFun (rt, _, _, _) + TFun (rt, _, _, _) when not (Util.equals (!pTypeSig rt) (!pTypeSig destt)) -> text "(" ++ self#pType None () destt ++ text ")" | _ -> nil)) (* Now the function name *) ++ (let ed = self#pExp () e in - match e with + match e with Lval(Var _, _) -> ed | _ -> text "(" ++ ed ++ text ")") - ++ text "(" ++ + ++ text "(" ++ (align (* Now the arguments *) - ++ (docList ~sep:(chr ',' ++ break) - (self#pExp ()) () args) + ++ (docList ~sep:(chr ',' ++ break) + (fun x -> self#pExp () (patchArgNotUseVLACast x)) () args) (* here we would need to remove casts to array types that are not ok *) ++ unalign) ++ text (")" ^ printInstrTerminator) @@ -3666,8 +3810,8 @@ class defaultCilPrinterClass : cilPrinter = object (self) ++ text ("}" ^ printInstrTerminator) else self#pLineDirective l - ++ text ("__asm__ ") - ++ self#pAttrs () attrs + ++ text ("__asm__ ") + ++ self#pAttrs () attrs ++ text " (" ++ (align ++ (docList ~sep:line @@ -3680,8 +3824,8 @@ class defaultCilPrinterClass : cilPrinter = object (self) (text ": " ++ (docList ~sep:(chr ',' ++ break) (fun (idopt, c, lv) -> - text(match idopt with - None -> "" + text(match idopt with + None -> "" | Some id -> "[" ^ id ^ "] " ) ++ text ("\"" ^ escape_string c ^ "\" (") @@ -3694,8 +3838,8 @@ class defaultCilPrinterClass : cilPrinter = object (self) (text ": " ++ (docList ~sep:(chr ',' ++ break) (fun (idopt, c, e) -> - text(match idopt with - None -> "" + text(match idopt with + None -> "" | Some id -> "[" ^ id ^ "] " ) ++ text ("\"" ^ escape_string c ^ "\" (") @@ -3711,29 +3855,35 @@ class defaultCilPrinterClass : cilPrinter = object (self) clobs))) ++ unalign) ++ text (")" ^ printInstrTerminator) - + (**** STATEMENTS ****) method pStmt () (s:stmt) = (* control-flow statement *) self#pStmtNext invalidStmt () s - method dStmt (out: out_channel) (ind: int) (s:stmt) : unit = - fprint out !lineLength (indent ind (self#pStmt () s)) + method dStmt (out: out_channel) (ind: int) (s:stmt) : unit = + fprint out ~width:!lineLength (indent ind (self#pStmt () s)) - method dBlock (out: out_channel) (ind: int) (b:block) : unit = - fprint out !lineLength (indent ind (align ++ self#pBlock () b)) + method dBlock (out: out_channel) (ind: int) (b:block) : unit = + fprint out ~width:!lineLength (indent ind (align ++ self#pBlock () b)) method private pStmtNext (next: stmt) () (s: stmt) = (* print the labels *) - ((docList ~sep:line (fun l -> self#pLabel () l)) () s.labels) - (* print the statement itself. If the labels are non-empty and the - * statement is empty, print a semicolon *) - ++ - (if s.skind = Instr [] && s.labels <> [] then - text ";" - else - (if s.labels <> [] then line else nil) - ++ self#pStmtKind next () s.skind) + let labels = ((docList ~sep:line (fun l -> self#pLabel () l)) () s.labels) in + if s.skind = Instr [] && s.labels <> [] then + (* If the labels are non-empty and the statement is empty, print a semicolon *) + labels ++ text ";" + else + let pre = + if s.labels <> [] then + (match s.skind with + | Instr (VarDecl(_)::_)-> text ";" (* first instruction is VarDecl, insert semicolon *) + | _ -> nil) + ++ line + else + nil (* no labels, no new line needed *) + in + labels ++ pre ++ self#pStmtKind next () s.skind method private pLabel () = function Label (s, _, true) -> text (s ^ ": ") @@ -3744,36 +3894,36 @@ class defaultCilPrinterClass : cilPrinter = object (self) | Default _ -> text "default: " (* The pBlock will put the unalign itself *) - method pBlock () (blk: block) = + method pBlock () (blk: block) = let rec dofirst () = function [] -> nil | [x] -> self#pStmtNext invalidStmt () x | x :: rest -> dorest nil x rest and dorest acc prev = function [] -> acc ++ (self#pStmtNext invalidStmt () prev) - | x :: rest -> + | x :: rest -> dorest (acc ++ (self#pStmtNext x () prev) ++ line) x rest in - (* Let the host of the block decide on the alignment. The d_block will + (* Let the host of the block decide on the alignment. The d_block will * pop the alignment as well *) - text "{" - ++ - (if blk.battrs <> [] then + text "{" + ++ + (if blk.battrs <> [] then self#pAttrsGen true blk.battrs else nil) ++ line ++ (dofirst () blk.bstmts) ++ unalign ++ line ++ text "}" - - (* Store here the name of the last file printed in a line number. This is + + (* 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#pLineDirective on an empty line *) - method pLineDirective ?(forcefile=false) l = + method pLineDirective ?(forcefile=false) l = currentLoc := l; match !lineDirectiveStyle with | None -> nil @@ -3789,7 +3939,7 @@ class defaultCilPrinterClass : cilPrinter = object (self) | LinePreprocessorOutput when not !msvcMode -> chr '#' | LinePreprocessorOutput | LinePreprocessorInput -> text "#line" in - lastLineNumber <- l.line; + lastLineNumber <- l.line; let filename = if forcefile || l.file <> lastFileName then begin @@ -3820,7 +3970,7 @@ class defaultCilPrinterClass : cilPrinter = object (self) ++ text "return (" ++ self#pExp () e ++ text ");" - + | Goto (sref, l) -> begin (* Grab one of the labels *) let rec pickLabel = function @@ -3830,7 +3980,7 @@ class defaultCilPrinterClass : cilPrinter = object (self) in match pickLabel !sref.labels with Some lbl -> self#pLineDirective l ++ text ("goto " ^ lbl ^ ";") - | None -> + | None -> ignore (error "Cannot find label for target of goto"); text "goto __invalid_label;" end @@ -3845,7 +3995,7 @@ class defaultCilPrinterClass : cilPrinter = object (self) self#pLineDirective l ++ text "break;" - | Continue l -> + | Continue l -> self#pLineDirective l ++ text "continue;" @@ -3856,8 +4006,8 @@ class defaultCilPrinterClass : cilPrinter = object (self) | If(be,t,{bstmts=[];battrs=[]},l) when not !printCilAsIs -> self#pIfConditionThen l be t - - | If(be,t,{bstmts=[{skind=Goto(gref,_);labels=[]}]; + + | If(be,t,{bstmts=[{skind=Goto(gref,_);labels=[]; _}]; battrs=[]},l) when !gref == next && not !printCilAsIs -> self#pIfConditionThen l be t @@ -3865,15 +4015,15 @@ class defaultCilPrinterClass : cilPrinter = object (self) | If(be,{bstmts=[];battrs=[]},e,l) when not !printCilAsIs -> self#pIfConditionThen l (UnOp(LNot,be,intType)) e - | If(be,{bstmts=[{skind=Goto(gref,_);labels=[]}]; + | If(be,{bstmts=[{skind=Goto(gref,_);labels=[]; _}]; battrs=[]},e,l) when !gref == next && not !printCilAsIs -> self#pIfConditionThen l (UnOp(LNot,be,intType)) e - + | If(be,t,e,l) -> self#pIfConditionThen l be t ++ (match e with - { bstmts=[{skind=If _} as elsif]; battrs=[] } -> + { bstmts=[{skind=If _; _} as elsif]; battrs=[] } -> text " else" ++ line (* Don't indent else-ifs *) ++ self#pStmtNext next () elsif @@ -3882,7 +4032,7 @@ class defaultCilPrinterClass : cilPrinter = object (self) ++ align ++ text "else " ++ self#pBlock () e) - + | Switch(e,b,_,l) -> self#pLineDirective l ++ (align @@ -3896,16 +4046,16 @@ class defaultCilPrinterClass : cilPrinter = object (self) let term, bodystmts = let rec skipEmpty = function [] -> [] - | {skind=Instr [];labels=[]} :: rest -> skipEmpty rest + | {skind=Instr [];labels=[]; _} :: rest -> skipEmpty rest | x -> x in (* Bill McCloskey: Do not remove the If if it has labels *) match skipEmpty b.bstmts with - {skind=If(e,tb,fb,_); labels=[]} :: rest + {skind=If(e,tb,fb,_); labels=[]; _} :: rest when not !printCilAsIs -> begin match skipEmpty tb.bstmts, skipEmpty fb.bstmts with - [], {skind=Break _; labels=[]} :: _ -> e, rest - | {skind=Break _; labels=[]} :: _, [] + [], {skind=Break _; labels=[]; _} :: _ -> e, rest + | {skind=Break _; labels=[]; _} :: _, [] -> UnOp(LNot, e, intType), rest | _ -> raise Not_found end @@ -3927,28 +4077,28 @@ class defaultCilPrinterClass : cilPrinter = object (self) ++ self#pBlock () b) end | Block b -> align ++ self#pBlock () b - - | TryFinally (b, h, l) -> - self#pLineDirective l + + | TryFinally (b, h, l) -> + self#pLineDirective l ++ text "__try " - ++ align + ++ align ++ self#pBlock () b ++ text " __fin" ++ align ++ text "ally " ++ self#pBlock () h - | TryExcept (b, (il, e), h, l) -> - self#pLineDirective l + | TryExcept (b, (il, e), h, l) -> + self#pLineDirective l ++ text "__try " - ++ align + ++ align ++ self#pBlock () b ++ text " __e" ++ align ++ text "xcept(" ++ line ++ align - (* Print the instructions but with a comma at the end, instead of + (* Print the instructions but with a comma at the end, instead of * semicolon *) - ++ (printInstrTerminator <- ","; - let res = + ++ (printInstrTerminator <- ","; + let res = (docList ~sep:line (self#pInstr ()) - () il) + () il) in printInstrTerminator <- ";"; res) @@ -3959,24 +4109,24 @@ class defaultCilPrinterClass : cilPrinter = object (self) (*** GLOBALS ***) method pGlobal () (g:global) : doc = (* global (vars, types, etc.) *) - match g with + match g with | GFun (fundec, l) -> - (* If the function has attributes then print a prototype because + (* If the function has attributes then print a prototype because * GCC cannot accept function attributes in a definition *) let oldattr = fundec.svar.vattr in - (* Always pring the file name before function declarations *) - let proto = - if oldattr <> [] then - (self#pLineDirective l) ++ (self#pVDecl () fundec.svar) - ++ chr ';' ++ line + (* Always print the file name before function declarations *) + let proto = + if oldattr <> [] then + (self#pLineDirective l) ++ (self#pVDecl () fundec.svar) + ++ chr ';' ++ line else nil in (* Temporarily remove the function attributes *) fundec.svar.vattr <- []; - let body = (self#pLineDirective ~forcefile:true l) + let body = (self#pLineDirective ~forcefile:true l) ++ (self#pFunDecl () fundec) in fundec.svar.vattr <- oldattr; proto ++ body ++ line - + | GType (typ, l) -> self#pLineDirective ~forcefile:true l ++ text "typedef " @@ -3988,11 +4138,11 @@ class defaultCilPrinterClass : cilPrinter = object (self) text "enum" ++ align ++ text (" " ^ enum.ename) ++ text " {" ++ line ++ (docList ~sep:(chr ',' ++ line) - (fun (n,i, loc) -> - text (n ^ " = ") + (fun (n,i, loc) -> + text (n ^ " = ") ++ self#pExp () i) () enum.eitems) - ++ unalign ++ line ++ text "} " + ++ unalign ++ line ++ text "} " ++ self#pAttrs () enum.eattr ++ text";\n" | GEnumTagDecl (enum, l) -> (* This is a declaration of a tag *) @@ -4011,7 +4161,7 @@ class defaultCilPrinterClass : cilPrinter = object (self) text su1 ++ (align ++ text su2 ++ chr ' ' ++ (self#pAttrs () sto_mod) ++ text n ++ text " {" ++ line - ++ ((docList ~sep:line (self#pFieldDecl ())) () + ++ ((docList ~sep:line (self#pFieldDecl ())) () comp.cfields) ++ unalign) ++ line ++ text "}" ++ @@ -4031,19 +4181,19 @@ class defaultCilPrinterClass : cilPrinter = object (self) ++ chr ' ' ++ (match io.init with None -> nil - | Some i -> text " = " ++ - (let islong = + | Some i -> text " = " ++ + (let islong = match i with CompoundInit (_, il) when List.length il >= 8 -> true - | _ -> false + | _ -> false in - if islong then - line ++ self#pLineDirective l ++ text " " + if islong then + line ++ self#pLineDirective l ++ text " " else nil) ++ (self#pInit () i)) ++ text ";\n" - - (* print global variable 'extern' declarations, and function prototypes *) + + (* print global variable 'extern' declarations, and function prototypes *) | GVarDecl (vi, l) -> if not !printCilAsIs && H.mem builtinFunctions vi.vname then begin (* Compiler builtins need no prototypes. Just print them in @@ -4051,7 +4201,7 @@ class defaultCilPrinterClass : cilPrinter = object (self) text "/* compiler builtin: \n " ++ (self#pVDecl () vi) ++ text "; */\n" - + end else self#pLineDirective l ++ (self#pVDecl () vi) @@ -4067,7 +4217,7 @@ class defaultCilPrinterClass : cilPrinter = object (self) (* also don't print the 'combiner' pragma *) (* nor 'cilnoremove' *) let suppress = - not !print_CIL_Input && + not !print_CIL_Input && not !msvcMode && ((startsWith "box" an) || (startsWith "ccured" an) || @@ -4084,70 +4234,70 @@ class defaultCilPrinterClass : cilPrinter = object (self) ++ docList ~sep:(chr ',') (self#pAttrParam ()) () args ++ text ")" in - self#pLineDirective l + self#pLineDirective l ++ (if suppress then text "/* " else text "") ++ (text "#pragma ") ++ d ++ (if suppress then text " */\n" else text "\n") - | GText s -> - if s <> "//" then + | GText s -> + if s <> "//" then text s ++ text "\n" else nil - method dGlobal (out: out_channel) (g: global) : unit = - (* For all except functions and variable with initializers, use the + method dGlobal (out: out_channel) (g: global) : unit = + (* For all except functions and variable with initializers, use the * pGlobal *) - match g with - GFun (fdec, l) -> - (* If the function has attributes then print a prototype because + match g with + GFun (fdec, l) -> + (* If the function has attributes then print a prototype because * GCC cannot accept function attributes in a definition *) let oldattr = fdec.svar.vattr in - let proto = - if oldattr <> [] then - (self#pLineDirective l) ++ (self#pVDecl () fdec.svar) + let proto = + if oldattr <> [] then + (self#pLineDirective l) ++ (self#pVDecl () fdec.svar) ++ chr ';' ++ line else nil in - fprint out !lineLength + fprint out ~width:!lineLength (proto ++ (self#pLineDirective ~forcefile:true l)); (* Temporarily remove the function attributes *) fdec.svar.vattr <- []; - fprint out !lineLength (self#pFunDecl () fdec); + fprint out ~width:!lineLength (self#pFunDecl () fdec); fdec.svar.vattr <- oldattr; output_string out "\n" | GVar (vi, {init = Some i}, l) -> begin - fprint out !lineLength + fprint out ~width:!lineLength (self#pLineDirective ~forcefile:true l ++ self#pVDecl () vi - ++ text " = " - ++ (let islong = + ++ text " = " + ++ (let islong = match i with CompoundInit (_, il) when List.length il >= 8 -> true - | _ -> false + | _ -> false in - if islong then - line ++ self#pLineDirective l ++ text " " - else nil)); + if islong then + line ++ self#pLineDirective l ++ text " " + else nil)); self#dInit out 3 i; output_string out ";\n" end - | g -> fprint out !lineLength (self#pGlobal () g) + | g -> fprint out ~width:!lineLength (self#pGlobal () g) - method pFieldDecl () fi = + method pFieldDecl () fi = (self#pType (Some (text (if fi.fname = missingFieldName then "" else fi.fname))) - () + () fi.ftype) ++ text " " - ++ (match fi.fbitfield with None -> nil + ++ (match fi.fbitfield with None -> nil | Some i -> text ": " ++ num i ++ text " ") ++ self#pAttrs () fi.fattr ++ text ";" - + method private pFunDecl () f = self#pVDecl () f.svar ++ line @@ -4160,10 +4310,10 @@ class defaultCilPrinterClass : cilPrinter = object (self) | None -> self#pVDecl () vi ++ text ";" | Some i -> self#pVDecl () vi ++ text " = " ++ self#pInit () i ++ text ";") - () f.slocals) + () (List.filter (fun v -> not v.vhasdeclinstruction) f.slocals)) ++ line ++ line (* the body *) - ++ ((* remember the declaration *) currentFormals <- f.sformals; + ++ ((* remember the declaration *) currentFormals <- f.sformals; let body = self#pBlock () f.sbody in currentFormals <- []; body)) @@ -4171,62 +4321,62 @@ class defaultCilPrinterClass : cilPrinter = object (self) ++ text "}" (***** PRINTING DECLARATIONS and TYPES ****) - - method pType (nameOpt: doc option) (* Whether we are declaring a name or + + method pType (nameOpt: doc option) (* Whether we are declaring a name or * we are just printing a type *) () (t:typ) = (* use of some type *) let name = match nameOpt with None -> nil | Some d -> d in - let printAttributes (a: attributes) = + let printAttributes (a: attributes) = let pa = self#pAttrs () a in - match nameOpt with - | None when not !print_CIL_Input && not !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. + match nameOpt with + | None when not !print_CIL_Input && not !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 + if pa = nil then nil else text "/*" ++ pa ++ text "*/" | _ -> pa in - match t with + match t with TVoid a -> text "void" - ++ self#pAttrs () a - ++ text " " + ++ self#pAttrs () a + ++ text " " ++ name - | TInt (ikind,a) -> - d_ikind () ikind - ++ self#pAttrs () a + | TInt (ikind,a) -> + d_ikind () ikind + ++ self#pAttrs () a ++ text " " ++ name - | TFloat(fkind, a) -> - d_fkind () fkind - ++ self#pAttrs () a - ++ text " " + | TFloat(fkind, a) -> + d_fkind () fkind + ++ self#pAttrs () a + ++ text " " ++ name | TComp (comp, a) -> (* A reference to a struct *) let su = if comp.cstruct then "struct" else "union" in - text (su ^ " " ^ comp.cname ^ " ") - ++ self#pAttrs () a + text (su ^ " " ^ comp.cname ^ " ") + ++ self#pAttrs () a ++ name - - | TEnum (enum, a) -> + + | TEnum (enum, a) -> text ("enum " ^ enum.ename ^ " ") - ++ self#pAttrs () a + ++ self#pAttrs () a ++ name - | 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 + | 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: doc option), (bt': typ) = - match bt with - TFun(rt, args, isva, fa) when !msvcMode -> + let (paren: doc option), (bt': typ) = + match bt with + TFun(rt, args, isva, fa) when !msvcMode -> let an, af', at = partitionAttributes ~default:AttrType fa in (* We take the af' and we put them into the parentheses *) - Some (text "(" ++ printAttributes af'), + Some (text "(" ++ printAttributes af'), TFun(rt, args, isva, addAttributes an at) | TFun _ | TArray _ -> Some (text "("), bt @@ -4235,50 +4385,50 @@ class defaultCilPrinterClass : cilPrinter = object (self) in let name' = text "*" ++ printAttributes a ++ name in let name'' = (* Put the parenthesis *) - match paren with - Some p -> p ++ name' ++ text ")" - | _ -> name' + match paren with + Some p -> p ++ name' ++ text ")" + | _ -> name' in - self#pType + self#pType (Some name'') - () + () bt' - | TArray (elemt, lo, a) -> + | TArray (elemt, lo, a) -> (* ignore the const attribute for arrays *) - let a' = dropAttributes [ "const" ] a in - let name' = + let a' = dropAttributes [ "const" ] a in + let name' = if a' == [] then name else - if nameOpt == None then printAttributes a' else - text "(" ++ printAttributes a' ++ name ++ text ")" + if nameOpt == None then printAttributes a' else + text "(" ++ printAttributes a' ++ name ++ text ")" in - self#pType + self#pType (Some (name' - ++ text "[" + ++ text "[" ++ (match lo with None -> nil | Some e -> self#pExp () e) ++ text "]")) () elemt - - | TFun (restyp, args, isvararg, a) -> - let name' = - if a == [] then name else + + | TFun (restyp, args, isvararg, a) -> + let name' = + if a == [] then name else if nameOpt == None then printAttributes a else - text "(" ++ printAttributes a ++ name ++ text ")" + text "(" ++ printAttributes a ++ name ++ text ")" in - self#pType + self#pType (Some (name' ++ text "(" - ++ (align - ++ - (if args = Some [] && isvararg then + ++ (align + ++ + (if args = Some [] && isvararg then text "..." else - (if args = None then nil + (if args = None then nil else if args = Some [] then text "void" - else - let pArg (aname, atype, aattr) = + else + let pArg (aname, atype, aattr) = let stom, rest = separateStorageModifiers aattr in (* First the storage modifiers *) (self#pAttrs () stom) @@ -4286,7 +4436,7 @@ class defaultCilPrinterClass : cilPrinter = object (self) ++ text " " ++ self#pAttrs () rest in - (docList ~sep:(chr ',' ++ break) pArg) () + (docList ~sep:(chr ',' ++ break) pArg) () (argsToList args)) ++ (if isvararg then break ++ text ", ..." else nil)) ++ unalign) @@ -4297,29 +4447,31 @@ class defaultCilPrinterClass : cilPrinter = object (self) | TNamed (t, a) -> text t.tname ++ self#pAttrs () a ++ text " " ++ name - | TBuiltin_va_list a -> + | TBuiltin_va_list a -> text "__builtin_va_list" - ++ self#pAttrs () a - ++ text " " + ++ self#pAttrs () a + ++ text " " ++ name (**** PRINTING ATTRIBUTES *********) - method pAttrs () (a: attributes) = + method pAttrs () (a: attributes) = self#pAttrsGen false a - (* Print one attribute. Return also an indication whether this attribute + (* Print one attribute. Return also an indication whether this attribute * should be printed inside the __attribute__ list *) method pAttr (Attr(an, args): attribute) : doc * bool = (* Recognize and take care of some known cases *) - match an, args with + match an, args with "const", [] -> text "const", false (* Put the aconst inside the attribute list *) + | "complex", [] when !c99Mode -> text "_Complex", false + | "complex", [] when not !msvcMode -> text "__complex__", false | "aconst", [] when not !msvcMode -> text "__const__", true | "thread", [] when not !msvcMode -> text "__thread", false (* - | "used", [] when not !msvcMode -> text "__attribute_used__", false + | "used", [] when not !msvcMode -> text "__attribute_used__", false *) | "volatile", [] -> text "volatile", false | "restrict", [] -> text "__restrict", false @@ -4327,20 +4479,20 @@ class defaultCilPrinterClass : cilPrinter = object (self) | "cdecl", [] when !msvcMode -> text "__cdecl", false | "stdcall", [] when !msvcMode -> text "__stdcall", false | "fastcall", [] when !msvcMode -> text "__fastcall", false - | "declspec", args when !msvcMode -> - text "__declspec(" + | "declspec", args when !msvcMode -> + text "__declspec(" ++ docList (self#pAttrParam ()) () args ++ text ")", false | "w64", [] when !msvcMode -> text "__w64", false - | "asm", args -> - text "__asm__(" + | "asm", args -> + text "__asm__(" ++ docList (self#pAttrParam ()) () args ++ text ")", 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,[])] -> + | "mode", [ACons(tag,[])] -> text "/* mode(" ++ text tag ++ text ") */", false (* sm: also suppress "format" because we seem to print it in *) @@ -4348,27 +4500,27 @@ class defaultCilPrinterClass : cilPrinter = object (self) | "format", _ -> text "/* format attribute */", false (* sm: here's another one I don't want to see gcc warnings about.. *) - | "mayPointToStack", _ when not !print_CIL_Input + | "mayPointToStack", _ when not !print_CIL_Input (* [matth: may be inside another comment.] - -> text "/*mayPointToStack*/", false + -> text "/*mayPointToStack*/", false *) -> text "", false - | "arraylen", [a] -> + | "arraylen", [a] -> (* text "/*[" ++ self#pAttrParam () a ++ text "]*/" *) nil, false - | _ -> (* This is the dafault case *) + | _ -> (* This is the default case *) (* Add underscores to the name *) let an' = if !msvcMode then "__" ^ an else "__" ^ an ^ "__" in - if args = [] then + if args = [] then text an', true else - text (an' ^ "(") + text (an' ^ "(") ++ (docList (self#pAttrParam ()) () args) - ++ text ")", + ++ text ")", true - method private pAttrPrec (contextprec: int) () (a: attrparam) = + method private pAttrPrec (contextprec: int) () (a: attrparam) = let thisLevel = getParenthLevelAttrParam a in let needParens = if thisLevel >= contextprec then @@ -4385,9 +4537,9 @@ class defaultCilPrinterClass : cilPrinter = object (self) self#pAttrParam () a - method pAttrParam () a = + method pAttrParam () a = let level = getParenthLevelAttrParam a in - match a with + match a with | AInt n -> num n | AStr s -> text ("\"" ^ escape_string s ^ "\"") | ACons(s, []) -> text s @@ -4401,36 +4553,36 @@ class defaultCilPrinterClass : cilPrinter = object (self) | AAlignOfE a -> text "__alignof__(" ++ self#pAttrParam () a ++ text ")" | AAlignOf t -> text "__alignof__(" ++ self#pType None () t ++ text ")" | AAlignOfS ts -> text "__alignof__()" - | AUnOp(u,a1) -> + | AUnOp(u,a1) -> (d_unop () u) ++ chr ' ' ++ (self#pAttrPrec level () a1) - | ABinOp(b,a1,a2) -> - align - ++ text "(" + | ABinOp(b,a1,a2) -> + align + ++ text "(" ++ (self#pAttrPrec level () a1) ++ text ") " ++ (d_binop () b) - ++ break + ++ break ++ text " (" ++ (self#pAttrPrec level () a2) ++ text ") " ++ unalign | ADot (ap, s) -> (self#pAttrParam () ap) ++ text ("." ^ s) - | AStar a1 -> + | AStar a1 -> text "(*" ++ (self#pAttrPrec derefStarLevel () a1) ++ text ")" | AAddrOf a1 -> text "& " ++ (self#pAttrPrec addrOfLevel () a1) - | AIndex (a1, a2) -> self#pAttrParam () a1 ++ text "[" ++ + | AIndex (a1, a2) -> self#pAttrParam () a1 ++ text "[" ++ self#pAttrParam () a2 ++ text "]" - | AQuestion (a1, a2, a3) -> + | AQuestion (a1, a2, a3) -> self#pAttrParam () a1 ++ text " ? " ++ self#pAttrParam () a2 ++ text " : " ++ - self#pAttrParam () a3 + self#pAttrParam () a3 + - (* A general way of printing lists of attributes *) - method private pAttrsGen (block: bool) (a: attributes) = - (* Scan all the attributes and separate those that must be printed inside + method private pAttrsGen (block: bool) (a: attributes) = + (* Scan all the attributes and separate those that must be printed inside * the __attribute__ list *) let rec loop (in__attr__: doc list) = function - [] -> begin + [] -> begin match in__attr__ with [] -> nil | _ :: _-> @@ -4439,7 +4591,7 @@ class defaultCilPrinterClass : cilPrinter = object (self) * Daniel ran into where blockattribute(nobox) was being * dropped by the merger *) - (if block then + (if block then text (" " ^ (forgcc "/*") ^ " __blockattribute__(") else text "__attribute__((") @@ -4449,9 +4601,9 @@ class defaultCilPrinterClass : cilPrinter = object (self) ++ text ")" ++ (if block then text (forgcc "*/") else text ")") end - | x :: rest -> + | x :: rest -> let dx, ina = self#pAttr x in - if ina then + if ina then loop (dx :: in__attr__) rest else if dx = nil then loop in__attr__ rest @@ -4469,47 +4621,47 @@ end (* class defaultCilPrinterClass *) let defaultCilPrinter = new defaultCilPrinterClass (* Top-level printing functions *) -let printType (pp: cilPrinter) () (t: typ) : doc = +let printType (pp: cilPrinter) () (t: typ) : doc = pp#pType None () t - -let printExp (pp: cilPrinter) () (e: exp) : doc = + +let printExp (pp: cilPrinter) () (e: exp) : doc = pp#pExp () e -let printLval (pp: cilPrinter) () (lv: lval) : doc = +let printLval (pp: cilPrinter) () (lv: lval) : doc = pp#pLval () lv -let printGlobal (pp: cilPrinter) () (g: global) : doc = +let printGlobal (pp: cilPrinter) () (g: global) : doc = pp#pGlobal () g -let dumpGlobal (pp: cilPrinter) (out: out_channel) (g: global) : unit = +let dumpGlobal (pp: cilPrinter) (out: out_channel) (g: global) : unit = pp#dGlobal out g -let printAttr (pp: cilPrinter) () (a: attribute) : doc = +let printAttr (pp: cilPrinter) () (a: attribute) : doc = let ad, _ = pp#pAttr a in ad -let printAttrs (pp: cilPrinter) () (a: attributes) : doc = +let printAttrs (pp: cilPrinter) () (a: attributes) : doc = pp#pAttrs () a -let printInstr (pp: cilPrinter) () (i: instr) : doc = +let printInstr (pp: cilPrinter) () (i: instr) : doc = pp#pInstr () i -let printStmt (pp: cilPrinter) () (s: stmt) : doc = +let printStmt (pp: cilPrinter) () (s: stmt) : doc = pp#pStmt () s -let printBlock (pp: cilPrinter) () (b: block) : doc = - (* We must add the alignment ourselves, beucase pBlock will pop it *) +let printBlock (pp: cilPrinter) () (b: block) : doc = + (* We must add the alignment ourselves, because pBlock will pop it *) align ++ pp#pBlock () b -let dumpStmt (pp: cilPrinter) (out: out_channel) (ind: int) (s: stmt) : unit = +let dumpStmt (pp: cilPrinter) (out: out_channel) (ind: int) (s: stmt) : unit = pp#dStmt out ind s -let dumpBlock (pp: cilPrinter) (out: out_channel) (ind: int) (b: block) : unit = +let dumpBlock (pp: cilPrinter) (out: out_channel) (ind: int) (b: block) : unit = pp#dBlock out ind b -let printInit (pp: cilPrinter) () (i: init) : doc = +let printInit (pp: cilPrinter) () (i: init) : doc = pp#pInit () i -let dumpInit (pp: cilPrinter) (out: out_channel) (ind: int) (i: init) : unit = +let dumpInit (pp: cilPrinter) (out: out_channel) (ind: int) (i: init) : unit = pp#dInit out ind i (* Now define some short cuts *) @@ -4521,7 +4673,7 @@ let d_init () i = printInit defaultCilPrinter () i let d_type () t = printType defaultCilPrinter () t let _ = pd_type := d_type let d_global () g = printGlobal defaultCilPrinter () g -let d_attrlist () a = printAttrs defaultCilPrinter () a +let d_attrlist () a = printAttrs defaultCilPrinter () a let d_attr () a = printAttr defaultCilPrinter () a let _ = pd_attr := d_attr let d_attrparam () e = defaultCilPrinter#pAttrParam () e @@ -4583,102 +4735,102 @@ class plainCilPrinterClass = let donecomps : (int, unit) H.t = H.create 13 in object (self) - inherit defaultCilPrinterClass as super - + inherit defaultCilPrinterClass + (*** PLAIN TYPES ***) - method pType (dn: doc option) () (t: typ) = - match dn with + method! pType (dn: doc option) () (t: typ) = + match dn with None -> self#pOnlyType () t | Some d -> d ++ text " : " ++ self#pOnlyType () t - method private pOnlyType () = function + method private pOnlyType () = function TVoid a -> dprintf "TVoid(@[%a@])" self#pAttrs a - | TInt(ikind, a) -> dprintf "TInt(@[%a,@?%a@])" + | TInt(ikind, a) -> dprintf "TInt(@[%a,@?%a@])" d_ikind ikind self#pAttrs a - | TFloat(fkind, a) -> + | TFloat(fkind, a) -> dprintf "TFloat(@[%a,@?%a@])" d_fkind fkind self#pAttrs a | TNamed (t, a) -> - dprintf "TNamed(@[%s,@?%a,@?%a@])" + dprintf "TNamed(@[%s,@?%a,@?%a@])" t.tname self#pOnlyType t.ttype self#pAttrs a | TPtr(t, a) -> dprintf "TPtr(@[%a,@?%a@])" self#pOnlyType t self#pAttrs a - | TArray(t,l,a) -> - let dl = match l with + | TArray(t,l,a) -> + let dl = match l with None -> text "None" | Some l -> dprintf "Some(@[%a@])" self#pExp l in - dprintf "TArray(@[%a,@?%a,@?%a@])" + dprintf "TArray(@[%a,@?%a,@?%a@])" self#pOnlyType t insert dl self#pAttrs a | TEnum(enum,a) -> dprintf "Enum(%s,@[%a@])" enum.ename self#pAttrs a - | TFun(tr,args,isva,a) -> + | TFun(tr,args,isva,a) -> dprintf "TFun(@[%a,@?%a%s,@?%a@])" - self#pOnlyType tr - insert + self#pOnlyType tr + insert (if args = None then text "None" - else (docList ~sep:(chr ',' ++ break) - (fun (an,at,aa) -> - dprintf "%s: %a" an self#pOnlyType at)) - () + else (docList ~sep:(chr ',' ++ break) + (fun (an,at,aa) -> + dprintf "%s: %a" an self#pOnlyType at)) + () (argsToList args)) (if isva then "..." else "") self#pAttrs a - | TComp (comp, a) -> - if H.mem donecomps comp.ckey then - dprintf "TCompLoop(%s %s, _, %a)" - (if comp.cstruct then "struct" else "union") comp.cname + | TComp (comp, a) -> + if H.mem donecomps comp.ckey then + dprintf "TCompLoop(%s %s, _, %a)" + (if comp.cstruct then "struct" else "union") comp.cname self#pAttrs comp.cattr else begin H.add donecomps comp.ckey (); (* Add it before we do the fields *) - dprintf "TComp(@[%s %s,@?%a,@?%a,@?%a@])" + dprintf "TComp(@[%s %s,@?%a,@?%a,@?%a@])" (if comp.cstruct then "struct" else "union") comp.cname - (docList ~sep:(chr ',' ++ break) - (fun f -> dprintf "%s : %a" f.fname self#pOnlyType f.ftype)) + (docList ~sep:(chr ',' ++ break) + (fun f -> dprintf "%s : %a" f.fname self#pOnlyType f.ftype)) comp.cfields self#pAttrs comp.cattr self#pAttrs a end - | TBuiltin_va_list a -> + | TBuiltin_va_list a -> dprintf "TBuiltin_va_list(%a)" self#pAttrs a - - (* Some plain pretty-printers. Unlike the above these expose all the + + (* Some plain pretty-printers. Unlike the above these expose all the * details of the internal representation *) - method pExp () = function - Const(c) -> - let d_plainconst () c = + method! pExp () = function + Const(c) -> + let d_plainconst () c = match c with - CInt64(i, ik, so) -> + CInt64(i, ik, so) -> let fmt = if isSigned ik then "%d" else "%x" in - dprintf "Int64(%s,%a,%s)" + dprintf "Int64(%s,%a,%s)" (Int64.format fmt i) d_ikind ik (match so with Some s -> s | _ -> "None") - | CStr(s) -> + | CStr(s) -> text ("CStr(\"" ^ escape_string s ^ "\")") - | CWStr(s) -> + | CWStr(s) -> dprintf "CWStr(%a)" d_const c - + | CChr(c) -> text ("CChr('" ^ escape_char c ^ "')") - | CReal(f, fk, so) -> - dprintf "CReal(%f, %a, %s)" + | CReal(f, fk, so) -> + dprintf "CReal(%f, %a, %s)" f - d_fkind fk + d_fkind fk (match so with Some s -> s | _ -> "None") | CEnum(_, s, _) -> text s in text "Const(" ++ d_plainconst () c ++ text ")" - | Lval(lv) -> - text "Lval(" + | Lval(lv) -> + text "Lval(" ++ (align ++ self#pLval () lv ++ unalign) ++ text ")" - + | CastE(t,e) -> dprintf "CastE(@[%a,@?%a@])" self#pOnlyType t self#pExp e - | UnOp(u,e1,_) -> + | UnOp(u,e1,_) -> dprintf "UnOp(@[%a,@?%a@])" d_unop u self#pExp e1 - - | BinOp(b,e1,e2,_) -> + + | BinOp(b,e1,e2,_) -> let d_plainbinop () b = match b with PlusA -> text "PlusA" @@ -4696,17 +4848,20 @@ class plainCilPrinterClass = dprintf "Question(@[%a,@?%a,@?%a@])" self#pExp e1 self#pExp e2 self#pExp e3 - | SizeOf (t) -> + | SizeOf (t) -> text "sizeof(" ++ self#pType None () t ++ chr ')' - | SizeOfE (e) -> + | SizeOfE (e) -> text "sizeofE(" ++ self#pExp () e ++ chr ')' - | SizeOfStr (s) -> + | SizeOfStr (s) -> text "sizeofStr(" ++ d_const () (CStr s) ++ chr ')' - | AlignOf (t) -> + | AlignOf (t) -> text "__alignof__(" ++ self#pType None () t ++ chr ')' - | AlignOfE (e) -> + | AlignOfE (e) -> text "__alignof__(" ++ self#pExp () e ++ chr ')' - + | Imag e -> + text "__imag__(" ++ self#pExp () e ++ chr ')' + | Real e -> + text "__real__(" ++ self#pExp () e ++ chr ')' | StartOf lv -> dprintf "StartOf(%a)" self#pLval lv | AddrOf (lv) -> dprintf "AddrOf(%a)" self#pLval lv | AddrOfLabel (sref) -> dprintf "AddrOfLabel(%a)" self#pStmt !sref @@ -4715,32 +4870,32 @@ class plainCilPrinterClass = method private d_plainoffset () = function NoOffset -> text "NoOffset" - | Field(fi,o) -> - dprintf "Field(@[%s:%a,@?%a@])" + | Field(fi,o) -> + dprintf "Field(@[%s:%a,@?%a@])" fi.fname self#pOnlyType fi.ftype self#d_plainoffset o - | Index(e, o) -> + | Index(e, o) -> dprintf "Index(@[%a,@?%a@])" self#pExp e self#d_plainoffset o - method pInit () = function + method! pInit () = function SingleInit e -> dprintf "SI(%a)" d_exp e - | CompoundInit (t, initl) -> - let d_plainoneinit (o, i) = + | CompoundInit (t, initl) -> + let d_plainoneinit (o, i) = self#d_plainoffset () o ++ text " = " ++ self#pInit () i in dprintf "CI(@[%a,@?%a@])" self#pOnlyType t (docList ~sep:(chr ',' ++ break) d_plainoneinit) initl (* - | ArrayInit (t, len, initl) -> + | ArrayInit (t, len, initl) -> let idx = ref (- 1) in - let d_plainoneinit i = + let d_plainoneinit i = incr idx; text "[" ++ num !idx ++ text "] = " ++ self#pInit () i in dprintf "AI(@[%a,%d,@?%a@])" self#pOnlyType t len (docList ~sep:(chr ',' ++ break) d_plainoneinit) initl -*) - method pLval () (lv: lval) = - match lv with +*) + method! pLval () (lv: lval) = + match lv with | Var vi, o -> dprintf "Var(@[%s,@?%a@])" vi.vname self#d_plainoffset o | Mem e, o -> dprintf "Mem(@[%a,@?%a@])" self#pExp e self#d_plainoffset o @@ -4768,7 +4923,7 @@ object (self) 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. - + The boolean here enables descriptive printing. Usually use true here, but you can set enable to false to make this class behave like defaultCilPrinterClass. This allows subclasses to turn the @@ -4812,16 +4967,16 @@ object (self) super#pVar vi (* Only substitute temp vars that appear in expressions. - (Other occurrences of lvalues are the left-hand sides of assignments, + (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 pExp () (e:exp) : doc = + method! pExp () (e:exp) : doc = if enable then match e with Lval (Var vi, o) - | StartOf (Var vi, o) -> + | StartOf (Var vi, o) -> self#pOffset (self#pVarDescriptive vi) o - | AddrOf (Var vi, o) -> + | AddrOf (Var vi, o) -> (* No parens needed, since offsets have higher precedence than & *) text "& " ++ self#pOffset (self#pVarDescriptive vi) o | _ -> super#pExp () e @@ -4829,7 +4984,7 @@ object (self) super#pExp () e end -let descriptiveCilPrinter: descriptiveCilPrinter = +let descriptiveCilPrinter: descriptiveCilPrinter = ((new descriptiveCilPrinterClass true) :> descriptiveCilPrinter) let dd_exp = descriptiveCilPrinter#pExp @@ -4840,20 +4995,20 @@ let dd_lval = descriptiveCilPrinter#pLval let printerForMaincil = ref defaultCilPrinter let rec d_typsig () = function - TSArray (ts, eo, al) -> - dprintf "TSArray(@[%a,@?%a,@?%a@])" - d_typsig ts - insert (text (match eo with None -> "None" + TSArray (ts, eo, al) -> + dprintf "TSArray(@[%a,@?%a,@?%a@])" + d_typsig ts + insert (text (match eo with None -> "None" | Some e -> "Some " ^ Int64.to_string e)) d_attrlist al - | TSPtr (ts, al) -> + | TSPtr (ts, al) -> dprintf "TSPtr(@[%a,@?%a@])" d_typsig ts d_attrlist al - | TSComp (iss, name, al) -> + | TSComp (iss, name, al) -> dprintf "TSComp(@[%s %s,@?%a@])" (if iss then "struct" else "union") name d_attrlist al - | TSFun (rt, args, isva, al) -> + | TSFun (rt, args, isva, al) -> dprintf "TSFun(@[%a,@?%a,%B,@?%a@])" d_typsig rt insert @@ -4863,21 +5018,21 @@ let rec d_typsig () = function docList ~sep:(chr ',' ++ break) (d_typsig ()) () args) isva d_attrlist al - | TSEnum (n, al) -> + | TSEnum (n, al) -> dprintf "TSEnum(@[%s,@?%a@])" n d_attrlist al | TSBase t -> dprintf "TSBase(%a)" d_type t -let newVID () = - let t = !nextGlobalVID in +let newVID () = + let t = !nextGlobalVID in incr nextGlobalVID; t (* Make a varinfo. Used mostly as a helper function below *) let makeVarinfo global name ?init typ = (* Strip const from type for locals *) - let vi = + let vi = { vname = name; vid = newVID (); vglob = global; @@ -4891,10 +5046,11 @@ let makeVarinfo global name ?init typ = vreferenced = false; vdescr = nil; vdescrpure = true; + vhasdeclinstruction = false; } in vi - -let copyVarinfo (vi: varinfo) (newname: string) : varinfo = + +let copyVarinfo (vi: varinfo) (newname: string) : varinfo = let vi' = {vi with vname = newname; vid = newVID () } in vi' @@ -4902,7 +5058,7 @@ let makeLocal fdec name typ init = (* a helper function *) fdec.smaxid <- 1 + fdec.smaxid; let vi = makeVarinfo false name ?init:init typ in vi - + (* Make a local variable and add it to a function *) let makeLocalVar fdec ?(insert = true) name ?init typ = let vi = makeLocal fdec name typ init in @@ -4929,85 +5085,85 @@ let makeTempVar fdec ?(insert = true) ?(name = "__cil_tmp") vi.vdescrpure <- descrpure; vi - + (* Set the formals and re-create the function name based on the information*) -let setFormals (f: fundec) (forms: varinfo list) = +let setFormals (f: fundec) (forms: varinfo list) = f.sformals <- forms; (* Set the formals *) match unrollType f.svar.vtype with - TFun(rt, _, isva, fa) -> - f.svar.vtype <- - TFun(rt, - Some (Util.list_map (fun a -> (a.vname, a.vtype, a.vattr)) forms), + TFun(rt, _, isva, fa) -> + f.svar.vtype <- + TFun(rt, + Some (Util.list_map (fun a -> (a.vname, a.vtype, a.vattr)) forms), isva, fa) | _ -> E.s (E.bug "Set formals. %s does not have function type\n" f.svar.vname) - - (* Set the types of arguments and results as given by the function type + + (* Set the types of arguments and results as given by the function type * passed as the second argument *) -let setFunctionType (f: fundec) (t: typ) = +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 + TFun (rt, Some args, va, a) -> + if List.length f.sformals <> List.length args then E.s (E.bug "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 + 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) + List.iter2 + (fun (an,at,aa) f -> + f.vtype <- at; f.vattr <- aa) args f.sformals | _ -> E.s (E.bug "setFunctionType: not a function type") - - (* Set the types of arguments and results as given by the 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) = +let setFunctionTypeMakeFormals (f: fundec) (t: typ) = match unrollType t with - TFun (rt, Some args, va, a) -> - if f.sformals <> [] then + TFun (rt, Some args, va, a) -> + if f.sformals <> [] then E.s (E.warn "setFunctionTypMakeFormals called on function %s with some formals already" f.svar.vname); (* Change the function type. *) - f.svar.vtype <- t; + f.svar.vtype <- t; f.sformals <- []; - + f.sformals <- Util.list_map (fun (n,t,a) -> makeLocal f n t None) args; setFunctionType f t | _ -> E.s (E.bug "setFunctionTypeMakeFormals: not a function type: %a" d_type t) - -let setMaxId (f: fundec) = + +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 + + (* 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 = +let makeFormalVar fdec ?(where = "$") name typ : varinfo = (* Search for the insertion place *) let thenewone = ref fdec.svar in (* Just a placeholder *) - let makeit () : varinfo = + let makeit () : varinfo = let vi = makeLocal fdec name typ None in thenewone := vi; vi in let rec loopFormals = function - [] -> + [] -> if where = "$" then [makeit ()] else E.s (E.error "makeFormalVar: cannot find insert-after formal %s" where) | f :: rest when f.vname = where -> f :: makeit () :: rest | f :: rest -> f :: loopFormals rest in - let newformals = - if where = "^" then makeit () :: fdec.sformals else + let newformals = + if where = "^" then makeit () :: fdec.sformals else loopFormals fdec.sformals in setFormals fdec newformals; !thenewone @@ -5020,7 +5176,7 @@ let makeGlobalVar name typ = (* Make an empty function *) -let emptyFunction name = +let emptyFunction name = { svar = makeGlobalVar name (TFun(voidType, Some [], false,[])); smaxid = 0; slocals = []; @@ -5028,39 +5184,39 @@ let emptyFunction name = sbody = mkBlock []; smaxstmtid = None; sallstmts = []; - } + } (* A dummy function declaration handy for initialization *) let dummyFunDec = emptyFunction "@dummy" -let dummyFile = +let dummyFile = { globals = []; fileName = ""; globinit = None; globinitcalled = false;} (***** Load and store files as unmarshalled Ocaml binary data. ****) -type savedFile = +type savedFile = { savedFile: file; savedNextVID: int; savedNextCompinfoKey: int} let saveBinaryFileChannel (cil_file : file) (outchan : out_channel) = - let save = {savedFile = cil_file; + let save = {savedFile = cil_file; savedNextVID = !nextGlobalVID; savedNextCompinfoKey = !nextCompinfoKey} in - Marshal.to_channel outchan save [] + Marshal.to_channel outchan save [] let saveBinaryFile (cil_file : file) (filename : string) = let outchan = open_out_bin filename in saveBinaryFileChannel cil_file outchan; - close_out outchan + close_out outchan (** Read a {!Cil.file} in binary form from the filesystem. The first * argument is the name of a file previously created by * {!Cil.saveBinaryFile}. Because this also reads some global state, * this should be called before any other CIL code is parsed or generated. *) -let loadBinaryFile (filename : string) : file = +let loadBinaryFile (filename : string) : file = let inchan = open_in_bin filename in let loaded : savedFile = (Marshal.from_channel inchan : savedFile) in close_in inchan ; @@ -5077,22 +5233,22 @@ let loadBinaryFile (filename : string) : file = loaded.savedFile -(* Take the name of a file and make a valid symbol name out of it. There are +(* Take the name of a file and make a valid symbol name out of it. There are * a few characters that are not valid in symbols *) -let makeValidSymbolName (s: string) = - let s = String.copy s in (* So that we can update in place *) +let makeValidSymbolName (s: string) = + let b = Bytes.copy (Bytes.of_string s) in (* So that we can update in place *) let l = String.length s in for i = 0 to l - 1 do let c = String.get s i in - let isinvalid = + let isinvalid = match c with '-' | '.' -> true | _ -> false in - if isinvalid then - String.set s i '_'; + if isinvalid then + Bytes.set b i '_'; done; - s + Bytes.to_string b let rec addOffset (toadd: offset) (off: offset) : offset = match off with @@ -5100,23 +5256,23 @@ let rec addOffset (toadd: offset) (off: offset) : offset = | Field(fid', offset) -> Field(fid', addOffset toadd offset) | Index(e, offset) -> Index(e, addOffset toadd offset) - (* Add an offset at the end of an lv *) + (* Add an offset at the end of an lv *) let addOffsetLval toadd (b, off) : lval = b, addOffset toadd off -let rec removeOffset (off: offset) : offset * offset = - match off with +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) -> + | Field(f, restoff) -> let off', last = removeOffset restoff in Field(f, off'), last - | Index(i, restoff) -> + | Index(i, restoff) -> let off', last = removeOffset restoff in Index(i, off'), last -let removeOffsetLval ((b, off): lval) : lval * offset = +let removeOffsetLval ((b, off): lval) : lval * offset = let off', last = removeOffset off in (b, off'), last @@ -5125,28 +5281,28 @@ let removeOffsetLval ((b, off): lval) : lval * offset = (* visit all the nodes in a Cil expression *) let doVisit (vis: cilVisitor) (action: 'a visitAction) - (children: cilVisitor -> 'a -> 'a) - (node: 'a) : 'a = + (children: cilVisitor -> 'a -> 'a) + (node: 'a) : 'a = match action with SkipChildren -> node | ChangeTo node' -> node' | DoChildren -> children vis node | ChangeDoChildrenPost(node', f) -> f (children vis node') -(* mapNoCopy is like map but avoid copying the list if the function does not +(* mapNoCopy is like map but avoid copying the list if the function does not * change the elements. *) let mapNoCopy (f: 'a -> 'a) l = let rec aux acc changed = function [] -> if changed then List.rev acc else l - | i :: resti -> + | i :: resti -> let i' = f i in aux (i' :: acc) (changed || i != i') resti in aux [] false l -let rec mapNoCopyList (f: 'a -> 'a list) l = +let mapNoCopyList (f: 'a -> 'a list) l = let rec aux acc changed = function [] -> if changed then List.rev acc else l - | i :: resti -> + | i :: resti -> let il' = f i in let has_changed = match il' with @@ -5159,87 +5315,92 @@ let rec mapNoCopyList (f: 'a -> 'a list) l = let doVisitList (vis: cilVisitor) (action: 'a list visitAction) (children: cilVisitor -> 'a -> 'a) - (node: 'a) : 'a list = + (node: 'a) : 'a list = match action with SkipChildren -> [node] | ChangeTo nodes' -> nodes' | DoChildren -> [children vis node] | ChangeDoChildrenPost(nodes', f) -> f (mapNoCopy (fun n -> children vis n) nodes') - + let debugVisit = false -let rec visitCilExpr (vis: cilVisitor) (e: exp) : exp = +let rec visitCilExpr (vis: cilVisitor) (e: exp) : exp = doVisit vis (vis#vexpr e) childrenExp e -and childrenExp (vis: cilVisitor) (e: exp) : exp = +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 match e with - | Const (CEnum(v, s, ei)) -> - let v' = vExp v in + | Const (CEnum(v, s, ei)) -> + let v' = vExp v in if v' != v then Const (CEnum(v', s, ei)) else e | Const _ -> e - | SizeOf t -> - let t'= vTyp t in + | SizeOf t -> + let t'= vTyp t in if t' != t then SizeOf t' else e - | SizeOfE e1 -> + | SizeOfE e1 -> let e1' = vExp e1 in if e1' != e1 then SizeOfE e1' else e | SizeOfStr s -> e - - | AlignOf t -> + | Real e1 -> + let e1' = vExp e1 in + if e1' != e1 then Real e1' else e + | Imag e1 -> + let e1' = vExp e1 in + if e1' != e1 then Imag e1' else e + | AlignOf t -> let t' = vTyp t in if t' != t then AlignOf t' else e - | AlignOfE e1 -> + | AlignOfE e1 -> let e1' = vExp e1 in if e1' != e1 then AlignOfE e1' else e - | Lval lv -> + | Lval lv -> let lv' = vLval lv in if lv' != lv then Lval lv' else e - | UnOp (uo, e1, t) -> + | UnOp (uo, e1, t) -> let e1' = vExp e1 in let t' = vTyp t in if e1' != e1 || t' != t then UnOp(uo, e1', t') else e - | BinOp (bo, e1, e2, t) -> + | 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 BinOp(bo, e1',e2',t') else e | Question (e1, e2, e3, t) -> let e1' = vExp e1 in let e2' = vExp e2 in let e3' = vExp e3 in let t' = vTyp t in if e1' != e1 || e2' != e2 || e3' != e3 || t' != t then Question(e1',e2',e3',t') else e - | CastE (t, e1) -> + | CastE (t, e1) -> let t' = vTyp t in let e1' = vExp e1 in if t' != t || e1' != e1 then CastE(t', e1') else e - | AddrOf lv -> + | AddrOf lv -> let lv' = vLval lv in if lv' != lv then AddrOf lv' else e | AddrOfLabel _ -> e - | StartOf lv -> + | StartOf lv -> let lv' = vLval lv in if lv' != lv then StartOf lv' else e -and visitCilInit (vis: cilVisitor) (forglob: varinfo) - (atoff: offset) (i: init) : init = - let rec childrenInit (vis: cilVisitor) (i: init) : init = +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 -> + | 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 + (* 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 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 + let newio = + if o' != o || i' != i then + begin hasChanged := true; (o', i') end else oi in newinitl := newio :: !newinitl in @@ -5248,10 +5409,10 @@ and visitCilInit (vis: cilVisitor) (forglob: varinfo) if t' != t || initl' != initl then CompoundInit (t', initl') else i in doVisit vis (vis#vinit forglob atoff i) childrenInit i - + and visitCilLval (vis: cilVisitor) (lv: lval) : lval = doVisit vis (vis#vlval lv) childrenLval lv -and childrenLval (vis: cilVisitor) (lv: lval) : lval = +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 @@ -5260,7 +5421,7 @@ and childrenLval (vis: cilVisitor) (lv: lval) : lval = let v' = doVisit vis (vis#vvrbl v) (fun _ x -> x) v in let off' = vOff off in if v' != v || off' != off then Var v', off' else lv - | Mem e, off -> + | Mem e, off -> let e' = vExp e in let off' = vOff off in if e' != e || off' != off then Mem e', off' else lv @@ -5270,10 +5431,10 @@ and visitCilOffset (vis: cilVisitor) (off: offset) : offset = and childrenOffset (vis: cilVisitor) (off: offset) : offset = let vOff off = visitCilOffset vis off in match off with - Field (f, o) -> + Field (f, o) -> let o' = vOff o in if o' != o then Field (f, o') else off - | Index (e, o) -> + | 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 @@ -5282,7 +5443,7 @@ and childrenOffset (vis: cilVisitor) (off: offset) : offset = (* 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 + * is moot according to cil.mli which claims the offsets in * initializers will never recursively contain offsets) *) and visitCilInitOffset (vis: cilVisitor) (off: offset) : offset = @@ -5301,23 +5462,24 @@ and childrenInstr (vis: cilVisitor) (i: instr) : instr = let fExp e = visitCilExpr vis e in let fLval lv = visitCilLval vis lv in match i with - | Set(lv,e,l) -> + | VarDecl(v,l) -> i + | Set(lv,e,l) -> let lv' = fLval lv in let e' = fExp e in if lv' != lv || e' != e then Set(lv',e',l) else i - | Call(None,f,args,l) -> + | 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 + | 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 + if lv' != lv || fn' != fn || args' != args then Call(Some lv', fn', args', l) else i - | Asm(sl,isvol,outs,ins,clobs,l) -> - let outs' = mapNoCopy (fun ((id,s,lv) as pair) -> + | Asm(sl,isvol,outs,ins,clobs,l) -> + let outs' = mapNoCopy (fun ((id,s,lv) as pair) -> let lv' = fLval lv in if lv' != lv then (id,s,lv') else pair) outs in - let ins' = mapNoCopy (fun ((id,s,e) as pair) -> + let ins' = mapNoCopy (fun ((id,s,e) as pair) -> let e' = fExp e in if e' != e then (id,s,e') else pair) ins in if outs' != outs || ins' != ins then @@ -5333,15 +5495,15 @@ and visitCilStmt (vis: cilVisitor) (s: stmt) : stmt = let res = doVisit vis (vis#vstmt s) (childrenStmt toPrepend) s in (* Now see if we have saved some instructions *) toPrepend := !toPrepend @ vis#unqueueInstr (); - (match !toPrepend with + (match !toPrepend with [] -> () (* Return the same statement *) - | _ -> + | _ -> (* Make our statement contain the instructions to prepend *) res.skind <- Block { battrs = []; bstmts = [ mkStmt (Instr !toPrepend); mkStmt res.skind ] }); currentLoc := oldloc; res - + and childrenStmt (toPrepend: instr list ref) : cilVisitor -> stmt -> stmt = (* this is a hack to avoid currying and reduce GC pressure *) () ; fun vis s -> @@ -5349,71 +5511,71 @@ and childrenStmt (toPrepend: instr list ref) : cilVisitor -> stmt -> stmt = let fBlock b = visitCilBlock vis b in let fInst i = visitCilInstr vis i in (* Just change the statement kind *) - let skind' = + let skind' = match s.skind with Break _ | Continue _ | Goto _ | Return (None, _) -> s.skind | ComputedGoto (e, l) -> let e' = fExp e in if e' != e then ComputedGoto (e', l) else s.skind - | Return (Some e, l) -> + | Return (Some e, l) -> let e' = fExp e in if e' != e then Return (Some e', l) else s.skind - | Loop (b, l, s1, s2) -> + | Loop (b, l, s1, s2) -> let b' = fBlock b in if b' != b then Loop (b', l, s1, s2) else s.skind - | If(e, s1, s2, l) -> - let e' = fExp e in + | 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 (); + 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' != e || s1' != s1 || s2' != s2 then If(e', s1', s2', l) else s.skind - | Switch (e, b, stmts, l) -> - let e' = fExp e in + | Switch (e, b, stmts, l) -> + let e' = fExp e in toPrepend := vis#unqueueInstr (); (* insert these before the switch *) let b' = fBlock b in (* the stmts in b should have cleaned up after themselves.*) assertEmptyQueue vis; (* Don't do stmts, but we better not change those *) if e' != e || b' != b then Switch (e', b', stmts, l) else s.skind - | Instr il -> + | Instr il -> let il' = mapNoCopyList fInst il in if il' != il then Instr il' else s.skind - | Block b -> - let b' = fBlock b in + | Block b -> + let b' = fBlock b in if b' != b then Block b' else s.skind - | TryFinally (b, h, l) -> + | 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) -> + | 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 il'' = let more = vis#unqueueInstr () in - if more != [] then + 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) + 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 labels' = let fLabel = function - Case (e, l) as lb -> + Case (e, l) as lb -> let e' = fExp e in if e' != e then Case (e', l) else lb | CaseRange (e1, e2, l) as lb -> @@ -5426,12 +5588,12 @@ and childrenStmt (toPrepend: instr list ref) : cilVisitor -> stmt -> stmt = in if labels' != s.labels then s.labels <- labels'; s - - - -and visitCilBlock (vis: cilVisitor) (b: block) : block = + + + +and visitCilBlock (vis: cilVisitor) (b: block) : block = doVisit vis (vis#vblock b) childrenBlock b -and childrenBlock (vis: cilVisitor) (b: block) : block = +and childrenBlock (vis: cilVisitor) (b: block) : block = let fStmt s = visitCilStmt vis s in let stmts' = mapNoCopy fStmt b.bstmts in if stmts' != b.bstmts then { battrs = b.battrs; bstmts = stmts'} else b @@ -5444,15 +5606,15 @@ and childrenType (vis : cilVisitor) (t : typ) : typ = let fTyp t = visitCilType vis t in let fAttr a = visitCilAttributes vis a in match t with - TPtr(t1, a) -> + 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) -> + | TArray(t1, None, a) -> let t1' = fTyp t1 in let a' = fAttr a in if t1' != t1 || a' != a then TArray(t1', None, a') else t - | TArray(t1, Some e, a) -> + | TArray(t1, Some e, a) -> let t1' = fTyp t1 in let e' = visitCilExpr vis e in let a' = fAttr a in @@ -5464,22 +5626,22 @@ and childrenType (vis : cilVisitor) (t : typ) : typ = let a' = fAttr a in if a != a' then TComp(cinfo, a') else t - | TFun(rettype, args, isva, a) -> + | 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 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 + 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) -> (* Do not go into the type. Will do it at the time of + | TNamed(t1, a) -> (* Do not go into the type. Will do it at the time of * GType *) let a' = fAttr a in if a' != a then TNamed (t1, a') else t @@ -5489,7 +5651,7 @@ and childrenType (vis : cilVisitor) (t : typ) : typ = 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 *) @@ -5505,50 +5667,50 @@ and childrenVarDecl (vis : cilVisitor) (v : varinfo) : varinfo = v and visitCilAttributes (vis: cilVisitor) (al: attribute list) : attribute list= - let al' = + let al' = mapNoCopyList (fun x -> doVisitList vis (vis#vattr x) childrenAttribute x) al in - if al' != al then + if al' != al then (* Must re-sort *) addAttributes al' [] else al -and childrenAttribute (vis: cilVisitor) (a: attribute) : attribute = +and childrenAttribute (vis: cilVisitor) (a: attribute) : attribute = let fAttrP a = visitCilAttrParams vis a in - match a with - Attr (n, args) -> + match a with + Attr (n, args) -> let args' = mapNoCopy fAttrP args in if args' != args then Attr(n, args') else a - + and visitCilAttrParams (vis: cilVisitor) (a: attrparam) : attrparam = doVisit vis (vis#vattrparam a) childrenAttrparam a -and childrenAttrparam (vis: cilVisitor) (aa: attrparam) : attrparam = +and childrenAttrparam (vis: cilVisitor) (aa: attrparam) : attrparam = let fTyp t = visitCilType vis t in let fAttrP a = visitCilAttrParams vis a in - match aa with + match aa with AInt _ | AStr _ -> aa - | ACons(n, args) -> + | ACons(n, args) -> let args' = mapNoCopy fAttrP args in if args' != args then ACons(n, args') else aa - | ASizeOf t -> + | ASizeOf t -> let t' = fTyp t in if t' != t then ASizeOf t' else aa - | ASizeOfE e -> + | ASizeOfE e -> let e' = fAttrP e in if e' != e then ASizeOfE e' else aa - | AAlignOf t -> + | AAlignOf t -> let t' = fTyp t in if t' != t then AAlignOf t' else aa - | AAlignOfE e -> + | AAlignOfE e -> let e' = fAttrP e in if e' != e then AAlignOfE e' else aa | ASizeOfS _ | AAlignOfS _ -> ignore (warn "Visitor inside of a type signature."); aa - | AUnOp (uo, e1) -> + | AUnOp (uo, e1) -> let e1' = fAttrP e1 in if e1' != e1 then AUnOp (uo, e1') else aa - | ABinOp (bo, e1, e2) -> + | 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 @@ -5561,17 +5723,17 @@ and childrenAttrparam (vis: cilVisitor) (aa: attrparam) : attrparam = | AAddrOf ap -> let ap' = fAttrP ap in if ap' != ap then AAddrOf ap' else aa - | AIndex (e1, e2) -> + | 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) -> + | 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 + if e1' != e1 || e2' != e2 || e3' != e3 then AQuestion (e1', e2', e3') else aa - + let rec visitCilFunction (vis : cilVisitor) (f : fundec) : fundec = if debugVisit then ignore (E.log "Visiting function %s\n" f.svar.vname); @@ -5579,7 +5741,7 @@ let rec visitCilFunction (vis : cilVisitor) (f : fundec) : fundec = let f = doVisit vis (vis#vfunc f) childrenFunction f in let toPrepend = vis#unqueueInstr () in - if toPrepend <> [] then + if toPrepend <> [] then f.sbody.bstmts <- mkStmt (Instr toPrepend) :: f.sbody.bstmts; f @@ -5597,7 +5759,7 @@ and childrenFunction (vis : cilVisitor) (f : fundec) : fundec = let toPrepend = vis#unqueueInstr () in f.sbody <- visitCilBlock vis f.sbody; (* visit the body *) - if toPrepend <> [] then + if toPrepend <> [] then f.sbody.bstmts <- mkStmt (Instr toPrepend) :: f.sbody.bstmts; f @@ -5611,7 +5773,7 @@ let rec visitCilGlobal (vis: cilVisitor) (g: global) : global list = res and childrenGlobal (vis: cilVisitor) (g: global) : global = match g with - | GFun (f, l) -> + | GFun (f, l) -> let f' = visitCilFunction vis f in if f' != f then GFun (f', l) else g | GType(t, l) -> @@ -5629,8 +5791,8 @@ and childrenGlobal (vis: cilVisitor) (g: global) : global = | GCompTag (comp, _) -> (* (trace "visit" (dprintf "visiting global comp %s\n" comp.cname)); *) - (* Do the types and attirbutes of the fields *) - let fieldVisit = fun fi -> + (* Do the types and attributes of the fields *) + let fieldVisit = fun fi -> fi.ftype <- visitCilType vis fi.ftype; fi.fattr <- visitCilAttributes vis fi.fattr in @@ -5638,10 +5800,10 @@ and childrenGlobal (vis: cilVisitor) (g: global) : global = comp.cattr <- visitCilAttributes vis comp.cattr; g - | GVarDecl(v, l) -> + | GVarDecl(v, l) -> let v' = visitCilVarDecl vis v in if v' != v then GVarDecl (v', l) else g - | GVar (v, inito, l) -> + | GVar (v, inito, l) -> let v' = visitCilVarDecl vis v in if v' != v then GVar (v', inito, l) else g @@ -5653,31 +5815,31 @@ and childrenGlobal (vis: cilVisitor) (g: global) : global = | _ -> g -(** A visitor that does constant folding. If "machdep" is true then we do +(** 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. + + 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(_,(Lval (Var vi,NoOffset)),_,_) - when ((vi.vname = "__builtin_va_arg") + Call(_,(Lval (Var vi,NoOffset)),_,_) + when ((vi.vname = "__builtin_va_arg") || (vi.vname = "__builtin_types_compatible_p")) -> SkipChildren | _ -> DoChildren - method vexpr (e: exp) = + method! vexpr (e: exp) = (* Do it bottom up *) ChangeDoChildrenPost (e, constFold machdep) - + end let constFoldVisitor (machdep: bool) = new constFoldVisitorClass machdep (* Iterate over all globals, including the global initializer *) let iterGlobals (fl: file) (doone: global -> unit) : unit = - let doone' g = + let doone' g = currentLoc := get_globalLoc g; doone g in @@ -5687,10 +5849,10 @@ let iterGlobals (fl: file) | Some g -> doone' (GFun(g, locUnknown))) (* Fold over all globals, including the global initializer *) -let foldGlobals (fl: file) - (doone: 'a -> global -> 'a) - (acc: 'a) : 'a = - let doone' acc g = +let foldGlobals (fl: file) + (doone: 'a -> global -> 'a) + (acc: 'a) : 'a = + let doone' acc g = currentLoc := get_globalLoc g; doone acc g in @@ -5706,11 +5868,11 @@ let foldGlobals (fl: 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 = +let findOrCreateFunc (f:file) (name:string) (t:typ) : varinfo = + let rec search glist = match glist with - GVarDecl(vi,_) :: rest | GFun ({svar = vi},_) :: rest when vi.vname = name -> - if not (isFunctionType vi.vtype) then + GVarDecl(vi,_) :: rest | GFun ({svar = vi; _},_) :: rest when vi.vname = name -> + if not (isFunctionType vi.vtype) then E.s (error ("findOrCreateFunc: can't create %s because another " ^^"global exists with that name.") name); vi @@ -5728,10 +5890,10 @@ let findOrCreateFunc (f:file) (name:string) (t:typ) : varinfo = (* A visitor for the whole file that does not change the globals *) let visitCilFileSameGlobals (vis : cilVisitor) (f : file) : unit = let fGlob g = visitCilGlobal vis g in - iterGlobals f (fun g -> - match fGlob g with + iterGlobals f (fun g -> + match fGlob g with [g'] when g' == g || Util.equals g' g -> () (* Try to do the pointer check first *) - | gl -> + | gl -> ignore (E.log "You used visitCilFilSameGlobals but the global got changed:\n %a\nchanged to %a\n" d_global g (docList ~sep:line (d_global ())) gl); ()) @@ -5741,7 +5903,7 @@ let visitCilFile (vis : cilVisitor) (f : file) : unit = (* Scan the globals. Make sure this is tail recursive. *) let rec loop (acc: global list) = function [] -> f.globals <- List.rev acc - | g :: restg -> + | g :: restg -> loop ((List.rev (fGlob g)) @ acc) restg in loop [] f.globals; @@ -5752,49 +5914,49 @@ let visitCilFile (vis : cilVisitor) (f : file) : unit = -(** Create or fetch the global initializer. Tries to put a call to the +(** 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 +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 + (* Sadly, we cannot use the Filename library because it does not like * function names with multiple . in them *) - let f = + let f = let len = String.length fl.fileName in - (* Find the last path separator and record the first . that we see, + (* Find the last path separator and record the first . that we see, * going backwards *) let lastDot = ref len in - let rec findLastPathSep i = + 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 + 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) + let basenoext = + String.sub fl.fileName (lastPathSep + 1) (!lastDot - lastPathSep - 1) in - emptyFunction + emptyFunction (makeValidSymbolName ("__globinit_" ^ basenoext)) in fl.globinit <- Some f; - (* Now try to add a call to the global initialized at the beginning of + (* Now try to add a call to the global initialized at the beginning of * main *) let inserted = ref false in - List.iter - (function + List.iter + (function GFun(m, lm) when m.svar.vname = main_name -> (* Prepend a prototype to the global initializer *) fl.globals <- GVarDecl (f.svar, lm) :: fl.globals; - m.sbody.bstmts <- - compactStmts (mkStmt (Instr [Call(None, - Lval(var f.svar), - [], locUnknown)]) + m.sbody.bstmts <- + compactStmts (mkStmt (Instr [Call(None, + Lval(var f.svar), + [], locUnknown)]) :: m.sbody.bstmts); inserted := true; if !E.verboseFlag then @@ -5803,18 +5965,18 @@ let getGlobInit ?(main_name="main") (fl: file) = | _ -> ()) fl.globals; - if not !inserted then - ignore (E.warn "Cannot find %s to add global initializer %s" + 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 = +let mapGlobals (fl: file) + (doone: global -> global) : unit = fl.globals <- Util.list_map doone fl.globals; (match fl.globinit with None -> () @@ -5831,15 +5993,15 @@ let dumpFile (pp: cilPrinter) (out : out_channel) (outfile: string) file = Pretty.fastMode := true; - if !E.verboseFlag then + if !E.verboseFlag then ignore (E.log "printing file %s\n" outfile); - let print x = fprint out 78 x in + let print x = fprint out ~width:78 x in print (text ("/* Generated by CIL v. " ^ cilVersion ^ " */\n" ^ (* sm: I want to easily tell whether the generated output * is with print_CIL_Input or not *) "/* print_CIL_Input is " ^ (if !print_CIL_Input then "true" else "false") ^ " */\n\n")); iterGlobals file (fun g -> dumpGlobal pp out g); - + (* sm: we have to flush the output channel; if we don't then under *) (* some circumstances (I haven't figure out exactly when, but it happens *) (* more often with big inputs), we get a truncated output file *) @@ -5851,11 +6013,11 @@ let dumpFile (pp: cilPrinter) (out : out_channel) (outfile: string) file = ****************** ******************) -(* Convert an expression into an attribute, if possible. Otherwise raise +(* Convert an expression into an attribute, if possible. Otherwise raise * NotAnAttrParam *) exception NotAnAttrParam of exp -let rec expToAttrParam (e: exp) : attrparam = - match e with +let rec expToAttrParam (e: exp) : attrparam = + match e with Const(CInt64(i,k,_)) -> let i' = mkCilint k i in if not (is_int_cilint i') then @@ -5864,9 +6026,9 @@ let rec expToAttrParam (e: exp) : attrparam = | 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', + | BinOp(bo, e1',e2', _) -> ABinOp (bo, expToAttrParam e1', expToAttrParam e2') | _ -> raise (NotAnAttrParam e) @@ -5874,9 +6036,9 @@ let rec expToAttrParam (e: exp) : attrparam = let rec peepHole1 (* Process one instruction 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 + (ss: stmt list) : unit = + let rec doInstrList (il: instr list) : instr list = + match il with [] -> [] | i :: rest -> begin match doone i with @@ -5884,22 +6046,22 @@ let rec peepHole1 (* Process one instruction and possibly replace it *) | Some sl -> doInstrList (sl @ rest) end in - - List.iter - (fun s -> + + List.iter + (fun s -> match s.skind with Instr il -> s.skind <- Instr (doInstrList il) - | If (e, tb, eb, _) -> + | 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 - | TryFinally (b, h, l) -> - peepHole1 doone b.bstmts; + | TryFinally (b, h, l) -> + peepHole1 doone b.bstmts; peepHole1 doone h.bstmts - | TryExcept (b, (il, e), h, l) -> - peepHole1 doone b.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 _ | ComputedGoto _ | Break _ | Continue _ -> ()) @@ -5907,32 +6069,32 @@ let rec peepHole1 (* Process one instruction and possibly replace it *) let rec peepHole2 (* Process two instructions and possibly replace them both *) (dotwo: instr * instr -> instr list option) - (ss: stmt list) : unit = - let rec doInstrList (il: instr list) : instr list = - match il with + (ss: stmt list) : unit = + let rec doInstrList (il: instr list) : instr list = + match il with [] -> [] | [i] -> [i] - | (i1 :: ((i2 :: rest) as rest2)) -> + | (i1 :: ((i2 :: rest) as rest2)) -> begin match dotwo (i1,i2) with None -> i1 :: doInstrList rest2 | Some sl -> doInstrList (sl @ rest) end in - List.iter - (fun s -> + List.iter + (fun s -> match s.skind with Instr il -> s.skind <- Instr (doInstrList il) - | If (e, tb, eb, _) -> + | If (e, tb, eb, _) -> peepHole2 dotwo tb.bstmts; peepHole2 dotwo eb.bstmts | Switch (e, b, _, _) -> peepHole2 dotwo b.bstmts | Loop (b, l, _, _) -> peepHole2 dotwo b.bstmts | Block b -> peepHole2 dotwo b.bstmts - | TryFinally (b, h, l) -> peepHole2 dotwo b.bstmts; + | TryFinally (b, h, l) -> peepHole2 dotwo b.bstmts; peepHole2 dotwo h.bstmts - | TryExcept (b, (il, e), h, l) -> - peepHole2 dotwo b.bstmts; + | TryExcept (b, (il, e), h, l) -> + peepHole2 dotwo b.bstmts; peepHole2 dotwo h.bstmts; s.skind <- TryExcept (b, (doInstrList il, e), h, l) @@ -5945,18 +6107,18 @@ let rec peepHole2 (* Process two instructions and possibly replace them both *) (*** Type signatures ***) (* Helper class for typeSig: replace any types in attributes with typsigs *) -class typeSigVisitor(typeSigConverter: typ->typsig) = object - inherit nopCilVisitor - method vattrparam ap = +class typeSigVisitor(typeSigConverter: typ->typsig) = object + inherit nopCilVisitor + method! vattrparam ap = match ap with | ASizeOf t -> ChangeTo (ASizeOfS (typeSigConverter t)) | AAlignOf t -> ChangeTo (AAlignOfS (typeSigConverter t)) | _ -> DoChildren end -let typeSigAddAttrs a0 t = +let typeSigAddAttrs a0 t = if a0 == [] then t else - match t with + match t with TSBase t -> TSBase (typeAddAttributes a0 t) | TSPtr (ts, a) -> TSPtr (ts, addAttributes a0 a) | TSArray (ts, l, a) -> TSArray(ts, l, addAttributes a0 a) @@ -5967,13 +6129,13 @@ let typeSigAddAttrs a0 t = (* Compute a type signature. Use ~ignoreSign:true to convert all signed integer types to unsigned, so that signed and unsigned will compare the same. *) -let rec typeSigWithAttrs ?(ignoreSign=false) doattr t = +let rec typeSigWithAttrs ?(ignoreSign=false) doattr t = let typeSig = typeSigWithAttrs ~ignoreSign doattr in let attrVisitor = new typeSigVisitor typeSig in let doattr al = visitCilAttributes attrVisitor (doattr al) in - match t with - | TInt (ik, al) -> - let ik' = + match t with + | TInt (ik, al) -> + let ik' = if ignoreSign then unsignedVersionOf ik else ik in TSBase (TInt (ik', doattr al)) @@ -5981,28 +6143,27 @@ let rec typeSigWithAttrs ?(ignoreSign=false) doattr t = | TVoid al -> TSBase (TVoid (doattr al)) | TEnum (enum, a) -> TSEnum (enum.ename, doattr a) | TPtr (t, a) -> TSPtr (typeSig t, doattr a) - | TArray (t,l,a) -> (* We do not want fancy expressions in array lengths. + | TArray (t,l,a) -> (* We do not want fancy expressions in array lengths. * So constant fold the lengths *) - let l' = - match l with - Some l -> begin - match constFold true l with + let l' = + match l with + Some l -> begin + match constFold true l with Const(CInt64(i, _, _)) -> Some i - | e -> E.s (E.bug "Invalid length in array type: %a\n" - (!pd_exp) e) - end + | e -> None (* Returning None for length in a typesig if the length is not a constant (VLA) *) + end | None -> None - in + in TSArray(typeSig t, l', doattr a) - | TComp (comp, a) -> + | TComp (comp, a) -> TSComp (comp.cstruct, comp.cname, doattr (addAttributes comp.cattr a)) - | TFun(rt,args,isva,a) -> + | TFun(rt,args,isva,a) -> TSFun(typeSig rt, (Util.list_map_opt (fun (_, atype, _) -> (typeSig atype)) args), isva, doattr a) | TNamed(t, a) -> typeSigAddAttrs (doattr a) (typeSig t.ttype) - | TBuiltin_va_list al -> TSBase (TBuiltin_va_list (doattr al)) + | TBuiltin_va_list al -> TSBase (TBuiltin_va_list (doattr al)) -let typeSig t = +let typeSig t = typeSigWithAttrs (fun al -> al) t let _ = pTypeSig := typeSig @@ -6027,142 +6188,116 @@ let typeSigAttrs = function -let dExp: doc -> exp = - fun d -> Const(CStr(sprint !lineLength d)) +let dExp: doc -> exp = + fun d -> Const(CStr(sprint ~width:!lineLength d)) -let dInstr: doc -> location -> instr = - fun d l -> Asm([], [sprint !lineLength d], [], [], [], l) +let dInstr: doc -> location -> instr = + fun d l -> Asm([], [sprint ~width:!lineLength d], [], [], [], l) -let dGlobal: doc -> location -> global = - fun d l -> GAsm(sprint !lineLength d, l) +let dGlobal: doc -> location -> global = + fun d l -> GAsm(sprint ~width:!lineLength d, l) - (* Make an AddrOf. Given an lval of type T will give back an expression of + (* Make an AddrOf. Given an lval of type T will give back an expression of * type ptr(T) *) -let mkAddrOf ((b, off) as lval) : exp = +let mkAddrOf ((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 - (* Don't do this: + (* Don't do this: | b, Index(z, NoOffset) when isZero z -> StartOf (b, NoOffset) &a[0] is not the same as a, e.g. within typeof and sizeof. Code must be able to handle the results without this anyway... *) | _ -> AddrOf lval -let mkAddrOrStartOf (lv: lval) : exp = - match unrollType (typeOfLval lv) with +let mkAddrOrStartOf (lv: lval) : exp = + match unrollType (typeOfLval lv) with TArray _ -> StartOf lv | _ -> mkAddrOf lv - (* 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 a function and a pointer to a function does + (* 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 a function and a pointer to a function does * not apply. You must do the conversion yourself using AddrOf *) -let mkMem ~(addr: exp) ~(off: offset) : lval = - let res = +let mkMem ~(addr: exp) ~(off: offset) : lval = + let res = match addr, off with AddrOf lv, _ -> addOffsetLval off lv | StartOf lv, _ -> (* Must be an array *) - addOffsetLval (Index(zero, off)) lv + addOffsetLval (Index(zero, off)) lv | _, _ -> Mem addr, off in -(* ignore (E.log "memof : %a:%a\nresult = %a\n" +(* ignore (E.log "memof : %a:%a\nresult = %a\n" d_plainexp addr d_plainoffset off d_plainexp res); *) res -let splitFunctionType (ftype: typ) - : typ * (string * typ * attributes) list option * bool * attributes = - match unrollType ftype with +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 - | _ -> E.s (bug "splitFunctionType invoked on a non function type %a" + | _ -> E.s (bug "splitFunctionType invoked on a non function type %a" d_type ftype) -let splitFunctionTypeVI (fvi: varinfo) - : typ * (string * typ * attributes) list option * bool * attributes = - match unrollType fvi.vtype with +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 | _ -> E.s (bug "Function %s invoked on a non function type" fvi.vname) -let isArrayType t = - match unrollType t with - TArray _ -> true - | _ -> false - - -let rec isConstant = function - | Const _ -> true - | UnOp (_, e, _) -> isConstant e - | BinOp (_, e1, e2, _) -> isConstant e1 && isConstant e2 - | Question (e1, e2, e3, _) -> isConstant e1 && isConstant e2 && isConstant e3 - | Lval (Var vi, NoOffset) -> - (vi.vglob && isArrayType vi.vtype || isFunctionType vi.vtype) - | Lval _ -> false - | SizeOf _ | SizeOfE _ | SizeOfStr _ | AlignOf _ | AlignOfE _ -> true - | CastE (_, e) -> isConstant e - | AddrOf (Var vi, off) | StartOf (Var vi, off) - -> vi.vglob && isConstantOffset off - | AddrOf (Mem e, off) | StartOf(Mem e, off) - -> isConstant e && isConstantOffset off - | AddrOfLabel _ -> true - -and isConstantOffset = function - NoOffset -> true - | Field(fi, off) -> isConstantOffset off - | Index(e, off) -> isConstant e && isConstantOffset off - let getCompField (cinfo:compinfo) (fieldName:string) : fieldinfo = (List.find (fun fi -> fi.fname = fieldName) cinfo.cfields) -let rec mkCastT ~(e: exp) ~(oldt: typ) ~(newt: typ) = +let mkCastT ~(e: exp) ~(oldt: typ) ~(newt: typ) = (* Do not remove old casts because they are conversions !!! *) if Util.equals (typeSig oldt) (typeSig newt) then begin e end else begin (* Watch out for constants *) - match newt, e with + match newt, e with (* Casts to _Bool are special: they behave like "!= 0" ISO C99 6.3.1.2 *) - TInt(IBool, []), Const(CInt64(i, _, _)) -> - let v = if i = Int64.zero then Int64.zero else Int64.one in - Const (CInt64(v, IBool, None)) - | TInt(newik, []), Const(CInt64(i, _, _)) -> kinteger64 newik i + TInt(IBool, []), Const(CInt64(i, _, _)) -> + let v = if i = Int64.zero then Int64.zero else Int64.one in + Const (CInt64(v, IBool, None)) + | TInt(newik, []), Const(CInt64(_, _, Some s)) -> kintegerCilint newik (Cilint.cilint_of_string s) + | TInt(newik, []), Const(CInt64(i, _, None)) -> kinteger64 newik i | _ -> CastE(newt,e) end -let mkCast ~(e: exp) ~(newt: typ) = - mkCastT e (typeOf e) newt +let mkCast ~(e: exp) ~(newt: typ) = + mkCastT ~e:e ~oldt:(typeOf e) ~newt:newt -type existsAction = +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 + | ExistsMaybe (* This node is not what we are + * looking for but maybe its * successors are *) -let existsType (f: typ -> existsAction) (t: typ) : bool = +let existsType (f: typ -> existsAction) (t: typ) : bool = let memo : (int, unit) H.t = H.create 17 in (* Memo table *) - let rec loop t = - match f t with + let rec loop t = + match f t with ExistsTrue -> true | ExistsFalse -> false - | ExistsMaybe -> - (match t with + | 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) + | TFun (rt, args, _, _) -> + (loop rt || List.exists (fun (_, at, _) -> loop at) (argsToList args)) | _ -> false) - and loopComp c = - if H.mem memo c.ckey then + and loopComp c = + if H.mem memo c.ckey then (* We are looping, the answer must be false *) false else begin @@ -6171,37 +6306,37 @@ let existsType (f: typ -> existsAction) (t: typ) : bool = end in loop t - + (* Try to do an increment, with constant folding *) let increm (e: exp) (i: int) = let et = typeOf e in let bop = if isPointerType et then PlusPI else PlusA in constFold false (BinOp(bop, e, integer i, et)) - + exception LenOfArray -let lenOfArray (eo: exp option) : int = - match eo with +let lenOfArray (eo: exp option) : int = + match eo with None -> raise LenOfArray | Some e -> begin match constFold true e with - | Const(CInt64(ni, _, _)) when ni >= Int64.zero -> + | Const(CInt64(ni, _, _)) when ni >= Int64.zero -> i64_to_int ni | e -> raise LenOfArray end - + (*** Make an initializer for zeroe-ing a data type ***) -let rec makeZeroInit (t: typ) : init = +let rec makeZeroInit (t: typ) : init = match unrollType t with TInt (ik, _) -> SingleInit (Const(CInt64(Int64.zero, ik, None))) | TFloat(fk, _) -> SingleInit(Const(CReal(0.0, fk, None))) | TEnum (e, _) -> SingleInit (kinteger e.ekind 0) - | TComp (comp, _) as t' when comp.cstruct -> - let inits = + | TComp (comp, _) as t' when comp.cstruct -> + let inits = List.fold_right - (fun f acc -> - if f.fname <> missingFieldName then + (fun f acc -> + if f.fname <> missingFieldName then (Field(f, NoOffset), makeZeroInit f.ftype) :: acc else acc) @@ -6209,13 +6344,13 @@ let rec makeZeroInit (t: typ) : init = in CompoundInit (t', inits) - | TComp (comp, _) when not comp.cstruct -> - let fstfield, rest = + | TComp (comp, _) when not comp.cstruct -> + let fstfield, rest = match comp.cfields with f :: rest -> f, rest | [] -> E.s (unimp "Cannot create init for empty union") in - let fieldToInit = + let fieldToInit = if !msvcMode then (* ISO C99 [6.7.8.10] says that the first field of the union is the one we should initialize. *) @@ -6241,64 +6376,64 @@ let rec makeZeroInit (t: typ) : init = widestField end in - CompoundInit(t, [(Field(fieldToInit, NoOffset), + CompoundInit(t, [(Field(fieldToInit, NoOffset), makeZeroInit fieldToInit.ftype)]) - | TArray(bt, Some len, _) as t' -> - let n = + | TArray(bt, Some len, _) as t' -> + let n = match constFold true len with Const(CInt64(n, _, _)) -> i64_to_int n | _ -> E.s (E.unimp "Cannot understand length of array") in let initbt = makeZeroInit bt in - let rec loopElems acc i = + let rec loopElems acc i = if i < 0 then acc - else loopElems ((Index(integer i, NoOffset), initbt) :: acc) (i - 1) + else loopElems ((Index(integer i, NoOffset), initbt) :: acc) (i - 1) in CompoundInit(t', loopElems [] (n - 1)) | TArray (bt, None, at) as t' -> - (* Unsized array, allow it and fill it in later + (* Unsized array, allow it and fill it in later * (see cabs2cil.ml, collectInitializer) *) CompoundInit (t', []) - | TPtr _ as t -> - SingleInit(if !insertImplicitCasts then mkCast zero t else zero) + | TPtr _ as t -> + SingleInit(if !insertImplicitCasts then mkCast ~e:zero ~newt:t else zero) | x -> E.s (unimp "Cannot initialize type: %a" d_type 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 +(** 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) + ~(ct: typ) ~(initl: (offset * init) list) - ~(acc: 'a) : 'a = + ~(acc: 'a) = match unrollType ct with TArray(bt, leno, _) -> begin (* Scan the existing initializer *) - let part = + let part = List.fold_left (fun acc (o, i) -> doinit o i bt acc) acc initl in (* See how many more we have to do *) - match leno with + match leno with Some lene when implicit -> begin - match constFold true lene with - Const(CInt64(i, _, _)) -> + match constFold true lene with + Const(CInt64(i, _, _)) -> let len_array = i64_to_int i in let len_init = List.length initl in - if len_array > len_init then + if len_array > len_init then let zi = makeZeroInit bt in - let rec loop acc i = + let rec loop acc i = if i >= len_array then acc - else - loop (doinit (Index(integer i, NoOffset)) zi bt acc) + else + loop (doinit (Index(integer i, NoOffset)) zi bt acc) (i + 1) in loop part (len_init + 1) @@ -6306,18 +6441,18 @@ let foldLeftCompound part | _ -> E.s (unimp "foldLeftCompound: array with initializer and non-constant length\n") end - + | _ when not implicit -> part | _ -> E.s (unimp "foldLeftCompound: TArray with initializer and no length") end - | TComp (comp, _) -> + | TComp (comp, _) -> let getTypeOffset = function Field(f, NoOffset) -> f.ftype | _ -> E.s (bug "foldLeftCompound: malformed initializer") in - List.fold_left + List.fold_left (fun acc (o, i) -> doinit o i (getTypeOffset o) acc) acc initl | _ -> E.s (E.unimp "Type of Compound is not array or struct or union") @@ -6335,28 +6470,28 @@ let rec isCompleteType t = module A = Alpha - + (** Uniquefy the variable names *) -let uniqueVarNames (f: file) : unit = +let uniqueVarNames (f: file) : unit = (* Setup the alpha conversion table for globals *) - let gAlphaTable: (string, + let gAlphaTable: (string, location A.alphaTableData ref) H.t = H.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 + (* 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) H.t = H.create 113 in (* Scan the file and add the global names to the table *) iterGlobals f (function - GVarDecl(vi, l) - | GVar(vi, _, l) - | GFun({svar = vi}, l) -> + GVarDecl(vi, l) + | GVar(vi, _, l) + | GFun({svar = vi; _}, l) -> (* See if we have used this name already for something else *) (try let oldid = H.find globalNames vi.vname in - if oldid <> vi.vid then - ignore (warn "The name %s is used for two distinct globals" + if oldid <> vi.vid then + ignore (warn "The name %s is used for two distinct globals" vi.vname); (* Here if we have used this name already. Go ahead *) () @@ -6364,24 +6499,24 @@ let uniqueVarNames (f: file) : unit = (* Here if this is the first time we define a name *) H.add globalNames vi.vname vi.vid; (* And register it *) - A.registerAlphaName gAlphaTable None vi.vname !currentLoc; + A.registerAlphaName ~alphaTable:gAlphaTable ~undolist:None ~lookupname:vi.vname ~data:!currentLoc; () end) | _ -> ()); (* Now we must scan the function bodies and rename the locals *) iterGlobals f - (function + (function GFun(fdec, l) -> begin currentLoc := l; - (* Setup an undo list to be able to revert the changes to the + (* Setup an undo list to be able to revert the changes to the * global alpha table *) let undolist = ref [] in (* Process one local variable *) - let processLocal (v: varinfo) = - let newname, oldloc = - A.newAlphaName gAlphaTable (Some undolist) v.vname - !currentLoc + let processLocal (v: varinfo) = + let newname, oldloc = + A.newAlphaName ~alphaTable:gAlphaTable ~undolist:(Some undolist) ~lookupname:v.vname + ~data:!currentLoc in if false && newname <> v.vname then (* Disable this warning *) ignore (warn "uniqueVarNames: Changing the name of local %s in %s to %s (due to duplicate at %a)" @@ -6395,19 +6530,19 @@ let uniqueVarNames (f: file) : unit = (* And now the locals *) List.iter processLocal fdec.slocals; (* Undo the changes to the global table *) - A.undoAlphaChanges gAlphaTable !undolist; + A.undoAlphaChanges ~alphaTable:gAlphaTable ~undolist:!undolist; () end | _ -> ()); () - + (* A visitor that makes a deep copy of a function body *) class copyFunctionVisitor (newname: string) = object (self) inherit nopCilVisitor (* Keep here a maping from locals to their copies *) - val map : (string, varinfo) H.t = H.create 113 + val map : (string, varinfo) H.t = H.create 113 (* Keep here a maping from statements to their copies *) val stmtmap : (int, stmt) H.t = H.create 113 val sid = ref 0 (* Will have to assign ids to statements *) @@ -6417,28 +6552,28 @@ class copyFunctionVisitor (newname: string) = object (self) val argid = ref 0 (* This is the main function *) - method vfunc (f: fundec) : fundec visitAction = + method! vfunc (f: fundec) : fundec visitAction = (* We need a map from the old locals/formals to the new ones *) H.clear map; argid := 0; (* Make a copy of the fundec. *) let f' = {f with svar = f.svar} in - let patchfunction (f' : fundec) = - (* Change the name. Only this late to allow the visitor to copy the + let patchfunction (f' : fundec) = + (* Change the name. Only this late to allow the visitor to copy the * svar *) f'.svar.vname <- newname; - let findStmt (i: int) = - try H.find stmtmap i + let findStmt (i: int) = + try H.find stmtmap i with Not_found -> E.s (bug "Cannot find the copy of stmt#%d" i) in - let patchstmt (s: stmt) = + let patchstmt (s: stmt) = match s.skind with - Goto (sr, l) -> + Goto (sr, l) -> (* Make a copy of the reference *) let sr' = ref (findStmt !sr.sid) in s.skind <- Goto (sr',l) - | Switch (e, body, cases, l) -> - s.skind <- Switch (e, body, + | Switch (e, body, cases, l) -> + s.skind <- Switch (e, body, Util.list_map (fun cs -> findStmt cs.sid) cases, l) | _ -> () in @@ -6449,10 +6584,10 @@ class copyFunctionVisitor (newname: string) = object (self) sid := 0; H.clear stmtmap; ChangeDoChildrenPost (f', patchfunction) - - (* We must create a new varinfo for each declaration. Memoize to + + (* We must create a new varinfo for each declaration. Memoize to * maintain sharing *) - method vvdec (v: varinfo) = + method! vvdec (v: varinfo) = (* Some varinfo have empty names. Give them some name *) if v.vname = "" then begin v.vname <- "arg" ^ string_of_int !argid; incr argid @@ -6466,16 +6601,16 @@ class copyFunctionVisitor (newname: string) = object (self) end (* We must replace references to local variables *) - method vvrbl (v: varinfo) = - if v.vglob then SkipChildren else + method! vvrbl (v: varinfo) = + if v.vglob then SkipChildren else try ChangeTo (H.find map v.vname) - with Not_found -> + with Not_found -> E.s (bug "Cannot find the new copy of local variable %s" v.vname) (* Replace statements. *) - method vstmt (s: stmt) : stmt visitAction = + method! vstmt (s: stmt) : stmt visitAction = s.sid <- !sid; incr sid; let s' = {s with sid = s.sid} in H.add stmtmap s.sid s'; (* Remember where we copied this *) @@ -6487,17 +6622,17 @@ class copyFunctionVisitor (newname: string) = object (self) ChangeDoChildrenPost (s', fun x -> x) (* Copy blocks since they are mutable *) - method vblock (b: block) = + method! vblock (b: block) = ChangeDoChildrenPost ({b with bstmts = b.bstmts}, fun x -> x) - method vglob _ = E.s (bug "copyFunction should not be used on globals") + method! vglob _ = E.s (bug "copyFunction should not be used on globals") end (* We need a function that copies a CIL function. *) -let copyFunction (f: fundec) (newname: string) : fundec = +let copyFunction (f: fundec) (newname: string) : fundec = visitCilFunction (new copyFunctionVisitor(newname)) f - + (********* Compute the CFG ********) let sid_counter = ref 0 @@ -6506,11 +6641,11 @@ let new_sid () = incr sid_counter; id -let statements : stmt list ref = ref [] -(* Clear all info about the CFG in statements *) +let statements : stmt list ref = ref [] +(* Clear all info about the CFG in statements *) class clear : cilVisitor = object inherit nopCilVisitor - method vstmt s = begin + method! vstmt s = begin s.sid <- !sid_counter ; incr sid_counter ; statements := s :: !statements; @@ -6518,30 +6653,30 @@ class clear : cilVisitor = object s.preds <- [] ; DoChildren end - method vexpr _ = SkipChildren - method vtype _ = SkipChildren - method vinst _ = SkipChildren + method! vexpr _ = SkipChildren + method! vtype _ = SkipChildren + method! vinst _ = SkipChildren end let link source dest = begin if not (List.mem dest source.succs) then source.succs <- dest :: source.succs ; if not (List.mem source dest.preds) then - dest.preds <- source :: dest.preds + dest.preds <- source :: dest.preds end let trylink source dest_option = match dest_option with None -> () -| Some(dest) -> link source dest +| Some(dest) -> link source dest -(** Cmopute the successors and predecessors of a block, given a fallthrough *) +(** Compute the successors and predecessors of a block, given a fallthrough *) let rec succpred_block b fallthrough rlabels = let rec handle sl = match sl with [] -> () | [a] -> succpred_stmt a fallthrough rlabels - | hd :: ((next :: _) as tl) -> + | hd :: ((next :: _) as tl) -> succpred_stmt hd (Some next) rlabels; - handle tl + handle tl in handle b.bstmts @@ -6551,12 +6686,12 @@ and succpred_stmt s fallthrough rlabels = | Return _ -> () | Goto(dest,l) -> link s !dest | ComputedGoto(e,l) -> List.iter (link s) rlabels - | Break _ - | Continue _ + | Break _ + | Continue _ | Switch _ -> failwith "computeCFGInfo: cannot be called on functions with break, continue or switch statements. Use prepareCFG first to remove them." - | If(e1,b1,b2,l) -> + | If(e1,b1,b2,l) -> (match b1.bstmts with [] -> trylink s fallthrough | hd :: tl -> (link s hd ; succpred_block b1 fallthrough rlabels )) ; @@ -6564,11 +6699,11 @@ and succpred_stmt s fallthrough rlabels = [] -> trylink s fallthrough | hd :: tl -> (link s hd ; succpred_block b2 fallthrough rlabels )) - | Loop(b,l,_,_) -> + | Loop(b,l,_,_) -> begin match b.bstmts with - [] -> failwith "computeCFGInfo: empty loop" - | hd :: tl -> - link s hd ; + [] -> failwith "computeCFGInfo: empty loop" + | hd :: tl -> + link s hd ; succpred_block b (Some(hd)) rlabels end @@ -6577,7 +6712,7 @@ and succpred_stmt s fallthrough rlabels = | hd :: tl -> link s hd ; succpred_block b fallthrough rlabels end - | TryExcept _ | TryFinally _ -> + | TryExcept _ | TryFinally _ -> failwith "computeCFGInfo: structured exception handling not implemented" let caseRangeFold (l: label list) = @@ -6602,7 +6737,7 @@ let caseRangeFold (l: label list) = (* [weimer] Sun May 5 12:25:24 PDT 2002 * This code was pulled from ext/switch.ml because it looks like we really - * want it to be part of CIL. + * want it to be part of CIL. * * Here is the magic handling to * (1) replace switch statements with if/goto @@ -6619,7 +6754,7 @@ let labelAlphaTable : (string, unit A.alphaTableData ref) H.t = H.create 11 let freshLabel (base:string) = - fst (A.newAlphaName labelAlphaTable None base ()) + fst (A.newAlphaName ~alphaTable:labelAlphaTable ~undolist:None ~lookupname:base ~data:()) let rec xform_switch_stmt s break_dest cont_dest = begin let suffix e = match getInteger e with @@ -6639,10 +6774,10 @@ let rec xform_switch_stmt s break_dest cont_dest = begin let str = Printf.sprintf "caserange_%s_%s" (suffix e1) (suffix e2) in Label(freshLabel str,l,false) | Default(l) -> Label(freshLabel "switch_default",l,false) - ) s.labels ; + ) s.labels ; match s.skind with | Instr _ | Return _ | Goto _ | ComputedGoto _ -> () - | Break(l) -> begin try + | Break(l) -> begin try s.skind <- Goto(break_dest (),l) with e -> ignore (error "prepareCFG: break: %a@!" d_stmt s) ; @@ -6677,7 +6812,7 @@ let rec xform_switch_stmt s break_dest cont_dest = begin * label_break: ; // break_stmt * * 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 + * non-default cases fail [ISO/IEC 9899:1999, �6.8.4.2, �5]. As * a result, we test all cases first, and hit 'default' only if * no case matches. However, we do not reorder the switch's * body, so fall-through still works as expected. @@ -6751,33 +6886,33 @@ let rec xform_switch_stmt s break_dest cont_dest = begin [break_stmt]; s.skind <- Block b; xform_switch_block b (fun () -> ref break_stmt) cont_dest - | Loop(b,l,_,_) -> + | Loop(b,l,_,_) -> let break_stmt = mkStmt (Instr []) in break_stmt.labels <- [Label(freshLabel "while_break",l,false)] ; let cont_stmt = mkStmt (Instr []) in cont_stmt.labels <- [Label(freshLabel "while_continue",l,false)] ; b.bstmts <- cont_stmt :: b.bstmts ; - let this_stmt = mkStmt - (Loop(b,l,Some(cont_stmt),Some(break_stmt))) in + let this_stmt = mkStmt + (Loop(b,l,Some(cont_stmt),Some(break_stmt))) in let break_dest () = ref break_stmt in - let cont_dest () = ref cont_stmt in + let cont_dest () = ref cont_stmt in xform_switch_block b break_dest cont_dest ; - break_stmt.succs <- s.succs ; + break_stmt.succs <- s.succs ; let new_block = mkBlock [ this_stmt ; break_stmt ] in s.skind <- Block new_block | Block(b) -> xform_switch_block b break_dest cont_dest - | TryExcept _ | TryFinally _ -> + | TryExcept _ | TryFinally _ -> failwith "xform_switch_statement: structured exception handling not implemented" end and xform_switch_block b break_dest cont_dest = - try + try let rec link_succs sl = match sl with | [] -> () | hd :: tl -> (if hd.succs = [] then hd.succs <- tl) ; link_succs tl - in + in link_succs b.bstmts ; - List.iter (fun stmt -> + List.iter (fun stmt -> xform_switch_stmt stmt break_dest cont_dest) b.bstmts ; with e -> List.iter (fun stmt -> ignore @@ -6789,17 +6924,17 @@ end and xform_switch_block b break_dest cont_dest = statements. *) class registerLabelsVisitor : cilVisitor = object inherit nopCilVisitor - method vstmt { labels = labels } = begin + method! vstmt { labels = labels; _ } = begin List.iter (function - Label (name,_,_) -> A.registerAlphaName labelAlphaTable None name () + Label (name,_,_) -> A.registerAlphaName ~alphaTable:labelAlphaTable ~undolist:None ~lookupname:name ~data:() | _ -> ()) labels; DoChildren end - method vexpr _ = SkipChildren - method vtype _ = SkipChildren - method vinst _ = SkipChildren + method! vexpr _ = SkipChildren + method! vtype _ = SkipChildren + method! vinst _ = SkipChildren end (* Find all labels-as-value in a function to use them as successors of computed @@ -6807,7 +6942,7 @@ end class addrOfLabelFinder slr = object(self) inherit nopCilVisitor - method vexpr e = match e with + method! vexpr e = match e with | AddrOfLabel sref -> slr := !sref :: (!slr); SkipChildren @@ -6829,16 +6964,16 @@ let prepareCFG (fd : fundec) : unit = clearing labelAlphaTable. Then register all labels. *) H.clear labelAlphaTable; ignore (visitCilFunction (new registerLabelsVisitor) fd); - xform_switch_block fd.sbody - (fun () -> failwith "prepareCFG: break with no enclosing loop") + xform_switch_block fd.sbody + (fun () -> failwith "prepareCFG: break with no enclosing loop") (fun () -> failwith "prepareCFG: continue with no enclosing loop") (* make the cfg and return a list of statements *) let computeCFGInfo (f : fundec) (global_numbering : bool) : unit = - if not global_numbering then - sid_counter := 0 ; + if not global_numbering then + sid_counter := 0 ; statements := []; - let clear_it = new clear in + let clear_it = new clear in ignore (visitCilBlock clear_it f.sbody) ; f.smaxstmtid <- Some (!sid_counter) ; let rlabels = findAddrOfLabelStmts f.sbody in @@ -6848,8 +6983,8 @@ let computeCFGInfo (f : fundec) (global_numbering : bool) : unit = f.sallstmts <- res; () -let initCIL () = - if not !initCIL_called then begin +let initCIL () = + if not !initCIL_called then begin (* Set the machine *) begin match !envMachine with @@ -6865,11 +7000,11 @@ let initCIL () = let findIkindSz (unsigned: bool) (sz: int) : ikind = try intKindForSize sz unsigned - with Not_found -> + with Not_found -> E.s(E.unimp "initCIL: cannot find the right ikind for size %d\n" sz) - in + in (* Find the right ikind given the name *) - let findIkindName (name: string) : ikind = + let findIkindName (name: string) : ikind = (* Test the most common sizes first *) if name = "int" then IInt else if name = "unsigned int" then IUInt @@ -6882,7 +7017,7 @@ let initCIL () = else if name = "char" then IChar else if name = "unsigned char" then IUChar else E.s(E.unimp "initCIL: cannot find the right ikind for type %s\n" name) - in + in upointType := TInt(findIkindSz true !M.theMachine.M.sizeof_ptr, []); ptrdiffType := TInt(findIkindSz false !M.theMachine.M.sizeof_ptr, []); kindOfSizeOf := findIkindName !M.theMachine.M.size_t; @@ -6902,80 +7037,80 @@ let initCIL () = initGccBuiltins (); () end - -(* We want to bring all type declarations before the data declarations. This - * is needed for code of the following form: + +(* 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. + 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 + There is one catch with this scheme. If the type contains an array whose + length refers to variables then those variables must be declared before the type *) let pullTypesForward = true - - (* Scan a type and collect the variables that are refered *) + + (* Scan a type and collect the variables that are referred *) class getVarsInGlobalClass (pacc: varinfo list ref) = object inherit nopCilVisitor - method vvrbl (vi: varinfo) = + method! vvrbl (vi: varinfo) = pacc := vi :: !pacc; SkipChildren - method vglob = function + method! vglob = function GType _ | GCompTag _ -> DoChildren | _ -> SkipChildren - + end -let getVarsInGlobal (g : global) : varinfo list = +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 hasPrefix p s = +let hasPrefix p s = let pl = String.length p in (String.length s >= pl) && String.sub s 0 pl = p -let pushGlobal (g: global) +let pushGlobal (g: global) ~(types:global list ref) - ~(variables: global list ref) = - if not pullTypesForward then + ~(variables: global list ref) = + if not pullTypesForward then variables := g :: !variables else begin - (* Collect a list of variables that are refered from the type. Return - * Some if the global should go with the types and None if it should go + (* 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 + let varsintype : (varinfo list * location) option = + match g with GType (_, l) | GCompTag (_, l) -> Some (getVarsInGlobal g, l) - | GEnumTag (_, l) | GPragma (Attr("pack", _), l) + | GEnumTag (_, l) | GPragma (Attr("pack", _), l) | GCompTagDecl (_, l) | GEnumTagDecl (_, l) -> Some ([], l) - (** Move the warning pragmas early + (* 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 + match varsintype with None -> variables := g :: !variables - | Some (vl, loc) -> - types := + | Some (vl, loc) -> + types := (* insert declarations for referred variables ('vl'), before * the type definition 'g' itself *) - g :: (List.fold_left (fun acc v -> GVarDecl(v, loc) :: acc) - !types vl) + g :: (List.fold_left (fun acc v -> GVarDecl(v, loc) :: acc) + !types vl) end -type formatArg = +type formatArg = Fe of exp | Feo of exp option (** For array lengths *) | Fu of unop @@ -7027,8 +7162,8 @@ let d_formatarg () = function | Ft t -> dprintf "Ft(%a)" d_type t | Fd n -> dprintf "Fd(%d)" n | Fg s -> dprintf "Fg(%s)" s - | Fp _ -> dprintf "Fp(...)" - | FP n -> dprintf "FP(...)" + | Fp _ -> dprintf "Fp(...)" + | FP n -> dprintf "FP(...)" | Fs _ -> dprintf "FS" | FS _ -> dprintf "FS" @@ -7045,28 +7180,28 @@ let d_formatarg () = function that integer. Otherwise, return None. *) let rec isInteger : exp -> int64 option = function | Const(CInt64 (n,_,_)) -> Some n - | Const(CChr c) -> isInteger (Const (charConstToInt c)) (* sign-extend *) + | Const(CChr c) -> isInteger (Const (charConstToInt c)) (* sign-extend *) | Const(CEnum(v, s, ei)) -> isInteger v | CastE(_, e) -> isInteger e | _ -> None - + (** Deprecated. For compatibility with older programs, these are aliases for {!Cil.builtinFunctions} *) let gccBuiltins = builtinFunctions let msvcBuiltins = builtinFunctions -(* Deprecated. Represents an integer as for a given kind. +(* Deprecated. 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: int64) : int64 * bool = +let truncateInteger64 (k: ikind) (i: int64) : int64 * bool = let nrBits = 8 * (bytesSizeOfInt k) in let signed = isSigned k in - if nrBits = 64 then + if nrBits = 64 then i, false else begin let i1 = Int64.shift_left i (64 - nrBits) in - let i2 = - if signed then Int64.shift_right i1 (64 - nrBits) + let i2 = + if signed then Int64.shift_right i1 (64 - nrBits) else Int64.shift_right_logical i1 (64 - nrBits) in let truncated = @@ -7080,7 +7215,7 @@ let truncateInteger64 (k: ikind) (i: int64) : int64 * bool = let chopped = Int64.shift_right i nrBits in chopped <> Int64.zero (* matth: also suppress the warning if we only chop off 1s. - This is probably due to a negative number being cast to an + This is probably due to a negative number being cast to an unsigned value. While potentially a bug, this is almost always what the programmer intended. *) && chopped <> Int64.minus_one @@ -7096,7 +7231,7 @@ let convertInts (i1:int64) (ik1:ikind) (i2:int64) (ik2:ikind) i1, i2, ik1 else begin let rank : ikind -> int = function - (* these are just unique numbers representing the integer + (* these are just unique numbers representing the integer conversion rank. *) | IBool -> 0 | IChar | ISChar | IUChar -> 1 @@ -7107,13 +7242,13 @@ let convertInts (i1:int64) (ik1:ikind) (i2:int64) (ik2:ikind) in let r1 = rank ik1 in let r2 = rank ik2 in - let ik' = + 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 = + 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. @@ -7122,12 +7257,11 @@ let convertInts (i1:int64) (ik1:ikind) (i2:int64) (ik2:ikind) if unsignedRank >= signedRank then unsignedKind else if (bytesSizeOfInt signedKind) > (bytesSizeOfInt unsignedKind) then signedKind - else + else unsignedVersionOf signedKind end in let i1',_ = truncateInteger64 ik' i1 in let i2',_ = truncateInteger64 ik' i2 in - i1', i2', ik' + i1', i2', ik' end - diff --git a/src/cil.mli b/src/cil.mli index 8b8a699a9..3706634da 100644 --- a/src/cil.mli +++ b/src/cil.mli @@ -1,11 +1,11 @@ (* * - * Copyright (c) 2001-2002, + * 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: @@ -46,218 +46,218 @@ open Cilint (** {b CIL API Documentation.} *) -(** Call this function to perform some initialization. Call if after you have +(** Call this function to perform some initialization. Call if after you have * set {!Cil.msvcMode}. *) val initCIL: unit -> unit -(** These are the CIL version numbers. A CIL version is a number of the form +(** These are the CIL version numbers. A CIL version is a number of the form * M.m.r (major, minor and release) *) val cilVersion: string val cilVersionMajor: int val cilVersionMinor: int val cilVersionRevision: int -(** This module defines the abstract syntax of CIL. It also provides utility - * functions for traversing the CIL data structures, and pretty-printing - * them. The parser for both the GCC and MSVC front-ends can be invoked as - * [Frontc.parse: string -> unit ->] {!Cil.file}. This function must be given - * the name of a preprocessed C file and will return the top-level data - * structure that describes a whole source file. By default the parsing and - * elaboration into CIL is done as for GCC source. If you want to use MSVC - * source you must set the {!Cil.msvcMode} to [true] and must also invoke the +(** This module defines the abstract syntax of CIL. It also provides utility + * functions for traversing the CIL data structures, and pretty-printing + * them. The parser for both the GCC and MSVC front-ends can be invoked as + * [Frontc.parse: string -> unit ->] {!Cil.file}. This function must be given + * the name of a preprocessed C file and will return the top-level data + * structure that describes a whole source file. By default the parsing and + * elaboration into CIL is done as for GCC source. If you want to use MSVC + * source you must set the {!Cil.msvcMode} to [true] and must also invoke the * function [Frontc.setMSVCMode: unit -> unit]. *) (** {b The Abstract Syntax of CIL} *) -(** 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.file} using the following iterators: {!Cil.mapGlobals}, - * {!Cil.iterGlobals} and {!Cil.foldGlobals}. You can also use the - * {!Cil.dummyFile} when you need a {!Cil.file} as a placeholder. For each - * global item CIL stores the source location where it appears (using the +(** 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.file} using the following iterators: {!Cil.mapGlobals}, + * {!Cil.iterGlobals} and {!Cil.foldGlobals}. You can also use the + * {!Cil.dummyFile} when you need a {!Cil.file} as a placeholder. For each + * global item CIL stores the source location where it appears (using the * type {!Cil.location}) *) -type file = +type file = { mutable fileName: string; (** The complete file name *) - mutable globals: global list; (** List of globals as they will appear + 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} + 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. This will not happen if your file does not contain a + 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. This will not happen if your file does not contain a * function called "main" *) - } + } (** Top-level representation of a C source file *) and comment = location * string -(** {b Globals}. The main type for representing global declarations and - * definitions. A list of these form a CIL file. The order of globals in the +(** {b Globals}. 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. *) (** A global declaration or definition *) 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 + | 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 + | 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 + (** 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 + (** 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 + (** 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). If the variable has a - function type then this is a prototype. There can be several - declarations and at most one definition for a given variable. If both - forms appear then they must share the same varinfo structure. A - prototype shares the varinfo with the fundec of the definition. Either + (** A variable declaration (not a definition). If the variable has a + function type then this is a prototype. There can be several + declarations and at most one definition for a given variable. If both + forms appear then they must share the same varinfo structure. A + prototype shares the varinfo with the fundec of the definition. Either has storage Extern or there must be a definition in this file *) | GVar of varinfo * initinfo * location - (** A variable definition. Can have an initializer. The initializer is - * updateable so that you can change it without requiring to recreate - * the list of globals. There can be at most one definition for a - * variable in an entire program. Cannot have storage Extern or function + (** 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. Note: the initializer field is kept for backwards compatibility, * but it is now also available directly in the varinfo. *) - | GFun of fundec * location + | GFun of fundec * location (** A function definition. *) - | GAsm of string * location (** Global asm statement. These ones + | 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 + | 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 + | GText of string (** Some text (printed verbatim) at + top level. E.g., this way you can put comments in the output. *) -(** {b Types}. A C type is represented in CIL using the type {!Cil.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 +(** {b Types}. A C type is represented in CIL using the type {!Cil.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 +(** 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}, + | 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 + | 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}, + | 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 * 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 + (** 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. 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} or - * {!Cil.unrollTypeDeep}. The attributes are in addition to those + | TNamed of typeinfo * attributes + (** The use of a named type. 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} or + * {!Cil.unrollTypeDeep}. The attributes are in addition to those * given when the type name was defined. *) | TComp of compinfo * attributes -(** The most delicate issue for C types is that recursion that is possible by - * using structures and pointers. To address this issue we have a more - * complex representation for structured types (struct and union). Each such - * type is represented using the {!Cil.compinfo} type. For each composite - * type the {!Cil.compinfo} structure must be declared at top level using - * [GCompTag] and all references to it must share the same copy of the - * structure. The attributes given are those pertaining to this use of the - * type and are in addition to the attributes that were given at the +(** The most delicate issue for C types is that recursion that is possible by + * using structures and pointers. To address this issue we have a more + * complex representation for structured types (struct and union). Each such + * type is represented using the {!Cil.compinfo} type. For each composite + * type the {!Cil.compinfo} structure must be declared at top level using + * [GCompTag] and all references to it must share the same copy of the + * structure. 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 {!Cil.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 + 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 *) (** There are a number of functions for querying the kind of a type. These are - {!Cil.isIntegralType}, - {!Cil.isArithmeticType}, - {!Cil.isPointerType}, - {!Cil.isScalarType}, - {!Cil.isFunctionType}, - {!Cil.isArrayType}. + {!Cil.isIntegralType}, + {!Cil.isArithmeticType}, + {!Cil.isPointerType}, + {!Cil.isScalarType}, + {!Cil.isFunctionType}, + {!Cil.isArrayType}. There are two easy ways to scan a type. First, you can use the {!Cil.existsType} to return a boolean answer about a type. This function is controlled by a user-provided function that is queried for each type that is used to construct the current type. The function can specify whether to terminate the scan with a boolean result or to continue the scan for the -nested types. +nested types. The other method for scanning types is provided by the visitor interface (see {!Cil.cilVisitor}). @@ -267,13 +267,13 @@ use instead type signatures (represented as {!Cil.typsig}). These contain the same information as types but canonicalized such that simple Ocaml structural equality will tell whether two types are equal. Use {!Cil.typeSig} to compute the signature of a type. If you want to ignore -certain type attributes then use {!Cil.typeSigWithAttrs}. +certain type attributes then use {!Cil.typeSigWithAttrs}. *) (** Various kinds of integers *) -and ikind = +and ikind = IChar (** [char] *) | ISChar (** [signed char] *) | IUChar (** [unsigned char] *) @@ -285,37 +285,39 @@ and ikind = | ILong (** [long] *) | IULong (** [unsigned long] *) | ILongLong (** [long long] (or [_int64] on Microsoft Visual C) *) - | IULongLong (** [unsigned long long] (or [unsigned _int64] on Microsoft + | 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] *) - +and fkind = + FFloat (** [float] *) + | FDouble (** [double] *) + | FLongDouble (** [long double] *) + | FComplexFloat (** [float _Complex] *) + | FComplexDouble (** [double _Complex] *) + | FComplexLongDouble (** [long double _Complex]*) (** {b 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 +(** 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.) *) -(** Attributes are lists sorted by the attribute name. Use the functions - * {!Cil.addAttribute} and {!Cil.addAttributes} to insert attributes in an +(** 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 = +and attrparam = | AInt of int (** 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 + | 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 @@ -333,74 +335,74 @@ and attrparam = | AIndex of attrparam * attrparam (** a1[a2] *) | AQuestion of attrparam * attrparam * attrparam (** a1 ? a2 : a3 **) -(** {b Structures.} The {!Cil.compinfo} describes the definition of a - * structure or union type. Each such {!Cil.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. +(** {b Structures.} The {!Cil.compinfo} describes the definition of a + * structure or union type. Each such {!Cil.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]. + 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.compinfo} can be tricky since it must contain fields - * that might refer to the host {!Cil.compinfo} and furthermore the type of - * the field might need to refer to the {!Cil.compinfo} for recursive types. - * Use the {!Cil.mkCompInfo} function to create a {!Cil.compinfo}. You can - * easily fetch the {!Cil.fieldinfo} for a given field in a structure with + * Constructing a {!Cil.compinfo} can be tricky since it must contain fields + * that might refer to the host {!Cil.compinfo} and furthermore the type of + * the field might need to refer to the {!Cil.compinfo} for recursive types. + * Use the {!Cil.mkCompInfo} function to create a {!Cil.compinfo}. You can + * easily fetch the {!Cil.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 +(** 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.). *) and compinfo = { - mutable cstruct: bool; + mutable cstruct: bool; (** True if struct, False if union *) - mutable cname: string; - (** The name. Always non-empty. Use {!Cil.compFullName} to get the full + 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 + 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 + 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; + mutable creferenced: bool; (** True if used. Initially set to false. *) } -(** {b Structure fields.} The {!Cil.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 +(** {b Structure fields.} The {!Cil.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 *) -and fieldinfo = { - mutable fcomp: compinfo; - (** The host structure that contains this field. There can be only one +and fieldinfo = { + mutable fcomp: compinfo; + (** The host structure that contains this field. There can be only one * [compinfo] that contains the field. *) - 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 + 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; + mutable ftype: typ; (** The type *) - 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 + 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; + mutable fattr: attributes; (** The attributes for this field (not for its type) *) mutable floc: location; (** The location where this field is defined *) @@ -408,22 +410,22 @@ and fieldinfo = { -(** {b Enumerations.} Information about an enumeration. This is shared by all - * references to an enumeration. Make sure you have a [GEnumTag] for each of +(** {b Enumerations.} Information about an enumeration. This is shared by all + * references to an enumeration. Make sure you have a [GEnumTag] for each of * of these. *) (** Information about an enumeration *) and enuminfo = { - mutable ename: string; + mutable ename: string; (** The name. Always non-empty. *) mutable eitems: (string * exp * location) list; - (** Items with names and values. This list should be non-empty. The item + (** Items with names and values. This list should be non-empty. The item * values must be compile-time constants. *) - mutable eattr: attributes; - (** The attributes that are defined at the same time as the enumeration - * type. These attributes can be supplemented individually at each + 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; + mutable ereferenced: bool; (** True if used. Initially set to false*) mutable ekind: ikind; (** The integer kind used to represent this enum. Per ANSI-C, this @@ -432,65 +434,65 @@ and enuminfo = { (** Information about a defined type *) and typeinfo = { - mutable tname: string; - (** The name. Can be empty only in a [GType] when introducing a composite + 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 actual type. This includes the attributes that were present in * the typedef *) - mutable treferenced: bool; + mutable treferenced: bool; (** True if used. Initially set to false*) } -(** {b Variables.} +(** {b Variables.} Each local or global variable is represented by a unique {!Cil.varinfo} structure. A global {!Cil.varinfo} can be introduced with the [GVarDecl] or [GVar] or [GFun] globals. A local varinfo can be introduced as part of a -function definition {!Cil.fundec}. +function definition {!Cil.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 +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. +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 +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. + A [varinfo] is also used in a function type to denote the list of formals. *) (** Information about a variable. *) -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. +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. *) - mutable vtype: typ; + mutable vtype: typ; (** The declared type of the variable. *) - mutable vattr: attributes; + mutable vattr: attributes; (** A list of attributes associated with the variable.*) - mutable vstorage: storage; + mutable vstorage: storage; (** The storage-class *) - mutable vglob: bool; + mutable vglob: bool; (** True if this is a global variable*) mutable vinline: bool; (** Whether this varinfo is for an inline function. *) - mutable vdecl: location; + mutable vdecl: location; (** Location of variable declaration. *) vinit: initinfo; @@ -499,19 +501,19 @@ and varinfo = { * assignments. Not mutable because the init field in initinfo is mutable * already. *) - 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 + 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 + 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 + mutable vreferenced: bool; + (** True if this variable is ever referenced. This is computed by * {!Rmtmps.removeUnusedTemps}. It is safe to just initialize this to False *) mutable vdescr: Pretty.doc; @@ -523,37 +525,46 @@ and varinfo = { (** Indicates whether the vdescr above is a pure expression or call. * Printing a non-pure vdescr more than once may yield incorrect * results. *) + + mutable vhasdeclinstruction: bool; + (** Indicates whether a VarDecl instruction was generated for this variable. + * Only applies to local variables. + * Currently, this is relevant for when to print the declaration. If this is + * true, it might be incorrect to print the declaration at the beginning of the + * function, rather than where the VarDecl instruction is. This was introduced to + * handle VLAs. + *) } (** Storage-class information *) -and storage = +and storage = NoStorage (** The default storage. Nothing is printed *) | Static | Register - | Extern + | Extern (** {b Expressions.} The CIL expression language contains only the side-effect free expressions of C. They are represented as the type {!Cil.exp}. There are several -interesting aspects of CIL expressions: +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. +source. CIL uses 64 bits 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). +{!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. +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 @@ -561,100 +572,101 @@ expression of array type and one of pointer type is made explicit, using 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 find the type of an expression with {!Cil.typeOf}. You can perform constant folding on expressions using the function -{!Cil.constFold}. +{!Cil.constFold}. *) (** Expressions (Side-effect free)*) and exp = 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 + | 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 + | Real of exp (** __real__() *) + | Imag of exp (** __imag__() *) + | 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 + (** 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 + | AlignOf of typ (** This corresponds to the GCC __alignof_. Has [unsigned int] type *) - | AlignOfE of exp + | AlignOfE of exp - - | UnOp of unop * exp * typ + + | 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 + (** Binary operation. Includes the type of the result. The arithmetic * conversions are made explicit for the arguments. *) | Question of exp * exp * exp * typ (** (a ? b : c) operation. Includes the type of the result *) - | CastE of typ * exp + | 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)]. Use - * {!Cil.mkAddrOrStartOf} to make one of these if you are not sure which + | 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)]. Use + * {!Cil.mkAddrOrStartOf} to make one of these if you are not sure which * one to use. *) | AddrOfLabel of stmt ref (** The address of a label, using GCC's label-as-value extension. If you * want to use these, you must set {!Cil.useComputedGoto}. *) - | 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)]. Use {!Cil.mkAddrOrStartOf} to make one of these if you are - * not sure which one to use. In C this operation is implicit, the - * [StartOf] operator is not printed. We have it in CIL because it makes + | 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)]. Use {!Cil.mkAddrOrStartOf} to make one of these if you are + * not sure which one to use. In C this operation is implicit, the + * [StartOf] operator is not printed. We have it in CIL because it makes * the typing rules simpler. *) (** {b Constants.} *) (** Literal constants *) and constant = - | CInt64 of int64 * ikind * string option - (** Integer constant. Give the ikind (see ISO9899 6.1.3.2) and the - * textual representation, if available. (This allows us to print a - * constant as, for example, 0xF instead of 15.) Use {!Cil.integer} or - * {!Cil.kinteger} to create these. Watch out for integers that cannot be + | CInt64 of int64 * ikind * string option + (** Integer constant. Give the ikind (see ISO9899 6.1.3.2) and the + * textual representation, if available. (This allows us to print a + * constant as, for example, 0xF instead of 15.) Use {!Cil.integer} or + * {!Cil.kinteger} to create these. Watch out for integers that cannot be * represented on 64 bits. OCAML does not give Overflow exceptions. *) - | 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 + | 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 + | CWStr of int64 list (** Wide character string constant. Note that the local interpretation * of such a literal depends on {!Cil.wcharType} and {!Cil.wcharKind}. * Such a constant has type pointer to {!Cil.wcharType}. The - * escape characters in the string have not been "interpreted" in + * 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 + | 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 + | 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 exp * string * enuminfo - (** An enumeration constant with the given value, name, from the given - * enuminfo. This is used only if {!Cil.lowerConstants} is true - * (default). Use {!Cil.constFoldVisitor} to replace these with integer + (** An enumeration constant with the given value, name, from the given + * enuminfo. This is used only if {!Cil.lowerConstants} is true + * (default). Use {!Cil.constFoldVisitor} to replace these with integer * constants. *) (** Unary operators *) @@ -667,12 +679,12 @@ and unop = 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 + | 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 *) @@ -684,46 +696,46 @@ and binop = | Shiftrt (** shift right *) | Lt (** < (arithmetic comparison) *) - | Gt (** > (arithmetic comparison) *) + | Gt (** > (arithmetic comparison) *) | Le (** <= (arithmetic comparison) *) | Ge (** > (arithmetic comparison) *) | Eq (** == (arithmetic comparison) *) - | Ne (** != (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 + | 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 + | 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}. *) -(** {b Lvalues.} 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 +(** {b Lvalues.} 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 +{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 +\[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. +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 +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 +To make it easy to tell what an lvalue means CIL represents lvalues as a host object and an offset (see {!Cil.lval}). The host object (represented as {!Cil.lhost}) can be a local or global variable or can be the object @@ -731,87 +743,87 @@ pointed-to by a pointer expression. The offset (represented as {!Cil.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. +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]. +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. +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 +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} *) -(** An lvalue *) and lval = lhost * offset (** The host part of an {!Cil.lval}. *) -and lhost = - | Var of varinfo +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 + | Mem of exp + (** The host is an object of type [T] when the expression has pointer * [TPtr(T)]. *) -(** The offset part of an {!Cil.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 focusing to some +(** The offset part of an {!Cil.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 focusing to some * smaller lvalue that is contained in the original one. *) -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 +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 + | 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 + (** 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 *) -(** {b 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.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 = +(** {b 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.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 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. - * For arrays, however, we allow you to give only a prefix of the - * initializers. You can scan an initializer list with + (** 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 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. + * For arrays, however, we allow you to give only a prefix of the + * initializers. You can scan an initializer list with * {!Cil.foldLeftCompound}. *) @@ -819,76 +831,75 @@ and init = * as a mutable field *) and initinfo = { mutable init : init option; - } + } -(** {b Function definitions.} +(** {b 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.fundec}. Some of the information (e.g. its name, type, storage, attributes) is stored as a {!Cil.varinfo} that is a field of the [fundec]. To refer to the function from the expression language you must use -the [varinfo]. +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} and {!Cil.makeFormalVar}. +{!Cil.makeFormalVar} and {!Cil.setFormals} and {!Cil.makeFormalVar}. *) -(** Function definitions. *) and fundec = - { mutable svar: varinfo; - (** Holds the name and type as a variable, so we can refer to it - * easily from the program. All references to this function either - * in a function call or in a prototype must point to the same + { 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} or {!Cil.makeFormalVar} - * to set these formals and ensure that they - * are reflected in the function type. Do not make copies of these + 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} or {!Cil.makeFormalVar} + * 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 + 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 + 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 + 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 * {!Cil.computeCFGInfo}. *) - mutable sallstmts: stmt list; (** After you call {!Cil.computeCFGInfo} - * this field is set to contain all + mutable sallstmts: stmt list; (** After you call {!Cil.computeCFGInfo} + * this field is set to contain all * statements in the function *) } -(** A block is a sequence of statements with the control falling through from +(** A block is a sequence of statements with the control falling through from one element to the next *) -and block = +and block = { mutable battrs: attributes; (** Attributes for the block *) mutable bstmts: stmt list; (** The statements comprising the block*) - } + } -(** {b Statements}. -CIL statements are the structural elements that make the CFG. They are +(** {b Statements}. +CIL statements are the structural elements that make the CFG. They are represented using the type {!Cil.stmt}. Every statement has a (possibly empty) list of labels. The -{!Cil.stmtkind} field of a statement indicates what kind of statement it +{!Cil.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. + 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] @@ -896,37 +907,35 @@ 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 {!Cil.prepareCFG} and {!Cil.computeCFGInfo} to do it. - -*) -(** Statements. *) + *) and stmt = { - mutable labels: label list; - (** Whether the statement starts with some labels, case statements or + mutable labels: label list; + (** Whether the statement starts with some labels, case statements or * default statements. *) - mutable skind: stmtkind; + mutable skind: stmtkind; (** The kind of statement *) - mutable sid: int; - (** A number (>= 0) that is unique in a function. Filled in only after + 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 + 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; + mutable preds: stmt list; (** The inverse of the succs function. *) - } + } (** 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 +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 + | Case of exp * location (** A case statement. This expression + * is lowered into a constant if + * {!Cil.lowerConstants} is set to * true. *) | CaseRange of exp * exp * location (** A case statement corresponding to a * range of values (GCC's extension). @@ -940,111 +949,117 @@ and label = (** The various kinds of control-flow statements statements *) -and stmtkind = - | Instr of instr list - (** A group of instructions that do not contain control flow. Control +and stmtkind = + | Instr of instr list + (** A group of instructions that do not contain control flow. Control * implicitly falls through. *) - | Return of exp option * location + | Return of exp option * location (** The return statement. This is a leaf in the CFG. *) - | Goto of stmt ref * location - (** A goto statement. Appears from actual goto's in the code or from - * goto's that have been inserted during elaboration. The reference - * points to the statement that is the target of the Goto. This means that - * you have to update the reference whenever you replace the target + | 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. *) - | ComputedGoto of exp * location + | ComputedGoto of exp * location (** A computed goto using GCC's label-as-value extension. If you want to use * these, you must set {!Cil.useComputedGoto}. *) - | Break of location + | Break of location (** A break to the end of the nearest enclosing Loop or Switch *) - | Continue of location + | Continue of location (** A continue to the start of the nearest enclosing [Loop] *) - | If of exp * block * block * location - (** A conditional. Two successors, the "then" and the "else" branches. + | If of exp * block * block * location + (** A conditional. Two successors, the "then" and the "else" branches. * Both branches fall-through to the successor of the If statement. *) - | Switch of exp * block * (stmt list) * location - (** A switch statement. The statements that implement the cases can be - * reached through the provided list. For each such target you can find - * among its labels what cases it implements. The statements that + | Switch of exp * block * (stmt list) * location + (** A switch statement. The statements that implement the cases can be + * reached through the provided list. For each such target you can find + * among its labels what cases it implements. The statements that * implement the cases are somewhere within the provided [block]. *) | Loop of block * location * (stmt option) * (stmt option) - (** A [while(1)] loop. The termination test is implemented in the body of + (** A [while(1)] loop. The termination test is implemented in the body of * a loop using a [Break] statement. If prepareCFG has been called, * the first stmt option will point to the stmt containing the continue * label for this loop and the second will point to the stmt containing * the break label for this loop. *) - | Block of block - (** Just a block of statements. Use it as a way to keep some block + | Block of block + (** Just a block of statements. Use it as a way to keep some block * attributes local *) - (** 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. *) | 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. *) - (** On MSVC we support structured exception handling. The try/except - * statement is a bit tricky: - [__try { blk } + | TryExcept of block * (instr list * exp) * block * location + (** On MSVC we support structured exception handling. The try/except + * statement is a bit tricky: + [__try { blk } __except (e) { handler }] - 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 + 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 !!! - *) - | TryExcept of block * (instr list * exp) * block * location - + *) -(** {b Instructions}. +(** {b Instructions}. An instruction {!Cil.instr} is a statement that has no local (intraprocedural) control flow. It can be either an assignment, function call, or an inline assembly instruction. *) (** Instructions. *) and instr = - Set of lval * exp * location - (** An assignment. The type of the expression is guaranteed to be the same + Set of lval * exp * location + (** An assignment. The type of the expression is guaranteed to be the same * with that of the lvalue *) + | VarDecl of varinfo * location + (** "Instruction" in the location where a varinfo was declared. + * All varinfos for which such a VarDecl instruction exists have + * vhasdeclinstruction set to true. + * The motivation for the addition of this instruction was to support VLAs + * for which declerations can not be pulled up like CIL used to do. + *) | Call of lval option * exp * exp list * location - (** A function call with the (optional) result placed in an lval. It is - * possible that the returned type of the function is not identical to - * that of the lvalue. In that case a cast is printed. The type of the - * actual arguments are identical to those of the declared formals. The - * number of arguments is the same as that of the declared formals, except - * for vararg functions. This construct is also used to encode a call to - * "__builtin_va_arg". In this case the second argument (which should be a + (** A function call with the (optional) result placed in an lval. It is + * possible that the returned type of the function is not identical to + * that of the lvalue. In that case a cast is printed. The type of the + * actual arguments are identical to those of the declared formals. The + * number of arguments is the same as that of the declared formals, except + * for vararg functions. This construct is also used to encode a call to + * "__builtin_va_arg". In this case the second argument (which should be a * type T) is encoded SizeOf(T) *) - | Asm of attributes * (* Really only const and volatile can appear + | Asm of attributes * (* Really only const and volatile can appear * here *) string list * (* templates (CR-separated) *) - (string option * string * lval) list * - (* outputs must be lvals with - * optional names and constraints. - * I would like these - * to be actually variables, but I - * run into some trouble with ASMs + (string option * string * lval) list * + (* outputs must be lvals with + * optional names and constraints. + * I would like these + * to be actually variables, but I + * run into some trouble with ASMs * in the Linux sources *) - (string option * string * exp) list * + (string option * string * exp) list * (* inputs with optional names and constraints *) string list * (* register clobbers *) location - (** There are for storing inline assembly. They follow the GCC - * specification: -{v + (** There are for storing inline assembly. They follow the GCC + * specification: +{v asm [volatile] ("...template..." "..template.." : "c1" (o1), "c2" (o2), ..., "cN" (oN) : "d1" (i1), "d2" (i2), ..., "dM" (iM) @@ -1055,12 +1070,12 @@ where the parts are - [volatile] (optional): when present, the assembler instruction cannot be removed, moved, or otherwise optimized - - template: a sequence of strings, with %0, %1, %2, etc. in the string to + - template: a sequence of strings, with %0, %1, %2, etc. in the string to refer to the input and output expressions. I think they're numbered - consecutively, but the docs don't specify. Each string is printed on + consecutively, but the docs don't specify. Each string is printed on a separate line. This is the only part that is present for MSVC inline assembly. - - "ci" (oi): pairs of constraint-string and output-lval; the + - "ci" (oi): pairs of constraint-string and output-lval; the constraint specifies that the register used must have some property, like being a floating-point register; the constraint string for outputs also has "=" to indicate it is written, or @@ -1074,7 +1089,7 @@ where the parts are "memory" may be specified for arbitrary memory effects an example (from gcc manual): -{v +{v asm volatile ("movc3 %0,%1,%2" : /* no outputs */ : "g" (from), "g" (to), "g" (count) @@ -1083,7 +1098,7 @@ an example (from gcc manual): Starting with gcc 3.1, the operands may have names: -{v +{v asm volatile ("movc3 %[in0],%1,%2" : /* no outputs */ : [in0] "g" (from), "g" (to), "g" (count) @@ -1093,19 +1108,19 @@ an example (from gcc manual): *) (** Describes a location in a source file. *) -and location = { +and location = { line: int; (** The line number. -1 means "do not know" *) file: string; (** The name of the source file*) byte: int; (** The byte position in the source file *) } -(** Type signatures. Two types are identical iff they have identical - * signatures. These contain the same information as types but canonicalized. - * For example, two function types that are identical except for the name of - * the formal arguments are given the same signature. Also, [TNamed] +(** Type signatures. Two types are identical iff they have identical + * signatures. These contain the same information as types but canonicalized. + * For example, two function types that are identical except for the name of + * the formal arguments are given the same signature. Also, [TNamed] * constructors are unrolled. *) -and typsig = +and typsig = TSArray of typsig * int64 option * attribute list | TSPtr of typsig * attribute list | TSComp of bool * string * attribute list @@ -1132,12 +1147,12 @@ val compareLoc: location -> location -> int (** Make an empty function *) val emptyFunction: string -> fundec -(** Update the formals of a [fundec] and make sure that the function type +(** 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 -(** 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 +(** 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 @@ -1145,12 +1160,12 @@ 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 +(** 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 -(** A dummy function declaration handy when you need one as a placeholder. It +(** A dummy function declaration handy when you need one as a placeholder. It * contains inside a dummy varinfo. *) val dummyFunDec: fundec @@ -1172,12 +1187,12 @@ val saveBinaryFileChannel : file -> out_channel -> unit * argument is the name of a file previously created by * {!Cil.saveBinaryFile}. Because this also reads some global state, * this should be called before any other CIL code is parsed or generated. *) -val loadBinaryFile : string -> file +val loadBinaryFile : string -> 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 +(** 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") *) -val getGlobInit: ?main_name:string -> file -> fundec +val getGlobInit: ?main_name:string -> file -> fundec (** Iterate over all globals, including the global initializer *) val iterGlobals: file -> (global -> unit) -> unit @@ -1185,7 +1200,7 @@ 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 +(** Map over all globals, including the global initializer and change things in place *) val mapGlobals: file -> (global -> global) -> unit @@ -1208,14 +1223,14 @@ val new_sid : unit -> int * function modifies its argument in place. *) val prepareCFG: fundec -> unit -(** Compute the CFG information for all statements in a fundec and return a - * list of the statements. The input fundec cannot have [Break], [Switch], +(** Compute the CFG information for all statements in a fundec and return a + * list of the statements. The input fundec cannot have [Break], [Switch], * [Default], or [Continue] {!Cil.stmtkind}s or {!Cil.label}s. Use * {!Cil.prepareCFG} to transform them away. The second argument should * be [true] if you wish a global statement number, [false] if you wish a - * local (per-function) statement numbering. The list of statements is set - * in the sallstmts field of a fundec. - * + * local (per-function) statement numbering. The list of statements is set + * in the sallstmts field of a fundec. + * * NOTE: unless you want the simpler control-flow graph provided by * prepareCFG, or you need the function's smaxstmtid and sallstmt fields * filled in, we recommend you use {!Cfg.computeFileCFG} instead of this @@ -1225,18 +1240,18 @@ val prepareCFG: fundec -> unit val computeCFGInfo: fundec -> bool -> unit -(** Create a deep copy of a function. There should be no sharing between the +(** Create a deep copy of a function. There should be no sharing between the * copy and the original function *) -val copyFunction: fundec -> string -> fundec +val copyFunction: fundec -> string -> fundec -(** 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 +(** 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 +val pushGlobal: global -> types: global list ref -> variables: global list ref -> unit (** An empty statement. Used in pretty printing *) @@ -1263,30 +1278,30 @@ val builtinLoc: location val makeZeroInit: 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. +(** 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 +{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) -> + | CompoundInit (ct, initl) -> foldLeftCompound ~implicit:false - ~doinit:(fun off' i' t' acc -> + ~doinit:(fun off' i' t' acc -> myInit (addOffsetLval lv off') i' acc) ~ct:ct ~initl:initl ~acc:acc v} *) -val foldLeftCompound: +val foldLeftCompound: implicit:bool -> doinit: (offset -> init -> typ -> 'a -> 'a) -> ct: typ -> @@ -1305,6 +1320,12 @@ val isVoidType: typ -> bool (** is the given type "void *"? *) val isVoidPtrType: typ -> bool +(** for numerical __complex types return type of corresponding real part and imaginary parts *) +val typeOfRealAndImagComponents: typ -> typ + +(** for an fkind, return the corresponding complex fkind *) +val getComplexFkind: fkind -> fkind + (** int *) val intType: typ @@ -1323,10 +1344,10 @@ val charType: typ (** char * *) val charPtrType: typ -(** wchar_t (depends on architecture) and is set when you call +(** wchar_t (depends on architecture) and is set when you call * {!Cil.initCIL}. *) val wcharKind: ikind ref -val wcharType: typ ref +val wcharType: typ ref (** char const * *) val charConstPtrType: typ @@ -1343,7 +1364,7 @@ val uintPtrType: typ (** double *) val doubleType: typ -(** An unsigned integer type that fits pointers. Depends on {!Cil.msvcMode} +(** An unsigned integer type that fits pointers. Depends on {!Cil.msvcMode} * and is set when you call {!Cil.initCIL}. *) val upointType: typ ref @@ -1351,11 +1372,11 @@ val upointType: typ ref * {!Cil.msvcMode} and is set when you call {!Cil.initCIL}. *) val ptrdiffType: typ ref -(** An unsigned integer type that is the type of sizeof. Depends on +(** An unsigned integer type that is the type of sizeof. Depends on * {!Cil.msvcMode} and is set when you call {!Cil.initCIL}. *) val typeOfSizeOf: typ ref -(** The integer kind of {!Cil.typeOfSizeOf}. +(** The integer kind of {!Cil.typeOfSizeOf}. * Set when you call {!Cil.initCIL}. *) val kindOfSizeOf: ikind ref @@ -1363,21 +1384,21 @@ val kindOfSizeOf: ikind ref val isSigned: ikind -> bool -(** Creates a a (potentially recursive) composite type. The arguments are: - * (1) a boolean indicating whether it is a struct or a union, (2) the name - * (always non-empty), (3) a function that when given a representation of the - * structure type constructs the type of the fields recursive type (the first - * argument is only useful when some fields need to refer to the type of the - * structure itself), and (4) a list of attributes to be associated with the - * composite type. The resulting compinfo has the field "cdefined" only if +(** Creates a a (potentially recursive) composite type. The arguments are: + * (1) a boolean indicating whether it is a struct or a union, (2) the name + * (always non-empty), (3) a function that when given a representation of the + * structure type constructs the type of the fields recursive type (the first + * argument is only useful when some fields need to refer to the type of the + * structure itself), and (4) a list of attributes to be associated with the + * composite type. The resulting compinfo has the field "cdefined" only if * the list of fields is non-empty. *) val mkCompInfo: bool -> (* whether it is a struct or a union *) string -> (* name of the composite type; cannot be empty *) - (compinfo -> + (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 + (* 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 @@ -1386,25 +1407,25 @@ val copyCompInfo: compinfo -> string -> compinfo (** This is a constant used as the name of an unnamed bitfield. These fields do not participate in initialization and their name is not printed. *) -val missingFieldName: string +val missingFieldName: string (** Get the full name of a comp *) val compFullName: compinfo -> string -(** Returns true if this is a complete type. - This means that sizeof(t) makes sense. - Incomplete types are not yet defined +(** Returns true if this is a complete type. + This means that sizeof(t) makes sense. + Incomplete types are not yet defined structures and empty arrays. *) -val isCompleteType: typ -> bool +val isCompleteType: typ -> bool -(** Unroll a type until it exposes a non +(** Unroll a type until it exposes a non * [TNamed]. Will collect all attributes appearing in [TNamed]!!! *) -val unrollType: typ -> typ +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] +(** 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 +val unrollTypeDeep: typ -> typ (** Separate out the storage-modifier name attributes *) val separateStorageModifiers: attribute list -> attribute list * attribute list @@ -1412,7 +1433,7 @@ val separateStorageModifiers: attribute list -> attribute list * attribute list (** True if the argument is an integral type (i.e. integer or enum) *) val isIntegralType: typ -> bool -(** True if the argument is an arithmetic type (i.e. integer, enum or +(** True if the argument is an arithmetic type (i.e. integer, enum or floating point *) val isArithmeticType: typ -> bool @@ -1426,18 +1447,18 @@ val isScalarType: typ -> bool val isFunctionType: typ -> bool (** Obtain the argument list ([] if None) *) -val argsToList: (string * typ * attributes) list option +val argsToList: (string * typ * attributes) list option -> (string * typ * attributes) list (** True if the argument is an array type *) val isArrayType: typ -> bool -(** Raised when {!Cil.lenOfArray} fails either because the length is [None] +(** 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 +(** 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 @@ -1446,42 +1467,42 @@ val getCompField: compinfo -> string -> fieldinfo (** A datatype to be used in conjunction with [existsType] *) -type existsAction = +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 + | 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. +(** 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 + 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 +(** 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: +val splitFunctionType: typ -> typ * (string * typ * attributes) list option * bool * attributes -(** Same as {!Cil.splitFunctionType} but takes a varinfo. Prints a nicer +(** Same as {!Cil.splitFunctionType} but takes a varinfo. Prints a nicer * error message if the varinfo is not for a function *) -val splitFunctionTypeVI: +val splitFunctionTypeVI: varinfo -> typ * (string * typ * attributes) list option * bool * attributes (** {b Type signatures} *) -(** Type signatures. Two types are identical iff they have identical - * signatures. These contain the same information as types but canonicalized. - * For example, two function types that are identical except for the name of - * the formal arguments are given the same signature. Also, [TNamed] +(** Type signatures. Two types are identical iff they have identical + * signatures. These contain the same information as types but canonicalized. + * For example, two function types that are identical except for the name of + * the formal arguments are given the same signature. Also, [TNamed] * constructors are unrolled. *) (** Print a type signature *) @@ -1496,7 +1517,7 @@ val typeSig: typ -> typsig val typeSigWithAttrs: ?ignoreSign:bool -> (attributes -> attributes) -> typ -> typsig (** Replace the attributes of a signature (only at top level) *) -val setTypeSigAttrs: attributes -> typsig -> typsig +val setTypeSigAttrs: attributes -> typsig -> typsig (** Get the top-level attributes of a signature *) val typeSigAttrs: typsig -> attributes @@ -1504,22 +1525,22 @@ val typeSigAttrs: typsig -> attributes (*********************************************************) (** {b 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 first argument specifies +(** 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 first argument specifies * whether the varinfo is for a global. *) val makeVarinfo: bool -> string -> ?init:init -> typ -> varinfo -(** 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 +(** 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. *) val makeFormalVar: fundec -> ?where:string -> string -> typ -> varinfo -(** Make a local variable and add it to a function's slocals (only if insert = - true, which is the default). Make sure you know what you are doing if you +(** Make a local variable and add it to a function's slocals (only if insert = + true, which is the default). Make sure you know what you are doing if you set insert=false. *) val makeLocalVar: fundec -> ?insert:bool -> string -> ?init:init -> typ -> varinfo @@ -1539,32 +1560,32 @@ val makeTempVar: fundec -> ?insert:bool -> ?name: string -> ?descr:Pretty.doc -> ?descrpure:bool -> typ -> varinfo -(** Make a global variable. Your responsibility to make sure that the name - is unique *) +(** Make a global variable. Your responsibility to make sure that the name + is unique *) val makeGlobalVar: string -> typ -> varinfo (** Make a shallow copy of a [varinfo] and assign a new identifier *) val copyVarinfo: varinfo -> string -> varinfo -(** Generate a new variable ID. This will be different than any variable ID +(** Generate a new variable ID. This will be different than any variable ID * that is generated by {!Cil.makeLocalVar} and friends *) val newVID: unit -> int -(** Add an offset at the end of an lvalue. Make sure the type of the lvalue +(** 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 +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] +(** 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] +(** 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 @@ -1572,7 +1593,7 @@ val removeOffset: offset -> offset * offset val typeOfLval: lval -> typ (** Compute the type of an offset from a base type *) -val typeOffset: typ -> offset -> typ +val typeOffset: typ -> offset -> typ (*******************************************************) @@ -1596,14 +1617,14 @@ val mone: exp * the given kind. *) val kintegerCilint: ikind -> cilint -> exp -(** Construct an integer of a given kind, using OCaml's int64 type. If needed - * it will truncate the integer to be within the representable range for the +(** Construct an integer of a given kind, using OCaml's int64 type. If needed + * it will truncate the integer to be within the representable range for the * given kind. *) val kinteger64: ikind -> int64 -> 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 +(** 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: ikind -> int -> exp @@ -1613,7 +1634,7 @@ val integer: int -> exp (** If the given expression is an integer constant or a CastE'd - integer constant, return that constant's value. + integer constant, return that constant's value. Otherwise return None. *) val getInteger: exp -> cilint option @@ -1631,70 +1652,73 @@ val isConstant: exp -> bool (** True if the given offset contains only field nanmes or constant indices. *) val isConstantOffset: offset -> bool -(** True if the given expression is a (possibly cast'ed) integer or character +(** True if the given expression is a (possibly cast'ed) integer or character constant with value zero *) val isZero: exp -> bool +(** True if the given expression is a null-pointer constant. As per 6.3.2.3 subsection 3 *) +val isNullPtrConstant: exp -> bool + (** Given the character c in a (CChr c), sign-extend it to 32 bits. (This is the official way of interpreting character constants, according to ISO C 6.4.4.4.10, which says that character constants are chars cast to ints) - Returns CInt64(sign-extened c, IInt, None) *) + Returns CInt64(sign-extended c, IInt, None) *) val charConstToInt: char -> constant -(** Do constant folding on an expression. If the first argument is true then +(** 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.*) + expressions in a given AST node.*) val constFold: bool -> exp -> exp -(** Do constant folding on a binary operation. The bulk of the work done by - [constFold] is done here. If the first argument is true then +(** Do constant folding on a binary operation. The bulk of the work done by + [constFold] is done here. If the first argument is true then will also compute compiler-dependent expressions such as sizeof *) val constFoldBinOp: bool -> binop -> exp -> exp -> typ -> exp -(** Increment an expression. Can be arithmetic or pointer type *) +(** Increment an expression. Can be arithmetic or pointer type *) val increm: exp -> int -> exp (** Makes an lvalue out of a given variable *) val var: varinfo -> lval -(** Make an AddrOf. Given an lvalue of type T will give back an expression of +(** 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: lval -> exp +val mkAddrOf: lval -> 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 +(** 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: 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 +(** 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 (** Make an expression that is a string constant (of pointer type) *) val mkString: string -> exp -(** Construct a cast when having the old type of the expression. If the new +(** 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. *) val mkCastT: e:exp -> oldt:typ -> newt:typ -> exp -(** Like {!Cil.mkCastT} but uses typeOf to get [oldt] *) -val mkCast: e:exp -> newt:typ -> exp +(** Like {!Cil.mkCastT} but uses typeOf to get [oldt] *) +val mkCast: e:exp -> newt:typ -> exp (** Removes casts from this expression, but ignores casts within - other expression constructs. So we delete the (A) and (B) casts from + 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 (** Compute the type of an expression *) val typeOf: exp -> typ -(** Convert a string representing a C integer literal to an expression. +(** 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 -> exp @@ -1728,55 +1752,55 @@ val dummyStmt: stmt (** Make a while loop. Can contain Break or Continue *) val mkWhile: guard:exp -> body:stmt list -> stmt list -(** Make a for loop for(i=start; i first:exp -> stopat:exp -> incr:exp +val mkForIncr: iter:varinfo -> 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 -> +(** 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 - + (**************************************************) (** {b 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 +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 + | 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 +(** 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 types *) val attributeHash: (string, attributeClass) Hashtbl.t -(** Partition the attributes into classes:name attributes, function type, +(** Partition the attributes into classes:name attributes, function type, and type attributes *) -val partitionAttributes: default:attributeClass -> +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 +(** 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 + +(** 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 +(** Remove all attributes with the given name. Maintains the attributes in sorted order. *) val dropAttribute: string -> attributes -> attributes @@ -1791,7 +1815,7 @@ val filterAttributes: string -> attributes -> attributes attributes must be sorted. *) val hasAttribute: string -> attributes -> bool -(** Returns all the attributes contained in a type. This requires a traversal +(** 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 @@ -1802,7 +1826,7 @@ val setTypeAttrs: typ -> attributes -> typ (* Resets the attributes *) 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 + does not remove attributes from typedef and tag definitions, just from their uses *) val typeRemoveAttributes: string list -> typ -> typ @@ -1820,108 +1844,115 @@ exception NotAnAttrParam of exp (** Different visiting actions. 'a will be instantiated with [exp], [instr], etc. *) -type 'a visitAction = - SkipChildren (** Do not visit the children. Return +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 + | DoChildren (** Continue with the children of this + node. Rebuild the node on return + if any of the children changes (use == test) *) - | ChangeTo of 'a (** Replace the expression with the + | ChangeTo of 'a (** Replace the expression with the given one *) - | 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 + | 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 *) -(** A visitor interface for traversing CIL trees. Create instantiations of - * this type by specializing the class {!Cil.nopCilVisitor}. Each of the - * specialized visiting functions can also call the [queueInstr] to specify - * that some instructions should be inserted before the current instruction +(** A visitor interface for traversing CIL trees. Create instantiations of + * this type by specializing the class {!Cil.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. *) class type cilVisitor = object - 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 + 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 + 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 + 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 + method vlval: lval -> lval visitAction (** Invoked on each lvalue occurrence *) - method voffs: offset -> offset visitAction + 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 + (** 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 + 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. *) - 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.) *) - method vinit: varinfo -> offset -> init -> init visitAction + 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.) *) + + method vinit: varinfo -> offset -> init -> init visitAction (** Initializers for static, * const and global variables, * pass the variable where this * occurs, and the offset *) - method vtype: typ -> typ visitAction (** Use of some type. Note - * that for structure/union - * and enumeration types the - * definition of the - * composite type is not - * visited. Use [vglob] to + + 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 vattr: attribute -> attribute list visitAction + + method vattr: attribute -> attribute list visitAction (** Attribute. Each attribute can be replaced by a list *) - method vattrparam: attrparam -> attrparam visitAction + + method vattrparam: attrparam -> attrparam visitAction (** Attribute parameters. *) - (** Add here instructions while visiting to queue them to preceede the - * current statement or instruction being processed. Use this method only - * when you are visiting an expression that is inside a function body, or - * a statement, because otherwise there will no place for the visitor to + (** 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. *) method queueInstr: instr list -> unit - (** Gets the queue of instructions and resets the queue. This is done - * automatically for you when you visit statments. *) + (** Gets the queue of instructions and resets the queue. This is done + * automatically for you when you visit statements. *) method unqueueInstr: unit -> instr list end @@ -1931,8 +1962,8 @@ class nopCilVisitor: cilVisitor (* other cil constructs *) -(** Visit a file. This will will re-cons all globals TWICE (so that it is - * tail-recursive). Use {!Cil.visitCilFileSameGlobals} if your visitor will +(** Visit a file. This will will re-cons all globals TWICE (so that it is + * tail-recursive). Use {!Cil.visitCilFileSameGlobals} if your visitor will * not change the list of globals. *) val visitCilFile: cilVisitor -> file -> unit @@ -1990,13 +2021,13 @@ val visitCilAttributes: cilVisitor -> attribute list -> attribute list (** Whether the pretty printer should print output for the MS VC compiler. Default is GCC. After you set this function you should call {!Cil.initCIL}. *) -val msvcMode: bool ref +val msvcMode: bool ref (** Whether to convert local static variables into global static variables *) val makeStaticGlobal: bool ref -(** 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 +(** 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 *) val useLogicalOperators: bool ref @@ -2021,18 +2052,18 @@ val caseRangeFold: label list -> label list Note that CIL assumes that optimization is always enabled ;-) *) val oldstyleExternInline : bool ref -(** A visitor that does constant folding. Pass as argument whether you want +(** A visitor that does constant folding. Pass as argument whether you want * machine specific simplifications to be done, or not. *) val constFoldVisitor: bool -> cilVisitor (** Styles of printing line directives *) type lineDirectiveStyle = - | LineComment (** Before every element, print the line - * number in comments. This is ignored by - * processing tools (thus errors are reproted - * in the CIL output), but useful for + | LineComment (** Before every element, print the line + * number in comments. This is ignored by + * processing tools (thus errors are reproted + * in the CIL output), but useful for * visual inspection *) - | LineCommentSparse (** Like LineComment but only print a line + | LineCommentSparse (** Like LineComment but only print a line * directive for a new source line *) | LinePreprocessorInput (** Use # nnn directives (in gcc mode) *) | LinePreprocessorOutput (** Use #line directives *) @@ -2040,15 +2071,15 @@ type lineDirectiveStyle = (** How to print line directives *) val lineDirectiveStyle: lineDirectiveStyle option ref -(** Whether we print something that will only be used as input to our own +(** Whether we print something that will only be used as input to our own * parser. In that case we are a bit more liberal in what we print *) val print_CIL_Input: bool ref -(** 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. There is one case howewer in which if you - * turn this on you will get code that does not compile: if you use varargs +(** 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. There is one case howewer in which if you + * turn this on you will get code that does not compile: if you use varargs * the __builtin_va_arg function will be printed in its internal form. *) val printCilAsIs: bool ref @@ -2066,33 +2097,33 @@ val forgcc: string -> string (** {b 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 +(** 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. *) val currentLoc: location ref (** A reference to the current global being visited *) -val currentGlobal: global ref +val currentGlobal: global ref -(** CIL has a fairly easy to use mechanism for printing error messages. This - * mechanism is built on top of the pretty-printer mechanism (see - * {!Pretty.doc}) and the error-message modules (see {!Errormsg.error}). +(** CIL has a fairly easy to use mechanism for printing error messages. This + * mechanism is built on top of the pretty-printer mechanism (see + * {!Pretty.doc}) and the error-message modules (see {!Errormsg.error}). - Here is a typical example for printing a log message: {v + Here is a typical example for printing a log message: {v ignore (Errormsg.log "Expression %a is not positive (at %s:%i)\n" d_exp e loc.file loc.line) v} - and here is an example of how you print a fatal error message that stop the -* execution: {v + and here is an example of how you print a fatal error message that stop the +* execution: {v Errormsg.s (Errormsg.bug "Why am I here?") v} - Notice that you can use C format strings with some extension. The most -useful extension is "%a" that means to consumer the next two argument from -the argument list and to apply the first to [unit] and then to the second -and to print the resulting {!Pretty.doc}. For each major type in CIL there is + Notice that you can use C format strings with some extension. The most +useful extension is "%a" that means to consumer the next two argument from +the argument list and to apply the first to [unit] and then to the second +and to print the resulting {!Pretty.doc}. For each major type in CIL there is a corresponding function that pretty-prints an element of that type: *) @@ -2124,15 +2155,15 @@ val additiveLevel: int val comparativeLevel: int val bitwiseLevel: int -(** Parentheses 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 +(** Parentheses 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! *) val getParenthLevel: exp -> int -(** A printer interface for CIL trees. Create instantiations of +(** A printer interface for CIL trees. Create instantiations of * this type by specializing the class {!Cil.defaultCilPrinterClass}. *) class type cilPrinter = object @@ -2142,9 +2173,9 @@ class type cilPrinter = object method getPrintInstrTerminator : unit -> string method pVDecl: unit -> varinfo -> Pretty.doc - (** Invoked for each variable declaration. Note that variable - * declarations are all the [GVar], [GVarDecl], [GFun], all the [varinfo] - * in formals of function types, and the formals and locals for function + (** Invoked for each variable declaration. Note that variable + * declarations are all the [GVar], [GVarDecl], [GFun], all the [varinfo] + * in formals of function types, and the formals and locals for function * definitions. *) method pVar: varinfo -> Pretty.doc @@ -2163,53 +2194,53 @@ class type cilPrinter = object (** Print a label. *) method pStmt: unit -> stmt -> Pretty.doc - (** Control-flow statement. This is used by + (** Control-flow statement. This is used by * {!Cil.printGlobal} and by {!Cil.dumpGlobal}. *) method dStmt: out_channel -> int -> stmt -> unit - (** Dump a control-flow statement to a file with a given indentation. + (** Dump a control-flow statement to a file with a given indentation. * This is used by {!Cil.dumpGlobal}. *) method dBlock: out_channel -> int -> block -> unit - (** Dump a control-flow block to a file with a given indentation. + (** Dump a control-flow block to a file with a given indentation. * This is used by {!Cil.dumpGlobal}. *) method pBlock: unit -> block -> Pretty.doc (** Print a block. *) method pGlobal: unit -> global -> Pretty.doc - (** Global (vars, types, etc.). This can be slow and is used only by + (** Global (vars, types, etc.). This can be slow and is used only by * {!Cil.printGlobal} but not by {!Cil.dumpGlobal}. *) method dGlobal: out_channel -> global -> unit - (** Dump a global to a file with a given indentation. This is used by + (** Dump a global to a file with a given indentation. This is used by * {!Cil.dumpGlobal} *) method pFieldDecl: unit -> fieldinfo -> Pretty.doc (** A field declaration *) - method pType: Pretty.doc option -> unit -> typ -> Pretty.doc - (** Use of some type in some declaration. The first argument is used to print - * the declared element, or is None if we are just printing a type with no - * name being declared. Note that for structure/union and enumeration types - * the definition of the composite type is not visited. Use [vglob] to + method pType: Pretty.doc option -> unit -> typ -> Pretty.doc + (** Use of some type in some declaration. The first argument is used to print + * the declared element, or is None if we are just printing a type with no + * name being declared. Note that for structure/union and enumeration types + * the definition of the composite type is not visited. Use [vglob] to * visit it. *) method pAttr: attribute -> Pretty.doc * bool - (** Attribute. Also return an indication whether this attribute must be + (** Attribute. Also return an indication whether this attribute must be * printed inside the __attribute__ list or not. *) - - method pAttrParam: unit -> attrparam -> Pretty.doc + + method pAttrParam: unit -> attrparam -> Pretty.doc (** Attribute parameter *) - + method pAttrs: unit -> attributes -> Pretty.doc (** Attribute lists *) method pLineDirective: ?forcefile:bool -> location -> Pretty.doc - (** Print a line-number. This is assumed to come always on an empty line. - * If the forcefile argument is present and is true then the file name - * will be printed always. Otherwise the file name is printed only if it - * is different from the last time time this function is called. The last + (** Print a line-number. This is assumed to come always on an empty line. + * If the forcefile argument is present and is true then the file name + * will be printed always. Otherwise the file name is printed only if it + * is different from the last time time this function is called. The last * file name is stored in a private field inside the cilPrinter object. *) method pStmtKind: stmt -> unit -> stmtkind -> Pretty.doc @@ -2220,21 +2251,21 @@ class type cilPrinter = object * statement printing in certain special cases. *) method pExp: unit -> exp -> Pretty.doc - (** Print expressions *) + (** Print expressions *) method pInit: unit -> init -> Pretty.doc - (** Print initializers. This can be slow and is used by + (** Print initializers. This can be slow and is used by * {!Cil.printGlobal} but not by {!Cil.dumpGlobal}. *) method dInit: out_channel -> int -> init -> unit - (** Dump a global to a file with a given indentation. This is used by + (** Dump a global to a file with a given indentation. This is used by * {!Cil.dumpGlobal} *) end class defaultCilPrinterClass: cilPrinter val defaultCilPrinter: cilPrinter -(** These are pretty-printers that will show you more details on the internal +(** These are pretty-printers that will show you more details on the internal * CIL representation, without trying hard to make it look like C *) class plainCilPrinterClass: cilPrinter val plainCilPrinter: cilPrinter @@ -2252,7 +2283,7 @@ class descriptiveCilPrinterClass : bool -> descriptiveCilPrinter 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. - + The boolean here enables descriptive printing. Usually use true here, but you can set enable to false to make this class behave like defaultCilPrinterClass. This allows subclasses to turn the @@ -2267,7 +2298,7 @@ val printerForMaincil: cilPrinter ref (* Top-level printing functions *) (** Print a type given a pretty printer *) val printType: cilPrinter -> unit -> typ -> Pretty.doc - + (** Print an expression given a pretty printer *) val printExp: cilPrinter -> unit -> exp -> Pretty.doc @@ -2275,41 +2306,41 @@ val printExp: cilPrinter -> unit -> exp -> Pretty.doc val printLval: cilPrinter -> unit -> lval -> Pretty.doc (** Print a global given a pretty printer *) -val printGlobal: cilPrinter -> unit -> global -> Pretty.doc +val printGlobal: cilPrinter -> unit -> global -> Pretty.doc (** Print an attribute given a pretty printer *) -val printAttr: cilPrinter -> unit -> attribute -> Pretty.doc +val printAttr: cilPrinter -> unit -> attribute -> Pretty.doc (** Print a set of attributes given a pretty printer *) -val printAttrs: cilPrinter -> unit -> attributes -> Pretty.doc +val printAttrs: cilPrinter -> unit -> attributes -> Pretty.doc (** Print an instruction given a pretty printer *) -val printInstr: cilPrinter -> unit -> instr -> Pretty.doc +val printInstr: cilPrinter -> unit -> instr -> Pretty.doc -(** Print a statement given a pretty printer. This can take very long - * (or even overflow the stack) for huge statements. Use {!Cil.dumpStmt} +(** Print a statement given a pretty printer. This can take very long + * (or even overflow the stack) for huge statements. Use {!Cil.dumpStmt} * instead. *) val printStmt: cilPrinter -> unit -> stmt -> Pretty.doc -(** Print a block given a pretty printer. This can take very long - * (or even overflow the stack) for huge block. Use {!Cil.dumpBlock} +(** Print a block given a pretty printer. This can take very long + * (or even overflow the stack) for huge block. Use {!Cil.dumpBlock} * instead. *) val printBlock: cilPrinter -> unit -> block -> Pretty.doc -(** Dump a statement to a file using a given indentation. Use this instead of +(** Dump a statement to a file using a given indentation. Use this instead of * {!Cil.printStmt} whenever possible. *) val dumpStmt: cilPrinter -> out_channel -> int -> stmt -> unit -(** Dump a block to a file using a given indentation. Use this instead of +(** Dump a block to a file using a given indentation. Use this instead of * {!Cil.printBlock} whenever possible. *) val dumpBlock: cilPrinter -> out_channel -> int -> block -> unit -(** Print an initializer given a pretty printer. This can take very long - * (or even overflow the stack) for huge initializers. Use {!Cil.dumpInit} +(** Print an initializer given a pretty printer. This can take very long + * (or even overflow the stack) for huge initializers. Use {!Cil.dumpInit} * instead. *) -val printInit: cilPrinter -> unit -> init -> Pretty.doc +val printInit: cilPrinter -> unit -> init -> Pretty.doc -(** Dump an initializer to a file using a given indentation. Use this instead of +(** Dump an initializer to a file using a given indentation. Use this instead of * {!Cil.printInit} whenever possible. *) val dumpInit: cilPrinter -> out_channel -> int -> init -> unit @@ -2322,12 +2353,12 @@ val d_exp: unit -> exp -> Pretty.doc (** Pretty-print an lvalue using {!Cil.defaultCilPrinter} *) val d_lval: unit -> lval -> Pretty.doc -(** Pretty-print an offset using {!Cil.defaultCilPrinter}, given the pretty +(** Pretty-print an offset using {!Cil.defaultCilPrinter}, given the pretty * printing for the base. *) val d_offset: Pretty.doc -> unit -> offset -> Pretty.doc -(** Pretty-print an initializer using {!Cil.defaultCilPrinter}. This can be - * extremely slow (or even overflow the stack) for huge initializers. Use +(** Pretty-print an initializer using {!Cil.defaultCilPrinter}. This can be + * extremely slow (or even overflow the stack) for huge initializers. Use * {!Cil.dumpInit} instead. *) val d_init: unit -> init -> Pretty.doc @@ -2344,7 +2375,7 @@ val d_attr: unit -> attribute -> Pretty.doc val d_attrparam: unit -> attrparam -> Pretty.doc (** Pretty-print a list of attributes using {!Cil.defaultCilPrinter} *) -val d_attrlist: unit -> attributes -> Pretty.doc +val d_attrlist: unit -> attributes -> Pretty.doc (** Pretty-print an instruction using {!Cil.defaultCilPrinter} *) val d_instr: unit -> instr -> Pretty.doc @@ -2352,19 +2383,19 @@ val d_instr: unit -> instr -> Pretty.doc (** Pretty-print a label using {!Cil.defaultCilPrinter} *) val d_label: unit -> label -> Pretty.doc -(** Pretty-print a statement using {!Cil.defaultCilPrinter}. This can be - * extremely slow (or even overflow the stack) for huge statements. Use +(** Pretty-print a statement using {!Cil.defaultCilPrinter}. This can be + * extremely slow (or even overflow the stack) for huge statements. Use * {!Cil.dumpStmt} instead. *) val d_stmt: unit -> stmt -> Pretty.doc -(** Pretty-print a block using {!Cil.defaultCilPrinter}. This can be - * extremely slow (or even overflow the stack) for huge blocks. Use +(** Pretty-print a block using {!Cil.defaultCilPrinter}. This can be + * extremely slow (or even overflow the stack) for huge blocks. Use * {!Cil.dumpBlock} instead. *) val d_block: unit -> block -> Pretty.doc -(** Pretty-print the internal representation of a global using - * {!Cil.defaultCilPrinter}. This can be extremely slow (or even overflow the - * stack) for huge globals (such as arrays with lots of initializers). Use +(** Pretty-print the internal representation of a global using + * {!Cil.defaultCilPrinter}. This can be extremely slow (or even overflow the + * stack) for huge globals (such as arrays with lots of initializers). Use * {!Cil.dumpGlobal} instead. *) val d_global: unit -> global -> Pretty.doc @@ -2383,7 +2414,7 @@ val dn_stmt : unit -> stmt -> Pretty.doc val dn_instr : unit -> instr -> Pretty.doc -(** Pretty-print a short description of the global. This is useful for error +(** Pretty-print a short description of the global. This is useful for error * messages *) val d_shortglobal: unit -> global -> Pretty.doc @@ -2396,8 +2427,8 @@ val dumpGlobal: cilPrinter -> out_channel -> global -> unit val dumpFile: cilPrinter -> out_channel -> string -> file -> unit -(** the following error message producing functions also print a location in - * the code. use {!Errormsg.bug} and {!Errormsg.unimp} if you do not want +(** the following error message producing functions also print a location in + * the code. use {!Errormsg.bug} and {!Errormsg.unimp} if you do not want * that *) (** Like {!Errormsg.bug} except that {!Cil.currentLoc} is also printed *) @@ -2409,33 +2440,33 @@ val unimp: ('a,unit,Pretty.doc) format -> 'a (** Like {!Errormsg.error} except that {!Cil.currentLoc} is also printed *) val error: ('a,unit,Pretty.doc) format -> 'a -(** Like {!Cil.error} except that it explicitly takes a location argument, +(** Like {!Cil.error} except that it explicitly takes a location argument, * instead of using the {!Cil.currentLoc} *) -val errorLoc: location -> ('a,unit,Pretty.doc) format -> 'a +val errorLoc: location -> ('a,unit,Pretty.doc) format -> 'a (** Like {!Errormsg.warn} except that {!Cil.currentLoc} is also printed *) val warn: ('a,unit,Pretty.doc) format -> 'a -(** Like {!Errormsg.warnOpt} except that {!Cil.currentLoc} is also printed. +(** Like {!Errormsg.warnOpt} except that {!Cil.currentLoc} is also printed. * This warning is printed only of {!Errormsg.warnFlag} is set. *) val warnOpt: ('a,unit,Pretty.doc) format -> 'a -(** Like {!Errormsg.warn} except that {!Cil.currentLoc} and context +(** Like {!Errormsg.warn} except that {!Cil.currentLoc} and context is also printed *) val warnContext: ('a,unit,Pretty.doc) format -> 'a -(** Like {!Errormsg.warn} except that {!Cil.currentLoc} and context is also +(** Like {!Errormsg.warn} except that {!Cil.currentLoc} and context is also * printed. This warning is printed only of {!Errormsg.warnFlag} is set. *) val warnContextOpt: ('a,unit,Pretty.doc) format -> 'a -(** Like {!Cil.warn} except that it explicitly takes a location argument, +(** Like {!Cil.warn} except that it explicitly takes a location argument, * instead of using the {!Cil.currentLoc} *) -val warnLoc: location -> ('a,unit,Pretty.doc) format -> 'a +val warnLoc: location -> ('a,unit,Pretty.doc) format -> 'a -(** Sometimes you do not want to see the syntactic sugar that the above - * pretty-printing functions add. In that case you can use the following - * pretty-printing functions. But note that the output of these functions is +(** Sometimes you do not want to see the syntactic sugar that the above + * pretty-printing functions add. In that case you can use the following + * pretty-printing functions. But note that the output of these functions is * not valid C *) (** Pretty-print the internal representation of an expression *) @@ -2447,7 +2478,7 @@ val d_plaininit: unit -> init -> Pretty.doc (** Pretty-print the internal representation of an lvalue *) val d_plainlval: unit -> lval -> Pretty.doc -(** Pretty-print the internal representation of an lvalue offset +(** Pretty-print the internal representation of an lvalue offset val d_plainoffset: unit -> offset -> Pretty.doc *) (** Pretty-print the internal representation of a type *) @@ -2457,6 +2488,7 @@ val d_plaintype: unit -> typ -> Pretty.doc (** Pretty-print an expression while printing descriptions rather than names of temporaries. *) val dd_exp: unit -> exp -> Pretty.doc + (** Pretty-print an lvalue on the left side of an assignment. If there is an offset or memory dereference, temporaries will be replaced by descriptions as in dd_exp. If the lval is a temp var, @@ -2469,35 +2501,35 @@ val dd_lval: unit -> lval -> Pretty.doc (** {b ALPHA conversion} has been moved to the Alpha module. *) -(** Assign unique names to local variables. This might be necessary after you - * transformed the code and added or renamed some new variables. Names are - * not used by CIL internally, but once you print the file out the compiler - * downstream might be confused. You might - * have added a new global that happens to have the same name as a local in - * some function. Rename the local to ensure that there would never be - * confusioin. Or, viceversa, you might have added a local with a name that +(** 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 (** {b Optimization Passes} *) -(** A peephole optimizer that processes two adjacent instructions and possibly +(** A peephole optimizer that processes two adjacent instructions and possibly replaces them both. If some replacement happens, then the new instructions are themselves subject to optimization *) val peepHole2: (instr * instr -> instr list option) -> stmt list -> unit -(** Similar to [peepHole2] except that the optimization window consists of +(** Similar to [peepHole2] except that the optimization window consists of one instruction, not two *) val peepHole1: (instr -> instr list option) -> stmt list -> unit (** {b Machine dependency} *) - -(** Raised when one of the bitsSizeOf functions cannot compute the size of a - * type. This can happen because the type contains array-length expressions - * that we don't know how to compute or because it is a type whose size is - * not defined (e.g. TFun or an undefined compinfo). The string is an - * explanation of the error *) + +(** Raised when one of the bitsSizeOf functions cannot compute the size of a + * type. This can happen because the type contains array-length expressions + * that we don't know how to compute or because it is a type whose size is + * not defined (e.g. TFun or an undefined compinfo). The string is an + * explanation of the error *) exception SizeOfError of string * typ (** Give the unsigned kind corresponding to any integer kind *) @@ -2522,18 +2554,18 @@ val intKindForSize : int -> bool -> ikind val floatKindForSize : int-> fkind (** The size in bytes of the given int kind. *) -val bytesSizeOfInt: ikind -> int +val bytesSizeOfInt: ikind -> int -(** 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 +(** 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 (** Represents an integer as for a given kind. Returns a truncation * flag saying that the value fit in the kind (NoTruncation), didn't * fit but no "interesting" bits (all-0 or all-1) were lost - * (ValueTruncation) or that bits were lost (BitTruncation). Another + * (ValueTruncation) or that bits were lost (BitTruncation). Another * way to look at the ValueTruncation result is that if you had used * the kind of opposite signedness (e.g. IUInt rather than IInt), you * would gave got NoTruncation... *) @@ -2560,15 +2592,15 @@ val mkCilint : ikind -> int64 -> cilint * call {!Cil.initCIL}. *) val sizeOf: typ -> exp -(** The minimum alignment (in bytes) for a type. This function is - * architecture dependent, so you should only call this after you call +(** 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 alignOf_int: typ -> int -(** Give a type of a base and an offset, returns the number of bits from the - * base address and the width (also expressed in bits) for the subobject - * denoted by the offset. Raises {!Cil.SizeOfError} when it cannot compute - * the size. This function is architecture dependent, so you should only call +(** 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 @@ -2579,7 +2611,7 @@ val char_is_unsigned: bool ref (** Whether the machine is little endian. Set after you call {!Cil.initCIL} *) val little_endian: bool ref -(** Whether the compiler generates assembly labels by prepending "_" to the +(** Whether the compiler generates assembly labels by prepending "_" to the identifier. That is, will function foo() have the label "foo", or "_foo"? Set after you call {!Cil.initCIL} *) val underscore_name: bool ref @@ -2588,17 +2620,17 @@ val underscore_name: bool ref val locUnknown: location (** Return the location of an instruction *) -val get_instrLoc: instr -> location +val get_instrLoc: instr -> location (** Return the location of a global, or locUnknown *) -val get_globalLoc: global -> location +val get_globalLoc: global -> location (** Return the location of a statement, or locUnknown *) -val get_stmtLoc: stmtkind -> location +val get_stmtLoc: stmtkind -> location (** Generate an {!Cil.exp} to be used in case of errors. *) -val dExp: Pretty.doc -> exp +val dExp: Pretty.doc -> exp (** Generate an {!Cil.instr} to be used in case of errors. *) val dInstr: Pretty.doc -> location -> instr @@ -2609,7 +2641,7 @@ val dGlobal: Pretty.doc -> location -> global (** Like map but try not to make a copy of the list *) val mapNoCopy: ('a -> 'a) -> 'a list -> 'a list -(** Like map but each call can return a list. Try not to make a copy of the +(** 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 @@ -2626,7 +2658,7 @@ val stripUnderscores: string -> string (** {b An Interpreter for constructing CIL constructs} *) (** The type of argument for the interpreter *) -type formatArg = +type formatArg = Fe of exp | Feo of exp option (** For array lengths *) | Fu of unop @@ -2638,7 +2670,7 @@ type formatArg = | Fva of bool (** For the ellipsis in a function type *) | Fv of varinfo | Fl of lval - | Flo of lval option + | Flo of lval option | Fo of offset @@ -2693,4 +2725,3 @@ val gccBuiltins: (string, typ * typ list * bool) Hashtbl.t (** @deprecated. For compatibility with older programs, these are aliases for {!Cil.builtinFunctions} *) val msvcBuiltins: (string, typ * typ list * bool) Hashtbl.t - diff --git a/src/cilint.ml b/src/cilint.ml index ae17e4d97..1b7e5de6f 100644 --- a/src/cilint.ml +++ b/src/cilint.ml @@ -21,8 +21,8 @@ bitwise operations on big_ints, and bug-fixed versions of int64_of_big_int and big_int_of_int64. *) -open Big_int - +open Big_int_Z + type cilint = Small of int | Big of big_int type truncation = NoTruncation | ValueTruncation | BitTruncation @@ -34,79 +34,79 @@ let b30 = power_int_positive_int 2 30 let m1 = minus_big_int unit_big_int (* True if 'b' is all 0's or all 1's *) -let nobits (b:big_int) : bool = +let nobits (b:big_int) : bool = sign_big_int b = 0 || compare_big_int b m1 = 0 -let big_int_of_cilint (c:cilint) : big_int = +let big_int_of_cilint (c:cilint) : big_int = match c with | Small i -> big_int_of_int i | Big b -> b -let cilint_of_big_int (b:big_int) : cilint = +let cilint_of_big_int (b:big_int) : cilint = if is_int_big_int b then Small (int_of_big_int b) else Big b -let neg_cilint c = +let neg_cilint c = match c with | Small i when i <> min_int -> Small (-i) | _ -> Big (minus_big_int (big_int_of_cilint c)) (* Apply big_int 'op' to two cilints, returning a cilint *) let b op c1 c2 = cilint_of_big_int (op (big_int_of_cilint c1) (big_int_of_cilint c2)) - + let add_cilint = b add_big_int let sub_cilint = b sub_big_int let mul_cilint = b mult_big_int let div_cilint = b div_big_int let mod_cilint = b mod_big_int -let compare_cilint (c1:cilint) (c2:cilint) : int = +let compare_cilint (c1:cilint) (c2:cilint) : int = match c1, c2 with | Small i1, Small i2 -> compare i1 i2 | _ -> compare_big_int (big_int_of_cilint c1) (big_int_of_cilint c2) -let is_zero_cilint (c:cilint) : bool = +let is_zero_cilint (c:cilint) : bool = match c with | Small i -> i = 0 | Big b -> sign_big_int b = 0 -let negative_cilint (c:cilint) : bool = - match c with +let negative_cilint (c:cilint) : bool = + match c with | Small i -> i < 0 | Big b -> sign_big_int b < 0 let cilint_of_int (i:int) : cilint = Small i -let int_of_cilint (c:cilint) : int = - match c with +let int_of_cilint (c:cilint) : int = + match c with | Small i -> i | Big b -> int_of_big_int b -let rec cilint_of_int64 (i64:int64) : cilint = - if Int64.compare i64 (Int64.of_int min_int) >= 0 && +let cilint_of_int64 (i64:int64) : cilint = + if Int64.compare i64 (Int64.of_int min_int) >= 0 && Int64.compare i64 (Int64.of_int max_int) <= 0 then Small (Int64.to_int i64) else (* We convert 30 bits at a time *) - let rec loop i mul acc = + let rec loop i mul acc = if i = 0L then acc else if i = -1L then sub_big_int acc mul - else + else let lo30 = Int64.to_int (Int64.logand i 0x3fffffffL) in loop (Int64.shift_right i 30) (mult_big_int mul b30) (add_big_int acc (mult_big_int mul (big_int_of_int lo30))) in Big (loop i64 unit_big_int zero_big_int) - + (* Note that this never fails, instead it returns the low-order 64-bits of the cilint. *) -let rec int64_of_cilint (c:cilint) : int64 = +let int64_of_cilint (c:cilint) : int64 = match c with | Small i -> Int64.of_int i - | Big b -> - let rec loop b mul acc = - if sign_big_int b = 0 then + | Big b -> + let rec loop b mul acc = + if sign_big_int b = 0 then acc else if compare_big_int b m1 == 0 then Int64.sub acc mul @@ -115,22 +115,22 @@ let rec int64_of_cilint (c:cilint) : int64 = loop hi (Int64.mul mul 0x40000000L) (Int64.add acc (Int64.mul mul (Int64.of_int (int_of_big_int lo)))) in loop b 1L 0L - -let cilint_of_string (s:string) : cilint = + +let cilint_of_string (s:string) : cilint = cilint_of_big_int (big_int_of_string s) -let string_of_cilint (c:cilint) : string = - match c with +let string_of_cilint (c:cilint) : string = + match c with | Small i -> string_of_int i | Big b -> string_of_big_int b (* Divide rounding towards zero *) -let div0_cilint (c1:cilint) (c2:cilint) = +let div0_cilint (c1:cilint) (c2:cilint) = match c1, c2 with | Small i1, Small i2 -> Small (i1 / i2) | _ -> let b1 = big_int_of_cilint c1 in - let b2 = big_int_of_cilint c2 in + let b2 = big_int_of_cilint c2 in let q, r = quomod_big_int b1 b2 in if lt_big_int b1 zero_big_int && (not (eq_big_int r zero_big_int)) then if gt_big_int b2 zero_big_int then @@ -141,17 +141,17 @@ let div0_cilint (c1:cilint) (c2:cilint) = Big q (* And the corresponding remainder *) -let rem_cilint (c1:cilint) (c2:cilint) = +let rem_cilint (c1:cilint) (c2:cilint) = (sub_cilint c1 (mul_cilint c2 (div0_cilint c1 c2))) (* Perform logical op 'op' over 'int' on two cilints. Does it work 30-bits at a time as that is guaranteed to fit in an 'int'. *) -let logop op c1 c2 = +let logop op c1 c2 = match c1, c2 with | Small i1, Small i2 -> Small (op i1 i2) | _ -> let b1 = big_int_of_cilint c1 in - let b2 = big_int_of_cilint c2 in + let b2 = big_int_of_cilint c2 in let rec loop b1 b2 mul acc = if nobits b1 && nobits b2 then (* Once we only have all-0/all-1 values left, we can find whether @@ -165,7 +165,7 @@ let logop op c1 c2 = let hi1, lo1 = quomod_big_int b1 b30 in let hi2, lo2 = quomod_big_int b2 b30 in let lo = op (int_of_big_int lo1) (int_of_big_int lo2) in - loop hi1 hi2 (mult_big_int mul b30) + loop hi1 hi2 (mult_big_int mul b30) (add_big_int acc (mult_big_int mul (big_int_of_int lo))) in cilint_of_big_int (loop b1 b2 unit_big_int zero_big_int) @@ -173,15 +173,15 @@ let logand_cilint = logop (land) let logor_cilint = logop (lor) let logxor_cilint = logop (lxor) -let shift_right_cilint (c1:cilint) (n:int) : cilint = +let shift_right_cilint (c1:cilint) (n:int) : cilint = match c1 with | Small i -> Small (i asr n) | Big b -> cilint_of_big_int (div_big_int b (power_int_positive_int 2 n)) -let shift_left_cilint (c1:cilint) (n:int) : cilint = +let shift_left_cilint (c1:cilint) (n:int) : cilint = cilint_of_big_int (mult_big_int (big_int_of_cilint c1) (power_int_positive_int 2 n)) -let lognot_cilint (c1:cilint) : cilint = +let lognot_cilint (c1:cilint) : cilint = match c1 with | Small i -> Small (lnot i) | Big b -> Big (pred_big_int (minus_big_int b)) @@ -189,11 +189,11 @@ let lognot_cilint (c1:cilint) : cilint = let truncate_signed_cilint (c:cilint) (n:int) : cilint * truncation = match c with | Small i when n >= Nativeint.size - 1 -> Small i, NoTruncation - | Small i when n < Nativeint.size - 2 -> + | Small i when n < Nativeint.size - 2 -> let max = 1 lsl (n - 1) in let truncmax = 1 lsl n in let bits = i land (truncmax - 1) in - let tval = + let tval = (* check if the n-th bit is 1... *) if bits < max then bits @@ -201,7 +201,7 @@ let truncate_signed_cilint (c:cilint) (n:int) : cilint * truncation = (* and fill with 1 bits on the left if it is *) bits - truncmax in - let trunc = + let trunc = if i >= max || i < -max then if i >= truncmax then BitTruncation @@ -215,15 +215,15 @@ let truncate_signed_cilint (c:cilint) (n:int) : cilint * truncation = let max = power_int_positive_int 2 (n - 1) in let truncmax = power_int_positive_int 2 n in let bits = mod_big_int b truncmax in - let tval = + let tval = if lt_big_int bits max then bits else sub_big_int bits truncmax in - let trunc = + let trunc = if ge_big_int b max || lt_big_int b (minus_big_int max) then - if ge_big_int b truncmax then + if ge_big_int b truncmax then BitTruncation else ValueTruncation @@ -238,7 +238,7 @@ let truncate_unsigned_cilint (c:cilint) (n:int) : cilint * truncation = let max = 1 lsl (n - 1) in let truncmax = 1 lsl n in let bits = i land (truncmax - 1) in - let trunc = + let trunc = if i >= truncmax || i < 0 then if i < -max then BitTruncation @@ -252,7 +252,7 @@ let truncate_unsigned_cilint (c:cilint) (n:int) : cilint * truncation = let max = power_int_positive_int 2 (n - 1) in let truncmax = power_int_positive_int 2 n in let bits = mod_big_int b truncmax in - let trunc = + let trunc = if ge_big_int b truncmax || lt_big_int b zero_big_int then if lt_big_int b (minus_big_int max) then BitTruncation @@ -261,8 +261,8 @@ let truncate_unsigned_cilint (c:cilint) (n:int) : cilint * truncation = else NoTruncation in cilint_of_big_int bits, trunc - -let is_int_cilint (c:cilint) : bool = + +let is_int_cilint (c:cilint) : bool = match c with | Small _ -> true | Big b -> is_int_big_int b diff --git a/src/cilint.mli b/src/cilint.mli index f6d6983e4..1f5b02662 100644 --- a/src/cilint.mli +++ b/src/cilint.mli @@ -3,7 +3,7 @@ (** The cilint type is public and not just big_int to make life with ocamldebug easier. Please do not rely on this representation, use the ..._of_cilint functions to get at a cilint's value. *) -type cilint = Small of int | Big of Big_int.big_int +type cilint = Small of int | Big of Big_int_Z.big_int (** 0 as a cilint *) val zero_cilint : cilint @@ -85,7 +85,7 @@ val int_of_cilint : cilint -> int val int64_of_cilint : cilint -> int64 (** Return the cilint's value as a big_int *) -val big_int_of_cilint : cilint -> Big_int.big_int +val big_int_of_cilint : cilint -> Big_int_Z.big_int (** Return the cilint's value as a string *) val string_of_cilint : cilint -> string @@ -97,7 +97,7 @@ val cilint_of_int : int -> cilint val cilint_of_int64 : int64 -> cilint (** Make a cilint from a big_int *) -val cilint_of_big_int : Big_int.big_int -> cilint +val cilint_of_big_int : Big_int_Z.big_int -> cilint (** Make a cilint from a string *) val cilint_of_string : string -> cilint diff --git a/src/cillower.ml b/src/cillower.ml index 61745bf40..a37a1b334 100644 --- a/src/cillower.ml +++ b/src/cillower.ml @@ -6,7 +6,7 @@ * 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: @@ -38,16 +38,15 @@ (** A number of lowering passes over CIL *) open Cil -open Pretty module E = Errormsg (** Lower CEnum constants *) class lowerEnumVisitorClass : cilVisitor = object (self) - inherit nopCilVisitor + inherit nopCilVisitor - method vexpr (e: exp) = + method! vexpr (e: exp) = match e with - Const (CEnum(v, s, ei)) -> + Const (CEnum(v, s, ei)) -> ChangeTo (visitCilExpr (self :>cilVisitor) v) | _ -> DoChildren diff --git a/src/ext/zrapp/ciltools.ml b/src/ciltools.ml similarity index 77% rename from src/ext/zrapp/ciltools.ml rename to src/ciltools.ml index a4ff66ee8..4b8ba1fb7 100644 --- a/src/ext/zrapp/ciltools.ml +++ b/src/ciltools.ml @@ -3,7 +3,7 @@ open Cilint (* Contributed by Nathan Cooprider *) -let isOne e = +let isOne e = match getInteger e with | Some n -> compare_cilint n one_cilint = 0 | _ -> false @@ -11,37 +11,37 @@ let isOne e = (* written by Zach *) let is_volatile_tp tp = - List.exists (function (Attr("volatile",_)) -> true - | _ -> false) (typeAttrs tp) - + List.exists (function (Attr("volatile",_)) -> true + | _ -> false) (typeAttrs tp) + (* written by Zach *) let is_volatile_vi vi = let vi_vol = - List.exists (function (Attr("volatile",_)) -> true + List.exists (function (Attr("volatile",_)) -> true | _ -> false) vi.vattr in let typ_vol = is_volatile_tp vi.vtype in vi_vol || typ_vol (***************************************************************************** - * A collection of useful functions that were not already in CIL as far as I - * could tell. However, I have been surprised before . . . + * A collection of useful functions that were not already in CIL as far as I + * could tell. However, I have been surprised before . . . ****************************************************************************) -type sign = Signed | Unsigned +type sign = Signed | Unsigned exception Not_an_integer (***************************************************************************** - * A bunch of functions for accessing integers. Originally written for - * somebody who didn't know CIL and just wanted to mess with it at the - * OCaml level. + * A bunch of functions for accessing integers. Originally written for + * somebody who didn't know CIL and just wanted to mess with it at the + * OCaml level. ****************************************************************************) let unbox_int_type (ye : typ) : (int * sign) = let tp = unrollType ye in - let s = - match tp with - TInt (i, _) -> + let s = + match tp with + TInt (i, _) -> if (isSigned i) then Signed else @@ -49,20 +49,20 @@ let unbox_int_type (ye : typ) : (int * sign) = | _ -> raise Not_an_integer in (bitsSizeOf tp), s - + exception Weird_bitwidth (* (int64 * int * sign) : exp *) let ocaml_int_to_cil v n s = - let char_size = bitsSizeOf charType in + let char_size = bitsSizeOf charType in let int_size = bitsSizeOf intType in - let short_size = bitsSizeOf (TInt(IShort,[]))in + let short_size = bitsSizeOf (TInt(IShort,[]))in let long_size = bitsSizeOf longType in let longlong_size = bitsSizeOf (TInt(ILongLong,[])) in - let i = + let i = match s with Signed -> - if (n = char_size) then + if (n = char_size) then ISChar else if (n = int_size) then IInt @@ -75,7 +75,7 @@ let ocaml_int_to_cil v n s = else raise Weird_bitwidth | Unsigned -> - if (n = char_size) then + if (n = char_size) then IUChar else if (n = int_size) then IUInt @@ -104,23 +104,23 @@ let rec isCompositeType tp = | _ -> false (** START OF deepHasAttribute ************************************************) -let visited = ref [] +let visited = ref [] class attribute_checker target rflag = object (self) inherit nopCilVisitor - method vtype t = - match t with + method! vtype t = + match t with TComp(cinfo, a) -> if(not (List.exists (fun x -> cinfo.cname = x) !visited )) then begin visited := cinfo.cname :: !visited; - List.iter - (fun f -> - if (hasAttribute target f.fattr) then + List.iter + (fun f -> + if (hasAttribute target f.fattr) then rflag := true else - ignore(visitCilType (new attribute_checker target rflag) + ignore(visitCilType (new attribute_checker target rflag) f.ftype)) cinfo.cfields; end; - DoChildren + DoChildren | TNamed(t1, a) -> if(not (List.exists (fun x -> t1.tname = x) !visited )) then begin visited := t1.tname :: !visited; @@ -129,7 +129,7 @@ class attribute_checker target rflag = object (self) DoChildren | _ -> DoChildren - method vattr (Attr(name,params)) = + method! vattr (Attr(name,params)) = if (name = target) then rflag := true; DoChildren end @@ -144,17 +144,17 @@ let deepHasAttribute s t = (** Stuff from ptranal, slightly modified ************************************) (***************************************************************************** - * A transformation to make every instruction be in its own statement. + * A transformation to make every instruction be in its own statement. ****************************************************************************) class callBBVisitor = object - inherit nopCilVisitor + inherit nopCilVisitor - method vstmt s = + method! vstmt s = match s.skind with Instr(il) -> begin - if (List.length il > 1) then - let list_of_stmts = Util.list_map (fun one_inst -> + if (List.length il > 1) then + let list_of_stmts = Util.list_map (fun one_inst -> mkStmtOneInstr one_inst) il in let block = mkBlock list_of_stmts in s.skind <- Block block; @@ -164,51 +164,50 @@ class callBBVisitor = object end | _ -> DoChildren - method vvdec _ = SkipChildren - method vexpr _ = SkipChildren - method vlval _ = SkipChildren - method vtype _ = SkipChildren -end + method! vvdec _ = SkipChildren + method! vexpr _ = SkipChildren + method! vlval _ = SkipChildren + method! vtype _ = SkipChildren +end let one_instruction_per_statement f = let thisVisitor = new callBBVisitor in - visitCilFileSameGlobals thisVisitor f + visitCilFileSameGlobals thisVisitor f (***************************************************************************** - * A transformation that gives each variable a unique identifier. + * A transformation that gives each variable a unique identifier. ****************************************************************************) class vidVisitor = object - inherit nopCilVisitor - val count = ref 0 + inherit nopCilVisitor + val count = ref 0 - method vvdec vi = + method! vvdec vi = vi.vid <- !count ; incr count ; SkipChildren -end +end let globally_unique_vids f = let thisVisitor = new vidVisitor in - visitCilFileSameGlobals thisVisitor f + visitCilFileSameGlobals thisVisitor f (** End of stuff from ptranal ************************************************) class sidVisitor = object - inherit nopCilVisitor - val count = ref 0 + inherit nopCilVisitor + val count = ref 0 - method vstmt s = + method! vstmt s = s.sid <- !count ; incr count ; DoChildren -end +end let globally_unique_sids f = let thisVisitor = new sidVisitor in - visitCilFileSameGlobals thisVisitor f + visitCilFileSameGlobals thisVisitor f (** Comparing expressions without a Out_of_memory error **********************) let compare_exp x y = compare x y - diff --git a/src/dataflow.ml b/src/dataflow.ml index 17973bb47..ece88a8ff 100644 --- a/src/dataflow.ml +++ b/src/dataflow.ml @@ -5,33 +5,33 @@ module E = Errormsg open Cil open Pretty -(** A framework for data flow analysis for CIL code. Before using +(** 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 = +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 + | Post of ('t -> 't) (** The default action, followed by the given * transformer *) -type 't stmtaction = +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 + 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 *) +type 't guardaction = + GDefault (** The default state *) | GUse of 't (** Use this data for the branch *) | GUnreachable (** The branch will never be taken. *) (****************************************************************** ********** - ********** FORWARDS + ********** FORWARDS ********** ********************************************************************) @@ -40,7 +40,7 @@ module type ForwardsTransfer = sig val debug: bool ref (** Whether to turn on debugging *) - type t (** The type of the data we compute for each block start. May be + type t (** The type of the data we compute for each block start. May be * imperative. *) val copy: t -> t @@ -48,103 +48,103 @@ module type ForwardsTransfer = sig val stmtStartData: t Inthash.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 + (** 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. *) - val pretty: unit -> t -> Pretty.doc + val pretty: unit -> t -> Pretty.doc (** Pretty-print the state *) val computeFirstPredecessor: Cil.stmt -> t -> t - (** Give the first value for a predecessors, compute the value to be set + (** Give the first value for a predecessors, compute the value to be set * for the block *) val combinePredecessors: Cil.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 + (** Take some old data for the start of a statement, and some new data for + * the same point. Return None if the combination is identical to the old * data. Otherwise, compute the combination, and return it. *) val doInstr: Cil.instr -> t -> t action - (** The (forwards) transfer function for an instruction. The - * {!Cil.currentLoc} is set before calling this. The default action is to + (** 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. *) val doStmt: Cil.stmt -> t -> t stmtaction - (** The (forwards) transfer function for a statement. The {!Cil.currentLoc} + (** The (forwards) transfer function for a statement. The {!Cil.currentLoc} * is set before calling this. The default action is to do the instructions * in this statement, if applicable, and continue with the successors. *) val doGuard: Cil.exp -> t -> t guardaction (** Generate the successor to an If statement assuming the given expression - * is nonzero. Analyses that don't need guard information can return + * is nonzero. Analyses that don't need guard information can return * 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 - * twice per If, once for "then" and once for "else". + * twice per If, once for "then" and once for "else". *) val filterStmt: Cil.stmt -> bool - (** Whether to put this statement in the worklist. This is called when a + (** Whether to put this statement in the worklist. This is called when a * block would normally be put in the worklist. *) - + end -module ForwardsDataFlow = +module ForwardsDataFlow = functor (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 + (** 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: Cil.stmt Queue.t = Queue.create () - (** We call this function when we have encountered a statement, with some + (** We call this function when we have encountered a statement, with some * state. *) - let reachedStatement (s: stmt) (d: T.t) : unit = + let reachedStatement (s: stmt) (d: T.t) : unit = let loc = get_stmtLoc s.skind in - if loc != locUnknown then + if loc != locUnknown then currentLoc := get_stmtLoc s.skind; - (** see if we know about it already *) - E.pushContext (fun _ -> dprintf "Reached statement %d with %a" + (* see if we know about it already *) + E.pushContext (fun _ -> dprintf "Reached statement %d with %a" s.sid T.pretty d); - let newdata: T.t option = + let newdata: T.t option = try - let old = IH.find T.stmtStartData s.sid in - match T.combinePredecessors s ~old:old d with + let old = IH.find T.stmtStartData s.sid in + match T.combinePredecessors s ~old:old d with None -> (* We are done here *) - if !T.debug then + if !T.debug then ignore (E.log "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 - ignore (E.log "FF(%s): weaken data for block %d: %a\n" + (* We have changed the data *) + if !T.debug then + ignore (E.log "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 - ignore (E.log "FF(%s): set data for block %d: %a\n" + let d' = T.computeFirstPredecessor s d in + if !T.debug then + ignore (E.log "FF(%s): set data for block %d: %a\n" T.name s.sid T.pretty d'); Some d' in E.popContext (); - match newdata with + match newdata with None -> () - | Some d' -> + | Some d' -> IH.replace T.stmtStartData s.sid d'; - if T.filterStmt s && + if T.filterStmt s && not (Queue.fold (fun exists s' -> exists || s'.sid = s.sid) false - worklist) then + worklist) then Queue.add s worklist (** Get the two successors of an If statement *) - let ifSuccs (s:stmt) : stmt * stmt = + let ifSuccs (s:stmt) : stmt * stmt = let fstStmt blk = match blk.bstmts with [] -> Cil.dummyStmt | fst::_ -> fst @@ -153,9 +153,9 @@ module ForwardsDataFlow = If(e, b1, b2, _) -> let thenSucc = fstStmt b1 in let elseSucc = fstStmt b2 in - let oneFallthrough () = - let fallthrough = - List.filter + let oneFallthrough () = + let fallthrough = + List.filter (fun s' -> thenSucc != s' && elseSucc != s') s.succs in @@ -169,29 +169,29 @@ module ForwardsDataFlow = let stmtOrFallthrough s' = if s' == Cil.dummyStmt then oneFallthrough () - else + else s' in (stmtOrFallthrough thenSucc, stmtOrFallthrough elseSucc) - + | _-> E.s (bug "ifSuccs on a non-If Statement.") (** Process a statement *) - let processStmt (s: stmt) : unit = + let processStmt (s: stmt) : unit = currentLoc := get_stmtLoc s.skind; - if !T.debug then + if !T.debug then ignore (E.log "FF(%s).stmt %d at %t\n" T.name s.sid d_thisloc); (* It must be the case that the block has some data *) - let init: T.t = - try T.copy (IH.find T.stmtStartData s.sid) - with Not_found -> + let init: T.t = + try T.copy (IH.find T.stmtStartData s.sid) + with Not_found -> E.s (E.bug "FF(%s): processing block without data" T.name) in - (** See what the custom says *) - match T.doStmt s init with + (* See what the custom says *) + match T.doStmt s init with SDone -> () | (SDefault | SUse _) as act -> begin let curr = match act with @@ -200,13 +200,13 @@ module ForwardsDataFlow = | SDone -> E.s (bug "SDone") in (* Do the instructions in order *) - let handleInstruction (s: T.t) (i: instr) : T.t = + let handleInstruction (s: T.t) (i: instr) : T.t = currentLoc := get_instrLoc i; - + (* Now handle the instruction itself *) - let s' = - let action = T.doInstr i s in - match action with + let s' = + let action = T.doInstr i s in + match action with | Done s' -> s' | Default -> s (* do nothing *) | Post f -> f s @@ -214,18 +214,18 @@ module ForwardsDataFlow = s' in - let after: T.t = - match s.skind with - Instr il -> + let after: T.t = + match s.skind with + Instr il -> (* Handle instructions starting with the first one *) List.fold_left handleInstruction curr il - | Goto _ | ComputedGoto _ | Break _ | Continue _ | If _ - | TryExcept _ | TryFinally _ + | Goto _ | ComputedGoto _ | Break _ | Continue _ | If _ + | TryExcept _ | TryFinally _ | Switch _ | Loop _ | Return _ | Block _ -> curr in currentLoc := get_stmtLoc s.skind; - + (* Handle If guards *) let succsToReach = match s.skind with If (e, _, _, _) -> begin @@ -240,9 +240,9 @@ module ForwardsDataFlow = match guard with GDefault -> reachedStatement succ after | GUse d -> reachedStatement succ d - | GUnreachable -> - if !T.debug then - ignore (E.log "FF(%s): Not exploring branch to %d\n" + | GUnreachable -> + if !T.debug then + ignore (E.log "FF(%s): Not exploring branch to %d\n" T.name succ.sid); () @@ -264,33 +264,33 @@ module ForwardsDataFlow = (** Compute the data flow. Must have the CFG initialized *) - let compute (sources: stmt list) = + 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 (IH.mem T.stmtStartData s.sid) then + (* All initial stmts must have non-bottom data *) + List.iter (fun s -> + if not (IH.mem T.stmtStartData s.sid) then E.s (E.error "FF(%s): initial stmt %d does not have data" T.name s.sid)) sources; if !T.debug then ignore (E.log "\nFF(%s): processing\n" - T.name); - let rec fixedpoint () = - if !T.debug && not (Queue.is_empty worklist) then - ignore (E.log "FF(%s): worklist= %a\n" + T.name); + let rec fixedpoint () = + if !T.debug && not (Queue.is_empty worklist) then + ignore (E.log "FF(%s): worklist= %a\n" T.name - (docList (fun s -> num s.sid)) + (docList (fun s -> num s.sid)) (List.rev (Queue.fold (fun acc s -> s :: acc) [] worklist))); - let keepgoing = - try - let s = Queue.take worklist in + let keepgoing = + try + let s = Queue.take worklist in processStmt s; true - with Queue.Empty -> - if !T.debug then + with Queue.Empty -> + if !T.debug then ignore (E.log "FF(%s): done\n\n" T.name); false in @@ -298,14 +298,14 @@ module ForwardsDataFlow = fixedpoint () in fixedpoint () - + end (****************************************************************** ********** - ********** BACKWARDS + ********** BACKWARDS ********** ********************************************************************) module type BackwardsTransfer = sig @@ -313,28 +313,28 @@ module type BackwardsTransfer = sig 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 + 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: unit -> t -> Pretty.doc (** Pretty-print the state *) val stmtStartData: t Inthash.t - (** For each block id, the data at the start. This data structure must be + (** For each block id, the data at the start. This data structure must be * initialized with the initial data for each block *) 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 + This is usually bottom, since we'll also use doStmt on Return statements. *) val combineStmtStartData: Cil.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 + (** 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. *) @@ -343,68 +343,68 @@ module type BackwardsTransfer = sig val doStmt: Cil.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 + (** 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: Cil.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 + (** 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: Cil.stmt -> Cil.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 + (** 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) *) - + end -module BackwardsDataFlow = - functor (T : BackwardsTransfer) -> +module BackwardsDataFlow = + functor (T : BackwardsTransfer) -> struct - let getStmtStartData (s: stmt) : T.t = + let getStmtStartData (s: stmt) : T.t = try IH.find T.stmtStartData s.sid - with Not_found -> + with Not_found -> E.s (E.bug "BF(%s): stmtStartData is not initialized for %d: %a" T.name s.sid d_stmt s) - (** Process a statement and return true if the set of live return + (** 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 + let processStmt (s: stmt) : bool = + if !T.debug then ignore (E.log "FF(%s).stmt %d\n" T.name s.sid); (* Find the state before the branch *) currentLoc := get_stmtLoc s.skind; - let d: T.t = - match T.doStmt s with + let d: T.t = + match T.doStmt s with Done d -> d | (Default | Post _) as action -> begin (* Do the default one. Combine the successors *) - let res = - match s.succs with + let res = + match s.succs with [] -> T.funcExitData - | fst :: rest -> - List.fold_left (fun acc succ -> + | fst :: rest -> + List.fold_left (fun acc succ -> T.combineSuccessors acc (getStmtStartData succ)) (getStmtStartData fst) rest in (* Now do the instructions *) - let res' = - match s.skind with - Instr il -> - (* Now scan the instructions in reverse order. This may + let res' = + match s.skind with + Instr il -> + (* Now scan the instructions in reverse order. This may * Stack_overflow on very long blocks ! *) - let handleInstruction (i: instr) (s: T.t) : T.t = + let handleInstruction (i: instr) (s: T.t) : T.t = currentLoc := get_instrLoc i; (* First handle the instruction itself *) - let action = T.doInstr i s in - match action with + let action = T.doInstr i s in + match action with | Done s' -> s' | Default -> s (* do nothing *) | Post f -> f s @@ -414,61 +414,61 @@ module BackwardsDataFlow = | _ -> res in - match action with + 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 + let s0 = getStmtStartData s in - match T.combineStmtStartData s ~old:s0 d with + 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 - ignore (E.log "BF(%s): set data for block %d: %a\n" + | Some d' -> + (* We have changed the data *) + if !T.debug then + ignore (E.log "BF(%s): set data for block %d: %a\n" T.name s.sid T.pretty d'); IH.replace T.stmtStartData s.sid d'; true (** Compute the data flow. Must have the CFG initialized *) - let compute (sinks: stmt list) = + let compute (sinks: stmt list) = let worklist: Cil.stmt Queue.t = Queue.create () in List.iter (fun s -> Queue.add s worklist) sinks; if !T.debug && not (Queue.is_empty worklist) then - ignore (E.log "\nBF(%s): processing\n" - T.name); - let rec fixedpoint () = - if !T.debug && not (Queue.is_empty worklist) then - ignore (E.log "BF(%s): worklist= %a\n" + ignore (E.log "\nBF(%s): processing\n" + T.name); + let rec fixedpoint () = + if !T.debug && not (Queue.is_empty worklist) then + ignore (E.log "BF(%s): worklist= %a\n" T.name - (docList (fun s -> num s.sid)) + (docList (fun s -> num s.sid)) (List.rev (Queue.fold (fun acc s -> s :: acc) [] worklist))); - let keepgoing = - try - let s = Queue.take worklist in - let changes = processStmt s in + let keepgoing = + try + let s = Queue.take worklist in + let changes = processStmt s in if changes then begin - (* We must add all predecessors of block b, only if not already + (* We must add all predecessors of block b, only if not already * in and if the filter accepts them. *) - List.iter + List.iter (fun p -> - if not (Queue.fold (fun exists s' -> exists || p.sid = s'.sid) + if not (Queue.fold (fun exists s' -> exists || p.sid = s'.sid) false worklist) && - T.filterStmt p s then + T.filterStmt p s then Queue.add p worklist) s.preds; end; true - with Queue.Empty -> - if !T.debug then + with Queue.Empty -> + if !T.debug then ignore (E.log "BF(%s): done\n\n" T.name); false in @@ -476,11 +476,11 @@ module BackwardsDataFlow = fixedpoint (); in fixedpoint (); - + end -(** Helper utility that finds all of the statements of a function. +(** Helper utility that finds all of the statements of a function. It also lists the return statments (including statements that fall through the end of a void function). Useful when you need an initial set of statements for BackwardsDataFlow.compute. *) @@ -489,7 +489,7 @@ let all_stmts = ref [] let sinkFinder = object(self) inherit nopCilVisitor - method vstmt s = + method! vstmt s = all_stmts := s ::(!all_stmts); match s.succs with [] -> (sink_stmts := s :: (!sink_stmts); @@ -506,4 +506,3 @@ let find_stmts (fdec:fundec) : (stmt list * stmt list) = all_stmts := []; sink_stmts := []; all, ret - diff --git a/src/dominators.ml b/src/dominators.ml index d3c394605..a258f5606 100644 --- a/src/dominators.ml +++ b/src/dominators.ml @@ -1,11 +1,11 @@ (* * - * Copyright (c) 2001-2002, + * 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: @@ -39,7 +39,7 @@ open Cil open Pretty module E = Errormsg -module H = Hashtbl +module H = Hashtbl module U = Util module IH = Inthash @@ -48,9 +48,9 @@ module DF = Dataflow let debug = false (* For each statement we maintain a set of statements that dominate it *) -module BS = Set.Make(struct +module BS = Set.Make(struct type t = Cil.stmt - let compare v1 v2 = Pervasives.compare v1.sid v2.sid + let compare v1 v2 = Stdlib.compare v1.sid v2.sid end) @@ -60,29 +60,29 @@ module BS = Set.Make(struct module DT = struct let name = "dom" - let debug = ref debug + let debug = ref debug type t = BS.t - (** For each statement in a function we keep the set of dominator blocks. + (** For each statement in a function we keep the set of dominator blocks. * Indexed by statement id *) let stmtStartData: t IH.t = IH.create 17 let copy (d: t) = d - let pretty () (d: t) = - dprintf "{%a}" + let pretty () (d: t) = + dprintf "{%a}" (docList (fun s -> dprintf "%d" s.sid)) (BS.elements d) - let computeFirstPredecessor (s: stmt) (d: BS.t) : BS.t = + let computeFirstPredecessor (s: stmt) (d: BS.t) : BS.t = (* Make sure we add this block to the set *) BS.add s d - let combinePredecessors (s: stmt) ~(old: BS.t) (d: BS.t) : BS.t option = + let combinePredecessors (s: stmt) ~(old: BS.t) (d: BS.t) : BS.t option = (* First, add this block to the data from the predecessor *) let d' = BS.add s d in - if BS.subset old d' then + if BS.subset old d' then None else Some (BS.inter old d') @@ -90,7 +90,7 @@ module DT = struct let doInstr (i: instr) (d: t) = DF.Default let doStmt (s: stmt) (d: t) = DF.SDefault - + let doGuard condition _ = DF.GDefault @@ -101,30 +101,30 @@ end module Dom = DF.ForwardsDataFlow(DT) -let getStmtDominators (data: BS.t IH.t) (s: stmt) : BS.t = +let getStmtDominators (data: BS.t IH.t) (s: stmt) : BS.t = try IH.find data s.sid with Not_found -> BS.empty (* Not reachable *) - -let getIdom (idomInfo: stmt option IH.t) (s: stmt) = + +let getIdom (idomInfo: stmt option IH.t) (s: stmt) = try IH.find idomInfo s.sid - with Not_found -> - E.s (E.bug "Immediate dominator information not set for statement %d" + with Not_found -> + E.s (E.bug "Immediate dominator information not set for statement %d" s.sid) -(** Check whether one block dominates another. This assumes that the "idom" +(** Check whether one block dominates another. This assumes that the "idom" * field has been computed. *) -let rec dominates (idomInfo: stmt option IH.t) (s1: stmt) (s2: stmt) = - s1 == s2 || +let rec dominates (idomInfo: stmt option IH.t) (s1: stmt) (s2: stmt) = + s1 == s2 || (let s2idom = getIdom idomInfo s2 in - match s2idom with + match s2idom with None -> false | Some s2idom -> dominates idomInfo s1 s2idom) - -let computeIDom ?(doCFG:bool=true) (f: fundec) : stmt option IH.t = + +let computeIDom ?(doCFG:bool=true) (f: fundec) : stmt option IH.t = (* We must prepare the CFG info first *) if doCFG then begin prepareCFG f; @@ -133,54 +133,54 @@ let computeIDom ?(doCFG:bool=true) (f: fundec) : stmt option IH.t = IH.clear DT.stmtStartData; let idomData: stmt option IH.t = IH.create 13 in - let _ = - match f.sbody.bstmts with + let _ = + match f.sbody.bstmts with [] -> () (* function has no body *) | start :: _ -> begin (* We start with only the start block *) IH.add DT.stmtStartData start.sid (BS.singleton start); - + Dom.compute [start]; - + (* Dump the dominators information *) - if debug then + if debug then List.iter - (fun s -> + (fun s -> let sdoms = getStmtDominators DT.stmtStartData s in if not (BS.mem s sdoms) then begin (* It can be that the block is not reachable *) - if s.preds <> [] then + if s.preds <> [] then E.s (E.bug "Statement %d is not in its list of dominators" s.sid); end; ignore (E.log "Dominators for %d: %a\n" s.sid DT.pretty (BS.remove s sdoms))) f.sallstmts; - + (* Now fill the immediate dominators for all nodes *) - let rec fillOneIdom (s: stmt) = - try + let rec fillOneIdom (s: stmt) = + try ignore (IH.find idomData s.sid) (* Already set *) with Not_found -> begin (* Get the dominators *) - let sdoms = getStmtDominators DT.stmtStartData s in + let sdoms = getStmtDominators DT.stmtStartData s in (* Fill the idom for the dominators first *) - let idom = - BS.fold - (fun d (sofar: stmt option) -> - if d.sid = s.sid then + let idom = + BS.fold + (fun d (sofar: stmt option) -> + if d.sid = s.sid then sofar (* Ignore the block itself *) else begin (* fill the idom information recursively *) fillOneIdom d; - match sofar with + match sofar with None -> Some d | Some sofar' -> - (* See if d is dominated by sofar. We know that the - * idom information has been computed for both sofar + (* See if d is dominated by sofar. We know that the + * idom information has been computed for both sofar * and for d*) - if dominates idomData sofar' d then + if dominates idomData sofar' d then Some d else sofar @@ -199,10 +199,10 @@ let computeIDom ?(doCFG:bool=true) (f: fundec) : stmt option IH.t = type tree = stmt option * BS.t IH.t -(* returns the IDoms and a map from statement ids to +(* returns the IDoms and a map from statement ids to the set of statements that are dominated *) -let computeDomTree ?(doCFG:bool=true) (f: fundec) - : stmt option IH.t * tree = +let computeDomTree ?(doCFG:bool=true) (f: fundec) + : stmt option IH.t * tree = (* We must prepare the CFG info first *) if doCFG then begin prepareCFG f; @@ -212,54 +212,54 @@ let computeDomTree ?(doCFG:bool=true) (f: fundec) let treeData: BS.t IH.t = IH.create 64 in let idomData: stmt option IH.t = IH.create 64 in - let _ = - match f.sbody.bstmts with + let _ = + match f.sbody.bstmts with [] -> () (* function has no body *) | start :: _ -> begin (* We start with only the start block *) IH.add DT.stmtStartData start.sid (BS.singleton start); - + Dom.compute [start]; - + (* Dump the dominators information *) - if debug then + if debug then List.iter - (fun s -> + (fun s -> let sdoms = getStmtDominators DT.stmtStartData s in if not (BS.mem s sdoms) then begin (* It can be that the block is not reachable *) - if s.preds <> [] then + if s.preds <> [] then E.s (E.bug "Statement %d is not in its list of dominators" s.sid); end; ignore (E.log "Dominators for %d: %a\n" s.sid DT.pretty (BS.remove s sdoms))) f.sallstmts; - + (* Now fill the immediate dominators for all nodes *) - let rec fillOneIdom (s: stmt) = - try + let rec fillOneIdom (s: stmt) = + try ignore (IH.find idomData s.sid) (* Already set *) with Not_found -> begin (* Get the dominators *) - let sdoms = getStmtDominators DT.stmtStartData s in + let sdoms = getStmtDominators DT.stmtStartData s in (* Fill the idom for the dominators first *) - let idom = - BS.fold - (fun d (sofar: stmt option) -> - if d.sid = s.sid then + let idom = + BS.fold + (fun d (sofar: stmt option) -> + if d.sid = s.sid then sofar (* Ignore the block itself *) else begin (* fill the idom information recursively *) fillOneIdom d; - match sofar with + match sofar with None -> Some d | Some sofar' -> - (* See if d is dominated by sofar. We know that the - * idom information has been computed for both sofar + (* See if d is dominated by sofar. We know that the + * idom information has been computed for both sofar * and for d*) - if dominates idomData sofar' d then + if dominates idomData sofar' d then Some d else sofar @@ -274,7 +274,7 @@ let computeDomTree ?(doCFG:bool=true) (f: fundec) match IH.tryfind treeData d.sid with | None -> IH.add treeData d.sid (BS.singleton s) | Some bs -> IH.replace treeData d.sid (BS.add s bs) - end + end end in (* Scan all blocks and compute the idom *) @@ -282,13 +282,13 @@ let computeDomTree ?(doCFG:bool=true) (f: fundec) end in try idomData, (Some(List.hd f.sbody.bstmts), treeData) - with Failure "hd" -> idomData, (None, treeData) + with Failure _ -> idomData, (None, treeData) type order = PreOrder | PostOrder -let rec domTreeIter (f: stmt -> unit) - (o : order) - (t: tree) +let rec domTreeIter (f: stmt -> unit) + (o : order) + (t: tree) : unit = let doChildren s = @@ -317,24 +317,24 @@ let children (t: tree) (s: stmt) : stmt list = | None -> [] | Some bs -> BS.elements bs -(** Compute the start of the natural loops. For each start, keep a list of - * origin of a back edge. The loop consists of the loop start and all - * predecessors of the origins of back edges, up to and including the loop +(** Compute the start of the natural loops. For each start, keep a list of + * origin of a back edge. The loop consists of the loop start and all + * predecessors of the origins of back edges, up to and including the loop * start *) -let findNaturalLoops (f: fundec) - (idomData: stmt option IH.t) : (stmt * stmt list) list = - let loops = +let findNaturalLoops (f: fundec) + (idomData: stmt option IH.t) : (stmt * stmt list) list = + let loops = List.fold_left - (fun acc b -> - (* Iterate over all successors, and see if they are among the + (fun acc b -> + (* Iterate over all successors, and see if they are among the * dominators for this block *) List.fold_left - (fun acc s -> - if dominates idomData s b then + (fun acc s -> + if dominates idomData s b then (* s is the start of a natural loop *) let rec addNaturalLoop = function [] -> [(s, [b])] - | (s', backs) :: rest when s'.sid = s.sid -> + | (s', backs) :: rest when s'.sid = s.sid -> (s', b :: backs) :: rest | l :: rest -> l :: addNaturalLoop rest in @@ -344,17 +344,17 @@ let findNaturalLoops (f: fundec) acc b.succs) [] - f.sallstmts + f.sallstmts in - - if debug then + + if debug then ignore (E.log "Natural loops:\n%a\n" (docList ~sep:line - (fun (s, backs) -> + (fun (s, backs) -> dprintf " Start: %d, backs:%a" s.sid (docList (fun b -> num b.sid)) backs)) loops); - + loops diff --git a/src/dune b/src/dune new file mode 100644 index 000000000..a774d6928 --- /dev/null +++ b/src/dune @@ -0,0 +1,51 @@ +(include_subdirs unqualified) + +(library + (public_name goblint-cil) + (name cil) + (wrapped false) ; this should be changed, but then module paths in goblint need to be prefixed + (libraries zarith findlib dynlink unix str stdlib-shims batteries.unthreaded) + (modules (:standard \ main)) +) + +(rule + (targets machdep.ml cilversion.ml) + (deps ../configure.ac ../Makefile.in ../install-sh ../config.sub ../config.guess ../config.h.in ../stamp-h.in cil.mli machdep-ml.c.in cilversion.ml.in) + (action (chdir .. (progn (run ./configure) (run make machdep) (run cp _build/machdep.ml src)))) +) + +(rule + (deps (package goblint-cil) ../src/main.exe (source_tree ../lib/perl5/App/Cilly) (source_tree ../test) ../bin/cilly ../configure.ac ../Makefile.in ../install-sh ../config.sub ../config.guess ../lib/perl5/App/Cilly.pm.in ../lib/perl5/Makefile.PL ../config.h.in ../stamp-h.in cil.mli machdep-ml.c.in cilversion.ml.in ../config.mk.in) + (action (chdir .. (progn + (run ./configure) + (run make machdep) + (run make lib/perl5/App/Cilly.pm) + (chdir lib/perl5 (progn + (run perl Makefile.PL) + (run make) + )) + (run cp src/main.exe bin/cilly.native) + (bash "mkdir -p share/cil && echo $(cd ../install/default/lib; pwd) > share/cil/ocamlpath") + (chdir test (progn + (run ./testcil -r --regrtest) + )) + ))) + (alias runtest) +) + +(ocamllex formatlex) +(ocamlyacc formatparse) + +(executable + (public_name main) + (modes exe) + (modules main) + (libraries goblint-cil) + (link_flags (-linkall)) +) + +(env + (dev + (flags (:standard -warn-error -A -w -27-32-34-37-38)) ; https://dune.readthedocs.io/en/stable/faq.html#how-to-make-warnings-non-fatal + ) +) diff --git a/src/expcompare.ml b/src/expcompare.ml index 4b6ac5094..79c8f8e82 100644 --- a/src/expcompare.ml +++ b/src/expcompare.ml @@ -1,10 +1,10 @@ (* * - * Copyright (c) 2004, + * Copyright (c) 2004, * Jeremy Condit * George C. Necula * All rights reserved. - * + * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: @@ -36,8 +36,6 @@ open Cil open Cilint -open Cilint -open Pretty module E = Errormsg @@ -91,7 +89,7 @@ and compareLval (lv1: lval) (lv2: lval) : bool = * expression. * * We remove casts from pointer types to unsigned int or unsigned long. - * + * * We also prune casts between equivalent integer types, such as a * difference in sign or int vs long. But we keep other arithmetic casts, * since they actually change the value of the expression. *) @@ -103,8 +101,8 @@ let rec stripNopCasts (e:exp): exp = when isConstType bt1 = isConstType bt2 -> stripNopCasts e' (* strip casts from pointers to unsigned int/long*) - | (TPtr _ as t1), (TInt(ik,_) as t2) - when bitsSizeOf t1 = bitsSizeOf t2 + | (TPtr _ as t1), (TInt(ik,_) as t2) + when bitsSizeOf t1 = bitsSizeOf t2 && not (isSigned ik) -> stripNopCasts e' | (TInt(ik1,_) as t1), (TInt(ik2,_) as t2) @@ -142,17 +140,17 @@ let rec stripCastsForPtrArith (e:exp): exp = if bitsSizeOf bt1 = bitsSizeOf bt2 && isConstType bt1 = isConstType bt2 then stripCastsForPtrArith e' - else + else e with SizeOfError _ -> (* bt1 or bt2 is abstract; don't strip. *) e end (* strip casts from pointers to unsigned int/long*) - | (TPtr _ as t1), (TInt(ik,_) as t2) - when bitsSizeOf t1 = bitsSizeOf t2 + | (TPtr _ as t1), (TInt(ik,_) as t2) + when bitsSizeOf t1 = bitsSizeOf t2 && not (isSigned ik) -> stripCastsForPtrArith e' - | (TInt(ik1,_) as t1), (TInt(ik2,_) as t2) + | (TInt(ik1,_) as t1), (TInt(ik2,_) as t2) (*when bitsSizeOf t1 = bitsSizeOf t2 ->*) (* Okay to strip.*) when bitsSizeOf t1 = bitsSizeOf t2 || (isSigned ik1 = isSigned ik2 && @@ -192,7 +190,7 @@ let compareTypesNoAttributes ?(ignoreSign=true) (t1 : typ) (t2 : typ) : bool = class volatileFinderClass br = object(self) inherit nopCilVisitor - method vtype (t : typ) = + method! vtype (t : typ) = if hasAttribute "volatile" (typeAttrs t) then begin br := true; SkipChildren @@ -225,20 +223,20 @@ let rec stripCastsDeepForPtrArith (e:exp): exp = if bitsSizeOf bt1 = bitsSizeOf bt2 && isConstType bt1 = isConstType bt2 then e' - else + else CastE(t,e') with SizeOfError _ -> (* bt1 or bt2 is abstract; don't strip. *) CastE(t,e') end | _, _ -> CastE(t,e') end - | UnOp(op,e,t) -> + | UnOp(op,e,t) -> let e = stripCastsDeepForPtrArith e in UnOp(op, e, t) | BinOp(MinusPP,e1,e2,t) -> let e1 = stripCastsDeepForPtrArith e1 in let e2 = stripCastsDeepForPtrArith e2 in - if not(compareTypesNoAttributes ~ignoreSign:false + if not(compareTypesNoAttributes ~ignoreSign:false (typeOf e1) (typeOf e2)) then BinOp(MinusPP, mkCast ~e:e1 ~newt:(typeOf e2), e2, t) else BinOp(MinusPP, e1, e2, t) @@ -298,4 +296,3 @@ let rec compareAttrParam (ap1 : attrparam) (ap2 : attrparam) : bool = compareAttrParam ap11 ap21 && compareAttrParam ap12 ap22 && compareAttrParam ap13 ap23 | _, _ -> false - diff --git a/src/ext/blockinggraph/META b/src/ext/blockinggraph/META deleted file mode 100644 index 82644c3ac..000000000 --- a/src/ext/blockinggraph/META +++ /dev/null @@ -1 +0,0 @@ -description = "computing and printing a static call graph" diff --git a/src/ext/blockinggraph/blockinggraph.ml b/src/ext/blockinggraph/blockinggraph.ml deleted file mode 100644 index 402e72b4f..000000000 --- a/src/ext/blockinggraph/blockinggraph.ml +++ /dev/null @@ -1,770 +0,0 @@ -(* - * - * 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. - * - *) -open Cil -open Feature -open Pretty -module E = Errormsg - -let debug = false - -let fingerprintAll = true - - -type blockkind = - NoBlock - | BlockTrans - | BlockPoint - | EndPoint - -(* For each function we have a node *) -type node = -{ - nodeid: int; - name: string; - mutable scanned: bool; - mutable expand: bool; - mutable fptr: bool; - mutable stacksize: int; - mutable fds: fundec option; - mutable bkind: blockkind; - mutable origkind: blockkind; - mutable preds: node list; - mutable succs: node list; - mutable predstmts: (stmt * node) list; -} - -type blockpt = -{ - id: int; - point: stmt; - callfun: string; - infun: string; - mutable leadsto: blockpt list; -} - - -(* Fresh ids for each node. *) -let curNodeNum : int ref = ref 0 -let getFreshNodeNum () : int = - let num = !curNodeNum in - incr curNodeNum; - num - -(* Initialize a node. *) -let newNode (name: string) (fptr: bool) (mangle: bool) : node = - let id = getFreshNodeNum () in - { nodeid = id; name = if mangle then name ^ (string_of_int id) else name; - scanned = false; expand = false; - fptr = fptr; stacksize = 0; fds = None; - bkind = NoBlock; origkind = NoBlock; - preds = []; succs = []; predstmts = []; } - - -(* My type signature ignores attributes and function pointers. *) -let myTypeSig (t: typ) : typsig = - let rec removeFunPtrs (ts: typsig) : typsig = - match ts with - TSPtr (TSFun _, a) -> - TSPtr (TSBase voidType, a) - | TSPtr (base, a) -> - TSPtr (removeFunPtrs base, a) - | TSArray (base, e, a) -> - TSArray (removeFunPtrs base, e, a) - | TSFun (ret, args, v, a) -> - TSFun (removeFunPtrs ret, (Util.list_map_opt removeFunPtrs args), v, a) - | _ -> ts - in - removeFunPtrs (typeSigWithAttrs (fun _ -> []) t) - - -(* We add a dummy function whose name is "@@functionPointer@@" that is called - * at all invocations of function pointers and itself calls all functions - * whose address is taken. *) -let functionPointerName = "@@functionPointer@@" - -(* We map names to nodes *) -let functionNodes: (string, node) Hashtbl.t = Hashtbl.create 113 -let getFunctionNode (n: string) : node = - Util.memoize - functionNodes - n - (fun _ -> newNode n false false) - -(* We map types to nodes for function pointers *) -let functionPtrNodes: (typsig, node) Hashtbl.t = Hashtbl.create 113 -let getFunctionPtrNode (t: typ) : node = - Util.memoize - functionPtrNodes - (myTypeSig t) - (fun _ -> newNode functionPointerName true true) - -let startNode: node = newNode "@@startNode@@" true false - - -(* -(** Dump the function call graph. *) -let dumpFunctionCallGraph (start: node) = - Hashtbl.iter (fun _ x -> x.scanned <- false) functionNodes; - let rec dumpOneNode (ind: int) (n: node) : unit = - output_string !E.logChannel "\n"; - for i = 0 to ind do - output_string !E.logChannel " " - done; - output_string !E.logChannel (n.name ^ " "); - begin - match n.bkind with - NoBlock -> () - | BlockTrans -> output_string !E.logChannel " " - | BlockPoint -> output_string !E.logChannel " " - | EndPoint -> output_string !E.logChannel " " - end; - if n.scanned then (* Already dumped *) - output_string !E.logChannel " " - else begin - n.scanned <- true; - List.iter (fun n -> if n.bkind <> EndPoint then dumpOneNode (ind + 1) n) - n.succs - end - in - dumpOneNode 0 start; - output_string !E.logChannel "\n\n" -*) - -let dumpFunctionCallGraphToFile () = - let channel = open_out "graph" in - let dumpNode _ (n: node) : unit = - let first = ref true in - let dumpSucc (n: node) : unit = - if !first then - first := false - else - output_string channel ","; - output_string channel n.name - in - output_string channel (string_of_int n.nodeid); - output_string channel ":"; - output_string channel (string_of_int n.stacksize); - output_string channel ":"; - if n.fds = None && not n.fptr then - output_string channel "x"; - output_string channel ":"; - output_string channel n.name; - output_string channel ":"; - List.iter dumpSucc n.succs; - output_string channel "\n"; - in - dumpNode () startNode; - Hashtbl.iter dumpNode functionNodes; - Hashtbl.iter dumpNode functionPtrNodes; - close_out channel - - -let addCall (callerNode: node) (calleeNode: node) (sopt: stmt option) = - if not (List.exists (fun n -> n.name = calleeNode.name) - callerNode.succs) then begin - if debug then - ignore (E.log "found call from %s to %s\n" - callerNode.name calleeNode.name); - callerNode.succs <- calleeNode :: callerNode.succs; - calleeNode.preds <- callerNode :: calleeNode.preds; - end; - match sopt with - Some s -> - if not (List.exists (fun (s', _) -> s' = s) calleeNode.predstmts) then - calleeNode.predstmts <- (s, callerNode) :: calleeNode.predstmts - | None -> () - - -class findCallsVisitor (host: node) : cilVisitor = object - inherit nopCilVisitor - - val mutable curStmt : stmt ref = ref (mkEmptyStmt ()) - - method vstmt s = - curStmt := s; - DoChildren - - method vinst i = - match i with - | Call(_,Lval(Var(vi),NoOffset),args,l) -> - addCall host (getFunctionNode vi.vname) (Some !curStmt); - SkipChildren - - | Call(_,e,_,l) -> (* Calling a function pointer *) - addCall host (getFunctionPtrNode (typeOf e)) (Some !curStmt); - SkipChildren - - | _ -> SkipChildren (* No calls in other instructions *) - - (* There are no calls in expressions and types *) - method vexpr e = SkipChildren - method vtype t = SkipChildren - -end - - -let endPt = { id = 0; point = mkEmptyStmt (); callfun = "end"; infun = "end"; - leadsto = []; } - -(* These values will be initialized for real in makeBlockingGraph. *) -let curId : int ref = ref 1 -let startName : string ref = ref "" -let blockingPoints : blockpt list ref = ref [] -let blockingPointsNew : blockpt Queue.t = Queue.create () -let blockingPointsHash : (int, blockpt) Hashtbl.t = Hashtbl.create 113 - -let getFreshNum () : int = - let num = !curId in - curId := !curId + 1; - num - -let getBlockPt (s: stmt) (cfun: string) (ifun: string) : blockpt = - try - Hashtbl.find blockingPointsHash s.sid - with Not_found -> - let num = getFreshNum () in - let bpt = { id = num; point = s; callfun = cfun; infun = ifun; - leadsto = []; } in - Hashtbl.add blockingPointsHash s.sid bpt; - blockingPoints := bpt :: !blockingPoints; - Queue.add bpt blockingPointsNew; - bpt - - -type action = - Process of stmt * node - | Next of stmt * node - | Return of node - -let getStmtNode (s: stmt) : node option = - match s.skind with - Instr instrs -> begin - let len = List.length instrs in - if len > 0 then - match List.nth instrs (len - 1) with - Call (_, Lval (Var vi, NoOffset), args, _) -> - Some (getFunctionNode vi.vname) - | Call (_, e, _, _) -> (* Calling a function pointer *) - Some (getFunctionPtrNode (typeOf e)) - | _ -> - None - else - None - end - | _ -> None - -let addBlockingPointEdge (bptFrom: blockpt) (bptTo: blockpt) : unit = - if not (List.exists (fun bpt -> bpt = bptTo) bptFrom.leadsto) then - bptFrom.leadsto <- bptTo :: bptFrom.leadsto - -let findBlockingPointEdges (bpt: blockpt) : unit = - let seenStmts = Hashtbl.create 117 in - let worklist = Queue.create () in - Queue.add (Next (bpt.point, getFunctionNode bpt.infun)) worklist; - while Queue.length worklist > 0 do - let act = Queue.take worklist in - match act with - Process (curStmt, curNode) -> begin - Hashtbl.add seenStmts curStmt.sid (); - match getStmtNode curStmt with - Some node -> begin - if debug then - ignore (E.log "processing node %s\n" node.name); - match node.bkind with - NoBlock -> - Queue.add (Next (curStmt, curNode)) worklist - | BlockTrans -> begin - let processFundec (fd: fundec) : unit = - let s = List.hd fd.sbody.bstmts in - if not (Hashtbl.mem seenStmts s.sid) then - let n = getFunctionNode fd.svar.vname in - Queue.add (Process (s, n)) worklist - in - match node.fds with - Some fd -> - processFundec fd - | None -> - List.iter - (fun n -> - match n.fds with - Some fd -> processFundec fd - | None -> E.s (bug "expected fundec")) - node.succs - end - | BlockPoint -> - addBlockingPointEdge bpt - (getBlockPt curStmt node.name curNode.name) - | EndPoint -> - addBlockingPointEdge bpt endPt - end - | _ -> - Queue.add (Next (curStmt, curNode)) worklist - end - | Next (curStmt, curNode) -> begin - match curStmt.Cil.succs with - [] -> - if debug then - ignore (E.log "hit end of %s\n" curNode.name); - Queue.add (Return curNode) worklist - | _ -> - List.iter (fun s -> - if not (Hashtbl.mem seenStmts s.sid) then - Queue.add (Process (s, curNode)) worklist) - curStmt.Cil.succs - end - | Return curNode when curNode.bkind = NoBlock -> - () - | Return curNode when curNode.name = !startName -> - addBlockingPointEdge bpt endPt - | Return curNode -> - List.iter (fun (s, n) -> if n.bkind <> NoBlock then - Queue.add (Next (s, n)) worklist) - curNode.predstmts; - List.iter (fun n -> if n.fptr then - Queue.add (Return n) worklist) - curNode.preds - done - -let markYieldPoints (n: node) : unit = - let rec markNode (n: node) : unit = - if n.bkind = NoBlock then - match n.origkind with - BlockTrans -> - if n.expand || n.fptr then begin - n.bkind <- BlockTrans; - List.iter markNode n.succs - end else begin - n.bkind <- BlockPoint - end - | _ -> - n.bkind <- n.origkind - in - Hashtbl.iter (fun _ n -> n.bkind <- NoBlock) functionNodes; - Hashtbl.iter (fun _ n -> n.bkind <- NoBlock) functionPtrNodes; - markNode n - -let makeBlockingGraph (start: node) = - let startStmt = - match start.fds with - Some fd -> List.hd fd.sbody.bstmts - | None -> E.s (bug "expected fundec") - in - curId := 1; - startName := start.name; - blockingPoints := [endPt]; - Queue.clear blockingPointsNew; - Hashtbl.clear blockingPointsHash; - ignore (getBlockPt startStmt start.name start.name); - while Queue.length blockingPointsNew > 0 do - let bpt = Queue.take blockingPointsNew in - findBlockingPointEdges bpt; - done - -let dumpBlockingGraph () = - List.iter - (fun bpt -> - if bpt.id < 2 then begin - ignore (E.log "bpt %d (%s): " bpt.id bpt.callfun) - end else begin - ignore (E.log "bpt %d (%s in %s): " bpt.id bpt.callfun bpt.infun) - end; - List.iter (fun bpt -> ignore (E.log "%d " bpt.id)) bpt.leadsto; - ignore (E.log "\n")) - !blockingPoints; - ignore (E.log "\n") - -let beforeFun = - makeGlobalVar "before_bg_node" - (TFun (voidType, Some [("node_idx", intType, []); - ("num_edges", intType, [])], - false, [])) - -let initFun = - makeGlobalVar "init_blocking_graph" - (TFun (voidType, Some [("num_nodes", intType, [])], - false, [])) - -let fingerprintVar = - let vi = makeGlobalVar "stack_fingerprint" intType in - vi.vstorage <- Extern; - vi - -let startNodeAddrs = - let vi = makeGlobalVar "start_node_addrs" (TPtr (voidPtrType, [])) in - vi.vstorage <- Extern; - vi - -let startNodeStacks = - let vi = makeGlobalVar "start_node_stacks" (TPtr (intType, [])) in - vi.vstorage <- Extern; - vi - -let startNodeAddrsArray = - makeGlobalVar "start_node_addrs_array" (TArray (voidPtrType, None, [])) - -let startNodeStacksArray = - makeGlobalVar "start_node_stacks_array" (TArray (intType, None, [])) - -let insertInstr (newInstr: instr) (s: stmt) : unit = - match s.skind with - Instr instrs -> - let rec insert (instrs: instr list) : instr list = - match instrs with - [] -> E.s (bug "instr list does not end with call\n") - | [Call _] -> newInstr :: instrs - | i :: rest -> i :: (insert rest) - in - s.skind <- Instr (insert instrs) - | _ -> - E.s (bug "instr stmt expected\n") - -let instrumentBlockingPoints () = - List.iter - (fun bpt -> - if bpt.id > 1 then - let arg1 = integer bpt.id in - let arg2 = integer (List.length bpt.leadsto) in - let call = Call (None, Lval (var beforeFun), - [arg1; arg2], locUnknown) in - insertInstr call bpt.point; - addCall (getFunctionNode bpt.infun) - (getFunctionNode beforeFun.vname) None) - !blockingPoints - - -let startNodes : node list ref = ref [] - -let makeAndDumpBlockingGraphs () : unit = - if List.length !startNodes > 1 then - E.s (unimp "We can't handle more than one start node right now.\n"); - List.iter - (fun n -> - markYieldPoints n; - (*dumpFunctionCallGraph n;*) - makeBlockingGraph n; - dumpBlockingGraph (); - instrumentBlockingPoints ()) - !startNodes - - -let pragmas : (string, int) Hashtbl.t = Hashtbl.create 13 - -let gatherPragmas (f: file) : unit = - List.iter - (function - GPragma (Attr ("stacksize", [AStr s; AInt n]), _) -> - Hashtbl.add pragmas s n - | _ -> ()) - f.globals - - -let blockingNodes : node list ref = ref [] - -let markBlockingFunctions () : unit = - let rec markFunction (n: node) : unit = - if debug then - ignore (E.log "marking %s\n" n.name); - if n.origkind = NoBlock then begin - n.origkind <- BlockTrans; - List.iter markFunction n.preds; - end - in - List.iter (fun n -> List.iter markFunction n.preds) !blockingNodes - -let hasFunctionTypeAttribute (n: string) (t: typ) : bool = - let _, _, _, a = splitFunctionType t in - hasAttribute n a - -let markVar (vi: varinfo) : unit = - let node = getFunctionNode vi.vname in - if node.origkind = NoBlock then begin - if hasAttribute "yield" vi.vattr then begin - node.origkind <- BlockPoint; - blockingNodes := node :: !blockingNodes; - end else if hasFunctionTypeAttribute "noreturn" vi.vtype then begin - node.origkind <- EndPoint; - end else if hasAttribute "expand" vi.vattr then begin - node.expand <- true; - end - end; - begin - try - node.stacksize <- Hashtbl.find pragmas node.name - with Not_found -> begin - match filterAttributes "stacksize" vi.vattr with - (Attr (_, [AInt n])) :: _ when n > node.stacksize -> - node.stacksize <- n - | _ -> () - end - end - -let makeFunctionCallGraph (f: Cil.file) : unit = - Hashtbl.clear functionNodes; - (* Scan the file and construct the control-flow graph *) - List.iter - (function - GFun(fdec, _) -> - let curNode = getFunctionNode fdec.svar.vname in - if fdec.svar.vaddrof then begin - addCall (getFunctionPtrNode fdec.svar.vtype) - curNode None; - end; - if hasAttribute "start" fdec.svar.vattr then begin - startNodes := curNode :: !startNodes; - end; - markVar fdec.svar; - curNode.fds <- Some fdec; - let vis = new findCallsVisitor curNode in - ignore (visitCilBlock vis fdec.sbody) - - | GVarDecl(vi, _) when isFunctionType vi.vtype -> - (* TODO: what if we take the addr of an extern? *) - markVar vi - - | _ -> ()) - f.globals - -let makeStartNodeLinks () : unit = - addCall startNode (getFunctionNode "main") None; - List.iter (fun n -> addCall startNode n None) !startNodes - -let funType (ret_t: typ) (args: (string * typ) list) = - TFun(ret_t, - Some (Util.list_map (fun (n,t) -> (n, t, [])) args), - false, []) - -class instrumentClass = object - inherit nopCilVisitor - - val mutable curNode : node ref = ref (getFunctionNode "main") - val mutable seenRet : bool ref = ref false - - val mutable funId : int ref = ref 0 - - method vfunc (fdec: fundec) : fundec visitAction = begin - (* Remember the current function. *) - curNode := getFunctionNode fdec.svar.vname; - seenRet := false; - funId := Random.bits (); - (* Add useful locals. *) - ignore (makeLocalVar fdec "savesp" voidPtrType); - ignore (makeLocalVar fdec "savechunk" voidPtrType); - ignore (makeLocalVar fdec "savebottom" voidPtrType); - (* Add macro for function entry when we're done. *) - let addEntryNode (fdec: fundec) : fundec = - if not !seenRet then E.s (bug "didn't find a return statement"); - let node = getFunctionNode fdec.svar.vname in - if fingerprintAll || node.origkind <> NoBlock then begin - let fingerprintSet = - Set (var fingerprintVar, BinOp (BXor, Lval (var fingerprintVar), - integer !funId, intType), - locUnknown) - in - fdec.sbody.bstmts <- mkStmtOneInstr fingerprintSet :: fdec.sbody.bstmts - end; - let nodeFun = emptyFunction ("NODE_CALL_"^(string_of_int node.nodeid)) in - let nodeCall = Call (None, Lval (var nodeFun.svar), [], locUnknown) in - nodeFun.svar.vtype <- funType voidType []; - nodeFun.svar.vstorage <- Static; - fdec.sbody.bstmts <- mkStmtOneInstr nodeCall :: fdec.sbody.bstmts; - fdec - in - ChangeDoChildrenPost (fdec, addEntryNode) - end - - method vstmt (s: stmt) : stmt visitAction = begin - begin - match s.skind with - Instr instrs -> begin - let instrumentNode (callNode: node) : unit = - (* Make calls to macros. *) - let suffix = "_" ^ (string_of_int !curNode.nodeid) ^ - "_" ^ (string_of_int callNode.nodeid) - in - let beforeFun = emptyFunction ("BEFORE_CALL" ^ suffix) in - let beforeCall = Call (None, Lval (var beforeFun.svar), - [], locUnknown) in - beforeFun.svar.vtype <- funType voidType []; - beforeFun.svar.vstorage <- Static; - let afterFun = emptyFunction ("AFTER_CALL" ^ suffix) in - let afterCall = Call (None, Lval (var afterFun.svar), - [], locUnknown) in - afterFun.svar.vtype <- funType voidType []; - afterFun.svar.vstorage <- Static; - (* Insert instrumentation around call site. *) - let rec addCalls (is: instr list) : instr list = - match is with - [call] -> [beforeCall; call; afterCall] - | cur :: rest -> cur :: addCalls rest - | [] -> E.s (bug "expected list of non-zero length") - in - s.skind <- Instr (addCalls instrs) - in - (* If there's a call site here, instrument it. *) - let len = List.length instrs in - if len > 0 then begin - match List.nth instrs (len - 1) with - Call (_, Lval (Var vi, NoOffset), _, _) -> - (* - if (try String.sub vi.vname 0 10 <> "NODE_CALL_" - with Invalid_argument _ -> true) then -*) - instrumentNode (getFunctionNode vi.vname) - | Call (_, e, _, _) -> (* Calling a function pointer *) - instrumentNode (getFunctionPtrNode (typeOf e)) - | _ -> () - end; - DoChildren - end - | Cil.Return _ -> begin - if !seenRet then E.s (bug "found multiple returns"); - seenRet := true; - if fingerprintAll || !curNode.origkind <> NoBlock then begin - let fingerprintSet = - Set (var fingerprintVar, BinOp (BXor, Lval (var fingerprintVar), - integer !funId, intType), - locUnknown) - in - s.skind <- Block (mkBlock [mkStmtOneInstr fingerprintSet; - mkStmt s.skind]); - end; - SkipChildren - end - | _ -> DoChildren - end - end -end - -let makeStartNodeTable (globs: global list) : global list = - if List.length !startNodes = 0 then - globs - else - let addrInitInfo = { init = None } in - let stackInitInfo = { init = None } in - let rec processNode (nodes: node list) (i: int) = - match nodes with - node :: rest -> - let curGlobs, addrInit, stackInit = processNode rest (i + 1) in - let fd = - match node.fds with - Some fd -> fd - | None -> E.s (bug "expected fundec") - in - let stack = - makeGlobalVar ("NODE_STACK_" ^ (string_of_int node.nodeid)) intType - in - GVarDecl (fd.svar, locUnknown) :: curGlobs, - ((Index (integer i, NoOffset), SingleInit (mkAddrOf (var fd.svar))) :: - addrInit), - ((Index (integer i, NoOffset), SingleInit (Lval (var stack))) :: - stackInit) - | [] -> (GVarDecl (startNodeAddrs, locUnknown) :: - GVarDecl (startNodeStacks, locUnknown) :: - GVar (startNodeAddrsArray, addrInitInfo, locUnknown) :: - GVar (startNodeStacksArray, stackInitInfo, locUnknown) :: - []), - [Index (integer i, NoOffset), SingleInit zero], - [Index (integer i, NoOffset), SingleInit zero] - in - let newGlobs, addrInit, stackInit = processNode !startNodes 0 in - addrInitInfo.init <- - Some (CompoundInit (TArray (voidPtrType, None, []), addrInit)); - stackInitInfo.init <- - Some (CompoundInit (TArray (intType, None, []), stackInit)); - let file = { fileName = "startnode.h"; globals = newGlobs; - globinit = None; globinitcalled = false; } in - let channel = open_out file.fileName in - dumpFile defaultCilPrinter channel file.fileName file; - close_out channel; - GText ("#include \"" ^ file.fileName ^ "\"") :: globs - -let instrumentProgram (f: file) : unit = - (* Add function prototypes. *) - f.globals <- makeStartNodeTable f.globals; - f.globals <- GText ("#include \"stack.h\"") :: - GVarDecl (initFun, locUnknown) :: - GVarDecl (beforeFun, locUnknown) :: - GVarDecl (fingerprintVar, locUnknown) :: - f.globals; - (* Add instrumentation to call sites. *) - visitCilFile ((new instrumentClass) :> cilVisitor) f; - (* Force creation of this node. *) - ignore (getFunctionNode beforeFun.vname); - (* Add initialization call to main(). *) - let mainNode = getFunctionNode "main" in - match mainNode.fds with - Some fdec -> - let arg1 = integer (List.length !blockingPoints) in - let initInstr = Call (None, Lval (var initFun), [arg1], locUnknown) in - let addrsInstr = - Set (var startNodeAddrs, StartOf (var startNodeAddrsArray), - locUnknown) - in - let stacksInstr = - Set (var startNodeStacks, StartOf (var startNodeStacksArray), - locUnknown) - in - let newStmt = - if List.length !startNodes = 0 then - mkStmtOneInstr initInstr - else - mkStmt (Instr [addrsInstr; stacksInstr; initInstr]) - in - fdec.sbody.bstmts <- newStmt :: fdec.sbody.bstmts; - addCall mainNode (getFunctionNode initFun.vname) None - | None -> - E.s (bug "expected main fundec") - - - -let feature = - { fd_name = "FCG"; - fd_enabled = false; - fd_description = "computing and printing a static call graph"; - fd_extraopt = []; - fd_doit = - (function (f : file) -> - Random.init 0; (* Use the same seed so that results are predictable. *) - gatherPragmas f; - makeFunctionCallGraph f; - makeStartNodeLinks (); - markBlockingFunctions (); - (* makeAndDumpBlockingGraphs (); *) - instrumentProgram f; - dumpFunctionCallGraphToFile ()); - fd_post_check = true; - } diff --git a/src/ext/blockinggraph/blockinggraph.mli b/src/ext/blockinggraph/blockinggraph.mli deleted file mode 100644 index 694d7eb11..000000000 --- a/src/ext/blockinggraph/blockinggraph.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* - * - * 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. - * - *) - -(* This module finds and analyzes yield points. *) - -val feature: Feature.t diff --git a/src/ext/callgraph/META b/src/ext/callgraph/META deleted file mode 100644 index 7fc040009..000000000 --- a/src/ext/callgraph/META +++ /dev/null @@ -1 +0,0 @@ -description = "generation of a static call graph" diff --git a/src/ext/callgraph/callgraph.ml b/src/ext/callgraph/callgraph.ml deleted file mode 100644 index 7a4c45376..000000000 --- a/src/ext/callgraph/callgraph.ml +++ /dev/null @@ -1,250 +0,0 @@ -(* callgraph.ml *) -(* code for callgraph.mli *) - -(* see copyright notice at end of this file *) - -open Cil -open Feature -open Trace -open Printf -module P = Pretty -module IH = Inthash -module H = Hashtbl -module E = Errormsg - -(* ------------------- interface ------------------- *) -(* a call node describes the local calling structure for a - * single function: which functions it calls, and which - * functions call it *) -type callnode = { - (* An id *) - cnid: int; - - (* the function this node describes *) - cnInfo: nodeinfo; - - (* set of functions this one calls, indexed by the node id *) - cnCallees: callnode IH.t; - - (* set of functions that call this one , indexed by the node id *) - cnCallers: callnode IH.t; -} - -and nodeinfo = - NIVar of varinfo * bool ref - (* Node corresponding to a function. If the boolean - * is true, then the function is defined, otherwise - * it is external *) - - | NIIndirect of string (* Indirect nodes have a string associated to them. - * These strings must be invalid function names *) - * varinfo list ref - (* A list of functions that this indirect node might - * denote *) - -let nodeName (n: nodeinfo) : string = - match n with - NIVar (v, _) -> v.vname - | NIIndirect (n, _) -> n - -(* a call graph is a hashtable, mapping a function name to - * the node which describes that function's call structure *) -type callgraph = - (string, callnode) Hashtbl.t - -(* given the name of a function, retrieve its callnode; this will create a - * node if one doesn't already exist. Will use the given nodeinfo only when - * creating nodes. *) -let nodeId = ref 0 -let getNodeByName (cg: callgraph) (ni: nodeinfo) : callnode = - let name = nodeName ni in - try - H.find cg name - with Not_found -> ( - (* make a new node *) - let ret:callnode = { - cnInfo = ni; - cnid = !nodeId; - cnCallees = IH.create 5; - cnCallers = IH.create 5; - } - in - incr nodeId; - (* add it to the table, then return it *) - H.add cg name ret; - ret - ) - -(* Get the node for a variable *) -let getNodeForVar (cg: callgraph) (v: varinfo) : callnode = - getNodeByName cg (NIVar (v, ref false)) - -let getNodeForIndirect (cg: callgraph) (e: exp) : callnode = - getNodeByName cg (NIIndirect ("", ref [])) - - -(* Find the name of an indirect node that a function whose address is taken - * belongs *) -let markFunctionAddrTaken (cg: callgraph) (f: varinfo) : unit = - (* - ignore (E.log "markFunctionAddrTaken %s\n" f.vname); - *) - let n = getNodeForIndirect cg (AddrOf (Var f, NoOffset)) in - match n.cnInfo with - NIIndirect (_, r) -> r := f :: !r - | _ -> assert false - - - -class cgComputer (graph: callgraph) = object(self) - inherit nopCilVisitor - - (* the current function we're in, so when we visit a call node - * we know who is the caller *) - val mutable curFunc: callnode option = None - - - (* begin visiting a function definition *) - method vfunc (f:fundec) : fundec visitAction = begin - (trace "callgraph" (P.dprintf "entering function %s\n" f.svar.vname)); - let node = getNodeForVar graph f.svar in - (match node.cnInfo with - NIVar (v, r) -> r := true - | _ -> assert false); - curFunc <- (Some node); - DoChildren - end - - (* visit an instruction; we're only interested in calls *) - method vinst (i:instr) : instr list visitAction = begin - (*(trace "callgraph" (P.dprintf "visiting instruction: %a\n" dn_instr i));*) - let caller : callnode = - match curFunc with - None -> assert false - | Some c -> c - in - let callerName: string = nodeName caller.cnInfo in - (match i with - Call(_,f,_,_) -> ( - let callee: callnode = - match f with - | Lval(Var(vi),NoOffset) -> - (trace "callgraph" (P.dprintf "I see a call by %s to %s\n" - callerName vi.vname)); - getNodeForVar graph vi - - | _ -> - (trace "callgraph" (P.dprintf "indirect call: %a\n" - dn_instr i)); - getNodeForIndirect graph f - in - - (* add one entry to each node's appropriate list *) - IH.replace caller.cnCallees callee.cnid callee; - IH.replace callee.cnCallers caller.cnid caller - ) - - | _ -> ()); (* ignore other kinds instructions *) - - DoChildren - end - - method vexpr (e: exp) = - (match e with - AddrOf (Var fv, NoOffset) when isFunctionType fv.vtype -> - markFunctionAddrTaken graph fv - | _ -> ()); - - DoChildren -end - -let computeGraph (f:file) : callgraph = begin - let graph = H.create 37 in - let obj:cgComputer = new cgComputer graph in - - (* visit the whole file, computing the graph *) - visitCilFileSameGlobals (obj :> cilVisitor) f; - - - (* return the computed graph *) - graph -end - -let printGraph (out:out_channel) (g:callgraph) : unit = begin - let printEntry _ (n:callnode) : unit = - let name = nodeName n.cnInfo in - (Printf.fprintf out " %s" name) - in - - let printCalls (node:callnode) : unit = - (fprintf out " calls:"); - (IH.iter printEntry node.cnCallees); - (fprintf out "\n is called by:"); - (IH.iter printEntry node.cnCallers); - (fprintf out "\n") - in - - H.iter (fun (name: string) (node: callnode) -> - match node.cnInfo with - NIVar (v, def) -> - (fprintf out "%s (%s):\n" - v.vname (if !def then "defined" else "external")); - printCalls node - - | NIIndirect (n, funcs) -> - fprintf out "Indirect %s:\n" n; - fprintf out " possible aliases: "; - List.iter (fun a -> fprintf out "%s " a.vname) !funcs; - fprintf out "\n" - - ) - - g - end - -let feature = - { fd_name = "callgraph"; - fd_enabled = false; - fd_description = "generation of a static call graph"; - fd_extraopt = []; - fd_doit = - (function (f: file) -> - let graph:callgraph = computeGraph f in - printGraph stdout graph); - fd_post_check = false; - } - -let () = Feature.register feature - -(* - * - * Copyright (c) 2001-2002 by - * George C. Necula necula@cs.berkeley.edu - * Scott McPeak smcpeak@cs.berkeley.edu - * Wes Weimer weimer@cs.berkeley.edu - * Ben Liblit liblit@cs.berkeley.edu - * - * All rights reserved. Permission to use, copy, modify and distribute - * this software for research purposes only is hereby granted, - * provided that the following conditions are met: - * 1. XSRedistributions 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 name of the authors may not be used to endorse or promote products - * derived from this software without specific prior written permission. - * - * DISCLAIMER: - * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. - * - *) diff --git a/src/ext/callgraph/callgraph.mli b/src/ext/callgraph/callgraph.mli deleted file mode 100644 index 2c416e554..000000000 --- a/src/ext/callgraph/callgraph.mli +++ /dev/null @@ -1,123 +0,0 @@ -(* - * - * 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. - * - *) -(* callgraph.mli *) -(* compute a static call graph *) - -(* module maintainer: scott *) -(* see copyright notice at end of this file *) - - -(* ------------------ types ------------------- *) -(* a call node describes the local calling structure for a - * single function: which functions it calls, and which - * functions call it *) -type callnode = { - (* An id *) - cnid: int; - - (* the function this node describes *) - cnInfo: nodeinfo; - - (* set of functions this one calls, indexed by the node id *) - cnCallees: callnode Inthash.t; - - (* set of functions that call this one , indexed by the node id *) - cnCallers: callnode Inthash.t; -} - -and nodeinfo = - NIVar of Cil.varinfo * bool ref - (* Node corresponding to a function. If the boolean - * is true, then the function is defined, otherwise - * it is external *) - - | NIIndirect of string (* Indirect nodes have a string associated to them. - * These strings must be invalid function names *) - * Cil.varinfo list ref - (* A list of functions that this indirect node might - * denote *) - - -val nodeName: nodeinfo -> string - -(* a call graph is a hashtable, mapping a function name to - * the node which describes that function's call structure *) -type callgraph = - (string, callnode) Hashtbl.t - - -(* ----------------- functions ------------------- *) -(* given a CIL file, compute its static call graph *) -val computeGraph : Cil.file -> callgraph - -(* print the callgraph in a human-readable format to a channel *) -val printGraph : out_channel -> callgraph -> unit - - -val feature: Feature.t -(* - * - * Copyright (c) 2001-2002 by - * George C. Necula necula@cs.berkeley.edu - * Scott McPeak smcpeak@cs.berkeley.edu - * Wes Weimer weimer@cs.berkeley.edu - * Ben Liblit liblit@cs.berkeley.edu - * - * All rights reserved. Permission to use, copy, modify and distribute - * this software for research purposes only is hereby granted, - * 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 name of the authors may not be used to endorse or promote products - * derived from this software without specific prior written permission. - * - * DISCLAIMER: - * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. - * - *) diff --git a/src/ext/canonicalize/META b/src/ext/canonicalize/META deleted file mode 100644 index a7516ae1b..000000000 --- a/src/ext/canonicalize/META +++ /dev/null @@ -1 +0,0 @@ -description = "fixing some C-isms so that the result is C++ compliant" diff --git a/src/ext/canonicalize/canonicalize.ml b/src/ext/canonicalize/canonicalize.ml deleted file mode 100644 index 152d99691..000000000 --- a/src/ext/canonicalize/canonicalize.ml +++ /dev/null @@ -1,295 +0,0 @@ -(* - * - * 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. - * - *) - - - -(************************************************************************ - * canonicalize performs several transformations to correct differences - * between C and C++, so that the output is (hopefully) valid C++ code. - * This is incomplete -- certain fixes which are necessary - * for some programs are not yet implemented. - * - * #1) C allows global variables to have multiple declarations and multiple - * (equivalent) definitions. This transformation removes all but one - * declaration and all but one definition. - * - * #2) Any variables that use C++ keywords as identifiers are renamed. - * - * #3) __inline is #defined to inline, and __restrict is #defined to nothing. - * - * #4) C allows function pointers with no specified arguments to be used on - * any argument list. To make C++ accept this code, we insert a cast - * from the function pointer to a type that matches the arguments. Of - * course, this does nothing to guarantee that the pointer actually has - * that type. - * - * #5) Makes casts from int to enum types explicit. (CIL changes enum - * constants to int constants, but doesn't use a cast.) - * - ************************************************************************) - -open Cil -open Feature -module E = Errormsg -module H = Hashtbl - -(* For transformation #1. Stores all variable definitions in the file. *) -let varDefinitions: (varinfo, global) H.t = H.create 111 - - -class canonicalizeVisitor = object(self) - inherit nopCilVisitor - val mutable currentFunction: fundec = Cil.dummyFunDec; - - (* A hashtable to prevent duplicate declarations. *) - val alreadyDeclared: (varinfo, unit) H.t = H.create 111 - val alreadyDefined: (varinfo, unit) H.t = H.create 111 - - (* move variable declarations around *) - method vglob g = match g with - GVar(v, ({init = Some _} as inito), l) -> - (* A definition. May have been moved to an earlier position. *) - if H.mem alreadyDefined v then begin - ignore (E.warn "Duplicate definition of %s at %a." - v.vname d_loc !currentLoc); - ChangeTo [] (* delete from here. *) - end else begin - H.add alreadyDefined v (); - if H.mem alreadyDeclared v then begin - (* Change the earlier declaration to Extern *) - let oldS = v.vstorage in - ignore (E.log "changing storage of %s from %a\n" - v.vname d_storage oldS); - v.vstorage <- Extern; - let newv = {v with vstorage = oldS} in - ChangeDoChildrenPost([GVar(newv, inito, l)], (fun g -> g) ) - end else - DoChildren - end - | GVar(v, {init=None}, l) - | GVarDecl(v, l) when not (isFunctionType v.vtype) -> begin - (* A declaration. May have been moved to an earlier position. *) - if H.mem alreadyDefined v || H.mem alreadyDeclared v then - ChangeTo [] (* delete from here. *) - else begin - H.add alreadyDeclared v (); - DoChildren - end - end - | GFun(f, l) -> - currentFunction <- f; - DoChildren - | _ -> - DoChildren - -(* #2. rename any identifiers whose names are C++ keywords *) - method vvdec v = - match v.vname with - | "bool" - | "catch" - | "cdecl" - | "class" - | "const_cast" - | "delete" - | "dynamic_cast" - | "explicit" - | "export" - | "false" - | "friend" - | "mutable" - | "namespace" - | "new" - | "operator" - | "pascal" - | "private" - | "protected" - | "public" - | "register" - | "reinterpret_cast" - | "static_cast" - | "template" - | "this" - | "throw" - | "true" - | "try" - | "typeid" - | "typename" - | "using" - | "virtual" - | "wchar_t"-> - v.vname <- v.vname ^ "__cil2cpp"; - DoChildren - | _ -> DoChildren - - method vinst i = -(* #5. If an assignment or function call uses expressions as enum values, - add an explicit cast. *) - match i with - Set (dest, exp, l) -> begin - let typeOfDest = typeOfLval dest in - match unrollType typeOfDest with - TEnum _ -> (* add an explicit cast *) - let newI = Set(dest, mkCast exp typeOfDest, l) in - ChangeTo [newI] - | _ -> SkipChildren - end - | Call (dest, f, args, l) -> begin - let rt, formals, isva, attrs = splitFunctionType (typeOf f) in - if isva then - SkipChildren (* ignore vararg functions *) - else - match formals with - Some formals' -> begin - let newArgs = try - (*Iterate over the arguments, looking for formals that - expect enum types, and insert casts where necessary. *) - List.map2 - (fun (actual: exp) (formalName, formalType, _) -> - match unrollType formalType with - TEnum _ -> mkCast actual formalType - | _ -> actual) - args - formals' - with Invalid_argument _ -> - E.s (error "Number of arguments to %a doesn't match type." - d_exp f) - in - let newI = Call(dest, f, newArgs, l) in - ChangeTo [newI] - end - | None -> begin - (* #4. No arguments were specified for this type. To fix this, infer the - type from the arguments that are used n this instruction, and insert - a cast to that type.*) - match f with - Lval(Mem(fp), off) -> - let counter: int ref = ref 0 in - let newFormals = Util.list_map - (fun (actual:exp) -> - incr counter; - let formalName = "a" ^ (string_of_int !counter) in - (formalName, typeOf actual, []))(* (name,type,attrs) *) - args in - let newFuncPtrType = - TPtr((TFun (rt, Some newFormals, false, attrs)), []) in - let newFuncPtr = Lval(Mem(mkCast fp newFuncPtrType), off) in - ChangeTo [Call(dest, newFuncPtr, args, l)] - | _ -> - ignore (warn "cppcanon: %a has no specified arguments, but it's not a function pointer." d_exp f); - SkipChildren - end - end - | _ -> SkipChildren - - method vinit (forg: varinfo) (off: offset) i = -(* #5. If an initializer uses expressions as enum values, - add an explicit cast. *) - match i with - SingleInit e -> DoChildren (* we don't handle simple initializers here, - because we don't know what type is expected. - This should be done in vglob if needed. *) - | CompoundInit(t, initList) -> - let changed: bool ref = ref false in - let initList' = Util.list_map - (* iterate over the list, adding casts for any expression that - is expected to be an enum type. *) - (function - (Field(fi, off), SingleInit e) -> begin - match unrollType fi.ftype with - TEnum _ -> (* add an explicit cast *) - let newE = mkCast e fi.ftype in - changed := true; - (Field(fi, off), SingleInit newE) - | _ -> (* not enum, no cast needed *) - (Field(fi, off), SingleInit e) - end - | other -> - (* This is a more complicated initializer, and I don't think - it can have type enum. It's children might, though. *) - other) - initList in - if !changed then begin - (* There may be other casts needed in other parts of the - initialization, so do the children too. *) - ChangeDoChildrenPost(CompoundInit(t, initList'), (fun x -> x)) - end else - DoChildren - - -(* #5. If a function returns an enum type, add an explicit cast to the - return type. *) - method vstmt stmt = - (match stmt.skind with - Return (Some exp, l) -> begin - let typeOfDest, _, _, _ = - splitFunctionType currentFunction.svar.vtype in - match unrollType typeOfDest with - TEnum _ -> - stmt.skind <- Return (Some (mkCast exp typeOfDest), l) - | _ -> () - end - | _ -> ()); - DoChildren -end (* class canonicalizeVisitor *) - - - -(* Entry point for this extension *) -let canonicalize (f:file) = - visitCilFile (new canonicalizeVisitor) f; - - (* #3. Finally, add some #defines to change C keywords to their C++ - equivalents: *) - f.globals <- - GText( "#ifdef __cplusplus\n" - ^" #define __restrict\n" (* "restrict" doesn't work *) - ^" #define __inline inline\n" - ^"#endif") - ::f.globals - - - -let feature = - { fd_name = "canonicalize"; - fd_enabled = false; - fd_description = "fixing some C-isms so that the result is C++ compliant."; - fd_extraopt = []; - fd_doit = canonicalize; - fd_post_check = true; - } - -let () = Feature.register feature diff --git a/src/ext/canonicalize/canonicalize.mli b/src/ext/canonicalize/canonicalize.mli deleted file mode 100644 index e89c5db92..000000000 --- a/src/ext/canonicalize/canonicalize.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* - * - * 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. - * - *) - -(************************************************************************ - * canonicalize performs several transformations to correct differences - * between C and C++, so that the output is (hopefully) valid C++ code. - * This is incomplete -- certain fixes which are necessary - * for some programs are not yet implemented. - * - * See canonicalize.ml for a list of changes. - * - ************************************************************************) - -val feature: Feature.t diff --git a/src/ext/canonicalize/default b/src/ext/canonicalize/default deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/ext/ccl/META b/src/ext/ccl/META deleted file mode 100644 index 755f2d0fb..000000000 --- a/src/ext/ccl/META +++ /dev/null @@ -1 +0,0 @@ -description = "CCured Lite" diff --git a/src/ext/ccl/ccl.ml b/src/ext/ccl/ccl.ml deleted file mode 100644 index a9bcb8b53..000000000 --- a/src/ext/ccl/ccl.ml +++ /dev/null @@ -1,1946 +0,0 @@ -(* - * - * Copyright (c) 2004, - * Jeremy Condit - * George C. Necula - * 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. - * - *) -open Cil -open Feature -open Pretty -module E = Errormsg - -let debug : bool ref = ref false -let verbose : bool ref = ref false -let suppress : bool ref = ref false - -let globals : global list ref = ref [] - -let curFunction : fundec ref = ref dummyFunDec -let curStmtId : int ref = ref 0 - -let verifiedExps : exp list ref = ref [] -let verifiedArgs : exp list ref = ref [] - -type stats = { - mutable numVisited : int; - mutable visited : (exp * location) list; - mutable failed : (exp * location) list; - mutable verified : (exp * location) list; -} - -let expStats : stats = - { numVisited = 0; visited = []; failed = []; verified = [] } - -let argStats : stats = - { numVisited = 0; visited = []; failed = []; verified = [] } - -type annot = -| AIgn -| AZero -| ANonZero -| ANonNeg -| AOne -| ANT of int -| ANTI of string * int -| ACC of int -| ACCB of string -| ACCBI of string -| AVC of string -| AVCB of string -| AVCBI of string -| AE of string -| AEI of string - -type fact = string * annot - -module OrderedFact = struct - type t = fact - let compare = compare -end -module FactSet = Set.Make(OrderedFact) - -module OrderedString = struct - type t = string - let compare = compare -end -module StringSet = Set.Make(OrderedString) - -type state = { - mutable facts : FactSet.t; - mutable openVars : StringSet.t; -} - -type summary = -| SNone -| SInt of int -| SVar of string -| SVarOff of string * string -| SVarOffConst of string * int -| SVarMult of string * int -| SDerefVar of string -| SDerefVarOff of string * string -| SDerefVarOffConst of string * int -| SDerefVarFld of string * string -| SAddrVar of string -| SFacts of FactSet.t - -let d_annot () (annot : annot) : doc = - match annot with - | AIgn -> text "AIgn" - | AZero -> text "AZero" - | ANonZero -> text "ANonZero" - | ANonNeg -> text "ANonNeg" - | AOne -> text "AOne" - | ANT n -> dprintf "ANT %d" n - | ANTI (s, n) -> dprintf "ANTI %s %d" s n - | ACC n -> dprintf "ACC %d" n - | ACCB s -> dprintf "ACCB %s" s - | ACCBI s -> dprintf "ACCBI %s" s - | AVC s -> dprintf "AVC %s" s - | AVCB s -> dprintf "AVCB %s" s - | AVCBI s -> dprintf "AVCBI %s" s - | AE s -> dprintf "AE %s" s - | AEI s -> dprintf "AEI %s" s - -let d_annots () (annots : annot list) : doc = - seq (text ", ") (d_annot ()) annots - -let d_fact () ((s, a) : fact) : doc = - dprintf "(%s %a)" s d_annot a - -let d_facts () (facts : FactSet.t) : doc = - seq (text ", ") (d_fact ()) (FactSet.elements facts) - -let d_state () (state : state) : doc = - d_facts () state.facts - -let d_summary () (sum : summary) : doc = - match sum with - | SNone -> dprintf "SNone" - | SInt i -> dprintf "SInt %d" i - | SVar s -> dprintf "SVar %s" s - | SVarOff (s1, s2) -> dprintf "SVarOff %s %s" s1 s2 - | SVarOffConst (s, i) -> dprintf "SVarOffConst %s %d" s i - | SVarMult (s, i) -> dprintf "SVarMult %s %d" s i - | SDerefVar s -> dprintf "SDerefVar %s" s - | SDerefVarOff (s1, s2) -> dprintf "SDerefVarOff %s %s" s1 s2 - | SDerefVarOffConst (s, i) -> dprintf "SDerefVarOffConst %s %d" s i - | SDerefVarFld (s1, s2) -> dprintf "SDerefVarFld %s %s" s1 s2 - | SAddrVar s -> dprintf "SAddrVar %s" s - | SFacts _ -> dprintf "SFacts" - -class cclPrinterClass = object - inherit defaultCilPrinterClass as super - - method pAttr (attr : attribute) : doc * bool = - match attr with - | Attr ("out", []) -> text "OUT", false - | Attr ("inout", []) -> text "INOUT", false - | Attr ("ignore", []) -> text "IGN", false - | Attr ("nullterm", []) -> text "NT", false - | Attr ("count", [AInt n]) -> dprintf "CT(%d)" n, false - | Attr ("count", [ACons (s, [])]) -> dprintf "CT(%s)" s, false - | Attr ("countof", [ACons (s, [])]) -> dprintf "CTOF(%s)" s, false - | Attr ("end", [ACons (s, [])]) -> dprintf "END(%s)" s, false - | _ -> super#pAttr attr -end - -let cclPrinter = new cclPrinterClass - -let dc_type () (t : typ) : doc = - let save = !print_CIL_Input in - print_CIL_Input := true; - let d = printType cclPrinter () t in - print_CIL_Input := save; - d - -let d_stats () (s : stats) : doc = - let numVisited = s.numVisited in - if numVisited > 0 then begin - let numVerified = List.length s.verified in - let percent = numVerified * 100 / numVisited in - dprintf "%d / %d (%d%%)" numVerified numVisited percent - end else - dprintf "0 / 0" - -let errorTable : (int, doc) Hashtbl.t = Hashtbl.create 13 - -let error (fmt : ('a, unit, doc, unit) format4) : 'a = - let f d = - E.hadErrors := true; - Hashtbl.add errorTable !curStmtId d - in - if !verbose then begin - E.hadErrors := true; - E.log ("%a: error: " ^^ fmt) d_loc !currentLoc - end else - Pretty.gprintf f ("%a: error: " ^^ fmt) d_loc !currentLoc - -let warning (fmt : ('a, unit, doc, unit) format4) : 'a = - let f d = - Hashtbl.add errorTable !curStmtId d - in - if !verbose then - E.log ("%a: warning: " ^^ fmt) d_loc !currentLoc - else - Pretty.gprintf f ("%a: warning: " ^^ fmt) d_loc !currentLoc - -let showStmtErrors (stmt : stmt) : unit = - List.iter - (fun d -> - fprint !E.logChannel 1000000 d; - flush !E.logChannel) - (List.rev (Hashtbl.find_all errorTable stmt.sid)) - -let clearStmtErrors (stmt : stmt) : unit = - while Hashtbl.mem errorTable stmt.sid do - Hashtbl.remove errorTable stmt.sid - done - -let clearErrors () : unit = - Hashtbl.clear errorTable - -let addVisited (s : stats) (e : exp) : unit = - if not (List.exists (fun (e', _) -> e' == e) s.visited) then - s.visited <- (e, !currentLoc) :: s.visited - -let addFailed (s : stats) (e : exp) : unit = - if not (List.exists (fun (e', _) -> e' == e) s.failed) then - s.failed <- (e, !currentLoc) :: s.failed - -let resetStats (s : stats) : unit = - s.visited <- []; - s.failed <- [] - -let tallyStats (s : stats) : unit = - let newVerified = - List.filter - (fun (e, _) -> not (List.exists (fun (e', _) -> e' == e) s.failed)) - s.visited - in - s.numVisited <- (List.length s.visited) + s.numVisited; - s.verified <- newVerified @ s.verified; - resetStats s - -let splitArrow (s : string) : string * string = - let idx = ref (-1) in - let len = String.length s in - for i = 0 to len - 2 do - if String.sub s i 2 = "->" then - idx := i - done; - if !idx >= 0 then - (String.sub s 0 !idx), (String.sub s (!idx + 2) (len - !idx - 2)) - else - raise Not_found - -let isIgnoreType (t : typ) : bool = - hasAttribute "ignore" (typeAttrs t) - -let isOutType (t : typ) : bool = - hasAttribute "out" (typeAttrs t) - -let isInOutType (t : typ) : bool = - hasAttribute "inout" (typeAttrs t) - -let isAllocator (t : typ) : bool = - hasAttribute "cclmalloc" (typeAttrs t) - -let getSizeIndex (t : typ) : int = - try - match List.hd (filterAttributes "cclmalloc" (typeAttrs t)) with - | Attr ("cclmalloc", [AInt n]) -> n - | a -> 0 - with Failure "hd" -> - 0 - -let listToFactSet (facts : fact list) : FactSet.t = - List.fold_right (fun fact set -> FactSet.add fact set) facts FactSet.empty - -let curVars : varinfo list ref = ref [] - -let clearVars () : unit = - curVars := [] - -let addVar (vi : varinfo) : unit = - if not (List.memq vi !curVars) then - curVars := vi :: !curVars - -let varNameToInfo (name : string) : varinfo option = - try - Some (List.find (fun vi -> vi.vname = name) !curVars) - with Not_found -> - None - (*E.s (E.bug "var name not in list\n")*) - -let varNameIsFS (name : string) : bool = - match varNameToInfo name with - | Some vi -> not vi.vaddrof - | None -> true - (*not (varNameToInfo name).vaddrof*) - -let rec varType (name : string) : typ = - match varNameToInfo name with - | Some vi -> vi.vtype - | None -> - begin - try - let vname, fname = splitArrow name in - match unrollType (varType vname) with - | TPtr (bt, _) -> - begin - match unrollType bt with - | TComp (ci, _) -> (getCompField ci fname).ftype - | t -> E.s (E.bug "expected comp type: %a\n" d_type t) - end - | t -> E.s (E.bug "expected ptr type: %a\n" d_type t) - with Not_found -> - E.s (E.bug "unrecognized var\n") - end - (*(varNameToInfo name).vtype*) - -let replaceName (name1 : string) (name2 : string) - (facts : FactSet.t) : FactSet.t = - FactSet.fold - (fun (aname1, annot1) rest -> - let aname2 = if aname1 = name1 then name2 else aname1 in - let annot2 = - match annot1 with - | ANTI (vname1, n) when vname1 = name1 -> ANTI (name2, n) - | AVC vname1 when vname1 = name1 -> AVC name2 - | AVCB vname1 when vname1 = name1 -> AVCB name2 - | AVCBI vname1 when vname1 = name1 -> AVCBI name2 - | ACCB vname1 when vname1 = name1 -> ACCB name2 - | ACCBI vname1 when vname1 = name1 -> ACCBI name2 - | AE vname1 when vname1 = name1 -> AE name2 - | AEI vname1 when vname1 = name1 -> AEI name2 - | ANTI _ - | AVC _ - | AVCB _ - | AVCBI _ - | ACCB _ - | ACCBI _ - | AE _ - | AEI _ - | AIgn - | AZero - | ANonZero - | ANonNeg - | AOne - | ANT _ - | ACC _ -> annot1 - in - FactSet.add (aname2, annot2) rest) - facts - FactSet.empty - -let addPrefix (prefix : string) (facts : FactSet.t) : FactSet.t = - FactSet.fold - (fun (aname1, annot1) rest -> - let aname2 = if aname1 <> "*" then prefix ^ aname1 else aname1 in - let annot2 = - match annot1 with - | ANTI (vname1, n) when vname1 <> "*" -> ANTI (prefix ^ vname1, n) - | AVC vname1 when vname1 <> "*" -> AVC (prefix ^ vname1) - | AVCB vname1 when vname1 <> "*" -> AVCB (prefix ^ vname1) - | AVCBI vname1 when vname1 <> "*" -> AVCBI (prefix ^ vname1) - | ACCB vname1 when vname1 <> "*" -> ACCB (prefix ^ vname1) - | ACCBI vname1 when vname1 <> "*" -> ACCBI (prefix ^ vname1) - | AE vname1 when vname1 <> "*" -> AE (prefix ^ vname1) - | AEI vname1 when vname1 <> "*" -> AEI (prefix ^ vname1) - | ANTI _ - | AVC _ - | AVCB _ - | AVCBI _ - | ACCB _ - | ACCBI _ - | AE _ - | AEI _ - | AIgn - | AZero - | ANonZero - | ANonNeg - | AOne - | ANT _ - | ACC _ -> annot1 - in - FactSet.add (aname2, annot2) rest) - facts - FactSet.empty - -let selectFactsEx (fn : string -> bool) (facts : FactSet.t) : FactSet.t = - FactSet.fold - (fun (aname, annot) rest -> - let save = - (fn aname) || - match annot with - | ANTI (vname, _) - | AVC vname - | AVCB vname - | AVCBI vname - | ACCB vname - | ACCBI vname - | AE vname - | AEI vname -> fn vname - | AIgn - | AZero - | ANonZero - | ANonNeg - | AOne - | ANT _ - | ACC _ -> false - in - if save then - FactSet.add (aname, annot) rest - else - rest) - facts - FactSet.empty - -let selectFacts (name : string) (facts : FactSet.t) : FactSet.t = - selectFactsEx (fun name' -> name = name') facts - -let getMaxFact (fn : fact -> int) (facts : FactSet.t) : int = - FactSet.fold - (fun fact cur -> max (fn fact) cur) - facts - (-1) - -let getMaxACC (name : string) (facts : FactSet.t) : int = - getMaxFact - (fun fact -> - match fact with - | name', ACC n when name = name' -> n - | _ -> -1) - facts - -let getMaxANT (name : string) (facts : FactSet.t) : int = - getMaxFact - (fun fact -> - match fact with - | name', ANT n when name = name' -> n - | _ -> -1) - facts - -let getMaxANTI (name1 : string) (name2 : string) (facts : FactSet.t) : int = - getMaxFact - (fun fact -> - match fact with - | name1', ANTI (name2', n) when name1 = name1' && name2 = name2' -> n - | _ -> -1) - facts - -let trimFacts (facts : FactSet.t) : FactSet.t = - FactSet.fold - (fun fact rest -> - match fact with - | name, ACC n when n < getMaxACC name facts -> rest - | name, ANT n when n < getMaxANT name facts -> rest - | name1, ANTI (name2, n) when n < getMaxANTI name1 name2 facts -> rest - | _ -> FactSet.add fact rest) - facts - FactSet.empty - -let joinFacts (facts1 : FactSet.t) (facts2 : FactSet.t) : FactSet.t = - let facts1' = trimFacts facts1 in - let facts2' = trimFacts facts2 in - let join = FactSet.inter facts1' facts2' in - FactSet.fold - (fun fact rest -> - let add fact' = - FactSet.add fact' rest - in - match fact with - | name, ACC n when name = "*" -> - let m = getMaxACC name facts2' in - if m >= 0 then - add (name, ACC (min n m)) - else - rest - | name, ANT n -> - let m = getMaxANT name facts2' in - if m >= 0 then - add (name, ANT (min n m)) - else - rest - | name1, ANTI (name2, n) -> - let m = getMaxANTI name1 name2 facts2' in - if m >= 0 then - add (name1, ANTI (name2, min n m)) - else - rest - | _ -> rest) - facts1' - join - -let closeFacts (facts : FactSet.t) : FactSet.t = - (* Warning: This code may need to change for more complex closure rules. *) - let closeAnnot (annot : annot) : annot list = - annot :: - match annot with - | ANT n -> [ ACC (n + 1) ] - | AZero -> [ ACC 1; ANT 0; ANonNeg ] - | AOne -> [ ANonZero; ANonNeg ] - | ACCB s -> [ ANonZero; ACCBI s ] - | AVCB s -> [ ANonZero; AVCBI s ] - | AE s -> [ AEI s ] - | _ -> [] - in - FactSet.fold - (fun (name, annot) rest -> - List.fold_right - (fun annot' rest' -> FactSet.add (name, annot') rest') - (closeAnnot annot) - rest) - facts - FactSet.empty - -let attrToFact (name : string) (attr : attribute) : fact option = - match attr with - (* My original annotations: *) - | Attr ("ignore", []) -> Some (name, AIgn) - | Attr ("nullterm", []) -> Some (name, ANT 0) - | Attr ("count", [AInt n]) -> Some (name, ACC n) - | Attr ("count", [ACons (s, [])]) -> Some (name, AVC s) - | Attr ("countof", [ACons (s, [])]) -> Some (s, AVC name) - | Attr ("end", [ACons (s, [])]) -> Some (name, AEI s) - (* For compatibility with the original CCured: *) - | Attr ("safe", []) -> Some (name, ACC 1) - | Attr ("string", []) -> Some (name, ANT 0) - | _ -> None - -let myAttr (attr : attribute) : bool = - match attrToFact "*" attr with - | Some _ -> true - | None when attr = Attr ("out", []) -> true - | None when attr = Attr ("inout", []) -> true - | None -> false - -let attrsToFacts (name : string) (attrs : attributes) : FactSet.t = - List.fold_right - (fun attr rest -> - match attrToFact name attr with - | Some fact -> FactSet.add fact rest - | None -> rest) - attrs - FactSet.empty - -let typeToFactsEx (name : string) (t : typ) (extra : attributes) : FactSet.t = - match unrollType t with - | TArray (_, len, attrs) -> - begin - try - FactSet.add - (name, ACC (lenOfArray len)) - (attrsToFacts name (attrs @ extra)) - with LenOfArray -> - attrsToFacts name (attrs @ extra) - end - | _ -> attrsToFacts name ((typeAttrs t) @ extra) - -let typeToFacts (name : string) (t : typ) : FactSet.t = - typeToFactsEx name t [] - -let typeToFactsPre (prefix : string) (name : string) (t : typ) : FactSet.t = - addPrefix prefix (typeToFacts name t) - -let getCompFacts (name : string) (ci : compinfo) : FactSet.t = - List.fold_right - (fun fld rest -> - FactSet.union - (addPrefix (name ^ "->") (typeToFacts fld.fname fld.ftype)) rest) - ci.cfields - FactSet.empty - -let getFunctionFacts (t : typ) : FactSet.t * FactSet.t = - match t with - | TFun (rtype, args, vararg, attrs) -> - let rec argIter i formals (accIn, accOut) = - match formals with - | (fName, fType, _) :: rest -> - let fakeName = - if fName <> "" then - "@" ^ fName - else - "@$arg" ^ (string_of_int i) - in - let fType' = - if isOutType fType || isInOutType fType then - match fType with - | TPtr (bt, _) -> bt - | _ -> E.s (E.bug "expected ptr type\n") - else - fType - in - let newFacts = - replaceName "*" fakeName (addPrefix "@" (typeToFacts "*" fType')) - in - let accIn', accOut' = - if isOutType fType then - accIn, FactSet.union newFacts accOut - else if isInOutType fType then - FactSet.union newFacts accIn, FactSet.union newFacts accOut - else - FactSet.union newFacts accIn, accOut - in - argIter (i + 1) rest (accIn', accOut') - | [] -> - accIn, accOut - in - let retFacts = - replaceName "*" "@$ret" (addPrefix "@" (typeToFacts "*" rtype)) - in - argIter 1 (argsToList args) (FactSet.empty, retFacts) - | _ -> E.s (E.bug "expected function type\n") - -let getVarFacts (name : string) (facts : FactSet.t) : FactSet.t = - replaceName name "*" (selectFacts name facts) - -let openVar (vname : string) (state : state) : unit = - if not (StringSet.mem vname state.openVars) then begin - let vi = - match varNameToInfo vname with - | Some vi -> vi - | None -> E.s (E.bug "can't open non-local var\n") - in - let e = - match unrollType vi.vtype with - | TPtr _ -> Lval (Var vi, NoOffset) - | TArray _ -> StartOf (Var vi, NoOffset) - | _ -> E.s (E.bug "expected ptr or array type\n") - in - let comp = - match unrollType (typeOfLval (Mem e, NoOffset)) with - | TComp (ci, _) -> ci - | t -> E.s (E.bug "expected comp type: %a\n" d_type t) - in - let facts = getCompFacts vname comp in - state.facts <- FactSet.union facts state.facts; - state.openVars <- StringSet.add vname state.openVars; - end - -let openVars (vnames : StringSet.t) (state : state) : unit = - StringSet.iter (fun vname -> openVar vname state) vnames - -let closeVar (vname : string) (state : state) : unit = - (* TODO: check! *) - if StringSet.mem vname state.openVars then begin - let prefix = vname ^ "->" in - let prefixLen = String.length prefix in - let prefixCheck v = - try - String.sub v 0 prefixLen <> prefix - with Invalid_argument _ -> - true - in - state.facts <- selectFactsEx prefixCheck state.facts; - state.openVars <- StringSet.remove vname state.openVars - end - -let closeAllVars (state : state) : unit = - StringSet.iter (fun vname -> closeVar vname state) state.openVars - -let makeState (fd : fundec) : state = - let facts = - List.fold_right - (fun vi rest -> - if not (isFunctionType vi.vtype) then - FactSet.union (typeToFactsEx vi.vname vi.vtype vi.vattr) rest - else - rest) - !curVars - FactSet.empty - in - { facts = facts; openVars = StringSet.empty; } - -let copyState (s : state) : state = - { facts = s.facts; openVars = s.openVars; } - -let joinStates (s1 : state) (s2 : state) : state = - let s1' = copyState s1 in - let s2' = copyState s2 in - let allVars = StringSet.union s1'.openVars s2'.openVars in - openVars allVars s1'; - openVars allVars s2'; - { facts = joinFacts (closeFacts s1'.facts) (closeFacts s2'.facts); - openVars = allVars; } - -let equalFacts (f1 : FactSet.t) (f2 : FactSet.t) : bool = - FactSet.equal (closeFacts f1) (closeFacts f2) - -let equalStates (s1 : state) (s2 : state) : bool = - equalFacts s1.facts s2.facts - -let checkCast (toFacts : FactSet.t) (fromFacts : FactSet.t) : bool = - let toClose = closeFacts toFacts in - let fromClose = closeFacts fromFacts in - let join = joinFacts toClose fromClose in - FactSet.subset toClose join - -let equalTypes (t1 : typ) (t2 : typ) : bool = - let typeSigNC (t : typ) : typsig = - let attrFilter (attr : attribute) : bool = - match attr with - | Attr ("const", []) - | Attr ("always_inline", []) -> false - | _ -> true - in - typeSigWithAttrs (List.filter attrFilter) t - in - (typeSigNC t1) = (typeSigNC t2) - -let equalBaseTypes (t1 : typ) (t2 : typ) : bool = - equalTypes (setTypeAttrs t1 []) (setTypeAttrs t2 []) - -let equalTypesNoAttrs (t1 : typ) (t2 : typ) : bool = - let typeSigNA (t : typ) : typsig = - typeSigWithAttrs (List.filter (fun attr -> not (myAttr attr))) t - in - (typeSigNA t1) = (typeSigNA t2) - -class normVisitor = object - inherit nopCilVisitor - - val mapping : (string, string) Hashtbl.t ref = ref (Hashtbl.create 1) - - method vtype (t : typ) : typ visitAction = - match t with - | TFun (rtype, args, vararg, attrs) -> - let oldMapping = !mapping in - let newMapping = Hashtbl.create 7 in - let rec iter index args = - match args with - | (name, _, _) :: rest -> - Hashtbl.add newMapping name (string_of_int index); - iter (index + 1) rest - | [] -> () - in - iter 1 (argsToList args); - Hashtbl.add newMapping "return" "0"; - mapping := newMapping; - ChangeDoChildrenPost (t, (fun x -> mapping := oldMapping; x)) - | _ -> - DoChildren - - method vattr (attr : attribute) : attribute list visitAction = - match attr with - | Attr ("count", [ACons (s, [])]) -> - begin - try - let newAttr = - Attr ("count", [ACons (Hashtbl.find !mapping s, [])]) - in - ChangeTo [ newAttr ] - with Not_found -> - E.s (E.bug "error normalizing type") - end - | _ -> - DoChildren -end - -let normalizeType (t : typ) : typ = - visitCilType (new normVisitor) t - -class normVisitor2 subst = object - inherit nopCilVisitor - - val subst = subst - - method vtype (t : typ) : typ visitAction = - match t with - | TFun _ -> SkipChildren - | _ -> DoChildren - - method vattr (attr : attribute) : attribute list visitAction = - match attr with - | Attr (aname, [ACons (s, [])]) - when aname = "count" || aname = "countof" -> - begin - try - let newAttr = - match Hashtbl.find subst s with - | SVar s' -> - [ Attr (aname, [ACons (s', [])]) ] - | SInt i when aname = "count" -> - [ Attr ("count", [AInt i]) ] - | SNone -> - [] - | _ -> - E.s (E.bug "unexpected summary\n") - in - ChangeTo newAttr - with Not_found -> begin - ignore (error "no substitution found for %s" s); - DoChildren - end - end - | _ -> - DoChildren -end - -let normalizeType2 (subst : (string, summary) Hashtbl.t) (t : typ) : typ = - visitCilType (new normVisitor2 subst) t - -let checkBaseTypes (toType : typ) (fromType : typ) : bool = - let rec check (t1 : typ) (t2 : typ) (dontCheck : bool) : bool = - (*ignore (E.log "checking %a = %a\n" d_type t1 d_type t2);*) - match unrollType t1, unrollType t2 with - | TPtr (t1', _), TPtr (t2', _) -> - let f1 = typeToFacts "*" t1 in - let f2 = typeToFacts "*" t2 in - (dontCheck || equalFacts f1 f2) && check t1' t2' false - | TFun _, TFun _ -> equalTypes (normalizeType t1) (normalizeType t2) - | (TInt _ | TFloat _), (TInt _ | TFloat _) -> true - | TInt _, TEnum _ -> true - | TEnum _, TInt _ -> true - | TInt _, TPtr _ -> true - | TVoid _, TVoid _ -> true - | TPtr _, TInt _ -> - ignore (warning ("unchecked integer to pointer cast\n" ^^ - " to: %a\n from: %a") - d_type t1 d_type t2); - true (* TODO: improve this check *) - | _, TVoid _ - | TVoid _, _ -> - ignore (warning ("unchecked void cast\n" ^^ - " to: %a\n from: %a") - d_type t1 d_type t2); - true (* TODO: improve this check *) - | _, _ -> equalTypes t1 t2 - in - let res = check toType fromType true in - (*ignore (E.log "result: %b\n" res);*) - res - -let changeFacts (fn : fact -> fact list) (facts : FactSet.t) : FactSet.t = - FactSet.fold - (fun fact rest -> - List.fold_right - (fun fact' rest' -> FactSet.add fact' rest') - (fn fact) rest) - (closeFacts facts) - FactSet.empty - -let changeState (fn : fact -> fact list) (state : state) : unit = - state.facts <- changeFacts fn state.facts - -let changeAnnots (fn : annot -> annot list) (facts : FactSet.t) : FactSet.t = - FactSet.fold - (fun (name, annot) rest -> - List.fold_right - (fun annot' rest' -> FactSet.add (name, annot') rest') - (fn annot) rest) - (closeFacts facts) - FactSet.empty - -let summaryToFacts (sum : summary) (state : state) : FactSet.t = - match sum with - | SNone -> - FactSet.empty - | SInt i -> - let annots = - (* TODO: refacor the following *) - if i = 0 then - FactSet.fold - (fun fact rest -> - match fact with - | name, ANT n -> (ANTI (name, n)) :: rest - | name, ACC n when n > i -> (ACCB name) :: rest - | name, AVC _ -> (AVCBI name) :: rest - | _ -> rest) - state.facts - [ AZero ] - else if i = 1 then - FactSet.fold - (fun fact rest -> - match fact with - | name, ANT n when n >= i -> (ANTI (name, n - i)) :: rest - | name, ACC n when n > i -> (ACCB name) :: rest - | name, AVC _ -> (AVCBI name) :: rest - | _ -> rest) - state.facts - [ AOne ] - else - FactSet.fold - (fun fact rest -> - match fact with - | name, ACC n when n > i && i > 0 -> (ACCB name) :: rest - | name, AVC _ when i > 0 -> (AVCBI name) :: rest - | _ -> rest) - state.facts - [ ANonZero ] - (* TODO: add ANonZero *) - in - let extra = - FactSet.fold - (fun fact rest -> - match fact with - | name, ACC n when 0 <= i && i <= n -> - FactSet.add (name, (AVC "*")) rest - | _ -> rest) - state.facts - FactSet.empty - in - List.fold_right - (fun annot rest -> FactSet.add ("*", annot) rest) - annots extra - | SVar vname -> - getVarFacts vname state.facts - | SVarOff (vname, oname) -> - FactSet.fold - (fun fact rest -> - match fact with - | vname', ANT _ when vname = vname' -> - let maxAnti = getMaxANTI oname vname state.facts in - if maxAnti >= 0 then - FactSet.add ("*", ANT maxAnti) rest - else - rest - | vname', ACC _ when vname = vname' -> - if FactSet.mem (oname, ACCB vname) state.facts then - FactSet.add ("*", ACC 1) rest - else - rest - | vname', AVC _ when vname = vname' -> - if FactSet.mem (oname, AVCB vname) state.facts then - FactSet.add ("*", ACC 1) rest - else - rest - | _ -> - rest) - state.facts - FactSet.empty - | SVarOffConst (vname, off) -> - changeFacts - (fun (vname', annot) -> - if vname = vname' then - match annot with - | ACC n when n >= off -> [ ("*", ACC (n - off)); (vname, AE "*") ] - | ANT n when n >= off -> [ ("*", ANT (n - off)); (vname, AE "*") ] - | ANTI (s, n) when n >= off -> [ ("*", ANTI (s, n - off)) ] - (* TODO: the following should be checked for overflow *) - | ACCB s -> [ ("*", ANonNeg); ("*", ACCBI s) ] - | AVCB s -> [ ("*", ANonNeg); ("*", AVCBI s) ] - | AE s -> [ ("*", AEI s) ] - | AZero when off = 1 -> [ ("*", AOne) ] - | AZero when off <> 0 -> [ ("*", ANonZero) ] - | _ -> [] - else - []) - state.facts - | SVarMult _ -> - FactSet.empty - | SDerefVar vname - | SDerefVarOff (vname, _) - | SDerefVarOffConst (vname, _) -> - let bt = - match unrollType (varType vname) with - | TPtr (bt, _) - | TArray (bt, _, _) -> bt - | _ -> E.s (E.bug "expected ptr or array type\n") - in - typeToFacts "*" bt - | SDerefVarFld (vname, fname) -> - openVar vname state; - getVarFacts (vname ^ "->" ^ fname) state.facts - | SAddrVar vname -> - FactSet.singleton ("*", ACC 1) - | SFacts facts -> - facts - -let safeDeref (facts : FactSet.t) : bool = - FactSet.exists - (fun fact -> - match fact with - | "*", ACC n when n > 0 -> true - | _ -> false) - (closeFacts facts) - -let hasAnnot (a : annot) (facts : FactSet.t) : bool = - FactSet.mem ("*", a) (closeFacts facts) - -let summaryIsZero (sum : summary) (state : state) : bool = - hasAnnot AZero (summaryToFacts sum state) - -let summaryIsNonZero (sum : summary) (state : state) : bool = - hasAnnot ANonZero (summaryToFacts sum state) - -let rec evaluateExp (e : exp) (state : state) : summary = - match e with - | UnOp (op, e', _) -> SNone - | BinOp ((PlusA | PlusPI | IndexPI), e1, e2, _) -> - begin - match evaluateExp e1 state, evaluateExp e2 state with - | SVar v1, SVar v2 -> SVarOff (v1, v2) - | SVar v1, SInt 0 -> SVar v1 - | SVar v1, SInt n -> SVarOffConst (v1, n) - | _, _ -> SNone - end - | BinOp (Mult, e1, e2, _) -> - begin - match evaluateExp e1 state, evaluateExp e2 state with - | SInt n1, SInt n2 -> SInt (n1 * n2) - | SVar v1, SInt n2 -> SVarMult (v1, n2) - | SInt n1, SVar v2 -> SVarMult (v2, n1) - | _, _ -> SNone - end - | BinOp (op, e1, e2, _) -> SNone - | AddrOf lv -> - begin - match evaluateLval lv state with - | SVar vname -> SAddrVar vname - | SDerefVar vname -> SVar vname - | SDerefVarOff (vname, off) -> SVarOff (vname, off) - | SDerefVarOffConst (vname, off) -> SVarOffConst (vname, off) - | _ -> SFacts (FactSet.singleton ("*", ACC 1)) - end - | Lval lv -> evaluateLval lv state - | CastE (t, e') -> - let eSum = evaluateExp e' state in - let eFacts = summaryToFacts eSum state in - let eType = typeOf e' in - let tFacts = typeToFacts "*" t in - (* TODO: NULL is defined as ((void* )0), so we hack around it... *) - if hasAnnot AZero eFacts then - eSum - (* TODO: character comparisons get cast to ints, but we need to - pass the summary through in order to recognize the conditional *) - else if isIntegralType eType && isIntegralType t then - eSum - (* TODO: same with pointers *) - else if isPointerType eType && isIntegralType t then - eSum - (* TODO: CIL inserts casts where toplevel annots don't match *) - else if equalBaseTypes eType t then - eSum - else begin - if not (hasAnnot AIgn tFacts) then begin - if not (checkBaseTypes t eType) then - ignore (error "cannot verify cast\n to: %a\n from: %a" - d_type t d_type eType); - if not (checkCast tFacts eFacts) then - ignore (error "cannot verify cast\n to: %a\n from: %a" - d_facts tFacts d_facts eFacts) - end; - SFacts tFacts - end - | Const (CStr s) -> - SFacts (FactSet.singleton ("*", ANT 0)) - | Const _ -> - begin - match getInteger e with - | Some i -> SInt (cilint_to_int i) (* TODO: possible bug in conv? *) - | None -> SNone - end - | SizeOf _ - | SizeOfE _ - | SizeOfStr _ -> - let e' = constFold true e in - begin - match e' with - | Const _ -> () - | _ -> E.s (E.bug "expected constant\n") - end; - evaluateExp e' state - | AlignOf _ - | AlignOfE _ -> SNone - | StartOf lv -> evaluateLval lv state - | Question _ -> E.s (E.unimp "ternary operator ?:") - | AddrOfLabel _ -> E.s (E.unimp "address of label") - -and evaluateLval (lv : lval) (state : state) : summary = - match lv with - | Var vi, NoOffset -> - SVar vi.vname - | Var _, _ -> - SFacts (typeToFacts "*" (typeOfLval lv)) - | Mem e, off -> - addVisited expStats e; - let s = evaluateExp e state in - if not (safeDeref (summaryToFacts s state)) then begin - ignore (error "cannot verify dereference of %a" d_exp e); - addFailed expStats e; - end; - begin - match s, off with - | SVar name, NoOffset -> SDerefVar name - | SVar name, Field (fld, NoOffset) -> - (*SDerefVarFld (name, fld.fname)*) - let hasArrow = - try - name.[(String.index name '-') + 1] = '>' - with Not_found | Invalid_argument _ -> - false - in - if not hasArrow then begin - openVar name state; - SVar (name ^ "->" ^ fld.fname) - end else - SFacts (typeToFacts "*" (typeOfLval lv)) - | SVarOff (bname, oname), NoOffset -> SDerefVarOff (bname, oname) - | SVarOffConst (name, off), NoOffset -> SDerefVarOffConst (name, off) - | _ -> SFacts (typeToFacts "*" (typeOfLval lv)) - end - -let getTypeSize (t : typ) : int = - match getInteger (constFold true (SizeOf t)) with - | Some i -> cilint_to_int i - | None -> E.s (E.bug "failed to compute size of type %a\n" d_type t) - -let getAllocFact (t : typ) (e : exp) (state : state) : FactSet.t * bool = - let sz = - match unrollType t with - | TPtr (bt, _) -> getTypeSize bt - | _ -> E.s (E.bug "expected ptr type\n") - in - let handleInt n = - FactSet.singleton ("*", ACC (n / sz)), (n mod sz) = 0 - in - let handleVarMult v n = - if n >= sz then - FactSet.singleton ("*", AVC v), (n mod sz) = 0 - else - FactSet.empty, false - in - match evaluateExp e state with - | SInt n -> handleInt n - | SVar v -> handleVarMult v 1 - | SVarMult (v, n) -> handleVarMult v n - | _ -> FactSet.empty, false - -let analyzeCond (cond : exp) (state : state) : unit = - let upgradeANT (n : int) (vname : string) : unit = - changeState - (fun (name, annot) -> - match annot with - | ANT m when name = vname && n = m -> - [ (name, ANT n); (name, ANT (n + 1)) ] - | _ -> [ (name, annot) ]) - state - in - let upgradeANTI (n : int) (vname : string) (sname : string) : unit = - changeState - (fun (name, annot) -> - match annot with - | ANTI (name', m) when name = vname && name' = sname && n = m -> - [ (name, ANTI (name', n + 1)) ] - | _ -> [ (name, annot) ]) - state - in - let upgradeACCBI (vname : string) (aname : string) : unit = - changeState - (fun (name, annot) -> - match annot with - | ACCBI name' when name = vname && name' = aname -> - [ (name, ACCB name') ] - | AZero when name = vname -> - [ (name, annot); (name, ACCB aname) ] - | ANonNeg when name = vname -> - [ (name, annot); (name, ACCB aname) ] - | _ -> [ (name, annot) ]) - state - in - let upgradeAVCBI (vname : string) (aname : string) : unit = - changeState - (fun (name, annot) -> - match annot with - | AVCBI name' when name = vname && name' = aname -> - [ (name, AVCB name') ] - | AZero when name = vname -> - [ (name, annot); (name, AVCB aname) ] - | ANonNeg when name = vname -> - [ (name, annot); (name, AVCB aname) ] - | _ -> [ (name, annot) ]) - state - in - let upgradeAEI (vname : string) : unit = - changeState - (fun (name, annot) -> - match annot with - | AEI bname when name = vname -> - [ (name, AE bname); (name, ACC 1) ] - | _ -> [ (name, annot) ]) - state - in - let equalNonZero (e : exp) (sum : summary) : unit = - match sum with - | SDerefVar vname -> - upgradeANT 0 vname - | SDerefVarOff (bname, oname) - when FactSet.mem (oname, ANTI (bname, 0)) state.facts -> - upgradeANTI 0 oname bname - | SDerefVarOffConst (vname, 1) -> - upgradeANT 1 vname - | _ -> - if !verbose then - ignore (E.log "unrecognized zero exp: %a == 0\n" d_exp e); - () - in - let checkLessThan (e1 : exp) (e2 : exp) : unit = - let s1 = evaluateExp e1 state in - let s2 = evaluateExp e2 state in - match s1, s2 with - | SVar vname, SInt i -> - let arrays = - FactSet.fold - (fun (name, annot) rest -> - if annot = ACC i then - name :: rest - else - rest) - state.facts - [] - in - List.iter (fun aname -> upgradeACCBI vname aname) arrays - | SVar vname, SVar bname -> - let arrays = - FactSet.fold - (fun (name, annot) rest -> - if annot = AVC bname then - name :: rest - else - rest) - state.facts - [] - in - let arrays2 = - FactSet.fold - (fun (name, annot) rest -> - if annot = AEI bname then - name :: rest - else - rest) - state.facts - [] - in - List.iter (fun aname -> upgradeAVCBI vname aname) arrays; - List.iter (fun aname -> upgradeAEI vname) arrays2 - | SVar vname, _ -> - let f2 = summaryToFacts s2 state in - let arrays = - FactSet.fold - (fun (name, annot) rest -> - if annot = AVC "*" then - name :: rest - else - rest) - f2 - [] - in - List.iter (fun aname -> upgradeAVCBI vname aname) arrays - | _ -> () - in - let checkEquality (e1 : exp) (e2 : exp) : unit = - let s1 = evaluateExp e1 state in - let s2 = evaluateExp e2 state in - if summaryIsNonZero s2 state then - equalNonZero e1 s1 - in - let checkDisequality (e1 : exp) (e2 : exp) : unit = - let s1 = evaluateExp e1 state in - let s2 = evaluateExp e2 state in - if summaryIsZero s2 state then - equalNonZero e1 s1 - in - let rec checkCond (cond : exp) (invert : bool) : unit = - match cond with - | UnOp (LNot, cond', _) -> - checkCond cond' (not invert) - | BinOp ((LAnd | LOr), _, _, _) -> - E.s (E.bug "&& or || not eliminated by cil\n") - | BinOp (Lt, cond1, cond2, _) -> - checkLessThan cond1 cond2 - | BinOp (Eq, cond1, cond2, _) -> - if invert then - checkDisequality cond1 cond2 - else - checkEquality cond1 cond2 - | BinOp (Ne, cond1, cond2, _) -> - if invert then - checkEquality cond1 cond2 - else - checkDisequality cond1 cond2 - | Lval lv -> - if invert then - checkEquality cond zero - else - checkDisequality cond zero - | _ -> - if !verbose then - ignore (E.log "unrecognized cond: %a\n" d_exp cond); - () - in - if !verbose then - ignore (E.log "%a: cond %a\n%a\n" d_loc !currentLoc - dn_exp cond d_state state); - checkCond cond false - -let analyzeStmt (stmt : stmt) (state : state) : bool = - let return = ref true in - begin - match stmt.skind with - | Instr instrs -> - List.iter - (fun instr -> - let doSetNames (vnames : string list) (facts : FactSet.t) : unit = - let removed = - FactSet.fold - (fun (name, annot) rest -> - match annot with - | ANTI (vname', _) - | AVC vname' - | AVCB vname' - | AVCBI vname' - | ACCB vname' - | ACCBI vname' when List.mem vname' vnames -> rest - | _ when List.mem name vnames -> rest - | _ -> FactSet.add (name, annot) rest) - state.facts - FactSet.empty - in - state.facts <- FactSet.union removed facts; - (* - ignore (E.log "%a: %s gets %a\n" d_loc !currentLoc - vname d_facts facts) - *) - in - let doSet (lv : lval) (eType : typ) (facts : FactSet.t) : unit = - let lvType = typeOfLval lv in - let lvSum = evaluateLval lv state in - if not (checkBaseTypes lvType eType) then - ignore (error ("assignment has incompatible types\n" ^^ - " to: %a\n from: %a") - d_type lvType d_type eType); - begin - match lvSum with - | SVar vname -> closeVar vname state - | _ -> () - end; - begin - match lvSum with - | SVar vname when varNameIsFS vname -> - doSetNames [ vname ] (replaceName "*" vname facts) - | _ -> - (* check base types equal *) - let lvFacts = summaryToFacts lvSum state in - if not (checkCast lvFacts facts) then - ignore (error ("assignment has incompatible facts\n" ^^ - " to: %a\n from: %a") - d_facts lvFacts d_facts facts) - end - in - if !return then begin - currentLoc := get_instrLoc instr; - if !verbose then - ignore (E.log "%a: instr %a\n%a\n" d_loc !currentLoc - dn_instr instr d_state state); - match instr with - | Call (None, Lval (Var vi, NoOffset), [ptr; chr; size], l) - when vi.vname = "memset" && isZero chr -> - let t = typeOf ptr in - let facts, exact = getAllocFact t size state in - if exact then begin - (* TODO: check that all ptrs are nullable *) - let ptrSum = evaluateExp ptr state in - let ptrFacts = summaryToFacts ptrSum state in - if not (checkCast facts ptrFacts) then - ignore (error - ("argument 1 to memset has incompatible facts\n" ^^ - "to: %a\n from: %a\n") - d_facts facts d_facts ptrFacts) - end else - ignore (error "cannot verify size of memset") - | Call (ret, fn, actuals, l) -> - let fnName = - match fn with - | Lval (Var vi, NoOffset) -> vi.vname - | _ -> "function pointer" - in - begin - match unrollType (typeOf fn) with - | TFun (rtype, argInfo, isVarArg, attrs) as fnType -> - let formals = argsToList argInfo in - let matches = Hashtbl.create 7 in - let removeNames = ref [] in - let inOutSubst = Hashtbl.create 7 in - let inFacts, outFacts = getFunctionFacts fnType in - let rec argIter fn : unit = - let rec argIterRec i formals actuals : unit = - match formals, actuals with - | fcur :: frest, acur :: arest -> - fn i fcur acur; - argIterRec (i + 1) frest arest - | [], [] -> - () - | [], _ :: _ -> - if isVarArg then begin - if not !suppress then - ignore (warning "ignoring vararg args") - end else - ignore (error "too many actuals") - | _ :: _, [] -> - ignore (error "too many formals") - in - argIterRec 1 formals actuals - in - let rec showWarnings i (fName, fType, _) aExp : unit = - let fFacts = typeToFacts "*" fType in - if FactSet.is_empty fFacts && isPointerType fType then - ignore (warning ("formal parameter %d of " ^^ - "%s has no annotations\n") - i fnName) - in - let rec prepFakeVars i (fname, ftype, _) aExp : unit = - let fakeName = - if fname <> "" then - "@" ^ fname - else - "@$arg" ^ (string_of_int i) - in - Hashtbl.add matches fname (SVar fakeName); - if isInOutType ftype then begin - let aSum = evaluateExp aExp state in - match aSum with - | SAddrVar vname -> - let aFacts = getVarFacts vname state.facts in - doSetNames [fakeName] aFacts - | _ -> - ignore (error ("in/out parameter %d to %s " ^^ - "could not be verified\n") - i fnName) - end else if not (isOutType ftype) then begin - let aSum = evaluateExp aExp state in - let aFacts = - replaceName "*" fakeName (summaryToFacts aSum state) - in - doSetNames [fakeName] aFacts - end - in - let rec checkIn i (fname, ftype, _) aExp : unit = - let fakeName = - if fname <> "" then - "@" ^ fname - else - "@$arg" ^ (string_of_int i) - in - if not (isIgnoreType ftype) && - not (isOutType ftype) then begin - let aFacts = getVarFacts fakeName state.facts in - let aType = typeOf aExp in - let fFacts = getVarFacts fakeName inFacts in - let fType = ftype in - if isPointerType fType then - addVisited argStats aExp; - if not (checkBaseTypes fType aType) then begin - ignore (error ("argument %d to %s has " ^^ - "incompatible type\n" ^^ - " to: %a\n from: %a\n") - i fnName d_type fType d_type aType); - addFailed argStats aExp; - end; - if not (checkCast fFacts aFacts) then begin - ignore (error ("argument %d to %s has " ^^ - "incompatible facts\n" ^^ - " to: %a\n from: %a\n") - i fnName d_facts fFacts d_facts aFacts); - addFailed argStats aExp; - end; - match evaluateExp aExp state with - | SVar name when not (isInOutType ftype) -> - Hashtbl.replace inOutSubst fakeName name - | SAddrVar name when isInOutType ftype -> - Hashtbl.replace inOutSubst fakeName name - | _ -> () - end - in - let rec checkOut i (fname, ftype, _) aExp : unit = - let fakeName = - if fname <> "" then - "@" ^ fname - else - "@$arg" ^ (string_of_int i) - in - if isOutType ftype || isInOutType ftype then begin - let _ = getVarFacts fakeName outFacts in - let fType = ftype in - match evaluateExp aExp state with - | SAddrVar aName -> - let aType = varType aName in - if not (checkBaseTypes aType fType) then - ignore (error ("out parameter %d to %s has " ^^ - "incompatible type\n" ^^ - " to: %a\n from: %a\n") - i fnName d_type aType d_type fType); - Hashtbl.add inOutSubst fakeName aName; - removeNames := aName :: !removeNames - | SInt 0 -> () - | _ -> - ignore (error ("out parameter %d to %s " ^^ - "could not be verified\n") - i fnName); - end - in - argIter showWarnings; - argIter prepFakeVars; - argIter checkIn; - closeAllVars state; - argIter checkOut; - let addFacts = - Hashtbl.fold replaceName inOutSubst outFacts - in - doSetNames !removeNames addFacts; - begin - match ret with - | Some lv -> - if isAllocator rtype then begin - let i = getSizeIndex rtype in - let sizeExp = List.nth actuals (i - 1) in - let lvType = typeOfLval lv in - let facts, _ = getAllocFact lvType sizeExp state in - doSet lv lvType facts - end else begin - let facts = getVarFacts "@$ret" addFacts in - doSet lv rtype facts - end - | None -> () - end; - state.facts <- - FactSet.diff state.facts - (selectFactsEx - (fun name -> name.[0] = '@') - state.facts); - let noReturn = - match fn with - | Lval (Var vi, NoOffset) -> - hasAttribute "noreturn" vi.vattr - | _ -> false - in - if noReturn then - return := false - | _ -> - ignore (error "function has non-function type") - end - | Set (lv, e, l) -> - doSet lv (typeOf e) (summaryToFacts (evaluateExp e state) state) - | Asm (_, _, _, _, _, l) -> - if not !suppress then - ignore (warning "ignoring asm") - end) - instrs - | Return (eo, l) -> - if !verbose then - ignore (E.log "%a: %a\n%a\n" d_loc !currentLoc - dn_stmt stmt d_state state); - begin - match eo with - | Some e -> - let fType = - match !curFunction.svar.vtype with - | TFun (rtype, _, _, _) -> rtype - | t -> E.s (E.bug "expected function type (1): %a\n%a\n" - dn_stmt stmt d_type t); - in - let eType = typeOf e in - if not (checkBaseTypes fType eType) then - ignore (error ("return has incompatible type\n" ^^ - " to: %a\n from: %a") - d_type fType d_type eType); - let fFacts = typeToFacts "*" fType in - let eFacts = summaryToFacts (evaluateExp e state) state in - if not (checkCast fFacts eFacts) then - ignore (error ("return has incompatible facts\n" ^^ - " to: %a\n from: %a") - d_facts fFacts d_facts eFacts) - | None -> () - end - | Loop _ - | Goto _ - | Block _ -> () - | If _ -> E.s (E.bug "if statement not handled separately") - | Break _ - | Switch _ - | Continue _ -> E.s (E.bug "break, switch, or continue not removed") - | TryFinally _ - | TryExcept _ -> E.s (E.unimp "exceptions") - | ComputedGoto _ -> E.s (E.unimp "computed goto") - end; - !return - -class preFunctionVisitor = object - inherit nopCilVisitor - - method vlval ((host, offset) : lval) = - begin - match host with - | Var vi -> addVar vi - | _ -> () - end; - DoChildren -end - -let stmtIter (fn : stmt -> unit) (fd : fundec) : unit = - let stmtline = Hashtbl.create 113 in - let setLine (stmt : stmt) (line : int) : unit = - let newLine = - let locLine = (get_stmtLoc stmt.skind).line in - if locLine > 0 then - locLine - else - try - min line (Hashtbl.find stmtline stmt.sid) - with Not_found -> - line - in - Hashtbl.replace stmtline stmt.sid newLine - in - let worklist = Stack.create () in - let firstStmt = List.hd fd.sbody.bstmts in - Stack.push firstStmt worklist; - setLine firstStmt 0; - while not (Stack.is_empty worklist) do - let stmt = Stack.pop worklist in - let line = - try - Hashtbl.find stmtline stmt.sid - with Not_found -> - E.s (E.bug "expected line number\n") - in - List.iter - (fun succ -> - if not (Hashtbl.mem stmtline succ.sid) then - Stack.push succ worklist; - setLine succ line) - stmt.succs - done; - let getLine stmt = - try - Hashtbl.find stmtline stmt.sid - with Not_found -> - 0 - in - let sortedStmts = - List.sort - (fun s1 s2 -> compare (getLine s1) (getLine s2)) - fd.sallstmts - in - List.iter fn sortedStmts - -let analyzeFundec (fd : fundec) : unit = - resetStats expStats; - resetStats argStats; - curFunction := fd; - clearVars (); - ignore (visitCilFunction (new preFunctionVisitor) fd); - let stmtState = Hashtbl.create 113 in - let worklist = Stack.create () in - let firstStmt = List.hd fd.sbody.bstmts in - let firstState = makeState fd in - try - Hashtbl.add stmtState firstStmt.sid firstState; - Stack.push firstStmt worklist; - while not (Stack.is_empty worklist) do - let stmt = Stack.pop worklist in - let state = - try - Hashtbl.find stmtState stmt.sid - with Not_found -> - E.s (E.bug "analyzeAlloc: state not found\n"); - in - let recordState (newState : state) (succ : stmt) : unit = - try - let succState = Hashtbl.find stmtState succ.sid in - if not (equalStates newState succState) then begin - Hashtbl.replace stmtState succ.sid - (joinStates newState succState); - Stack.push succ worklist; - end - with Not_found -> - begin - Hashtbl.replace stmtState succ.sid newState; - Stack.push succ worklist; - end - in - curStmtId := stmt.sid; - currentLoc := get_stmtLoc stmt.skind; - match stmt.skind with - | If (cond, thenBranch, elseBranch, l) -> - let getBranchStmt (branch : block) : stmt = - try - List.hd branch.bstmts - with Failure "hd" -> - dummyStmt - in - let thenStmt = getBranchStmt thenBranch in - let elseStmt = getBranchStmt elseBranch in - let otherStmts = - List.filter - (fun succ -> succ.sid <> thenStmt.sid && - succ.sid <> elseStmt.sid) - stmt.succs - in - let handleStmt (cond : exp) (succ : stmt) : unit = - let newState = copyState state in - clearStmtErrors stmt; - analyzeCond cond newState; - recordState newState succ; - in - begin - match otherStmts with - | [] -> - if thenStmt == dummyStmt || elseStmt == dummyStmt then - E.s (E.bug "can't handle if statement succs\n"); - handleStmt cond thenStmt; - handleStmt (UnOp (LNot, cond, intType)) elseStmt; - | [otherStmt] -> - if thenStmt != dummyStmt && elseStmt != dummyStmt then - E.s (E.bug "can't handle if statement succs\n"); - handleStmt cond - (if thenStmt == dummyStmt then otherStmt else thenStmt); - handleStmt (UnOp (LNot, cond, intType)) - (if elseStmt == dummyStmt then otherStmt else elseStmt); - | _ -> - E.s (E.bug "can't handle if statement succs\n") - end - | _ -> - begin - let newState = copyState state in - clearStmtErrors stmt; - if analyzeStmt stmt newState then - List.iter (recordState newState) stmt.succs - end - done; - stmtIter showStmtErrors fd; - clearErrors (); - tallyStats expStats; - tallyStats argStats; - with E.Error -> - begin - (* - let worklist2 = Stack.create () in - let donelist = Hashtbl.create 113 in - Stack.push firstStmt worklist2; - while not (Stack.is_empty worklist2) do - let stmt = Stack.pop worklist2 in - let state = - try - Hashtbl.find stmtState stmt.sid - with Not_found -> - { facts = FactSet.empty; } - in - ignore (E.log "%a: %a\n%a\n" d_loc (get_stmtLoc stmt.skind) - dn_stmt stmt d_state state); - Hashtbl.add donelist stmt.sid (); - let sortedSuccs = - List.sort - (fun s2 s1 -> compare (get_stmtLoc s1.skind).line - (get_stmtLoc s2.skind).line) - stmt.succs - in - List.iter - (fun succ -> - if not (Hashtbl.mem donelist succ.sid) then - Stack.push succ worklist2) - sortedSuccs - done; - *) - raise E.Error - end - -class preVisitor = object - inherit nopCilVisitor - - method vinst (inst : instr) = - begin - match inst with - | Call (ret, fn, args, attrs) -> - let newArgs = - match unrollType (typeOf fn) with - | TFun (_, argInfo, _, _) -> - let dropCast (t : typ) (e : exp) : exp = - match e with - | CastE (t', e') when equalTypesNoAttrs t t' -> e' - | _ -> e - in - let rec matchArgs formals actuals : exp list = - match formals, actuals with - | (_, fType, _) :: fRest, aExp :: aRest -> - (dropCast fType aExp) :: (matchArgs fRest aRest) - | [], aRest -> - aRest - | _, [] -> - [] - in - matchArgs (argsToList argInfo) args - | t -> E.s (E.bug "expected function type (2): %a\n%a\n" - d_instr inst d_type t); - in - ChangeDoChildrenPost ([Call (ret, fn, newArgs, attrs)], (fun x -> x)) - | _ -> - DoChildren - end - - method vlval ((host, offset) : lval) = - begin - match host with - | Var vi -> addVar vi - | _ -> () - end; - let rec rewriteIndex (o : offset) (acc : lval) : lval = - match o with - | Index (e, o') -> - let start = StartOf acc in - let index = BinOp (PlusPI, start, e, typeOf start) in - let acc' = Mem index, NoOffset in - rewriteIndex o' acc' - | Field (fld, o') -> - let acc' = addOffsetLval (Field (fld, NoOffset)) acc in - rewriteIndex o' acc' - | NoOffset -> acc - in - ChangeDoChildrenPost (rewriteIndex offset (host, NoOffset), (fun x -> x)) -end - -class outVisitor = object - inherit nopCilVisitor - - val mapping : (string, varinfo) Hashtbl.t = Hashtbl.create 5 - val retStmt : stmt ref = ref dummyStmt - - method vfunc (fd : fundec) = - let instrs = ref [] in - let retInstrs = ref [] in - Hashtbl.clear mapping; - retStmt := dummyStmt; - List.iter - (fun vi -> - if isOutType vi.vtype || isInOutType vi.vtype then begin - let bt = - match vi.vtype with - | TPtr (bt, _) -> bt - | _ -> E.s (E.bug "expected ptr type\n") - in - let vi' = makeLocalVar fd (vi.vname ^ "_local") bt in - Hashtbl.replace mapping vi.vname vi'; - retInstrs := Set ((Mem (Lval (var vi)), NoOffset), Lval (var vi'), - locUnknown) :: !retInstrs; - if isInOutType vi.vtype then - instrs := Set (var vi', Lval (Mem (Lval (var vi)), NoOffset), - locUnknown) :: !instrs - end) - fd.sformals; - let replace fd = - fd.sbody <- mkBlock [mkStmt (Instr !instrs); mkStmt (Block fd.sbody)]; - fd - in - retStmt := mkStmt (Instr !retInstrs); - ChangeDoChildrenPost (fd, replace) - - method vstmt (stmt : stmt) = - match stmt.skind with - (* - TODO - | Return _ when !retStmt != dummyStmt -> - let replace stmt = - mkStmt (Block (mkBlock [!retStmt; stmt])) - in - ChangeDoChildrenPost (stmt, replace) - *) - | _ -> - DoChildren - - method vinst (inst : instr) = - match inst with - | Call (ret, fn, args, attrs) -> - let newArgs = - Util.list_map - (fun arg -> - match arg with - | Lval (Var vi, NoOffset) when Hashtbl.mem mapping vi.vname -> - AddrOf (var (Hashtbl.find mapping vi.vname)) - | _ -> arg) - args - in - ChangeDoChildrenPost ([Call (ret, fn, newArgs, attrs)], (fun x -> x)) - | _ -> - DoChildren - - method vlval (lv : lval) = - match lv with - | Mem (Lval (Var vi, NoOffset)), NoOffset - when Hashtbl.mem mapping vi.vname -> - ChangeDoChildrenPost (var (Hashtbl.find mapping vi.vname), - (fun x -> x)) - | _ -> - DoChildren -end - -class ptrArithVisitor = object - inherit nopCilVisitor - - method vfunc (fd : fundec) = - prepareCFG fd; - computeCFGInfo fd false; - analyzeFundec fd; - DoChildren -end - -let analyzeFile (f : file) : unit = - ignore (Partial.calls_end_basic_blocks f); - ignore (Partial.globally_unique_vids f); - globals := f.globals; - visitCilFile (new preVisitor) f; - visitCilFile (new outVisitor) f; - visitCilFile (new ptrArithVisitor) f; - verifiedExps := Util.list_map fst expStats.verified; - verifiedArgs := Util.list_map fst argStats.verified; - ignore (E.log "\nCCL Results:\n Derefs: %a\n Args: %a\n\n" - d_stats expStats d_stats argStats); - (* - ignore (E.log "Verified derefs:\n"); - List.iter - (fun (e, l) -> ignore (E.log "%a: %a\n" d_loc l d_exp e)) - expStats.verified; - *) - if !E.hadErrors then - E.s (E.error "Verification failed") - -let feature = - { fd_name = "CCL"; - fd_enabled = false; - fd_description = "CCured Lite"; - fd_extraopt = [ - "--cclverbose", Arg.Set verbose, "Enable verbose output for CCL"; - "--cclsuppress", Arg.Set suppress, "Suppress some CCL warnings"; - ]; - fd_doit = analyzeFile; - fd_post_check = true; - } diff --git a/src/ext/ccl/ccl.mli b/src/ext/ccl/ccl.mli deleted file mode 100644 index ceb344c0c..000000000 --- a/src/ext/ccl/ccl.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * Jeremy Condit - * George C. Necula - * 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. - * - *) - -val verifiedExps: Cil.exp list ref -val verifiedArgs: Cil.exp list ref - -val feature: Feature.t diff --git a/src/ext/cqualann/META b/src/ext/cqualann/META deleted file mode 100644 index b03743dbf..000000000 --- a/src/ext/cqualann/META +++ /dev/null @@ -1 +0,0 @@ -description = "adding assembly annotations for Cqual qualifiers" diff --git a/src/ext/cqualann/cqualann.ml b/src/ext/cqualann/cqualann.ml deleted file mode 100644 index c6cb82922..000000000 --- a/src/ext/cqualann/cqualann.ml +++ /dev/null @@ -1,516 +0,0 @@ - -(* - * "Copyright (c) 2005 The Regents of the University of California. - * All rights reserved. - * - * Permission to use, copy, modify, and distribute this software and its - * documentation for any purpose, without fee, and without written agreement is - * hereby granted, provided that the above copyright notice, the following - * two paragraphs and the author appear in all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR - * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT - * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF - * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO - * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS." - * - * Authors: Matt Harren (matth@cs.berkeley.edu) -*) - - -(* - * Emits assembly annotations for CQual attributes. - * This is only useful to me. -- Matt -*) - -open Cil -open Feature -open Pretty -module E = Errormsg -module H = Hashtbl - -let sensitive_attributes = ["EQ_tainted" ; "LE_tainted" ; - "GE_untainted" ; "EQ_untainted"; - "Poly_tainted" ; "EQ_const"] -let const_attribute = "const" -let tainted_attribute = "EQ_tainted" -let poly_taint_attribute = "Poly_tainted" - -let builtinTLongLong = "builtinTaintedLongLong" -let builtinULongLong = "builtinUntaintedLongLong" - -(* Checks whether the given type has a the "tainted" attribute. - *) -let rec containsSmallocAttribute (t:typ): bool = - (hasAttribute tainted_attribute (typeAttrs t)) - || - (match unrollType t with - | TArray(t, _, _) -> containsSmallocAttribute t - | TComp(ci, _) -> begin - (* recurse on the fields of the struct *) - try - ignore (List.find (fun f -> containsSmallocAttribute f.ftype) - ci.cfields); - true (* iter stops when it finds a match, ie finds an annoted field*) - with Not_found -> false (* if no annotated field exists, throws *) - end - | _ -> false) - -(* Given a type T*, is T tainted? *) -let baseTypeContainsSmallocAttribute (t:typ): bool = - match unrollType t with - | TPtr(bt, _) -> containsSmallocAttribute bt - | _ ->E.s (error "Expecting a pointer type, got %a" d_type t) - - - -(* Clears all "tainted" attributes from all types. Useful since gcc doesn't - * understand the "tainted" attribute and throws warnings. - *) -class smallocClearAttributes (attrnames : string list ) = object - inherit nopCilVisitor - method vattr a = - match a with Attr(attrname, _) -> - if List.mem attrname attrnames then - ChangeTo [] - else - DoChildren -end - - - -let findOrCreateFunc f name t = - let rec search glist = - match glist with - GVarDecl(vi,_) :: rest when isFunctionType vi.vtype - && vi.vname = name -> vi - | _ :: rest -> search rest (* tail recursive *) - | [] -> (*not found, so create one *) - let new_decl = makeGlobalVar name t in - f.globals <- GVarDecl(new_decl, locUnknown) :: f.globals; - new_decl - in - search f.globals - -let stringOf (i:int): string = Int32.to_string (Int32.of_int i) - -let arrayLen eo : int = - try - lenOfArray eo - with LenOfArray -> E.s (unimp "array without a size") - -(* flatten nested arrays *) -let rec getSize t: int * typ = - match unrollType t with - TArray(bt, e, _) -> - let mylen = arrayLen e in - let len', bt' = getSize bt in - (mylen*len'), bt' - | _ -> 1, t - - -(* exception Unimp *) -let uniqueUnimplLabel = ref 0 -let unimplementedT t = - ignore (warn "Can't annotate unimplemented type: %a (Attrs: %a)" - d_type t d_attrlist (typeAttrs t)); -(* raise Unimp *) - incr uniqueUnimplLabel; - text "unimplemented" ++ num !uniqueUnimplLabel - -let rec encodeType (t:typ): doc = - let unimplemented () = unimplementedT t in - let makeType str ty: doc = - chr '(' ++ text str ++ chr ' ' ++ ty ++ chr ')' - in - let a = typeAttrs t in - let addTaint t' = - if hasAttribute tainted_attribute a then - makeType "tainted" t' - else begin - match filterAttributes poly_taint_attribute a with - [] -> makeType "untainted" t' - | [Attr(s, [AStr varname])] -> - text "(poly " ++ text varname ++ chr ' ' ++ t' ++ chr ')' - | _ -> - E.s (error "bad attributes in %a." d_plaintype t) - end - in - match unrollType t with - TInt _ as t' when bitsSizeOf t' = 32 -> (*int, uint, long, ulong*) - addTaint (text "int") - | TInt _ as t' when bitsSizeOf t' = 8 -> addTaint (text "char") - | TInt _ as t' when bitsSizeOf t' = 16 -> addTaint (text "short") - | TInt _ as t' when bitsSizeOf t' = 64 -> (* long long *) - if hasAttribute tainted_attribute a then - text builtinTLongLong - else - text builtinULongLong - | TComp(ci, _) when ci.cstruct -> - text ci.cname - | TFun _ -> encodeFuncType t - | TVoid _ -> text "void" - | TPtr(bt, _) -> begin - let bt' = encodeType bt in - addTaint (makeType "ptr" bt') - end - | _ -> - unimplemented () - -and encodeFuncType = function - TFun(rt, args, va, a) -> - (* FIXME: varargs *) - if va then - ignore (warn "vararg functions unimplemented."); - if a <> [] then - ignore (warn "function attributes unimplemented."); - let params: doc = - docList ~sep:(chr ' ') (fun (_, t, _) -> - encodeType t) - () (argsToList args) - in - let rt' = - if bitsSizeOf rt > 32 then begin - E.log "The Cqual verifier doesn't currently support multi-word return values."; - unimplementedT rt - end - else encodeType rt - in - text "(func " ++ rt' ++ chr ' ' ++ params ++ chr ')' - | _ -> - E.s (bug "nonfunc in encodeFuncType") - - -(* For arrays inside structs, unroll them into "len" different fields *) -(* FIXME: this doesn't work well for variable access *) -let encodeArrayType (fieldName:string) (t:typ) = - if not (isArrayType t) then - E.s (bug " non-array passed to encodeArrayType"); - let len, bt = getSize t in - let acc: doc list ref = ref [] in - let typestr = encodeType bt in - for i = len - 1 downto 0 do - let d = dprintf ", \"%s%d\", %a" fieldName i insert typestr in - acc := d::!acc - done; - (docList ~sep:nil (fun x -> x) () !acc) - - -(******* Annotation macros *****************************************) - -let quoted s: string = - "\"" ^ s ^ "\"" - -(* Like quoted, but prepends _ to identifiers if Cil.underscore_name is true.*) -let quotedLabel s: doc = - if !Cil.underscore_name then - text ("\"_" ^ s ^ "\"") - else - text ("\"" ^ s ^ "\"") - -let strOf (d:doc):string = - sprint 1024 d - - -let globalAnn label args: global = - let annstr = "#ANN(" ^ label ^", " ^ (strOf args) ^")" in - GAsm(annstr, !currentLoc) - -let volatile = [Attr("volatile", [])] - -let isAllocFun (vf:varinfo) : bool = - vf.vname = "malloc" || vf.vname = "calloc" || vf.vname = "realloc" - - -let localVarAnn label func v typ sz: instr = - (*combine the function name and the var name *) - let vname = quotedLabel (func.svar.vname ^ ":" ^ v.vname) in - (* FIXME: are the input/outputs right? *) - let annstr = dprintf "#ANN(%s, %a, %a, %d, %%0)" - label insert vname insert typ sz - in - let lv = if isArrayType v.vtype then - (Var v, Index(Cil.zero, NoOffset)) - else - (Var v, NoOffset) - in - Asm([], [strOf annstr], [None, "=m", lv], - (* ["0", Lval(lv)] *) - [], [], !currentLoc) - - - - -let structANN = "ANN_STRUCT" -let funcANN = "ANN_FUNC" (* A func that is declared or defined *) -let rootANN = "ANN_ROOT" (* A func that is defined *) -let globalANN = "ANN_GLOBAL" -let globalarrayANN = "ANN_GLOBALARRAY" - -let allocANN = "ANN_ALLOC" -let localANN = "ANN_LOCAL" -(* let localarrayANN = "ANN_LOCALARRAY" *) - -let allocAnn typeStr: instr = - let annstr = dprintf "#ANN(%s, %a)" allocANN insert typeStr in - Asm(volatile, [strOf annstr], [], [], [], !currentLoc) - -(******* Strings *******) - -let newGlobals = ref [] - -let stringId = ref 0 -let newStringName () = - incr stringId; - "__string" ^ (string_of_int !stringId) - -let taintedChar = typeAddAttributes [Attr(tainted_attribute, [])] charType - -let global4String (s : string) (charIsTainted: bool): exp = - let l = 1 + (String.length s) in - let stringInit = - let initl' = ref [] in - let idx = ref 0 in - String.iter (fun c -> - let i = (Index(integer !idx, NoOffset), - SingleInit(Const(CChr c))) in - incr idx; - initl' := i::!initl') s; - initl' := (Index(integer l, NoOffset), - SingleInit(integer 0)) :: !initl'; - List.rev !initl' - in - let bt = if charIsTainted then taintedChar else charType in - let newt = TArray(bt, Some (integer l), []) in - let gvar = makeGlobalVar (newStringName ()) newt in - gvar.vstorage <- Static; - let start = AddrOf (Var gvar, Index(zero, NoOffset)) in - let init = CompoundInit(newt, stringInit) in - newGlobals := (GVar (gvar, {init=Some init}, !currentLoc))::!newGlobals; - start - -class stringVisitor -= object(self) - inherit nopCilVisitor - - method vexpr e = begin - match e with - Const(CStr s) -> -(* ignore (E.log "String without cast: %a\n" d_plainexp e); *) - ChangeTo(global4String s false) - | CastE(t, Const(CStr s)) -> - let taint = baseTypeContainsSmallocAttribute t in -(* ignore (E.log "%stainted String: %a\n" *) -(* (if taint then "" else "Un") d_plainexp e); *) - ChangeTo(CastE(t, global4String s taint)) - | _ -> DoChildren - end -end -(******* Visitor *******) - - -let startsWith s prefix = - let n = String.length prefix in - (String.length s >= n) && ((Str.first_chars s n) = prefix) - -let annotatedFunctions: (varinfo, unit) H.t = H.create 19 -let annotateFundec fv = - if H.mem annotatedFunctions fv then - None - else begin - H.add annotatedFunctions fv (); - let fname = fv.vname in - let ftype = encodeFuncType fv.vtype in - let typestr = quotedLabel fname ++ text ", " ++ ftype in - let ann = globalAnn funcANN typestr in - Some ann - end - -class annotationVisitor -= object(self) - inherit nopCilVisitor - - val mutable currentFunction: fundec = Cil.dummyFunDec - - method vvdec v = begin -(* FIXME: if maybeStack v.vattr then begin *) -(* assert (not v.vglob); *) -(* (\* For a local, this flag would only be set if we take the address of v, *) -(* right? *\) *) -(* (\* ignore (E.log " We take the address of %s.\n" v.vname); *\) *) -(* let t = encodeType v.vtype in *) -(* self#queueInstr *) -(* [localVarAnn ccuredlocal currentFunction v (quoted t)]; *) -(* () *) -(* end *) -(* else *) - if not v.vglob then begin - if isArrayType v.vtype || v.vaddrof then begin - match v.vtype with - TArray (bt, Some size, a) -> - let size' = getInteger (constFold true size) in - if size' = None then E.s (error "Non-constant array size"); - let size'' = (cilint_to_int (Util.valOf size')) - * (bitsSizeOf bt / 8) in - let typestr = encodeType bt in - self#queueInstr - [localVarAnn localANN currentFunction v typestr size'']; - () - | TArray _ -> E.s (unimp "array without a size") - | _ -> - let size = (bitsSizeOf v.vtype) / 8 in - let typestr = encodeType v.vtype in - self#queueInstr - [localVarAnn localANN currentFunction v typestr size]; - () - end - end; - DoChildren - end - - method vinst i = begin - match i with - Call (Some dest, Lval(Var vf, NoOffset), _, _) when (isAllocFun vf) - && not (isVoidPtrType (typeOfLval dest)) -> - begin - let t = encodeType (typeOfLval dest) in - self#queueInstr [allocAnn t]; - DoChildren - end - | _ -> DoChildren - end - - method vglob g = begin - try - match g with - GFun (fdec, l) -> - currentFunction <- fdec; - (* Step 1: declare the function signature *) - - let anno = annotateFundec fdec.svar in - let rootAnn = globalAnn rootANN - (quotedLabel fdec.svar.vname) in - let newG = match anno with - Some ann -> [ann; rootAnn; g] - | None -> [rootAnn; g] - in - ChangeDoChildrenPost( - newG, - (fun g -> currentFunction <- Cil.dummyFunDec; g) - ) - | GVarDecl (vi, l) - when isFunctionType vi.vtype (* && vi.vname <> "__ccuredInit" *) -> - begin - let anno = annotateFundec vi in - match anno with - Some ann -> ChangeDoChildrenPost( [ann; g],(fun g -> g)) - | None -> DoChildren - end - | GCompTag (ci, l) -> - if ci.cname = "printf_arguments" then begin - ignore (warn "skipping \"%s\"" ci.cname ); - DoChildren - end - else if ci.cstruct then begin - (* ignore (E.log "printing struct \"%s\"\n" ci.cname ); *) - let annstr = ref (text (quoted ci.cname)) in - List.iter - (fun fi -> - if fi.fname = Cil.missingFieldName then - E.s (unimp "not a real field? in %a" d_global g); - if isArrayType fi.ftype then - annstr := !annstr ++ encodeArrayType fi.fname fi.ftype - else begin - let typestr = encodeType fi.ftype in - annstr := !annstr ++ text ", " ++ text (quoted fi.fname) - ++ text ", " ++ typestr - end) - ci.cfields; - let ann = globalAnn structANN !annstr in - ChangeDoChildrenPost( - [ann; g], - (fun g -> g) - ) - end - else begin - ignore (unimplementedT (TComp(ci,[]))); - SkipChildren - end - | GVar (vi, _, l) -> - (* ignore (E.log "annotating %s: %a\n" vi.vname d_type vi.vtype); *) - (match vi.vtype with - TArray(bt, leno, a) when (bitsSizeOf bt) < 32 -> - (* FIXME: hack for chars. Expand this array so its - length is a multiple of 4. *) - let len = arrayLen leno in - let len' = ((len + 3) / 4) * 4 in - assert (len'>=len && len' ()); - let ann = - match vi.vtype with - TArray _ -> - let size, bt = getSize vi.vtype in - globalAnn globalarrayANN - (dprintf "%a, %a, %d" - insert (quotedLabel vi.vname) - insert (encodeType bt) - size) - | TFun _ -> E.s (bug "Use GVarDecl for function prototypes.") - | _ -> globalAnn globalANN (quotedLabel vi.vname - ++ text ", " - ++ encodeType vi.vtype) - in - ChangeDoChildrenPost( - [ann; g], - (fun g -> g) - ) - | _ -> - DoChildren - with e -> - (* DoChildren *) - raise e - end - -end - - -(**** Entry point to the transformation ****) - -let entry_point (f : file) = - ignore (E.log "Annotating function parameters.\n"); - let longlongU = - globalAnn structANN - (text "\"builtinUntaintedLongLong\", \"q1\", (untainted int), \"q2\", (untainted int)") in - let longlongT = - globalAnn structANN - (text "\"builtinTaintedLongLong\", \"q1\", (tainted int), \"q2\", (tainted int)") in - newGlobals := [longlongU; longlongT]; - visitCilFileSameGlobals (new stringVisitor :>cilVisitor) f; - f.globals <- Util.list_append !newGlobals f.globals; - visitCilFile (new annotationVisitor :>cilVisitor) f; - visitCilFileSameGlobals (new smallocClearAttributes sensitive_attributes ) f; - () - - - -(*********************** - * The Cil.featureDesc that tells the CIL front-end how to call this module. - * This is the only value that needs to be exported from smalloc.ml. **) - -let feature = - { fd_name = "CqualAnn"; - fd_enabled = false; - fd_description = "adding assembly annotations for Cqual qualifiers." ; - fd_extraopt = [ "--doCollapseCallCast", - Arg.Set Cabs2cil.doCollapseCallCast, - "use this flag to improve handling of malloc" ]; - fd_doit = entry_point; - fd_post_check = true - } - diff --git a/src/ext/dataslicing/dataslicing.ml b/src/ext/dataslicing/dataslicing.ml index 2083c4704..3681cd35b 100644 --- a/src/ext/dataslicing/dataslicing.ml +++ b/src/ext/dataslicing/dataslicing.ml @@ -1,10 +1,10 @@ (* * - * Copyright (c) 2004, + * Copyright (c) 2004, * Jeremy Condit * George C. Necula * All rights reserved. - * + * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: @@ -35,7 +35,6 @@ *) open Cil open Feature -open Pretty module E = Errormsg let debug = false @@ -111,7 +110,7 @@ let rec sliceCompInfo (i : int) (cinfo : compinfo) : compinfo = Hashtbl.find compInfos (i, cinfo.ckey) with Not_found -> mkCompInfo cinfo.cstruct (regionStruct i cinfo.cname) - (fun cinfo' -> + (fun cinfo' -> Hashtbl.add compInfos (i, cinfo.ckey) cinfo'; List.fold_right (fun finfo rest -> @@ -424,11 +423,11 @@ let sliceGlobalVars (g : global) : unit = class dropAttrsVisitor = object inherit nopCilVisitor - method vvrbl (vinfo : varinfo) = + method! vvrbl (vinfo : varinfo) = vinfo.vattr <- dropAttribute "var_sliced" vinfo.vattr; DoChildren - method vglob (g : global) = + method! vglob (g : global) = begin match g with | GCompTag (cinfo, _) -> @@ -445,13 +444,13 @@ let sliceFile (f : file) : unit = f.globals <- List.rev !newGlobals; visitCilFile (new dropAttrsVisitor) f -let feature = +let feature = { fd_name = "DataSlicing"; fd_enabled = false; fd_description = "data slicing"; fd_extraopt = []; fd_doit = sliceFile; fd_post_check = true; - } + } let () = Feature.register feature diff --git a/src/ext/dataslicing/dune b/src/ext/dataslicing/dune new file mode 100644 index 000000000..7d30bfcea --- /dev/null +++ b/src/ext/dataslicing/dune @@ -0,0 +1,6 @@ +(library + (public_name goblint-cil.dataslicing) + (name dataslicing) + (wrapped false) ; this should be changed, but then module paths in goblint need to be prefixed + (libraries goblint-cil stdlib-shims) +) diff --git a/src/ext/dune b/src/ext/dune new file mode 100644 index 000000000..ff757cb8c --- /dev/null +++ b/src/ext/dune @@ -0,0 +1 @@ +(include_subdirs no) diff --git a/src/ext/epicenter/META b/src/ext/epicenter/META deleted file mode 100644 index 87ce435b1..000000000 --- a/src/ext/epicenter/META +++ /dev/null @@ -1,2 +0,0 @@ -requires = "cil.callgraph" -description = "remove all functions except those within some number" diff --git a/src/ext/epicenter/default b/src/ext/epicenter/default deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/ext/epicenter/epicenter.ml b/src/ext/epicenter/epicenter.ml deleted file mode 100644 index fd4fd2b72..000000000 --- a/src/ext/epicenter/epicenter.ml +++ /dev/null @@ -1,115 +0,0 @@ -(* epicenter.ml *) -(* code for epicenter.mli *) - -(* module maintainer: scott *) -(* see copyright at end of this file *) - -open Callgraph -open Cil -open Feature -open Trace -open Pretty -module H = Hashtbl -module IH = Inthash - -let sliceFile (f:file) (epicenter:string) (maxHops:int) : unit = - (* compute the static call graph *) - let graph:callgraph = (computeGraph f) in - - (* will accumulate here the set of names of functions already seen *) - let seen: (string, unit) H.t = (H.create 117) in - - (* when removing "unused" symbols, keep all seen functions *) - let isRoot : global -> bool = function - | GFun ({svar = {vname = vname}}, _) -> - H.mem seen vname - | _ -> - false - in - - (* recursive depth-first search through the call graph, finding - * all nodes within 'hops' hops of 'node' and marking them to - * to be retained *) - let rec dfs (node:callnode) (hops:int) : unit = - (* only recurse if we haven't already marked this node *) - if not (H.mem seen (nodeName node.cnInfo)) then - begin - (* add this node *) - H.add seen (nodeName node.cnInfo) (); - trace "epicenter" (dprintf "will keep %s\n" (nodeName node.cnInfo)); - - (* if we cannot do any more hops, stop *) - if (hops > 0) then - - (* recurse on all the node's callers and callees *) - let recurse _ (adjacent:callnode) : unit = - (dfs adjacent (hops - 1)) - in - IH.iter recurse node.cnCallees; - IH.iter recurse node.cnCallers - end - in - dfs (Hashtbl.find graph epicenter) maxHops; - - (* finally, throw away anything we haven't decided to keep *) - Cilutil.sliceGlobal := true; - Rmtmps.removeUnusedTemps ~isRoot:isRoot f - -let epicenterName = ref "" -let epicenterHops = ref 0 - -let feature = - { fd_name = "epicenter"; - fd_enabled = false; - fd_description = "remove all functions except those within some number" ^ - "\n\t\t\t\tof hops (in the call graph) from a given function"; - fd_extraopt = - [ - ("--epicenter-name", - Arg.String (fun s -> epicenterName := s), - " do an epicenter slice starting from function "); - ("--epicenter-hops", Arg.Int (fun n -> epicenterHops := n), - " specify max # of hops for epicenter slice"); - ]; - - fd_doit = - (fun f -> - sliceFile f !epicenterName !epicenterHops); - - fd_post_check = true; - } - -let () = Feature.register feature - -(* - * - * Copyright (c) 2001-2002 by - * George C. Necula necula@cs.berkeley.edu - * Scott McPeak smcpeak@cs.berkeley.edu - * Wes Weimer weimer@cs.berkeley.edu - * Ben Liblit liblit@cs.berkeley.edu - * - * All rights reserved. Permission to use, copy, modify and distribute - * this software for research purposes only is hereby granted, - * provided that the following conditions are met: - * 1. XSRedistributions 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 name of the authors may not be used to endorse or promote products - * derived from this software without specific prior written permission. - * - * DISCLAIMER: - * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. - * - *) diff --git a/src/ext/heapify/META b/src/ext/heapify/META deleted file mode 100644 index 613a1dc28..000000000 --- a/src/ext/heapify/META +++ /dev/null @@ -1 +0,0 @@ -description = "maintain a separate stack for return addresses" diff --git a/src/ext/heapify/default b/src/ext/heapify/default deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/ext/heapify/heapify.ml b/src/ext/heapify/heapify.ml deleted file mode 100644 index fbe6beca5..000000000 --- a/src/ext/heapify/heapify.ml +++ /dev/null @@ -1,252 +0,0 @@ -(* - * - * 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. - * - *) - -(* - * Heapify: a program transform that looks over functions, finds those - * that have local (stack) variables that contain arrays, puts all such - * local variables into a single heap allocated structure, changes all - * accesses to such variables into accesses to fields of that structure - * and frees the structure on return. - *) -open Cil -open Feature - -(* utilities that should be in Cil.ml *) -(* sfg: this function appears to never be called *) -let mkSimpleField ci fn ft fl = - { fcomp = ci ; fname = fn ; ftype = ft ; fbitfield = None ; fattr = []; - floc = fl } - - -(* actual Heapify begins *) - -let heapifyNonArrays = ref false - -(* Does this local var contain an array? *) -let rec containsArray (t:typ) : bool = (* does this type contain an array? *) - match unrollType t with - TArray _ -> true - | TComp(ci, _) -> (* look at the types of the fields *) - List.exists (fun fi -> containsArray fi.ftype) ci.cfields - | _ -> - (* Ignore other types, including TInt and TPtr. We don't care whether - there are arrays in the base types of pointers; only about whether - this local variable itself needs to be moved to the heap. *) - false - - -class heapifyModifyVisitor big_struct big_struct_fields varlist free - (currentFunction: fundec) = object(self) - inherit nopCilVisitor (* visit lvalues and statements *) - method vlval l = match l with (* should we change this one? *) - Var(vi),vi_offset when List.mem_assoc vi varlist -> (* check list *) - let i = List.assoc vi varlist in (* find field offset *) - let big_struct_field = List.nth big_struct_fields i in - let new_lval = Mem(Lval(big_struct, NoOffset)), - Field(big_struct_field,vi_offset) in (* rewrite the lvalue *) - ChangeDoChildrenPost(new_lval, (fun l -> l)) - | _ -> DoChildren (* ignore other lvalues *) - method vstmt s = match s.skind with (* also rewrite the return *) - Return(None,loc) -> - let free_instr = Call(None,free,[Lval(big_struct,NoOffset)],loc) in - self#queueInstr [free_instr]; (* insert free_instr before the return *) - DoChildren - | Return(Some exp ,loc) -> - (* exp may depend on big_struct, so evaluate it before calling free. - * This becomes: tmp = exp; free(big_struct); return tmp; *) - let exp_new = visitCilExpr (self :> cilVisitor) exp in - let ret_tmp = makeTempVar currentFunction (typeOf exp_new) in - let eval_ret_instr = Set(var ret_tmp, exp_new, loc) in - let free_instr = Call(None,free,[Lval(big_struct,NoOffset)],loc) in - (* insert the instructions before the return *) - self#queueInstr [eval_ret_instr; free_instr]; - s.skind <- (Return(Some(Lval(var ret_tmp)), loc)); - DoChildren - | _ -> DoChildren (* ignore other statements *) -end - -class heapifyAnalyzeVisitor f alloc free = object - inherit nopCilVisitor (* only look at function bodies *) - method vglob gl = match gl with - GFun(fundec,funloc) -> - let counter = ref 0 in (* the number of local vars containing arrays *) - let varlist = ref [] in (* a list of (var,id) pairs, in reverse order *) - List.iter (fun vi -> - (* find all local vars with arrays. If the user requests it, - we also look for non-array vars whose address is taken. *) - if (containsArray vi.vtype) || (vi.vaddrof && !heapifyNonArrays) - then begin - varlist := (vi,!counter) :: !varlist ; (* add it to the list *) - incr counter (* put the next such var in the next slot *) - end - ) fundec.slocals ; - if (!varlist <> []) then begin (* some local vars contain arrays *) - let name = (fundec.svar.vname ^ "_heapify") in - let ci = mkCompInfo true name (* make a big structure *) - (fun _ -> List.rev_map (* reverse the list to fix the order *) - (* each local var becomes a field *) - (fun (vi,i) -> vi.vname,vi.vtype,None,[],vi.vdecl) !varlist) [] in - let vi = makeLocalVar fundec name (TPtr(TComp(ci,[]),[])) in - let modify = new heapifyModifyVisitor (Var(vi)) ci.cfields - !varlist free fundec in (* rewrite accesses to local vars *) - fundec.sbody <- visitCilBlock modify fundec.sbody ; - let alloc_stmt = mkStmt (* allocate the big struct on the heap *) - (Instr [Call(Some(Var(vi),NoOffset), alloc, - [SizeOf(TComp(ci,[]))],funloc)]) in - fundec.sbody.bstmts <- alloc_stmt :: fundec.sbody.bstmts ; - fundec.slocals <- List.filter (fun vi -> (* remove local vars *) - not (List.mem_assoc vi !varlist)) fundec.slocals ; - let typedec = (GCompTag(ci,funloc)) in (* declare the big struct *) - ChangeTo([typedec ; GFun(fundec,funloc)]) (* done! *) - end else - DoChildren (* ignore everything else *) - | _ -> DoChildren -end - -let heapify (f : file) (alloc : exp) (free : exp) = - visitCilFile (new heapifyAnalyzeVisitor f alloc free) f; - f - -(* heapify code ends here *) - -let default_heapify (f : file) = - let alloc_fun = emptyFunction "malloc" in - let free_fun = emptyFunction "free" in - let alloc_exp = (Lval((Var(alloc_fun.svar)),NoOffset)) in - let free_exp = (Lval((Var(free_fun.svar)),NoOffset)) in - ignore (heapify f alloc_exp free_exp) - -(* StackGuard clone *) - -class sgModifyVisitor restore_ra_stmt = object - inherit nopCilVisitor - method vstmt s = match s.skind with (* also rewrite the return *) - Return(_,loc) -> let new_block = mkBlock [restore_ra_stmt ; s] in - ChangeTo(mkStmt (Block(new_block))) - | _ -> DoChildren (* ignore other statements *) -end - -class sgAnalyzeVisitor f push pop get_ra set_ra = object - inherit nopCilVisitor - method vfunc fundec = - let needs_guarding = List.fold_left - (fun acc vi -> acc || containsArray vi.vtype) - false fundec.slocals in - if needs_guarding then begin - let ra_tmp = makeLocalVar fundec "return_address" voidPtrType in - let ra_exp = Lval(Var(ra_tmp),NoOffset) in - let save_ra_stmt = mkStmt (* save the current return address *) - (Instr [Call(Some(Var(ra_tmp),NoOffset), get_ra, [], locUnknown) ; - Call(None, push, [ra_exp], locUnknown)]) in - let restore_ra_stmt = mkStmt (* restore the old return address *) - (Instr [Call(Some(Var(ra_tmp),NoOffset), pop, [], locUnknown) ; - Call(None, set_ra, [ra_exp], locUnknown)]) in - let modify = new sgModifyVisitor restore_ra_stmt in - fundec.sbody <- visitCilBlock modify fundec.sbody ; - fundec.sbody.bstmts <- save_ra_stmt :: fundec.sbody.bstmts ; - ChangeTo(fundec) (* done! *) - end else DoChildren -end - -let stackguard (f : file) (push : exp) (pop : exp) - (get_ra : exp) (set_ra : exp) = - visitCilFileSameGlobals (new sgAnalyzeVisitor f push pop get_ra set_ra) f; - f - (* stackguard code ends *) - -let default_stackguard (f : file) = - let expify fundec = Lval(Var(fundec.svar),NoOffset) in - let push = expify (emptyFunction "stackguard_push") in - let pop = expify (emptyFunction "stackguard_pop") in - let get_ra = expify (emptyFunction "stackguard_get_ra") in - let set_ra = expify (emptyFunction "stackguard_set_ra") in - let global_decl = -"extern void * stackguard_get_ra(); -extern void stackguard_set_ra(void *new_ra); -/* You must provide an implementation for functions that get and set the - * return address. Such code is unfortunately architecture specific. - */ -struct stackguard_stack { - void * data; - struct stackguard_stack * next; -} * stackguard_stack; - -void stackguard_push(void *ra) { - void * old = stackguard_stack; - stackguard_stack = (struct stackguard_stack *) - malloc(sizeof(stackguard_stack)); - stackguard_stack->data = ra; - stackguard_stack->next = old; -} - -void * stackguard_pop() { - void * ret = stackguard_stack->data; - void * next = stackguard_stack->next; - free(stackguard_stack); - stackguard_stack->next = next; - return ret; -}" in - f.globals <- GText(global_decl) :: f.globals ; - ignore (stackguard f push pop get_ra set_ra ) - - -let feature1 = - { fd_name = "stackGuard"; - fd_enabled = false; - fd_description = "instrument function calls and returns to maintain a\n\t\t\t\tseparate stack for return addresses" ; - fd_extraopt = []; - fd_doit = (function (f: file) -> default_stackguard f); - fd_post_check = true; - } -let feature2 = - { fd_name = "heapify"; - fd_enabled = false; - fd_description = "move stack-allocated arrays to the heap" ; - fd_extraopt = [ - "--heapifyAll", Arg.Set heapifyNonArrays, - " When using heapify, move all local vars whose address is taken,\n\t\t\t\tnot just arrays."; - ]; - fd_doit = (function (f: file) -> default_heapify f); - fd_post_check = true; - } - -let () = Feature.register feature1 -let () = Feature.register feature2 - - - - diff --git a/src/ext/inliner/META b/src/ext/inliner/META deleted file mode 100644 index e662a1531..000000000 --- a/src/ext/inliner/META +++ /dev/null @@ -1 +0,0 @@ -description = "inline function calls" diff --git a/src/ext/inliner/inliner.ml b/src/ext/inliner/inliner.ml deleted file mode 100644 index 909b432de..000000000 --- a/src/ext/inliner/inliner.ml +++ /dev/null @@ -1,446 +0,0 @@ -(* - * - * Copyright (c) 2007, - * George C. Necula - * 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. - * - *) - - -(** This module provides inlining functions. You can run it from the cilly - * command line by passing the names of the functions to inline: - * - * cilly --save-temps --inline=toinline module.c - * - * This module has not been tested extensively, so you should run it with - * the --check argument to ensure that it does not break any CIL invariants - * - * - * You can also call directly the [doFile] and [doFunction] functions. - - *) - -open Pretty -open Cil -open Feature -module E = Errormsg -module H = Hashtbl -module IH = Inthash -module A = Alpha - -let debug = true - -exception Recursion (* Used to signal recursion *) - -(* A visitor that makes a deep copy of a function body for use inside a host - * function, replacing duplicate labels, returns, etc. *) -class copyBodyVisitor (host: fundec) (* The host of the - * inlining *) - (inlining: varinfo) (* Function being - * inlined *) - (replVar: varinfo -> varinfo) (* Maps locals of the - * inlined function - * to locals of the - * host *) - (retlval: varinfo option) (* The destination - * for the "return" *) - (replLabel: string -> string) - (* A renamer for - * labels *) - (retlab: stmt) (* The label for the - * return *) - = object (self) - inherit nopCilVisitor - - (* Keep here a maping from statements to their copies, indexed by their - * original ID *) - val stmtmap : stmt IH.t = IH.create 113 - - (* Keep here a list of statements to be patched *) - val patches : stmt list ref = ref [] - - val argid = ref 0 - - (* This is the entry point *) - method vfunc (f: fundec) : fundec visitAction = - let patchfunction (f' : fundec) = - let findStmt (i: int) = - try IH.find stmtmap i - with Not_found -> E.s (bug "Cannot find the copy of stmt#%d" i) - in - E.log "Patching gotos\n"; - let patchstmt (s: stmt) = - match s.skind with - Goto (sr, l) -> - if debug then - E.log "patching goto\n"; - (* Make a copy of the reference *) - let sr' = ref (findStmt !sr.sid) in - s.skind <- Goto (sr',l) - | Switch (e, body, cases, l) -> - s.skind <- Switch (e, body, - Util.list_map (fun cs -> findStmt cs.sid) cases, l) - | _ -> () - in - List.iter patchstmt !patches; - f' - in - patches := []; - IH.clear stmtmap; - ChangeDoChildrenPost (f, patchfunction) - - (* We must replace references to local variables *) - method vvrbl (v: varinfo) = - if v.vglob then - SkipChildren - else - let v' = replVar v in - if v == v' then - SkipChildren - else - ChangeTo v' - - - method vinst (i: instr) = - match i with - Call (_, Lval (Var vi, _), _, _) when vi.vid == inlining.vid -> - raise Recursion - - | _ -> DoChildren - - (* Replace statements. *) - method vstmt (s: stmt) : stmt visitAction = - (* There is a possibility that we did not have the statements IDed - * propertly. So, we change the ID even on the replaced copy so that we - * can index on them ! *) - (match host.smaxstmtid with - Some id -> - s.sid <- 1 + id - | None -> - s.sid <- 1); - (* Copy and change ID *) - let s' = {s with sid = s.sid} in - host.smaxstmtid <- Some s'.sid; - - IH.add stmtmap s.sid s'; (* Remember where we copied this statement *) - (* if we have a Goto or a Switch remember them to fixup at end *) - (match s'.skind with - (Goto _ | Switch _) -> - E.log "Found goto\n"; - patches := s' :: !patches - | _ -> ()); - - (* Change the returns *) - let postProc (s': stmt) : stmt = - (* Rename the labels if necessary *) - s'.labels <- - Util.list_map (fun lb -> - match lb with - Label (n, l, fromsrc) -> Label(replLabel n, l, fromsrc) - | _ -> lb) s'.labels; - - (* Now deal with the returns *) - (match s'.skind with - | Return (ro, l) -> begin - (* Change this into an assignment followed by a Goto *) - match ro, retlval with - _, None -> (* Function called with no return lval *) - s'.skind <- Goto (ref retlab, l) - - | None, _ -> - ignore (warn "Found return without value in inlined function"); - s'.skind <- Goto (ref retlab, l) - - | Some rv, Some retvar-> - s'.skind <- - Block (mkBlock [ mkStmt (Instr [(Set (var retvar, rv, l))]); - mkStmt (Goto (ref retlab, l)) ]) - end - | _ -> ()); - s' - in - (* Do the children then postprocess *) - ChangeDoChildrenPost (s', postProc) - - (* Copy blocks since they are mutable *) - method vblock (b: block) = - ChangeDoChildrenPost ({b with bstmts = b.bstmts}, fun x -> x) - - - method vglob _ = E.s (bug "copyFunction should not be used on globals") -end - -(** Replace a statement with the result of inlining *) -let replaceStatement (host: fundec) (* The host *) - (inlineWhat: varinfo -> fundec option) (* What to inline *) - (replLabel: string -> string) (* label - * replacement *) - (anyInlining: bool ref) (* will set this - * to true if we - * did any - * inlining *) - (s: stmt) : stmt = - match s.skind with - Instr il when il <> [] -> - let prevrstmts: stmt list ref = ref [] in (* Reversed list of previous - * statements *) - let prevrinstr: instr list ref = ref [] in (* Reverse list of previous - * instructions, in this - * statement *) - let emptyPrevrinstr () = - if !prevrinstr <> [] then begin - prevrstmts := mkStmt (Instr (List.rev !prevrinstr)) :: !prevrstmts; - prevrinstr := [] - end - in - - let rec loop (rest: instr list) (* Remaining instructions *) - : unit = - match rest with - [] -> (* Done *) () - - | (Call (lvo, Lval (Var fvi, NoOffset), args, l) as i) :: resti -> begin - if debug then - E.log "Checking whether to inline %s\n" fvi.vname; - let replo: fundec option = - match inlineWhat fvi with - Some repl -> - if repl.svar.vid = host.svar.vid then begin - ignore (warn "Inliner encountered recursion in inlined function %s" - host.svar.vname); - None - end else - Some repl - | None -> None - in - match replo with - | None -> prevrinstr := i :: !prevrinstr; - loop resti - - | Some repl -> begin - anyInlining := true; - E.log "Done inlining\n"; - - (* We must inline *) - (* Prepare the mapping of local variables *) - let vmap : varinfo IH.t = IH.create 13 in - let replVar (vi: varinfo) = - if vi.vglob then vi - else - try IH.find vmap vi.vid - with Not_found -> begin - E.s (bug "Cannot find the new copy of local variable %s" - vi.vname) - end - in - (* Do the actual arguments, and keep extending prevrinstr *) - let rec loopArgs (args: exp list) (formals: varinfo list) = - match args, formals with - [], [] -> () - | (a :: args'), (f :: formals') -> begin - (* We must copy the argument even if it is already a - * variable, to obey call by value *) - (* Make a local and a copy *) - let f' = makeTempVar host ~name:f.vname f.vtype in - prevrinstr := (Set (var f', a, l)) :: !prevrinstr; - IH.add vmap f.vid f'; - - loopArgs args' formals' - end - | _, _ -> E.bug "Invalid number of arguments" - in - loopArgs args repl.sformals; - - (* Copy the locals *) - List.iter (fun loc -> - let loc' = makeTempVar host ~name:loc.vname loc.vtype in - IH.add vmap loc.vid loc') repl.slocals; - - - (* Make the return statement *) - let (ret : stmt), (retvar: varinfo option) = - let rt, _, isva, _ = splitFunctionType repl.svar.vtype in - match rt with - TVoid _ -> mkStmt (Instr []), None - | _ -> begin - match lvo with - None -> mkStmt (Instr []), None - | Some lv -> - (* Make a return variable *) - let rv = makeTempVar - host ~name:("ret_" ^ repl.svar.vname) rt in - mkStmtOneInstr (Set (lv, Lval (var rv), l)), Some rv - end - in - ret.labels <- [Label (replLabel ("Lret_" ^ repl.svar.vname), - l, false)]; - let oldBody = repl.sbody in - (* Now replace the body *) - (try - ignore (visitCilFunction - (new copyBodyVisitor host repl.svar replVar - retvar replLabel ret) - repl); - currentLoc := l; - let body' = repl.sbody in - (* Replace the old body in the function to inline *) - repl.sbody <- oldBody; - - emptyPrevrinstr (); - prevrstmts := ret :: (mkStmt (Block body')) :: !prevrstmts - with Recursion -> - ignore (warn "Encountered recursion in function %s" - repl.svar.vname); - prevrinstr := i :: !prevrinstr); - - loop resti - end - end - | i :: resti -> - prevrinstr := i :: !prevrinstr; - loop resti - in - loop il; - - emptyPrevrinstr (); - if List.length !prevrstmts > 1 then - s.skind <- Block (mkBlock (List.rev !prevrstmts)); - - s - - | _ -> s - - -(** Apply inlining to a function, modify in place *) -let doFunction (host: fundec) (* The function into which to inline *) - (inlineWhat: varinfo -> fundec option) (* The functions to - * inline, as a - * partial map - * from varinfo to - * body *) - (anyInlining: bool ref) (* Will be set to true - * if any inlining - * took place *) - : unit = - if debug then - E.log "Doing inlining for %s\n" host.svar.vname; - - (* Scan the host function and build the alpha-conversion table for labels *) - let labTable: (string, unit A.alphaTableData ref) H.t = H.create 5 in - ignore (visitCilBlock - (object - inherit nopCilVisitor - method vstmt (s: stmt) = - List.iter - (fun l -> - match l with - Label(ln, _, _) -> - ignore (A.registerAlphaName ~alphaTable:labTable - ~undolist:None ~data:() ~lookupname:ln) - | _ -> ()) - s.labels; - DoChildren - - end) - host.sbody); - (* Now the label replacement function *) - let replLabel (ln: string) : string = - let ln', _ = A.newAlphaName - ~alphaTable:labTable ~undolist:None ~lookupname:ln ~data:() in - ln' - in - (* Now scan the function to do the inlining *) - let body' : block = - visitCilBlock (object - inherit nopCilVisitor - method vstmt (s: stmt) = - ChangeDoChildrenPost (s, - replaceStatement host inlineWhat - replLabel anyInlining) - end) host.sbody in - host.sbody <- body'; - () - - -(** Apply inlining to a whole file *) -let doFile (inlineWhat: varinfo -> fundec option) (* What to inline. See - * comments for [doFunction] *) - (fl: file) = - iterGlobals fl (fun g -> - match g with - GFun(fd, l) -> - (* Keep doing inlining until there is no more. We will catch - * recursion eventually when we want to inline a function into itself*) - let anyInlining = ref true in - while !anyInlining do - anyInlining := false; - doFunction fd inlineWhat anyInlining - done - - | _ -> ()) - - -(* Function names to inline *) -let toinline: string list ref = ref [] -let doit (fl: file) = - (* Scan the file and build the hashtable of functions to inline *) - let inlineTable: (string, fundec) H.t = H.create 5 in - visitCilFile (object - inherit nopCilVisitor - method vfunc (fd: fundec) = - if List.mem fd.svar.vname !toinline then - H.add inlineTable fd.svar.vname fd; - SkipChildren - end) fl; - let inlineWhat (vi: varinfo) : fundec option = - try Some (H.find inlineTable vi.vname) - with Not_found -> None - in - (* Give warnings if we cannot find some fundecs *) - List.iter (fun fn -> - if not (H.mem inlineTable fn) then - ignore (warn "Cannot inline function %s because we cannot find its definition" fn)) - !toinline; - - doFile inlineWhat fl - -let rec feature = - { fd_name = "inliner"; - fd_enabled = false; - fd_description = "inline function calls"; - fd_extraopt = [ - "--inline", Arg.String (fun s -> feature.fd_enabled <- true; - toinline := s :: !toinline), - " inline this function"; - ]; - fd_doit = doit; - fd_post_check = true; - } - diff --git a/src/ext/liveness/dune b/src/ext/liveness/dune new file mode 100644 index 000000000..c29008cfc --- /dev/null +++ b/src/ext/liveness/dune @@ -0,0 +1,6 @@ +(library + (public_name goblint-cil.liveness) + (name liveness) + (wrapped false) ; this should be changed, but then module paths in goblint need to be prefixed + (libraries goblint-cil stdlib-shims) +) diff --git a/src/ext/liveness/liveness.ml b/src/ext/liveness/liveness.ml index b76ce54d3..d1dfbe892 100644 --- a/src/ext/liveness/liveness.ml +++ b/src/ext/liveness/liveness.ml @@ -1,6 +1,6 @@ (* Calculate which variables are live at - * each statememnt. + * each statement. * * * @@ -42,7 +42,7 @@ let live_func = ref "" module VS = UD.VS let debug_print () vs = (VS.fold - (fun vi d -> + (fun vi d -> d ++ text "name: " ++ text vi.vname ++ text " id: " ++ num vi.vid ++ text " ") vs nil) ++ line @@ -64,7 +64,7 @@ module LiveFlow = struct let pretty () vs = let fn = !printer in fn () vs - + let stmtStartData = IH.create 32 let funcExitData = VS.empty @@ -106,7 +106,7 @@ let all_stmts = ref [] class nullAdderClass = object(self) inherit nopCilVisitor - method vstmt s = + method! vstmt s = all_stmts := s :: (!all_stmts); IH.add LiveFlow.stmtStartData s.sid VS.empty; DoChildren @@ -135,7 +135,7 @@ let getLiveSet sid = let getLiveness (s:stmt) = Inthash.find LiveFlow.stmtStartData s.sid -let getPostLiveness (s:stmt) : LiveFlow.t = +let getPostLiveness (s:stmt) : LiveFlow.t = let foldLiveness live s = VS.union live (getLiveness s) in List.fold_left foldLiveness VS.empty s.succs @@ -167,7 +167,7 @@ class livenessVisitorClass (out : bool) = object(self) val mutable cur_liv_dat = None - method vstmt stm = + method! vstmt stm = sid <- stm.sid; match getLiveSet sid with | None -> begin @@ -187,7 +187,7 @@ class livenessVisitorClass (out : bool) = object(self) end end - method vinst i = + method! vinst i = try let data = List.hd liv_dat_lst in cur_liv_dat <- Some(data); @@ -195,7 +195,7 @@ class livenessVisitorClass (out : bool) = object(self) if !debug then E.log "livVis: at %a, data is %a\n" d_instr i debug_print data; DoChildren - with Failure "hd" -> + with Failure _ -> if !debug then E.log "livnessVisitor: il liv_dat_lst mismatch\n"; DoChildren end @@ -219,7 +219,7 @@ class deadnessVisitorClass = object(self) val mutable post_dead_vars = VS.empty val mutable post_live_vars = VS.empty - method vstmt stm = + method! vstmt stm = sid <- stm.sid; match getLiveSet sid with | None -> begin @@ -232,8 +232,8 @@ class deadnessVisitorClass = object(self) | Some vs -> begin let (dead,live) = List.fold_left (fun (dead,live) stm -> - let dvs = - (* things can die in non instr statemnts *) + let dvs = + (* things can die in non instr statements *) match stm.skind with | Instr _ | Block _ -> VS.diff (getPostLiveness stm) vs @@ -259,7 +259,7 @@ class deadnessVisitorClass = object(self) end end - method vinst i = + method! vinst i = try let data = List.hd liv_dat_lst in cur_liv_dat <- Some(data); @@ -274,7 +274,7 @@ class deadnessVisitorClass = object(self) E.log "deadVis: at %a, liveout: %a, inlive: %a, post_dead_vars: %a\n" d_instr i debug_print data debug_print inlive debug_print post_dead_vars; DoChildren - with Failure "hd" -> + with Failure _ -> if !debug then E.log "deadnessVisitor: il liv_dat_lst mismatch\n"; post_dead_vars <- VS.empty; post_live_vars <- VS.empty; @@ -282,8 +282,8 @@ class deadnessVisitorClass = object(self) end let print_everything () = - let d = IH.fold (fun i vs d -> - d ++ num i ++ text ": " ++ LiveFlow.pretty () vs) + let d = IH.fold (fun i vs d -> + d ++ num i ++ text ": " ++ LiveFlow.pretty () vs) LiveFlow.stmtStartData nil in ignore(printf "%t" (fun () -> d)) @@ -296,8 +296,8 @@ let match_label lbl = match lbl with class doFeatureClass = object(self) inherit nopCilVisitor - method vfunc fd = - if String.compare fd.svar.vname (!live_func) = 0 then + method! vfunc fd = + if String.compare fd.svar.vname (!live_func) = 0 then (Cfg.clearCFGinfo fd; ignore(Cfg.cfgFun fd); computeLiveness fd; @@ -308,16 +308,16 @@ class doFeatureClass = object(self) else DoChildren) else SkipChildren - method vstmt s = + method! vstmt s = if List.exists match_label s.labels then try let vs = IH.find LiveFlow.stmtStartData s.sid in (printer := min_print; ignore(printf "%a" LiveFlow.pretty vs); SkipChildren) - with Not_found -> + with Not_found -> if !debug then ignore(E.log "Liveness: stmt: %d not found\n" s.sid); DoChildren - else + else (if List.length s.labels = 0 then if !debug then ignore(E.log "Liveness: no label at sid=%d\n" s.sid); DoChildren) diff --git a/src/ext/liveness/usedef.ml b/src/ext/liveness/usedef.ml index d7fe713c5..e0b9d4725 100644 --- a/src/ext/liveness/usedef.ml +++ b/src/ext/liveness/usedef.ml @@ -1,12 +1,11 @@ open Cil -open Pretty module E = Errormsg (** compute use/def information *) -module VS = Set.Make (struct +module VS = Set.Make (struct type t = Cil.varinfo (* Subtraction is safe since vids are always positive*) let compare v1 v2 = v1.vid - v2.vid @@ -16,25 +15,25 @@ module VS = Set.Make (struct This also returns a modified argument list which will be used for the purpose of Use analysis, in case you have a function that needs special treatment of its args. *) -let getUseDefFunctionRef: (exp -> exp list -> VS.t * VS.t * exp list) ref = +let getUseDefFunctionRef: (exp -> exp list -> VS.t * VS.t * exp list) ref = ref (fun func args -> (VS.empty, VS.empty, args)) (** Say if you want to consider a variable use. This applies to variable reads only; see also considerVariableAddrOfAsUse *) -let considerVariableUse: (varinfo -> bool) ref = +let considerVariableUse: (varinfo -> bool) ref = ref (fun _ -> true) (** Say if you want to consider a variable def *) -let considerVariableDef: (varinfo -> bool) ref = +let considerVariableDef: (varinfo -> bool) ref = ref (fun _ -> true) (** Say if you want to consider a variable addrof as a use *) -let considerVariableAddrOfAsUse: (varinfo -> bool) ref = +let considerVariableAddrOfAsUse: (varinfo -> bool) ref = ref (fun _ -> true) (** Say if you want to consider a variable addrof as a def *) -let considerVariableAddrOfAsDef: (varinfo -> bool) ref = +let considerVariableAddrOfAsDef: (varinfo -> bool) ref = ref (fun _ -> false) (** Return any vars that should be considered "used" by an expression, @@ -59,12 +58,12 @@ let varDefs: VS.t ref = ref VS.empty class useDefVisitorClass : cilVisitor = object (self) inherit nopCilVisitor - - (** this will be invoked on variable definitions only because we intercept + + (** this will be invoked on variable definitions only because we intercept * all uses of variables in expressions ! *) - method vvrbl (v: varinfo) = + method! vvrbl (v: varinfo) = if (!considerVariableDef) v && - not(!onlyNoOffsetsAreDefs) then + not(!onlyNoOffsetsAreDefs) then varDefs := VS.add v !varDefs; if (!considerVariableDef) v && !onlyNoOffsetsAreDefs then @@ -73,11 +72,11 @@ class useDefVisitorClass : cilVisitor = object (self) (** If l is a variable, this means we are in a def, not a use! * Other cases are handled by vexpr. - * + * * If onlyNoOffsetsAreDefs is true, then we need to see the * varinfo in an lval along with the offset. Otherwise just * DoChildren *) - method vlval (l: lval) = + method! vlval (l: lval) = if !onlyNoOffsetsAreDefs then match l with (Var vi, NoOffset) -> @@ -93,22 +92,22 @@ class useDefVisitorClass : cilVisitor = object (self) | _ -> DoChildren else DoChildren - method vexpr (e:exp) = + method! vexpr (e:exp) = let extra = (!extraUsesOfExpr) e in - if not (VS.is_empty extra) then + if not (VS.is_empty extra) then varUsed := VS.union extra !varUsed; match e with - Lval (Var v, off) -> + Lval (Var v, off) -> ignore (visitCilOffset (self :> cilVisitor) off); if (!considerVariableUse) v then begin varUsed := VS.add v !varUsed end; SkipChildren (* So that we do not see the v *) - | AddrOf (Var v, off) - | StartOf (Var v, off) -> + | AddrOf (Var v, off) + | StartOf (Var v, off) -> ignore (visitCilOffset (self :> cilVisitor) off); - if (!considerVariableAddrOfAsUse) v then + if (!considerVariableAddrOfAsUse) v then varUsed := VS.add v !varUsed; if (!considerVariableAddrOfAsDef) v then varDefs := VS.add v !varDefs; @@ -120,15 +119,15 @@ class useDefVisitorClass : cilVisitor = object (self) | _ -> DoChildren (* For function calls, do the transitive variable read/defs *) - method vinst i = + method! vinst i = let doCall f desto args = - (* we will compute the use and def that appear in - * this instruction. We also add in the stuff computed by + (* we will compute the use and def that appear in + * this instruction. We also add in the stuff computed by * getUseDefFunctionRef *) let use, def, args' = !getUseDefFunctionRef f args in varUsed := VS.union !varUsed use; varDefs := VS.union !varDefs def; - + (* Now visit the children of "Call (lvo, f, args', _)" *) let self: cilVisitor = (self :> cilVisitor) in (match desto with None -> () @@ -138,7 +137,7 @@ class useDefVisitorClass : cilVisitor = object (self) SkipChildren in match i with - Call (None, (Lval(Var vi, NoOffset) as f), [valist; SizeOf t; adest], _) + Call (None, (Lval(Var vi, NoOffset) as f), [valist; SizeOf t; adest], _) (* __builtin_va_arg is special: in CIL, the left hand side is stored as the last argument. *) when vi.vname = "__builtin_va_arg" -> @@ -147,10 +146,10 @@ class useDefVisitorClass : cilVisitor = object (self) | _ -> E.s (bug "bad call to %s" vi.vname) in doCall f (Some dest') [valist; SizeOf t] - | Call (_, Lval(Var vi, _), _, _) + | Call (_, Lval(Var vi, _), _, _) when vi.vname = "__builtin_va_arg" -> E.s (bug "bad call to %s" vi.vname) - | Call (lvo, f, args, _) -> + | Call (lvo, f, args, _) -> doCall f lvo args | Asm(_,_,slvl,_,_,_) -> List.iter (fun (_,s,lv) -> match lv with (Var v, off) -> @@ -159,14 +158,14 @@ class useDefVisitorClass : cilVisitor = object (self) | _ -> ()) slvl; DoChildren | _ -> DoChildren - + end -let useDefVisitor = new useDefVisitorClass +let useDefVisitor = new useDefVisitorClass -(** Compute the use information for an expression (accumulate to an existing +(** Compute the use information for an expression (accumulate to an existing * set) *) -let computeUseExp ?(acc=VS.empty) (e: exp) : VS.t = +let computeUseExp ?(acc=VS.empty) (e: exp) : VS.t = varUsed := acc; ignore (visitCilExpr useDefVisitor e); !varUsed @@ -174,24 +173,24 @@ let computeUseExp ?(acc=VS.empty) (e: exp) : VS.t = (** Compute the use/def information for an instruction *) let computeUseDefInstr ?(acc_used=VS.empty) - ?(acc_defs=VS.empty) - (i: instr) : VS.t * VS.t = + ?(acc_defs=VS.empty) + (i: instr) : VS.t * VS.t = varUsed := acc_used; varDefs := acc_defs; ignore (visitCilInstr useDefVisitor i); !varUsed, !varDefs -(** Compute the use/def information for a statement kind. Do not descend into +(** Compute the use/def information for a statement kind. Do not descend into * the nested blocks. *) let computeUseDefStmtKind ?(acc_used=VS.empty) - ?(acc_defs=VS.empty) + ?(acc_defs=VS.empty) (sk: stmtkind) : VS.t * VS.t = varUsed := acc_used; varDefs := acc_defs; - let ve e = ignore (visitCilExpr useDefVisitor e) in - let _ = - match sk with + let ve e = ignore (visitCilExpr useDefVisitor e) in + let _ = + match sk with Return (None, _) -> () | Return (Some e, _) -> ve e | If (e, _, _, _) -> ve e @@ -199,7 +198,7 @@ let computeUseDefStmtKind ?(acc_used=VS.empty) | ComputedGoto (e, _) -> ve e | Loop (_, _, _, _) -> () | Switch (e, _, _, _) -> ve e - | Instr il -> + | Instr il -> List.iter (fun i -> ignore (visitCilInstr useDefVisitor i)) il | TryExcept _ | TryFinally _ -> () | Block _ -> () @@ -209,7 +208,7 @@ let computeUseDefStmtKind ?(acc_used=VS.empty) (* Compute the use/def information for a statement kind. DO descend into nested blocks *) let rec computeDeepUseDefStmtKind ?(acc_used=VS.empty) - ?(acc_defs=VS.empty) + ?(acc_defs=VS.empty) (sk: stmtkind) : VS.t * VS.t = let handle_block b = List.fold_left (fun (u,d) s -> @@ -219,10 +218,10 @@ let rec computeDeepUseDefStmtKind ?(acc_used=VS.empty) in varUsed := acc_used; varDefs := acc_defs; - let ve e = ignore (visitCilExpr useDefVisitor e) in - match sk with + let ve e = ignore (visitCilExpr useDefVisitor e) in + match sk with Return (None, _) -> !varUsed, !varDefs - | Return (Some e, _) -> + | Return (Some e, _) -> let _ = ve e in !varUsed, !varDefs | If (e, tb, fb, _) -> @@ -236,12 +235,12 @@ let rec computeDeepUseDefStmtKind ?(acc_used=VS.empty) let _ = ve e in !varUsed, !varDefs | Loop (b, _, _, _) -> handle_block b - | Switch (e, b, _, _) -> + | Switch (e, b, _, _) -> let _ = ve e in let u, d = !varUsed, !varDefs in let u', d' = handle_block b in (VS.union u u', VS.union d d') - | Instr il -> + | Instr il -> List.iter (fun i -> ignore (visitCilInstr useDefVisitor i)) il; !varUsed, !varDefs | TryExcept _ | TryFinally _ -> !varUsed, !varDefs diff --git a/src/ext/llvm/META b/src/ext/llvm/META deleted file mode 100644 index e2ca6de80..000000000 --- a/src/ext/llvm/META +++ /dev/null @@ -1 +0,0 @@ -description = "generate llvm code" diff --git a/src/ext/llvm/llvm.ml b/src/ext/llvm/llvm.ml deleted file mode 100644 index eda194cf8..000000000 --- a/src/ext/llvm/llvm.ml +++ /dev/null @@ -1,176 +0,0 @@ -(* Copyright (c) 2008 Intel Corporation - * 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 Intel Corporation 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 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 INTEL OR ITS - * 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. - *) - -(* Generate LLVM code for a CIL file. This provides an alternate code generation - path from CIL (vs the usual "regenerate and compile C code"), which gives more - code generation flexibility (to the extent that LLVM is more flexible than C). - - The current implementation is targeted to x86 processors using gcc's C dialect. - Supporting MSVC or other processors shouldn't require too much work - x86 - and gcc dependencies are marked with comments starting with X86: and GCC: - respectively. We handle all of C, except: - - bitfields, shows up in: - - field read/writes - - structure declarations - inline and module-level assembly - - gcc inline assembly - - gcc pragmas/attributes (those not handled by CIL directly) - - "align" directives: - - need to output align on globals, alloca - - should output align on load, store (note: already passed to llvm.memcpy) - - need to ensure padding is added to structures that use the "aligned" attribute - - variable-size types, shows up in: - - iExp: will just recurse indefinitely - - iBinop/MinusPP: will get an exception when computing elemsize -*) -open Cil -open Feature -open Pretty -open List -open Llvmutils -open Llvmgen -open Llvmssa - -(* Generate LLVM code (as a doc string) for file 'f'. Currently x86+gcc specific, - and missing bitfield support (plus a few minor gcc-specific features, see above) *) -let generate (f:file) : doc = - - (* Implementation overview: - - For all top-level declarations except function definitions, we directly - generate a doc string representing the LLVM equivalent. - - For functions, we use the llvmGeneratorClass to "compile" (but the - transformation is very simple) CIL's intermediate code to LLVM code - (see the llvm* types in llvmgen.ml) in non-SSA form. We then use - llvmssa.ml to transform this code into SSA form, and finally print - the results as a doc string. - - We also use llvmGeneratorClass to keep track of the string constants - used in file 'f'. We need to print these as top-level LLVM constants - (outside function bodies). - *) - - let globals = new llvmGeneratorClass in - - (* LLVM linkage for global 'vi' *) - let rec gLinkage (vi:varinfo) (default:string) : string = - match vi.vstorage with - | Static -> " internal" - | Extern -> " external" - | _ -> default - - (* LLVM linkage for function 'vi' *) - and fLinkage (vi:varinfo) : string = - match vi.vstorage with - | Static -> "internal " - | Extern when vi.vinline -> "internal " - | _ -> "" - - and gVarDecl (vi:varinfo) : doc = - dprintf "@@%s =%s global %a\n" vi.vname (gLinkage vi " weak") dgType vi.vtype - - and gFunctionDecl (fi:varinfo) : doc = - dprintf "declare %a\n" dgFunctionSig fi - - and gFunctionDef (f:fundec) : doc = - let hdr = dprintf "define %s%a " (fLinkage f.svar) dgFunctionSig f.svar in - let blocks = globals#mkFunction f in - (*fprint ~width:80 stderr ((dprintf "%s\n" f.svar.vname) ++ (globals#printBlocks () blocks));*) - let ssaLocals = filter (fun vi -> llvmUseLocal vi) (f.sformals @ f.slocals) in - let ssaBlocks = llvmSsa globals blocks f.sformals ssaLocals in - hdr ++ (text "{\n") ++ (globals#printBlocks () ssaBlocks) ++ (text "}\n") - - and gStruct (ci:compinfo) : doc = - let pfield f = gType f.ftype in - dprintf "%%struct.%s = type { %a }\n" ci.cname (docList pfield) ci.cfields - - (* Generate LLVM initializer from CIL initializer 'i' for type 't' *) - and giInit (t:typ) (initexp:init) : doc = - let tdoc = gType t in - let idoc = match initexp with - | SingleInit e -> - (*ignore(Pretty.eprintf "%a\n" (printExp plainCilPrinter) e);*) - globals#printValueNoType () (globals#mkConstantExp e) - | CompoundInit (ct, inits) -> - if isArrayType ct then - (* the docs imply that we should pad the array if there are - missing initializers for the tail of the array, - but the default frontend doesn't generate any it seems... *) - let ct' = typeArrayOf ct in - dprintf "[ %a ]" (docList (fun (o, i) -> giInit ct' i)) inits - else (* a structure initializer *) - let pfield (o, fieldinit) = match o with - | Field(f, NoOffset) -> giInit f.ftype fieldinit - | _ -> raise Bug - in - dprintf "{ %a }" (docList pfield) inits - in tdoc ++ (text " ") ++ idoc - - and gInit (t,ii) : doc = match ii.init with - | None -> dprintf "%a zeroinitializer" dgType t - | Some i -> giInit t i - and dgInit () = gInit - - and gGlobal (g:global) : doc = match g with - | GType _ -> nil - | GCompTag (ci, _) -> gStruct ci - | GCompTagDecl (ci, _) when not ci.cdefined -> - dprintf "%%struct.%s = type opaque\n" ci.cname - | GCompTagDecl (ci, _) -> nil - | GEnumTag _ -> nil - | GEnumTagDecl _ -> nil - | GVarDecl (vi, _) -> - if isFunctionType vi.vtype then - gFunctionDecl vi - else - gVarDecl vi - | GVar (vi, ii, _) -> dprintf "@@%s =%s global %a\n" - vi.vname (gLinkage vi "") dgInit (vi.vtype, ii) - | GFun (fi, _) -> gFunctionDef fi - | GAsm _ -> nil - | GPragma _ -> nil - | GText s -> text s - in - - let body = fold_left (++) nil (map gGlobal f.globals) in - (globals#printGlobals ()) ++ body - -(* CIL feature setup *) -let feature = - { fd_name = "llvm"; - fd_enabled = false; - fd_description = "generate llvm code"; - fd_extraopt = []; - fd_doit = - (function (f: file) -> - fprint stdout 80 (generate f)); - fd_post_check = false - } diff --git a/src/ext/llvm/llvmgen.ml b/src/ext/llvm/llvmgen.ml deleted file mode 100644 index 800258727..000000000 --- a/src/ext/llvm/llvmgen.ml +++ /dev/null @@ -1,1250 +0,0 @@ -(* Copyright (c) 2008 Intel Corporation - * 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 Intel Corporation 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 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 INTEL OR ITS - * 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. - *) - -open Cil -open List -open Pretty -open Printf -open Llvmutils -open Expcompare -module H = Hashtbl -module S = String - -exception NotConstant - -(* Types used to represent an LLVM function body, which is just a list - of LLVM blocks (llvmBlock), where the first block is the function - entry point. See http://llvm.org for documentation on LLVM itself. -*) -type llvmBlock = { - lblabel: string; (* unique label identifying this block *) - mutable lbbody: llvmInstruction list; - mutable lbterminator: llvmTerminator; - - (* predecessor blocks, use llvmDestinations to get successors *) - mutable lbpreds : llvmBlock list; - } - -and llvmInstruction = { - mutable liresult: llvmLocal option; - liop: llvmOp; - mutable liargs: llvmValue list; - } - -and llvmTerminator = - | TUnreachable - | TDead (* not a real LLVM terminator, used to mark blocks that should be removed *) - | TRet of llvmValue list - | TBranch of llvmBlock - | TCond of llvmValue * llvmBlock * llvmBlock - | TSwitch of llvmValue * llvmBlock * (int64 * llvmBlock) list - -(* Note that LLVM values are typed; use llvmTypeOf to get the type of one of these *) -and llvmValue = - | LGlobal of llvmGlobal - | LLocal of llvmLocal - | LBool of bool - | LInt of int64 * ikind - | LFloat of float * fkind - | LUndef - | LZero - | LNull of llvmType - | LPhi of llvmValue * llvmBlock - | LType of llvmType - | LGetelementptr of llvmValue list - | LCast of llvmCast * llvmValue * llvmType - | LBinary of llvmBinop * llvmValue * llvmValue * llvmType - | LCmp of llvmCmp * llvmValue * llvmValue - | LFcmp of llvmFCmp * llvmValue * llvmValue - | LSelect of llvmValue * llvmValue * llvmValue - -and llvmLocal = string * llvmType -and llvmGlobal = string * llvmType - -(* We just reuse CIL's type to represent LLVM types. As a result, the code below is - not very careful in its use of llvmType vs typ. LLVM has some types that don't - correspond well with C types (i1, a single-bit, and some vector-types), but we - don't use the vector types and can fudge the uses of i1. *) -and llvmType = typ - -and llvmOp = - | LIassign (* for use before SSA transformation *) - | LIphi - | LIgetelementptr - | LIload - | LIstore - | LIcall - | LIalloca - | LIbinary of llvmBinop - | LIcmp of llvmCmp - | LIfcmp of llvmFCmp - | LIselect - | LIcast of llvmCast - | LIva_arg - -and llvmBinop = - | LBadd - | LBsub - | LBmul - | LBudiv - | LBsdiv - | LBfdiv - | LBurem - | LBsrem - | LBfrem - | LBshl - | LBlshr - | LBashr - | LBand - | LBor - | LBxor - -and llvmCmp = - | LCeq - | LCne - | LCslt - | LCult - | LCsle - | LCule - | LCsgt - | LCugt - | LCsge - | LCuge - -and llvmFCmp = - | LCFoeq - | LCFone - | LCFolt - | LCFole - | LCFogt - | LCFoge - | LCFord - | LCFueq - | LCFune - | LCFult - | LCFule - | LCFugt - | LCFuge - -and llvmCast = - | LAtrunc - | LAzext - | LAsext - | LAuitofp - | LAsitofp - | LAfptoui - | LAfptosi - | LAfptrunc - | LAfpext - | LAinttoptr - | LAptrtoint - | LAbitcast - -let binopName op = match op with -| LBadd -> "add" -| LBsub -> "sub" -| LBmul -> "mul" -| LBudiv -> "udiv" -| LBsdiv -> "sdiv" -| LBfdiv -> "fdiv" -| LBurem -> "urem" -| LBsrem -> "srem" -| LBfrem -> "frem" -| LBshl -> "shl" -| LBlshr -> "lshr" -| LBashr -> "ashr" -| LBand -> "and" -| LBor -> "or" -| LBxor -> "xor" - -and cmpName op = match op with -| LCeq -> "eq" -| LCne -> "ne" -| LCslt -> "slt" -| LCult -> "ult" -| LCsle -> "sle" -| LCule -> "ule" -| LCsgt -> "sgt" -| LCugt -> "ugt" -| LCsge -> "sge" -| LCuge -> "uge" - -and fcmpName op = match op with -| LCFoeq -> "oeq" -| LCFone -> "one" -| LCFolt -> "olt" -| LCFole -> "ole" -| LCFogt -> "ogt" -| LCFoge -> "oge" -| LCFord -> "ord" -| LCFueq -> "ueq" -| LCFune -> "une" -| LCFult -> "ult" -| LCFule -> "ule" -| LCFugt -> "ugt" -| LCFuge -> "uge" - -and castName op = match op with -| LAtrunc -> "trunc" -| LAzext -> "zext" -| LAsext -> "sext" -| LAuitofp -> "uitofp" -| LAsitofp -> "sitofp" -| LAfptoui -> "fptoui" -| LAfptosi -> "fptosi" -| LAfptrunc -> "fptrunc" -| LAfpext -> "fpext" -| LAinttoptr -> "inttoptr" -| LAptrtoint -> "ptrtoint" -| LAbitcast -> "bitcast" - -(* Some common LLVM types *) -let i1Type = voidType (* this could be made into a real, distinct type *) -let i32Type = TInt(intKindForSize 4 false, []) -let i8starType = charPtrType - -(* Return the type of LLVM value 'v' *) -let rec llvmTypeOf (v:llvmValue) : llvmType = match v with -| LGlobal (_, t) -> TPtr(t, []) (* global LLVM symbols are pointers to the global's location *) -| LLocal (_, t) -> t -| LType t -> t -| LInt (_, ik) -> TInt(ik, []) -| LFloat (_, fk) -> TFloat(fk, []) -(* To understand getelementptr, please see the LLVM documentation (in brief, the first - argument is a pointer, the 2nd is an index for that pointer, and subsequent arguments - access embedded arrays and fields, and the result is a pointer to the referenced - location) *) -| LGetelementptr [ base ] -> llvmTypeOf base -| LGetelementptr (base :: index :: path) -> - let accessed (t:llvmType) (v:llvmValue) : llvmType = - match v with - | LInt(i, _) -> begin - match unrollType t with - | TArray (t, _, _) -> t - | TComp (ci, _) -> - let field = nth ci.cfields (Int64.to_int i) in - field.ftype - | _ -> raise Bug - end - | _ -> raise Bug - in - let t = fold_left accessed (typePointsTo (llvmTypeOf base)) path in - TPtr(t, []) -| LCast (_, _, t) -> t -| LBool _ -> i1Type -| LNull t -> t -| LCmp _ -> i1Type -| LFcmp _ -> i1Type -| LSelect (_, v1, _) -> llvmTypeOf v1 -| LBinary (_, _, _, t) -> t -| _ -> voidType - -(* True if t can be the type of an LLVM local *) -let llvmLocalType (t:typ) : bool = - match unrollType t with - | (TInt _ | TFloat _ | TPtr _ | TEnum _) -> true - | _ -> false - -(* True if local variable 'vi' should be represented by an LLVM local *) -let llvmUseLocal (vi:varinfo) = - not vi.vaddrof && llvmLocalType vi.vtype - -(* True if 'vi's address is taken, and it would've been represented by - an LLVM local if that had not been the case. - Include hack for __builtin_va_list... *) -let llvmDoNotUseLocal (vi:varinfo) = - vi.vaddrof && llvmLocalType vi.vtype || - (match unrollType vi.vtype with - | TBuiltin_va_list _ -> true - | _ -> false) - -(* Returns the list of blocks that 'term' can branch to; - 'llvmDestinations b.lbterm' is the successors of LLVM block b *) -let llvmDestinations (term:llvmTerminator) = match term with -| TUnreachable -> [] -| TDead -> [] -| TRet _ -> [] -| TBranch b -> [b] -| TCond (_, b1, b2) -> [b1; b2] -| TSwitch (_, defaultb, cases) -> defaultb :: (map snd cases) - -(* Compare two llvmValues for equality. We can't just use = because - that can cause an infinite loop (due to types). *) -let rec llvmValueEqual (v1:llvmValue) (v2:llvmValue) = match (v1, v2) with -| (LGlobal (name1, _), LGlobal(name2, _)) -> name1 = name2 -| (LLocal (name1, _), LLocal(name2, _)) -> name1 = name2 -| (LNull t1, LNull t2) -> compareTypes t1 t2 -| (LPhi (v1, b1), LPhi (v2, b2)) -> llvmValueEqual v1 v2 && b1.lblabel = b2.lblabel -| (LType t1, LType t2) -> compareTypes t1 t2 -| (LGetelementptr vl1, LGetelementptr vl2) -> for_all2 llvmValueEqual vl1 vl2 -| (LCast (op1, v1, t1), LCast (op2, v2, t2)) -> - op1 = op2 && llvmValueEqual v1 v2 && compareTypes t1 t2 -| (LBinary (op1, v1, w1, t1), LBinary (op2, v2, w2, t2)) -> - op1 = op2 && llvmValueEqual v1 v2 && llvmValueEqual w1 w2 && compareTypes t1 t2 -| (LCmp (op1, v1, w1), LCmp (op2, v2, w2)) -> - op1 = op2 && llvmValueEqual v1 v2 && llvmValueEqual w1 w2 -| (LFcmp (op1, v1, w1), LFcmp (op2, v2, w2)) -> - op1 = op2 && llvmValueEqual v1 v2 && llvmValueEqual w1 w2 -| (LSelect (c1, v1, w1), LSelect (c2, v2, w2)) -> - llvmValueEqual c1 c2 && llvmValueEqual v1 v2 && llvmValueEqual w1 w2 -| _ -> v1 = v2 - -(* Return the LLVM local for local variable 'vi' *) -let llocal (vi:varinfo) : llvmLocal = - (* If the variable can be stored directly in a LLVM local, do so. Otherwise, - the LLVM local is a pointer to the actual variable (and will be stack - allocated with alloca at the entry to the function) *) - if llvmUseLocal vi then - (vi.vname, vi.vtype) - else if llvmDoNotUseLocal vi then - ("address." ^ vi.vname, TPtr (vi.vtype, [])) - else - (vi.vname, TPtr (vi.vtype, [])) - -(* Return the LLVM global for global variable 'vi' *) -let lglobal (vi:varinfo) : llvmGlobal = - (vi.vname, vi.vtype) - -(* Return the LLVM value representing variable 'vi' *) -let lvar (vi:varinfo) : llvmValue = - if vi.vglob then LGlobal (lglobal vi) else LLocal (llocal vi) - -(* Return the LLVM value representing integer 'n' of integer type 't' *) -let lint (n:int) (t:typ) : llvmValue = LInt (Int64.of_int n, integralKind t) - -(* Return the LLVM value corresponding to '(t)0' (this is the implicit - comparison target in C conditions (if, &&, ||, !) *) -let lzero (t:typ) : llvmValue = - match unrollType t with - | TInt (ik, _) -> LInt (Int64.zero, ik) - | TFloat (fk, _) -> LFloat (0.0, fk) - | TPtr _ -> LNull t - | _ -> raise Bug - -(* Build LLVM instruction 'res' = 'op' 'args' *) -let mkIns op res args = { liresult = Some res; liargs = args; liop = op } - -(* Build LLVM instruction 'op' 'args' *) -let mkVoidIns op args = { liresult = None; liargs = args; liop = op } - -(* Build the LLVM instruction that compares 'v' to zero, storing the boolean - result in 'res' *) -let mkTrueIns (res:llvmLocal) (v:llvmValue) : llvmInstruction = - let t = llvmTypeOf v in - if isFloatingType t then - mkIns (LIfcmp LCFune) res [ v; lzero t ] - else - mkIns (LIcmp LCne) res [ v; lzero t ] - -(* Build escaaped version of string s using LLVM's escaped string syntax *) -let llvmEscape (s:string) : string = - let digit i = - if i < 10 then Char.chr (48 + i) - else Char.chr (55 + i) in - let l = S.length s in - let b = Buffer.create (l + 2) in - for i = 0 to l - 1 do - let c = s.[i] in - let cc = Char.code c in - if cc < 32 || cc > 126 then begin - Buffer.add_char b '\\'; - Buffer.add_char b (digit (cc / 16)); - Buffer.add_char b (digit (cc mod 16)) - end else - Buffer.add_char b c - done; - Buffer.contents b - -(* Negate LLVM value 'v' (must be an integer or floating constant) *) -let llvmValueNegate (v:llvmValue) : llvmValue = match v with -| LInt (i, ik) -> LInt(Int64.sub Int64.zero i, ik) -| LFloat (f, fk) -> LFloat(-. f, fk) -| _ -> raise Bug - -(* Return the LLVM cast operator for casting from 'tfrom' to 'tto *) -let llvmCastOp (tfrom:typ) (tto:typ) : llvmCast = - if isIntegralType tfrom && isIntegralType tto then - let frombits = bitsSizeOf tfrom - and tobits = bitsSizeOf tto in - if tobits < frombits then - LAtrunc - else if tobits > frombits then - if isSignedType tfrom then LAsext else LAzext - else - LAbitcast - else if isIntegralType tfrom && isFloatingType tto then - if isSignedType tfrom then LAsitofp else LAuitofp - else if isFloatingType tfrom && isIntegralType tto then - if isSignedType tto then LAfptosi else LAfptoui - else if isFloatingType tfrom && isFloatingType tto then - let frombits = bitsSizeOf tfrom - and tobits = bitsSizeOf tto in - if tobits < frombits then - LAfptrunc - else if tobits > frombits then - LAfpext - else - LAbitcast - else if isIntegralType tfrom && isPointerType tto then - LAinttoptr - else if isPointerType tfrom && isIntegralType tto then - LAptrtoint - else if isPointerType tfrom && isPointerType tto then - LAbitcast - else - raise Bug - -(* comments in actual definition *) -class type llvmGenerator = object - method addString : string -> llvmGlobal - method addWString : int64 list -> llvmGlobal - method mkFunction : fundec -> llvmBlock list - method mkConstant : constant -> llvmValue - method mkConstantExp : exp -> llvmValue - - method printGlobals : unit -> doc - method printBlocks : unit -> llvmBlock list -> doc - method printValue : unit -> llvmValue -> doc - method printValueNoType : unit -> llvmValue -> doc -end - -(* An object that generates code for CIL function bodies and initializers, while - keeping track of string constants *) -class llvmGeneratorClass : llvmGenerator = object (self) - val mutable strings : (llvmGlobal * string) list = [] - val mutable wstrings : (llvmGlobal * int64 list) list = [] - val mutable nextGLabel = 0 - - (* A zero of pointer size *) - val lzerop = lzero !upointType - - (* LLVM intrinsics, in doc string and LLVM value form. - The doc strings could be generated from the LLVM values *) - val intrinsics = - (text "declare void @llvm.memcpy.i32(i8*, i8*, i32, i32) nounwind\n") ++ - (text "declare void @llvm.va_start(i8*)\n") ++ - (text "declare void @llvm.va_copy(i8*, i8*)\n") ++ - (text "declare void @llvm.va_end(i8*)\n") - - val intrinsic_memcpy : llvmValue = - let a t = ("", t, []) in - let args = [ a i8starType; a i8starType; a i32Type; a i32Type ] in - let t = TFun(voidType, Some args, false, []) in - LGlobal ("llvm.memcpy.i32", t) - val intrinsic_va_start : llvmValue = - let a t = ("", t, []) in - let t = TFun(voidType, Some [ a i8starType ], false, []) in - LGlobal ("llvm.va_start", t) - val intrinsic_va_end : llvmValue = - let a t = ("", t, []) in - let t = TFun(voidType, Some [ a i8starType ], false, []) in - LGlobal ("llvm.va_end", t) - val intrinsic_va_copy : llvmValue = - let a t = ("", t, []) in - let t = TFun(voidType, Some [ a i8starType; a i8starType ], false, []) in - LGlobal ("llvm.va_copy", t) - - (* This gets set to a mapping from gcc's to LLVM's vararg intrinsics *) - val mutable vaIntrinsics = [] - - (* Return a new global label *) - method private newGLabel () : string = - let nglabel = sprintf ".G%d" nextGLabel in - nextGLabel <- nextGLabel + 1; - nglabel - - (* Record a new string and return the global value that references it *) - method addString (s:string) : llvmGlobal = - let reals = s ^ "\000" in (* CIL strings are missing the trailing nul *) - let strt = TArray(charType, Some (kinteger IInt (S.length reals)), []) in - let g = (self#newGLabel (), strt) in - strings <- (g, reals) :: strings; - g - - (* Record a new wide string and return the global value that references it *) - method addWString (ws:int64 list) : llvmGlobal = - let realws = ws @ [ Int64.zero ] in (* CIL strings are missing the trailing nul *) - let wstrt = TArray(!wcharType, Some (kinteger IInt (length realws)), []) in - let g = (self#newGLabel (), wstrt) in - wstrings <- (g, realws) :: wstrings; - g - - (* Print all global symbols and intrinsics used in the functions and - constant expressions seen so far *) - method printGlobals () : doc = - let p1s ((glabel, t), s) = (* print string def *) - dprintf "@@%s = internal constant %a c\"%s\"\n" glabel dgType t (llvmEscape s) - and p1ws ((glabel, t), ws) = (* print wide string def *) - let value wc = LInt (wc, !wcharKind) in - dprintf "@@%s = internal constant %a [ %a ]\n" glabel dgType t - (d_list ", " self#printValue) (map value ws) - in intrinsics ++ - (fold_left (++) nil (map p1s strings)) ++ - (fold_left (++) nil (map p1ws wstrings)) - - (* Print an LLVM value without it's associated LLVM type *) - method printValueNoType () (v:llvmValue) : doc = - match v with - | LGlobal (s,t) -> dprintf "@@%s" s - | LLocal (s,t) -> dprintf "%%%s" s - | LBool true -> text "true" - | LBool false -> text "false" - | LInt (n,_) -> d_int64 n - | LFloat (f,_) -> text (sprintf "%.20e" f) - | LUndef -> text "undef" - | LZero -> text "zeroinitializer" - | LNull _ -> text "null" - | LGetelementptr vl -> dprintf "getelementptr(%a)" (d_list ", " self#printValue) vl - | LCast (op, v, t) -> dprintf "%s(%a to %a)" (castName op) self#printValue v dgType t - | LBinary (op, v1, v2, _) -> dprintf "%s(%a, %a)" (binopName op) self#printValue v1 self#printValue v2 - | LCmp (op, v1, v2) -> dprintf "icmp %s (%a, %a)" (cmpName op) self#printValue v1 self#printValue v2 - | LFcmp (op, v1, v2) -> dprintf "fcmp %s (%a, %a)" (fcmpName op) self#printValue v1 self#printValue v2 - | LSelect (c, v1, v2) -> dprintf "select (%a, %a, %a)" self#printValue c self#printValue v1 self#printValue v2 - | LPhi (v,b) -> dprintf "[ %a, %%%s ]" self#printValueNoType v b.lblabel - | LType _ -> nil - - (* Print an LLVM value prefixed by it's LLVM type *) - method printValue () (v:llvmValue) : doc = - let vdoc = self#printValueNoType () v in - let t = llvmTypeOf v in - if t <> voidType then - (gType t) ++ (text " ") ++ vdoc - else - vdoc - - (* Print an LLVM block list *) - method printBlocks () (bl:llvmBlock list) : doc = - let rec llvmPrintIns (i:llvmInstruction) : doc = - let (ddest, dtype) = match i.liresult with - | Some (s, t) -> (dprintf "%%%s = " s, t) - | None -> (nil, voidType) - and p n () = self#printValue () (nth i.liargs n) (* print nth arg *) - and pnt n () = self#printValueNoType () (nth i.liargs n) (* print nth arg w/o type *) - in ddest ++ match i.liop with - | LIassign -> dprintf "[%t]\n" (p 0) - | LIload -> dprintf "load %t\n" (p 0) - | LIstore -> dprintf "store %t, %t\n" (p 0) (p 1) - | LIcall -> dprintf "call %t(%a)\n" (p 0) (d_list ", " self#printValue) (tl i.liargs) - | LIbinary op -> dprintf "%s %t, %t\n" (binopName op) (p 0) (pnt 1) - | LIcmp op -> dprintf "icmp %s %t, %t\n" (cmpName op) (p 0) (pnt 1) - | LIfcmp op -> dprintf "fcmp %s %t, %t\n" (fcmpName op) (p 0) (pnt 1) - | LIselect -> dprintf "select i1 %t, %t, %t\n" (pnt 0) (p 1) (p 2) - | LIva_arg -> dprintf "va_arg %t, %t\n" (p 0) (p 1) - | LIcast op -> dprintf "%s %t to %t\n" (castName op) (p 0) (p 1) - | LIphi -> dprintf "phi %a %a\n" dgType dtype (d_list ", " self#printValue) i.liargs - | LIgetelementptr -> dprintf "getelementptr %a\n" (d_list ", " self#printValue) i.liargs - | LIalloca -> dprintf "alloca %a\n" (d_list ", " self#printValue) i.liargs - - and llvmPrintTerm (term:llvmTerminator) : doc = - match term with - | TUnreachable -> text "unreachable\n" - | TDead -> text "unreachable\n" - | TBranch b -> dprintf "br label %%%s\n" b.lblabel - | TCond (v, b1, b2) -> dprintf "br i1 %a, label %%%s, label %%%s\n" - self#printValueNoType v b1.lblabel b2.lblabel - | TSwitch (v, def, cases) -> - let printOneCase () (n, b) = - dprintf "%a %a, label %%%s" dgType (llvmTypeOf v) f_int64 n b.lblabel in - dprintf "switch %a, label %%%s [ %a ]\n" self#printValue v def.lblabel - (d_list " " printOneCase) cases - | TRet [] -> text "ret void\n" - | TRet rl -> dprintf "ret %a\n" (d_list ", " self#printValue) rl - - and llvmPrint1 (b:llvmBlock) : doc = - let label = - if b.lblabel <> "" then dprintf "%s:\n" b.lblabel - else nil - and body = fold_left (++) nil (map llvmPrintIns b.lbbody) - and term = llvmPrintTerm b.lbterminator in - label ++ (indent 8 (body ++ term)) - - in fold_left (++) nil (map llvmPrint1 bl) - - (* Build the LLVM value for CIL constant 'c' *) - method mkConstant (c:constant) : llvmValue = - match c with - | CInt64 (i, ik, _) -> LInt (i, ik) - | CStr s -> LGetelementptr [ LGlobal (self#addString s); lzerop; lzerop ] - | CWStr ws -> LGetelementptr [ LGlobal (self#addWString ws); lzerop; lzerop ] - | CChr c -> LInt (Int64.of_int (Char.code c), IInt) - | CReal (f, fk, _) -> LFloat (f, fk) - | CEnum (e, _, ei) -> LInt (intConstValue e, ei.ekind) - - (* Build the LLVM value for CIL constant expression 'e' - this includes constant - lvalues like &s[3].a.b[2].c which CIL doesn't constant fold *) - method mkConstantExp (e:exp) : llvmValue = - (* This is a simplified, restricted version of the code generation case... *) - let rec accessPath (o:offset) : llvmValue list = - match o with - | NoOffset -> [] - | Field (fi, o') -> (lint (fieldIndexOf fi) i32Type) :: accessPath o' - | Index (e, o') -> (self#mkConstantExp e) :: accessPath o' - - and iStartOf (h, o) : llvmValue = - let opath = (accessPath o) @ [ lzerop ] in - match h with - | Var vi when vi.vglob -> LGetelementptr (lvar vi :: lzerop :: opath) - | _ -> raise NotConstant - - and iAddrOf (h, o) : llvmValue = - let opath = accessPath o in - match h with - | Var vi when vi.vglob -> - if opath = [] then - lvar vi - else - LGetelementptr (lvar vi :: lzerop :: opath) - | _ -> raise NotConstant - - and plusPI (p:llvmValue) (offset:llvmValue) : llvmValue = - (* Add 'offset' to the last offset in getelementptr value 'p' *) - match (p, offset) with - | (LGetelementptr vl, LInt(i, _)) -> - (* The current offset is at the end of the getelementptr value... *) - let rev_vl = rev vl in - let newoffset = - match hd rev_vl with - | LInt(j, jk) -> LInt(Int64.add i j, jk) - | _ -> raise NotConstant - in - LGetelementptr (rev (newoffset :: tl rev_vl)) - | _ -> raise NotConstant - - and minusPI (p:llvmValue) (offset:llvmValue) = plusPI p (llvmValueNegate offset) - - and mkConstantCast (v:llvmValue) (tto:typ) : llvmValue = - let castop = llvmCastOp (llvmTypeOf v) tto in - LCast (castop, v, tto) - - and iCast (tto:typ) (e:exp) : llvmValue = - let castop = llvmCastOp (typeOf e) tto in - LCast (castop, (self#mkConstantExp e), tto) - - and iUnop op (e:exp) (t:typ) : llvmValue = - let v = self#mkConstantExp e in - let targ = typeOf e in - match op with - | Neg -> LBinary (LBsub, lzero targ, v, t) - | BNot -> LBinary (LBxor, v, lint (-1) targ, t) - | LNot -> - let t = llvmTypeOf v in - let cond = - if isFloatingType t then - LFcmp (LCFune, v, lzero t) - else - LCmp (LCne, v, lzero t) - in LSelect (cond, lzero t, lint 1 t) - - and iBinop op (e1:exp) (e2:exp) (t:typ) : llvmValue = - let v1 = self#mkConstantExp e1 in - let v2 = self#mkConstantExp e2 in - let targ1 = typeOf e1 in - (* generate constant for an arithmetic operator *) - let arith op = LBinary (op, v1, v2, t) in - (* generate constant for a comparison operator *) - let compare sop uop fop = - let cond = - if isIntegralType targ1 then - if isSignedType targ1 then LCmp (sop, v1, v2) - else LCmp (uop, v1, v2) - else LFcmp (fop, v1, v2) - in LSelect(cond, lint 1 t, lint 0 t) - in - match op with - | PlusA -> arith LBadd - | MinusA -> arith LBsub - | (PlusPI | IndexPI) -> plusPI v1 v2 - | MinusPI -> minusPI v1 v2 - | MinusPP -> - let asint1 = mkConstantCast v1 t in - let asint2 = mkConstantCast v2 t in - let elemsize = bitsSizeOf (typePointsTo targ1) / 8 in - let diff = LBinary (LBsub, asint1, asint2, t) in - LBinary (LBsdiv, diff, lint elemsize t, t) - | Mult -> arith LBmul - | Div -> - let op = - if isIntegralType t then - if isSignedType t then LBsdiv else LBudiv - else LBfdiv - in arith op - | Mod -> arith (if isSignedType t then LBsrem else LBurem) - | Shiftlt -> arith LBshl - | Shiftrt -> arith (if isSignedType t then LBashr else LBlshr) - | BAnd -> arith LBand - | BOr -> arith LBor - | BXor -> arith LBxor - (* for floating point, llvm-gcc believes in unordered !=, ordered - everything else *) - | Lt -> compare LCslt LCult LCFolt - | Gt -> compare LCsgt LCugt LCFogt - | Le -> compare LCsle LCule LCFole - | Ge -> compare LCsge LCuge LCFoge - | Eq -> compare LCeq LCeq LCFoeq - | Ne -> compare LCne LCne LCFune - | LAnd -> raise (Unimplemented "LAnd") (* not normally used by CIL *) - | LOr -> raise (Unimplemented "Lor") (* not normally used by CIL *) - - (* Handle all the expressions that can actually occur in a constant or - constant lvalue *) - in match constFold true e with - | Const c -> self#mkConstant c - | CastE (t, e) -> iCast t e - | StartOf lv -> iStartOf lv - | AddrOf lv -> iAddrOf lv - | UnOp (op, e, t) -> iUnop op e t - | BinOp (op, e1, e2, t) -> iBinop op e1 e2 t - | _ -> raise NotConstant - - (* Generate LLVM code for function 'f'. - Note: this code assumes that the statement ids (sid field of stmt) - have either not been set (< 0), or are set to unique values. After - mkFunction returns, the statement ids will have unique positive - values. *) - method mkFunction (f:fundec) : llvmBlock list = - (* Set up the GCC vararg intrinsic mapping (once) *) - if vaIntrinsics = [] then - vaIntrinsics <- [ "__builtin_va_start", intrinsic_va_start; - "__builtin_va_copy", intrinsic_va_copy; - "__builtin_va_end", intrinsic_va_end ]; - - let blocks = ref [] in (* blocks for this function *) - let tmp_allocas = ref [] in (* additional temporary alloca's for this function *) - - let blabels = H.create 32 in - let nextLabel = ref 0 in - (* Return a new label *) - let newLabel () = - let nlabel = sprintf "L%d" !nextLabel in - nextLabel := !nextLabel + 1; - nlabel - (* Return the unique label for statement 's' *) - and labelOf (s:stmt) : string = - (* Pick a new label the first time its requested *) - if s.sid < 0 then begin - s.sid <- !nextLabel; - nextLabel := !nextLabel + 1 - end; - sprintf "S%d" s.sid - in - - (* Return the block identified by label 'label', creating an - "empty" block if 'label' hasn't been requested before. This - allows us to target a block X in terminators before they've - actually been compiled: when X is finally visited, we'll call - getNamedBlock with the same label (courtesy of labelOf), get - the "empty" block we created earlier, and fill it in (see - mkBlock) *) - let rec getNamedBlock (label:string) : llvmBlock = - try - H.find blabels label - with Not_found -> (* create the empty block *) - let nb = { lblabel = label; lbbody = []; lbterminator = TUnreachable; lbpreds = [] } in - H.add blabels label nb; - blocks := nb :: !blocks; - nb - (* Let X be the block identified by 'label'. Sets the instructions for - block X to 'il' and its terminator to 'term X'. Returns X. *) - and mkBlock (label:string) (il:llvmInstruction list) (term: llvmTerminator) : llvmBlock = - let nb = getNamedBlock label in - nb.lbbody <- il; - nb.lbterminator <- term; - nb - in - - let tmp = ref 0 in - (* Return a new LLVM temporary. These must be assigned exactly once (we do - not run the SSA transform on temporaries). *) - let nextTemp (t:llvmType) : llvmLocal = - tmp := !tmp + 1; - (sprintf ".t%d" !tmp, t) - in - - let mkCast (v:llvmValue) (tto:typ) : llvmInstruction * llvmValue = - let tmp = nextTemp tto in - (mkIns (LIcast (llvmCastOp (llvmTypeOf v) tto)) tmp [ v; LType tto ], LLocal tmp) - in - - (* Compile CIL statements to LLVM blocks - each statement becomes - a separate LLVM block (we do some block merging as a cleanup - pass at the end of code generation - see simplifyBlock). - - These functions take three terminator arguments. When compiling - a statement s, the first (XXterm) is used when s terminates - normally, the second (XXbrk) when s terminates via a break - statement, and the third (XXcont) when s terminates via a - continue statement. *) - - let rec gBlock (label:string) (b:block) bterm bbrk bcont : llvmBlock = - let rec connectStmts (s:stmt) sterm = - let sblock = gStmt s sterm bbrk bcont in - TBranch sblock (* Our predecessor should branch to us... *) - in let eblock = fold_right connectStmts b.bstmts bterm in - mkBlock label [] eblock - - and gStmt (s:stmt) = - let slabel = labelOf s in - match s.skind with - | Instr il -> gIList slabel il - | Return (None, _) -> gReturnVoid slabel - | Return (Some e, _) -> gReturn slabel e - | Goto (sref, _) -> gGoto slabel sref - | ComputedGoto _ -> raise (Unimplemented "ComputedGoto") - | Break _ -> gBreak slabel - | Continue _ -> gContinue slabel - | If (e, b1, b2, _) -> gIf slabel e b1 b2 - | Switch (e, b, slist, _) -> gSwitch slabel e b slist - | Loop (b, _, _, _) -> gLoop slabel b - | Block b -> gBlock slabel b - | TryFinally (_, _, _) -> raise (Unimplemented "TryFinally") - | TryExcept (_, _, _, _) -> raise (Unimplemented "TryExcept") - - and gReturnVoid (label:string) sterm sbrk scont : llvmBlock = - mkBlock label [] (TRet []) - - and gReturn (label:string) (e:exp) sterm sbrk scont : llvmBlock = - let tret = typeOf e in - if isCompType tret then - (* X86: structures returned by copy into distinguished first argument *) - let (ilret, vret) = iExp e in - let ilmemcpy = iMemcpy (LLocal (".result", TPtr(tret, []))) vret in - mkBlock label (ilret @ ilmemcpy) (TRet []) - else - let retterm (v:llvmValue) : llvmTerminator = TRet [v] in - gExp label e retterm sbrk scont - - and gBreak (label:string) sterm sbrk scont : llvmBlock = - mkBlock label [] sbrk - - and gContinue (label:string) sterm sbrk scont : llvmBlock = - mkBlock label [] scont - - and gGoto (label:string) (sref:stmt ref) sterm sbrk scont : llvmBlock = - let target = getNamedBlock (labelOf !sref) in - mkBlock label [] (TBranch target) - - and gIf (label:string) (e:exp) (b1:block) (b2:block) sterm sbrk scont : llvmBlock = - let lb1 = gBlock (newLabel ()) b1 sterm sbrk scont in - let lb2 = gBlock (newLabel ()) b2 sterm sbrk scont in - let (ilcond, vcond) = iExp e in - let istrue = nextTemp i1Type in - let test = mkTrueIns istrue vcond in - mkBlock label (ilcond @ [ test ]) (TCond (LLocal istrue, lb1, lb2)) - - and gSwitch (label:string) (e:exp) (b:block) (slist:stmt list) sterm sbrk scont : llvmBlock = - ignore(gBlock (newLabel ()) b sterm sterm scont); - let switchterm (v:llvmValue) : llvmTerminator = - let defblock = ref (mkBlock (newLabel ()) [] sterm) in - let cases = ref [] in - let addCase (target:llvmBlock) (l:label) = match l with - | Label _ -> () - | Case (e, _) -> cases := (intConstValue e, target) :: !cases - | CaseRange _ -> assert false - | Default _ -> defblock := target - in iter (fun s -> iter (addCase (getNamedBlock (labelOf s))) (caseRangeFold s.labels)) slist; - TSwitch (v, !defblock, !cases) - in - gExp label e switchterm sbrk scont - - and gLoop (label:string) (b:block) sterm sbrk scont : llvmBlock = - let loop = getNamedBlock label in - let loopback = TBranch loop in - gBlock label b loopback sterm loopback - - and gIList (label:string) (instrs:instr list) sterm sbrk scont = - let il_instrs = flatten (map iIns instrs) in - mkBlock label il_instrs sterm - - and gExp (label:string) (e:exp) (eterm:llvmValue -> llvmTerminator) ebrk econt : llvmBlock = - let (il,v) = iExp e in - mkBlock label il (eterm v) - - (* Generate instructions to memcpy src to dest *) - and iMemcpy (dest:llvmValue) (src:llvmValue) : llvmInstruction list = - let t = typePointsTo (llvmTypeOf dest) in - let size = lint ((bitsSizeOf t) / 8) i32Type in - let align = lint (alignOf_int t) i32Type in - let (idest_cast, i8dest) = mkCast dest i8starType in - let (isrc_cast, i8src) = mkCast src i8starType in - let imemcpy = mkVoidIns LIcall [ intrinsic_memcpy; i8dest; i8src; size; align ] in - [ idest_cast; isrc_cast; imemcpy ] - - and iIns (i:instr) : llvmInstruction list = match i with - | Set (lv, e, _) -> iSet lv e - (* GCC: recognize and handle gcc's intrinsic vararg functions *) - | Call (None, Lval(Var vi, NoOffset), args, _) - when mem_assoc vi.vname vaIntrinsics -> iVaIntrinsic vi.vname args - (* GCC: recognize and handle gcc's intrinsic va_arg function *) - | Call (None, Lval(Var vi, NoOffset), [valist; SizeOf targ; dest], _) - when vi.vname = "__builtin_va_arg" -> iVaArg valist targ dest - | Call (r, fn, args, _) -> iCall r fn args - | Asm _ -> raise (Unimplemented "Asm") - - and iSet (lv:lval) (e:exp) : llvmInstruction list = - let (il,v) = iExp e in - il @ iWLval lv v - - (* Handle one of gcc's intrinsic vararg functions (va_start, va_end, va_copy) - by calling the corresponding LLVM intrinsic. This latter expects all - arguments to be of type i8 *, and be the address of the va_list arguments. *) - and iVaIntrinsic (name:string) (args:exp list) : llvmInstruction list = - let vaExp (e:exp) = - let (il, v) = iExp (mkAddrOfExp e) in - let (iv_cast, vi8) = mkCast v i8starType in - (il @ [ iv_cast ], vi8) - in - let (ilargs, vargs) = split (map vaExp args) in - let call = mkVoidIns LIcall (assoc name vaIntrinsics :: vargs) in - (flatten ilargs) @ [ call ] - - (* Handle gcc's intrinsic va_arg function by using LLVM's va_arg instruction *) - and iVaArg (valist:exp) (targ:typ) (dest:exp) = - let destlv = match dest with - | CastE(_, AddrOf lv) -> lv - | _ -> raise Bug in - let (il, v) = iExp (mkAddrOfExp valist) in - let tmpdest = nextTemp targ in - let va_arg_ins = mkIns LIva_arg tmpdest [ v; LType targ ] in - (* CIL doesn't insert the implicit cast to dest's type, so we do... *) - let destt = (typeOfLval destlv) in - if compareTypes targ destt then - il @ (va_arg_ins :: iWLval destlv (LLocal tmpdest)) - else - let (cast_ins, vcast) = mkCast (LLocal tmpdest) destt in - il @ (va_arg_ins :: cast_ins :: iWLval destlv vcast) - - and iCall (r:lval option) (fn:exp) (args:exp list) : llvmInstruction list = - let (ret, argst, _, _) = splitFunctionType (typeOf fn) in - let (ilargs, vargs) = split (iArgs args (argsToList argst)) in - let (ilfn, vfn) = iExp (mkAddrOfExp fn) in - if isCompType ret then - (* X86: structures returned by copy into distinguished first argument *) - match r with - | Some rv -> - (* iRLval returns the pointer value when asked to read a structure *) - let (ilres, vresptr) = iRLval rv in - let call = mkVoidIns LIcall (vfn :: vresptr :: vargs) in - (flatten ilargs) @ ilres @ ilfn @ [ call ] - | None -> - let resptr = nextTemp (TPtr(ret, [])) in - tmp_allocas := mkIns LIalloca resptr [ LType ret ] :: !tmp_allocas; - let call = mkVoidIns LIcall (vfn :: (LLocal resptr) :: vargs) in - (flatten ilargs) @ ilfn @ [ call ] - else - match r with - | Some rv -> - let callResult = nextTemp ret in - let call = mkIns LIcall callResult (vfn :: vargs) in - (flatten ilargs) @ ilfn @ [ call ] @ iWLval rv (LLocal callResult) - | None -> - let call = mkVoidIns LIcall (vfn :: vargs) in - (flatten ilargs) @ ilfn @ [ call ] - - and iArgs (args:exp list) (argts: (string * typ * attributes) list) : (llvmInstruction list * llvmValue) list = - (* compile argument list - this would be just "map iExp", except that - CIL doesn't include the default promotions for varargs and oldstyle - functions *) - match (args, argts) with - | ([], []) -> [] - | (a1::args', t1::argts') -> iExp a1 :: iArgs args' argts' - | (a1::args', []) -> - let t1 = typeOf a1 in - begin - match defaultPromotion t1 with - | Some t' -> iCast t' a1 :: iArgs args' [] - | None -> iExp a1 :: iArgs args' [] - end - | _ -> raise Bug - - and iExp (e:exp) : llvmInstruction list * llvmValue = - try ([], self#mkConstantExp e) - with NotConstant -> iExpNotConstant e - - and iExpNotConstant (e:exp) : llvmInstruction list * llvmValue = match e with - | Const c -> ([], self#mkConstant c) - | SizeOf t -> iExp (sizeOf t) - | SizeOfE e -> iExp (sizeOf (typeOf e)) - | SizeOfStr s -> ([], LInt (Int64.of_int ((String.length s) + 1), !kindOfSizeOf)) - | AlignOf t -> ([], LInt (Int64.of_int (alignOf_int t), !kindOfSizeOf)) - | AlignOfE e -> ([], LInt (Int64.of_int (alignOf_int (typeOf e)), !kindOfSizeOf)) - | Lval lv -> iRLval lv - | UnOp (op, e, t) -> iUnop op e t - | BinOp (op, e1, e2, t) -> iBinop op e1 e2 t - | CastE (t, e) -> iCast t e - | AddrOf lv -> iAddrOf lv - | StartOf lv -> iStartOf lv - | AddrOfLabel _ -> raise (Unimplemented "AddrOfLabel") - | Question _ -> raise (Unimplemented "Question") - - and iUnop op (e:exp) (t:typ) : llvmInstruction list * llvmValue = - let (il,v) = iExp e in - let targ = typeOf e in - let res = nextTemp t in - let ins = - match op with - | Neg -> [ mkIns (LIbinary LBsub) res [ lzero targ; v ] ] - | BNot -> [ mkIns (LIbinary LBxor) res [ v; lint (-1) targ ] ] - | LNot -> - let istrue = nextTemp i1Type in - [ mkTrueIns istrue v; - mkIns LIselect res [ LLocal istrue; lzero t; lint 1 t ] ] - in (il @ ins, LLocal res) - - and iBinop op (e1:exp) (e2:exp) (t:typ) : llvmInstruction list * llvmValue = - let (il1,v1) = iExp e1 in - let (il2,v2) = iExp e2 in - let targ1 = typeOf e1 in - let targ2 = typeOf e2 in - let res = nextTemp t in - (* generate code for an arithmetic operator *) - let arith op = [ mkIns (LIbinary op) res [ v1; v2 ] ] in - (* generate code for a comparison operator *) - let compare sop uop fop = - let cmpop = - if isIntegralType targ1 then - if isSignedType targ1 then LIcmp sop else LIcmp uop - else LIfcmp fop - in - let istrue = nextTemp i1Type in - [ mkIns cmpop istrue [ v1; v2 ]; - mkIns LIselect res [ LLocal istrue; lint 1 t; lint 0 t ] ] - in - let il = - match op with - | PlusA -> arith LBadd - | MinusA -> arith LBsub - | (PlusPI | IndexPI) -> - (* CIL doesn't cast the 2nd arg to int (could be viewed as a bug) *) - if compareTypesNoAttributes targ2 intType then - [ mkIns LIgetelementptr res [ v1; v2 ] ] - else - let (icast, v2') = mkCast v2 intType in - [ icast; mkIns LIgetelementptr res [ v1; v2' ] ] - | MinusPI -> - let tmp = nextTemp targ2 in - (* CIL doesn't cast the 2nd arg to int (could be viewed as a bug) *) - if compareTypesNoAttributes targ2 intType then - [ mkIns (LIbinary LBsub) tmp [ lzero targ2; v2 ]; - mkIns LIgetelementptr res [ v1; LLocal tmp ] ] - else - let (icast, v2') = mkCast v2 intType in - [ icast; mkIns (LIbinary LBsub) tmp [ lzero targ2; v2' ]; - mkIns LIgetelementptr res [ v1; LLocal tmp ] ] - | MinusPP -> - let (cast1_ins, asint1) = mkCast v1 t in - let (cast2_ins, asint2) = mkCast v2 t in - let diff = nextTemp t in - let elemsize = bitsSizeOf (typePointsTo targ1) / 8 in - [ cast1_ins; cast2_ins; - mkIns (LIbinary LBsub) diff [ asint1; asint2 ]; - mkIns (LIbinary LBsdiv) res [ LLocal diff; lint elemsize t ] ] - | Mult -> arith LBmul - | Div -> - let op = - if isIntegralType t then - if isSignedType t then LBsdiv else LBudiv - else LBfdiv - in arith op - | Mod -> arith (if isSignedType t then LBsrem else LBurem) - | Shiftlt -> arith LBshl - | Shiftrt -> arith (if isSignedType t then LBashr else LBlshr) - | BAnd -> arith LBand - | BOr -> arith LBor - | BXor -> arith LBxor - (* for floating point, llvm-gcc believes in unordered !=, ordered - everything else *) - | Lt -> compare LCslt LCult LCFolt - | Gt -> compare LCsgt LCugt LCFogt - | Le -> compare LCsle LCule LCFole - | Ge -> compare LCsge LCuge LCFoge - | Eq -> compare LCeq LCeq LCFoeq - | Ne -> compare LCne LCne LCFune - | LAnd -> raise (Unimplemented "LAnd") (* not normally used by CIL *) - | LOr -> raise (Unimplemented "Lor") (* not normally used by CIL *) - in (il1 @ il2 @ il, LLocal res) - - and iCast (tto:typ) (e:exp) : llvmInstruction list * llvmValue = - let (il, v) = iExp e in - let (cast_ins, vc) = mkCast v tto in - (il @ [ cast_ins ], vc) - - (* Return the instructions, getelementptr access path and result type for - evaluating CIL access path 'o' from base type 't' *) - and accessPath (o:offset) (t:typ) : llvmInstruction list * llvmValue list * typ = - match o with - | NoOffset -> ([], [], t) - | Field (fi, o') -> - let fieldIndex = fieldIndexOf fi in - let (ilo', opath', t') = accessPath o' fi.ftype in - (ilo', lint fieldIndex i32Type :: opath', t') - | Index (e, o') -> - let (il, v) = iExp e in - let (ilo', opath', t') = accessPath o' (typeArrayOf t) in - (il @ ilo', v :: opath', t') - - and iLhost (h:lhost) : llvmInstruction list * llvmValue = - match h with - | Var vi -> ([], lvar vi) - | Mem e -> iExp e - - and lvalPtr (h:lhost) (o:offset) : llvmInstruction list * llvmValue * typ = - if o = NoOffset then - match h with - | Var vi -> ([], lvar vi, vi.vtype) - | Mem e -> let (il, v) = iExp e in (il, v, typePointsTo (typeOf e)) - else - let (ilo, opath, t) = accessPath o (typeOfLhost h) in - let ptr = nextTemp (TPtr(t, [])) in - let (ilh, vh) = iLhost h in - (ilo @ ilh @ [ mkIns LIgetelementptr ptr (vh :: lzerop :: opath) ], LLocal ptr, t) - - and isSimpleLval (h:lhost) (o:offset) = - o = NoOffset && match h with - | Var vi when isFunctionType vi.vtype -> true - | Var vi when not vi.vglob && llvmUseLocal vi -> true - | _ -> false - - and varinfoOf (h:lhost) = match h with - | Var vi -> vi - | _ -> raise Bug - - (* Return instructions to write 'v' to lvalue '(h, o)'. - Handling NoOffset separately makes this code clearer, as it's - always fairly different than the offset case *) - and iWLval (h, o) (v:llvmValue) : llvmInstruction list = - if isSimpleLval h o then - [ mkIns LIassign (llocal (varinfoOf h)) [ v ] ] - else - let (ilptr, ptr, t) = lvalPtr h o in - if isCompType t then ilptr @ iMemcpy ptr v - else ilptr @ [ mkVoidIns LIstore [ v; ptr ]] - - (* Read lvalue '(h, o)', returns instructions and the LLVM value of the result. - Handling NoOffset separately makes this code clearer, as it's - always fairly different than the offset case *) - and iRLval (h, o) : llvmInstruction list * llvmValue = - if isSimpleLval h o then - ([], lvar (varinfoOf h)) - else - let (ilptr, ptr, t) = lvalPtr h o in - if isCompType t then (* just return a pointer to the structure *) - (ilptr, ptr) - else - let res = nextTemp t in - (ilptr @ [ mkIns LIload res [ ptr ]], LLocal res) - - (* Get a pointer to the start of an lvalue representing an array *) - and iStartOf (h, o) : llvmInstruction list * llvmValue = - iAddrOf (h, (addOffset (Index (zero, NoOffset)) o)) - - (* Get a pointer to lvalue '(h, o)'. - Handling NoOffset separately makes this code clearer, as it's - always fairly different than the offset case *) - and iAddrOf (h, o) : llvmInstruction list * llvmValue = - let (ilptr, ptr, t) = lvalPtr h o in (ilptr, ptr) - - (* stack allocate locals that aren't ssa'ed *) - and allocateLocals (locals:varinfo list) : llvmInstruction list = - let genLocal (il:llvmInstruction list) (vi:varinfo) = - if not (llvmUseLocal vi) then - mkIns LIalloca (llocal vi) [ LType vi.vtype ] :: il - else - il - in fold_left genLocal [] locals - - (* stack allocate and save formals whose address is taken, if they would - normally be ssa'ed *) - and saveFormals (formals:varinfo list) : llvmInstruction list = - let saveFormal (il:llvmInstruction list) (vi:varinfo) = - if llvmDoNotUseLocal vi then - let lvi = llocal vi in - mkIns LIalloca lvi [ LType vi.vtype ] :: - mkVoidIns LIstore [ LLocal (vi.vname, vi.vtype); LLocal lvi ] :: il - else - il - in fold_left saveFormal [] formals - - (* Simplify generated blocks by removing unreachable blocks, and merging - blocks with a single predecessor into that predecessor when possible. - This is not strictly necessary, but makes output more readable. *) - and simplifyBlock (b:llvmBlock) : bool = - if b.lbterminator = TDead then - false - else if length b.lbpreds = 1 then - let pred = hd b.lbpreds in - match pred.lbterminator with - | TBranch _ -> - pred.lbbody <- pred.lbbody @ b.lbbody; - pred.lbterminator <- b.lbterminator; - b.lbbody <- []; - ignore(simplifyBlock pred); - false - | _ -> true - else true - - (* Change the terminator of all blocks in 'bl' not reachable from 'entry' - to TDead, so that simplifyBlock can remove them *) - and markReachable (entry:llvmBlock) (bl:llvmBlock list) : unit = - let reachable = H.create 32 in - H.add reachable entry.lblabel true; - let worklist = ref [ entry ] in - let mark b = - if not (H.mem reachable b.lblabel) then begin - H.add reachable b.lblabel true; - worklist := b :: !worklist - end - in - while !worklist <> [] do - let work = hd !worklist in - worklist := tl !worklist; - iter mark (llvmDestinations work.lbterminator) - done; - let kill b = - if not (H.mem reachable b.lblabel) then b.lbterminator <- TDead - in iter kill bl - - (* Add 'b' to the lbpreds (predecessors) set of its successors *) - and setPredecessors (b:llvmBlock) : unit = - let addPred (succ:llvmBlock) = - if not (memq b succ.lbpreds) then succ.lbpreds <- b :: succ.lbpreds - in - iter addPred (llvmDestinations b.lbterminator) - in - - (*ignore(Pretty.eprintf "%a\n" (printBlock plainCilPrinter) f.sbody);*) - let entry = gBlock "entry" f.sbody TUnreachable TUnreachable TUnreachable in - entry.lbbody <- (saveFormals f.sformals) @ (allocateLocals f.slocals) @ !tmp_allocas @ entry.lbbody; - markReachable entry !blocks; - iter setPredecessors !blocks; - blocks := filter simplifyBlock !blocks; - (* recompute predecessors after simplification *) - iter (fun b -> b.lbpreds <- []) !blocks; - iter setPredecessors !blocks; - (*fprint ~width:80 stderr (dprintf "%s\n%a" f.svar.vname self#printBlocks !blocks);*) - !blocks -end diff --git a/src/ext/llvm/llvmssa.ml b/src/ext/llvm/llvmssa.ml deleted file mode 100644 index 71700a019..000000000 --- a/src/ext/llvm/llvmssa.ml +++ /dev/null @@ -1,234 +0,0 @@ -(* Copyright (c) 2008 Intel Corporation - * 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 Intel Corporation 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 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 INTEL OR ITS - * 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. - *) - -(* Transform LLVM code output by llvmGeneratorClass#mkFunction into SSA form. - Uses the SSA transformation algorithm described in: - Simple Generation of Static Single-Assignment Form - John Aycock and Nigel Horspool - CC'2000 - (which is much simpler and essentially just as effective as the "usual", rather - complex algorithm...) -*) - -let z = 3 - -open Cil -open List -open Printf -open Llvmutils -open Llvmgen -open Pretty -module H = Hashtbl -module S = String - -let z = 3 - -(* Apply the SSA transform on locals in 'ssavars' to a function whose - body is 'bl'. 'formals' is the formal arguments to the function - (but formals which should be subject to the SSA transform must also - be in the 'ssavars' list). *) - -let z = 3 - -let llvmSsa (globals:llvmGenerator) (bl:llvmBlock list) (formals:varinfo list) (ssavars:varinfo list) : llvmBlock list = - (* map from (b:string, v:string) -> llvmLocal - giving the ssa variable to use for 'v' at entry to block labeled 'b' *) - let entryName = H.create 32 - - (* map from (b:string, v:string) -> llvmValue - giving the value to use for 'v' at exit from block labeled 'b' - note that the result is a value as 'v' may have been assigned a constant in 'b' *) - and exitValue = H.create 32 in - - let id = ref 0 in - (* create a new unique LLVM local for local variable 'vi' *) - let nextname (s:string) (t:typ) : llvmLocal = - id := !id + 1; - (sprintf "%s.%d" s !id, t) - in - - (* Rename variables 'vl' in block 'b': pick new variables for 'b' at - entry to 'b' (except if 'b' is the function entry point), and - rename all uses and subsequent assignments. Record the variable's - new names at entry to 'b' and new values at exit from 'b' in - entryName and exitValue *) - let renameVariables (vl:varinfo list) (b:llvmBlock) : unit = - let blabel = b.lblabel in - - (* The entry value is a new variable for all blocks except the function entry - point. At entry, formals keep their name in the argument list, while - non-formals get C's 0 value for their type (maybe LUndef would be a better - choice?) *) - let name1 vi = - if b.lbpreds <> [] then begin - let phiname = nextname vi.vname vi.vtype in - H.add entryName (b.lblabel, vi.vname) phiname; - LLocal phiname - end else if memq vi formals then - LLocal (vi.vname, vi.vtype) - else - lzero vi.vtype - in - - (* Set initial variable values *) - iter (fun vi -> H.add exitValue (blabel, vi.vname) (name1 vi)) vl; - - (* Rename LLVM value 'lv' *) - let rec renameValue (lv:llvmValue) = match lv with - | LLocal (av, t) when H.mem exitValue (blabel, av) -> H.find exitValue (blabel, av) - | _ -> lv - - (* Rename 'i's arguments, and remap the assigned variable if it's in vl *) - and renameIns (i:llvmInstruction) : unit = - i.liargs <- map renameValue i.liargs; - match i.liresult with - | Some (rv, t) when H.mem exitValue (blabel, rv) -> (* rv assigned, pick new name *) - if i.liop = LIassign then (* special assignment instruction *) - (* from here on, substitute rv with the value assigned *) - H.replace exitValue (blabel, rv) (hd i.liargs) - else begin - (* give rv a new name *) - let newname = nextname rv t in - i.liresult <- Some newname; - H.replace exitValue (blabel, rv) (LLocal newname) - end - | _ -> () - - (* Rename in terminator 'term' *) - and renameTerminator (term:llvmTerminator) : llvmTerminator = - match term with - | TRet lv -> TRet (map renameValue lv) - | TCond (lv, b1, b2) -> TCond (renameValue lv, b1, b2) - | TSwitch (lv, db, cases) -> TSwitch (renameValue lv, db, cases) - | _ -> term - in - - iter renameIns b.lbbody; - b.lbterminator <- renameTerminator b.lbterminator; - in - - (* Add the phi statement for 'vi' to the start of block 'b' *) - let addPhi (b:llvmBlock) (vi:varinfo) : unit= - if b.lbpreds <> [] then - let v = vi.vname in - let args = map (fun pb -> LPhi (H.find exitValue (pb.lblabel, v), pb)) b.lbpreds in - let phiIns = mkIns LIphi (H.find entryName (b.lblabel, v)) args in - b.lbbody <- phiIns :: b.lbbody - in - - (* Optimize phi statements following Aycock & Horspool - see the paper for - full details *) - let optimizeSsa (bl:llvmBlock list) : unit = - (* A union-find hash table for tracking an SSA variable's current value *) - let varmap = H.create 32 in - let rec remap v = - (*fprint ~width:80 stderr (dprintf "lookup %a\n" globals#printValue v);*) - if H.mem varmap v then - let v' = H.find varmap v in - let v'' = remap v' in - if not (llvmValueEqual v'' v') then begin - (*fprint ~width:80 stderr (dprintf "short %a -> %a\n" globals#printValue v globals#printValue v'');*) - H.replace varmap v v'' - end; - v'' - else - v - in - - (* One optimization pass: remove phi-statements of the form d=phi(d, ..., d) - and d=phi(...d or c...), in the latter case rename d to c. Note that c - might be an LLVM value. *) - let onepass () : bool = - let change = ref false in - let oneins (i:llvmInstruction) : unit = - if i.liop = LIphi && i.liargs <> [] then - let rec checkRewrite (d:llvmValue) (phiargs:llvmValue list) = - match phiargs with - | LPhi (v, _) :: phiargs' -> - let v' = remap v in - if llvmValueEqual v' d then - checkRewrite d phiargs' - else - checkCandidate d phiargs' v' - | [] -> i.liargs <- [] (* it's all d = phi(d, ..., d) -> nuke the phi *) - | _ -> () - and checkCandidate (d:llvmValue) (phiargs:llvmValue list) (c:llvmValue) = - match phiargs with - | LPhi (v, _) :: phiargs' -> - let v' = remap v in - if llvmValueEqual v' c || llvmValueEqual v' d then - checkCandidate d phiargs' c - | [] -> (* it's all d = phi(...d or c...) -> nuke the phi and replace d by c *) - change := true; - (*fprint ~width:80 stderr (dprintf "remap %a -> %a, %B\n" globals#printValue d globals#printValue c (llvmValueEqual d c));*) - H.add varmap d c; - i.liargs <- [] - | _ -> () - in - checkRewrite (LLocal (getOption i.liresult)) i.liargs - - in iter (fun b -> iter oneins b.lbbody) bl; - !change - in - - (* After optimization, remap all variables to their final value *) - let doremap () = - let rec remapval (v:llvmValue) : llvmValue = match v with - | LLocal lv -> remap v - | LPhi (v', b) -> LPhi (remapval v', b) - | _ -> v - in - let remapterm (t:llvmTerminator) : llvmTerminator = - match t with - | TRet lv -> TRet (map remapval lv) - | TCond (lv, b1, b2) -> TCond (remapval lv, b1, b2) - | TSwitch (lv, db, cases) -> TSwitch (remapval lv, db, cases) - | _ -> t - in - let remapins (i:llvmInstruction) : unit = - i.liargs <- map remapval i.liargs - in iter (fun b -> iter remapins b.lbbody; b.lbterminator <- remapterm b.lbterminator) bl - in - - while onepass () do () done; - doremap () - in - - (* Remove the phi instructions killed by optimization, and the assignment - statements we created during initial code generation *) - let removeAssignAndDeadPhi (b:llvmBlock) : unit = - let liveins i = not (i.liop = LIassign || i.liop = LIphi && i.liargs = []) in - b.lbbody <- filter liveins b.lbbody - in - - iter (renameVariables ssavars) bl; - iter (fun b -> iter (addPhi b) ssavars) bl; - (*fprint ~width:80 stderr (dprintf "%s\n%a" "pre-opt" globals#printBlocks bl);*) - optimizeSsa bl; - iter removeAssignAndDeadPhi bl; - bl diff --git a/src/ext/llvm/llvmutils.ml b/src/ext/llvm/llvmutils.ml deleted file mode 100644 index 32585c735..000000000 --- a/src/ext/llvm/llvmutils.ml +++ /dev/null @@ -1,169 +0,0 @@ -(* Copyright (c) 2008 Intel Corporation - * 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 Intel Corporation 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 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 INTEL OR ITS - * 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. - *) - -(* General utility functions for the LLVM code generation (some of these are - more generally useful) -*) -open Cil -open Pretty -open List - -exception Unimplemented of string -exception Bug - -(* A few useful predicate / accessor functions - the accessor functions raise Bug - when the argument isn't as expected *) - -let getOption (v:'a option) : 'a = - match v with - | Some x -> x - | None -> raise Bug - -(* Type predicates *) -let isFloatingType t = - match unrollType t with - | TFloat _ -> true - | _ -> false -let isSignedType t = - match unrollType t with - | TInt (ik, _) -> isSigned ik - | _ -> false -let isVaListType (t:typ) = - match unrollType t with - | TBuiltin_va_list _ -> true - | _ -> false -let isCompType (t:typ) = - match unrollType t with - | TComp _ -> true - | _ -> false - -let defaultPromotion (t:typ) : typ option = - match unrollType t with - | TFloat (FFloat, _) -> Some doubleType - | TInt (ik, _) when bytesSizeOfInt ik < bytesSizeOfInt IInt -> Some intType - | _ -> None - -(* Extract information from types *) -let integralKind (t:typ) : ikind = - match unrollType t with - | TInt (ik, _) -> ik - | TEnum _ -> IInt - | _ -> IInt -let typeArrayOf (t:typ) : typ = - match unrollType t with - | TArray (t, _, _) -> t - | _ -> raise Bug -let typePointsTo (t:typ) : typ = - match unrollType t with - | TPtr (t, _) -> t - | _ -> raise Bug - -let typeOfLhost (h:lhost) = - match h with - | Var vi -> vi.vtype - | Mem e -> typePointsTo (typeOf e) - -(* The index of field fi within its structure *) -let fieldIndexOf (fi:fieldinfo) : int = - let rec indexLoop fields n = match fields with - | [] -> raise Bug - | fi' :: _ when fi' == fi -> n - | _ :: fields' -> indexLoop fields' (n + 1) - in indexLoop fi.fcomp.cfields 0 - -(* Reduce a constant expression to its integer value - fail if it isn't possible *) -let intConstValue (e:exp) : int64 = - match constFold true e with - | Const(CInt64(n,_,_)) -> n - | _ -> raise Bug - -(* Return the &e expression, fail if that's illegal *) -let mkAddrOfExp (e:exp) : exp = - match e with - | Lval lv -> mkAddrOrStartOf lv - | _ -> raise Bug - -(* Convert a CIL function signature to an LLVM type signature (as a doc string). - 'name' is the function name if any; use 'name = nil' to generate a function-type - doc string. *) -let rec gSig (name:doc) (ret, oargs, isva, a) : doc = - let args = argsToList oargs in - let parg (argname, t, _) = - let namedoc () = - (* don't print argument names in function-type doc strings *) - if name <> nil && argname <> "" then (text " %") ++ (text argname) else nil - in - if isCompType t then - (* X86: structures passed by value, using LLVM's byval annotation *) - dprintf "%a *byval%t" dgType t namedoc - else - dprintf "%a%t" dgType t namedoc - in - let varargs () = if isva then text ", ..." else - match oargs with - | Some _ -> nil - | None -> text "..." in - if isCompType ret then - (* X86: structure results handled as a special first argument pointing to the - result buffer, marked with LLVM's sret annotation *) - let resultName () = if name <> nil then (text " %.result") else nil in - dprintf "void %a(%a *sret%t, %a%t)" insert name dgType ret resultName (docList parg) args varargs - else - dprintf "%a %a(%a%t)" dgType ret insert name (docList parg) args varargs - -(* Convert a CIL type 't' to an LLVM type (as a doc string) *) -and gType (t:typ) : doc = match t with -| TVoid _ -> text "void" -| TInt (ik, _) -> dprintf "i%d" (bitsSizeOf t) -| TFloat (FFloat, _) -> text "float" -| TFloat (FDouble, _) -> text "double" -| TFloat (FLongDouble, _) -> text "fp128" -| TPtr (t, _) -> - (* LLVM uses "i8 *" for 'void *' *) - if isVoidType t then text "i8 *" - else (gType t) ++ (text " *") -| TArray (t, None, _) -> (text "[ 0 x ") ++ (gType t) ++ (text "]") -| TArray (t, size, _) -> - let asize = try lenOfArray size with LenOfArray -> 0 in - dprintf "[ %d x %a ]" asize dgType t -| TFun (a, b, c, d) -> gSig nil (a, b, c, d) -| TNamed (ti, _) -> gType ti.ttype -| TComp (ci, _) -> (text "%struct.") ++ (text ci.cname) -| TEnum (ei, _) -> dprintf "i%d" (bitsSizeOf t) -| TBuiltin_va_list _ -> text "i8 *" - -(* Convert a CIL type 't' to an LLVM type (as a doc string), for use with dprintf's %a *) -and dgType () = gType - -(* Generate an LLVM function header for function 'f' (as a doc string) *) -let gFunctionSig (fi:varinfo) : doc = - gSig ((text "@") ++ (text fi.vname)) (splitFunctionType fi.vtype) -(* Generate an LLVM function header for function 'f' (as a doc string), for use - with dprintf's %a *) -let dgFunctionSig () = gFunctionSig - diff --git a/src/ext/logcalls/META b/src/ext/logcalls/META deleted file mode 100644 index f014e5691..000000000 --- a/src/ext/logcalls/META +++ /dev/null @@ -1 +0,0 @@ -description = "generation of code to log function calls" diff --git a/src/ext/logcalls/default b/src/ext/logcalls/default deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/ext/logcalls/logcalls.ml b/src/ext/logcalls/logcalls.ml deleted file mode 100644 index 20d6b2729..000000000 --- a/src/ext/logcalls/logcalls.ml +++ /dev/null @@ -1,271 +0,0 @@ -(** See copyright notice at the end of this file *) - -(** Add printf before each function call *) - -open Pretty -open Cil -open Feature -open Trace -module E = Errormsg -module H = Hashtbl - -let i = ref 0 -let name = ref "" - -(* Switches *) -let printFunctionName = ref "printf" - -let addProto = ref false - -let printf: varinfo option ref = ref None -let makePrintfFunction () : varinfo = - match !printf with - Some v -> v - | None -> begin - let v = makeGlobalVar !printFunctionName - (TFun(voidType, Some [("format", charPtrType, [])], - true, [])) in - printf := Some v; - addProto := true; - v - end - -let mkPrint (format: string) (args: exp list) : instr = - let p: varinfo = makePrintfFunction () in - Call(None, Lval(var p), (mkString format) :: args, !currentLoc) - - -let d_string (fmt : ('a,unit,doc,string) format4) : 'a = - let f (d: doc) : string = - Pretty.sprint 200 d - in - Pretty.gprintf f fmt - -let currentFunc: string ref = ref "" - -class logCallsVisitorClass = object - inherit nopCilVisitor - - (* Watch for a declaration for our printer *) - - method vinst i = begin - match i with - | Call(lo,e,al,l) -> - let pre = mkPrint (d_string "call %a\n" d_exp e) [] in - let post = mkPrint (d_string "return from %a\n" d_exp e) [] in -(* - let str1 = prefix ^ - (Pretty.sprint 800 ( Pretty.dprintf "Calling %a(%a)\n" - d_exp e - (docList ~sep:(chr ',' ++ break ) (fun arg -> - try - match unrollType (typeOf arg) with - TInt _ | TEnum _ -> dprintf "%a = %%d" d_exp arg - | TFloat _ -> dprintf "%a = %%g" d_exp arg - | TVoid _ -> text "void" - | TComp _ -> text "comp" - | _ -> dprintf "%a = %%p" d_exp arg - with _ -> dprintf "%a = %%p" d_exp arg)) al)) in - let log_args = List.filter (fun arg -> - match unrollType (typeOf arg) with - TVoid _ | TComp _ -> false - | _ -> true) al in - let str2 = prefix ^ (Pretty.sprint 800 - ( Pretty.dprintf "Returned from %a\n" d_exp e)) in - let newinst str args = ((Call (None, Lval(var printfFun.svar), - ( [ (* one ; *) mkString str ] @ args), - locUnknown)) : instr )in - let ilist = ([ (newinst str1 log_args) ; i ; (newinst str2 []) ] : instr list) in - *) - ChangeTo [ pre; i; post ] - - | _ -> DoChildren - end - method vstmt (s : stmt) = begin - match s.skind with - Return _ -> - let pre = mkPrint (d_string "exit %s\n" !currentFunc) [] in - ChangeTo (mkStmt (Block (mkBlock [ mkStmtOneInstr pre; s ]))) - | _ -> DoChildren - -(* -(Some(e),l) -> - let str = prefix ^ Pretty.sprint 800 ( Pretty.dprintf - "Return(%%p) from %s\n" funstr ) in - let newinst = ((Call (None, Lval(var printfFun.svar), - ( [ (* one ; *) mkString str ; e ]), - locUnknown)) : instr )in - let new_stmt = mkStmtOneInstr newinst in - let slist = [ new_stmt ; s ] in - (ChangeTo(mkStmt(Block(mkBlock slist)))) - | Return(None,l) -> - let str = prefix ^ (Pretty.sprint 800 ( Pretty.dprintf - "Return void from %s\n" funstr)) in - let newinst = ((Call (None, Lval(var printfFun.svar), - ( [ (* one ; *) mkString str ]), - locUnknown)) : instr )in - let new_stmt = mkStmtOneInstr newinst in - let slist = [ new_stmt ; s ] in - (ChangeTo(mkStmt(Block(mkBlock slist)))) - | _ -> DoChildren -*) - end -end - -let logCallsVisitor = new logCallsVisitorClass - - -let logCalls (f: file) : unit = - - let doGlobal = function - | GVarDecl (v, _) when v.vname = !printFunctionName -> - if !printf = None then - printf := Some v - - | GFun (fdec, loc) -> - currentFunc := fdec.svar.vname; - (* do the body *) - ignore (visitCilFunction logCallsVisitor fdec); - (* Now add the entry instruction *) - let pre = mkPrint (d_string "enter %s\n" !currentFunc) [] in - fdec.sbody <- - mkBlock [ mkStmtOneInstr pre; - mkStmt (Block fdec.sbody) ] -(* - (* debugging 'anagram', it's really nice to be able to see the strings *) - (* inside fat pointers, even if it's a bit of a hassle and a hack here *) - let isFatCharPtr (cinfo:compinfo) = - cinfo.cname="wildp_char" || - cinfo.cname="fseqp_char" || - cinfo.cname="seqp_char" in - - (* Collect expressions that denote the actual arguments *) - let actargs = - (* make lvals out of args which pass test below *) - (Util.list_map - (fun vi -> match unrollType vi.vtype with - | TComp(cinfo, _) when isFatCharPtr(cinfo) -> - (* access the _p field for these *) - (* luckily it's called "_p" in all three fat pointer variants *) - Lval(Var(vi), Field(getCompField cinfo "_p", NoOffset)) - | _ -> - Lval(var vi)) - - (* decide which args to pass *) - (List.filter - (fun vi -> match unrollType vi.vtype with - | TPtr(TInt(k, _), _) when isCharType(k) -> - !printPtrs || !printStrings - | TComp(cinfo, _) when isFatCharPtr(cinfo) -> - !printStrings - | TVoid _ | TComp _ -> false - | TPtr _ | TArray _ | TFun _ -> !printPtrs - | _ -> true) - fdec.sformals) - ) in - - (* make a format string for printing them *) - (* sm: expanded width to 200 because I want one per line *) - let formatstr = prefix ^ (Pretty.sprint 200 - (dprintf "entering %s(%a)\n" fdec.svar.vname - (docList ~sep:(chr ',' ++ break) - (fun vi -> match unrollType vi.vtype with - | TInt _ | TEnum _ -> dprintf "%s = %%d" vi.vname - | TFloat _ -> dprintf "%s = %%g" vi.vname - | TVoid _ -> dprintf "%s = (void)" vi.vname - | TComp(cinfo, _) -> ( - if !printStrings && isFatCharPtr(cinfo) then - dprintf "%s = \"%%s\"" vi.vname - else - dprintf "%s = (comp)" vi.vname - ) - | TPtr(TInt(k, _), _) when isCharType(k) -> ( - if (!printStrings) then - dprintf "%s = \"%%s\"" vi.vname - else if (!printPtrs) then - dprintf "%s = %%p" vi.vname - else - dprintf "%s = (str)" vi.vname - ) - | TPtr _ | TArray _ | TFun _ -> ( - if (!printPtrs) then - dprintf "%s = %%p" vi.vname - else - dprintf "%s = (ptr)" vi.vname - ) - | _ -> dprintf "%s = (?type?)" vi.vname)) - fdec.sformals)) in - - i := 0 ; - name := fdec.svar.vname ; - if !allInsts then ( - let thisVisitor = new verboseLogVisitor printfFun !name prefix in - fdec.sbody <- visitCilBlock thisVisitor fdec.sbody - ); - fdec.sbody.bstmts <- - mkStmt (Instr [Call (None, Lval(var printfFun.svar), - ( (* one :: *) mkString formatstr - :: actargs), - loc)]) :: fdec.sbody.bstmts - *) - | _ -> () - in - Stats.time "logCalls" (iterGlobals f) doGlobal; - if !addProto then begin - let p = makePrintfFunction () in - E.log "Adding prototype for call logging function %s\n" p.vname; - f.globals <- GVarDecl (p, locUnknown) :: f.globals - end - -let feature = - { fd_name = "logcalls"; - fd_enabled = false; - fd_description = "generation of code to log function calls"; - fd_extraopt = [ - ("--logcallprintf", Arg.String (fun s -> printFunctionName := s), - " the name of the printf function to use"); - ("--logcalladdproto", Arg.Unit (fun s -> addProto := true), - " whether to add the prototype for the printf function") - ]; - fd_doit = logCalls; - fd_post_check = true - } - -let () = Feature.register feature - -(* - * - * 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. - * - *) diff --git a/src/ext/logcalls/logcalls.mli b/src/ext/logcalls/logcalls.mli deleted file mode 100644 index d96021011..000000000 --- a/src/ext/logcalls/logcalls.mli +++ /dev/null @@ -1,41 +0,0 @@ -(* - * - * 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. - * - *) - - -(* A simple CIL transformer that inserts calls to a runtime function to log - * the call in each function *) -val feature: Feature.t diff --git a/src/ext/logwrites/META b/src/ext/logwrites/META deleted file mode 100644 index 8bfeea6ed..000000000 --- a/src/ext/logwrites/META +++ /dev/null @@ -1 +0,0 @@ -description = "generation of code to log memory writes" diff --git a/src/ext/logwrites/default b/src/ext/logwrites/default deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/ext/logwrites/logwrites.ml b/src/ext/logwrites/logwrites.ml deleted file mode 100644 index 02fefcf2e..000000000 --- a/src/ext/logwrites/logwrites.ml +++ /dev/null @@ -1,141 +0,0 @@ -(* - * - * 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. - * - *) - -open Pretty -open Cil -open Feature -module E = Errormsg -module H = Hashtbl - -(* David Park at Stanford points out that you cannot take the address of a - * bitfield in GCC. *) - -(* Returns true if the given lvalue offset ends in a bitfield access. *) -let rec is_bitfield lo = match lo with - | NoOffset -> false - | Field(fi,NoOffset) -> not (fi.fbitfield = None) - | Field(_,lo) -> is_bitfield lo - | Index(_,lo) -> is_bitfield lo - -(* Return an expression that evaluates to the address of the given lvalue. - * For most lvalues, this is merely AddrOf(lv). However, for bitfields - * we do some offset gymnastics. - *) -let addr_of_lv (lh,lo) = - if is_bitfield lo then begin - (* we figure out what the address would be without the final bitfield - * access, and then we add in the offset of the bitfield from the - * beginning of its enclosing comp *) - let rec split_offset_and_bitfield lo = match lo with - | NoOffset -> failwith "logwrites: impossible" - | Field(fi,NoOffset) -> (NoOffset,fi) - | Field(e,lo) -> let a,b = split_offset_and_bitfield lo in - ((Field(e,a)),b) - | Index(e,lo) -> let a,b = split_offset_and_bitfield lo in - ((Index(e,a)),b) - in - let new_lv_offset, bf = split_offset_and_bitfield lo in - let new_lv = (lh, new_lv_offset) in - let enclosing_type = TComp(bf.fcomp, []) in - let bits_offset, bits_width = - bitsOffset enclosing_type (Field(bf,NoOffset)) in - let bytes_offset = bits_offset / 8 in - let lvPtr = mkCast ~e:(mkAddrOf (new_lv)) ~newt:(charPtrType) in - (BinOp(PlusPI, lvPtr, (integer bytes_offset), ulongType)) - end else (AddrOf (lh,lo)) - -class logWriteVisitor = object - inherit nopCilVisitor - (* Create a prototype for the logging function, but don't put it in the - * file *) - val printfFun = - let fdec = emptyFunction "syslog" in - fdec.svar.vtype <- TFun(intType, - Some [ ("prio", intType, []); - ("format", charConstPtrType, []) ], - true, []); - fdec - - method vinst (i: instr) : instr list visitAction = - match i with - Set(lv, e, l) -> begin - (* Check if we need to log *) - match lv with - (Var(v), off) when not v.vglob -> SkipChildren - | _ -> let str = Pretty.sprint 80 - (Pretty.dprintf "Write %%p to 0x%%08x at %%s:%%d (%a)\n" d_lval lv) - in - ChangeTo - [ Call((None), (Lval(Var(printfFun.svar),NoOffset)), - [ one ; - mkString str ; e ; addr_of_lv lv; - mkString l.file; - integer l.line], locUnknown); - i] - end - | Call(Some lv, f, args, l) -> begin - (* Check if we need to log *) - match lv with - (Var(v), off) when not v.vglob -> SkipChildren - | _ -> let str = Pretty.sprint 80 - (Pretty.dprintf "Write retval to 0x%%08x at %%s:%%d (%a)\n" d_lval lv) - in - ChangeTo - [ Call((None), (Lval(Var(printfFun.svar),NoOffset)), - [ one ; - mkString str ; AddrOf lv; - mkString l.file; - integer l.line], locUnknown); - i] - end - | _ -> SkipChildren - -end - -let feature = - { fd_name = "logwrites"; - fd_enabled = false; - fd_description = "generation of code to log memory writes"; - fd_extraopt = []; - fd_doit = - (function (f: file) -> - let lwVisitor = new logWriteVisitor in - visitCilFileSameGlobals lwVisitor f); - fd_post_check = true; - } - -let () = Feature.register feature diff --git a/src/ext/makecfg/META b/src/ext/makecfg/META new file mode 100644 index 000000000..3f870b1d0 --- /dev/null +++ b/src/ext/makecfg/META @@ -0,0 +1 @@ +description = "make the program look more like a CFG" diff --git a/src/ext/callgraph/default b/src/ext/makecfg/default similarity index 100% rename from src/ext/callgraph/default rename to src/ext/makecfg/default diff --git a/src/ext/makecfg/dune b/src/ext/makecfg/dune new file mode 100644 index 000000000..5bbf28b0c --- /dev/null +++ b/src/ext/makecfg/dune @@ -0,0 +1,6 @@ +(library + (public_name goblint-cil.makecfg) + (name makecfg) + (wrapped false) ; this should be changed, but then module paths in goblint need to be prefixed + (libraries goblint-cil) +) diff --git a/src/ext/makecfg/makeCFG.ml b/src/ext/makecfg/makeCFG.ml new file mode 100644 index 000000000..3b6c7fd77 --- /dev/null +++ b/src/ext/makecfg/makeCFG.ml @@ -0,0 +1,117 @@ +(* See copyright notice at the end of the file *) +open Cil +open Feature + +(***************************************************************************** + * A transformation to make every function call end its statement. So + * { x=1; Foo(); y=1; } + * becomes at least: + * { { x=1; Foo(); } + * { y=1; } } + * But probably more like: + * { { x=1; } { Foo(); } { y=1; } } + ****************************************************************************) +let rec contains_call il = + match il with + [] -> false + | Call _ :: tl -> true + | _ :: tl -> contains_call tl + +class callBBVisitor = +object + inherit nopCilVisitor + + method! vstmt s = + match s.skind with + Instr il when contains_call il -> + begin + let list_of_stmts = + Util.list_map (fun one_inst -> mkStmtOneInstr one_inst) il in + let block = mkBlock list_of_stmts in + ChangeDoChildrenPost + (s, (fun _ -> s.skind <- Block block; s)) + end + | _ -> DoChildren + + method! vvdec _ = SkipChildren + method! vexpr _ = SkipChildren + method! vlval _ = SkipChildren + method! vtype _ = SkipChildren +end + +let calls_end_basic_blocks f = + let thisVisitor = new callBBVisitor in + visitCilFileSameGlobals thisVisitor f + +(***************************************************************************** + * A transformation that gives each variable a unique identifier. + ****************************************************************************) +class vidVisitor = object + inherit nopCilVisitor + val count = ref 0 + + method! vvdec vi = + vi.vid <- !count; + incr count; + SkipChildren +end + +let globally_unique_vids f = + let thisVisitor = new vidVisitor in + visitCilFileSameGlobals thisVisitor f + +let makeCFGFeature = + { fd_name = "makeCFG"; + fd_enabled = false; + fd_description = "make the program look more like a CFG" ; + fd_extraopt = []; + fd_doit = (fun f -> + ignore (calls_end_basic_blocks f) ; + ignore (globally_unique_vids f) ; + iterGlobals f (fun glob -> match glob with + GFun(fd,_) -> prepareCFG fd ; + ignore (computeCFGInfo fd true) + | _ -> ()) + ); + fd_post_check = true; + } + +let () = Feature.register makeCFGFeature + +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * Christoph L. Spiel + * 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. + * + *) diff --git a/src/ext/oneret/META b/src/ext/oneret/META deleted file mode 100644 index b88eab144..000000000 --- a/src/ext/oneret/META +++ /dev/null @@ -1 +0,0 @@ -description = "make each function have at most one 'return'" diff --git a/src/ext/oneret/default b/src/ext/oneret/default deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/ext/oneret/oneret.ml b/src/ext/oneret/oneret.ml deleted file mode 100644 index 0029a7841..000000000 --- a/src/ext/oneret/oneret.ml +++ /dev/null @@ -1,177 +0,0 @@ -(* - * - * 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 exactly one Return statement in the whole body. - * Replace all the other returns with Goto. This is convenient if you later - * want to insert some finalizer code, since you have a precise place where - * to put it *) -open Cil -open Feature -open Pretty - -module E = Errormsg - -let dummyVisitor = new nopCilVisitor - -let oneret (f: Cil.fundec) : unit = - let fname = f.svar.vname in - (* Get the return type *) - let retTyp = - match f.svar.vtype with - TFun(rt, _, _, _) -> rt - | _ -> E.s (E.bug "Function %s does not have a function type\n" - 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 locUnknown in - let retVar : varinfo option ref = ref None in - let getRetVar (x: unit) : varinfo = - match !retVar with - Some rv -> rv - | None -> begin - let rv = makeTempVar f ~name:"__retres" retTyp in (* don't collide *) - retVar := Some rv; - rv - end - 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 - (* Must create a statement *) - let rv = - if hasRet then Some (Lval(Var (getRetVar ()), NoOffset)) else None - in - let sr = mkStmt (Return (rv, !lastloc)) in - retStmt := sr; - sr - end else - !retStmt - 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 *) - let rec scanStmts (mainbody: bool) = 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; - [rs] - - | [] -> [] - - | [{skind=Return (Some (Lval(Var _,NoOffset)), _)} as s] - when mainbody && not !haveGoto - -> [s] - - | ({skind=Return (retval, l)} as s) :: rests -> - currentLoc := l; -(* - 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 - E.s (error "Found return without value in function %s" fname); - if not hasRet && retval <> None then - E.s (error "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, l)] - | None -> Instr [] - end; - (* See if this is the last statement in function *) - if mainbody && rests == [] then - s :: scanStmts mainbody rests - else begin - (* Add a Goto *) - let sgref = ref (getRetStmt ()) in - let sg = mkStmt (Goto (sgref, l)) in - haveGoto := true; - s :: sg :: (scanStmts mainbody rests) - end - - | ({skind=If(eb,t,e,l)} as s) :: rests -> - currentLoc := l; - s.skind <- If(eb, scanBlock false t, scanBlock false e, l); - s :: scanStmts mainbody rests - | ({skind=Loop(b,l,lb1,lb2)} as s) :: rests -> - currentLoc := l; - s.skind <- Loop(scanBlock false b, l,lb1,lb2); - s :: scanStmts mainbody rests - | ({skind=Switch(e, b, cases, l)} as s) :: rests -> - currentLoc := l; - s.skind <- Switch(e, scanBlock false b, cases, l); - s :: scanStmts mainbody rests - | ({skind=Block b} as s) :: rests -> - s.skind <- Block (scanBlock false b); - s :: scanStmts mainbody rests - | ({skind=(Goto _ | ComputedGoto _ | Instr _ | Continue _ | Break _ - | TryExcept _ | TryFinally _)} as s) - :: rests -> s :: scanStmts mainbody rests - - and scanBlock (mainbody: bool) (b: block) = - { bstmts = scanStmts mainbody b.bstmts; battrs = b.battrs; } - - in - ignore (visitCilBlock dummyVisitor f.sbody) ; (* sets CurrentLoc *) - lastloc := !currentLoc ; (* last location in the function *) - f.sbody <- scanBlock true f.sbody - - -let feature = - { fd_name = "oneRet"; - fd_enabled = false; - fd_description = "make each function have at most one 'return'" ; - fd_extraopt = []; - fd_doit = (function (f: file) -> - Cil.iterGlobals f (fun glob -> match glob with - Cil.GFun(fd,_) -> oneret fd; - | _ -> ())); - fd_post_check = true; - } - -let () = Feature.register feature diff --git a/src/ext/oneret/oneret.mli b/src/ext/oneret/oneret.mli deleted file mode 100644 index c681928bc..000000000 --- a/src/ext/oneret/oneret.mli +++ /dev/null @@ -1,44 +0,0 @@ -(* - * - * 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.fundec -> unit -val feature : Feature.t diff --git a/src/ext/partial/META b/src/ext/partial/META deleted file mode 100644 index 3f7be44a0..000000000 --- a/src/ext/partial/META +++ /dev/null @@ -1,2 +0,0 @@ -requires = "cil.pta" -description = "interprocedural partial evaluation and constant folding" diff --git a/src/ext/partial/default b/src/ext/partial/default deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/ext/partial/heap.ml b/src/ext/partial/heap.ml deleted file mode 100644 index 10f48a045..000000000 --- a/src/ext/partial/heap.ml +++ /dev/null @@ -1,112 +0,0 @@ -(* See copyright notice at the end of the file *) - -(* The type of a heap (priority queue): keys are integers, data values - * are whatever you like *) -type ('a) t = { - elements : (int * ('a option)) array ; - mutable size : int ; (* current number of elements *) - capacity : int ; (* max number of elements *) -} - -let create size = { - elements = Array.create (size+1) (max_int,None) ; - size = 0 ; - capacity = size ; -} - -let clear heap = heap.size <- 0 - -let is_full heap = (heap.size = heap.capacity) - -let is_empty heap = (heap.size = 0) - -let insert heap prio elt = begin - if is_full heap then begin - raise (Invalid_argument "Heap.insert") - end ; - heap.size <- heap.size + 1 ; - let i = ref heap.size in - while ( fst heap.elements.(!i / 2) < prio ) do - heap.elements.(!i) <- heap.elements.(!i / 2) ; - i := (!i / 2) - done ; - heap.elements.(!i) <- (prio,Some(elt)) - end - -let examine_max heap = - if is_empty heap then begin - raise (Invalid_argument "Heap.examine_max") - end ; - match heap.elements.(1) with - p,Some(elt) -> p,elt - | p,None -> failwith "Heap.examine_max" - -let extract_max heap = begin - if is_empty heap then begin - raise (Invalid_argument "Heap.extract_max") - end ; - let max = heap.elements.(1) in - let last = heap.elements.(heap.size) in - heap.size <- heap.size - 1 ; - let i = ref 1 in - let break = ref false in - while (!i * 2 <= heap.size) && not !break do - let child = ref (!i * 2) in - - (* find smaller child *) - if (!child <> heap.size && - fst heap.elements.(!child+1) > fst heap.elements.(!child)) then begin - incr child - end ; - - (* percolate one level *) - if (fst last < fst heap.elements.(!child)) then begin - heap.elements.(!i) <- heap.elements.(!child) ; - i := !child - end else begin - break := true - end - done ; - heap.elements.(!i) <- last ; - match max with - p,Some(elt) -> p,elt - | p,None -> failwith "Heap.examine_min" - end - - -(* - * - * 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. - * - *) diff --git a/src/ext/partial/partial.ml b/src/ext/partial/partial.ml deleted file mode 100644 index 887a95bb9..000000000 --- a/src/ext/partial/partial.ml +++ /dev/null @@ -1,1209 +0,0 @@ -(* See copyright notice at the end of the file *) -(***************************************************************************** - * Partial Evaluation & Constant Folding - * - * Soundness Assumptions: - * (1) Whole program analysis. You may call functions that are not defined - * (e.g., library functions) but they may not call back. - * (2) An undefined function may not return the address of a function whose - * address is not already taken in the code I can see. - * (3) A function pointer call may only call a function that has its - * address visibly taken in the code I can see. - * - * (More assumptions in the comments below) - *****************************************************************************) -open Cil -open Cilint -open Feature -open Pretty - -(***************************************************************************** - * A generic signature for Alias Analysis information. Used to compute the - * call graph and do symbolic execution. - ****************************************************************************) -module type AliasInfo = - sig - val setup : Cil.file -> unit - val can_have_the_same_value : Cil.exp -> Cil.exp -> bool - val resolve_function_pointer : Cil.exp -> Cil.fundec list - end - -(***************************************************************************** - * A generic signature for Symbolic Execution execution algorithms. Such - * algorithms are used below to perform constant folding and dead-code - * elimination. You write a "basic-block" symex algorithm, we'll make it - * a whole-program CFG-pruner. - ****************************************************************************) -module type Symex = - sig - type t (* the type of a symex algorithm state object *) - val empty : t (* all values unknown *) - val equal : t -> t -> bool (* are these the same? *) - val assign : t -> Cil.lval -> Cil.exp -> (Cil.exp * t) - (* incorporate an assignment, return the RHS *) - val unassign : t -> Cil.lval -> t - (* lose all information about the given lvalue: assume an - * unknown external value has been assigned to it *) - val assembly : t -> Cil.instr -> t (* handle ASM *) - val assume : t -> Cil.exp -> t (* incorporate an assumption *) - val evaluate : t -> Cil.exp -> Cil.exp (* symbolic evaluation *) - val join : (t list) -> t (* join a bunch of states *) - val call : t -> Cil.fundec -> (Cil.exp list) -> (Cil.exp list * t) - (* we are calling the given function with the given actuals *) - val return : t -> Cil.fundec -> t - (* we are returning from the given function *) - val call_to_unknown_function : t -> t - (* throw away information that may have been changed *) - val debug : t -> unit - end - -(***************************************************************************** - * A generic signature for whole-progam call graphs. - ****************************************************************************) -type callGraphNode = { - fd : Cil.fundec; - mutable calledBy : Cil.fundec list; - mutable calls : Cil.fundec list -} - -type callNodeHash = (Cil.varinfo, callGraphNode) Hashtbl.t - -module type CallGraph = - sig - val compute : Cil.file -> callNodeHash - val can_call : callNodeHash -> Cil.fundec -> Cil.fundec list - val can_be_called_by : callNodeHash -> Cil.fundec -> Cil.fundec list - val fundec_of_varinfo : callNodeHash -> Cil.varinfo -> Cil.fundec - end - -module type CallGraph' = - sig - type t (* the type of a call graph *) - val compute : Cil.file -> t (* file for which we compute the graph *) - val can_call : t -> Cil.fundec -> Cil.fundec list - val can_be_called_by : t -> Cil.fundec -> Cil.fundec list - val fundec_of_varinfo : t -> Cil.varinfo -> Cil.fundec - end - -(***************************************************************************** - * My cheap-o Alias Analysis. Assume all expressions can have the same - * value and any function with its address taken can be the target of - * any function pointer. - * - * Soundness Assumptions: - * (1) Someone must call "find_all_functions_with_address_taken" before the - * results are valid. This is already done in the code below. - ****************************************************************************) -module EasyAlias : AliasInfo = -struct - let all_functions_with_address_taken = ref [] - - let find_all_functions_with_address_taken (f : Cil.file) = - iterGlobals - f - (function - GFun (fd, _) -> - if fd.svar.vaddrof then - all_functions_with_address_taken := - fd :: !all_functions_with_address_taken - | _ -> ()) - - let setup f = find_all_functions_with_address_taken f - - let can_have_the_same_value e1 e2 = true - - let resolve_function_pointer e1 = !all_functions_with_address_taken -end - -(***************************************************************************** - * Alias analysis using CIL's Ptranal feature. - ****************************************************************************) -module PtranalAlias : AliasInfo = - struct - let setup f = EasyAlias.setup f - - let can_have_the_same_value e1 e2 = - try Ptranal.may_alias e1 e2 - with Not_found -> true - - let resolve_function_pointer e1 = - try Ptranal.resolve_funptr e1 - with Not_found -> EasyAlias.resolve_function_pointer e1 - end - -(***************************************************************************** - * My particular method for computing the Call Graph. - ****************************************************************************) -module EasyCallGraph = functor (A : AliasInfo) -> -struct - let cgCreateNode cg fundec = - let newnode = { - fd = fundec; - calledBy = []; - calls = [] - } in - Hashtbl.add cg fundec.svar newnode - - let cgFindNode cg svar = Hashtbl.find cg svar - - let cgAddEdge cg caller callee = - try - let n1 = cgFindNode cg caller in - let n2 = cgFindNode cg callee in - n1.calls <- n2.fd :: n1.calls; - n2.calledBy <- n1.fd :: n2.calledBy - with _ -> () - - class callGraphVisitor cg = - object - inherit nopCilVisitor - - val the_fun = ref None - - method vinst i = - begin - match i with - Call (_, Lval (Var callee, NoOffset), _, _) -> - begin - (* known function call *) - match !the_fun with - None -> failwith "callGraphVisitor: call outside of any function" - | Some enclosing -> cgAddEdge cg enclosing callee - end - | Call (_, e, _, _) -> - begin - (* unknown function call *) - match !the_fun with - None -> failwith "callGraphVisitor: call outside of any function" - | Some enclosing -> - List.iter - (fun possible_target_fd -> - cgAddEdge cg enclosing possible_target_fd.svar) - (A.resolve_function_pointer e) - end - | _ -> () - end; - SkipChildren - - method vfunc f = - the_fun := Some f.svar; - DoChildren - end - - let compute (f : Cil.file) = - let cg = Hashtbl.create 511 in - iterGlobals - f - (function GFun (fd, _) -> cgCreateNode cg fd - | _ -> ()); - visitCilFileSameGlobals (new callGraphVisitor cg) f; - cg - - let can_call cg fd = - let n = cgFindNode cg fd.svar in n.calls - - let can_be_called_by cg fd = - let n = cgFindNode cg fd.svar in n.calledBy - - let fundec_of_varinfo cg vi = - let n = cgFindNode cg vi in n.fd -end (* END OF: module EasyCallGraph *) - -(***************************************************************************** - * Necula's Constant Folding Strategem (re-written to be applicative) - * - * Soundness Assumptions: - * (1) Inline assembly does not affect constant folding. - ****************************************************************************) -module NeculaFolding = functor (A : AliasInfo) -> -struct - module IntMap = Map.Make (struct - type t = int - let compare x y = x - y - end) - - (* Register file. Maps identifiers of local variables to expressions. - * We also remember if the expression depends on memory or depends on - * variables that depend on memory *) - type reg = { - rvi : varinfo; - rval : exp; - rmem : bool - } - - type t = reg IntMap.t - - let empty = IntMap.empty - - let equal t1 t2 = (compare t1 t2 = 0) (* use OCAML here *) - - let dependsOnMem = ref false - - (* Rewrite an expression based on the current register file *) - class rewriteExpClass (regFile : t) = - object - inherit nopCilVisitor - method vexpr = function - Lval (Var v, NoOffset) -> - begin - try - let defined = IntMap.find v.vid regFile in - if defined.rmem then dependsOnMem := true; - match defined.rval with - Const x -> ChangeTo defined.rval - | _ -> DoChildren - with Not_found -> DoChildren - end - | Lval (Mem _, _) -> - dependsOnMem := true; - DoChildren - | _ -> DoChildren - end - - (* Rewrite an expression and return the new expression along with an - * indication of whether it depends on memory *) - let rewriteExp r (e : exp) : exp * bool = - dependsOnMem := false; - let e' = constFold true (visitCilExpr (new rewriteExpClass r) e) in - e', !dependsOnMem - - let eval r e = - let new_e, _depends = rewriteExp r e in - new_e - - let setMemory regFile = - (* Get a list of all mappings that depend on memory *) - let depids = ref [] in - IntMap.iter (fun id v -> if v.rmem then depids := id :: !depids) regFile; - (* And remove them from the register file *) - List.fold_left (fun acc id -> IntMap.remove id acc) regFile !depids - - let setRegister regFile (v : varinfo) ((e, b) : exp * bool) = - IntMap.add v.vid {rvi = v; rval = e; rmem = b} regFile - - let resetRegister regFile (id : int) = - IntMap.remove id regFile - - class findLval lv contains = - object - inherit nopCilVisitor - method vlval l = - if Util.equals l lv then - begin - contains := true; - SkipChildren - end - else - DoChildren - end - - let removeMappingsThatDependOn regFile l = - (* Get a list of all mappings that depend on l *) - let depids = ref [] in - IntMap.iter - (fun id reg -> - let found = ref false in - ignore (visitCilExpr (new findLval l found) reg.rval); - if !found then depids := id :: !depids) - regFile; - (* And remove them from the register file *) - List.fold_left (fun acc id -> IntMap.remove id acc) regFile !depids - - let assign r l e = - let newe, b = rewriteExp r e in - let r' = - match l with - Var v, NoOffset -> - let r'' = setRegister r v (newe, b) in - removeMappingsThatDependOn r'' l - | Mem _, _ -> setMemory r - | _ -> r - in newe, r' - - let unassign r l = - let r' = - match l with - Var v, NoOffset -> - let r'' = resetRegister r v.vid in - removeMappingsThatDependOn r'' l - | Mem _, _ -> setMemory r - | _ -> r - in r' - - let assembly r i = r (* no-op in Necula-world *) - - let assume r e = r (* no-op in Necula-world *) - - let evaluate r e = - let newe, _ = rewriteExp r e in - newe - - (* Join two symex states *) - let join2 (r1 : t) (r2 : t) = - let keep = ref [] in - IntMap.iter - (fun id reg -> - try - let reg' = IntMap.find id r2 in - if Util.equals reg'.rval reg.rval && reg'.rmem = reg.rmem then - keep := (id, reg) :: !keep - with _ -> ()) - r1; - List.fold_left - (fun acc (id, v) -> IntMap.add id v acc) - IntMap.empty - !keep - - let join (lst : t list) = - match lst with - [] -> failwith "empty list" - | r :: tl -> - List.fold_left (fun (acc : t) (elt : t) -> join2 acc elt) r tl - - let call r fd el = - let new_arg_list = ref [] in - let final_r = - List.fold_left2 - (fun r vi e -> - let newe, r' = assign r (Var vi, NoOffset) e in - new_arg_list := newe :: !new_arg_list; - r') - r - fd.sformals el - in - (List.rev !new_arg_list), final_r - - let return r fd = - let filter_out a_predicate a_map = - IntMap.fold - (fun k v a -> if a_predicate k v then a else IntMap.add k v a) - IntMap.empty - a_map - and formals_and_locals = fd.sformals @ fd.slocals - in - filter_out - (fun k v -> List.mem v.rvi formals_and_locals) - r - - let call_to_unknown_function r = - setMemory r - - let debug r = - IntMap.iter - (fun key reg -> - ignore (Pretty.printf "%s <- %a (%b)@!" - reg.rvi.vname d_exp reg.rval reg.rmem)) - r -end (* END OF: NeculaFolding *) - -(***************************************************************************** - * A transformation to make every function call end its statement. So - * { x=1; Foo(); y=1; } - * becomes at least: - * { { x=1; Foo(); } - * { y=1; } } - * But probably more like: - * { { x=1; } { Foo(); } { y=1; } } - ****************************************************************************) -let rec contains_call il = - match il with - [] -> false - | Call _ :: tl -> true - | _ :: tl -> contains_call tl - -class callBBVisitor = -object - inherit nopCilVisitor - - method vstmt s = - match s.skind with - Instr il when contains_call il -> - begin - let list_of_stmts = - Util.list_map (fun one_inst -> mkStmtOneInstr one_inst) il in - let block = mkBlock list_of_stmts in - ChangeDoChildrenPost - (s, (fun _ -> s.skind <- Block block; s)) - end - | _ -> DoChildren - - method vvdec _ = SkipChildren - method vexpr _ = SkipChildren - method vlval _ = SkipChildren - method vtype _ = SkipChildren -end - -let calls_end_basic_blocks f = - let thisVisitor = new callBBVisitor in - visitCilFileSameGlobals thisVisitor f - -(***************************************************************************** - * A transformation that gives each variable a unique identifier. - ****************************************************************************) -class vidVisitor = object - inherit nopCilVisitor - val count = ref 0 - - method vvdec vi = - vi.vid <- !count; - incr count; - SkipChildren -end - -let globally_unique_vids f = - let thisVisitor = new vidVisitor in - visitCilFileSameGlobals thisVisitor f - -(***************************************************************************** - * The Weimeric Partial Evaluation Data-Flow Engine - * - * This functor performs flow-sensitive, context-insensitive whole-program - * data-flow analysis with an eye toward partial evaluation and constant - * folding. - * - * Toposort the whole-program inter-procedural CFG to compute - * (1) the number of actual predecessors for each statement - * (2) the global toposort ordering - * - * Perform standard data-flow analysis (joins, etc) on the ICFG until you - * hit a fixed point. If this changed the structure of the ICFG (by - * removing an IF-branch or an empty function call), redo the whole thing. - * - * Soundness Assumptions: - * (1) A "call instruction" is the last thing in its statement. - * Use "calls_end_basic_blocks" to get this. cil/src/main.ml does - * this when you pass --makeCFG. - * (2) All variables have globally unique identifiers. - * Use "globally_unique_vids" to get this. cil/src/main.ml does - * this when you pass --makeCFG. - * (3) This may not be a strict soundness requirement, but I wrote this - * assuming that the input file has all switch/break/continue - * statements removed. - ****************************************************************************) -module MakePartial = - functor (S : Symex) -> - functor (C : CallGraph) -> - functor (A : AliasInfo) -> -struct - let debug = false - - (* Sets of {c goto}-targets *) - module LabelSet = - Set.Make (struct - type t = label - let compare x y = - match x, y with - Label (name1, _, _), Label (name2, _, _) -> - String.compare name1 name2 - | _, _ -> 0 - end) - - (* We keep this information about every statement. Ideally this should - * be put in the stmt itself, but CIL doesn't give us space. *) - type sinfo = { (* statement info *) - incoming_state : (int, S.t) Hashtbl.t; - (* mapping from stmt.sid to Symex.state *) - reachable_preds : (int, bool) Hashtbl.t; - (* basically a set of all of the stmt.sids that can really - * reach this statement *) - mutable last_used_state : S.t option; - (* When we last did the Post () of this statement, what - * incoming state did we use? If our new incoming state is - * the same, we don't have to do it again. *) - mutable priority : int; - (* Whole-program toposort priority. High means "do me first". - * The first stmt in "main()" will have the highest priority. - *) - } - - let sinfo_ht = Hashtbl.create 511 - let clear_sinfo () = Hashtbl.clear sinfo_ht - - (* We construct sinfo nodes lazily: if you ask for one that isn't - * there, we build it. *) - let get_sinfo stmt = - try - Hashtbl.find sinfo_ht stmt.sid - with _ -> - let new_sinfo = {incoming_state = Hashtbl.create 3; - reachable_preds = Hashtbl.create 3; - last_used_state = None; - priority = (-1)} in - Hashtbl.add sinfo_ht stmt.sid new_sinfo; - new_sinfo - - (* Topological Sort is a DFS in which you assign a priority right as - * you finished visiting the children. While we're there we compute - * the actual number of unique predecessors for each statement. The CIL - * information may be out of date because we keep changing the CFG by - * removing IFs and whatnot. *) - let toposort_counter = ref 1 - let add_edge s1 s2 = - let si2 = get_sinfo s2 in - Hashtbl.replace si2.reachable_preds s1.sid true - - let rec toposort c stmt = - let si = get_sinfo stmt in - if si.priority >= 0 then () (* already visited! *) - else - begin - si.priority <- 0; (* currently visiting *) - (* handle function calls in this basic block *) - begin - match stmt.skind with - Instr il -> - List.iter - (fun i -> - let fd_list = - match i with - Call (_, Lval (Var vi, NoOffset), _, _) -> - begin - try - let fd = C.fundec_of_varinfo c vi in - [fd] - with e -> [] (* calling external function *) - end - | Call (_, e, _, _) -> - A.resolve_function_pointer e - | _ -> [] - in - List.iter - (fun fd -> - if List.length fd.sbody.bstmts > 0 then - let fun_stmt = List.hd fd.sbody.bstmts in - add_edge stmt fun_stmt; - toposort c fun_stmt) - fd_list) - il - | _ -> () - end; - List.iter - (fun succ -> add_edge stmt succ; toposort c succ) - stmt.succs; - si.priority <- !toposort_counter; - incr toposort_counter - end - - (* we set this to true whenever we eliminate an IF or otherwise - * change the CFG *) - let changed_cfg = ref false - - (* Partially evaluate / constant fold a statement. Basically this - * just asks the Symex algorithm to evaluate the RHS in the current - * state and then compute a new state that incorporates the - * assignment. - * - * However, we have special handling for ifs and calls. If we can - * evaluate an if predicate to a constant, we remove the if. - * - * If we are going to make a call to a function with an empty body, - * we remove the function call. *) - let partial_stmt c state stmt handle_funcall = - let result = - match stmt.skind with - Instr il -> - let state = ref state in - let new_il = - Util.list_map - (fun i -> - if debug then - ignore (Pretty.printf "Instr %a@!" d_instr i); - match i with - Set (l, e, loc) -> - let e', state' = S.assign !state l e in - state := state'; - [Set (l, e', loc)] - | Call (lo, Lval (Var vi, NoOffset), al, loc) -> - let result, know_retval = - try - let fd = C.fundec_of_varinfo c vi in - match fd.sbody.bstmts with - [] -> [], false (* no point in making this call *) - | hd :: _tl -> - if match hd.skind with - Return (None, _loc) -> true - | _ -> false then - [], false (* no point in making this call *) - else if match hd.skind with - Return (Some ret_exp, _loc) -> - isConstant (S.evaluate !state ret_exp) - | _ -> false then - match lo, hd.skind with - Some lv, Return (Some ret_exp, _loc) -> - let ret_exp', state' = S.assign !state lv ret_exp in - state := state'; - [Set (lv, ret_exp', loc)], true (* replace call with constant *) - | None, Return (Some _ret_exp, _loc) -> - failwith "partial_stmt: internal error" - | _, _ -> [], false (* never reached *) - else - let al', state' = S.call !state fd al in - handle_funcall stmt hd state'; - let state'' = S.return state' fd in - state := state''; - [Call (lo, Lval (Var vi, NoOffset), al', loc)], false - with e -> - let state'' = S.call_to_unknown_function !state in - let al' = Util.list_map (S.evaluate !state) al in - state := state''; - [Call (lo, Lval (Var vi, NoOffset), al', loc)], false - in - (* handle return value *) - begin - match lo, know_retval with - Some lv, false -> state := S.unassign !state lv - | Some lv, true -> () - | None, _ -> () - end; - result - | Call (lo, f, al, loc) -> - let al' = Util.list_map (S.evaluate !state) al in - state := S.call_to_unknown_function !state; - begin - match lo with - Some lv -> state := S.unassign !state lv - | None -> () - end; - [Call (lo, f, al', loc)] - | Asm _ -> - state := S.assembly !state i; - [i]) - il in - stmt.skind <- Instr (List.flatten new_il); - if debug then - ignore (Pretty.printf "New Stmt is %a@!" d_stmt stmt); - !state - - | If (e, b1, b2, loc) -> - (* Answer whether block [b] contains labels that are - alive. "Live" labels are actually targets of - [goto]-instructions {b outside} of [b]. *) - let has_live_labels b = - let gather_labels acc stmt = - List.fold_left (fun a x -> LabelSet.add x a) acc stmt.labels in - let rec visit_block stmt_fun acc blk = - List.fold_left - (fun a x -> - let y = stmt_fun a x in - match x.skind with - Instr _ - | Return _ | Goto _ | ComputedGoto _ | Break _ | Continue _ -> y - | If (_expr, then_block, else_block, _loc) -> - visit_block - stmt_fun - (visit_block stmt_fun y then_block) - else_block - | Switch (_expr, block, _stmt_list, _loc) -> - visit_block stmt_fun y block - | Loop (block, _loc, _opt_stmt1, _opt_stmt2) -> - visit_block stmt_fun y block - | Block block -> - visit_block stmt_fun y block - | TryFinally (block1, block2, _loc) - | TryExcept (block1, _, block2, _loc) -> - visit_block - stmt_fun - (visit_block stmt_fun y block1) - block2) - acc - blk.bstmts - and gather_gotos acc stmt = - match stmt.skind with - Goto (stmt_ref, _loc) -> gather_labels acc !stmt_ref - | ComputedGoto _ -> - (* Assume that CFG fills successors correctly *) - List.fold_left (fun a s -> gather_labels a s) - acc stmt.succs - | _ -> acc - and transitive_closure ini_stmt = - let rec iter trace acc stmt = - List.fold_left - (fun (a_trace, a_stmt) s -> - if List.mem s.sid a_trace then (a_trace, a_stmt) - else iter (s.sid :: a_trace) (s :: a_stmt) s) - (trace, acc) (stmt.preds @ stmt.succs) in - List.sort (* sorting is unnecessary, but nice *) - (fun a b -> a.sid - b.sid) - (snd (iter [] [] ini_stmt)) in - let block_labels = visit_block gather_labels LabelSet.empty b - and block_gotos = visit_block gather_gotos LabelSet.empty b - and all_gotos = - List.fold_left - (fun a x -> - match x.skind with - Goto (stmt_ref, _loc) -> gather_labels a !stmt_ref - | ComputedGoto _ -> - (* Assume that CFG fills successors correctly *) - List.fold_left (fun a s -> gather_labels a s) - a x.succs - | Block block -> visit_block gather_gotos a block - | _ -> a) - LabelSet.empty - (if b.bstmts = [] then [] - else transitive_closure (List.hd b.bstmts)) - in - not (LabelSet.is_empty - (LabelSet.inter - (LabelSet.diff all_gotos block_gotos) - block_labels)) in - (* helper function to remove "if"-branch [b] *) - let remove stmt b = - changed_cfg := true; - match b.bstmts with - [] -> () - | hd :: _tl -> - stmt.succs <- List.filter - (fun succ -> succ.sid <> hd.sid) - stmt.succs - (* helper function to make a simplified "if"-statement block *) - and mk_if_block b = - let stmt = mkStmt (Block b) in - stmt.sid <- new_sid (); - Block {bstmts = [stmt]; battrs = []} - (* logical falseness in C expressed in cilly's terms *) - and is_false e = isZero e - (* logical truth in C expressed in cilly's terms *) - and is_true e = - match getInteger e with - Some x -> not (is_zero_cilint x) - | None -> false in - (* evaluate expression and eliminate branches *) - let e' = S.evaluate state e in - if debug then - ignore (Pretty.printf "%a evals to %a\n" d_exp e d_exp e'); - if is_true e' then - begin - if has_live_labels b2 then - begin - () (* leave block alone *) - end - else - begin - if b2.bstmts = [] && b2.battrs = [] then - begin - stmt.skind <- Block b1; - match b1.bstmts with - [] -> () - | hd :: _tl -> stmt.succs <- [hd] - end - else stmt.skind <- mk_if_block b1; - remove stmt b2 - end - end - else if is_false e' then - begin - if has_live_labels b1 then - begin - () (* leave block alone *) - end - else - begin - if b1.bstmts = [] && b1.battrs = [] then - begin - stmt.skind <- Block b2; - match b2.bstmts with - [] -> () - | hd :: _tl -> stmt.succs <- [hd] - end - else stmt.skind <- mk_if_block b2; - remove stmt b1 - end - end - else stmt.skind <- If (e', b1, b2, loc); - state - - | Return (Some e, loc) -> - let e' = S.evaluate state e in - stmt.skind <- Return (Some e', loc); - state - - | Block b -> - if debug && List.length stmt.succs > 1 then - ignore (Pretty.printf "(%a) has successors [%a]@!" - d_stmt stmt - (docList ~sep:(chr '@') (d_stmt ())) - stmt.succs); - state - - | _ -> state - in result - - (* This is the main conceptual entry-point for the partial - * evaluation data-flow functor. *) - let dataflow (file : Cil.file) (* whole program *) - (c : callNodeHash) (* control-flow graph *) - (initial_state : S.t) (* any assumptions? *) - (initial_stmt : Cil.stmt) = (* entry point *) - begin - (* count the total number of statements in the program *) - let num_stmts = ref 1 in - iterGlobals - file - (function - GFun (fd, _) -> - begin - match fd.smaxstmtid with - Some i -> if i > !num_stmts then num_stmts := i - | None -> () - end - | _ -> ()); - if debug then - Printf.printf "Dataflow: at most %d statements in program\n" !num_stmts; - - (* create a priority queue in which to store statements *) - let worklist = Heap.create !num_stmts in - - let finished = ref false in - let passes = ref 0 in - - (* add something to the work queue *) - let enqueue caller callee state = - let si = get_sinfo callee in - Hashtbl.replace si.incoming_state caller.sid state; - Heap.insert worklist si.priority callee - in - (* we will be finished when we complete a round of - * data-flow that does not change the ICFG *) - while not !finished do - clear_sinfo (); - incr passes; - - (* we must recompute the ordering and the predecessor - * information because we may have changed it by removing - * IFs *) - if debug then - Printf.printf "Dataflow: Topological Sorting & Reachability\n"; - toposort c initial_stmt; - - let initial_si = get_sinfo initial_stmt in - Heap.insert worklist initial_si.priority initial_stmt; - - while not (Heap.is_empty worklist) do - let p, s = Heap.extract_max worklist in - if debug then - begin - ignore (Pretty.printf "Working on stmt %d (%a) %a@!" - s.sid - (docList ~sep:(chr ',' ++ break) (fun s -> dprintf "%d" s.sid)) - s.succs - d_stmt s); - flush stdout; - end; - let si = get_sinfo s in - - (* Even though this stmt is on the worklist, we - * may not have to do anything with it if the join - * of all of the incoming states is the same as the - * last state we used here. *) - let must_recompute, incoming_state = - begin - let list_of_incoming_states = ref [] in - Hashtbl.iter - (fun true_pred_sid b -> - let this_pred_state = - try - Hashtbl.find si.incoming_state true_pred_sid - with _ -> - (* this occurs when we're evaluating a statement and we - * have not yet evaluated all of its predecessors (the - * first time we look at a loop head, say). We must be - * conservative. We'll come back later with better - * information (as we work toward the fix-point). *) - S.empty - in - if debug then - begin - Printf.printf " Incoming State from %d\n" true_pred_sid; - S.debug this_pred_state; - flush stdout - end; - list_of_incoming_states := - this_pred_state :: !list_of_incoming_states) - si.reachable_preds; - let merged_incoming_state = - if !list_of_incoming_states = [] then - (* this occurs when we're looking at the - * first statement in "main" -- it has no - * preds *) - initial_state - else S.join !list_of_incoming_states - in - if debug then - begin - Printf.printf " Merged State:\n"; - S.debug merged_incoming_state; - flush stdout - end; - let must_recompute = - match si.last_used_state with - None -> true - | Some last -> not (S.equal merged_incoming_state last) - in must_recompute, merged_incoming_state - end - in - if must_recompute then - begin - si.last_used_state <- Some incoming_state; - let outgoing_state = - (* partially evaluate and optimize the - * statement *) - partial_stmt c incoming_state s enqueue in - let fresh_succs = s.succs in - (* touch every successor so that we will - * reconsider it *) - List.iter - (fun succ -> - enqueue s succ outgoing_state) - fresh_succs; - end - else - begin - if debug then Printf.printf "No need to recompute.\n" - end - done; - if debug then - Printf.printf "Dataflow: Pass %d Complete\n" !passes; - if !changed_cfg then - begin - if debug then - Printf.printf "Dataflow: Restarting (CFG Changed)\n"; - changed_cfg := false - end - else - finished := true - done; - if debug then - Printf.printf "Dataflow: Completed (%d passes)\n" !passes - end - - let simplify file c fd (assumptions : (Cil.lval * Cil.exp) list) = - let starting_state = - List.fold_left - (fun s (l, e) -> let _e', s' = S.assign s l e in s') - S.empty - assumptions - in - dataflow file c starting_state (List.hd fd.sbody.bstmts) -end - - -module PartialAlgorithm : -sig - val use_ptranal_alias : bool ref - val setup_alias_analysis : Cil.file -> unit - val compute_callgraph : Cil.file -> callNodeHash - val simplify : - Cil.file -> callNodeHash -> Cil.fundec -> (Cil.lval * Cil.exp) list -> unit -end - = -struct - (* Currently our partial-eval optimizer is built out of basically - * nothing. The (easy-)alias analysis is fake, the call graph is - * cheap, and we're using George's old basic-block symex. Still, it - * works. *) - - (* Don't you love Functor application? *) - module BasicCallGraph : CallGraph = EasyCallGraph (EasyAlias) - module BasicSymex = NeculaFolding (EasyAlias) - module BasicPartial = - MakePartial (BasicSymex) (BasicCallGraph) (EasyAlias) - - module PtranalBasicCallGraph : CallGraph = EasyCallGraph (PtranalAlias) - module PtranalBasicSymex = NeculaFolding (PtranalAlias) - module PtranalBasicPartial = - MakePartial (BasicSymex) (PtranalBasicCallGraph) (PtranalAlias) - - (* Select easy alias analysis or the fully-fledged one in module - * Ptranal. *) - let use_ptranal_alias = ref false - - let setup_alias_analysis f = - if !use_ptranal_alias then PtranalAlias.setup f - else EasyAlias.setup f - - let compute_callgraph f = - if !use_ptranal_alias then PtranalBasicCallGraph.compute f - else BasicCallGraph.compute f - - let simplify f c fd a = - if !use_ptranal_alias then PtranalBasicPartial.simplify f c fd a - else BasicPartial.simplify f c fd a -end - -(* A very easy entry-point to partial evaluation/symbolic execution. - * You pass the Cil file and a list of assumptions (lvalue, exp pairs - * that should be treated as assignments that occur before the program - * starts). - * - * We partially evaluate and optimize starting from root (usually - * "main"). The Cil.file is modified in place. *) -let partial (f : Cil.file) (root : string) (assumptions : (Cil.lval * Cil.exp) list) = - try - PartialAlgorithm.setup_alias_analysis f; - let c = PartialAlgorithm.compute_callgraph f in - try - if not (foldGlobals f (fun a x -> - a || - match x with - GFun (fd, _loc) -> - if fd.svar.vname = root then - begin - PartialAlgorithm.simplify - f c fd assumptions; - true - end - else false - | _ -> false) - false) then - Printf.printf "Warning: root function \"%s\" not found\n" root - with e -> - begin - Printf.printf "Error in DataFlow: %s\n" (Printexc.to_string e); - raise e - end - with e -> - begin - Printf.printf "Error in Partial: %s\n" (Printexc.to_string e); - raise e - end - -class globalConstVisitor = -object - inherit nopCilVisitor - - val mutable init_const : (lval * exp) list = [] - - method vglob g = - let is_const vi = hasAttribute "const" (typeAttrs vi.vtype) in - match g with - GVar (vi, ii, loc) -> - if is_const vi then - match ii.init with - Some init -> - begin - match init with - SingleInit exp -> - begin - init_const <- (var vi, exp) :: init_const; - ChangeTo [GVar (vi, - {init = Some (SingleInit (constFold true exp))}, - loc)] - end - | CompoundInit (_typ, _ini_list) -> SkipChildren - end - | None -> SkipChildren (* uninitialized constant *) - else SkipChildren - | _ -> SkipChildren - - method get_initialized_constants = init_const -end - -(* Assume global constants are initialized and feed this information - * into the partial evaluator or treat constants as labels with unknown - * values. I am aware that we ought to distinguish between plain - * constants and "volatile" constants. - cls *) -let initialized_constants = ref false - -(* Name of function where we start to simplify *) -let root_fun = ref "main" - -let do_feature_partial f = - if not (Feature.enabled "makeCFG") then - Errormsg.s (Errormsg.error - "--dopartial: you must also specify --domakeCFG\n"); - if not (Feature.enabled "ptranal") && - !PartialAlgorithm.use_ptranal_alias then - Errormsg.s (Errormsg.error - "--dopartial: you must also specify --doptranal\n"); - partial - f - !root_fun - (if !initialized_constants then - begin - let gcv = new globalConstVisitor in - visitCilFile (gcv :> Cil.cilVisitor) f; - gcv#get_initialized_constants - end - else []) - -let feature = { - fd_name = "partial"; - fd_enabled = false; - fd_description = "interprocedural partial evaluation and constant folding"; - fd_extraopt = [ - ("--partial_global_const", - Arg.Set initialized_constants, - " treat global constants as initialized"); - ("--partial_no_global_const", - Arg.Clear initialized_constants, - " treat global constants as unknown values"); - ("--partial_root_function", - Arg.String (fun name -> root_fun := name), - (" where to start simplification")); - ("--partial_use_easy_alias", - Arg.Clear PartialAlgorithm.use_ptranal_alias, - " to analyze pointers"); - ("--partial_use_ptranal_alias", - Arg.Set PartialAlgorithm.use_ptranal_alias, - " to analyze pointers (also see options of ptranal feature)") - ]; - fd_doit = do_feature_partial; - fd_post_check = false -} - -let makeCFGFeature = - { fd_name = "makeCFG"; - fd_enabled = false; - fd_description = "make the program look more like a CFG" ; - fd_extraopt = []; - fd_doit = (fun f -> - ignore (calls_end_basic_blocks f) ; - ignore (globally_unique_vids f) ; - iterGlobals f (fun glob -> match glob with - GFun(fd,_) -> prepareCFG fd ; - (* jc: blockinggraph depends on this "true" arg *) - ignore (computeCFGInfo fd true) - | _ -> ()) - ); - fd_post_check = true; - } - -let () = Feature.register makeCFGFeature (* ww: make CFG *must* come before Partial *) -let () = Feature.register feature -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * Christoph L. Spiel - * 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. - * - *) diff --git a/src/ext/pta/dune b/src/ext/pta/dune new file mode 100644 index 000000000..589e66515 --- /dev/null +++ b/src/ext/pta/dune @@ -0,0 +1,6 @@ +(library + (public_name goblint-cil.pta) + (name ptranal) + (wrapped false) ; this should be changed, but then module paths in goblint need to be prefixed + (libraries goblint-cil stdlib-shims) +) diff --git a/src/ext/pta/golf.ml b/src/ext/pta/golf.ml index 69c94abe4..909f471a0 100644 --- a/src/ext/pta/golf.ml +++ b/src/ext/pta/golf.ml @@ -101,7 +101,7 @@ struct type 'a t = 'a bound let compare (x : 'a t) (y : 'a t) = if U.equal (x.info, y.info) then x.index - y.index - else Pervasives.compare (U.deref x.info) (U.deref y.info) + else Stdlib.compare (U.deref x.info) (U.deref y.info) end module Path = @@ -113,12 +113,12 @@ struct if U.equal (x.tail, y.tail) then begin if x.reached_global = y.reached_global then - Pervasives.compare x.kind y.kind - else Pervasives.compare x.reached_global y.reached_global + Stdlib.compare x.kind y.kind + else Stdlib.compare x.reached_global y.reached_global end - else Pervasives.compare (U.deref x.tail) (U.deref y.tail) + else Stdlib.compare (U.deref x.tail) (U.deref y.tail) end - else Pervasives.compare (U.deref x.head) (U.deref y.head) + else Stdlib.compare (U.deref x.head) (U.deref y.head) end module B = S.Make (Bound) @@ -130,7 +130,7 @@ type 'a boundset = 'a B.t type 'a pathset = 'a P.t (** Constants, which identify elements in points-to sets *) -(** jk : I'd prefer to make this an 'a constant and specialize it to varinfo +(* jk : I'd prefer to make this an 'a constant and specialize it to varinfo for use with the Cil frontend, but for now, this will do *) type constant = int * string * Cil.varinfo @@ -565,7 +565,7 @@ let string_of_tau (t : tau) : string = string_of_tau' t (** Convert an lvalue to a string *) -let rec string_of_lvalue (lv : lvalue) : string = +let string_of_lvalue (lv : lvalue) : string = let contents = string_of_tau lv.contents and l = string_of_label lv.l in assert (pair_or_var lv.contents); (* do a consistency check *) @@ -586,7 +586,7 @@ let print_path (p : lblinfo path) : unit = (PathHash.hash p) (** Print a list of tau elements, comma separated *) -let rec print_tau_list (l : tau list) : unit = +let print_tau_list (l : tau list) : unit = let rec print_t_strings = function h :: [] -> print_endline h | h :: t -> @@ -708,7 +708,7 @@ let make_pair (p,f : tau * tau) : tau = lam = f}) (** Copy the toplevel constructor of [t], putting fresh variables in each - argement of the constructor. *) + argument of the constructor. *) let copy_toplevel (t : tau) : tau = match find t with Pair _ -> make_pair (fresh_var_i false, fresh_var_i false) @@ -737,7 +737,7 @@ let pad_args (f, f' : finfo * finfo) : unit = let to_pad = if !padding > 0 then f' else (padding := -(!padding); f) in - for i = 1 to !padding do + for _ = 1 to !padding do to_pad.args <- to_pad.args @ [fresh_var false] done @@ -748,13 +748,13 @@ let pad_args2 (fi, tlr : finfo * tau list ref) : unit = if !padding == 0 then () else if !padding > 0 then - for i = 1 to !padding do + for _ = 1 to !padding do tlr := !tlr @ [fresh_var false] done else begin padding := -(!padding); - for i = 1 to !padding do + for _ = 1 to !padding do fi.args <- fi.args @ [fresh_var false] done end @@ -915,6 +915,7 @@ and trigger_vhole (vi : vinfo) (t : tau) = | _ -> () in iter_tau add_self_loops t + (** Pick the representative info for two tinfo's. This function prefers the first argument when both arguments are the same structure, but when one type is a structure and the other is a var, it picks the structure. @@ -1020,6 +1021,7 @@ and fetch_constraint () : tconstraint option = try Some (Q.take eq_worklist) with Q.Empty -> (try Some (Q.take leq_worklist) with Q.Empty -> None) + (** The main solver loop. *) and solve_constraints () : unit = match fetch_constraint () with @@ -1424,7 +1426,7 @@ let smart_alias_query (l : label) (l' : label) : bool = let dead_configs : config_map = CH.create 16 in (* the set of discovered configurations *) let discovered : config_map = CH.create 16 in - let rec filter_match (i : int) = + let filter_match (i : int) = B.filter (fun (b : lblinfo bound) -> i = b.index) in let rec simulate c l l' = @@ -1641,7 +1643,7 @@ let rec tauPointsTo (l : tau) : absloc list = | Ref r -> r.rl :: tauPointsTo r.points_to | _ -> [] -let rec absloc_points_to (l : lvalue) : absloc list = +let absloc_points_to (l : lvalue) : absloc list = tauPointsTo l.contents diff --git a/src/ext/pta/olf.ml b/src/ext/pta/olf.ml index 517fe28da..510833ed4 100644 --- a/src/ext/pta/olf.ml +++ b/src/ext/pta/olf.ml @@ -64,7 +64,7 @@ module Bound = struct type 'a t = 'a bound let compare (x : 'a t) (y : 'a t) = - Pervasives.compare (U.deref x.info) (U.deref y.info) + Stdlib.compare (U.deref x.info) (U.deref y.info) end module B = S.Make (Bound) @@ -72,7 +72,7 @@ module B = S.Make (Bound) type 'a boundset = 'a B.t (** Abslocs, which identify elements in points-to sets *) -(** jk : I'd prefer to make this an 'a absloc and specialize it to +(* jk : I'd prefer to make this an 'a absloc and specialize it to varinfo for use with the Cil frontend, but for now, this will do *) type absloc = int * string * Cil.varinfo option @@ -469,7 +469,7 @@ let string_of_tau (t : tau) : string = string_of_tau' t (** Convert an lvalue to a string *) -let rec string_of_lvalue (lv : lvalue) : string = +let string_of_lvalue (lv : lvalue) : string = let contents = string_of_tau lv.contents and l = string_of_c_absloc lv.l in @@ -478,7 +478,7 @@ let rec string_of_lvalue (lv : lvalue) : string = Printf.sprintf "[%s]^(%s)" contents l (** Print a list of tau elements, comma separated *) -let rec print_tau_list (l : tau list) : unit = +let print_tau_list (l : tau list) : unit = let rec print_t_strings = function [] -> () | h :: [] -> print_endline h @@ -576,7 +576,7 @@ let make_pair (p, f : tau * tau) : tau = lam = f}) (** Copy the toplevel constructor of [t], putting fresh variables in each - argement of the constructor. *) + argument of the constructor. *) let copy_toplevel (t : tau) : tau = match find t with Pair _ -> make_pair (fresh_var_i false, fresh_var_i false) @@ -601,11 +601,11 @@ let pad_args (fi, tlr : finfo * tau list ref) : unit = if padding == 0 then () else if padding > 0 then - for i = 1 to padding do + for _ = 1 to padding do tlr := !tlr @ [fresh_var false] done else - for i = 1 to -padding do + for _ = 1 to -padding do fi.args <- fi.args @ [fresh_var false] done @@ -703,7 +703,8 @@ and unify_c_abslocs (l, l' : c_absloc * c_absloc) : unit = and merge_v_lbounds (vi, vi' : vinfo * vinfo) : unit = vi'.v_lbounds <- B.union vi.v_lbounds vi'.v_lbounds; and merge_v_ubounds (vi, vi' : vinfo * vinfo) : unit = - vi'.v_ubounds <- B.union vi.v_ubounds vi'.v_ubounds; + vi'.v_ubounds <- B.union vi.v_ubounds vi'.v_ubounds + (** Pick the representative info for two tinfo's. This function prefers the first argument when both arguments are the same structure, but when one type is a structure and the other is a @@ -760,7 +761,7 @@ and add_constraint_int (c : tconstraint) (toplev : bool) = end else if !debug_constraints then print_constraint c else (); - insist (can_add_constraints ()) + insist (can_add_constraints ()) "can't add constraints after compute_results is called"; begin match c with @@ -786,6 +787,7 @@ and fetch_constraint () : tconstraint option = try Some (Q.take leq_worklist) with Q.Empty -> None end + (** The main solver loop. *) and solve_constraints () : unit = match fetch_constraint () with diff --git a/src/ext/pta/ptranal.ml b/src/ext/pta/ptranal.ml index e3a3be266..c9fe907d1 100644 --- a/src/ext/pta/ptranal.ml +++ b/src/ext/pta/ptranal.ml @@ -255,6 +255,8 @@ and analyze_expr (e : exp ) : A.tau = | StartOf l -> A.address (analyze_lval l) | AlignOfE _ -> A.bottom () | SizeOfE _ -> A.bottom () + | Imag __ -> A.bottom () + | Real __ -> A.bottom () in H.add expressions e result; result @@ -286,20 +288,20 @@ let analyze_instr (i : instr ) : unit = else (* todo : check to see if the thing is an undefined function *) let fnres, site = if is_undefined_fun fexpr && !conservative_undefineds then - A.apply_undefined (Util.list_map analyze_expr actuals) + begin + found_undefined := true; + A.apply_undefined (Util.list_map analyze_expr actuals) + end else A.apply (analyze_expr fexpr) (Util.list_map analyze_expr actuals) in begin match res with - Some r -> - begin - A.assign_ret site (analyze_lval r) fnres; - found_undefined := true; - end + Some r -> A.assign_ret site (analyze_lval r) fnres | None -> () end | Asm _ -> () + | VarDecl _ -> () let rec analyze_stmt (s : stmt ) : unit = match s.skind with @@ -522,7 +524,7 @@ let compute_aliases = compute_may_aliases type absloc = A.absloc -let rec lvalue_of_varinfo (vi : varinfo) : A.lvalue = +let lvalue_of_varinfo (vi : varinfo) : A.lvalue = H.find lvalue_hash vi let lvalue_of_lval = traverse_lval diff --git a/src/ext/pta/setp.mli b/src/ext/pta/setp.mli index 954344623..8b2513516 100644 --- a/src/ext/pta/setp.mli +++ b/src/ext/pta/setp.mli @@ -1,9 +1,9 @@ (* * - * Copyright (c) 2001-2002, + * Copyright (c) 2001-2002, * John Kodumal * All rights reserved. - * + * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: @@ -54,13 +54,14 @@ are purely applicative (no side-effects). The implementation uses balanced binary trees, and is therefore reasonably efficient: insertion and membership take time - logarithmic in the size of the set, for instance. + logarithmic in the size of the set, for instance. *) -module type PolyOrderedType = +module type PolyOrderedType = sig type 'a t (** The type of the set elements. *) + val compare : 'a t -> 'a t -> int (** A total ordering function over the set elements. This is a two-argument function [f] such that @@ -68,7 +69,7 @@ module type PolyOrderedType = [f e1 e2] is strictly negative if [e1] is smaller than [e2], and [f e1 e2] is strictly positive if [e1] is greater than [e2]. Example: a suitable ordering function is - the generic structural comparison function {!Pervasives.compare}. *) + the generic structural comparison function {!Stdlib.compare}. *) end (** Input signature of the functor {!Set.Make}. *) @@ -139,7 +140,7 @@ module type S = val exists: ('a elt -> bool) -> 'a t -> bool (** [exists p s] checks if at least one element of the set satisfies the predicate [p]. *) - + val filter: ('a elt -> bool) -> 'a t -> 'a t (** [filter p s] returns the set of all elements in [s] that satisfy predicate [p]. *) diff --git a/src/ext/pta/steensgaard.ml b/src/ext/pta/steensgaard.ml index 9e6a122ee..05a8b4247 100644 --- a/src/ext/pta/steensgaard.ml +++ b/src/ext/pta/steensgaard.ml @@ -1,9 +1,9 @@ (* * - * Copyright (c) 2001-2002, + * Copyright (c) 2001-2002, * John Kodumal * All rights reserved. - * + * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: @@ -62,22 +62,22 @@ module H = Hashtbl module Q = Queue (** Polarity kinds-- positive, negative, or nonpolar. *) -type polarity = Pos - | Neg +type polarity = Pos + | Neg | Non -(** Label bounds. The polymorphic type is a hack for recursive modules *) -type 'a bound = {index : int; info : 'a} +(** Label bounds. The polymorphic type is a hack for recursive modules *) +type 'a bound = {index : int; info : 'a} -(** The 'a type may in general contain urefs, which makes Pervasives.compare +(** The 'a type may in general contain urefs, which makes Stdlib.compare incorrect. However, the bounds will always be correct because if two tau's - get unified, their cached instantiations will be re-entered into the + get unified, their cached instantiations will be re-entered into the worklist, ensuring that any labels find the new bounds *) module Bound = -struct +struct type 'a t = 'a bound - let compare (x : 'a t) (y : 'a t) = - Pervasives.compare x y + let compare (x : 'a t) (y : 'a t) = + Stdlib.compare x y end module B = S.Make(Bound) @@ -92,12 +92,12 @@ struct type t = constant let compare ((xid,_) : t) ((yid,_) : t) = - Pervasives.compare xid yid + Stdlib.compare xid yid end module C = Set.Make(Constant) -(** Sets of constants. Set union is used when two labels containing +(** Sets of constants. Set union is used when two labels containing constant sets are unified *) type constantset = C.t @@ -106,9 +106,9 @@ type lblinfo = { (** Name of this label *) mutable aliases: constantset; (** Set of constants (tags) for checking aliases *) - p_bounds: label boundset U.uref; + p_bounds: label boundset U.uref; (** Set of umatched (p) lower bounds *) - n_bounds: label boundset U.uref; + n_bounds: label boundset U.uref; (** Set of unmatched (n) lower bounds *) mutable p_cached: bool; (** Flag indicating whether all reachable p edges have been locally cached *) @@ -119,43 +119,43 @@ type lblinfo = { } (** Constructor labels *) -and label = lblinfo U.uref +and label = lblinfo U.uref (** The type of lvalues. *) type lvalue = { - l: label; + l: label; contents: tau } (** Data for variables. *) and vinfo = { - v_name: string; - mutable v_global: bool; + v_name: string; + mutable v_global: bool; v_cache: cache -} +} (** Data for ref constructors. *) and rinfo = { - rl: label; - mutable r_global: bool; - points_to: tau; + rl: label; + mutable r_global: bool; + points_to: tau; r_cache: cache } (** Data for fun constructors. *) and finfo = { - fl: label; - mutable f_global: bool; - args: tau list ref; - ret: tau; + fl: label; + mutable f_global: bool; + args: tau list ref; + ret: tau; f_cache: cache } (* Data for pairs. Note there is no label. *) and pinfo = { - mutable p_global: bool; - ptr: tau; - lam: tau; + mutable p_global: bool; + ptr: tau; + lam: tau; p_cache: cache } @@ -164,8 +164,8 @@ and tinfo = Wild | Var of vinfo | Ref of rinfo | Fun of finfo - | Pair of pinfo - + | Pair of pinfo + (** The top-level points-to type. *) and tau = tinfo U.uref @@ -176,18 +176,18 @@ and cache = (int,polarity * tau) H.t type su_constraint = Instantiation of tau * (int * polarity) * tau | Unification of tau * tau -(** Association lists, used for printing recursive types. The first element +(** Association lists, used for printing recursive types. The first element is a type that has been visited. The second element is the string - representation of that type (so far). If the string option is set, then + representation of that type (so far). If the string option is set, then this type occurs within itself, and is associated with the recursive var - name stored in the option. When walking a type, add it to an association - list. + name stored in the option. When walking a type, add it to an association + list. Example : suppose we have the constraint 'a = ref('a). The type is unified via cyclic unification, and would loop infinitely if we attempted to print it. What we want to do is print the type u rv. ref(rv). This is accomplished in the following manner: - + -- ref('a) is visited. It is not in the association list, so it is added and the string "ref(" is stored in the second element. We recurse to print the first argument of the constructor. @@ -203,11 +203,11 @@ type su_constraint = Instantiation of tau * (int * polarity) * tau complete the type by printing the result of the call, "rv", and ")" In a type where the recursive variable appears twice, e.g. 'a = pair('a,'a), - the second time we hit 'a, the string option will be set, so we know to + the second time we hit 'a, the string option will be set, so we know to reuse the same recursive variable name. *) type association = tau * string ref * string option ref - + (***********************************************************************) (* *) (* Global Variables *) @@ -221,9 +221,9 @@ let print_constraints : bool ref = ref false are solved in batch fashion at calls to solveConstraints. *) let solve_online : bool ref = ref true -(** If true, print all constraints (including induced) and show additional +(** If true, print all constraints (including induced) and show additional debug output. *) -let debug = ref false +let debug = ref false let debug_constraints = debug (** If true, print out extra verbose debug information (including contents @@ -255,7 +255,7 @@ let inst_worklist : su_constraint Q.t = Q.create() (***********************************************************************) (** Consistency check for inferred types *) -let pair_or_var (t : tau) = +let pair_or_var (t : tau) = match (U.deref t) with | Pair _ -> true | Var _ -> true @@ -274,8 +274,8 @@ let fun_or_var (t : tau) = | _ -> false (** Generate a unique integer. *) -let fresh_index () : int = - incr counter; +let fresh_index () : int = + incr counter; !counter (** Negate a polarity. *) @@ -286,25 +286,25 @@ let negate (p : polarity) : polarity = | Non -> Non (** Compute the least-upper-bounds of two polarities. *) -let lub (p,p' : polarity * polarity) : polarity = +let lub (p,p' : polarity * polarity) : polarity = match p with - | Pos -> + | Pos -> begin - match p' with + match p' with | Pos -> Pos | _ -> Non end - | Neg -> + | Neg -> begin match p' with - | Neg -> Neg + | Neg -> Neg | _ -> Non end | Non -> Non (** Extract the cache from a type *) let get_cache (t : tau) : cache = - match U.deref t with + match U.deref t with | Wild -> raise Bad_cache | Var v -> v.v_cache | Ref r -> r.r_cache @@ -312,7 +312,7 @@ let get_cache (t : tau) : cache = | Fun f -> f.f_cache (** Determine whether or not a type is global *) -let get_global (t : tau) : bool = +let get_global (t : tau) : bool = match U.deref t with | Wild -> false | Var v -> v.v_global @@ -329,17 +329,17 @@ let global_lvalue lv = get_global lv.contents let rec ulist_mem e l = match l with | [] -> false - | h :: t -> if (U.equal(h,e)) then true else ulist_mem e t + | h :: t -> if (U.equal(h,e)) then true else ulist_mem e t (** Convert a polarity to a string *) -let string_of_polarity p = - match p with +let string_of_polarity p = + match p with | Pos -> "+" | Neg -> "-" | Non -> "T" (** Convert a label to a string, short representation *) -let string_of_label2 (l : label) : string = +let string_of_label2 (l : label) : string = "\"" ^ (U.deref l).l_name ^ "\"" (** Convert a label to a string, long representation *) @@ -352,29 +352,29 @@ let string_of_label (l : label ) : string = let aliases = constset_to_string (C.elements ((U.deref l).aliases)) in if ( (aliases = "") || (not !verbose_debug)) - then string_of_label2 l + then string_of_label2 l else aliases (** Return true if the element [e] is present in the association list *) let rec assoc_list_mem (e : tau) (l : association list) = match l with | [] -> None - | (h,s,so) :: t -> + | (h,s,so) :: t -> if (U.equal(h,e)) then (Some (s,so)) else assoc_list_mem e t - + (** Given a tau, create a unique recursive variable name. This should always return the same name for a given tau *) -let fresh_recvar_name (t : tau) : string = +let fresh_recvar_name (t : tau) : string = match U.deref t with - | Pair p -> "rvp" ^ string_of_int((Hashtbl.hash p)) - | Ref r -> "rvr" ^ string_of_int((Hashtbl.hash r)) + | Pair p -> "rvp" ^ string_of_int((Hashtbl.hash p)) + | Ref r -> "rvr" ^ string_of_int((Hashtbl.hash r)) | Fun f -> "rvf" ^ string_of_int((Hashtbl.hash f)) | _ -> raise (Inconsistent ("recvar_name")) (** Return a string representation of a tau, using association lists. *) -let string_of_tau (t : tau ) : string = +let string_of_tau (t : tau ) : string = let tau_map : association list ref = ref [] in - let rec string_of_tau' t = + let rec string_of_tau' t = match (assoc_list_mem t (!tau_map)) with | Some (s,so) -> (* recursive type. see if a var name has been set *) begin @@ -395,9 +395,9 @@ let string_of_tau (t : tau ) : string = tau_map := (t,s,so) :: (!tau_map); (match (U.deref t) with - | Wild -> s := "_"; + | Wild -> s := "_"; | Var v -> s := v.v_name; - | Pair p -> + | Pair p -> begin assert (ref_or_var(p.ptr)); assert (fun_or_var(p.lam)); @@ -406,7 +406,7 @@ let string_of_tau (t : tau ) : string = s := (!s) ^ ","; s := (!s) ^ (string_of_tau' p.lam); s := (!s) ^"}" - + end | Ref r -> begin @@ -416,7 +416,7 @@ let string_of_tau (t : tau ) : string = s := (!s) ^ "|,"; s := (!s) ^ (string_of_tau' r.points_to); s := (!s) ^ ")" - + end | Fun f -> begin @@ -427,7 +427,7 @@ let string_of_tau (t : tau ) : string = assert(pair_or_var(h)); s := (!s) ^ (string_of_tau' h) end - | h :: t -> + | h :: t -> begin assert(pair_or_var(h)); s := (!s) ^ (string_of_tau' h) ^ ","; @@ -439,7 +439,7 @@ let string_of_tau (t : tau ) : string = s := (!s) ^ (string_of_label f.fl); s := (!s) ^ "|,"; s := (!s) ^ "<"; - if (List.length !(f.args) > 0) + if (List.length !(f.args) > 0) then string_of_args !(f.args) else @@ -454,15 +454,15 @@ let string_of_tau (t : tau ) : string = in string_of_tau' t -(** Convert an lvalue to a string *) -let rec string_of_lvalue (lv : lvalue) : string = +(** Convert an lvalue to a string *) +let string_of_lvalue (lv : lvalue) : string = let contents = (string_of_tau(lv.contents)) in let l = (string_of_label lv.l) in assert(pair_or_var(lv.contents)); Printf.sprintf "[%s]^(%s)" contents l - + (** Print a list of tau elements, comma separated *) -let rec print_tau_list (l : tau list) : unit = +let print_tau_list (l : tau list) : unit = let t_strings = Util.list_map string_of_tau l in let rec print_t_strings = function | h :: [] -> print_string h; print_newline(); @@ -472,11 +472,11 @@ let rec print_tau_list (l : tau list) : unit = print_t_strings t_strings (** Print a constraint. *) -let print_constraint (c : su_constraint) = - match c with - | Unification (t,t') -> +let print_constraint (c : su_constraint) = + match c with + | Unification (t,t') -> let lhs = string_of_tau t in - let rhs = string_of_tau t' in + let rhs = string_of_tau t' in Printf.printf "%s == %s\n" lhs rhs | Instantiation (t,(i,p),t') -> let lhs = string_of_tau t in @@ -486,7 +486,7 @@ let print_constraint (c : su_constraint) = Printf.printf "%s <={%s,%s} %s\n" lhs index pol rhs (* If [positive] is true, return the p-edge bounds, otherwise, return - the n-edge bounds. *) + the n-edge bounds. *) let get_bounds (positive : bool) (l : label) : label boundset U.uref = if (positive) then (U.deref l).p_bounds @@ -499,14 +499,14 @@ let on_path (l : label) : bool = (U.deref l).on_path (** Used for cycle detection during the flow step. Identifies [l] as being - on/off the current path. *) + on/off the current path. *) let set_on_path (l : label) (b : bool) : unit = (U.deref l).on_path <- b (** Make the type a global type *) let set_global (t : tau) (b : bool) : bool = - if (!debug && b) - then + if (!debug && b) + then Printf.printf "Setting a new global : %s\n" (string_of_tau t); begin assert ( (not (get_global(t)) ) || b ); @@ -521,7 +521,7 @@ let set_global (t : tau) (b : bool) : bool = (** Return a label's bounds as a string *) let string_of_bounds (is_pos : bool) (l : label) : string = - let bounds = + let bounds = if (is_pos) then U.deref ((U.deref l).p_bounds) else @@ -529,7 +529,7 @@ let string_of_bounds (is_pos : bool) (l : label) : string = in B.fold (fun b -> fun res -> res ^ (string_of_label2 b.info) ^ " " ) bounds "" - + (***********************************************************************) (* *) (* Type Operations -- these do not create any constraints *) @@ -543,28 +543,28 @@ let wild () : tau = wild_val (** Create an lvalue with label [lbl] and tau contents [t]. *) -let make_lval (lbl,t : label * tau) : lvalue = +let make_lval (lbl,t : label * tau) : lvalue = {l = lbl; contents = t} (** Create a new label with name [name]. Also adds a fresh constant - with name [name] to this label's aliases set. *) + with name [name] to this label's aliases set. *) let make_label (name : string) : label = U.uref { l_name = name; - aliases = (C.add (fresh_index(),name) C.empty); - p_bounds = U.uref (B.empty); + aliases = (C.add (fresh_index(),name) C.empty); + p_bounds = U.uref (B.empty); n_bounds = U.uref (B.empty); p_cached = false; n_cached = false; on_path = false } -(** Create a new label with an unspecified name and an empty alias set. *) +(** Create a new label with an unspecified name and an empty alias set. *) let fresh_label () : label = U.uref { l_name = "l_" ^ (string_of_int (fresh_index())); - aliases = (C.empty); - p_bounds = U.uref (B.empty); + aliases = (C.empty); + p_bounds = U.uref (B.empty); n_bounds = U.uref (B.empty); p_cached = false; n_cached = false; @@ -572,13 +572,13 @@ let fresh_label () : label = } (** Create a fresh bound. *) -let make_bound (i,a : int * 'a) : 'a bound = +let make_bound (i,a : int * 'a) : 'a bound = {index = i; info = a } (** Create a fresh named variable with name '[name]. *) let make_var (b: bool) (name : string) : tau = - U.uref (Var {v_name = ("'" ^name); - v_global = b; + U.uref (Var {v_name = ("'" ^name); + v_global = b; v_cache = H.create 4}) (** Create a fresh unnamed variable (name will be 'fv). *) @@ -586,40 +586,40 @@ let fresh_var () : tau = make_var false ("fv" ^ (string_of_int (fresh_index())) ) (** Create a fresh unnamed variable (name will be 'fi). *) -let fresh_var_i () : tau = +let fresh_var_i () : tau = make_var false ("fi" ^ (string_of_int (fresh_index())) ) (** Create a Fun constructor. *) let make_fun (lbl,a,r : label * (tau list) * tau) : tau = - U.uref (Fun {fl = lbl ; - f_global = false; - args = ref a; + U.uref (Fun {fl = lbl ; + f_global = false; + args = ref a; ret = r; f_cache = H.create 4}) (** Create a Ref constructor. *) let make_ref (lbl,pt : label * tau) : tau = - U.uref (Ref {rl = lbl ; - r_global = false; - points_to = pt; + U.uref (Ref {rl = lbl ; + r_global = false; + points_to = pt; r_cache = H.create 4}) (** Create a Pair constructor. *) let make_pair (p,f : tau * tau) : tau = - U.uref (Pair {ptr = p; + U.uref (Pair {ptr = p; p_global = false; - lam = f; + lam = f; p_cache = H.create 4}) (** Copy the toplevel constructor of [t], putting fresh variables in each - argement of the constructor. *) -let copy_toplevel (t : tau) : tau = + argument of the constructor. *) +let copy_toplevel (t : tau) : tau = match U.deref t with - | Pair _ -> + | Pair _ -> make_pair (fresh_var_i(), fresh_var_i()) - | Ref _ -> + | Ref _ -> make_ref (fresh_label(),fresh_var_i()) - | Fun f -> + | Fun f -> let fresh_fn = fun _ -> fresh_var_i() in make_fun (fresh_label(), Util.list_map fresh_fn !(f.args) , fresh_var_i()) @@ -629,11 +629,11 @@ let pad_args (l,l' : (tau list ref) * (tau list ref)) : unit = let padding = ref ((List.length (!l)) - (List.length (!l'))) in if (!padding == 0) then () - else - let to_pad = + else + let to_pad = if (!padding > 0) then l' else (padding := -(!padding);l) in - for i = 1 to (!padding) do + for _ = 1 to (!padding) do to_pad := (!to_pad) @ [fresh_var()] done @@ -645,7 +645,7 @@ let pad_args (l,l' : (tau list ref) * (tau list ref)) : unit = (** Returns true if the constraint has no effect, i.e. either the left-hand side or the right-hand side is wild. *) -let wild_constraint (t,t' : tau * tau) : bool = +let wild_constraint (t,t' : tau * tau) : bool = let ti,ti' = U.deref t, U.deref t' in match ti,ti' with | Wild, _ -> true @@ -667,17 +667,17 @@ let exists_cycle (t,t' : tau * tau) : bool = print_newline(); print_string (string_of_tau t); print_newline(); *) - (* raise Instantiation_cycle *) + (* raise Instantiation_cycle *) (* visited := List.tl (!visited) *) (* check *) end else begin visited := t :: (!visited); - if (U.equal(t,t')) + if (U.equal(t,t')) then raise Cycle_found else - H.iter (fun _ -> fun (_,t'') -> - if (U.equal (t,t'')) then () + H.iter (fun _ -> fun (_,t'') -> + if (U.equal (t,t'')) then () else ignore (exists_cycle' t'') ) (get_cache t) ; @@ -689,14 +689,14 @@ let exists_cycle (t,t' : tau * tau) : bool = false with | Cycle_found -> true - + exception Subterm - + (** Returns true if [t'] is a proper subterm of [t] *) -let proper_subterm (t,t') = +let proper_subterm (t,t') = let visited : tau list ref = ref [] in - let rec proper_subterm' t = - if (ulist_mem t (!visited)) + let rec proper_subterm' t = + if (ulist_mem t (!visited)) then () (* recursive type *) else if (U.equal (t,t')) @@ -721,7 +721,7 @@ let proper_subterm (t,t') = end in try - if (U.equal(t,t')) then false + if (U.equal(t,t')) then false else begin proper_subterm' t; @@ -741,24 +741,24 @@ let eoc (t,t') : bool = then Printf.printf "Occurs check : %s occurs within %s\n" (string_of_tau t') (string_of_tau t) - else + else (); - true + true end else false - + (** Resolve an instantiation constraint *) let rec instantiate_int (t,(i,p),t' : tau * (int * polarity) * tau) = - if ( wild_constraint(t,t') || (not (store(t,(i,p),t'))) || + if ( wild_constraint(t,t') || (not (store(t,(i,p),t'))) || U.equal(t,t') ) then () - else + else let ti,ti' = U.deref t, U.deref t' in - match ti,ti' with - | Ref r, Ref r' -> + match ti,ti' with + | Ref r, Ref r' -> instantiate_ref(r,(i,p),r') - | Fun f, Fun f' -> + | Fun f, Fun f' -> instantiate_fun(f,(i,p),f') | Pair pr, Pair pr' -> begin @@ -766,15 +766,15 @@ let rec instantiate_int (t,(i,p),t' : tau * (int * polarity) * tau) = add_constraint_int (Instantiation (pr.lam,(i,p),pr'.lam)) end | Var v, _ -> () - | _,Var v' -> + | _,Var v' -> if eoc(t,t') - then + then add_constraint_int (Unification (t,t')) else begin unstore(t,i); add_constraint_int (Unification ((copy_toplevel t),t')); - add_constraint_int (Instantiation (t,(i,p),t')) + add_constraint_int (Instantiation (t,(i,p),t')) end | _ -> raise (Inconsistent("instantiate")) @@ -784,76 +784,76 @@ and instantiate_ref (ri,(i,p),ri') : unit = add_constraint_int (Instantiation(ri.points_to,(i,Non),ri'.points_to)); instantiate_label (ri.rl,(i,p),ri'.rl) -(** Apply instantiations to the fun's label, and structurally down the type. +(** Apply instantiations to the fun's label, and structurally down the type. Flip the polarity for the function's args. If the lengths of the argument lists don't match, extend the shorter list as necessary. *) and instantiate_fun (fi,(i,p),fi') : unit = pad_args (fi.args, fi'.args); assert(List.length !(fi.args) == List.length !(fi'.args)); add_constraint_int (Instantiation (fi.ret,(i,p),fi'.ret)); - List.iter2 (fun t ->fun t' -> - add_constraint_int (Instantiation(t,(i,negate p),t'))) + List.iter2 (fun t ->fun t' -> + add_constraint_int (Instantiation(t,(i,negate p),t'))) !(fi.args) !(fi'.args); instantiate_label (fi.fl,(i,p),fi'.fl) -(** Instantiate a label. Update the label's bounds with new flow edges. +(** Instantiate a label. Update the label's bounds with new flow edges. *) and instantiate_label (l,(i,p),l' : label * (int * polarity) * label) : unit = if (!debug) then - Printf.printf "%s <= {%d,%s} %s\n" (string_of_label l) i + Printf.printf "%s <= {%d,%s} %s\n" (string_of_label l) i (string_of_polarity p) (string_of_label l'); let li,li' = U.deref l, U.deref l' in match p with | Pos -> - U.update (li'.p_bounds, + U.update (li'.p_bounds, B.add(make_bound (i,l)) (U.deref li'.p_bounds) ) - | Neg -> - U.update (li.n_bounds, + | Neg -> + U.update (li.n_bounds, B.add(make_bound (i,l')) (U.deref li.n_bounds) ) | Non -> begin - U.update (li'.p_bounds, + U.update (li'.p_bounds, B.add(make_bound (i,l)) (U.deref li'.p_bounds) ); - U.update (li.n_bounds, + U.update (li.n_bounds, B.add(make_bound (i,l')) (U.deref li.n_bounds) ) end - + (** Resolve a unification constraint. Does the uref unification after grabbing - a copy of the information before the two infos are unified. The other + a copy of the information before the two infos are unified. The other interesting feature of this function is the way 'globalness' is propagated. - If a non-global is unified with a global, the non-global becomes global. - If the ecr became global, there is a problem because none of its cached + If a non-global is unified with a global, the non-global becomes global. + If the ecr became global, there is a problem because none of its cached instantiations know that the type became monomorphic. In this case, they must be re-inserted via merge-cache. Merge-cache always reinserts cached instantiations from the non-ecr type, i.e. the type that was 'killed' by the unification. *) -and unify_int (t,t' : tau * tau) : unit = - if (wild_constraint(t,t') || U.equal(t,t')) +and unify_int (t,t' : tau * tau) : unit = + if (wild_constraint(t,t') || U.equal(t,t')) then () - else + else let ti, ti' = U.deref t, U.deref t' in begin U.unify combine (t,t'); match ti,ti' with - | Var v, _ -> - begin + | Var v, _ -> + begin if (set_global t' (v.v_global || (get_global t'))) then (H.iter (merge_cache t') (get_cache t')) else (); H.iter (merge_cache t') v.v_cache end | _, Var v -> - begin + begin if (set_global t (v.v_global || (get_global t))) then (H.iter (merge_cache t) (get_cache t)) else (); H.iter (merge_cache t) v.v_cache end - | Ref r, Ref r' -> + | Ref r, Ref r' -> begin if (set_global t (r.r_global || r'.r_global)) then (H.iter (merge_cache t) (get_cache t)) @@ -861,11 +861,11 @@ and unify_int (t,t' : tau * tau) : unit = H.iter (merge_cache t) r'.r_cache; unify_ref(r,r') end - | Fun f, Fun f' -> + | Fun f, Fun f' -> begin if (set_global t (f.f_global || f'.f_global)) then (H.iter (merge_cache t) (get_cache t)) - else (); + else (); H.iter (merge_cache t) f'.f_cache; unify_fun (f,f'); end @@ -873,7 +873,7 @@ and unify_int (t,t' : tau * tau) : unit = begin if (set_global t (p.p_global || p'.p_global)) then (H.iter (merge_cache t) (get_cache t)) - else (); + else (); H.iter (merge_cache t) p'.p_cache; add_constraint_int (Unification (p.ptr,p'.ptr)); add_constraint_int (Unification (p.lam,p'.lam)) @@ -884,30 +884,30 @@ and unify_int (t,t' : tau * tau) : unit = (** Unify the ref's label, and apply unification structurally down the type. *) and unify_ref (ri,ri' : rinfo * rinfo) : unit = add_constraint_int (Unification (ri.points_to,ri'.points_to)); - unify_label(ri.rl,ri'.rl) + unify_label(ri.rl,ri'.rl) -(** Unify the fun's label, and apply unification structurally down the type, +(** Unify the fun's label, and apply unification structurally down the type, at arguments and return value. When combining two lists of different lengths, always choose the longer list for the representative. *) -and unify_fun (li,li' : finfo * finfo) : unit = +and unify_fun (li,li' : finfo * finfo) : unit = let rec union_args = function | _, [] -> false | [], _ -> true - | h :: t, h' :: t' -> - add_constraint_int (Unification (h,h')); union_args(t,t') + | h :: t, h' :: t' -> + add_constraint_int (Unification (h,h')); union_args(t,t') in begin unify_label(li.fl,li'.fl); add_constraint_int (Unification (li.ret,li'.ret)); - if (union_args(!(li.args),!(li'.args))) + if (union_args(!(li.args),!(li'.args))) then li.args := !(li'.args); end (** Unify two labels, combining the set of constants denoting aliases. *) and unify_label (l,l' : label * label) : unit = - let pick_name (li,li' : lblinfo * lblinfo) = - if ( (String.length li.l_name) > 1 && (String.sub (li.l_name) 0 2) = "l_") - then + let pick_name (li,li' : lblinfo * lblinfo) = + if ( (String.length li.l_name) > 1 && (String.sub (li.l_name) 0 2) = "l_") + then li.l_name <- li'.l_name else () in @@ -915,7 +915,7 @@ and unify_label (l,l' : label * label) : unit = let p_bounds = U.deref (li.p_bounds) in let p_bounds' = U.deref (li'.p_bounds) in let n_bounds = U.deref (li.n_bounds) in - let n_bounds' = U.deref (li'.n_bounds) in + let n_bounds' = U.deref (li'.n_bounds) in begin pick_name(li,li'); li.aliases <- C.union (li.aliases) (li'.aliases); @@ -926,7 +926,7 @@ and unify_label (l,l' : label * label) : unit = in(* if (!debug) then begin - Printf.printf "Unifying %s with %s...\n" + Printf.printf "Unifying %s with %s...\n" (string_of_label l) (string_of_label l'); Printf.printf "pbounds : %s\n" (string_of_bounds true l); Printf.printf "nbounds : %s\n" (string_of_bounds false l); @@ -940,22 +940,22 @@ and unify_label (l,l' : label * label) : unit = Printf.printf "nbounds : %s\n" (string_of_bounds false l) end *) -(** Re-assert a cached instantiation constraint, since the old type was +(** Re-assert a cached instantiation constraint, since the old type was killed by a unification *) and merge_cache (rep : tau) (i : int) (p,t' : polarity * tau) : unit = add_constraint_int (Instantiation (rep,(i,p),t')) - + (** Pick the representative info for two tinfo's. This function prefers the first argument when both arguments are the same structure, but when one type is a structure and the other is a var, it picks the structure. *) -and combine (ti,ti' : tinfo * tinfo) : tinfo = +and combine (ti,ti' : tinfo * tinfo) : tinfo = match ti,ti' with | Var _, _ -> ti' - | _,_ -> ti + | _,_ -> ti (** Add a new constraint induced by other constraints. *) and add_constraint_int (c : su_constraint) = - if (!print_constraints && !debug) then print_constraint c else (); + if (!print_constraints && !debug) then print_constraint c else (); begin match c with | Instantiation _ -> @@ -964,13 +964,13 @@ and add_constraint_int (c : su_constraint) = Q.add c eq_worklist end; if (!debug) then solve_constraints() else () - -(** Add a new constraint introduced through this module's interface (a + +(** Add a new constraint introduced through this module's interface (a top-level constraint). *) and add_constraint (c : su_constraint) = begin add_constraint_int (c); - if (!print_constraints && not (!debug)) then print_constraint c else (); + if (!print_constraints && not (!debug)) then print_constraint c else (); if (!solve_online) then solve_constraints() else () end @@ -978,24 +978,24 @@ and add_constraint (c : su_constraint) = (* Fetch constraints, preferring equalities. *) and fetch_constraint () : su_constraint option = if (Q.length eq_worklist > 0) - then + then Some (Q.take eq_worklist) else if (Q.length inst_worklist > 0) then Some (Q.take inst_worklist) else - None + None (** Returns the target of a cached instantiation, if it exists. *) and target (t,i,p : tau * int * polarity) : (polarity * tau) option = let cache = get_cache t in - if (global_tau t) then Some (Non,t) + if (global_tau t) then Some (Non,t) else try Some (H.find cache i) - with + with | Not_found -> None - + (** Caches a new instantiation, or applies well-formedness. *) and store ( t,(i,p),t' : tau * (int * polarity) * tau) : bool = let cache = get_cache t in @@ -1009,14 +1009,14 @@ and store ( t,(i,p),t' : tau * (int * polarity) * tau) : bool = add_constraint_int (Unification (t',t'')); H.replace cache i (lub(p,p''),t''); (* add a new forced instantiation as well *) - if (lub(p,p'') = p'') + if (lub(p,p'') = p'') then () else begin unstore(t,i); add_constraint_int (Instantiation (t,(i,lub(p,p'')),t'')) end; - false + false end | None -> begin @@ -1030,7 +1030,7 @@ let cache = get_cache t in H.remove cache i (** The main solver loop. *) -and solve_constraints () : unit = +and solve_constraints () : unit = match fetch_constraint () with | Some c -> begin @@ -1048,23 +1048,23 @@ and solve_constraints () : unit = (* Interface Functions *) (* *) (***********************************************************************) - + (** Return the contents of the lvalue. *) -let rvalue (lv : lvalue) : tau = +let rvalue (lv : lvalue) : tau = lv.contents (** Dereference the rvalue. If it does not have enough structure to support the operation, then the correct structure is added via new unification constraints. *) let rec deref (t : tau) : lvalue = - match U.deref t with + match U.deref t with | Pair p -> ( match U.deref (p.ptr) with | Var _ -> - begin + begin (* let points_to = make_pair(fresh_var(),fresh_var()) in *) - let points_to = fresh_var() in + let points_to = fresh_var() in let l = fresh_label() in let r = make_ref(l,points_to) in @@ -1074,7 +1074,7 @@ let rec deref (t : tau) : lvalue = | Ref r -> make_lval(r.rl, r.points_to) | _ -> raise (Inconsistent("deref")) ) - | Var v -> + | Var v -> begin add_constraint (Unification (t,make_pair(fresh_var(),fresh_var()))); deref t @@ -1082,7 +1082,7 @@ let rec deref (t : tau) : lvalue = | _ -> raise (Inconsistent("deref -- no top level pair")) (** Form the union of [t] and [t']. *) -let join (t : tau) (t' : tau) : tau = +let join (t : tau) (t' : tau) : tau = let t'' = fresh_var() in add_constraint (Unification (t,t'')); add_constraint (Unification (t',t'')); @@ -1090,7 +1090,7 @@ let join (t : tau) (t' : tau) : tau = (** Form the union of a list [tl], expected to be the initializers of some structure or array type. *) -let join_inits (tl : tau list) : tau = +let join_inits (tl : tau list) : tau = let t' = fresh_var() in begin List.iter (function t'' -> add_constraint (Unification(t',t''))) tl; @@ -1098,12 +1098,12 @@ let join_inits (tl : tau list) : tau = end (** Take the address of an lvalue. Does not add constraints. *) -let address (lv : lvalue) : tau = +let address (lv : lvalue) : tau = make_pair (make_ref (lv.l, lv.contents), fresh_var() ) - -(** Instantiate a type with index i. By default, uses positive polarity. + +(** Instantiate a type with index i. By default, uses positive polarity. Adds an instantiation constraint. *) -let instantiate (lv : lvalue) (i : int) : lvalue = +let instantiate (lv : lvalue) (i : int) : lvalue = if (!analyze_mono) then lv else begin @@ -1112,16 +1112,16 @@ let instantiate (lv : lvalue) (i : int) : lvalue = instantiate_label(lv.l,(i,Pos),l'); add_constraint (Instantiation (lv.contents,(i,Pos),t')); make_lval(l',t') (* check -- fresh label ?? *) - end - + end + (** Constraint generated from assigning [t] to [lv]. *) -let assign (lv : lvalue) (t : tau) : unit = +let assign (lv : lvalue) (t : tau) : unit = add_constraint (Unification (lv.contents,t)) - + (** Project out the first (ref) component or a pair. If the argument [t] has no discovered structure, raise No_contents. *) -let proj_ref (t : tau) : tau = +let proj_ref (t : tau) : tau = match U.deref t with | Pair p -> p.ptr | Var v -> raise No_contents @@ -1129,34 +1129,34 @@ let proj_ref (t : tau) : tau = (* Project out the second (fun) component of a pair. If the argument [t] has no discovered structure, create it on the fly by adding constraints. *) -let proj_fun (t : tau) : tau = +let proj_fun (t : tau) : tau = match U.deref t with | Pair p -> p.lam - | Var v -> + | Var v -> let p,f = fresh_var(), fresh_var() in add_constraint (Unification (t,make_pair(p,f))); f | _ -> raise Bad_proj let get_args (t : tau) : tau list ref = - match U.deref t with + match U.deref t with | Fun f -> f.args | _ -> raise (Inconsistent("get_args")) -(** Function type [t] is applied to the arguments [actuals]. Unifies the - actuals with the formals of [t]. If no functions have been discovered for +(** Function type [t] is applied to the arguments [actuals]. Unifies the + actuals with the formals of [t]. If no functions have been discovered for [t] yet, create a fresh one and unify it with t. The result is the return value of the function. *) -let apply (t : tau) (al : tau list) : tau = +let apply (t : tau) (al : tau list) : tau = let f = proj_fun(t) in - let actuals = ref al in + let actuals = ref al in let formals,ret = match U.deref f with | Fun fi -> (fi.args),fi.ret | Var v -> - let new_l,new_ret,new_args = - fresh_label(), fresh_var (), - Util.list_map (function _ -> fresh_var()) (!actuals) + let new_l,new_ret,new_args = + fresh_label(), fresh_var (), + Util.list_map (function _ -> fresh_var()) (!actuals) in let new_fun = make_fun(new_l,new_args,new_ret) in add_constraint (Unification(new_fun,f)); @@ -1166,35 +1166,35 @@ let apply (t : tau) (al : tau list) : tau = | Wild -> raise (Inconsistent("apply_wild")) in pad_args(formals,actuals); - List.iter2 (fun actual -> fun formal -> + List.iter2 (fun actual -> fun formal -> add_constraint (Unification (actual,formal)) ) !actuals !formals; - ret - -(** Create a new function type with name [name], list of formal arguments + ret + +(** Create a new function type with name [name], list of formal arguments [formals], and return value [ret]. Adds no constraints. *) -let make_function (name : string) (formals : lvalue list) (ret : tau) : tau = - let - f = make_fun(make_label(name),Util.list_map (fun x -> rvalue x) formals, ret) +let make_function (name : string) (formals : lvalue list) (ret : tau) : tau = + let + f = make_fun(make_label(name),Util.list_map (fun x -> rvalue x) formals, ret) in make_pair(fresh_var(),f) -(** Create an lvalue. If [is_global] is true, the lvalue will be treated +(** Create an lvalue. If [is_global] is true, the lvalue will be treated monomorphically. *) -let make_lvalue (is_global : bool) (name : string) : lvalue = - if (!debug && is_global) - then +let make_lvalue (is_global : bool) (name : string) : lvalue = + if (!debug && is_global) + then Printf.printf "Making global lvalue : %s\n" name else (); make_lval(make_label(name), make_var is_global name) - + (** Create a fresh non-global named variable. *) let make_fresh (name : string) : tau = make_var false (name) (** The default type for constants. *) -let bottom () : tau = +let bottom () : tau = make_var false ("bottom") (** Unify the result of a function with its return value. *) @@ -1212,19 +1212,19 @@ let return (t : tau) (t' : tau) = let combine_lbounds (s,s' : label boundset * label boundset) = B.union s s' -(** Truncates a list of urefs [l] to those elements up to and including the +(** Truncates a list of urefs [l] to those elements up to and including the first occurence of the specified element [elt]. *) -let truncate l elt = +let truncate l elt = let keep = ref true in - List.filter - (fun x -> - if (not (!keep)) - then + List.filter + (fun x -> + if (not (!keep)) + then false else begin - if (U.equal(x,elt)) - then + if (U.equal(x,elt)) + then keep := false else (); true @@ -1233,8 +1233,8 @@ let truncate l elt = let debug_cycle_bounds is_pos c = let rec debug_cycle_bounds' = function - | h :: [] -> - Printf.printf "%s --> %s\n" (string_of_bounds is_pos h) + | h :: [] -> + Printf.printf "%s --> %s\n" (string_of_bounds is_pos h) (string_of_label2 h) | h :: t -> begin @@ -1249,7 +1249,7 @@ let debug_cycle_bounds is_pos c = (** For debugging, print a cycle of instantiations *) let debug_cycle (is_pos,c,l,p) = let kind = if is_pos then "P" else "N" in - let rec string_of_cycle = function + let rec string_of_cycle = function | h :: [] -> string_of_label2 h | [] -> "" | h :: t -> Printf.sprintf "%s,%s" (string_of_label2 h) (string_of_cycle t) @@ -1263,26 +1263,26 @@ let debug_cycle (is_pos,c,l,p) = (** Compute pos or neg flow, depending on [is_pos]. Searches for cycles in the instantiations (can these even occur?) and unifies either the positive or - negative edge sets for the labels on the cycle. Note that this does not - ever unify the labels themselves. The return is the new bounds of the + negative edge sets for the labels on the cycle. Note that this does not + ever unify the labels themselves. The return is the new bounds of the argument label *) let rec flow (is_pos : bool) (path : label list) (l : label) : label boundset = - let collapse_cycle () = + let collapse_cycle () = let cycle = truncate path l in debug_cycle (is_pos,cycle,l,path); - List.iter (fun x -> U.unify combine_lbounds + List.iter (fun x -> U.unify combine_lbounds ((get_bounds is_pos x),get_bounds is_pos l) ) cycle in - if (on_path l) + if (on_path l) then begin - collapse_cycle (); + collapse_cycle (); (* set_on_path l false; *) B.empty end else - if ( (is_pos && (U.deref l).p_cached) || + if ( (is_pos && (U.deref l).p_cached) || ( (not is_pos) && (U.deref l).n_cached) ) then begin U.deref (get_bounds is_pos l) @@ -1292,42 +1292,42 @@ let rec flow (is_pos : bool) (path : label list) (l : label) : label boundset = let newbounds = ref B.empty in let base = get_bounds is_pos l in set_on_path l true; - if (is_pos) then - (U.deref l).p_cached <- true - else + if (is_pos) then + (U.deref l).p_cached <- true + else (U.deref l).n_cached <- true; - B.iter - (fun x -> - if (U.equal(x.info,l)) then () + B.iter + (fun x -> + if (U.equal(x.info,l)) then () else - (newbounds := + (newbounds := (B.union (!newbounds) (flow is_pos (l :: path) x.info))) - ) (U.deref base); + ) (U.deref base); set_on_path l false; U.update (base,(B.union (U.deref base) !newbounds)); U.deref base end - + (** Compute and cache any positive flow. *) -let pos_flow l : constantset = - let result = ref C.empty in +let pos_flow l : constantset = + let result = ref C.empty in begin ignore (flow true [] l); B.iter (fun x -> result := C.union (!result) (U.deref(x.info)).aliases ) - (U.deref (get_bounds true l)); + (U.deref (get_bounds true l)); !result end - + (** Compute and cache any negative flow. *) let neg_flow l : constantset = let result = ref C.empty in begin - ignore (flow false [] l); + ignore (flow false [] l); B.iter (fun x -> result := C.union (!result) (U.deref(x.info)).aliases ) (U.deref (get_bounds false l)); !result end - + (** Compute and cache any pos-neg flow. Assumes that both pos_flow and neg_flow have been computed for the label [l]. *) let pos_neg_flow(l : label) : constantset = @@ -1343,7 +1343,7 @@ let pos_neg_flow(l : label) : constantset = let points_to_int (lv : lvalue) : constantset = let visited_caches : cache list ref = ref [] in let rec points_to_tau (t : tau) : constantset = - try + try begin match U.deref (proj_ref t) with | Var v -> C.empty @@ -1364,7 +1364,7 @@ let points_to_int (lv : lvalue) : constantset = | Var v -> rebuild_flow v.v_cache | _ -> raise (Inconsistent ("points_to")) end - and rebuild_flow (c : cache) : constantset = + and rebuild_flow (c : cache) : constantset = if (List.mem c (!visited_caches) ) (* cyclic instantiations *) then begin @@ -1375,40 +1375,40 @@ let points_to_int (lv : lvalue) : constantset = begin visited_caches := c :: (!visited_caches); let result = ref (C.empty) in - H.iter (fun _ -> fun(p,t) -> - match p with - | Pos -> () + H.iter (fun _ -> fun(p,t) -> + match p with + | Pos -> () | _ -> result := C.union (!result) (points_to_tau t) ) c; visited_caches := List.tl (!visited_caches); !result end in - if (!no_flow) then + if (!no_flow) then (U.deref lv.l).aliases - else + else points_to_tau (lv.contents) let points_to (lv : lvalue) : string list = Util.list_map snd (C.elements (points_to_int lv)) -let alias_query (a_progress : bool) (lv : lvalue list) : int * int = +let alias_query (a_progress : bool) (lv : lvalue list) : int * int = (0,0) (* todo *) (* let a_count = ref 0 in let ptsets = Util.list_map points_to_int lv in let total_sets = List.length ptsets in - let counted_sets = ref 0 in - let record_alias s s' = - if (C.is_empty (C.inter s s')) + let counted_sets = ref 0 in + let record_alias s s' = + if (C.is_empty (C.inter s s')) then () else (incr a_count) in let rec check_alias = function | h :: t -> begin - List.iter (record_alias h) ptsets; - check_alias t + List.iter (record_alias h) ptsets; + check_alias t end | [] -> () in diff --git a/src/ext/sfi/META b/src/ext/sfi/META deleted file mode 100644 index 3c69c3d90..000000000 --- a/src/ext/sfi/META +++ /dev/null @@ -1 +0,0 @@ -description = "instrument memory operations" diff --git a/src/ext/sfi/default b/src/ext/sfi/default deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/ext/sfi/sfi.ml b/src/ext/sfi/sfi.ml deleted file mode 100644 index d8b5db91c..000000000 --- a/src/ext/sfi/sfi.ml +++ /dev/null @@ -1,339 +0,0 @@ -(* - * - * Copyright (c) 2005, - * George C. Necula - * 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. - * - *) - -(** This is a module that inserts runtime checks for memory reads/writes and - * allocations *) - -open Pretty -open Cil -open Feature -module E = Errormsg -module H = Hashtbl - -let doSfi = ref false -let doSfiReads = ref false -let doSfiWrites = ref true - -(* A number of functions to be skipped *) -let skipFunctions : (string, unit) H.t = H.create 13 -let mustSfiFunction (f: fundec) : bool = - not (H.mem skipFunctions f.svar.vname) - -(** Some functions are known to be allocators *) -type dataLocation = - InResult (* Interesting data is in the return value *) - | InArg of int (* in the nth argument. Starts from 1. *) - | InArgTimesArg of int * int (* (for size) data is the product of two - * arguments *) - | PointedToByArg of int (* pointed to by nth argument *) - -(** Compute the data based on the location and the actual argument list *) -let extractData (dl: dataLocation) (args: exp list) (res: lval option) : exp = - let getArg (n: int) = - try List.nth args (n - 1) (* Args are based at 1 *) - with _ -> E.s (E.bug "Cannot extract argument %d at %a" - n d_loc !currentLoc) - in - match dl with - InResult -> begin - match res with - None -> - E.s (E.bug "Cannot extract InResult data (at %a)" d_loc !currentLoc) - | Some r -> Lval r - end - | InArg n -> getArg n - | InArgTimesArg (n1, n2) -> - let a1 = getArg n1 in - let a2 = getArg n2 in - BinOp(Mult, mkCast ~e:a1 ~newt:longType, - mkCast ~e:a2 ~newt:longType, longType) - | PointedToByArg n -> - let a = getArg n in - Lval (mkMem a NoOffset) - - - -(* for each allocator, where is the length and where is the result *) -let allocators: (string, (dataLocation * dataLocation)) H.t = H.create 13 -let _ = - H.add allocators "malloc" (InArg 1, InResult); - H.add allocators "calloc" (InArgTimesArg (1, 2), InResult); - H.add allocators "realloc" (InArg 2, InResult) - -(* for each deallocator, where is the data being deallocated *) -let deallocators: (string, dataLocation) H.t = H.create 13 -let _= - H.add deallocators "free" (InArg 1); - H.add deallocators "realloc" (InArg 1) - -(* Returns true if the given lvalue offset ends in a bitfield access. *) -let rec is_bitfield lo = match lo with - | NoOffset -> false - | Field(fi,NoOffset) -> not (fi.fbitfield = None) - | Field(_,lo) -> is_bitfield lo - | Index(_,lo) -> is_bitfield lo - -(* Return an expression that evaluates to the address of the given lvalue. - * For most lvalues, this is merely AddrOf(lv). However, for bitfields - * we do some offset gymnastics. - *) -let addr_of_lv (lv: lval) = - let lh, lo = lv in - if is_bitfield lo then begin - (* we figure out what the address would be without the final bitfield - * access, and then we add in the offset of the bitfield from the - * beginning of its enclosing comp *) - let rec split_offset_and_bitfield lo = match lo with - | NoOffset -> failwith "logwrites: impossible" - | Field(fi,NoOffset) -> (NoOffset,fi) - | Field(e,lo) -> let a,b = split_offset_and_bitfield lo in - ((Field(e,a)),b) - | Index(e,lo) -> let a,b = split_offset_and_bitfield lo in - ((Index(e,a)),b) - in - let new_lv_offset, bf = split_offset_and_bitfield lo in - let new_lv = (lh, new_lv_offset) in - let enclosing_type = TComp(bf.fcomp, []) in - let bits_offset, bits_width = - bitsOffset enclosing_type (Field(bf,NoOffset)) in - let bytes_offset = bits_offset / 8 in - let lvPtr = mkCast ~e:(mkAddrOf (new_lv)) ~newt:(charPtrType) in - (BinOp(PlusPI, lvPtr, (integer bytes_offset), ulongType)) - end else - (mkAddrOf (lh,lo)) - - -let mustLogLval (forwrite: bool) (lv: lval) : bool = - match lv with - Var v, off -> (* Inside a variable. We assume the array offsets are fine *) - false - | Mem e, off -> - if forwrite && not !doSfiWrites then - false - else if not forwrite && not !doSfiReads then - false - - (* If this is an lval of function type, we do not log it *) - else if isFunctionType (typeOfLval lv) then - false - else - true - -(* Create prototypes for the logging functions *) -let mkProto (name: string) (args: (string * typ * attributes) list) = - let fdec = emptyFunction name in - fdec.svar.vtype <- TFun(voidType, - Some args, false, []); - fdec - - -let logReads = mkProto "logRead" [ ("addr", voidPtrType, []); - ("what", charPtrType, []); - ("file", charPtrType, []); - ("line", intType, []) ] -let callLogRead (lv: lval) = - let what = Pretty.sprint 80 (d_lval () lv) in - Call(None, - Lval(Var(logReads.svar),NoOffset), - [ addr_of_lv lv; mkString what; mkString !currentLoc.file; - integer !currentLoc.line], !currentLoc ) - -let logWrites = mkProto "logWrite" [ ("addr", voidPtrType, []); - ("what", charPtrType, []); - ("file", charPtrType, []); - ("line", intType, []) ] -let callLogWrite (lv: lval) = - let what = Pretty.sprint 80 (d_lval () lv) in - Call(None, - Lval(Var(logWrites.svar), NoOffset), - [ addr_of_lv lv; mkString what; mkString !currentLoc.file; - integer !currentLoc.line], !currentLoc ) - -let logStackFrame = mkProto "logStackFrame" [ ("func", charPtrType, []) ] -let callLogStack (fname: string) = - Call(None, - Lval(Var(logStackFrame.svar), NoOffset), - [ mkString fname; ], !currentLoc ) - -let logAlloc = mkProto "logAlloc" [ ("addr", voidPtrType, []); - ("size", intType, []); - ("file", charPtrType, []); - ("line", intType, []) ] -let callLogAlloc (szloc: dataLocation) - (resLoc: dataLocation) - (args: exp list) - (res: lval option) = - let sz = extractData szloc args res in - let res = extractData resLoc args res in - Call(None, - Lval(Var(logAlloc.svar), NoOffset), - [ res; sz; mkString !currentLoc.file; - integer !currentLoc.line ], !currentLoc ) - - -let logFree = mkProto "logFree" [ ("addr", voidPtrType, []); - ("file", charPtrType, []); - ("line", intType, []) ] -let callLogFree (dataloc: dataLocation) - (args: exp list) - (res: lval option) = - let data = extractData dataloc args res in - Call(None, - Lval(Var(logFree.svar), NoOffset), - [ data; mkString !currentLoc.file; - integer !currentLoc.line ], !currentLoc ) - -class sfiVisitorClass : Cil.cilVisitor = object (self) - inherit nopCilVisitor - - method vexpr (e: exp) : exp visitAction = - match e with - Lval lv when mustLogLval false lv -> (* A read *) - self#queueInstr [ callLogRead lv ]; - DoChildren - - | _ -> DoChildren - - - method vinst (i: instr) : instr list visitAction = - match i with - Set(lv, e, l) when mustLogLval true lv -> - self#queueInstr [ callLogWrite lv ]; - DoChildren - - | Call(lvo, f, args, l) -> - (* Instrument the write *) - (match lvo with - Some lv when mustLogLval true lv -> - self#queueInstr [ callLogWrite lv ] - | _ -> ()); - (* Do the expressions in the call, and then see if we need to - * instrument the function call *) - ChangeDoChildrenPost - ([i], - (fun il -> - currentLoc := l; - match f with - Lval (Var fv, NoOffset) -> begin - (* Is it an allocator? *) - try - let szloc, resloc = H.find allocators fv.vname in - il @ [callLogAlloc szloc resloc args lvo] - with Not_found -> begin - (* Is it a deallocator? *) - try - let resloc = H.find deallocators fv.vname in - il @ [ callLogFree resloc args lvo ] - with Not_found -> - il - end - end - | _ -> il)) - - | _ -> DoChildren - - method vfunc (fdec: fundec) = - (* Instead a stack log at the start of a function *) - ChangeDoChildrenPost - (fdec, - fun fdec -> - fdec.sbody <- - mkBlock - [ mkStmtOneInstr (callLogStack fdec.svar.vname); - mkStmt (Block fdec.sbody) ]; - fdec) - -end - -let doit (f: file) = - let sfiVisitor = new sfiVisitorClass in - let compileLoc (l: location) = function - ACons("inres", []) -> InResult - | ACons("inarg", [AInt n]) -> InArg n - | ACons("inargxarg", [AInt n1; AInt n2]) -> InArgTimesArg (n1, n2) - | ACons("pointedby", [AInt n]) -> PointedToByArg n - | _ -> E.warn "Invalid location at %a" d_loc l; - InResult - in - iterGlobals f - (fun glob -> - match glob with - GFun(fdec, _) when mustSfiFunction fdec -> - ignore (visitCilFunction sfiVisitor fdec) - | GPragma(Attr("sfiignore", al), l) -> - List.iter - (function AStr fn -> H.add skipFunctions fn () - | _ -> E.warn "Invalid argument in \"sfiignore\" pragma at %a" - d_loc l) - al - - | GPragma(Attr("sfialloc", al), l) -> begin - match al with - AStr fname :: locsz :: locres :: [] -> - H.add allocators fname (compileLoc l locsz, compileLoc l locres) - | _ -> E.warn "Invalid sfialloc pragma at %a" d_loc l - end - - | GPragma(Attr("sfifree", al), l) -> begin - match al with - AStr fname :: locwhat :: [] -> - H.add deallocators fname (compileLoc l locwhat) - | _ -> E.warn "Invalid sfifree pragma at %a" d_loc l - end - - - | _ -> ()); - (* Now add the prototypes for the instrumentation functions *) - f.globals <- - GVarDecl (logReads.svar, locUnknown) :: - GVarDecl (logWrites.svar, locUnknown) :: - GVarDecl (logStackFrame.svar, locUnknown) :: - GVarDecl (logAlloc.svar, locUnknown) :: - GVarDecl (logFree.svar, locUnknown) :: f.globals - - -let feature = - { fd_name = "sfi"; - fd_enabled = false; - fd_description = "instrument memory operations"; - fd_extraopt = [ - "--sfireads", Arg.Set doSfiReads, " SFI for reads"; - "--sfiwrites", Arg.Set doSfiWrites, " SFI for writes"; - ]; - fd_doit = doit; - fd_post_check = true; - } - -let () = Feature.register feature diff --git a/src/ext/simplemem/META b/src/ext/simplemem/META deleted file mode 100644 index afb3fa7de..000000000 --- a/src/ext/simplemem/META +++ /dev/null @@ -1 +0,0 @@ -description = "simplify all memory expressions" diff --git a/src/ext/simplemem/default b/src/ext/simplemem/default deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/ext/simplemem/simplemem.ml b/src/ext/simplemem/simplemem.ml deleted file mode 100644 index caee94672..000000000 --- a/src/ext/simplemem/simplemem.ml +++ /dev/null @@ -1,135 +0,0 @@ -(* - * - * 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. - * - *) - -(* - * Simplemem: Transform a program so that all memory expressions are - * "simple". Introduce well-typed temporaries to hold intermediate values - * for expressions that would normally involve more than one memory - * reference. - * - * If simplemem succeeds, each lvalue should contain only one Mem() - * constructor. - *) -open Cil -open Feature - -(* current context: where should we put our temporaries? *) -let thefunc = ref None - -(* build up a list of assignments to temporary variables *) -let assignment_list = ref [] - -(* turn "int a[5][5]" into "int ** temp" *) -let rec array_to_pointer tau = - match unrollType tau with - TArray(dest,_,al) -> TPtr(array_to_pointer dest,al) - | _ -> tau - -(* create a temporary variable in the current function *) -let make_temp tau = - let tau = array_to_pointer tau in - match !thefunc with - Some(fundec) -> makeTempVar fundec ~name:("mem_") tau - | None -> failwith "simplemem: temporary needed outside a function" - -(* separate loffsets into "scalar addition parts" and "memory parts" *) -let rec separate_loffsets lo = - match lo with - NoOffset -> NoOffset, NoOffset - | Field(fi,rest) -> - let s,m = separate_loffsets rest in - Field(fi,s) , m - | Index(_) -> NoOffset, lo - -(* Recursively decompose the lvalue so that what is under a "Mem()" - * constructor is put into a temporary variable. *) -let rec handle_lvalue (lb,lo) = - let s,m = separate_loffsets lo in - match lb with - Var(vi) -> - handle_loffset (lb,s) m - | Mem(Lval(Var(_),NoOffset)) -> - (* special case to avoid generating "tmp = ptr;" *) - handle_loffset (lb,s) m - | Mem(e) -> - begin - let new_vi = make_temp (typeOf e) in - assignment_list := (Set((Var(new_vi),NoOffset),e,!currentLoc)) - :: !assignment_list ; - handle_loffset (Mem(Lval(Var(new_vi),NoOffset)),NoOffset) lo - end -and handle_loffset lv lo = - match lo with - NoOffset -> lv - | Field(f,o) -> handle_loffset (addOffsetLval (Field(f,NoOffset)) lv) o - | Index(exp,o) -> handle_loffset (addOffsetLval (Index(exp,NoOffset)) lv) o - -(* the transformation is implemented as a Visitor *) -class simpleVisitor = object - inherit nopCilVisitor - - method vfunc fundec = (* we must record the current context *) - thefunc := Some(fundec) ; - DoChildren - - method vlval lv = ChangeDoChildrenPost(lv, - (fun lv -> handle_lvalue lv)) - - method unqueueInstr () = - let result = List.rev !assignment_list in - assignment_list := [] ; - result -end - -(* Main entry point: apply the transformation to a file *) -let simplemem (f : file) = - try - visitCilFileSameGlobals (new simpleVisitor) f; - f - with e -> Printf.printf "Exception in Simplemem.simplemem: %s\n" - (Printexc.to_string e) ; raise e - -let feature = - { fd_name = "simpleMem"; - fd_enabled = false; - fd_description = "simplify all memory expressions" ; - fd_extraopt = []; - fd_doit = (function (f: file) -> ignore (simplemem f)) ; - fd_post_check = true; - } - -let () = Feature.register feature diff --git a/src/ext/simplify/META b/src/ext/simplify/META deleted file mode 100644 index 7b7d77c1b..000000000 --- a/src/ext/simplify/META +++ /dev/null @@ -1 +0,0 @@ -description = "compiles CIL to 3-address code" diff --git a/src/ext/simplify/default b/src/ext/simplify/default deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/ext/simplify/simplify.ml b/src/ext/simplify/simplify.ml deleted file mode 100644 index 182da9870..000000000 --- a/src/ext/simplify/simplify.ml +++ /dev/null @@ -1,769 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * Sumit Gulwani - * 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. - * - *) - -(* This module simplifies the expressions in a program in the following ways: - -1. All expressions are either - - basic::= - Const _ - Addrof(Var v, NoOffset) - StartOf(Var v, NoOffset) - Lval(Var v, off), where v is a variable whose address is not taken - and off contains only "basic" - - exp::= - basic - Lval(Mem basic, NoOffset) - BinOp(bop, basic, basic) - UnOp(uop, basic) - CastE(t, basic) - - lval ::= - Mem basic, NoOffset - Var v, off, where v is a variable whose address is not taken and off - contains only "basic" - - - all sizeof and alignof are turned into constants - - accesses to variables whose address is taken is turned into "Mem" accesses - - same for accesses to arrays - - all field and index computations are turned into address arithmetic, - including bitfields. - -*) - - -open Pretty -open Cil -open Feature -module E = Errormsg -module H = Hashtbl - -type taExp = exp (* Three address expression *) -type bExp = exp (* Basic expression *) - -let debug = true - -(* Whether to split structs *) -let splitStructs = ref true - -(* Whether to simplify inside of Mem *) -let simpleMem = ref true -let simplAddrOf = ref true - -(* Whether to convert function calls to calls-by-pointer when function address - * has been taken somewhere. *) -let convertDirectCalls = ref true - -(* Whether to convert field offsets to offsets by integer. - * This conversion makes the generated code analysis simpler for static source - * code verifiers. *) -let convertFieldOffsets = ref true -(* WARN: splitStructs should be set to false if field offsets are not - * converted. Otherwise, the connection between a pointer to a structure and - * its fields is sometimes lost, and is harder to analyze statically. If a - * structure inside a structure (say, "struct A{struct B b} a;" is split into - * fields, then, instead of a pointer to the enclosed structure (in "&a.b"), a - * pointer to its first member might be used. This will make the rest of the - * structure pointed to by "&a.b" be accessed through the (possibly - * non-structure) pointer to its first element, which is harder to analyze - * statically. - * - * Last, but not least, this inconsistency will trigger "Cannot find - * component .foo of bar" error if you turn splitting structure on and take an - * address of bar.foo, where foo is a field of a structure type. :-) -*) - -let onlyVariableBasics = ref false -let noStringConstantsBasics = ref false - -exception BitfieldAccess - -(* Turn an expression into a three address expression (and queue some - * instructions in the process) *) -let rec makeThreeAddress - (setTemp: taExp -> bExp) (* Given an expression save it into a temp and - * return that temp *) - (e: exp) : taExp = - match e with - SizeOf _ | SizeOfE _ | AlignOf _ | AlignOfE _ | SizeOfStr _ -> - constFold true e - | Const _ -> e - | AddrOf (Var _, NoOffset) -> e - | AddrOfLabel (_) -> e - | Lval lv -> Lval (simplifyLval setTemp lv) - | BinOp(bo, e1, e2, tres) -> - BinOp(bo, makeBasic setTemp e1, makeBasic setTemp e2, tres) - | Question _ -> - E.s (bug "Simplify: There should not be a \"?:\" operator here.") - | UnOp(uo, e1, tres) -> - UnOp(uo, makeBasic setTemp e1, tres) - | CastE(t, e) -> - CastE(t, makeBasic setTemp e) - | AddrOf lv -> begin - if not(!simplAddrOf) then e else - match simplifyLval setTemp lv with - Mem a, NoOffset -> if !simpleMem then a else AddrOf(Mem a, NoOffset) - (* Do not change addrof if we do not convert field offsets *) - | Mem a, off when not !convertFieldOffsets -> AddrOf(Mem a, off) - (* Do not change addrof if we do not convert field offsets *) - | Var v, off when not !convertFieldOffsets -> AddrOf(Var v, off) - | _ -> (* This is impossible, because we are taking the address - * of v and simplifyLval should turn it into a Mem, except if the - * sizeof has failed. *) - E.s (bug "Simplify: makeThreeAddress for AddrOf(LV=%a, LVT=%a)" - d_lval lv d_type (typeOfLval lv)) - end - | StartOf lv -> - makeThreeAddress setTemp (AddrOf (addOffsetLval (Index(zero, NoOffset)) - lv)) - -(* Make a basic expression *) -and makeBasic (setTemp: taExp -> bExp) (e: exp) : bExp = - let dump = false (* !currentLoc.line = 395 *) in - if dump then - ignore (E.log "makeBasic %a\n" d_plainexp e); - (* Make it a three address expression first *) - let e' = makeThreeAddress setTemp e in - if dump then - ignore (E.log " e'= %a\n" d_plainexp e'); - (* See if it is a basic one *) - match e' with - | Lval (Var _, _) -> e' - | Const _ | AddrOf (Var _, NoOffset) | StartOf (Var _, NoOffset) -> - if !onlyVariableBasics then setTemp e' else e' - | SizeOf _ | SizeOfE _ | AlignOf _ | AlignOfE _ | SizeOfStr _ -> - E.s (bug "Simplify: makeBasic found SizeOf: %a" d_exp e') - - (* We cannot make a function to be Basic, unless it actually is a variable - * already. If this is a function pointer the best we can do is to make - * the address of the function basic *) - | Lval (Mem a, NoOffset) when isFunctionType (typeOf e') -> - if dump then - ignore (E.log " a function type\n"); - let a' = makeBasic setTemp a in - Lval (Mem a', NoOffset) - - | AddrOf lv when not(!simplAddrOf) -> e' - - | _ -> begin - if dump then ignore (E.log "Placing %a into a temporary\n" d_plainexp e'); - setTemp e' (* Put it into a temporary otherwise *) - end - - -and simplifyLval - (setTemp: taExp -> bExp) - (lv: lval) : lval = - (* Add, watching for a zero *) - let add (e1: exp) (e2: exp) = - if isZero e2 then e1 else BinOp(PlusA, e1, e2, !upointType) - in - (* Convert an offset to an integer, and possibly a residual bitfield offset*) - let rec offsetToInt - (t: typ) (* The type of the host *) - (off: offset) : exp * offset = - match off with - NoOffset -> zero, NoOffset - | Field(fi, off') -> begin - let start = - try - let start, _ = bitsOffset t (Field(fi, NoOffset)) in - start - with SizeOfError (whystr, t') -> - E.s (E.bug "%a: Cannot compute sizeof: %s: %a" - d_loc !currentLoc whystr d_type t') - in - if start land 7 <> 0 then begin - (* We have a bitfield *) - assert (off' = NoOffset); - zero, Field(fi, off') - end else begin - let next, restoff = offsetToInt fi.ftype off' in - add (integer (start / 8)) next, restoff - end - end - | Index(ei, off') -> begin - let telem = match unrollType t with - TArray(telem, _, _) -> telem - | _ -> E.s (bug "Simplify: simplifyLval: index on a non-array") - in - let next, restoff = offsetToInt telem off' in - add - (BinOp(Mult, ei, SizeOf telem, !upointType)) - next, - restoff - end - in - let tres = TPtr(typeOfLval lv, []) in - let typeForCast restOff: typ = - (* in (e+i)-> restoff, what should we cast e+i to? *) - match restOff with - Index _ -> E.s (bug "index in restOff") - | NoOffset -> tres - | Field(fi, NoOffset) -> (* bitfield *) - TPtr(TComp(fi.fcomp, []), []) - | Field(fi, _) -> E.s (bug "bug in offsetToInt") - in - match lv with - Mem a, off when not !convertFieldOffsets -> - let a' = if !simpleMem then makeBasic setTemp a else a in - Mem a', off - | Mem a, off -> - let offidx, restoff = offsetToInt (typeOfLval (Mem a, NoOffset)) off in - let a' = - if offidx <> zero then - add (mkCast a !upointType) offidx - else - a - in - let a' = if !simpleMem then makeBasic setTemp a' else a' in - Mem (mkCast a' (typeForCast restoff)), restoff - (* We are taking this variable's address; but suppress simplification if it's a simple function - * call in no-convert-function-calls mode*) - | Var v, off when v.vaddrof && (!convertDirectCalls || not (isFunctionType (typeOfLval lv) )) -> - if (not !convertFieldOffsets) then (Var v, off) else - let offidx, restoff = offsetToInt v.vtype off in - (* We cannot call makeBasic recursively here, so we must do it - * ourselves *) - let a = mkAddrOrStartOf (Var v, NoOffset) in - let a' = - if offidx = zero then a else - if !simpleMem then - add (mkCast a !upointType) (makeBasic setTemp offidx) - else add (mkCast a !upointType) offidx - in - let a' = if !simpleMem then setTemp a' else a' in - Mem (mkCast a' (typeForCast restoff)), restoff - - | Var v, off -> - (Var v, simplifyOffset setTemp off) - - -(* Simplify an offset and make sure it has only three address expressions in - * indices *) -and simplifyOffset (setTemp: taExp -> bExp) = function - NoOffset -> NoOffset - | Field(fi, off) -> Field(fi, simplifyOffset setTemp off) - | Index(ei, off) -> - let ei' = makeBasic setTemp ei in - Index(ei', simplifyOffset setTemp off) - - - - -(** This is a visitor that will turn all expressions into three address code *) -class threeAddressVisitor (fi: fundec) = object (self) - inherit nopCilVisitor - - method private makeTemp (e1: exp) : exp = - let t = makeTempVar fi (typeOf e1) in - (* Add this instruction before the current statement *) - self#queueInstr [Set(var t, e1, !currentLoc)]; - Lval(var t) - - (* We'll ensure that this gets called only for top-level expressions - * inside functions. We must turn them into three address code. *) - method vexpr (e: exp) = - let e' = makeThreeAddress self#makeTemp e in - ChangeTo e' - - - (** We want the argument in calls to be simple variables *) - method vinst (i: instr) = - match i with - Call (someo, f, args, loc) -> - let someo' = - match someo with - Some lv -> Some (simplifyLval self#makeTemp lv) - | _ -> None - in - let f' = makeBasic self#makeTemp f in - let args' = Util.list_map (makeBasic self#makeTemp) args in - ChangeTo [ Call (someo', f', args', loc) ] - | _ -> DoChildren - - (* This method will be called only on top-level "lvals" (those on the - * left of assignments and function calls) *) - method vlval (lv: lval) = - ChangeTo (simplifyLval self#makeTemp lv) -end - - -(* Whether to split the arguments of functions *) -let splitArguments = true - -(* Whether we try to do the splitting all in one pass. The advantage is that - * it is faster and it generates nicer names *) -let lu = locUnknown - -(* Go over the code and split some temporary variables of stucture type into - * several separate variables. The hope is that the compiler will have an - * easier time to do standard optimizations with the resulting scalars *) -(* Unfortunately, implementing this turns out to be more complicated than I - * thought *) - -(** Iterate over the fields of a structured type. Returns the empty list if - * no splits. The offsets are in order in which they appear in the structure - * type. Along with the offset we pass a string that identifies the - * meta-component, and the type of that component. *) -let rec foldRightStructFields - (doit: offset -> string -> typ -> 'a) (* Invoked on non-struct fields *) - (off: offset) - (post: 'a list) (** A suffix to what you compute *) - (fields: fieldinfo list) : 'a list = - List.fold_right - (fun f post -> - let off' = addOffset (Field(f, NoOffset)) off in - match unrollType f.ftype with - TComp (comp, _) when comp.cstruct -> (* struct type: recurse *) - if (List.exists (fun f -> isArrayType f.ftype) comp.cfields) then - begin - E.log ("%a: Simplify: Not splitting struct %s because one" - ^^" of its fields is an array.\n") - d_loc (List.hd comp.cfields).floc - comp.cname; - (doit off' f.fname f.ftype) :: post - end - else - foldRightStructFields doit off' post comp.cfields - | _ -> - (doit off' f.fname f.ftype) :: post) - fields - post - - -let rec foldStructFields - (t: typ) - (doit: offset -> string -> typ -> 'a) - : 'a list = - match unrollType t with - TComp (comp, _) when comp.cstruct -> - foldRightStructFields doit NoOffset [] comp.cfields - | _ -> [] - - -(* Map a variable name to a list of component variables, along with the - * accessor offset. The fields are in the order in which they appear in the - * structure. *) -let newvars : (string, (offset * varinfo) list) H.t = H.create 13 - -(* Split a variable and return the replacements, in the proper order. If this - * variable is not split, then return just the variable. *) -let splitOneVar (v: varinfo) - (mknewvar: string -> typ -> varinfo) : varinfo list = - try - (* See if we have already split it *) - Util.list_map snd (H.find newvars v.vname) - with Not_found -> begin - let vars: (offset * varinfo) list = - foldStructFields v.vtype - (fun off n t -> (* make a new one *) - let newname = v.vname ^ "_" ^ n in - let v'= mknewvar newname t in - (off, v')) - in - if vars = [] then - [ v ] - else begin - (* Now remember the newly created vars *) - H.add newvars v.vname vars; - Util.list_map snd vars (* Return just the vars *) - end - end - - -(* A visitor that finds all locals that appear in a call or have their - * address taken *) -let dontSplitLocals : (string, bool) H.t = H.create 111 -class findVarsCantSplitClass : cilVisitor = object (self) - inherit nopCilVisitor - - (* expressions, to see the address being taken *) - method vexpr (e: exp) : exp visitAction = - match e with - AddrOf (Var v, NoOffset) -> - H.add dontSplitLocals v.vname true; SkipChildren - (* See if we take the address of the "_ms" field in a variable *) - | _ -> DoChildren - - - (* variables involved in call instructions *) - method vinst (i: instr) : instr list visitAction = - match i with - Call (res, f, args, _) -> - (match res with - Some (Var v, NoOffset) -> H.add dontSplitLocals v.vname true - | _ -> ()); - if not splitArguments then - List.iter (fun a -> - match a with - Lval (Var v, NoOffset) -> H.add dontSplitLocals v.vname true - | _ -> ()) args; - (* Now continue the visit *) - DoChildren - - | _ -> DoChildren - - (* Variables used in return should not be split *) - method vstmt (s: stmt) : stmt visitAction = - match s.skind with - Return (Some (Lval (Var v, NoOffset)), _) -> - H.add dontSplitLocals v.vname true; DoChildren - | Return (Some e, _) -> - DoChildren - | _ -> DoChildren - - method vtype t = SkipChildren - -end -let findVarsCantSplit = new findVarsCantSplitClass - -let isVar lv = - match lv with - (Var v, NoOffset) -> true - | _ -> false - - -class splitVarVisitorClass(func:fundec option) : cilVisitor = object (self) - inherit nopCilVisitor - - method private makeTemp (e1: exp) : exp = - let fi:fundec = match func with - Some f -> f - | None -> - E.s (bug "You can't create a temporary if you're not in a function.") - in - let t = makeTempVar fi (typeOf e1) in - (* Add this instruction before the current statement *) - self#queueInstr [Set(var t, e1, !currentLoc)]; - Lval(var t) - - - (* We must process the function types *) - method vtype t = - (* We invoke the visitor first and then we fix it *) - let postProcessFunType (t: typ) : typ = - match t with - TFun(rt, Some params, isva, a) -> - let rec loopParams = function - [] -> [] - | ((pn, pt, pa) :: rest) as params -> - let rest' = loopParams rest in - let res: (string * typ * attributes) list = - foldStructFields pt - (fun off n t -> - (* Careful with no-name parameters, or we end up with - * many parameters named _p ! *) - ((if pn <> "" then pn ^ n else ""), t, pa)) - in - if res = [] then (* Not a fat *) - if rest' == rest then - params (* No change at all. Try not to reallocate so that - * the visitor does not allocate. *) - else - (pn, pt, pa) :: rest' - else (* Some change *) - res @ rest' - in - let params' = loopParams params in - if params == params' then - t - else - TFun(rt, Some params', isva, a) - - | t -> t - in - if splitArguments then - ChangeDoChildrenPost(t, postProcessFunType) - else - SkipChildren - - (* Whenever we see a variable with a field access we try to replace it - * by its components *) - method vlval ((b, off) : lval) : lval visitAction = - try - match b, off with - Var v, (Field _ as off) -> - (* See if this variable has some splits.Might throw Not_found *) - let splits = H.find newvars v.vname in - (* Now find among the splits one that matches this offset. And - * return the remaining offset *) - let rec find = function - [] -> - E.s (E.bug "Cannot find component %a of %s\n" - (d_offset nil) off v.vname) - | (splitoff, splitvar) :: restsplits -> - let rec matches = function - Field(f1, rest1), Field(f2, rest2) - when f1.fname = f2.fname -> - matches (rest1, rest2) - | off, NoOffset -> - (* We found a match *) - (Var splitvar, off) - | NoOffset, restoff -> - ignore (warn "Found aggregate lval %a" - d_lval (b, off)); - find restsplits - - | _, _ -> (* We did not match this one; go on *) - find restsplits - in - matches (off, splitoff) - in - ChangeTo (find splits) - | _ -> DoChildren - with Not_found -> DoChildren - - (* Sometimes we pass the variable as a whole to a function or we - * assign it to something *) - method vinst (i: instr) : instr list visitAction = - match i with - (* Split into several instructions and then do children inside - * the rhs. Howver, v might appear in the rhs and if we - * duplicate the instruction we might get bad - * results. (e.g. test/small1/simplify_Structs2.c). So first copy - * the rhs to temp variables, then to v. - * - * Optimization: if the rhs is a variable, skip the temporary vars. - * Either the rhs = lhs, in which case this is all a nop, or it's not, - * in which case the rhs and lhs don't overlap.*) - - Set ((Var v, NoOffset), Lval lv, l) when H.mem newvars v.vname -> begin - let needTemps = not (isVar lv) in - let vars4v = H.find newvars v.vname in - if vars4v = [] then E.s (errorLoc l "No fields in split struct"); - ChangeTo - (Util.list_map - (fun (off, newv) -> - let lv' = - visitCilLval (self :> cilVisitor) - (addOffsetLval off lv) in - (* makeTemp creates a temp var and puts (Lval lv') in it, - before any instructions in this ChangeTo list are handled.*) - let lv_tmp = if needTemps then - self#makeTemp (Lval lv') - else - (Lval lv') - in - Set((Var newv, NoOffset), lv_tmp, l)) - vars4v) - end - - | Set (lv, Lval (Var v, NoOffset), l) when H.mem newvars v.vname -> begin - (* Split->NonSplit assignment. no overlap between lhs and rhs - is possible*) - let vars4v = H.find newvars v.vname in - if vars4v = [] then E.s (errorLoc l "No fields in split struct"); - ChangeTo - (Util.list_map - (fun (off, newv) -> - let lv' = - visitCilLval (self :> cilVisitor) - (addOffsetLval off lv) in - Set(lv', Lval (Var newv, NoOffset), l)) - vars4v) - end - - (* Split all function arguments in calls *) - | Call (ret, f, args, l) when splitArguments -> - (* Visit the children first and then see if we must change the - * arguments *) - let finishArgs = function - [Call (ret', f', args', l')] as i' -> - let mustChange = ref false in - let newargs = - (* Look for opportunities to split arguments. If we can - * split, we must split the original argument (in args). - * Otherwise, we use the result of processing children - * (in args'). *) - List.fold_right2 - (fun a a' acc -> - match a with - Lval (Var v, NoOffset) when H.mem newvars v.vname -> - begin - mustChange := true; - (Util.list_map - (fun (_, newv) -> - Lval (Var newv, NoOffset)) - (H.find newvars v.vname)) - @ acc - end - | Lval lv -> begin - let newargs = - foldStructFields (typeOfLval lv) - (fun off n t -> - let lv' = addOffsetLval off lv in - Lval lv') in - if newargs = [] then - a' :: acc (* not a split var *) - else begin - mustChange := true; - newargs @ acc - end - end - | _ -> (* only lvals are split, right? *) - a' :: acc) - args args' - [] - in - if !mustChange then - [Call (ret', f', newargs, l')] - else - i' - | _ -> E.s (E.bug "splitVarVisitorClass: expecting call") - in - ChangeDoChildrenPost ([i], finishArgs) - - | _ -> DoChildren - - - method vfunc (func: fundec) : fundec visitAction = - H.clear newvars; - H.clear dontSplitLocals; - (* Visit the type of the function itself *) - if splitArguments then - func.svar.vtype <- visitCilType (self :> cilVisitor) func.svar.vtype; - - (* Go over the block and find the candidates *) - ignore (visitCilBlock findVarsCantSplit func.sbody); - - (* Now go over the formals and create the splits *) - if splitArguments then begin - (* Split all formals because we will split all arguments in function - * types *) - let newformals = - List.fold_right - (fun form acc -> - (* Process the type first *) - form.vtype <- - visitCilType (self : #cilVisitor :> cilVisitor) form.vtype; - let form' = - splitOneVar form - (fun s t -> makeTempVar func ~insert:false ~name:s t) - in - (* Now it is a good time to check if we actually can split this - * one *) - if List.length form' > 1 && - H.mem dontSplitLocals form.vname then - ignore (warn "boxsplit: can't split formal \"%s\" in %s. Make sure you never take the address of a formal." - form.vname func.svar.vname); - form' @ acc) - func.sformals [] - in - (* Now make sure we fix the type. *) - setFormals func newformals - end; - (* Now go over the locals and create the splits *) - List.iter - (fun l -> - (* Process the type of the local *) - l.vtype <- visitCilType (self :> cilVisitor) l.vtype; - (* Now see if we must split it *) - if not (H.mem dontSplitLocals l.vname) then begin - ignore (splitOneVar l (fun s t -> makeTempVar func ~name:s t)) - end) - func.slocals; - (* Now visit the body and change references to these variables *) - ignore (visitCilBlock (self :> cilVisitor) func.sbody); - H.clear newvars; - H.clear dontSplitLocals; - SkipChildren (* We are done with this function *) - - (* Try to catch the occurrences of the variable in a sizeof expression *) - method vexpr (e: exp) = - match e with - | SizeOfE (Lval(Var v, NoOffset)) -> begin - try - let splits = H.find newvars v.vname in - (* We cound here on no padding between the elements ! *) - ChangeTo - (List.fold_left - (fun acc (_, thisv) -> - BinOp(PlusA, SizeOfE(Lval(Var thisv, NoOffset)), - acc, uintType)) - zero - splits) - with Not_found -> DoChildren - end - | _ -> DoChildren -end - -let doGlobal = function - GFun(fi, _) -> - (* Visit the body and change all expressions into three address code *) - let v = new threeAddressVisitor fi in - fi.sbody <- visitCilBlock v fi.sbody; - if !splitStructs then begin - H.clear dontSplitLocals; - let splitVarVisitor = new splitVarVisitorClass (Some fi) in - ignore (visitCilFunction splitVarVisitor fi); - end - | GVarDecl(vi, _) when isFunctionType vi.vtype -> - (* we might need to split the args/return value in the function type. *) - if !splitStructs then begin - H.clear dontSplitLocals; - let splitVarVisitor = new splitVarVisitorClass None in - ignore (visitCilVarDecl splitVarVisitor vi); - end - | _ -> () - -let feature = - { fd_name = "simplify"; - fd_enabled = false; - fd_description = "compiles CIL to 3-address code"; - fd_extraopt = [ - ("--no-split-structs", Arg.Clear splitStructs, - " do not split structured variables"); - ("--no-convert-direct-calls", Arg.Clear convertDirectCalls, - " do not convert direct function calls to function pointer \ - calls if the address of the function was taken"); - ("--no-convert-field-offsets", Arg.Unit ( fun () -> - convertFieldOffsets := false; - (* do not split structs in function calls *) - splitStructs := false - ), - " do not convert field offsets to offsets by integer. \ - Implies --no-split-structs. To be used by static code \ - verification tools."); - ]; - fd_doit = (function f -> iterGlobals f doGlobal); - fd_post_check = true; -} - -let () = Feature.register feature diff --git a/src/ext/simplify/simplify.mli b/src/ext/simplify/simplify.mli deleted file mode 100644 index e3d12b987..000000000 --- a/src/ext/simplify/simplify.mli +++ /dev/null @@ -1,16 +0,0 @@ -(** Whether to split structs *) -val splitStructs : bool ref - -(** Whether to simplify inside of Mem *) -val simpleMem : bool ref - -(** Whether to simplify inside of AddrOf *) -val simplAddrOf : bool ref - -val onlyVariableBasics : bool ref -val noStringConstantsBasics : bool ref - -(** Simplify a given global *) -val doGlobal : Cil.global -> unit - -val feature : Feature.t diff --git a/src/ext/syntacticsearch/META b/src/ext/syntacticsearch/META new file mode 100644 index 000000000..537f54c7c --- /dev/null +++ b/src/ext/syntacticsearch/META @@ -0,0 +1 @@ +description = "Syntactic Search in CIL programs" diff --git a/src/ext/syntacticsearch/codeQuery.ml b/src/ext/syntacticsearch/codeQuery.ml new file mode 100644 index 000000000..0bb278494 --- /dev/null +++ b/src/ext/syntacticsearch/codeQuery.ml @@ -0,0 +1,73 @@ +open Yojson.Safe +module Result = Ppx_deriving_yojson_runtime.Result +(* JSON-query has the following form: + select: ... + type: ... + target: ... + find: ... + structure: ... + constraint: ... *) + +type selectable = + | Name_sel [@name "name"] + | Location_sel [@name "location"] [@to_yojson fun x -> `String x] + | Type_sel [@name "type"] [@to_yojson fun x -> `String x] + | ID_sel [@name "id"] [@to_yojson fun x -> `String x] +[@@deriving yojson] + +type select = selectable list [@@deriving yojson] + +type kind = + | Var_k [@name "var"] + | Fun_k [@name "fun"] + | Datatype_k [@name "datatype"] +[@@deriving yojson] + +type target = + | Name_t of string [@name "name"] + | ID_t of int [@name "id"] + | All_t [@name "all"] + | AllGlobVar_t [@name "all_glob_var"] + | Or_t of string list [@name "or"] + | And_t of string list [@name "and"] +[@@deriving yojson] + +type find = + | Uses_f [@name "uses"] + | Decl_f [@name "decl"] + | Defs_f [@name "defs"] + | UsesWithVar_f of string [@name "uses_with_var"] + | Returns_f [@name "returns"] +[@@deriving yojson] + +type structure = + | Fun_s of string [@name "fun_name"] + | Cond_s [@name "cond"] + | NonCond_s [@name "non-cond"] + | None_s [@name "none"] +[@@deriving yojson] + +type constr = Constraint_c of string [@name "constr"] | None_c [@name "none"] +[@@deriving yojson] + +(* Type-definition of a query for mapping use *) +type query = { + sel : select; [@key "select"] + k : kind; [@key "type"] + tar : target; [@key "target"] + f : find; [@key "find"] + str : (structure[@default None_s]); [@key "structure"] + lim : (constr[@default None_c]); [@key "constraint"] +} +[@@deriving yojson] + +(* toString-function for query *) + +let to_string_q query = Yojson.Safe.to_string (query_to_yojson query) + +exception Error of string + +let parse_json_file filename = + let jsonTree = from_file filename in + let derived = query_of_yojson jsonTree in + match derived with Result.Ok y -> y | Result.Error x -> raise (Error x) diff --git a/src/ext/syntacticsearch/dune b/src/ext/syntacticsearch/dune new file mode 100644 index 000000000..eb47349cf --- /dev/null +++ b/src/ext/syntacticsearch/dune @@ -0,0 +1,7 @@ +(library + (public_name goblint-cil.syntacticsearch) + (name syntacticsearch) + (wrapped false) ; this should be changed, but then module paths in goblint need to be prefixed + (libraries goblint-cil yojson ppx_deriving_yojson.runtime batteries.unthreaded) + (preprocess (pps ppx_deriving_yojson)) +) diff --git a/src/ext/syntacticsearch/funcDatatype.ml b/src/ext/syntacticsearch/funcDatatype.ml new file mode 100644 index 000000000..687b371e8 --- /dev/null +++ b/src/ext/syntacticsearch/funcDatatype.ml @@ -0,0 +1,91 @@ +open Cil + +(* Finds definition of a user-defined type *) +let find_def name file = + BatList.filter_map + (function + | GType (info, loc) -> + if String.compare name info.tname = 0 then Some ("", loc, name, -1) + else None + | GCompTag (info, loc) -> + if String.compare name info.cname = 0 then Some ("", loc, name, -1) + else None + | GEnumTag (info, loc) -> + if String.compare name info.ename = 0 then Some ("", loc, name, -1) + else None + | _ -> None) + file.globals + +(* Finds all definition of user-defined types *) +let find_def_all file = + BatList.filter_map + (function + | GType (info, loc) -> Some ("", loc, info.tname, -1) + | GCompTag (info, loc) -> Some ("", loc, info.cname, -1) + | GEnumTag (info, loc) -> Some ("", loc, info.ename, -1) + | _ -> None) + file.globals + +let find_in_globals list name = + BatList.filter_map + (function + | GVar (info, _, _) -> + if + String.compare name + (String.trim (Pretty.sprint ~width:1 (d_type () info.vtype))) + = 0 + then Some info.vid + else None + | _ -> None) + list + +let find_in_varinfos list name = + BatList.filter_map + (fun info -> + if + String.compare name + (String.trim (Pretty.sprint ~width:1 (d_type () info.vtype))) + = 0 + then Some info.vid + else None) + list + +let find_fundec globals name = + let gfun = + BatList.find_opt + (function + | GFun (fundec, _) -> String.compare fundec.svar.vname name = 0 + | _ -> false) + globals + in + match gfun with Some (GFun (fundec, _)) -> Some fundec | _ -> None + +let find_typevar_uses_in_fun list funname file = + List.flatten + @@ List.map (fun x -> FuncVar.find_uses_in_fun "" x funname file false) list + +(* Finds uses of a datatype in a function *) +let find_uses_in_fun typename funname file = + match find_fundec file.globals funname with + | None -> [] + | Some f -> + find_typevar_uses_in_fun + ( find_in_globals file.globals typename + @ find_in_varinfos f.slocals typename + @ find_in_varinfos f.sformals typename ) + f.svar.vname file + +(* Finds all uses of a datatype in all functions *) +let find_uses typename file = + let list = FuncVar.find_uses_all file false in + List.filter (fun (_, _, typ, _) -> String.compare typ typename = 0) list + +(* Finds all uses of a datatype in conditions *) +let find_uses_in_cond typename file = + let list = FuncVar.find_uses_in_cond_all file false in + List.filter (fun (_, _, typ, _) -> String.compare typ typename = 0) list + +(* Finds all uses of a datatype in non-conditions *) +let find_uses_in_noncond typename file = + let list = FuncVar.find_uses_in_noncond_all file false in + List.filter (fun (_, _, typ, _) -> String.compare typ typename = 0) list diff --git a/src/ext/syntacticsearch/funcFunction.ml b/src/ext/syntacticsearch/funcFunction.ml new file mode 100644 index 000000000..3d26a39fd --- /dev/null +++ b/src/ext/syntacticsearch/funcFunction.ml @@ -0,0 +1,427 @@ +open Cil +open Cabs2cil + +let is_equal_funname_funid varinfo name id = + if String.compare varinfo.vname name = 0 || varinfo.vid = id then true + else false + +let rec delete_elem list s = + match list with + | x :: xs -> + if String.compare x s = 0 then delete_elem xs s else x :: delete_elem xs s + | [] -> [] + +let rec delete_duplicates list acc = + match list with + | x :: xs -> delete_duplicates (delete_elem xs x) (x :: acc) + | [] -> acc + +let map_gfun f = function GFun (dec, loc) -> f dec loc | _ -> None + +let find_all_with_origname n = + let ns = Hashtbl.find_all environment n in + BatList.filter_map (function | (EnvVar v,_) -> Some v.vname | _ -> None) ns + +class fun_find_returns funname funid result : nopCilVisitor = + object + inherit nopCilVisitor + + method! vfunc fundec = + if is_equal_funname_funid fundec.svar funname funid then DoChildren + else SkipChildren + + method! vstmt stmt = + match stmt.skind with + | Return (Some exp, loc) -> + result := + !result + @ [ + ( "", + loc, + String.trim (Pretty.sprint ~width:1 (d_type () (typeOf exp))), + -1 ); + ]; + DoChildren + | Return (None, loc) -> + result := !result @ [ ("", loc, "void", -1) ]; + DoChildren + | _ -> DoChildren + end + +(* Finds all returns of a function *) +let find_returns funname funid file = + let result = ref [] in + let visitor = new fun_find_returns funname funid result in + ignore (visitCilFileSameGlobals visitor file); + !result + +(* Finds all returns in all functions *) +let find_returns_all file = + List.flatten + @@ BatList.filter_map + (map_gfun (fun fundec _ -> Some (find_returns "" fundec.svar.vid file))) + file.globals + +class fun_find_sig funname funid result : nopCilVisitor = + object + inherit nopCilVisitor + + method! vfunc fundec = + if is_equal_funname_funid fundec.svar funname funid then DoChildren + else SkipChildren + + method! vstmt stmt = + match stmt.skind with + | Return (Some exp, loc) -> + result := + !result + @ [ + ( "", + loc, + String.trim (Pretty.sprint ~width:1 (d_type () (typeOf exp))), + -1 ); + ]; + SkipChildren + | Return (None, loc) -> + result := !result @ [ ("", loc, "void", -1) ]; + SkipChildren + | _ -> DoChildren + end + +let create_sig fundec file = + let result = ref [] in + let return_type = + match + visitCilFileSameGlobals + (new fun_find_sig fundec.svar.vname fundec.svar.vid result) + file; + !result + with + | (_, _, typ, _) :: _ -> typ + | [] -> + Printf.printf "This should never happen\n"; + "" + in + let rec input_type list = + match list with + | [ x ] -> + String.trim (Pretty.sprint ~width:1 (d_type () x.vtype)) ^ " " ^ x.vname + | x :: xs -> + String.trim (Pretty.sprint ~width:1 (d_type () x.vtype)) + ^ " " ^ x.vname ^ ", " ^ input_type xs + | [] -> "" + in + return_type ^ " " ^ fundec.svar.vname ^ " (" ^ input_type fundec.sformals + ^ ")" + +(* Finds all definitions of a function *) +let find_def funname funid file = + let fn fundec loc = + if is_equal_funname_funid fundec.svar funname funid then + Some (fundec.svar.vname, loc, create_sig fundec file, fundec.svar.vid) + else None + in + BatList.filter_map (map_gfun fn) file.globals + +(* Finds all definitions of all functions *) +let find_def_all file = + List.flatten + @@ BatList.filter_map + (map_gfun (fun fundec _ -> Some (find_def "" fundec.svar.vid file))) + file.globals + +let find_fundec funname funid list = + let gfun = + BatList.find_opt + (fun x -> + match x with + | GFun (dec, _) -> is_equal_funname_funid dec.svar funname funid + | _ -> false) + list + in + match gfun with Some (GFun (dec, _)) -> Some dec | _ -> None + +class fun_find_uses funname funid file result : nopCilVisitor = + object + inherit nopCilVisitor + + method! vinst instr = + match instr with + | Call (_, Lval (Var varinfo, NoOffset), _, loc) -> + if is_equal_funname_funid varinfo funname funid then ( + match find_fundec funname funid file.globals with + | None -> SkipChildren + | Some dec -> + result := + !result + @ [ (varinfo.vname, loc, create_sig dec file, varinfo.vid) ]; + SkipChildren ) + else SkipChildren + | _ -> SkipChildren + end + +(* Finds all calls of a function in all functions *) +let find_uses funname funid file = + let result = ref [] in + let visitor = new fun_find_uses funname funid file result in + ignore (visitCilFileSameGlobals visitor file); + !result + +(* Find all calls of all functions in all functions *) +let find_uses_all file = + List.flatten + @@ BatList.filter_map + (map_gfun (fun fundec _ -> Some (find_uses "" fundec.svar.vid file))) + file.globals + +class fun_find_uses_in_fun funname funid funstrucname file result : + nopCilVisitor = + object + inherit nopCilVisitor + + method! vfunc fundec = + if is_equal_funname_funid fundec.svar funstrucname (-1) then DoChildren + else SkipChildren + + method! vinst instr = + match instr with + | Call (_, Lval (Var varinfo, NoOffset), _, loc) -> + if is_equal_funname_funid varinfo funname funid then ( + match find_fundec funname funid file.globals with + | None -> SkipChildren + | Some dec -> + result := + !result + @ [ (varinfo.vname, loc, create_sig dec file, varinfo.vid) ]; + SkipChildren ) + else SkipChildren + | _ -> SkipChildren + end + +(* Finds calls of a function in a function *) +let find_uses_in_fun funname funid funstrucname file = + let result = ref [] in + let visitor = + new fun_find_uses_in_fun funname funid funstrucname file result + in + ignore (visitCilFileSameGlobals visitor file); + !result + +(* Finds all calls of all functions in a function *) +let find_uses_in_fun_all funstrucname file = + List.flatten + @@ BatList.filter_map + (map_gfun (fun fundec _ -> + Some (find_uses_in_fun "" fundec.svar.vid funstrucname file))) + file.globals + +let loc_default = { line = -1; file = ""; byte = -1 } + +class fun_find_usesvar_in_fun fundec funstrucname varname varid file result : + nopCilVisitor = + object + inherit nopCilVisitor + + method! vfunc dec = + if is_equal_funname_funid dec.svar funstrucname (-1) then DoChildren + else SkipChildren + + method! vinst instr = + match instr with + | Call (_, exp, list, loc) -> ( + match exp with + | Lval (Var varinfo, _) -> + if + is_equal_funname_funid varinfo fundec.svar.vname fundec.svar.vid + then + if + List.length + (FuncVar.search_expression_list list varname loc_default + varid true) + > 0 + then ( + result := + !result + @ [ + (varinfo.vname, loc, create_sig fundec file, varinfo.vid); + ]; + SkipChildren ) + else SkipChildren + else SkipChildren + | _ -> SkipChildren ) + | _ -> SkipChildren + end + +(* Finds calls of a function with a var in argument in a function *) +let find_usesvar_in_fun funname funid funstrucname varname file = + match find_fundec funname funid file.globals with + | None -> [] + | Some fundec -> + let result = ref [] in + let dedup = + delete_duplicates (find_all_with_origname varname) [] + in + List.iter + (fun x -> + visitCilFileSameGlobals + (new fun_find_usesvar_in_fun fundec funstrucname x (-1) file result) + file) + dedup; + !result + +(* Finds calls of all function with a var in argument in a function *) +let find_usesvar_in_fun_all funstrucname varname file = + List.flatten + @@ BatList.filter_map + (map_gfun (fun fundec _ -> + Some + (find_usesvar_in_fun "" fundec.svar.vid funstrucname varname file))) + file.globals + +(* Finds all calls of a function with a var in argument in all functions *) +let find_usesvar funname funid varname file = + List.flatten + @@ BatList.filter_map + (map_gfun (fun fundec _ -> + Some + (find_usesvar_in_fun funname funid fundec.svar.vname varname file))) + file.globals + +(* Finds all calls of all functions with a var in argument in all functions *) +let find_usesvar_all varname file = + List.flatten + @@ BatList.filter_map + (map_gfun (fun fundec _ -> + Some (find_usesvar "" fundec.svar.vid varname file))) + file.globals + +let is_temporary id = Inthash.mem allTempVars id + +class find_calls_with_tmp result funname funid : nopCilVisitor = + object + inherit nopCilVisitor + + method! vinst instr = + match instr with + | Call (lval_opt, Lval (Var varinfo, _), _, _) -> + if is_equal_funname_funid varinfo funname funid then + match lval_opt with + | Some (Var tmpinfo, _) -> + if is_temporary tmpinfo.vid then + result := !result @ [ (tmpinfo.vid, varinfo.vid) ]; + SkipChildren + | _ -> SkipChildren + else SkipChildren + | _ -> SkipChildren + end + +let find_lval_of_calls funname funid file = + let result = ref [] in + let visitor = new find_calls_with_tmp result funname funid in + visitCilFileSameGlobals visitor file; + !result + +let create_fun_res name id file loc = + let fundec_opt = find_fundec name id file.globals in + match fundec_opt with + | None -> ("", loc_default, "", -1) + | Some fundec -> + (fundec.svar.vname, loc, create_sig fundec file, fundec.svar.vid) + +(* Finds all calls of a function in a condition in all functions *) +let find_uses_cond funname funid file = + let id_list = find_lval_of_calls funname funid file in + BatList.filter_map + (fun (tmp, func) -> + match FuncVar.find_uses_in_cond "" tmp file true with + | (_, loc, _, _) :: _ -> Some (create_fun_res "" func file loc) + | _ -> None) + id_list + +(* Finds all calls of all functions in a condition in all functions *) +let find_uses_cond_all file = + List.flatten + @@ BatList.filter_map + (map_gfun (fun fundec _ -> Some (find_uses_cond "" fundec.svar.vid file))) + file.globals + +(* Finds calls of a function in non-condition in all functions *) +let find_uses_noncond funname funid file = + let uses_cond = find_uses_cond funname funid file in + let all_uses = find_uses funname funid file in + List.filter (fun x -> not (List.mem x uses_cond)) all_uses + +(* Finds calls of all functions in non-condition in all functions *) +let find_uses_noncond_all file = + List.flatten + @@ BatList.filter_map + (map_gfun (fun fundec _ -> + Some (find_uses_noncond "" fundec.svar.vid file))) + file.globals + +class find_calls_usesvar_with_tmp result funname funid varname : nopCilVisitor = + object + inherit nopCilVisitor + + method! vinst instr = + match instr with + | Call (lval_opt, Lval (Var varinfo, _), arg_list, loc) -> + if + is_equal_funname_funid varinfo funname funid + && List.length + (List.flatten + (List.map + (fun x -> + FuncVar.search_expression_list arg_list x loc (-1) true) + (find_all_with_origname varname))) + > 0 + then + match lval_opt with + | Some (Var tmpinfo, _) -> + if + String.length tmpinfo.vname > 2 + && String.compare "tmp" (String.sub tmpinfo.vname 0 3) = 0 + then result := !result @ [ (tmpinfo.vid, varinfo.vid) ]; + SkipChildren + | _ -> SkipChildren + else SkipChildren + | _ -> SkipChildren + end + +let find_lval_of_calls_usesvar funname funid varname file = + let result = ref [] in + let visitor = new find_calls_usesvar_with_tmp result funname funid varname in + visitCilFileSameGlobals visitor file; + !result + +(* Finds calls of a function with a variable as argument in conditions *) +let find_usesvar_cond funname funid varname file = + let id_list = find_lval_of_calls_usesvar funname funid varname file in + BatList.filter_map + (fun (tmp, func) -> + match FuncVar.find_uses_in_cond "" tmp file true with + | (_, loc, _, _) :: _ -> Some (create_fun_res "" func file loc) + | _ -> None) + id_list + +(* Finds calls of all functions with a variable as argument in conditions *) +let find_usesvar_cond_all varname file = + List.flatten + @@ BatList.filter_map + (map_gfun (fun fundec _ -> + Some (find_usesvar_cond "" fundec.svar.vid varname file))) + file.globals + +(* Finds calls of a function with a variable as argument in non-conditions *) +let find_usesvar_noncond funname funid varname file = + let uses_cond = find_usesvar_cond funname funid varname file in + let all_uses = find_usesvar funname funid varname file in + List.filter (fun x -> not (List.mem x uses_cond)) all_uses + +(* Finds calls of all functions with a variable as argument in non-conditions *) +let find_usesvar_noncond_all varname file = + List.flatten + @@ BatList.filter_map + (map_gfun (fun fundec _ -> + Some (find_usesvar_noncond "" fundec.svar.vid varname file))) + file.globals diff --git a/src/ext/syntacticsearch/funcVar.ml b/src/ext/syntacticsearch/funcVar.ml new file mode 100644 index 000000000..6ce5db0e4 --- /dev/null +++ b/src/ext/syntacticsearch/funcVar.ml @@ -0,0 +1,655 @@ +open Cil +open Cabs2cil + +(* Helper functions *) +let is_equal_varname_varid varinfo name id = + if String.compare varinfo.vname name = 0 || varinfo.vid = id then true + else false + +let rec delete_elem list s = + match list with + | x :: xs -> + if String.compare x s = 0 then delete_elem xs s else x :: delete_elem xs s + | [] -> [] + +let rec delete_duplicates list tbl = + match list with + | x :: xs -> ( + let _ = try Hashtbl.find tbl x with Not_found -> Hashtbl.add tbl x 1; 1 in + x :: delete_duplicates xs tbl ) + | [] -> [] + +let map_gfun f = function GFun (dec, loc) -> f dec loc | _ -> None + +let map_gvar f = function + | GVar (varinfo, initinfo, loc) -> f varinfo initinfo loc + | _ -> None + +let is_temporary id = Inthash.mem allTempVars id + +let generate_func_loc_table cilfile = + BatList.filter_map + (map_gfun (fun dec loc -> Some (dec.svar.vname, loc.line))) + cilfile.globals + +let generate_globalvar_list cilfile = + BatList.filter_map + (map_gvar (fun varinfo _ _ -> Some varinfo.vname)) + cilfile.globals + +let get_all_alphaconverted_in_fun varname funname cilfile = + let fun_loc_table = generate_func_loc_table cilfile in + let loc_start = + snd + @@ List.find (function x, _ -> String.compare x funname = 0) fun_loc_table + in + let rec iter_fun_loc list = + match list with + | (fname, _) :: xs -> + if fname = funname then + match xs with (_, line) :: _ -> line | [] -> max_int + else iter_fun_loc xs + | [] -> 0 + in + let loc_end = iter_fun_loc fun_loc_table in + let tmp = + BatList.filter_map + (function + | EnvVar varinfo, loc when loc.line >= loc_start && loc.line < loc_end + -> + Some varinfo.vname + | _ -> None) + (Hashtbl.find_all environment varname) + in + delete_duplicates + ( tmp + @ + if + List.exists + (function x -> String.compare x varname = 0) + (generate_globalvar_list cilfile) + then [ varname ] + else [] ) + (Hashtbl.create 30) + +class var_search_in_expr varname varid loc result includeCallTmp : nopCilVisitor + = + object + inherit nopCilVisitor + + method! vvrbl info = + if + is_equal_varname_varid info varname varid + && (includeCallTmp || not (is_temporary info.vid)) + then + result := + !result + @ [ + ( info.vname, + loc, + String.trim (Pretty.sprint ~width:1 (d_type () info.vtype)), + info.vid ); + ] + else (); + SkipChildren + end + +(* Finds a variable in an expression *) +let search_expression exp name loc varid includeCallTmp = + let result = ref [] in + let visitor = new var_search_in_expr name varid loc result includeCallTmp in + ignore (visitCilExpr visitor exp); + !result + +(* Finds a variable in a lhost *) +let search_lhost host name loc varid includeCallTmp = + match host with + | Var info -> + if + is_equal_varname_varid info name varid + && (includeCallTmp || not (is_temporary info.vid)) + then + [ + ( info.vname, + loc, + String.trim (Pretty.sprint ~width:1 (d_type () info.vtype)), + info.vid ); + ] + else [] + | Mem exp -> search_expression exp name loc varid includeCallTmp + +let rec search_offset os name loc varid includeCallTmp = + match os with + | NoOffset -> [] + | Field (_, offset) -> search_offset offset name loc varid includeCallTmp + | Index (exp, offset) -> + search_expression exp name loc varid includeCallTmp + @ search_offset offset name loc varid includeCallTmp + +(* Finds a variable in a list of expressions *) +let rec search_expression_list list name loc varid includeCallTmp = + match list with + | x :: xs -> + search_expression x name loc varid includeCallTmp + @ search_expression_list xs name loc varid includeCallTmp + | [] -> [] + +(* Finds a variable in a list of instructions *) +let rec search_instr_list_for_var list name varid includeCallTmp = + match list with + | Set ((lhost, offset), exp, loc) :: xs -> + search_lhost lhost name loc varid includeCallTmp + @ search_offset offset name loc varid includeCallTmp + @ search_expression exp name loc varid includeCallTmp + @ search_instr_list_for_var xs name varid includeCallTmp + | VarDecl (info, loc) :: xs -> + ( match info.vtype with + | TArray (_, Some exp, _) -> + search_expression exp name loc varid includeCallTmp + | _ -> [] ) + @ + if + is_equal_varname_varid info name varid + && (includeCallTmp || not (is_temporary info.vid)) + then + ( info.vname, + loc, + String.trim (Pretty.sprint ~width:1 (d_type () info.vtype)), + info.vid ) + :: search_instr_list_for_var xs name varid includeCallTmp + else search_instr_list_for_var xs name varid includeCallTmp + | Call (Some (lhost, offset), exp, exp_list, loc) :: xs -> + search_lhost lhost name loc varid includeCallTmp + @ search_offset offset name loc varid includeCallTmp + @ search_expression exp name loc varid includeCallTmp + @ search_expression_list exp_list name loc varid includeCallTmp + @ search_instr_list_for_var xs name varid includeCallTmp + | Call (None, exp, exp_list, loc) :: xs -> + search_expression exp name loc varid includeCallTmp + @ search_expression_list exp_list name loc varid includeCallTmp + @ search_instr_list_for_var xs name varid includeCallTmp + (* Should I consider Asm too? *) + | _ :: xs -> search_instr_list_for_var xs name varid includeCallTmp + | [] -> [] + +(* Finds a variable in a list of statements *) +let rec search_stmt_list_for_var list name varid includeCallTmp = + match list with + | x :: xs -> + ( match x.skind with + | Instr ins_list -> + search_instr_list_for_var ins_list name varid includeCallTmp + | Return (Some exp, loc) -> + search_expression exp name loc varid includeCallTmp + | ComputedGoto (exp, loc) -> + search_expression exp name loc varid includeCallTmp + | If (exp, b1, b2, loc) -> + search_expression exp name loc varid includeCallTmp + @ search_stmt_list_for_var b1.bstmts name varid includeCallTmp + @ search_stmt_list_for_var b2.bstmts name varid includeCallTmp + | Switch (exp, _, stmt_list, loc) -> + search_expression exp name loc varid includeCallTmp + @ search_stmt_list_for_var stmt_list name varid includeCallTmp + | Loop (block, _, None, None) -> + search_stmt_list_for_var block.bstmts name varid includeCallTmp + | Loop (block, _, None, Some s2) -> + search_stmt_list_for_var block.bstmts name varid includeCallTmp + @ search_stmt_list_for_var [ s2 ] name varid includeCallTmp + | Loop (block, _, Some s1, None) -> + search_stmt_list_for_var block.bstmts name varid includeCallTmp + @ search_stmt_list_for_var [ s1 ] name varid includeCallTmp + | Loop (block, _, Some s1, Some s2) -> + search_stmt_list_for_var block.bstmts name varid includeCallTmp + @ search_stmt_list_for_var [ s1 ] name varid includeCallTmp + @ search_stmt_list_for_var [ s2 ] name varid includeCallTmp + | Block block -> + search_stmt_list_for_var block.bstmts name varid includeCallTmp + | TryFinally (b1, b2, _) -> + search_stmt_list_for_var b1.bstmts name varid includeCallTmp + @ search_stmt_list_for_var b2.bstmts name varid includeCallTmp + | TryExcept (b1, (instr_list, exp), b2, loc) -> + search_stmt_list_for_var b1.bstmts name varid includeCallTmp + @ search_instr_list_for_var instr_list name varid includeCallTmp + @ search_expression exp name loc varid includeCallTmp + @ search_stmt_list_for_var b2.bstmts name varid includeCallTmp + | _ -> [] ) + @ search_stmt_list_for_var xs name varid includeCallTmp + | [] -> [] + +(* Finds all uses of a variable in a function-body *) +let find_uses_in_fun_var dec name varid includeCallTmp cilfile = + if varid != -1 then + search_stmt_list_for_var dec.sbody.bstmts name varid includeCallTmp + else + let list = get_all_alphaconverted_in_fun name dec.svar.vname cilfile in + List.flatten + @@ List.map + (fun x -> + search_stmt_list_for_var dec.sbody.bstmts x (-1) includeCallTmp) + list + +(* Finds the function in which a variable shall be found *) +let find_uses_in_fun_find_fun list name varname varid includeCallTmp cilfile = + let r = + BatList.find_opt + (function + | GFun (dec, _) -> String.compare dec.svar.vname name = 0 | _ -> false) + list + in + match r with + | Some (GFun (dec, _)) -> + find_uses_in_fun_var dec varname varid includeCallTmp cilfile + | _ -> [] + +(* Finds all uses of a variable in a function *) +let find_uses_in_fun varname varid funname file includeCallTmp = + find_uses_in_fun_find_fun file.globals funname varname varid includeCallTmp + file + +let find_all_glob_vars list = + BatList.filter_map (map_gvar (fun info _ _ -> Some info.vid)) list + +(* Finds all uses of all global variables in a function *) +let find_uses_in_fun_all_glob funname file includeCallTmp = + let id_list = find_all_glob_vars file.globals in + List.flatten + @@ List.map + (fun x -> find_uses_in_fun "" x funname file includeCallTmp) + id_list + +let find_fundec globals funname = + let r = + BatList.find_opt + (function + | GFun (dec, _) -> String.compare dec.svar.vname funname = 0 + | _ -> false) + globals + in + match r with Some (GFun (dec, _)) -> Some dec | _ -> None + +(* Finds all uses of all variables in a function *) +let find_uses_in_fun_all funname file includeCallTmp = + let flat l = + List.flatten + @@ List.map (fun x -> find_uses_in_fun "" x funname file includeCallTmp) l + in + match find_fundec file.globals funname with + | None -> [] + | Some fundec -> + find_uses_in_fun_all_glob funname file includeCallTmp + @ flat (List.map (fun x -> x.vid) fundec.sformals) + @ flat (List.map (fun x -> x.vid) fundec.slocals) + +let find_var_in_globals varname varid list = + let r = + BatList.find_opt + (function + | GVar (info, _, _) -> is_equal_varname_varid info varname varid + | _ -> false) + list + in + match r with + | Some (GVar (info, _, loc)) -> + [ + ( info.vname, + loc, + String.trim (Pretty.sprint ~width:1 (d_type () info.vtype)), + info.vid ); + ] + | _ -> [] + +(* Find all uses of a variable in all functions *) +let find_uses varname varid file includeCallTmp = + let uses_in_all_fun = + List.flatten + @@ BatList.filter_map + (map_gfun (fun dec _ -> + Some + (find_uses_in_fun varname varid dec.svar.vname file + includeCallTmp))) + file.globals + in + find_var_in_globals varname varid file.globals @ uses_in_all_fun + +(* Finds all uses of global variables in all functions *) +let find_uses_all_glob file includeCallTmp = + let res = + List.flatten + @@ BatList.filter_map + (map_gfun (fun dec _ -> + Some + (find_uses_in_fun_all_glob dec.svar.vname file includeCallTmp))) + file.globals + in + List.flatten + (List.map + (fun x -> find_var_in_globals "" x file.globals) + (find_all_glob_vars file.globals)) + @ res + +(* Finds uses of all variables in all functions *) +let find_uses_all file includeCallTmp = + let res = + List.flatten + @@ BatList.filter_map + (map_gfun (fun dec _ -> + Some (find_uses_in_fun_all dec.svar.vname file includeCallTmp))) + file.globals + in + List.flatten + (List.map + (fun x -> find_var_in_globals "" x file.globals) + (find_all_glob_vars file.globals)) + @ res + +let rec cond_search_uses_stmt_list list varname varid includeCallTmp = + match list with + | x :: xs -> + ( match x.skind with + | If (exp, b1, b2, loc) -> + search_expression exp varname loc varid includeCallTmp + @ cond_search_uses_stmt_list (b1.bstmts @ b2.bstmts) varname varid + includeCallTmp + | Switch (exp, block, _, loc) -> + search_expression exp varname loc varid includeCallTmp + @ cond_search_uses_stmt_list block.bstmts varname varid includeCallTmp + | Loop (block, _, None, None) -> + cond_search_uses_stmt_list block.bstmts varname varid includeCallTmp + | Loop (block, _, None, Some s1) -> + cond_search_uses_stmt_list (s1 :: block.bstmts) varname varid + includeCallTmp + | Loop (block, _, Some s2, None) -> + cond_search_uses_stmt_list (s2 :: block.bstmts) varname varid + includeCallTmp + | Loop (block, _, Some s2, Some s1) -> + cond_search_uses_stmt_list (s2 :: s1 :: block.bstmts) varname varid + includeCallTmp + | Block block -> + cond_search_uses_stmt_list block.bstmts varname varid includeCallTmp + | TryFinally (b1, b2, _) -> + cond_search_uses_stmt_list (b1.bstmts @ b2.bstmts) varname varid + includeCallTmp + | TryExcept (b1, _, b2, _) -> + cond_search_uses_stmt_list (b1.bstmts @ b2.bstmts) varname varid + includeCallTmp + | _ -> [] ) + @ cond_search_uses_stmt_list xs varname varid includeCallTmp + | [] -> [] + +(* Finds all uses of a variable in conditions of a function *) +let find_uses_in_cond_in_fun varname varid funname file includeCallTmp = + match find_fundec file.globals funname with + | None -> [] + | Some fundec -> + if varid != -1 then + cond_search_uses_stmt_list fundec.sbody.bstmts varname varid + includeCallTmp + else + List.flatten + @@ List.map + (fun x -> + cond_search_uses_stmt_list fundec.sbody.bstmts x (-1) + includeCallTmp) + (get_all_alphaconverted_in_fun varname funname file) + +(* Finds all uses of a variable in conditions in all functions *) +let find_uses_in_cond varname varid file includeCallTmp = + let rec iter_functions list = + match list with + | GFun (dec, _) :: xs -> + find_uses_in_cond_in_fun varname varid dec.svar.vname file + includeCallTmp + @ iter_functions xs + | _ :: xs -> iter_functions xs + | [] -> [] + in + iter_functions file.globals + +(* Finds all uses of global variables in conditions in all functions *) +let find_uses_in_cond_all_glob file includeCallTmp = + let id_list = find_all_glob_vars file.globals in + List.flatten + @@ List.map (fun x -> find_uses_in_cond "" x file includeCallTmp) id_list + +(* Finds all uses of global variables in conditions in a function *) +let find_uses_in_cond_in_fun_all_glob funname file includeCallTmp = + let id_list = find_all_glob_vars file.globals in + List.flatten + @@ List.map + (fun x -> find_uses_in_cond_in_fun "" x funname file includeCallTmp) + id_list + +(* Finds all uses of variables in conditions in a function *) +let find_uses_in_cond_in_fun_all funname file includeCallTmp = + let get_formals_locals dec = dec.sformals @ dec.slocals in + let fundec_opt = find_fundec file.globals funname in + match fundec_opt with + | None -> [] + | Some fundec -> + find_uses_in_cond_in_fun_all_glob funname file includeCallTmp + @ List.flatten + @@ List.map + (fun x -> + find_uses_in_cond_in_fun x.vname (-1) funname file includeCallTmp) + (get_formals_locals fundec) + +(* Finds all uses of variables in conditions in all functions *) +let find_uses_in_cond_all file includeCallTmp = + List.flatten + @@ BatList.filter_map + (map_gfun (fun dec _ -> + Some + (find_uses_in_cond_in_fun_all dec.svar.vname file includeCallTmp))) + file.globals + +let rec remove_result list res = + match list with + | x :: xs -> + if x = res then remove_result xs res else x :: remove_result xs res + | [] -> [] + +(* Finds all uses of a variable in non-conditions *) +let find_uses_in_noncond varname varid file includeCallTmp = + let no_struc_result = find_uses varname varid file includeCallTmp in + let cond_result = find_uses_in_cond varname varid file includeCallTmp in + List.filter (fun x -> not (List.mem x cond_result)) no_struc_result + +(* Finds all uses of global variables in non-conditions *) +let find_uses_in_noncond_all_glob file includeCallTmp = + let id_list = find_all_glob_vars file.globals in + List.flatten + @@ List.map (fun x -> find_uses_in_noncond "" x file includeCallTmp) id_list + +(* Finds all uses of variables in non-conditions *) +let find_uses_in_noncond_all file includeCallTmp = + let no_struc_result = find_uses_all file includeCallTmp in + let cond_result = find_uses_in_cond_all file includeCallTmp in + List.filter (fun x -> not (List.mem x cond_result)) no_struc_result + +(* Finds the declaration of a variable in a function *) +let find_decl_in_fun varname varid funname file = + let get_formals_locals dec = dec.sformals @ dec.slocals in + let iter_list_name list name = + BatList.filter_map + (fun x -> + if String.compare x.vname name = 0 && not (is_temporary x.vid) then + Some + ( x.vname, + x.vdecl, + String.trim (Pretty.sprint ~width:1 (d_type () x.vtype)), + x.vid ) + else None) + list + in + let iter_namelist name_list varinfo_list = + List.flatten @@ List.map (fun x -> iter_list_name varinfo_list x) name_list + in + match find_fundec file.globals funname with + | None -> [] + | Some fundec -> + if varid != -1 then + BatList.filter_map + (fun x -> + if x.vid = varid then + Some + ( x.vname, + x.vdecl, + String.trim (Pretty.sprint ~width:1 (d_type () x.vtype)), + x.vid ) + else None) + (get_formals_locals fundec) + else + iter_namelist + (get_all_alphaconverted_in_fun varname funname file) + (get_formals_locals fundec) + +(* Finds all declarations in a function *) +let find_decl_in_fun_all funname file = + match find_fundec file.globals funname with + | None -> [] + | Some fundec -> + List.map + (fun x -> + ( x.vname, + x.vdecl, + String.trim (Pretty.sprint ~width:1 (d_type () x.vtype)), + x.vid )) + (fundec.sformals @ fundec.slocals) + +(* Finds all global variable declarations *) +let find_decl_all_glob file = + BatList.filter_map + (map_gvar (fun info _ loc -> + Some + ( info.vname, + loc, + String.trim (Pretty.sprint ~width:1 (d_type () info.vtype)), + info.vid ))) + file.globals + +(* Finds the declarations of a variable globally and in all functions *) +let find_decl varname varid file = + let rec iter_global_decls result = + match result with + | (name, loc, typ, id) :: xs -> + if String.compare varname name = 0 || id = varid then + [ (name, loc, typ, id) ] + else iter_global_decls xs + | [] -> [] + in + let rec iter_functions globals = + match globals with + | GFun (dec, _) :: xs -> + find_decl_in_fun varname varid dec.svar.vname file @ iter_functions xs + | _ :: xs -> iter_functions xs + | [] -> [] + in + iter_global_decls (find_decl_all_glob file) @ iter_functions file.globals + +(* Finds all declaration globally and in all functions *) +let find_decl_all file = + let list = + List.flatten + @@ BatList.filter_map + (map_gfun (fun dec _ -> + Some (find_decl_in_fun_all dec.svar.vname file))) + file.globals + in + find_decl_all_glob file @ list + +class var_find_def_in_fun varname varid funname result : nopCilVisitor = + object + inherit nopCilVisitor + + method! vfunc fundec = + if String.compare fundec.svar.vname funname = 0 then DoChildren + else SkipChildren + + method! vinst instr = + match instr with + | Set ((Var info, _), _, loc) -> + if is_equal_varname_varid info varname varid then ( + result := + !result + @ [ + ( info.vname, + loc, + String.trim (Pretty.sprint ~width:1 (d_type () info.vtype)), + info.vid ); + ]; + SkipChildren ) + else SkipChildren + | _ -> SkipChildren + end + +(* Finds definitions of a variable in a function *) +let find_defs_in_fun varname varid funname file = + let result = ref [] in + let visitor = new var_find_def_in_fun varname varid funname result in + if varid != -1 then ( + visitCilFileSameGlobals visitor file; + !result ) + else + let list = get_all_alphaconverted_in_fun varname funname file in + List.iter + (fun x -> + visitCilFileSameGlobals + (new var_find_def_in_fun x (-1) funname result) + file) + list; + !result + +(* Finds definitions of all global variables in a function *) +let find_defs_in_fun_all_glob funname file = + List.flatten + @@ BatList.filter_map + (map_gvar (fun info _ _ -> + Some (find_defs_in_fun "" info.vid funname file))) + file.globals + +(* Finds definitions of all variables in a functions *) +let find_defs_in_fun_all funname file = + let fundec_opt = find_fundec file.globals funname in + let get_formals_locals dec = dec.sformals @ dec.slocals in + match fundec_opt with + | None -> [] + | Some fundec -> + find_defs_in_fun_all_glob funname file + @ List.flatten + @@ List.map + (fun x -> find_defs_in_fun "" x.vid funname file) + (get_formals_locals fundec) + +(* Finds definitions of a variable in all functions *) +let find_defs varname varid file = + let r = + List.flatten + @@ BatList.filter_map + (map_gfun (fun dec _ -> + Some (find_defs_in_fun varname varid dec.svar.vname file))) + file.globals + in + find_var_in_globals varname varid file.globals @ r + +(* Finds definitions of all global variables in all functions *) +let find_defs_all_glob file = + List.flatten + (List.map + (fun x -> find_var_in_globals "" x file.globals) + (find_all_glob_vars file.globals)) + @ List.flatten + @@ BatList.filter_map + (map_gfun (fun dec _ -> + Some (find_defs_in_fun_all_glob dec.svar.vname file))) + file.globals + +(* Finds definitions of all variables in all functions *) +let find_defs_all file = + List.flatten + (List.map + (fun x -> find_var_in_globals "" x file.globals) + (find_all_glob_vars file.globals)) + @ List.flatten + @@ BatList.filter_map + (map_gfun (fun dec _ -> Some (find_defs_in_fun_all dec.svar.vname file))) + file.globals diff --git a/src/ext/syntacticsearch/queryMapping.ml b/src/ext/syntacticsearch/queryMapping.ml new file mode 100644 index 000000000..69da500e5 --- /dev/null +++ b/src/ext/syntacticsearch/queryMapping.ml @@ -0,0 +1,513 @@ +open Cil +open CodeQuery + +(* Default output if the input-query is not supported *) +let loc_default = { line = -1; file = ""; byte = -1 } + +let rec delete_elem (name1, loc1, typ1, id1) list = + match list with + | (name2, loc2, typ2, id2) :: xs -> + if + String.compare name1 name2 = 0 + && loc1.line = loc2.line && loc1.byte = loc2.byte + && String.compare loc1.file loc2.file = 0 + && String.compare typ1 typ2 = 0 + && id1 = id2 + then delete_elem (name1, loc1, typ1, id1) xs + else (name2, loc2, typ2, id2) :: delete_elem (name1, loc1, typ1, id1) xs + | [] -> [] + +let rec delete_duplicates list tbl = + match list with + | x :: xs -> ( + let _ = try Hashtbl.find tbl x with Not_found -> Hashtbl.add tbl x 1; 1 in + x :: delete_duplicates xs tbl + ) + | [] -> [] + +let rec and_one_elem (name1, loc1, typ1, id1) list = + match list with + | (name2, loc2, typ2, id2) :: xs -> + if loc1.line = loc2.line then + [ (name1, loc1, typ1, id1); (name2, loc2, typ2, id2) ] + @ and_one_elem (name1, loc1, typ1, id1) xs + else and_one_elem (name1, loc1, typ1, id1) xs + | [] -> [] + +let rec and_two_lists list1 list2 = + match list1 with + | x :: xs -> and_one_elem x list2 @ and_two_lists xs list2 + | [] -> [] + +let rec and_several_lists list_of_lists = + match list_of_lists with + | x :: y :: xs -> and_several_lists (and_two_lists x y :: xs) + | [ x ] -> x + | [] -> [] + +(* Naming of functions: resolve_query_[kind]_[find]_[structure] *) + +(* Resolution of datatype-oriented queries *) +let resolve_query_datatype_uses_fun query cilfile funname = + match query.tar with + | Name_t name -> FuncDatatype.find_uses_in_fun name funname cilfile + | And_t list -> + and_several_lists + (List.map + (fun x -> FuncDatatype.find_uses_in_fun x funname cilfile) + list) + | Or_t list -> + List.flatten + (List.map + (fun x -> FuncDatatype.find_uses_in_fun x funname cilfile) + list) + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_datatype_uses_none query cilfile = + match query.tar with + | Name_t name -> FuncDatatype.find_uses name cilfile + | And_t list -> + and_several_lists + (List.map (fun x -> FuncDatatype.find_uses x cilfile) list) + | Or_t list -> + List.flatten (List.map (fun x -> FuncDatatype.find_uses x cilfile) list) + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_datatype_uses_cond query cilfile = + match query.tar with + | Name_t name -> FuncDatatype.find_uses_in_cond name cilfile + | And_t list -> + and_several_lists + (List.map (fun x -> FuncDatatype.find_uses_in_cond x cilfile) list) + | Or_t list -> + List.flatten + (List.map (fun x -> FuncDatatype.find_uses_in_cond x cilfile) list) + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_datatype_uses_noncond query cilfile = + match query.tar with + | Name_t name -> FuncDatatype.find_uses_in_noncond name cilfile + | And_t list -> + and_several_lists + (List.map (fun x -> FuncDatatype.find_uses_in_noncond x cilfile) list) + | Or_t list -> + List.flatten + (List.map (fun x -> FuncDatatype.find_uses_in_cond x cilfile) list) + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_datatype_uses query cilfile = + match query.str with + | Fun_s funname -> resolve_query_datatype_uses_fun query cilfile funname + | Cond_s -> resolve_query_datatype_uses_cond query cilfile + | NonCond_s -> resolve_query_datatype_uses_noncond query cilfile + | None_s -> resolve_query_datatype_uses_none query cilfile + +let resolve_query_datatype_defs_none query cilfile = + match query.tar with + | Name_t name -> FuncDatatype.find_def name cilfile + | Or_t list -> + List.flatten (List.map (fun x -> FuncDatatype.find_def x cilfile) list) + | All_t -> FuncDatatype.find_def_all cilfile + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_datatype_defs query cilfile = + match query.str with + | None_s -> resolve_query_datatype_defs_none query cilfile + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_datatype query cilfile = + match query.f with + | Uses_f -> resolve_query_datatype_uses query cilfile + | Defs_f -> resolve_query_datatype_defs query cilfile + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +(* Resolution of variable-oriented queries *) +let resolve_query_var_uses_fun query cilfile funname = + match query.tar with + | Name_t name -> FuncVar.find_uses_in_fun name (-1) funname cilfile false + | ID_t id -> FuncVar.find_uses_in_fun "" id funname cilfile false + | AllGlobVar_t -> FuncVar.find_uses_in_fun_all_glob funname cilfile false + | All_t -> FuncVar.find_uses_in_fun_all funname cilfile false + | And_t list -> + and_several_lists + (List.map + (fun x -> FuncVar.find_uses_in_fun x (-1) funname cilfile false) + list) + | Or_t list -> + List.flatten + (List.map + (fun x -> FuncVar.find_uses_in_fun x (-1) funname cilfile false) + list) + +let resolve_query_var_uses_none query cilfile = + match query.tar with + | Name_t name -> FuncVar.find_uses name (-1) cilfile false + | ID_t id -> FuncVar.find_uses "" id cilfile false + | AllGlobVar_t -> FuncVar.find_uses_all_glob cilfile false + | All_t -> FuncVar.find_uses_all cilfile false + | And_t list -> + and_several_lists + (List.map (fun x -> FuncVar.find_uses x (-1) cilfile false) list) + | Or_t list -> + List.flatten + (List.map (fun x -> FuncVar.find_uses x (-1) cilfile false) list) + +let resolve_query_var_uses_cond query cilfile = + match query.tar with + | Name_t name -> FuncVar.find_uses_in_cond name (-1) cilfile false + | ID_t id -> FuncVar.find_uses_in_cond "" id cilfile false + | AllGlobVar_t -> FuncVar.find_uses_in_cond_all_glob cilfile false + | All_t -> FuncVar.find_uses_in_cond_all cilfile false + | And_t list -> + and_several_lists + (List.map + (fun x -> FuncVar.find_uses_in_cond x (-1) cilfile false) + list) + | Or_t list -> + List.flatten + (List.map + (fun x -> FuncVar.find_uses_in_cond x (-1) cilfile false) + list) + +let resolve_query_var_uses_noncond query cilfile = + match query.tar with + | Name_t name -> FuncVar.find_uses_in_noncond name (-1) cilfile false + | ID_t id -> FuncVar.find_uses_in_noncond "" id cilfile false + | AllGlobVar_t -> FuncVar.find_uses_in_noncond_all_glob cilfile false + | All_t -> FuncVar.find_uses_in_noncond_all cilfile false + | And_t list -> + and_several_lists + (List.map + (fun x -> FuncVar.find_uses_in_noncond x (-1) cilfile false) + list) + | Or_t list -> + List.flatten + (List.map + (fun x -> FuncVar.find_uses_in_noncond x (-1) cilfile false) + list) + +let resolve_query_var_uses query cilfile = + match query.str with + | Fun_s funname -> resolve_query_var_uses_fun query cilfile funname + | Cond_s -> resolve_query_var_uses_cond query cilfile + | NonCond_s -> resolve_query_var_uses_noncond query cilfile + | None_s -> resolve_query_var_uses_none query cilfile + +let resolve_query_var_decl_fun query cilfile funname = + match query.tar with + | Name_t name -> FuncVar.find_decl_in_fun name (-1) funname cilfile + | ID_t id -> FuncVar.find_decl_in_fun "" id funname cilfile + | All_t -> FuncVar.find_decl_in_fun_all funname cilfile + | Or_t list -> + List.flatten + (List.map + (fun x -> FuncVar.find_decl_in_fun x (-1) funname cilfile) + list) + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_var_decl_none query cilfile = + match query.tar with + | AllGlobVar_t -> FuncVar.find_decl_all_glob cilfile + | Name_t name -> FuncVar.find_decl name (-1) cilfile + | ID_t id -> FuncVar.find_decl "" id cilfile + | All_t -> FuncVar.find_decl_all cilfile + | Or_t list -> + List.flatten (List.map (fun x -> FuncVar.find_decl x (-1) cilfile) list) + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_var_decl query cilfile = + match query.str with + | Fun_s funname -> resolve_query_var_decl_fun query cilfile funname + | None_s -> resolve_query_var_decl_none query cilfile + | NonCond_s -> resolve_query_var_decl_none query cilfile + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_var_defs_fun query cilfile funname = + match query.tar with + | Name_t name -> FuncVar.find_defs_in_fun name (-1) funname cilfile + | ID_t id -> FuncVar.find_defs_in_fun "" id funname cilfile + | AllGlobVar_t -> FuncVar.find_defs_in_fun_all_glob funname cilfile + | All_t -> FuncVar.find_defs_in_fun_all funname cilfile + | Or_t list -> + List.flatten + (List.map + (fun x -> FuncVar.find_defs_in_fun x (-1) funname cilfile) + list) + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_var_defs_none query cilfile = + match query.tar with + | Name_t name -> FuncVar.find_defs name (-1) cilfile + | ID_t id -> FuncVar.find_defs "" id cilfile + | AllGlobVar_t -> FuncVar.find_defs_all_glob cilfile + | All_t -> FuncVar.find_defs_all cilfile + | Or_t list -> + List.flatten (List.map (fun x -> FuncVar.find_defs x (-1) cilfile) list) + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_var_defs query cilfile = + match query.str with + | Fun_s funname -> resolve_query_var_defs_fun query cilfile funname + | None_s -> resolve_query_var_defs_none query cilfile + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_var query cilfile = + match query.f with + | Uses_f -> resolve_query_var_uses query cilfile + | Decl_f -> resolve_query_var_decl query cilfile + | Defs_f -> resolve_query_var_defs query cilfile + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_fun_return_none query cilfile = + match query.tar with + | Name_t name -> FuncFunction.find_returns name (-1) cilfile + | ID_t id -> FuncFunction.find_returns "" id cilfile + | All_t -> FuncFunction.find_returns_all cilfile + | Or_t list -> + List.flatten + (List.map (fun x -> FuncFunction.find_returns x (-1) cilfile) list) + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_fun_return query cilfile = + match query.str with + | None_s -> resolve_query_fun_return_none query cilfile + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_fun_defs_none query cilfile = + match query.tar with + | Name_t name -> FuncFunction.find_def name (-1) cilfile + | ID_t id -> FuncFunction.find_def "" id cilfile + | All_t -> FuncFunction.find_def_all cilfile + | Or_t list -> + List.flatten + (List.map (fun x -> FuncFunction.find_def x (-1) cilfile) list) + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_fun_defs query cilfile = + match query.str with + | None_s -> resolve_query_fun_defs_none query cilfile + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_fun_uses_none query cilfile = + match query.tar with + | Name_t name -> FuncFunction.find_uses name (-1) cilfile + | ID_t id -> FuncFunction.find_uses "" id cilfile + | All_t -> FuncFunction.find_uses_all cilfile + | And_t list -> + and_several_lists + (List.map (fun x -> FuncFunction.find_uses x (-1) cilfile) list) + | Or_t list -> + List.flatten + (List.map (fun x -> FuncFunction.find_uses x (-1) cilfile) list) + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_fun_uses_fun query cilfile funname = + match query.tar with + | Name_t name -> FuncFunction.find_uses_in_fun name (-1) funname cilfile + | ID_t id -> FuncFunction.find_uses_in_fun "" id funname cilfile + | All_t -> FuncFunction.find_uses_in_fun_all funname cilfile + | And_t list -> + and_several_lists + (List.map + (fun x -> FuncFunction.find_uses_in_fun x (-1) funname cilfile) + list) + | Or_t list -> + List.flatten + (List.map + (fun x -> FuncFunction.find_uses_in_fun x (-1) funname cilfile) + list) + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_fun_uses_cond query cilfile = + match query.tar with + | Name_t name -> FuncFunction.find_uses_cond name (-1) cilfile + | ID_t id -> FuncFunction.find_uses_cond "" id cilfile + | All_t -> FuncFunction.find_uses_all cilfile + | And_t list -> + and_several_lists + (List.map (fun x -> FuncFunction.find_uses_cond x (-1) cilfile) list) + | Or_t list -> + List.flatten + (List.map (fun x -> FuncFunction.find_uses_cond x (-1) cilfile) list) + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_fun_uses_noncond query cilfile = + match query.tar with + | Name_t name -> FuncFunction.find_uses_noncond name (-1) cilfile + | ID_t id -> FuncFunction.find_uses_noncond "" id cilfile + | All_t -> FuncFunction.find_uses_noncond_all cilfile + | And_t list -> + and_several_lists + (List.map (fun x -> FuncFunction.find_uses_noncond x (-1) cilfile) list) + | Or_t list -> + List.flatten + (List.map (fun x -> FuncFunction.find_uses_noncond x (-1) cilfile) list) + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_fun_uses query cilfile = + match query.str with + | None_s -> resolve_query_fun_uses_none query cilfile + | Fun_s funname -> resolve_query_fun_uses_fun query cilfile funname + | Cond_s -> resolve_query_fun_uses_cond query cilfile + | NonCond_s -> resolve_query_fun_uses_noncond query cilfile + +let resolve_query_fun_usesvar_fun query cilfile varname strucfunname = + match query.tar with + | Name_t funname -> + FuncFunction.find_usesvar_in_fun funname (-1) strucfunname varname cilfile + | ID_t id -> + FuncFunction.find_usesvar_in_fun "" id strucfunname varname cilfile + | All_t -> FuncFunction.find_usesvar_in_fun_all strucfunname varname cilfile + | And_t list -> + and_several_lists + (List.map + (fun x -> + FuncFunction.find_usesvar_in_fun x (-1) strucfunname varname + cilfile) + list) + | Or_t list -> + List.flatten + (List.map + (fun x -> + FuncFunction.find_usesvar_in_fun x (-1) strucfunname varname + cilfile) + list) + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_fun_usesvar_none query cilfile varname = + match query.tar with + | Name_t funname -> FuncFunction.find_usesvar funname (-1) varname cilfile + | ID_t id -> FuncFunction.find_usesvar "" id varname cilfile + | All_t -> FuncFunction.find_usesvar_all varname cilfile + | And_t list -> + and_several_lists + (List.map + (fun x -> FuncFunction.find_usesvar x (-1) varname cilfile) + list) + | Or_t list -> + List.flatten + (List.map + (fun x -> FuncFunction.find_usesvar x (-1) varname cilfile) + list) + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_fun_usesvar_cond query cilfile varname = + match query.tar with + | Name_t funname -> + FuncFunction.find_usesvar_cond funname (-1) varname cilfile + | ID_t id -> FuncFunction.find_usesvar_cond "" id varname cilfile + | All_t -> FuncFunction.find_usesvar_cond_all varname cilfile + | And_t list -> + and_several_lists + (List.map + (fun x -> FuncFunction.find_usesvar_cond x (-1) varname cilfile) + list) + | Or_t list -> + List.flatten + (List.map + (fun x -> FuncFunction.find_usesvar_cond x (-1) varname cilfile) + list) + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_fun_usesvar_noncond query cilfile varname = + match query.tar with + | Name_t funname -> + FuncFunction.find_usesvar_noncond funname (-1) varname cilfile + | ID_t id -> FuncFunction.find_usesvar_noncond "" id varname cilfile + | All_t -> FuncFunction.find_usesvar_noncond_all varname cilfile + | And_t list -> + and_several_lists + (List.map + (fun x -> FuncFunction.find_usesvar_noncond x (-1) varname cilfile) + list) + | Or_t list -> + List.flatten + (List.map + (fun x -> FuncFunction.find_usesvar_noncond x (-1) varname cilfile) + list) + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +let resolve_query_fun_usesvar query cilfile varname = + match query.str with + | Fun_s strucfunname -> + resolve_query_fun_usesvar_fun query cilfile varname strucfunname + | None_s -> resolve_query_fun_usesvar_none query cilfile varname + | Cond_s -> resolve_query_fun_usesvar_cond query cilfile varname + | NonCond_s -> resolve_query_fun_usesvar_noncond query cilfile varname + +let resolve_query_fun query cilfile = + match query.f with + | Returns_f -> resolve_query_fun_return query cilfile + | Defs_f -> resolve_query_fun_defs query cilfile + | Uses_f -> resolve_query_fun_uses query cilfile + | UsesWithVar_f varname -> resolve_query_fun_usesvar query cilfile varname + | _ -> + Printf.printf "Not supported.\n"; + [ ("", loc_default, "", -1) ] + +(* Main mapping function *) +let map_query query cilfile = + let tmp = + if query.lim != None_c then + Printf.printf + "Constraint is not supported yet. This parameter will be ignored.\n" + else (); + match query.k with + | Datatype_k -> resolve_query_datatype query cilfile + | Var_k -> resolve_query_var query cilfile + | Fun_k -> resolve_query_fun query cilfile + in + let hashtbl = Hashtbl.create (List.length tmp) in + delete_duplicates tmp hashtbl diff --git a/src/ext/syntacticsearch/resultPrinter.ml b/src/ext/syntacticsearch/resultPrinter.ml new file mode 100644 index 000000000..a98501e0b --- /dev/null +++ b/src/ext/syntacticsearch/resultPrinter.ml @@ -0,0 +1,95 @@ +open CodeQuery +open Cil +open Feature + +let rec contains list elem = + match list with + | x :: xs -> if elem = x then true else contains xs elem + | [] -> false + +let rec get_max_lengths result_list name_l line_l file_l byte_l typ_l id_l = + match result_list with + | (name, loc, typ, id) :: xs -> + get_max_lengths xs + (max name_l (String.length name)) + (max line_l (String.length (string_of_int loc.line))) + (max file_l (String.length loc.file)) + (max byte_l (String.length (string_of_int loc.byte))) + (max typ_l (String.length typ)) + (max id_l (String.length (string_of_int id))) + | [] -> (name_l, line_l, file_l, byte_l, typ_l, id_l) + +let print_result result query = + let print_name = contains query.sel Name_sel in + let print_loc = contains query.sel Location_sel in + let print_typ = contains query.sel Type_sel in + let print_id = contains query.sel ID_sel in + let max_lengths = get_max_lengths result 0 0 0 0 0 0 in + let name_l = match max_lengths with x, _, _, _, _, _ -> x in + let line_l = match max_lengths with _, x, _, _, _, _ -> x in + let file_l = match max_lengths with _, _, x, _, _, _ -> x in + let byte_l = match max_lengths with _, _, _, x, _, _ -> x in + let typ_l = match max_lengths with _, _, _, _, x, _ -> x in + let id_l = match max_lengths with _, _, _, _, _, x -> x in + let rec add_whitespace num = + if num <= 0 then "" else " " ^ add_whitespace (num - 1) + in + let create_name name = + if print_name then + "name: " ^ name ^ add_whitespace (name_l - String.length name) ^ ", " + else "" + in + let create_location loc = + if print_loc then + "line: " ^ string_of_int loc.line + ^ add_whitespace (line_l - String.length (string_of_int loc.line)) + ^ ", file: " ^ loc.file + ^ add_whitespace (file_l - String.length loc.file) + ^ ", byte: " ^ string_of_int loc.byte + ^ add_whitespace (byte_l - String.length (string_of_int loc.byte)) + ^ ", " + else "" + in + let create_type typ = + if print_typ then + "type: " ^ typ ^ add_whitespace (typ_l - String.length typ) ^ ", " + else "" + in + let create_id id = + if print_id then + "id: " ^ string_of_int id + ^ add_whitespace (id_l - String.length (string_of_int id)) + ^ "" + else "" + in + let create_entry (name, loc, typ, id) = + create_name name ^ create_location loc ^ create_type typ ^ create_id id + ^ "\n" + in + let rec create_printout list = + match list with x :: xs -> create_entry x ^ create_printout xs | [] -> "" + in + if print_name || print_loc || print_typ || print_id then + create_printout result + else "" + +let query_file_name = ref "" + +let feature = { + fd_name = "syntacticsearch"; + fd_enabled = false; + fd_description = "Syntactic Search in CIL programs"; + fd_extraopt = [ + ("--syntacticsearch_query_file", + Arg.Set_string query_file_name, + " Name of the file containing the syntactic search query") + ]; + fd_doit = (fun f -> + Printexc.record_backtrace true; + let q = CodeQuery.parse_json_file !query_file_name in + let results = QueryMapping.map_query q f in + print_endline (print_result results q)); + fd_post_check = false +} + +let () = Feature.register feature diff --git a/src/ext/zrapp/META b/src/ext/zrapp/META index cd1bfa9b5..9d02bff76 100644 --- a/src/ext/zrapp/META +++ b/src/ext/zrapp/META @@ -1,2 +1,2 @@ -requires = "cil.liveness" +requires = "goblint-cil.liveness" description = "pretty printing with checks for name conflicts and temp variable elimination" diff --git a/src/ext/zrapp/availexps.ml b/src/ext/zrapp/availexps.ml index ed8363ccd..bf9371909 100644 --- a/src/ext/zrapp/availexps.ml +++ b/src/ext/zrapp/availexps.ml @@ -14,11 +14,13 @@ module IH = Inthash module U = Util module S = Stats +exception Unimplemented of string + let debug = ref false let doTime = ref false -let time s f a = +let time s f a = if !doTime then S.time s f a else f a @@ -56,9 +58,9 @@ let eh_equals eh1 eh2 = with Not_found -> false) eh1 true -let eh_pretty () eh = line ++ seq line (fun (vid,e) -> +let eh_pretty () eh = line ++ seq ~sep:line ~doit:(fun (vid,e) -> text "AE:vid:" ++ num vid ++ text ": " ++ - (d_exp () e)) (IH.tolist eh) + (d_exp () e)) ~elements:(IH.tolist eh) (* the result must be the intersection of eh1 and eh2 *) (* exp IH.t -> exp IH.t -> exp IH.t *) @@ -86,7 +88,7 @@ let eh_combine eh1 eh2 = class memReadOrAddrOfFinderClass br = object(self) inherit nopCilVisitor - method vexpr e = match e with + method! vexpr e = match e with | Lval(Mem _, _) -> begin br := true; SkipChildren @@ -96,7 +98,7 @@ class memReadOrAddrOfFinderClass br = object(self) SkipChildren | _ -> DoChildren - method vvrbl vi = + method! vvrbl vi = if vi.vaddrof || vi.vglob then (br := true; SkipChildren) @@ -111,7 +113,7 @@ let exp_has_mem_read e = ignore(visitCilExpr vis e); !br - + let eh_kill_mem eh = IH.iter (fun vid e -> if exp_has_mem_read e @@ -121,8 +123,8 @@ let eh_kill_mem eh = (* need to kill exps containing a particular vi sometimes *) class viFinderClass vi br = object(self) inherit nopCilVisitor - - method vvrbl vi' = + + method! vvrbl vi' = if vi.vid = vi'.vid then (br := true; SkipChildren) else DoChildren @@ -145,7 +147,7 @@ let eh_kill_vi eh vi = class lvalFinderClass lv br = object(self) inherit nopCilVisitor - method vlval l = + method! vlval l = if compareLval l lv then (br := true; SkipChildren) else DoChildren @@ -168,8 +170,8 @@ let eh_kill_lval eh lv = class volatileFinderClass br = object(self) inherit nopCilVisitor - method vexpr e = - if (hasAttribute "volatile" (typeAttrs (typeOf e))) + method! vexpr e = + if (hasAttribute "volatile" (typeAttrs (typeOf e))) then (br := true; SkipChildren) else DoChildren end @@ -200,7 +202,7 @@ let eh_kill_addrof_or_global eh = end with Not_found -> ()) eh -let eh_handle_inst i eh = +let eh_handle_inst i eh = if (!ignore_inst) i then eh else match i with (* if a pointer write, kill things with read in them. @@ -208,11 +210,11 @@ let eh_handle_inst i eh = and globals. otherwise kill things with lv in them and add e *) Set(lv,e,_) -> (match lv with - (Mem _, _) -> - (eh_kill_mem eh; + (Mem _, _) -> + (eh_kill_mem eh; eh_kill_addrof_or_global eh; eh) - | (Var vi, NoOffset) when not (exp_is_volatile e) -> + | (Var vi, NoOffset) when not (exp_is_volatile e) -> (match e with Lval(Var vi', NoOffset) -> (* ignore x = x *) if vi'.vid = vi.vid then eh else @@ -246,6 +248,8 @@ let eh_handle_inst i eh = (UD.VS.iter (fun vi -> eh_kill_vi eh vi) d; eh) + | VarDecl _ -> raise (Unimplemented "VarDecl") (* VarDecl instruction is not supported for availexps, to make availexps work for programs without VLA *) + (* make sure to set alwaysGenerateVarDecl in cabs2cil.ml to false. To support VLA, implement this. *) module AvailableExps = struct @@ -269,7 +273,7 @@ module AvailableExps = if time "eh_equals" (eh_equals old) eh then None else Some(time "eh_combine" (eh_combine old) eh) - let doInstr i eh = + let doInstr i eh = let action = eh_handle_inst i in DF.Post(action) @@ -289,9 +293,9 @@ module AE = DF.ForwardsDataFlow(AvailableExps) class varHashMakerClass = object(self) inherit nopCilVisitor - method vvrbl vi = + method! vvrbl vi = (if not(IH.mem varHash vi.vid) - then + then (if !debug && vi.vglob then ignore(E.log "%s is global\n" vi.vname); if !debug && not(vi.vglob) then ignore(E.log "%s is not global\n" vi.vname); IH.add varHash vi.vid vi)); @@ -317,7 +321,7 @@ let computeAEs fd = IH.clear AvailableExps.stmtStartData; IH.add AvailableExps.stmtStartData first_stm.sid (IH.create 4); time "compute" AE.compute [first_stm] - with Failure "hd" -> if !debug then ignore(E.log "fn w/ no stmts?\n") + with Failure _ -> if !debug then ignore(E.log "fn w/ no stmts?\n") | Not_found -> if !debug then ignore(E.log "no data for first_stm?\n") @@ -351,7 +355,7 @@ class aeVisitorClass = object(self) val mutable cur_ae_dat = None - method vstmt stm = + method! vstmt stm = sid <- stm.sid; match getAEs sid with None -> @@ -369,7 +373,7 @@ class aeVisitorClass = object(self) cur_ae_dat <- None; DoChildren - method vinst i = + method! vinst i = if !debug then ignore(E.log "aeVist: before %a, ae_dat_lst is %d long\n" d_instr i (List.length ae_dat_lst)); try @@ -378,7 +382,7 @@ class aeVisitorClass = object(self) ae_dat_lst <- List.tl ae_dat_lst; if !debug then ignore(E.log "aeVisit: data is %a\n" eh_pretty data); DoChildren - with Failure "hd" -> + with Failure _ -> if !debug then ignore(E.log "aeVis: il ae_dat_lst mismatch\n"); DoChildren diff --git a/src/ext/zrapp/availexpslv.ml b/src/ext/zrapp/availexpslv.ml index d107be554..58ec91644 100644 --- a/src/ext/zrapp/availexpslv.ml +++ b/src/ext/zrapp/availexpslv.ml @@ -15,11 +15,13 @@ module H = Hashtbl module U = Util module S = Stats +exception Unimplemented of string + let debug = ref false let doTime = ref false -let time s f a = +let time s f a = if !doTime then S.time s f a else f a @@ -44,7 +46,7 @@ let registerIgnoreCall (f : instr -> bool) : unit = ignore_call := (fun i -> (f i) || (f' i)) -module LvExpHash = +module LvExpHash = H.Make(struct type t = lval let equal lv1 lv2 = compareLval lv1 lv2 @@ -95,7 +97,7 @@ let lvh_combine lvh1 lvh2 = class memReadOrAddrOfFinderClass br = object(self) inherit nopCilVisitor - method vexpr e = match e with + method! vexpr e = match e with | AddrOf(Mem _, _) | StartOf(Mem _, _) | Lval(Mem _, _) -> begin @@ -107,7 +109,7 @@ class memReadOrAddrOfFinderClass br = object(self) SkipChildren | _ -> DoChildren - method vvrbl vi = + method! vvrbl vi = if vi.vaddrof || vi.vglob then (br := true; SkipChildren) @@ -147,8 +149,8 @@ let lvh_kill_mem lvh = (* need to kill exps containing a particular vi sometimes *) class viFinderClass vi br = object(self) inherit nopCilVisitor - - method vvrbl vi' = + + method! vvrbl vi' = if vi.vid = vi'.vid then (br := true; SkipChildren) else DoChildren @@ -183,7 +185,7 @@ let lvh_kill_vi lvh vi = class lvalFinderClass lv br = object(self) inherit nopCilVisitor - method vlval l = + method! vlval l = if compareLval l lv then (br := true; SkipChildren) else DoChildren @@ -215,8 +217,8 @@ let lvh_kill_lval lvh lv = class volatileFinderClass br = object(self) inherit nopCilVisitor - method vexpr e = - if (hasAttribute "volatile" (typeAttrs (typeOf e))) + method! vexpr e = + if (hasAttribute "volatile" (typeAttrs (typeOf e))) then (br := true; SkipChildren) else DoChildren end @@ -232,7 +234,7 @@ let exp_is_volatile e : bool = class addrOfOrGlobalFinderClass br = object(self) inherit nopCilVisitor - method vvrbl vi = + method! vvrbl vi = if vi.vaddrof || vi.vglob then (br := true; SkipChildren) else DoChildren @@ -258,10 +260,10 @@ let lvh_kill_addrof_or_global lvh = lvh -let lvh_handle_inst i lvh = +let lvh_handle_inst i lvh = if (!ignore_inst) i then lvh else match i with - Set(lv,e,_) -> begin + Set(lv,e,_) -> begin match lv with | (Mem _, _) -> begin LvExpHash.replace lvh lv e; @@ -271,7 +273,7 @@ let lvh_handle_inst i lvh = end | _ when not (exp_is_volatile e) -> begin (* ignore x = x *) - if compareExpStripCasts (Lval lv) e then lvh + if compareExpStripCasts (Lval lv) e then lvh else begin LvExpHash.replace lvh lv e; lvh_kill_lval lvh lv; @@ -309,6 +311,8 @@ let lvh_handle_inst i lvh = lvh_kill_vi lvh vi) d; lvh end + | VarDecl _ -> raise (Unimplemented "VarDecl") (* VarDecl instruction is not supported for availexpslv, to make availexpslv work for programs without VLA *) + (* make sure to set alwaysGenerateVarDecl in cabs2cil.ml to false. To support VLA, implement this. *) module AvailableExps = struct @@ -332,7 +336,7 @@ module AvailableExps = if time "lvh_equals" (lvh_equals old) lvh then None else Some(time "lvh_combine" (lvh_combine old) lvh) - let doInstr i lvh = + let doInstr i lvh = let action = lvh_handle_inst i in DF.Post(action) @@ -359,7 +363,7 @@ let computeAEs fd = IH.clear AvailableExps.stmtStartData; IH.add AvailableExps.stmtStartData first_stm.sid (LvExpHash.create 4); time "compute" AE.compute [first_stm] - with Failure "hd" -> if !debug then ignore(E.log "fn w/ no stmts?\n") + with Failure _ -> if !debug then ignore(E.log "fn w/ no stmts?\n") | Not_found -> if !debug then ignore(E.log "no data for first_stm?\n") @@ -394,7 +398,7 @@ class aeVisitorClass = object(self) val mutable cur_ae_dat = None - method vstmt stm = + method! vstmt stm = sid <- stm.sid; match getAEs sid with None -> @@ -412,7 +416,7 @@ class aeVisitorClass = object(self) cur_ae_dat <- None; DoChildren - method vinst i = + method! vinst i = if !debug then ignore(E.log "aeVist: before %a, ae_dat_lst is %d long\n" d_instr i (List.length ae_dat_lst)); try @@ -421,7 +425,7 @@ class aeVisitorClass = object(self) ae_dat_lst <- List.tl ae_dat_lst; if !debug then ignore(E.log "aeVisit: data is %a\n" lvh_pretty data); DoChildren - with Failure "hd" -> + with Failure _ -> if !debug then ignore(E.log "aeVis: il ae_dat_lst mismatch\n"); DoChildren diff --git a/src/ext/zrapp/deadcodeelim.ml b/src/ext/zrapp/deadcodeelim.ml index 863a6a55c..f8f4cc62e 100644 --- a/src/ext/zrapp/deadcodeelim.ml +++ b/src/ext/zrapp/deadcodeelim.ml @@ -2,8 +2,6 @@ used *) open Cil -open Cilint -open Pretty open Expcompare module E = Errormsg @@ -32,7 +30,7 @@ let time s f a = * knows of functions returning a result that have * no side effects. If the result is not used, then * the call will be eliminated. *) -let callHasNoSideEffects : (instr -> bool) ref = +let callHasNoSideEffects : (instr -> bool) ref = ref (fun _ -> false) @@ -58,19 +56,19 @@ class usedDefsCollectorClass = object(self) method add_defids iosh e u = UD.VS.iter (fun vi -> - if IH.mem iosh vi.vid then + if IH.mem iosh vi.vid then let ios = IH.find iosh vi.vid in - if !debug then ignore(E.log "DCE: IOS size for vname=%s at stmt=%d: %d\n" + if !debug then ignore(E.log "DCE: IOS size for vname=%s at stmt=%d: %d\n" vi.vname sid (RD.IOS.cardinal ios)); RD.IOS.iter (function - Some(i) -> + Some(i) -> if !debug then ignore(E.log "DCE: def %d used: %a\n" i d_exp e); usedDefsSet := IS.add i (!usedDefsSet) | None -> ()) ios else if !debug then ignore(E.log "DCE: vid %d:%s not in stm:%d iosh at %a\n" vi.vid vi.vname sid d_plainexp e)) u - method vexpr e = + method! vexpr e = let u = UD.computeUseExp e in match self#get_cur_iosh() with Some(iosh) -> self#add_defids iosh e u; DoChildren @@ -78,7 +76,7 @@ class usedDefsCollectorClass = object(self) if !debug then ignore(E.log "DCE: use but no rd data: %a\n" d_plainexp e); DoChildren - method vstmt s = + method! vstmt s = ignore(super#vstmt s); match s.skind with | Instr _ -> DoChildren @@ -102,7 +100,7 @@ class usedDefsCollectorClass = object(self) | None -> DoChildren end - method vinst i = + method! vinst i = let handle_inst iosh i = match i with | Asm(_,_,slvl,_,_,_) -> List.iter (fun (_,s,lv) -> match lv with (Var v, off) -> @@ -121,7 +119,7 @@ class usedDefsCollectorClass = object(self) let set = IH.find sidUseSetHash i in IH.replace sidUseSetHash i (IS.add sid set) with Not_found -> - IH.add sidUseSetHash i (IS.singleton sid) + IH.add sidUseSetHash i (IS.singleton sid) end | None -> ()) ios) u) (ce::el) | Set((Mem _,_) as lh, rhs,l) -> @@ -136,14 +134,14 @@ class usedDefsCollectorClass = object(self) let set = IH.find sidUseSetHash i in IH.replace sidUseSetHash i (IS.add sid set) with Not_found -> - IH.add sidUseSetHash i (IS.singleton sid) + IH.add sidUseSetHash i (IS.singleton sid) end | None -> ()) ios) u) ([Lval(lh);rhs]) | _ -> () in ignore(super#vinst i); match cur_rd_dat with - | None -> begin + | None -> begin if !debug then ignore(E.log "DCE: instr with no cur_rd_dat\n"); (* handle_inst *) DoChildren @@ -158,7 +156,7 @@ class usedDefsCollectorClass = object(self) let ios = IH.find iosh vi.vid in RD.IOS.iter (function | Some i -> begin (* add n + s to set for i *) - try + try let set = IH.find defUseSetHash i in IH.replace defUseSetHash i (IS.add (n+s) set) with Not_found -> @@ -177,24 +175,24 @@ class usedDefsCollectorClass = object(self) end (*************************************************** - * Also need to find reads from volatiles - * uses two functions I've put in ciltools which - * are basically what Zach wrote, except one is for + * Also need to find reads from volatiles + * uses two functions I've put in ciltools which + * are basically what Zach wrote, except one is for * types and one is for vars. Another difference is - * they filter out pointers to volatiles. This - * handles DMA + * they filter out pointers to volatiles. This + * handles DMA ***************************************************) class hasVolatile flag = object (self) - inherit nopCilVisitor - method vlval l = + inherit nopCilVisitor + method! vlval l = let tp = typeOfLval l in if (Ciltools.is_volatile_tp tp) then flag := true; DoChildren - method vexpr e = + method! vexpr e = DoChildren end -let exp_has_volatile e = +let exp_has_volatile e = let flag = ref false in ignore (visitCilExpr (new hasVolatile flag) e); !flag @@ -212,7 +210,7 @@ let rec compareExp (e1: exp) (e2: exp) : bool = | Lval lv1, Lval lv2 | StartOf lv1, StartOf lv2 | AddrOf lv1, AddrOf lv2 -> compareLval lv1 lv2 - | BinOp(bop1, l1, r1, _), BinOp(bop2, l2, r2, _) -> + | BinOp(bop1, l1, r1, _), BinOp(bop2, l2, r2, _) -> bop1 = bop2 && compareExp l1 l2 && compareExp r1 r2 | _ -> begin match getInteger (constFold true e1), getInteger (constFold true e2) with @@ -245,17 +243,17 @@ let rec stripNopCasts (e:exp): exp = TPtr _, TPtr _ -> (* okay to strip *) stripNopCasts e' (* strip casts from pointers to unsigned int/long*) - | (TPtr _ as t1), (TInt(ik,_) as t2) - when bitsSizeOf t1 = bitsSizeOf t2 + | (TPtr _ as t1), (TInt(ik,_) as t2) + when bitsSizeOf t1 = bitsSizeOf t2 && not (isSigned ik) -> stripNopCasts e' - | (TInt _ as t1), (TInt _ as t2) + | (TInt _ as t1), (TInt _ as t2) when bitsSizeOf t1 = bitsSizeOf t2 -> (* Okay to strip.*) stripNopCasts e' | _ -> e end | _ -> e - + let compareExpStripCasts (e1: exp) (e2: exp) : bool = compareExp (stripNopCasts e1) (stripNopCasts e2) *) @@ -266,7 +264,7 @@ let removedCount = ref 0 class uselessInstrElim : cilVisitor = object(self) inherit nopCilVisitor - method vstmt stm = + method! vstmt stm = (* give a set of varinfos and an iosh and get * the set of definition ids definining the vars *) @@ -294,7 +292,7 @@ class uselessInstrElim : cilVisitor = object(self) * something from defuses is in instruses and is also used somewhere else *) if UD.VS.exists (fun vi -> vi.vglob) instruses then true else let instruses = viSetToDefIdSet iosh instruses in - IS.fold (fun i' b -> + IS.fold (fun i' b -> if not(IS.mem i' instruses) then begin if !debug then ignore(E.log "i not in instruses: %a\n" d_instr i); true @@ -304,11 +302,11 @@ class uselessInstrElim : cilVisitor = object(self) IH.mem sidUseSetHash i' || if not(IS.equal i'_uses (IS.singleton defid)) then begin IS.iter (fun iu -> match RD.getSimpRhs iu with - | Some(RD.RDExp e) -> - if !debug then ignore(E.log "i' had other than one use: %d: %a\n" + | Some(RD.RDExp e) -> + if !debug then ignore(E.log "i' had other than one use: %d: %a\n" (IS.cardinal i'_uses) d_exp e) | Some(RD.RDCall i) -> - if !debug then ignore(E.log "i' had other than one use: %d: %a\n" + if !debug then ignore(E.log "i' had other than one use: %d: %a\n" (IS.cardinal i'_uses) d_instr i) | None -> ()) i'_uses; true @@ -318,7 +316,7 @@ class uselessInstrElim : cilVisitor = object(self) in let test (i,(_,s,iosh)) = - match i with + match i with | Call(Some(Var vi,NoOffset),Lval(Var vf,NoOffset),el,l) -> if not(!callHasNoSideEffects i) then begin if !debug then ignore(E.log "found call w/ side effects: %a\n" d_instr i); @@ -362,7 +360,7 @@ class uselessInstrElim : cilVisitor = object(self) stm.skind <- Instr(filter il ((),s,iosh)); SkipChildren | _ -> DoChildren - + end (* until fixed point is reached *) @@ -390,7 +388,7 @@ let elim_dead_code (fd : fundec) : fundec = removedCount := 0; time "reaching definitions" RD.computeRDs fd; if !debug then ignore(E.log "DCE: collecting used definitions\n"); - ignore(time "ud-collector" + ignore(time "ud-collector" (visitCilFunction (new usedDefsCollectorClass :> cilVisitor)) fd); if !debug then ignore(E.log "DCE: eliminating useless instructions\n"); let fd' = time "useless-elim" (visitCilFunction (new uselessInstrElim)) fd in @@ -399,7 +397,7 @@ let elim_dead_code (fd : fundec) : fundec = class deadCodeElimClass : cilVisitor = object(self) inherit nopCilVisitor - method vfunc fd = + method! vfunc fd = let fd' = elim_dead_code(*_fp*) fd in ChangeTo(fd') diff --git a/src/ext/zrapp/dune b/src/ext/zrapp/dune new file mode 100644 index 000000000..86b37bcd2 --- /dev/null +++ b/src/ext/zrapp/dune @@ -0,0 +1,6 @@ +(library + (public_name goblint-cil.zrapp) + (name zrapp) + (wrapped false) ; this should be changed, but then module paths in goblint need to be prefixed + (libraries goblint-cil goblint-cil.liveness stdlib-shims) +) diff --git a/src/ext/zrapp/reachingdefs.ml b/src/ext/zrapp/reachingdefs.ml index c8199f7c2..050fea3f5 100644 --- a/src/ext/zrapp/reachingdefs.ml +++ b/src/ext/zrapp/reachingdefs.ml @@ -36,12 +36,12 @@ let time s f a = S.time s f a else f a -module IOS = +module IOS = Set.Make(struct type t = int option let compare io1 io2 = match io1, io2 with - Some i1, Some i2 -> Pervasives.compare i1 i2 + Some i1, Some i2 -> Stdlib.compare i1 i2 | Some i1, None -> 1 | None, Some i2 -> -1 | None, None -> 0 @@ -62,7 +62,7 @@ let ih_inter ih1 ih2 = let ih_union ih1 ih2 = let ih' = IH.copy ih1 in IH.iter (fun id vi -> - if not(IH.mem ih' id) + if not(IH.mem ih' id) then IH.add ih' id vi else ()) ih2; ih' @@ -92,8 +92,8 @@ let iosh_defId_find iosh defId = let get_vid vid ios io = match io with Some(i) -> Some(i) - | None -> - let there = IOS.exists + | None -> + let there = IOS.exists (function None -> false | Some(i') -> defId = i') ios in if there then Some(vid) else None @@ -130,7 +130,7 @@ let iosh_equals iosh1 iosh2 = (* if IH.length iosh1 = 0 && not(IH.length iosh2 = 0) || IH.length iosh2 = 0 && not(IH.length iosh1 = 0)*) if not(IH.length iosh1 = IH.length iosh2) - then + then (if !debug then ignore(E.log "iosh_equals: length not same: %d %d\n" (IH.length iosh1) (IH.length iosh2)); false) @@ -145,7 +145,7 @@ let iosh_equals iosh1 iosh2 = with Not_found -> (if !debug then ignore(E.log "iosh_equals: vid %d not in iosh2\n" vid); false)) iosh1 true - + (* replace an entire set with a singleton. if nothing was there just add the singleton *) (* IOS.t IH.t -> int -> varinfo -> unit *) @@ -171,7 +171,7 @@ let iosh_filter_dead iosh vs = iosh (* Takes the defs, the data, and a function for obtaining the next def id *) (* VS.t -> IOS.t IH.t -> (unit->int) -> unit *) -let proc_defs vs iosh f = +let proc_defs vs iosh f = let pd vi = let newi = f() in if !debug then @@ -206,12 +206,12 @@ let instrRDs il sid (ivih, s, iosh) out = let proc_one hil i = match hil with - | [] -> + | [] -> let _, defd = UD.computeUseDefInstr i in - if UD.VS.is_empty defd + if UD.VS.is_empty defd then ((*if !debug then print_instr i ((), s, iosh);*) [((), s, iosh)]) - else + else let iosh' = IH.copy iosh in proc_defs defd iosh' (idMaker () s); (*if !debug then @@ -219,8 +219,8 @@ let instrRDs il sid (ivih, s, iosh) out = ((), s + UD.VS.cardinal defd, iosh')::hil | (_, s', iosh')::hrst as l -> let _, defd = UD.computeUseDefInstr i in - if UD.VS.is_empty defd - then + if UD.VS.is_empty defd + then ((*if !debug then print_instr i ((),s', iosh');*) ((), s', iosh')::l) @@ -236,7 +236,7 @@ let instrRDs il sid (ivih, s, iosh) out = Hashtbl.add iRDsHtbl (sid,true) foldedout; Hashtbl.add iRDsHtbl (sid,false) foldednotout; if out then foldedout else foldednotout - + (* The right hand side of an assignment is either @@ -252,9 +252,9 @@ let rhsHtbl = IH.create 64 (* to avoid recomputation *) let getDefRhs didstmh stmdat defId = if IH.mem rhsHtbl defId then IH.find rhsHtbl defId else let stm = - try IH.find didstmh defId + try IH.find didstmh defId with Not_found -> E.s (E.error "getDefRhs: defId %d not found" defId) in - let (_,s,iosh) = + let (_,s,iosh) = try IH.find stmdat stm.sid with Not_found -> E.s (E.error "getDefRhs: sid %d not found" stm.sid) in match stm.skind with @@ -265,26 +265,28 @@ let getDefRhs didstmh stmdat defId = let iihl = List.combine (List.combine il ivihl) ivihl_in in (try let ((i,(_,_,diosh)),(_,_,iosh_in)) = List.find (fun ((i,(_,_,iosh')),_) -> match time "iosh_defId_find" (iosh_defId_find iosh') defId with - Some vid -> + Some vid -> (match i with Set((Var vi',NoOffset),_,_) -> vi'.vid = vid (* _ -> NoOffset *) | Call(Some(Var vi',NoOffset),_,_,_) -> vi'.vid = vid (* _ -> NoOffset *) | Call(None,_,_,_) -> false - | Asm(_,_,sll,_,_,_) -> List.exists + | Asm(_,_,sll,_,_,_) -> List.exists (function (_,_,(Var vi',NoOffset)) -> vi'.vid = vid | _ -> false) sll | _ -> false) | None -> false) iihl in (match i with Set((lh,_),e,_) -> (match lh with - Var(vi') -> + Var(vi') -> (IH.add rhsHtbl defId (Some(RDExp(e),stm.sid,iosh_in)); Some(RDExp(e), stm.sid, iosh_in)) | _ -> E.s (E.error "Reaching Defs getDefRhs: right vi not first")) - | Call(lvo,e,el,_) -> + | Call(lvo,e,el,_) -> (IH.add rhsHtbl defId (Some(RDCall(i),stm.sid,iosh_in)); Some(RDCall(i), stm.sid, iosh_in)) - | Asm(a,sl,slvl,sel,sl',_) -> None) (* ? *) + | Asm(a,sl,slvl,sel,sl',_) -> None + | VarDecl _ -> None + ) (* ? *) with Not_found -> (if !debug then ignore (E.log "getDefRhs: No instruction defines %d\n" defId); IH.add rhsHtbl defId None; @@ -294,7 +296,7 @@ let getDefRhs didstmh stmdat defId = (*None*) let prettyprint didstmh stmdat () (_,s,iosh) = (*text ""*) - seq line (fun (vid,ios) -> + seq ~sep:line ~doit:(fun (vid,ios) -> num vid ++ text ": " ++ IOS.fold (fun io d -> match io with None -> d ++ text "None " @@ -307,7 +309,7 @@ let prettyprint didstmh stmdat () (_,s,iosh) = (*text ""*) | Some(RDCall(c),_,_) -> d ++ num i ++ text " " ++ (d_instr () c)) ios nil) - (IH.tolist iosh) + ~elements:(IH.tolist iosh) module ReachingDef = struct @@ -320,10 +322,10 @@ module ReachingDef = or must-reach *) let mayReach = ref false - + (* An integer that tells the id number of the first definition *) - (* Also a hash from variable ids to a set of + (* Also a hash from variable ids to a set of definition ids that reach this statement. None means there is a path to this point on which there is no definition of the variable *) @@ -345,7 +347,7 @@ module ReachingDef = (* pretty printer *) let pretty = prettyprint defIdStmtHash stmtStartData - + (* The first id to use when computeFirstPredecessor is next called *) @@ -382,11 +384,11 @@ module ReachingDef = | None -> ((), startDefId, IH.copy iosh) | Some vs -> ((), startDefId, iosh_filter_dead (IH.copy iosh) vs) - + let combinePredecessors (stm:stmt) ~(old:t) ((_, s, iosh):t) = match old with (_, os, oiosh) -> begin - if time "iosh_equals" (iosh_equals oiosh) iosh - then None + if time "iosh_equals" (iosh_equals oiosh) iosh + then None else begin Some((), os, time "iosh_combine" (iosh_combine oiosh) iosh) end @@ -405,7 +407,7 @@ module ReachingDef = (* all the work gets done at the instruction level *) let doStmt stm (_, s, iosh) = - if not(IH.mem sidStmtHash stm.sid) then + if not(IH.mem sidStmtHash stm.sid) then IH.add sidStmtHash stm.sid stm; if !debug then ignore(E.log "RD: looking at %a\n" d_stmt stm); match L.getLiveSet stm.sid with @@ -428,7 +430,7 @@ module RD = DF.ForwardsDataFlow(ReachingDef) None in iosh *) (* IOS.t IH.t -> varinfo list -> () *) let iosh_none_fill iosh vil = - List.iter (fun vi -> + List.iter (fun vi -> IH.add iosh vi.vid (IOS.singleton None)) vil @@ -467,12 +469,12 @@ let computeRDs fdec = if compare fdec.svar.vname (!debug_fn) = 0 then debug := false (* now ReachingDef.stmtStartData has the reaching def data in it *) - with Failure "hd" -> if compare fdec.svar.vname (!debug_fn) = 0 then + with Failure _ -> if compare fdec.svar.vname (!debug_fn) = 0 then debug := false (* return the definitions that reach the statement with statement id sid *) -let getRDs sid = +let getRDs sid = try Some (IH.find ReachingDef.stmtStartData sid) with Not_found -> @@ -506,9 +508,9 @@ let isDefInstr i defId = (* Pretty print the reaching definition data for a function *) let ppFdec fdec = - seq line (fun stm -> + seq ~sep:line ~doit:(fun stm -> let ivih = IH.find ReachingDef.stmtStartData stm.sid in - ReachingDef.pretty () ivih) fdec.sbody.bstmts + ReachingDef.pretty () ivih) ~elements:fdec.sbody.bstmts (* If this class is extended with a visitor on expressions, @@ -528,10 +530,10 @@ class rdVisitorClass = object (self) instruction if there is one *) val mutable cur_rd_dat = None - method vstmt stm = + method! vstmt stm = sid <- stm.sid; match getRDs sid with - None -> + None -> if !debug then ignore(E.log "rdVis: stm %d had no data\n" sid); cur_rd_dat <- None; DoChildren @@ -546,14 +548,14 @@ class rdVisitorClass = object (self) cur_rd_dat <- None; DoChildren - method vinst i = - if !debug then ignore(E.log "rdVis: before %a, rd_dat_lst is %d long\n" + method! vinst i = + if !debug then ignore(E.log "rdVis: before %a, rd_dat_lst is %d long\n" d_instr i (List.length rd_dat_lst)); try cur_rd_dat <- Some(List.hd rd_dat_lst); rd_dat_lst <- List.tl rd_dat_lst; DoChildren - with Failure "hd" -> + with Failure _ -> if !debug then ignore(E.log "rdVis: il rd_dat_lst mismatch\n"); DoChildren @@ -565,4 +567,3 @@ class rdVisitorClass = object (self) | Some(_,_,iosh) -> Some iosh end - diff --git a/src/ext/zrapp/rmciltmps.ml b/src/ext/zrapp/rmciltmps.ml index a1c32fcbc..3cc6920b7 100644 --- a/src/ext/zrapp/rmciltmps.ml +++ b/src/ext/zrapp/rmciltmps.ml @@ -3,8 +3,6 @@ others must wait until pretty printing *) open Cil -open Pretty -open Expcompare module E = Errormsg module RD = Reachingdefs @@ -13,10 +11,10 @@ module UD = Usedef module IH = Inthash module S = Stats -module IS = +module IS = Set.Make(struct type t = int - let compare = Pervasives.compare + let compare = Stdlib.compare end) let debug = RD.debug @@ -37,7 +35,7 @@ type nameform = Suffix of string | Prefix of string | Exact of string Returns None if, for example, the definition is caused by an assembly instruction *) (* int -> (rhs * int * IOS.t IH.t) option *) -let getDefRhs = RD.getDefRhs +let getDefRhs = RD.getDefRhs RD.ReachingDef.defIdStmtHash RD.ReachingDef.stmtStartData @@ -49,20 +47,20 @@ let exp_ok = ref true class memReadOrAddrOfFinderClass = object(self) inherit nopCilVisitor - method vexpr e = match e with - Lval(Mem _, _) -> + method! vexpr e = match e with + Lval(Mem _, _) -> exp_ok := false; SkipChildren | _ -> DoChildren - method vvrbl vi = + method! vvrbl vi = if vi.vglob then (if !debug then ignore(E.log "memReadOrAddrOfFinder: %s is a global\n" vi.vname); exp_ok := false; SkipChildren) else if vi.vaddrof then - (if !debug then + (if !debug then ignore(E.log "memReadOrAddrOfFinder: %s has its address taken\n" vi.vname); exp_ok := false; @@ -88,8 +86,8 @@ let fsr = ref emptyStmt class stmtFinderClass sid = object(self) inherit nopCilVisitor - method vstmt stm = - if stm.sid = sid + method! vstmt stm = + if stm.sid = sid then (fsr := stm; SkipChildren) else DoChildren @@ -126,19 +124,19 @@ let writes_between f dsid sid = if !debug && wh then ignore(E.log "writes_between: start=goal and write here\n"); if !debug && (not wh) then ignore(E.log "writes_between: start=goal and no write here\n"); b || (find_write start)) - else + else (* if time "List.mem1" (List.mem start.sid) (!visited_sid_lr) then false else *) if IS.mem start.sid (!visited_sid_isr) then false else let w = find_write start in if !debug && w then ignore(E.log "writes_between: found write %a\n" d_stmt start); visited_sid_isr := IS.add start.sid (!visited_sid_isr); - let rec proc_succs sl = match sl with [] -> false + let rec proc_succs sl = match sl with [] -> false | s::rest -> if dfs goal (w || b) s then true else proc_succs rest in proc_succs start.succs in match stmo, dstmo with - None, _ | _, None -> + None, _ | _, None -> E.s (E.error "writes_between: defining stmt not an instr") | Some stm, Some dstm -> let _ = visited_sid_isr := IS.singleton stm.sid in @@ -157,24 +155,24 @@ let verify_unmodified uses fdefs curiosh defiosh = let curido = RD.iosh_singleton_lookup curiosh vi in let defido = RD.iosh_singleton_lookup defiosh vi in match curido, defido with - Some(curid), Some(defid) -> + Some(curid), Some(defid) -> (if !debug then ignore (E.log "verify_unmodified: curido: %d defido: %d\n" curid defid); curid = defid && b) - | None, None -> + | None, None -> if not(UD.VS.mem vi fdefs) then (if !debug then ignore (E.log "verify_unmodified: %s not defined in function\n" vi.vname); b) else (* if the same set of definitions reaches, we can replace, also *) let curios = try IH.find curiosh vi.vid with Not_found -> RD.IOS.empty in - let defios = try IH.find defiosh vi.vid + let defios = try IH.find defiosh vi.vid with Not_found -> RD.IOS.empty in RD.IOS.compare curios defios == 0 && b | _, _ -> - (if !debug then ignore (E.log "verify_unmodified: %s has conflicting definitions. cur: %a\n def: %a\n" - vi.vname RD.ReachingDef.pretty ((),0,curiosh) + (if !debug then ignore (E.log "verify_unmodified: %s has conflicting definitions. cur: %a\n def: %a\n" + vi.vname RD.ReachingDef.pretty ((),0,curiosh) RD.ReachingDef.pretty ((),0,defiosh)); - false)) + false)) uses true let fdefs = ref UD.VS.empty @@ -182,9 +180,9 @@ let udDeepSkindHtbl = IH.create 64 class defCollectorClass = object(self) inherit nopCilVisitor - method vstmt s = + method! vstmt s = let _,d = if IH.mem udDeepSkindHtbl s.sid - then IH.find udDeepSkindHtbl s.sid + then IH.find udDeepSkindHtbl s.sid else let u',d' = UD.computeDeepUseDefStmtKind s.skind in IH.add udDeepSkindHtbl s.sid (u',d'); (u',d') in @@ -238,7 +236,7 @@ let ok_to_replace vi curiosh sid defiosh dsid f r = if (not safe || target_addrof) && writes then (if !debug then ignore (E.log "ok_to_replace: replacement not safe because of pointers or addrOf\n"); - false) + false) else let fdefs = collect_fun_defs f in let _ = if !debug then ignore (E.log "ok_to_replace: card fdefs = %d\n" (UD.VS.cardinal fdefs)) in let _ = if !debug then ignore (E.log "ok_to_replace: card uses = %d\n" (UD.VS.cardinal uses)) in @@ -249,7 +247,7 @@ let useList = ref [] class useListerClass (defid:int) (vi:varinfo) = object(self) inherit RD.rdVisitorClass - method vexpr e = + method! vexpr e = match e with | Lval(Var vi', off) -> begin match self#get_cur_iosh() with @@ -267,7 +265,7 @@ end (* ok_to_replace_with_incdec *) (* Find out if it is alright to replace the use of a variable - with a post-incrememnt/decrement of the variable it is assigned to be *) + with a post-increment/decrement of the variable it is assigned to be *) (* Takes the definitions reaching the variable use, the definitions reaching the place where the variable was defined, the fundec, the varinfo for the variable being considered and the right @@ -275,7 +273,7 @@ end let ok_to_replace_with_incdec curiosh defiosh f id vi r = (* number of uses of vi where definition id reaches *) - let num_uses () = + let num_uses () = let _ = useList := [] in let ulc = new useListerClass id vi in let _ = visitCilFunction (ulc :> cilVisitor) f in @@ -288,9 +286,9 @@ let ok_to_replace_with_incdec curiosh defiosh f id vi r = and None otherwise *) let inc_or_dec e vi = match e with - BinOp((PlusA|PlusPI|IndexPI), Lval(Var vi', NoOffset), + BinOp((PlusA|PlusPI|IndexPI), Lval(Var vi', NoOffset), Const(CInt64(one,_,_)),_) -> - if vi.vid = vi'.vid && one = Int64.one + if vi.vid = vi'.vid && one = Int64.one then Some(PlusA) else if vi.vid = vi'.vid && one = Int64.minus_one then Some(MinusA) @@ -309,7 +307,7 @@ let ok_to_replace_with_incdec curiosh defiosh f id vi r = let defido = RD.iosh_singleton_lookup defiosh rhsvi in (match curido, defido with Some(curid), _ -> - let defios = try IH.find defiosh rhsvi.vid + let defios = try IH.find defiosh rhsvi.vid with Not_found -> RD.IOS.empty in let redefrhso = getDefRhs curid in (match redefrhso with @@ -324,7 +322,7 @@ let ok_to_replace_with_incdec curiosh defiosh f id vi r = if not (tmprdid = id) then (if !debug then ignore (E.log "ok_to_replace: initial def of %s doesn't reach redef of %s\n" vi.vname rhsvi.vname); None) - else let redefios = try IH.find redefiosh rhsvi.vid + else let redefios = try IH.find redefiosh rhsvi.vid with Not_found -> RD.IOS.empty in let curdef_stmt = try IH.find RD.ReachingDef.defIdStmtHash curid with Not_found -> E.s (E.error "ok_to_replace: couldn't find statement defining %d" curid) in @@ -336,12 +334,12 @@ let ok_to_replace_with_incdec curiosh defiosh f id vi r = (match redefrhs with RD.RDExp(e) -> (match inc_or_dec e rhsvi with Some(PlusA) -> - if num_uses () = 1 then + if num_uses () = 1 then Some(curdef_stmt.sid, curid, rhsvi, PlusA) else (if !debug then ignore (E.log "ok_to_replace: tmp used more than once\n"); None) | Some(MinusA) -> - if num_uses () = 1 then + if num_uses () = 1 then Some(curdef_stmt.sid, curid, rhsvi, MinusA) else (if !debug then ignore (E.log "ok_to_replace: tmp used more than once\n"); None) @@ -402,11 +400,11 @@ let check_form s f = String.length s = frmlen && compare s ext = 0 -(* check a name against a list of forms +(* check a name against a list of forms if it matches any then return true *) (* string -> nameform list -> bool *) let check_forms s fl = - List.fold_left (fun b f -> b || check_form s f) + List.fold_left (fun b f -> b || check_form s f) false fl let forms = [Exact "tmp"; @@ -425,11 +423,11 @@ let forms = [Exact "tmp"; let varXformClass action data sid fd nofrm = object(self) inherit nopCilVisitor - method vexpr e = match e with + method! vexpr e = match e with Lval(Var vi, NoOffset) -> (match action data sid vi fd nofrm with None -> DoChildren - | Some e' -> + | Some e' -> (* Cast e' to the correct type. *) let e'' = mkCast ~e:e' ~newt:vi.vtype in ChangeTo e'') @@ -454,7 +452,7 @@ end let lvalXformClass action data sid fd nofrm = object(self) inherit nopCilVisitor - method vexpr e = + method! vexpr e = let castrm e = e (*stripCastsForPtrArith e*) in @@ -463,7 +461,7 @@ let lvalXformClass action data sid fd nofrm = object(self) match action data sid lv fd nofrm with | None -> (* don't substitute constants in memory lvals *) - let post e = + let post e = match e with | Lval(Mem(Const _),off') -> Lval(Mem e', off') | _ -> castrm e @@ -472,7 +470,7 @@ let lvalXformClass action data sid fd nofrm = object(self) | Some e' -> let e'' = mkCast ~e:e' ~newt:(typeOf(Lval lv)) in ChangeDoChildrenPost(e'', castrm) - end + end | Lval lv -> begin match action data sid lv fd nofrm with | None -> DoChildren @@ -500,13 +498,13 @@ let iosh_get_useful_def iosh vi = not(vi.vid = vi'.vid) (* false if they are the same *) | _ -> true) ios in - if not(RD.IOS.cardinal ios' = 1) - then (if !debug then ignore(E.log "iosh_get_useful_def: multiple different defs of %d:%s(%d)\n" + if not(RD.IOS.cardinal ios' = 1) + then (if !debug then ignore(E.log "iosh_get_useful_def: multiple different defs of %d:%s(%d)\n" vi.vid vi.vname (RD.IOS.cardinal ios')); None) else RD.IOS.choose ios' else (if !debug then ignore(E.log "iosh_get_useful_def: no def of %s reaches here\n" vi.vname); - None) + None) let ae_tmp_to_exp_change = ref false let ae_tmp_to_exp eh sid vi fd nofrm = @@ -520,7 +518,7 @@ let ae_tmp_to_exp eh sid vi fd nofrm = | Const(CWStr _) -> None (* don't fwd subst str lits *) | _ -> begin ae_tmp_to_exp_change := true; - Some e + Some e end end with Not_found -> None @@ -529,7 +527,7 @@ let ae_tmp_to_exp eh sid vi fd nofrm = let ae_lval_to_exp_change = ref false let ae_lval_to_exp ?(propStrings:bool = false) lvh sid lv fd nofrm = match lv, nofrm with - | (Var vi, NoOffset), false -> + | (Var vi, NoOffset), false -> (* If the var is not a temp, then don't replace *) if check_forms vi.vname forms then begin try @@ -572,18 +570,18 @@ let ae_lval_to_exp ?(propStrings:bool = false) lvh sid lv fd nofrm = (* IOS.t IH.t -> sid -> varinfo -> fundec -> bool -> exp option *) let rd_tmp_to_exp_change = ref false let rd_tmp_to_exp iosh sid vi fd nofrm = - if nofrm || (check_forms vi.vname forms) - then let ido = iosh_get_useful_def iosh vi in - match ido with None -> + if nofrm || (check_forms vi.vname forms) + then let ido = iosh_get_useful_def iosh vi in + match ido with None -> if !debug then ignore(E.log "tmp_to_exp: non-single def: %s\n" vi.vname); None | Some(id) -> let defrhs = time "getDefRhs" getDefRhs id in - match defrhs with None -> + match defrhs with None -> if !debug then ignore(E.log "tmp_to_exp: no def of %s\n" vi.vname); None | Some(RD.RDExp(e) as r, dsid , defiosh) -> if time "ok_to_replace" (ok_to_replace vi iosh sid defiosh dsid fd) r - then + then (if !debug then ignore(E.log "tmp_to_exp: changing %s to %a\n" vi.vname d_plainexp e); match e with | Const(CStr _) @@ -592,13 +590,13 @@ let rd_tmp_to_exp iosh sid vi fd nofrm = rd_tmp_to_exp_change := true; Some e end) - else + else (if !debug then ignore(E.log "tmp_to_exp: not ok to replace %s\n" vi.vname); None) - | _ -> + | _ -> if !debug then ignore(E.log "tmp_to_exp: rhs is call %s\n" vi.vname); None - else + else (if !debug then ignore(E.log "tmp_to_exp: %s didn't match form or nofrm\n" vi.vname); None) @@ -615,7 +613,7 @@ let ae_fwd_subst data sid e fd nofrm = let ae_lv_fwd_subst ?(propStrings:bool = false) data sid e fd nofrm = ae_lval_to_exp_change := false; let e' = visitCilExpr (lvalXformClass (ae_lval_to_exp ~propStrings:propStrings) - data sid fd nofrm) e + data sid fd nofrm) e in (e', !ae_lval_to_exp_change) @@ -645,7 +643,7 @@ let tmp_to_const iosh sid vi fd nofrm = match RD.iosh_lookup iosh vi with None -> None | Some(ios) -> - let defido = + let defido = try RD.IOS.choose ios with Not_found -> None in match defido with None -> None | Some defid -> @@ -663,11 +661,11 @@ let tmp_to_const iosh sid vi fd nofrm = if Util.equals c c' then match RD.getDefIdStmt defid with None -> E.s (E.error "tmp_to_const: defid has no statement") - | Some(stm) -> ok_to_replace vi iosh sid defiosh stm.sid fd (RD.RDExp(Const c')) + | Some(stm) -> ok_to_replace vi iosh sid defiosh stm.sid fd (RD.RDExp(Const c')) else false | _ -> false) ios in - if same + if same then (tmp_to_const_change := true; Some(Const c)) else None else None) @@ -687,7 +685,7 @@ let ae_const_prop eh sid e fd nofrm = class expTempElimClass (fd:fundec) = object (self) inherit RD.rdVisitorClass - method vexpr e = + method! vexpr e = let do_change iosh vi = let ido = RD.iosh_singleton_lookup iosh vi in @@ -698,7 +696,7 @@ class expTempElimClass (fd:fundec) = object (self) Some(RD.RDExp(e) as r, dsid, defiosh) -> if !debug then ignore(E.log "Can I replace %s with %a?\n" vi.vname d_exp e); if ok_to_replace vi iosh sid defiosh dsid fd r - then + then (if !debug then ignore(E.log "Yes.\n"); ChangeTo(e)) else (if !debug then ignore(E.log "No.\n"); @@ -715,10 +713,10 @@ class expTempElimClass (fd:fundec) = object (self) Some(_,s,iosh) -> do_change iosh vi | None -> let iviho = RD.getRDs sid in match iviho with - Some(_,s,iosh) -> + Some(_,s,iosh) -> (if !debug then ignore (E.log "Try to change %s outside of instruction.\n" vi.vname); do_change iosh vi) - | None -> + | None -> (if !debug then ignore (E.log "%s in statement w/o RD info\n" vi.vname); DoChildren)) else DoChildren) @@ -729,7 +727,7 @@ end class expLvTmpElimClass (fd : fundec) = object(self) inherit AELV.aeVisitorClass - method vexpr e = + method! vexpr e = match self#get_cur_eh () with | None -> DoChildren | Some eh -> begin @@ -742,7 +740,7 @@ end class incdecTempElimClass (fd:fundec) = object (self) inherit RD.rdVisitorClass - method vexpr e = + method! vexpr e = let do_change iosh vi = let ido = RD.iosh_singleton_lookup iosh vi in @@ -774,10 +772,10 @@ class incdecTempElimClass (fd:fundec) = object (self) Some(_,s,iosh) -> do_change iosh vi | None -> let iviho = RD.getRDs sid in match iviho with - Some(_,s,iosh) -> + Some(_,s,iosh) -> (if !debug then ignore (E.log "Try to change %s outside of instruction.\n" vi.vname); do_change iosh vi) - | None -> + | None -> (if !debug then ignore (E.log "%s in statement w/o RD info\n" vi.vname); DoChildren)) else DoChildren) @@ -788,7 +786,7 @@ end class callTempElimClass (fd:fundec) = object (self) inherit RD.rdVisitorClass - method vexpr e = + method! vexpr e = let do_change iosh vi = let ido = RD.iosh_singleton_lookup iosh vi in @@ -819,10 +817,10 @@ class callTempElimClass (fd:fundec) = object (self) Some(_,s,iosh) -> do_change iosh vi | None -> let iviho = RD.getRDs sid in match iviho with - Some(_,s,iosh) -> + Some(_,s,iosh) -> (if !debug then ignore (E.log "Try to change %s:%d outside of instruction.\n" vi.vname vi.vid); do_change iosh vi) - | None -> + | None -> (if !debug then ignore (E.log "%s in statement w/o RD info\n" vi.vname); DoChildren)) else DoChildren) @@ -832,14 +830,14 @@ class callTempElimClass (fd:fundec) = object (self) unless they are found and the replacement prevented. It will be possible to replace more temps if dead code elimination is performed before printing. *) - method vinst i = + method! vinst i = (* Need to copy this from rdVisitorClass because we are overriding *) - if !debug then ignore(E.log "rdVis: before %a, rd_dat_lst is %d long\n" + if !debug then ignore(E.log "rdVis: before %a, rd_dat_lst is %d long\n" d_instr i (List.length rd_dat_lst)); (try cur_rd_dat <- Some(List.hd rd_dat_lst); rd_dat_lst <- List.tl rd_dat_lst - with Failure "hd" -> + with Failure _ -> if !debug then ignore(E.log "rdVis: il rd_dat_lst mismatch\n")); match i with Set((Var vi,off),_,_) -> @@ -870,14 +868,14 @@ let rm_unused_locals fd = (* see if a vi is volatile *) let is_volatile vi = let vi_vol = - List.exists (function (Attr("volatile",_)) -> true + List.exists (function (Attr("volatile",_)) -> true | _ -> false) vi.vattr in let typ_vol = - List.exists (function (Attr("volatile",_)) -> true + List.exists (function (Attr("volatile",_)) -> true | _ -> false) (typeAttrs vi.vtype) in - if !debug && (vi_vol || typ_vol) then + if !debug && (vi_vol || typ_vol) then ignore(E.log "unusedRemover: %s is volatile\n" vi.vname); - if !debug && not(vi_vol || typ_vol) then + if !debug && not(vi_vol || typ_vol) then ignore(E.log "unusedRemover: %s is not volatile\n" vi.vname); vi_vol || typ_vol @@ -893,7 +891,7 @@ class unusedRemoverClass : cilVisitor = object(self) val mutable cur_func = dummyFunDec (* figure out which locals aren't used *) - method vfunc f = + method! vfunc f = cur_func <- f; (* the set of used variables *) let used = List.fold_left (fun u s -> @@ -907,7 +905,7 @@ class unusedRemoverClass : cilVisitor = object(self) then un else (if !debug then ignore (E.log "unusedRemoverClass: %s is unused\n" vi.vname); UD.VS.add vi un)) UD.VS.empty f.slocals in - + (* a filter function for picking out the local variables that need to be kept *) let good_var vi = @@ -926,7 +924,7 @@ class unusedRemoverClass : cilVisitor = object(self) (* remove instructions that set variables that aren't used. Also remove instructions that set variables mentioned in iioh *) - method vstmt stm = + method! vstmt stm = (* return the list of pairs with fst = f *) let findf_in_pl f pl = @@ -950,7 +948,7 @@ class unusedRemoverClass : cilVisitor = object(self) (match rhs with RD.RDCall _ -> (if !debug then ignore (E.log "check_incdec: rhs not an expression\n"); false) - | RD.RDExp e' -> + | RD.RDExp e' -> if Util.equals e e' then true else (if !debug then ignore (E.log "check_incdec: rhs of %d: %a, and needed redef %a not equal\n" redefid d_plainexp e' d_plainexp e); @@ -966,13 +964,13 @@ class unusedRemoverClass : cilVisitor = object(self) pretty printed as a function call *) let will_be_call e = match e with - Lval(Var vi,NoOffset) -> + Lval(Var vi,NoOffset) -> if not(IH.mem iioh vi.vid) then false else (match IH.find iioh vi.vid with None -> false | Some _ -> true) | _ -> false in - + (* a filter function for picking out the instructions that we want to keep *) (* instr -> bool *) @@ -1035,16 +1033,16 @@ end (* Lifts child blocks into parents if the block has no attributes or labels *) let rec fold_blocks b = b.bstmts <- List.fold_right - (fun s acc -> + (fun s acc -> match s.skind with - Block ib -> + Block ib -> fold_blocks ib; - if (List.length ib.battrs = 0 && + if (List.length ib.battrs = 0 && List.length s.labels = 0) then ib.bstmts @ acc else s::acc - | Instr il when il = [] && s.labels = [] -> + | Instr il when il = [] && s.labels = [] -> acc | _ -> s::acc) b.bstmts @@ -1052,13 +1050,13 @@ let rec fold_blocks b = class removeBrackets = object (self) inherit nopCilVisitor - method vblock b = + method! vblock b = fold_blocks b; DoChildren end (* clean up the code and - eliminate some temporaries + eliminate some temporaries for pretty printing a whole function *) (* Cil.fundec -> Cil.fundec *) let eliminate_temps f = @@ -1080,9 +1078,9 @@ let eliminate_temps f = let f' = visitCilFunction (new unusedRemoverClass) f' in f' -(* same as above, but doesn't remove the +(* same as above, but doesn't remove the obviated instructions and declarations. - Use this before using zrapp to print + Use this before using zrapp to print expressions without temps *) let eliminateTempsForExpPrinting f = Cfg.clearCFGinfo f; diff --git a/src/ext/zrapp/zrapp.ml b/src/ext/zrapp/zrapp.ml index b7c271a18..f9e20b0b4 100644 --- a/src/ext/zrapp/zrapp.ml +++ b/src/ext/zrapp/zrapp.ml @@ -1,7 +1,6 @@ open Escape open Pretty -open Trace open Cil open Feature @@ -76,7 +75,7 @@ let simpleGaSearch l = (* location -> string list *) let get_comments l = - let cabsl = {A.lineno = l.line; + let cabsl = {A.lineno = l.line; A.filename = l.file; A.byteno = l.byte; A.ident = 0;} in @@ -117,7 +116,7 @@ let get_loop_condition b = (* stm list -> stm list *) let rec skipEmpty = function | [] -> [] - | {skind = Instr []; labels = []}::rest -> + | {skind = Instr []; labels = []; _}::rest -> skipEmpty rest | x -> x in @@ -131,36 +130,36 @@ let get_loop_condition b = let tsl = skipEmpty tb.bstmts in let fsl = skipEmpty fb.bstmts in (match tsl, fsl with - {skind = Break _} :: _, [] -> Some e - | [], {skind = Break _} :: _ -> + {skind = Break _; _} :: _, [] -> Some e + | [], {skind = Break _; _} :: _ -> Some(UnOp(LNot, e, intType)) - | ({skind = If(_,_,_,_)} as s) :: _, [] -> + | ({skind = If(_,_,_,_); _} as s) :: _, [] -> let teo = get_cond_from_if s in (match teo with None -> None - | Some te -> + | Some te -> Some(BinOp(LAnd,e,EC.stripNopCasts te,intType))) - | [], ({skind = If(_,_,_,_)} as s) :: _ -> + | [], ({skind = If(_,_,_,_); _} as s) :: _ -> let feo = get_cond_from_if s in (match feo with None -> None - | Some fe -> + | Some fe -> Some(BinOp(LAnd,UnOp(LNot,e,intType), EC.stripNopCasts fe,intType))) - | {skind = Break _} :: _, ({skind = If(_,_,_,_)} as s):: _ -> + | {skind = Break _; _} :: _, ({skind = If(_,_,_,_); _} as s):: _ -> let feo = get_cond_from_if s in (match feo with None -> None - | Some fe -> + | Some fe -> Some(BinOp(LOr,e,EC.stripNopCasts fe,intType))) - | ({skind = If(_,_,_,_)} as s) :: _, {skind = Break _} :: _ -> + | ({skind = If(_,_,_,_); _} as s) :: _, {skind = Break _; _} :: _ -> let teo = get_cond_from_if s in (match teo with None -> None - | Some te -> + | Some te -> Some(BinOp(LOr,UnOp(LNot,e,intType), EC.stripNopCasts te,intType))) - | ({skind = If(_,_,_,_)} as ts) :: _ , ({skind = If(_,_,_,_)} as fs) :: _ -> + | ({skind = If(_,_,_,_); _} as ts) :: _ , ({skind = If(_,_,_,_); _} as fs) :: _ -> let teo = get_cond_from_if ts in let feo = get_cond_from_if fs in (match teo, feo with @@ -177,9 +176,9 @@ let get_loop_condition b = in let sl = skipEmpty b.bstmts in match sl with - ({skind = If(_,_,_,_); labels=[]} as s) :: rest -> + ({skind = If(_,_,_,_); labels=[]; _} as s) :: rest -> get_cond_from_if s, rest - | s :: _ -> + | s :: _ -> (if !debug then ignore(E.log "checkMover: %a is first, not an if\n" d_stmt s); None, sl) @@ -199,7 +198,7 @@ class zraCilPrinterClass : cilPrinter = object (self) (* give the varinfo for the variable to be printed, * returns the varinfo for the varinfo with that name * in the current environment. - * Returns argument and prints a warning if the variable + * Returns argument and prints a warning if the variable * isn't in the environment *) method private getEnvVi (v:varinfo) : varinfo = try @@ -223,7 +222,7 @@ class zraCilPrinterClass : cilPrinter = object (self) (** Get the comment out of a location if there is one *) - method pLineDirective ?(forcefile=false) l = + method! pLineDirective ?(forcefile=false) l = let ld = super#pLineDirective l in if !printComments then let c = String.concat "\n" (get_comments l) in @@ -233,8 +232,8 @@ class zraCilPrinterClass : cilPrinter = object (self) else ld (* variable use *) - method pVar (v:varinfo) = - (* warn about instances where a possibly unintentionally + method! pVar (v:varinfo) = + (* warn about instances where a possibly unintentionally conflicting name is used *) if IH.mem RCT.iioh v.vid then let rhso = IH.find RCT.iioh v.vid in @@ -253,7 +252,7 @@ class zraCilPrinterClass : cilPrinter = object (self) let _ = super#setPrintInstrTerminator oldpit in let _ = printComments := opc in c ++ d - | _ -> + | _ -> if IH.mem RCT.incdecHash v.vid then (* print an post-inc/dec instead of a temp variable *) let redefid, rhsvi, b = IH.find RCT.incdecHash v.vid in @@ -278,8 +277,8 @@ class zraCilPrinterClass : cilPrinter = object (self) text v.vname) (* variable declaration *) - method pVDecl () (v:varinfo) = - (* See if the name is already in the environment with a + method! pVDecl () (v:varinfo) = + (* See if the name is already in the environment with a different varinfo. If so, give a warning. If not, add the name to the environment *) let _ = if (H.mem lenvHtbl v.vname) && not(self#checkVi v) then @@ -303,9 +302,9 @@ class zraCilPrinterClass : cilPrinter = object (self) ++ self#pAttrs () rest (* For printing deputy annotations *) - method pAttr (Attr (an, args) : attribute) : doc * bool = + method! pAttr (Attr (an, args) : attribute) : doc * bool = if not (!deputyAttrs) then super#pAttr (Attr(an,args)) else - match an, args with + match an, args with | "fancybounds", [AInt i1; AInt i2] -> nil, false (*if !showBounds then dprintf "BND(%a, %a)" self#pExp (getBoundsExp i1) @@ -362,28 +361,28 @@ class zraCilPrinterClass : cilPrinter = object (self) nil, false | _ -> super#pAttr (Attr (an, args)) - + (*** GLOBALS ***) - method pGlobal () (g:global) : doc = (* global (vars, types, etc.) *) - match g with + method! pGlobal () (g:global) : doc = (* global (vars, types, etc.) *) + match g with | GFun (fundec, l) -> - (* If the function has attributes then print a prototype because + (* If the function has attributes then print a prototype because * GCC cannot accept function attributes in a definition *) let oldattr = fundec.svar.vattr in (* Always pring the file name before function declarations *) - let proto = - if oldattr <> [] then - (self#pLineDirective l) ++ (self#pVDecl () fundec.svar) - ++ chr ';' ++ line + let proto = + if oldattr <> [] then + (self#pLineDirective l) ++ (self#pVDecl () fundec.svar) + ++ chr ';' ++ line else nil in (* Temporarily remove the function attributes *) fundec.svar.vattr <- []; - let body = (self#pLineDirective ~forcefile:true l) + let body = (self#pLineDirective ~forcefile:true l) ++ (self#pFunDecl () fundec) in fundec.svar.vattr <- oldattr; proto ++ body ++ line - + | GType (typ, l) -> self#pLineDirective ~forcefile:true l ++ text "typedef " @@ -395,8 +394,8 @@ class zraCilPrinterClass : cilPrinter = object (self) text "enum" ++ align ++ text (" " ^ enum.ename) ++ self#pAttrs () enum.eattr ++ text " {" ++ line ++ (docList ~sep:(chr ',' ++ line) - (fun (n,i, loc) -> - text (n ^ " = ") + (fun (n,i, loc) -> + text (n ^ " = ") ++ self#pExp () i) () enum.eitems) ++ unalign ++ line ++ text "};\n" @@ -416,7 +415,7 @@ class zraCilPrinterClass : cilPrinter = object (self) text su1 ++ (align ++ text su2 ++ chr ' ' ++ (self#pAttrs () sto_mod) ++ text n ++ text " {" ++ line - ++ ((docList ~sep:line (self#pFieldDecl ())) () + ++ ((docList ~sep:line (self#pFieldDecl ())) () comp.cfields) ++ unalign) ++ line ++ text "}" ++ @@ -432,18 +431,18 @@ class zraCilPrinterClass : cilPrinter = object (self) ++ chr ' ' ++ (match io.init with None -> nil - | Some i -> text " = " ++ - (let islong = + | Some i -> text " = " ++ + (let islong = match i with CompoundInit (_, il) when List.length il >= 8 -> true - | _ -> false + | _ -> false in - if islong then - line ++ self#pLineDirective l ++ text " " + if islong then + line ++ self#pLineDirective l ++ text " " else nil) ++ (self#pInit () i)) ++ text ";\n" - + (* print global variable 'extern' declarations, and function prototypes *) | GVarDecl (vi, l) -> let builtins = if !msvcMode then msvcBuiltins else gccBuiltins in @@ -453,7 +452,7 @@ class zraCilPrinterClass : cilPrinter = object (self) text "/* compiler builtin: \n " ++ (self#pVDecl () vi) ++ text "; */\n" - + end else self#pLineDirective l ++ (self#pVDecl () vi) @@ -469,7 +468,7 @@ class zraCilPrinterClass : cilPrinter = object (self) (* also don't print the 'combiner' pragma *) (* nor 'cilnoremove' *) let suppress = - not !print_CIL_Input && + not !print_CIL_Input && not !msvcMode && ((startsWith "box" an) || (startsWith "ccured" an) || @@ -486,66 +485,66 @@ class zraCilPrinterClass : cilPrinter = object (self) ++ docList ~sep:(chr ',') (self#pAttrParam ()) () args ++ text ")" in - self#pLineDirective l + self#pLineDirective l ++ (if suppress then text "/* " else text "") ++ (text "#pragma ") ++ d ++ (if suppress then text " */\n" else text "\n") - | GText s -> - if s <> "//" then + | GText s -> + if s <> "//" then text s ++ text "\n" else nil - method dGlobal (out: out_channel) (g: global) : unit = - (* For all except functions and variable with initializers, use the + method! dGlobal (out: out_channel) (g: global) : unit = + (* For all except functions and variable with initializers, use the * pGlobal *) - match g with - GFun (fdec, l) -> - (* If the function has attributes then print a prototype because + match g with + GFun (fdec, l) -> + (* If the function has attributes then print a prototype because * GCC cannot accept function attributes in a definition *) let oldattr = fdec.svar.vattr in - let proto = - if oldattr <> [] then - (self#pLineDirective l) ++ (self#pVDecl () fdec.svar) + let proto = + if oldattr <> [] then + (self#pLineDirective l) ++ (self#pVDecl () fdec.svar) ++ chr ';' ++ line else nil in - fprint out 80 (proto ++ (self#pLineDirective ~forcefile:true l)); + fprint out ~width:80 (proto ++ (self#pLineDirective ~forcefile:true l)); (* Temporarily remove the function attributes *) fdec.svar.vattr <- []; - fprint out 80 (self#pFunDecl () fdec); + fprint out ~width:80 (self#pFunDecl () fdec); fdec.svar.vattr <- oldattr; output_string out "\n" | GVar (vi, {init = Some i}, l) -> begin - fprint out 80 + fprint out ~width:80 (self#pLineDirective ~forcefile:true l ++ self#pVDecl () vi - ++ text " = " - ++ (let islong = + ++ text " = " + ++ (let islong = match i with CompoundInit (_, il) when List.length il >= 8 -> true - | _ -> false + | _ -> false in - if islong then - line ++ self#pLineDirective l ++ text " " - else nil)); + if islong then + line ++ self#pLineDirective l ++ text " " + else nil)); self#dInit out 3 i; output_string out ";\n" end - | g -> fprint out 80 (self#pGlobal () g) + | g -> fprint out ~width:80 (self#pGlobal () g) - method pFieldDecl () fi = + method! pFieldDecl () fi = self#pLineDirective fi.floc ++ (self#pType (Some (text (if fi.fname = missingFieldName then "" else fi.fname))) - () + () fi.ftype) ++ text " " - ++ (match fi.fbitfield with None -> nil + ++ (match fi.fbitfield with None -> nil | Some i -> text ": " ++ num i ++ text " ") ++ self#pAttrs () fi.fattr ++ text ";" @@ -555,7 +554,7 @@ class zraCilPrinterClass : cilPrinter = object (self) H.clear lenvHtbl; (* new local environment *) (* add the arguments to the local environment *) List.iter (fun vi -> H.add lenvHtbl vi.vname vi) f.sformals; - let nf = + let nf = if !doElimTemps then RCT.eliminate_temps f else f in @@ -569,14 +568,14 @@ class zraCilPrinterClass : cilPrinter = object (self) ++ decls ++ line ++ line (* the body *) - ++ ((* remember the declaration *) super#setCurrentFormals nf.sformals; + ++ ((* remember the declaration *) super#setCurrentFormals nf.sformals; let body = self#pBlock () nf.sbody in super#setCurrentFormals []; body)) ++ line ++ text "}" - method private pStmtKind (next : stmt) () (sk : stmtkind) = + method! private pStmtKind (next : stmt) () (sk : stmtkind) = match sk with | Loop(b,l,_,_) -> begin (* See if we can turn this into a while(e) {} *) @@ -614,15 +613,15 @@ type outfile = let outChannel : outfile option ref = ref None (* Processign of output file arguments *) -let openFile (what: string) (takeit: outfile -> unit) (fl: string) = +let openFile (what: string) (takeit: outfile -> unit) (fl: string) = if !E.verboseFlag then ignore (Printf.printf "Setting %s to %s\n" what fl); (try takeit {fname = fl; fchan = open_out fl} with _ -> raise (Arg.Bad ("Cannot open " ^ what ^ " file " ^ fl))) -let feature = - { fd_name = "zrapp"; +let feature = + { fd_name = "zrapp"; fd_enabled = false; fd_description = "pretty printing with checks for name conflicts and\n\t\t\t\ttemp variable elimination"; fd_extraopt = [ @@ -638,8 +637,8 @@ let feature = "--zrapp_comments", Arg.Unit (fun _ -> printComments := true), "Print comments from source file in output";]; - fd_doit = - (function (f: file) -> + fd_doit = + (function (f: file) -> lineDirectiveStyle := None; printerForMaincil := zraCilPrinter); fd_post_check = false diff --git a/src/feature.ml b/src/feature.ml index 13e90158d..0fb800925 100644 --- a/src/feature.ml +++ b/src/feature.ml @@ -39,12 +39,12 @@ module D = Dynlink module F = Findlib type t = { - mutable fd_enabled: bool; - fd_name: string; - fd_description: string; - fd_extraopt: (string * Arg.spec * string) list; + mutable fd_enabled: bool; + fd_name: string; + fd_description: string; + fd_extraopt: (string * Arg.spec * string) list; fd_doit: (file -> unit); - fd_post_check: bool; + fd_post_check: bool; } let features = ref [] @@ -96,7 +96,9 @@ let adapt_filename f = try let findlib_lookup pkg = try let preds = [ if D.is_native then "native" else "byte"; "plugin" ] in + let cil_deps = F.package_deep_ancestors preds ["goblint-cil"] in let deps = F.package_deep_ancestors preds [pkg] in + let deps = List.filter (fun x -> not (List.mem x cil_deps)) deps in let find_modules pkg = let base = F.package_directory pkg in let archives = @@ -128,7 +130,7 @@ let add_plugin path = load path; plugins := path :: !plugins -(** Look for plugin and depencies and add them *) +(** Look for plugin and dependencies and add them *) let loadWithDeps s = let paths = find_plugin s in List.iter add_plugin paths diff --git a/src/formatcil.ml b/src/formatcil.ml index 33bc749f8..3bbfa3622 100644 --- a/src/formatcil.ml +++ b/src/formatcil.ml @@ -1,11 +1,11 @@ (* * - * Copyright (c) 2001-2002, + * 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: @@ -35,49 +35,47 @@ * *) open Cil -open Pretty -open Trace (* sm: 'trace' function *) module E = Errormsg module H = Hashtbl let noMemoize = ref false let expMemoTable : - (string, (((string * formatArg) list -> exp) * + (string, (((string * formatArg) list -> exp) * (exp -> formatArg list option))) H.t = H.create 23 let typeMemoTable : - (string, (((string * formatArg) list -> typ) * + (string, (((string * formatArg) list -> typ) * (typ -> formatArg list option))) H.t = H.create 23 let lvalMemoTable : - (string, (((string * formatArg) list -> lval) * + (string, (((string * formatArg) list -> lval) * (lval -> formatArg list option))) H.t = H.create 23 let instrMemoTable : - (string, ((location -> (string * formatArg) list -> instr) * + (string, ((location -> (string * formatArg) list -> instr) * (instr -> formatArg list option))) H.t = H.create 23 let stmtMemoTable : - (string, ((string -> typ -> varinfo) -> - location -> + (string, ((string -> typ -> varinfo) -> + location -> (string * formatArg) list -> stmt)) H.t = H.create 23 let stmtsMemoTable : - (string, ((string -> typ -> varinfo) -> - location -> + (string, ((string -> typ -> varinfo) -> + location -> (string * formatArg) list -> stmt list)) H.t = H.create 23 -let doParse (prog: string) - (theParser: (Lexing.lexbuf -> Formatparse.token) +let doParse (prog: string) + (theParser: (Lexing.lexbuf -> Formatparse.token) -> Lexing.lexbuf -> 'a) - (memoTable: (string, 'a) H.t) : 'a = + (memoTable: (string, 'a) H.t) : 'a = try if !noMemoize then raise Not_found else H.find memoTable prog with Not_found -> begin - let lexbuf = Formatlex.init prog in + let lexbuf = Formatlex.init ~prog:prog in try Formatparse.initialize Formatlex.initial lexbuf; let res = theParser Formatlex.initial lexbuf in @@ -94,94 +92,94 @@ let doParse (prog: string) raise e end end - -let cExp (prog: string) : (string * formatArg) list -> exp = + +let cExp (prog: string) : (string * formatArg) list -> exp = let cf = doParse prog Formatparse.expression expMemoTable in (fst cf) -let cLval (prog: string) : (string * formatArg) list -> lval = +let cLval (prog: string) : (string * formatArg) list -> lval = let cf = doParse prog Formatparse.lval lvalMemoTable in (fst cf) -let cType (prog: string) : (string * formatArg) list -> typ = +let cType (prog: string) : (string * formatArg) list -> typ = let cf = doParse prog Formatparse.typename typeMemoTable in (fst cf) -let cInstr (prog: string) : location -> (string * formatArg) list -> instr = +let cInstr (prog: string) : location -> (string * formatArg) list -> instr = let cf = doParse prog Formatparse.instr instrMemoTable in (fst cf) -let cStmt (prog: string) : (string -> typ -> varinfo) -> - location -> (string * formatArg) list -> stmt = +let cStmt (prog: string) : (string -> typ -> varinfo) -> + location -> (string * formatArg) list -> stmt = let cf = doParse prog Formatparse.stmt stmtMemoTable in cf -let cStmts (prog: string) : - (string -> typ -> varinfo) -> - location -> (string * formatArg) list -> stmt list = +let cStmts (prog: string) : + (string -> typ -> varinfo) -> + location -> (string * formatArg) list -> stmt list = let cf = doParse prog Formatparse.stmt_list stmtsMemoTable in cf (* Match an expression *) -let dExp (prog: string) : exp -> formatArg list option = +let dExp (prog: string) : exp -> formatArg list option = let df = doParse prog Formatparse.expression expMemoTable in (snd df) (* Match an lvalue *) -let dLval (prog: string) : lval -> formatArg list option = +let dLval (prog: string) : lval -> formatArg list option = let df = doParse prog Formatparse.lval lvalMemoTable in (snd df) (* Match a type *) -let dType (prog: string) : typ -> formatArg list option = +let dType (prog: string) : typ -> formatArg list option = let df = doParse prog Formatparse.typename typeMemoTable in (snd df) (* Match an instruction *) -let dInstr (prog: string) : instr -> formatArg list option = +let dInstr (prog: string) : instr -> formatArg list option = let df = doParse prog Formatparse.instr instrMemoTable in (snd df) -let test () = +let test () = (* Construct a dummy function *) let func = emptyFunction "test_formatcil" in (* Construct a few varinfo *) let res = makeLocalVar func "res" (TPtr(intType, [])) in - let fptr = makeLocalVar func "fptr" + let fptr = makeLocalVar func "fptr" (TPtr(TFun(intType, None, false, []), [])) in (* Construct an instruction *) - let makeInstr () = - Call(Some (var res), + let makeInstr () = + Call(Some (var res), Lval (Mem (CastE(TPtr(TFun(TPtr(intType, []), Some [ ("", intType, []); ("a2", TPtr(intType, []), []); ("a3", TPtr(TPtr(intType, []), - []), []) ], + []), []) ], false, []), []), - Lval (var fptr))), + Lval (var fptr))), NoOffset), - [ ], locUnknown) + [ ], locUnknown) in let times = 100000 in (* Make the instruction the regular way *) - Stats.time "make instruction regular" - (fun _ -> for i = 0 to times do ignore (makeInstr ()) done) + Stats.time "make instruction regular" + (fun _ -> for _ = 0 to times do ignore (makeInstr ()) done) (); (* Now make the instruction interpreted *) noMemoize := true; Stats.time "make instruction interpreted" - (fun _ -> for i = 0 to times do - let _ = + (fun _ -> for _ = 0 to times do + let _ = cInstr "%v:res = (* ((int * (*)(int, int * a2, int * * a3))%v:fptr))();" - locUnknown [ ("res", Fv res); - ("fptr", Fv fptr) ] + locUnknown [ ("res", Fv res); + ("fptr", Fv fptr) ] in () done) @@ -189,27 +187,25 @@ let test () = (* Now make the instruction interpreted with memoization *) noMemoize := false; Stats.time "make instruction interpreted memoized" - (fun _ -> for i = 0 to times do - let _ = + (fun _ -> for _ = 0 to times do + let _ = cInstr "%v:res = (* ((int * (*)(int, int * a2, int * * a3))%v:fptr))();" - locUnknown [ ("res", Fv res); ("fptr", Fv fptr) ] + locUnknown [ ("res", Fv res); ("fptr", Fv fptr) ] in () done) (); (* Now make the instruction interpreted with partial application *) - let partInstr = + let partInstr = cInstr "%v:res = (* ((int * (*)(int, int * a2, int * * a3))%v:fptr))();" in Stats.time "make instruction interpreted partial" - (fun _ -> for i = 0 to times do - let _ = + (fun _ -> for _ = 0 to times do + let _ = partInstr - locUnknown [ ("res", Fv res); ("fptr", Fv fptr) ] + locUnknown [ ("res", Fv res); ("fptr", Fv fptr) ] in () done) (); - + () - - diff --git a/src/formatlex.mll b/src/formatlex.mll index 584a060d5..fa694dacb 100644 --- a/src/formatlex.mll +++ b/src/formatlex.mll @@ -145,11 +145,11 @@ let scan_oct_escape str = * We convert L"Hi" to "H\000i\000" *) let wbtowc wstr = let len = String.length wstr in - let dest = String.make (len * 2) '\000' in + let dest = Bytes.make (len * 2) '\000' in for i = 0 to len-1 do - dest.[i*2] <- wstr.[i] ; + Bytes.set dest (i*2) (String.get wstr i) done ; - dest + Bytes.to_string dest (* This function converst the "Hi" in L"Hi" to { L'H', L'i', L'\0' } *) let wstr_to_warray wstr = diff --git a/src/formatparse.mly b/src/formatparse.mly index da4b1ace1..34406bb3a 100644 --- a/src/formatparse.mly +++ b/src/formatparse.mly @@ -1,12 +1,12 @@ /*(* Parser for constructing CIL from format strings *) (* * - * Copyright (c) 2001-2002, + * 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: @@ -38,7 +38,6 @@ */ %{ open Cil -open Pretty module E = Errormsg let parse_error msg : 'a = (* sm: c++-mode highlight hack: -> ' <- *) @@ -47,34 +46,34 @@ let parse_error msg : 'a = (* sm: c++-mode highlight hack: -> ' <- *) msg -let getArg (argname: string) (args: (string * formatArg) list) = - try +let getArg (argname: string) (args: (string * formatArg) list) = + try snd (List.find (fun (n, a) -> n = argname) args) - with _ -> + with _ -> E.s (error "Pattern string %s does not have argument with name %s" !Lexerhack.currentPattern argname) -let wrongArgType (which: string) (expected: string) (found: formatArg) = - E.s (bug "Expecting %s argument (%s) and found %a\n" +let wrongArgType (which: string) (expected: string) (found: formatArg) = + E.s (bug "Expecting %s argument (%s) and found %a\n" expected which d_formatarg found) -let doUnop (uo: unop) subexp = - ((fun args -> +let doUnop (uo: unop) subexp = + ((fun args -> let e = (fst subexp) args in UnOp(uo, e, typeOf e)), - (fun e -> match e with - UnOp(uo', e', _) when uo = uo' -> (snd subexp) e' - | _ -> None)) + (fun e -> match e with + UnOp(uo', e', _) when uo = uo' -> (snd subexp) e' + | _ -> None)) -let buildPlus e1 e2 : exp = +let buildPlus e1 e2 : exp = let t1 = typeOf e1 in - if isPointerType t1 then + if isPointerType t1 then BinOp(PlusPI, e1, e2, t1) - else + else BinOp(PlusA, e1, e2, t1) -let buildMinus e1 e2 : exp = +let buildMinus e1 e2 : exp = let t1 = typeOf e1 in let t2 = typeOf e2 in if isPointerType t1 then @@ -85,14 +84,14 @@ let buildMinus e1 e2 : exp = else BinOp(MinusA, e1, e2, t1) -let doBinop bop e1t e2t = - ((fun args -> - let e1 = (fst e1t) args in - let e2 = (fst e2t) args in +let doBinop bop e1t e2t = + ((fun args -> + let e1 = (fst e1t) args in + let e2 = (fst e2t) args in let t1 = typeOf e1 in BinOp(bop, e1, e2, t1)), - (fun e -> match e with + (fun e -> match e with BinOp(bop', e1, e2, _) when bop' = bop -> begin match (snd e1t) e1, (snd e2t) e2 with Some m1, Some m2 -> Some (m1 @ m2) @@ -101,42 +100,42 @@ let doBinop bop e1t e2t = | _ -> None)) (* Check the equivalence of two format lists *) -let rec checkSameFormat (fl1: formatArg list) (fl2: formatArg list) = - match fl1, fl2 with +let rec checkSameFormat (fl1: formatArg list) (fl2: formatArg list) = + match fl1, fl2 with [], [] -> true | h1::t1, h2::t2 -> begin - let rec checkOffsetEq o1 o2 = + let rec checkOffsetEq o1 o2 = match o1, o2 with NoOffset, NoOffset -> true - | Field(f1, o1'), Field(f2, o2') -> + | Field(f1, o1'), Field(f2, o2') -> f1.fname = f2.fname && checkOffsetEq o1' o2' - | Index(e1, o1'), Index(e2, o2') -> + | Index(e1, o1'), Index(e2, o2') -> checkOffsetEq o1' o2' && checkExpEq e1 e2 | _, _ -> false - and checkExpEq e1 e2 = - match e1, e2 with + and checkExpEq e1 e2 = + match e1, e2 with Const(CInt64(n1, _, _)), Const(CInt64(n2, _, _)) -> n1 = n2 | Lval l1, Lval l2 -> checkLvalEq l1 l2 - | UnOp(uo1, e1, _), UnOp(uo2, e2, _) -> + | UnOp(uo1, e1, _), UnOp(uo2, e2, _) -> uo1 = uo2 && checkExpEq e1 e2 - | BinOp(bo1, e11, e12, _), BinOp(bo2, e21, e22, _) -> + | BinOp(bo1, e11, e12, _), BinOp(bo2, e21, e22, _) -> bo1 = bo2 && checkExpEq e11 e21 && checkExpEq e21 e22 | AddrOf l1, AddrOf l2 -> checkLvalEq l1 l2 | StartOf l1, StartOf l2 -> checkLvalEq l1 l2 | SizeOf t1, SizeOf t2 -> typeSig t1 = typeSig t2 - | _, _ -> + | _, _ -> ignore (E.warn "checkSameFormat for Fe"); false - and checkLvalEq l1 l2 = + and checkLvalEq l1 l2 = match l1, l2 with (Var v1, o1), (Var v2, o2) -> v1 == v2 && checkOffsetEq o1 o2 - | (Mem e1, o1), (Mem e2, o2) -> + | (Mem e1, o1), (Mem e2, o2) -> checkOffsetEq o1 o2 && checkExpEq e1 e2 | _, _ -> false in - let hdeq = - match h1, h2 with + let hdeq = + match h1, h2 with Fv v1, Fv v2 -> v1 == v2 | Fd n1, Fd n2 -> n1 = n2 | Fe e1, Fe e2 -> checkExpEq e1 e2 @@ -151,13 +150,13 @@ let rec checkSameFormat (fl1: formatArg list) (fl2: formatArg list) = end | _, _ -> false -let matchBinopEq (bopeq: binop -> bool) lvt et = - (fun i -> match i with +let matchBinopEq (bopeq: binop -> bool) lvt et = + (fun i -> match i with Set (lv, BinOp(bop', Lval (lv'), e', _), l) when bopeq bop' -> begin - match lvt lv, lvt lv', et e' with - Some m1, Some m1', Some m2 -> + match lvt lv, lvt lv', et e' with + Some m1, Some m1', Some m2 -> (* Must check that m1 and m2 are the same *) - if checkSameFormat m1 m1' then + if checkSameFormat m1 m1' then Some (m1 @ m2) else None @@ -165,55 +164,55 @@ let matchBinopEq (bopeq: binop -> bool) lvt et = end | _ -> None) -let doBinopEq bop lvt et = - ((fun loc args -> +let doBinopEq bop lvt et = + ((fun loc args -> let l = (fst lvt) args in Set(l, BinOp(bop, (Lval l), (fst et) args, typeOfLval l), loc)), matchBinopEq (fun bop' -> bop = bop') (snd lvt) (snd et)) -let getField (bt: typ) (fname: string) : fieldinfo = - match unrollType bt with +let getField (bt: typ) (fname: string) : fieldinfo = + match unrollType bt with TComp(ci, _) -> begin try List.find (fun f -> fname = f.fname) ci.cfields - with Not_found -> + with Not_found -> E.s (bug "Cannot find field %s in %s\n" fname (compFullName ci)) end - | t -> E.s (bug "Trying to access field %s in non-struct\n" fname) + | t -> E.s (bug "Trying to access field %s in non-struct\n" fname) -let matchIntType (ik: ikind) (t:typ) : formatArg list option = - match unrollType t with +let matchIntType (ik: ikind) (t:typ) : formatArg list option = + match unrollType t with TInt(ik', _) when ik = ik' -> Some [] | _ -> None -let matchFloatType (fk: fkind) (t:typ) : formatArg list option = - match unrollType t with +let matchFloatType (fk: fkind) (t:typ) : formatArg list option = + match unrollType t with TFloat(fk', _) when fk = fk' -> Some [] | _ -> None -let doAttr (id: string) - (aargs: (((string * formatArg) list -> attrparam list) * +let doAttr (id: string) + (aargs: (((string * formatArg) list -> attrparam list) * (attrparam list -> formatArg list option)) option) - = - let t = match aargs with + = + let t = match aargs with Some t -> t - | None -> (fun _ -> []), + | None -> (fun _ -> []), (function [] -> Some [] | _ -> None) in - ((fun args -> Attr (id, (fst t) args)), - - (fun attrs -> + ((fun args -> Attr (id, (fst t) args)), + + (fun attrs -> (* Find the attributes with the same ID *) - List.fold_left - (fun acc a -> - match acc, a with + List.fold_left + (fun acc a -> + match acc, a with Some _, _ -> acc (* We found one already *) - | None, Attr(id', args) when id = id' -> + | None, Attr(id', args) when id = id' -> (* Now match the arguments *) - (snd t) args + (snd t) args | None, _ -> acc) None attrs)) @@ -221,7 +220,7 @@ let doAttr (id: string) type falist = formatArg list -type maybeInit = +type maybeInit = NoInit | InitExp of exp | InitCall of lval * exp list @@ -248,7 +247,7 @@ type maybeInit = %token SIZEOF ALIGNOF -%token EQ +%token EQ %token ARROW DOT %token EQ_EQ EXCLAM_EQ INF SUP INF_EQ SUP_EQ @@ -334,7 +333,7 @@ type maybeInit = %% -initialize: +initialize: /* empty */ { } ; @@ -342,39 +341,39 @@ initialize: expression: -| ARG_e { (* Count arguments eagerly *) - let currentArg = $1 in +| ARG_e { (* Count arguments eagerly *) + let currentArg = $1 in ((fun args -> - match getArg currentArg args with + match getArg currentArg args with Fe e -> e - | a -> wrongArgType currentArg + | a -> wrongArgType currentArg "expression" a), (fun e -> Some [ Fe e ])) - } + } | constant { $1 } | lval %prec IDENT { ((fun args -> Lval ((fst $1) args)), - (fun e -> match e with - Lval l -> (snd $1) l + (fun e -> match e with + Lval l -> (snd $1) l | _ -> None)) - } + } | SIZEOF expression { ((fun args -> SizeOfE ((fst $2) args)), - fun e -> match e with + fun e -> match e with SizeOfE e' -> (snd $2) e' | _ -> None) } | SIZEOF LPAREN typename RPAREN { ((fun args -> SizeOf ((fst $3) args)), - - (fun e -> match e with + + (fun e -> match e with SizeOf t -> (snd $3) t | _ -> None)) } @@ -391,7 +390,7 @@ expression: (fun e -> match e with AlignOf t' -> (snd $3) t' | _ -> None)) - } + } | PLUS expression { $2 } @@ -405,75 +404,75 @@ expression: { doUnop BNot $2 } | argu expression %prec ARG_u - { ((fun args -> + { ((fun args -> let e = (fst $2) args in UnOp((fst $1) args, e, typeOf e)), - (fun e -> match e with + (fun e -> match e with UnOp(uo, e', _) -> begin - match (snd $1) uo, (snd $2) e' with + match (snd $1) uo, (snd $2) e' with Some m1, Some m2 -> Some (m1 @ m2) | _ -> None end | _ -> None)) - } - - + } + + | AND expression %prec ADDROF - { ((fun args -> + { ((fun args -> match (fst $2) args with Lval l -> mkAddrOf l | _ -> E.s (bug "AddrOf applied to a non lval")), - (fun e -> match e with + (fun e -> match e with AddrOf l -> (snd $2) (Lval l) - | e -> (snd $2) (Lval (mkMem e NoOffset)))) + | e -> (snd $2) (Lval (mkMem ~addr:e ~off:NoOffset)))) } -| LPAREN expression RPAREN +| LPAREN expression RPAREN { $2 } | expression PLUS expression - { ((fun args -> buildPlus ((fst $1) args) - ((fst $3) args)), - (fun e -> match e with + { ((fun args -> buildPlus ((fst $1) args) + ((fst $3) args)), + (fun e -> match e with BinOp((PlusPI|PlusA), e1, e2, _) -> begin match (snd $1) e1, (snd $3) e2 with Some m1, Some m2 -> Some (m1 @ m2) | _, _ -> None end | _ -> None)) - } + } | expression MINUS expression { ((fun args -> buildMinus ((fst $1) args) ((fst $3) args)), - (fun e -> match e with - BinOp((MinusPP|MinusPI|MinusA), e1, e2, _) -> + (fun e -> match e with + BinOp((MinusPP|MinusPI|MinusA), e1, e2, _) -> begin match (snd $1) e1, (snd $3) e2 with Some m1, Some m2 -> Some (m1 @ m2) | _, _ -> None end | _ -> None)) - } + } | expression argb expression %prec ARG_b - { ((fun args -> - let e1 = (fst $1) args in + { ((fun args -> + let e1 = (fst $1) args in let bop = (fst $2) args in - let e2 = (fst $3) args in + let e2 = (fst $3) args in let t1 = typeOf e1 in BinOp(bop, e1, e2, t1)), - - (fun e -> match e with + + (fun e -> match e with BinOp(bop, e1, e2, _) -> begin match (snd $1) e1,(snd $2) bop,(snd $3) e2 with - Some m1, Some m2, Some m3 -> + Some m1, Some m2, Some m3 -> Some (m1 @ m2 @ m3) | _, _, _ -> None end | _ -> None)) - } + } | expression STAR expression { doBinop Mult $1 $3 } @@ -505,21 +504,21 @@ expression: { doBinop Ge $1 $3 } | LPAREN typename RPAREN expression - { ((fun args -> + { ((fun args -> let t = (fst $2) args in let e = (fst $4) args in - mkCast e t), - - (fun e -> - let t', e' = - match e with + mkCast ~e:e ~newt:t), + + (fun e -> + let t', e' = + match e with CastE (t', e') -> t', e' | _ -> typeOf e, e in match (snd $2) t', (snd $4 e') with Some m1, Some m2 -> Some (m1 @ m2) | _, _ -> None)) - } + } ; /*(* Separate the ARG_ to ensure that the counting of arguments is right *)*/ @@ -531,7 +530,7 @@ argu : | a -> wrongArgType currentArg "unnop" a), fun uo -> Some [ Fu uo ]) - } + } ; argb : @@ -542,7 +541,7 @@ argb : | a -> wrongArgType currentArg "binop" a), fun bo -> Some [ Fb bo ]) - } + } ; constant: @@ -552,11 +551,11 @@ constant: Fd n -> integer n | a -> wrongArgType currentArg "integer" a), - fun e -> match e with - Const(CInt64(n, _, _)) -> + fun e -> match e with + Const(CInt64(n, _, _)) -> Some [ Fd (Int64.to_int n) ] - | _ -> None) - } + | _ -> None) + } | ARG_g { let currentArg = $1 in ((fun args -> @@ -564,16 +563,16 @@ constant: Fg s -> Const(CStr s) | a -> wrongArgType currentArg "string" a), - fun e -> match e with + fun e -> match e with Const(CStr s) -> Some [ Fg s ] - | _ -> None) - } + | _ -> None) + } | CST_INT { let n = parseInt $1 in ((fun args -> n), - (fun e -> match e, n with - Const(CInt64(e', _, _)), + (fun e -> match e, n with + Const(CInt64(e', _, _)), Const(CInt64(n', _, _)) when e' = n' -> Some [] | _ -> None)) } @@ -581,10 +580,10 @@ constant: /*(***************** LVALUES *******************)*/ -lval: +lval: | ARG_l { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with + ((fun args -> + match getArg currentArg args with Fl l -> l | Fv v -> Var v, NoOffset | a -> wrongArgType currentArg "lval" a), @@ -593,40 +592,40 @@ lval: } | argv offset %prec ARG_v - { ((fun args -> + { ((fun args -> let v = (fst $1) args in (Var v, (fst $2) v.vtype args)), - (fun l -> match l with + (fun l -> match l with Var vi, off -> begin - match (snd $1) vi, (snd $2) off with + match (snd $1) vi, (snd $2) off with Some m1, Some m2 -> Some (m1 @ m2) | _ -> None end | _ -> None)) } -| STAR expression { ((fun args -> mkMem ((fst $2) args) NoOffset), +| STAR expression { ((fun args -> mkMem ~addr:((fst $2) args) ~off:NoOffset), - (fun l -> match l with + (fun l -> match l with Mem e, NoOffset -> (snd $2) e | _, _ -> None)) } -| expression ARROW IDENT offset - { ((fun args -> +| expression ARROW IDENT offset + { ((fun args -> let e = (fst $1) args in - let baset = - match unrollTypeDeep (typeOf e) with + let baset = + match unrollTypeDeep (typeOf e) with TPtr (t, _) -> t | _ -> E.s (bug "Expecting a pointer for field %s\n" $3) in let fi = getField baset $3 in - mkMem e (Field(fi, (fst $4) fi.ftype args))), + mkMem ~addr:e ~off:(Field(fi, (fst $4) fi.ftype args))), - (fun l -> match l with + (fun l -> match l with Mem e, Field(fi, off) when fi.fname = $3 -> begin - match (snd $1) e, (snd $4) off with + match (snd $1) e, (snd $4) off with Some m1, Some m2 -> Some (m1 @ m2) | _, _ -> None end @@ -634,18 +633,18 @@ lval: } | LPAREN STAR expression RPAREN offset - { ((fun args -> + { ((fun args -> let e = (fst $3) args in - let baset = - match unrollTypeDeep (typeOf e) with + let baset = + match unrollTypeDeep (typeOf e) with TPtr (t, _) -> t | _ -> E.s (bug "Expecting a pointer\n") in - mkMem e ((fst $5) baset args)), + mkMem ~addr:e ~off:((fst $5) baset args)), - (fun l -> match l with + (fun l -> match l with Mem e, off -> begin - match (snd $3) e, (snd $5 off) with + match (snd $3) e, (snd $5 off) with Some m1, Some m2 -> Some (m1 @ m2) | _, _ -> None end @@ -661,23 +660,23 @@ argv : | a -> wrongArgType currentArg "varinfo" a), fun v -> Some [ Fv v ]) - } + } | IDENT { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with + ((fun args -> + match getArg currentArg args with Fv v -> v | a -> wrongArgType currentArg "varinfo" a), - (fun v -> + (fun v -> E.s (bug "identifiers (%s) are not supported for deconstruction" currentArg))) - } + } ; - + /*(********** OFFSETS *************)*/ -offset: +offset: | ARG_o { let currentArg = $1 in - ((fun t args -> - match getArg currentArg args with + ((fun t args -> + match getArg currentArg args with Fo o -> o | a -> wrongArgType currentArg "offset" a), @@ -686,34 +685,34 @@ offset: | /* empty */ { ((fun t args -> NoOffset), - (fun off -> match off with + (fun off -> match off with NoOffset -> Some [] | _ -> None)) } -| DOT IDENT offset { ((fun t args -> +| DOT IDENT offset { ((fun t args -> let fi = getField t $2 in Field (fi, (fst $3) fi.ftype args)), - (fun off -> match off with - Field (fi, off') when fi.fname = $2 -> + (fun off -> match off with + Field (fi, off') when fi.fname = $2 -> (snd $3) off' | _ -> None)) } | LBRACKET expression RBRACKET offset - { ((fun t args -> - let bt = - match unrollType t with - TArray(bt, _, _) -> bt + { ((fun t args -> + let bt = + match unrollType t with + TArray(bt, _, _) -> bt | _ -> E.s (error "Formatcil: expecting an array for index") in - let e = (fst $2) args in + let e = (fst $2) args in Index(e, (fst $4) bt args)), - (fun off -> match off with + (fun off -> match off with Index (e, off') -> begin - match (snd $2) e, (snd $4) off with + match (snd $2) e, (snd $4) off with Some m1, Some m2 -> Some (m1 @ m2) | _, _ -> None end @@ -723,94 +722,94 @@ offset: /*(************ TYPES **************)*/ -typename: one_formal { ((fun args -> +typename: one_formal { ((fun args -> let (_, ft, _) = (fst $1) args in ft), (fun t -> (snd $1) ("", t, []))) - } + } ; -one_formal: +one_formal: /*(* Do not allow attributes for the name *)*/ | type_spec attributes decl - { ((fun args -> + { ((fun args -> let tal = (fst $2) args in let ts = (fst $1) tal args in let (fn, ft, _) = (fst $3) ts args in (fn, ft, [])), - (fun (fn, ft, fa) -> - match (snd $3) (fn, ft) with + (fun (fn, ft, fa) -> + match (snd $3) (fn, ft) with Some (restt, m3) -> begin - match (snd $1) restt, + match (snd $1) restt, (snd $2) (typeAttrs restt)with - Some m1, Some m2 -> + Some m1, Some m2 -> Some (m1 @ m2 @ m3) | _, _ -> None end | _ -> None)) - } + } -| ARG_f +| ARG_f { let currentArg = $1 in - ((fun args -> + ((fun args -> match getArg currentArg args with Ff (fn, ft, fa) -> (fn, ft, fa) | a -> wrongArgType currentArg "formal" a), (fun (fn, ft, fa) -> Some [ Ff (fn, ft, fa) ])) - } + } ; -type_spec: +type_spec: | ARG_t { let currentArg = $1 in - ((fun al args -> - match getArg currentArg args with + ((fun al args -> + match getArg currentArg args with Ft t -> typeAddAttributes al t | a -> wrongArgType currentArg "type" a), - + (fun t -> Some [ Ft t ])) } | VOID { ((fun al args -> TVoid al), - (fun t -> match unrollType t with + (fun t -> match unrollType t with TVoid _ -> Some [] | _ -> None)) } | ARG_k { let currentArg = $1 in - ((fun al args -> - match getArg currentArg args with + ((fun al args -> + match getArg currentArg args with Fk ik -> TInt(ik, al) | a -> wrongArgType currentArg "ikind" a), - (fun t -> match unrollType t with + (fun t -> match unrollType t with TInt(ik, _) -> Some [ Fk ik ] | _ -> None)) - } + } | CHAR { ((fun al args -> TInt(IChar, al)), (matchIntType IChar)) } -| UNSIGNED CHAR { ((fun al args -> TInt(IUChar, al)), +| UNSIGNED CHAR { ((fun al args -> TInt(IUChar, al)), matchIntType IUChar) } -| SHORT { ((fun al args -> TInt(IShort, al)), +| SHORT { ((fun al args -> TInt(IShort, al)), matchIntType IShort) } -| UNSIGNED SHORT { ((fun al args -> TInt(IUShort, al)), +| UNSIGNED SHORT { ((fun al args -> TInt(IUShort, al)), matchIntType IUShort) } -| INT { ((fun al args -> TInt(IInt, al)), +| INT { ((fun al args -> TInt(IInt, al)), matchIntType IInt) } | UNSIGNED INT { ((fun al args -> TInt(IUInt, al)), matchIntType IUInt) } -| LONG { ((fun al args -> TInt(ILong, al)), +| LONG { ((fun al args -> TInt(ILong, al)), matchIntType ILong) } -| UNSIGNED LONG { ((fun al args -> TInt(IULong, al)), +| UNSIGNED LONG { ((fun al args -> TInt(IULong, al)), matchIntType IULong) } -| LONG LONG { ((fun al args -> TInt(ILongLong, al)), - +| LONG LONG { ((fun al args -> TInt(ILongLong, al)), + matchIntType ILongLong) } | UNSIGNED LONG LONG { ((fun al args -> TInt(IULongLong, al)), @@ -819,120 +818,120 @@ type_spec: } | FLOAT { ((fun al args -> TFloat(FFloat, al)), - matchFloatType FFloat) + matchFloatType FFloat) } | DOUBLE { ((fun al args -> TFloat(FDouble, al)), matchFloatType FDouble) } | STRUCT ARG_c { let currentArg = $2 in - ((fun al args -> - match getArg currentArg args with + ((fun al args -> + match getArg currentArg args with Fc ci -> TComp(ci, al) | a -> wrongArgType currentArg "compinfo" a), - (fun t -> match unrollType t with + (fun t -> match unrollType t with TComp(ci, _) -> Some [ Fc ci ] | _ -> None)) } | UNION ARG_c { let currentArg = $2 in - ((fun al args -> - match getArg currentArg args with + ((fun al args -> + match getArg currentArg args with Fc ci -> TComp(ci, al) | a -> wrongArgType currentArg "compinfo" a), - (fun t -> match unrollType t with + (fun t -> match unrollType t with TComp(ci, _) -> Some [ Fc ci ] | _ -> None)) } -| TYPEOF LPAREN expression RPAREN - { ((fun al args -> typeAddAttributes al +| TYPEOF LPAREN expression RPAREN + { ((fun al args -> typeAddAttributes al (typeOf ((fst $3) args))), - + (fun t -> E.s (bug "Cannot match typeof(e)\n"))) - } + } ; -decl: -| STAR attributes decl - { ((fun ts args -> +decl: +| STAR attributes decl + { ((fun ts args -> let al = (fst $2) args in (fst $3) (TPtr(ts, al)) args), - (fun (fn, ft) -> - match (snd $3) (fn, ft) with + (fun (fn, ft) -> + match (snd $3) (fn, ft) with Some (TPtr(bt, al), m2) -> begin - match (snd $2) al with + match (snd $2) al with Some m1 -> Some (bt, m1 @ m2) | _ -> None end | _ -> None)) - } + } | direct_decl { $1 } ; -direct_decl: +direct_decl: | /* empty */ { ((fun ts args -> ("", ts, [])), (* Match any name in this case *) - (fun (fn, ft) -> + (fun (fn, ft) -> Some (unrollType ft, []))) } | IDENT { ((fun ts args -> ($1, ts, [])), - (fun (fn, ft) -> - if fn = "" || fn = $1 then - Some (unrollType ft, []) - else + (fun (fn, ft) -> + if fn = "" || fn = $1 then + Some (unrollType ft, []) + else None)) } -| LPAREN attributes decl RPAREN - { ((fun ts args -> +| LPAREN attributes decl RPAREN + { ((fun ts args -> let al = (fst $2) args in (fst $3) (typeAddAttributes al ts) args), (fun (fn, ft) -> begin match (snd $3) (fn, ft) with Some (restt, m2) -> begin - match (snd $2) (typeAttrs restt) with + match (snd $2) (typeAttrs restt) with Some m1 -> Some (restt, m1 @ m2) | _ -> None end | _ -> None end)) - } + } | direct_decl LBRACKET exp_opt RBRACKET - { ((fun ts args -> + { ((fun ts args -> (fst $1) (TArray(ts, (fst $3) args, [])) args), - (fun (fn, ft) -> - match (snd $1) (fn, ft) with + (fun (fn, ft) -> + match (snd $1) (fn, ft) with Some (TArray(bt, lo, _), m1) -> begin - match (snd $3) lo with + match (snd $3) lo with Some m2 -> Some (unrollType bt, m1 @ m2) | _ -> None - end + end | _ -> None)) } /*(* We use parentheses around the function to avoid conflicts *)*/ -| LPAREN attributes decl RPAREN LPAREN parameters RPAREN - { ((fun ts args -> +| LPAREN attributes decl RPAREN LPAREN parameters RPAREN + { ((fun ts args -> let al = (fst $2) args in let pars, isva = (fst $6) args in (fst $3) (TFun(ts, pars, isva, al)) args), - (fun (fn, ft) -> - match (snd $3) (fn, ft) with + (fun (fn, ft) -> + match (snd $3) (fn, ft) with Some (TFun(rt, args, isva, al), m1) -> begin - match (snd $2) al, (snd $6) (args, isva) with - Some m2, Some m6 + match (snd $2) al, (snd $6) (args, isva) with + Some m2, Some m6 -> Some (unrollType rt, m1 @ m2 @ m6) | _ -> None end @@ -940,86 +939,86 @@ direct_decl: } ; -parameters: +parameters: | /* empty */ { ((fun args -> (None, false)), (* Match any formals *) - (fun (pars, isva) -> - match pars, isva with - (_, false) -> Some [] + (fun (pars, isva) -> + match pars, isva with + (_, false) -> Some [] | _ -> None)) - } + } -| parameters_ne { ((fun args -> - let (pars : (string * typ * attributes) list), +| parameters_ne { ((fun args -> + let (pars : (string * typ * attributes) list), (isva : bool) = (fst $1) args in (Some pars), isva), - (function + (function ((Some pars), isva) -> (snd $1) (pars, isva) | _ -> None)) - } + } ; -parameters_ne: -| ELLIPSIS +parameters_ne: +| ELLIPSIS { ((fun args -> ([], true)), - (function - ([], true) -> Some [] + (function + ([], true) -> Some [] | _ -> None)) } | ARG_va { let currentArg = $1 in - ((fun args -> + ((fun args -> match getArg currentArg args with Fva isva -> ([], isva) | a -> wrongArgType currentArg "vararg" a), - (function - ([], isva) -> Some [ Fva isva ] + (function + ([], isva) -> Some [ Fva isva ] | _ -> None)) - } + } | ARG_F { let currentArg = $1 in - ((fun args -> + ((fun args -> match getArg currentArg args with FF fl -> ( fl, false) | a -> wrongArgType currentArg "formals" a), - (function - (pars, false) -> Some [ FF pars ] + (function + (pars, false) -> Some [ FF pars ] | _ -> None)) - } + } | one_formal { ((fun args -> ([(fst $1) args], false)), - (function - ([ f ], false) -> (snd $1) f + (function + ([ f ], false) -> (snd $1) f | _ -> None)) } | one_formal COMMA parameters_ne - { ((fun args -> + { ((fun args -> let this = (fst $1) args in let (rest, isva) = (fst $3) args in (this :: rest, isva)), - (function + (function ((f::rest, isva)) -> begin - match (snd $1) f, (snd $3) (rest, isva) with + match (snd $1) f, (snd $3) (rest, isva) with Some m1, Some m2 -> Some (m1 @ m2) | _, _ -> None end | _ -> None)) - } + } ; -exp_opt: +exp_opt: /* empty */ { ((fun args -> None), (* Match anything if the pattern does not have a len *) (fun _ -> Some [])) } @@ -1029,7 +1028,7 @@ exp_opt: (fun lo -> match lo with Some e -> (snd $1) e | _ -> None)) - } + } | ARG_eo { let currentArg = $1 in ((fun args -> match getArg currentArg args with @@ -1037,25 +1036,25 @@ exp_opt: | a -> wrongArgType currentArg "exp_opt" a), fun lo -> Some [ Feo lo ]) - } + } ; -attributes: +attributes: /*(* Ignore other attributes *)*/ - /* empty */ { ((fun args -> []), + /* empty */ { ((fun args -> []), (fun attrs -> Some [])) } - + | ARG_A { let currentArg = $1 in - ((fun args -> + ((fun args -> match getArg currentArg args with FA al -> al | a -> wrongArgType currentArg "attributes" a), (fun al -> Some [ FA al ])) - } - + } + | attribute attributes { ((fun args -> addAttribute ((fst $1) args) ((fst $2) args)), @@ -1064,88 +1063,88 @@ attributes: match (snd $1) attrs, (snd $2) attrs with Some m1, Some m2 -> Some (m1 @ m2) | _, _ -> None)) - } + } ; attribute: | CONST { doAttr "const" None } | RESTRICT { doAttr "restrict" None } | VOLATILE { doAttr "volatile" None } -| ATTRIBUTE LPAREN LPAREN attr RPAREN RPAREN +| ATTRIBUTE LPAREN LPAREN attr RPAREN RPAREN { $4 } ; - -attr: -| IDENT + +attr: +| IDENT { doAttr $1 None } - -| IDENT LPAREN attr_args_ne RPAREN + +| IDENT LPAREN attr_args_ne RPAREN { doAttr $1 (Some $3) } ; -attr_args_ne: +attr_args_ne: attr_arg { ((fun args -> [ (fst $1) args ]), - (fun aargs -> match aargs with + (fun aargs -> match aargs with [ arg ] -> (snd $1) arg | _ -> None)) - } -| attr_arg COMMA attr_args_ne { ((fun args -> + } +| attr_arg COMMA attr_args_ne { ((fun args -> let this = (fst $1) args in this :: ((fst $3) args)), - (fun aargs -> match aargs with + (fun aargs -> match aargs with h :: rest -> begin match (snd $1) h, (snd $3) rest with Some m1, Some m2 -> Some (m1 @ m2) | _, _ -> None end | _ -> None)) - } + } | ARG_P { let currentArg = $1 in - ((fun args -> + ((fun args -> match getArg currentArg args with FP al -> al | a -> wrongArgType currentArg "attrparams" a), (fun al -> Some [ FP al ])) - } + } ; -attr_arg: +attr_arg: | IDENT { ((fun args -> ACons($1, [])), - (fun aarg -> match aarg with + (fun aarg -> match aarg with ACons(id, []) when id = $1 -> Some [] | _ -> None)) - } -| IDENT LPAREN attr_args_ne RPAREN + } +| IDENT LPAREN attr_args_ne RPAREN { ((fun args -> ACons($1, (fst $3) args)), - (fun aarg -> match aarg with - ACons(id, args) when id = $1 -> + (fun aarg -> match aarg with + ACons(id, args) when id = $1 -> (snd $3) args | _ -> None)) - } + } | ARG_p { let currentArg = $1 in - ((fun args -> + ((fun args -> match getArg currentArg args with Fp p -> p | a -> wrongArgType currentArg "attrparam" a), (fun ap -> Some [ Fp ap])) - } - + } + ; /* (********** INSTRUCTIONS ***********) */ -instr: +instr: | ARG_i SEMICOLON { let currentArg = $1 in - ((fun loc args -> - match getArg currentArg args with + ((fun loc args -> + match getArg currentArg args with Fi i -> i | a -> wrongArgType currentArg "instr" a), @@ -1153,7 +1152,7 @@ instr: } | lval EQ expression SEMICOLON - { ((fun loc args -> + { ((fun loc args -> Set((fst $1) args, (fst $3) args, loc)), (fun i -> match i with @@ -1163,28 +1162,28 @@ instr: | _, _ -> None end | _ -> None)) - } + } | lval PLUS_EQ expression SEMICOLON - { ((fun loc args -> + { ((fun loc args -> let l = (fst $1) args in Set(l, buildPlus (Lval l) ((fst $3) args), loc)), - matchBinopEq + matchBinopEq (fun bop -> bop = PlusPI || bop = PlusA) - (snd $1) (snd $3)) + (snd $1) (snd $3)) } | lval MINUS_EQ expression SEMICOLON - { ((fun loc args -> + { ((fun loc args -> let l = (fst $1) args in - Set(l, + Set(l, buildMinus (Lval l) ((fst $3) args), loc)), - matchBinopEq (fun bop -> bop = MinusA - || bop = MinusPP - || bop = MinusPI) - (snd $1) (snd $3)) + matchBinopEq (fun bop -> bop = MinusA + || bop = MinusPP + || bop = MinusPI) + (snd $1) (snd $3)) } | lval STAR_EQ expression SEMICOLON { doBinopEq Mult $1 $3 } @@ -1210,17 +1209,17 @@ instr: | lval SUP_SUP_EQ expression SEMICOLON { doBinopEq Shiftrt $1 $3 } -/* (* Would be nice to be able to condense the next three rules but we get +/* (* Would be nice to be able to condense the next three rules but we get * into conflicts *)*/ | lval EQ lval LPAREN arguments RPAREN SEMICOLON - { ((fun loc args -> - Call(Some ((fst $1) args), Lval ((fst $3) args), + { ((fun loc args -> + Call(Some ((fst $1) args), Lval ((fst $3) args), (fst $5) args, loc)), - (fun i -> match i with + (fun i -> match i with Call(Some l, Lval f, args, loc) -> begin match (snd $1) l, (snd $3) f, (snd $5) args with - Some m1, Some m2, Some m3 -> + Some m1, Some m2, Some m3 -> Some (m1 @ m2 @ m3) | _, _, _ -> None end @@ -1228,11 +1227,11 @@ instr: } | lval LPAREN arguments RPAREN SEMICOLON - { ((fun loc args -> - Call(None, Lval ((fst $1) args), - (fst $3) args, loc)), + { ((fun loc args -> + Call(None, Lval ((fst $1) args), + (fst $3) args, loc)), - (fun i -> match i with + (fun i -> match i with Call(None, Lval f, args, loc) -> begin match (snd $1) f, (snd $3) args with Some m1, Some m2 -> Some (m1 @ m2) @@ -1242,14 +1241,14 @@ instr: } | arglo lval LPAREN arguments RPAREN SEMICOLON - { ((fun loc args -> - Call((fst $1) args, Lval ((fst $2) args), - (fst $4) args, loc)), - - (fun i -> match i with + { ((fun loc args -> + Call((fst $1) args, Lval ((fst $2) args), + (fst $4) args, loc)), + + (fun i -> match i with Call(lo, Lval f, args, loc) -> begin match (snd $1) lo, (snd $2) f, (snd $4) args with - Some m1, Some m2, Some m3 -> + Some m1, Some m2, Some m3 -> Some (m1 @ m2 @ m3) | _, _, _ -> None end @@ -1258,10 +1257,10 @@ instr: ; /* (* Separate this out to ensure that the counting or arguments is right *)*/ -arglo: +arglo: ARG_lo { let currentArg = $1 in - ((fun args -> - let res = + ((fun args -> + let res = match getArg currentArg args with Flo x -> x | a -> wrongArgType currentArg "lval option" a @@ -1269,12 +1268,12 @@ arglo: res), (fun lo -> Some [ Flo lo ])) - } -; -arguments: - /* empty */ { ((fun args -> []), + } +; +arguments: + /* empty */ { ((fun args -> []), - (fun actuals -> match actuals with + (fun actuals -> match actuals with [] -> Some [] | _ -> None)) } @@ -1285,26 +1284,26 @@ arguments: arguments_ne: expression { ((fun args -> [ (fst $1) args ]), - (fun actuals -> match actuals with + (fun actuals -> match actuals with [ h ] -> (snd $1) h | _ -> None)) } | ARG_E { let currentArg = $1 in - ((fun args -> + ((fun args -> match getArg currentArg args with FE el -> el | a -> wrongArgType currentArg "arguments" a), (fun actuals -> Some [ FE actuals ])) - } + } | expression COMMA arguments_ne { ((fun args -> ((fst $1) args) :: ((fst $3) args)), - (fun actuals -> match actuals with + (fun actuals -> match actuals with h :: rest -> begin - match (snd $1) h, (snd $3) rest with + match (snd $1) h, (snd $3) rest with Some m1, Some m2 -> Some (m1 @ m2) | _, _ -> None end @@ -1314,81 +1313,81 @@ arguments_ne: /*(******** STATEMENTS *********)*/ -stmt: +stmt: IF LPAREN expression RPAREN stmt %prec IF - { (fun mkTemp loc args -> - mkStmt (If((fst $3) args, + { (fun mkTemp loc args -> + mkStmt (If((fst $3) args, mkBlock [ $5 mkTemp loc args ], mkBlock [], loc))) } -| IF LPAREN expression RPAREN stmt ELSE stmt - { (fun mkTemp loc args -> - mkStmt (If((fst $3) args, +| IF LPAREN expression RPAREN stmt ELSE stmt + { (fun mkTemp loc args -> + mkStmt (If((fst $3) args, mkBlock [ $5 mkTemp loc args ], mkBlock [ $7 mkTemp loc args], loc))) } -| RETURN exp_opt SEMICOLON - { (fun mkTemp loc args -> - mkStmt (Return((fst $2) args, loc))) +| RETURN exp_opt SEMICOLON + { (fun mkTemp loc args -> + mkStmt (Return((fst $2) args, loc))) } -| BREAK SEMICOLON - { (fun mkTemp loc args -> +| BREAK SEMICOLON + { (fun mkTemp loc args -> mkStmt (Break loc)) } -| CONTINUE SEMICOLON - { (fun mkTemp loc args -> +| CONTINUE SEMICOLON + { (fun mkTemp loc args -> mkStmt (Continue loc)) } -| LBRACE stmt_list RBRACE - { (fun mkTemp loc args -> +| LBRACE stmt_list RBRACE + { (fun mkTemp loc args -> let stmts = $2 mkTemp loc args in mkStmt (Block (mkBlock (stmts)))) } -| WHILE LPAREN expression RPAREN stmt - { (fun mkTemp loc args -> +| WHILE LPAREN expression RPAREN stmt + { (fun mkTemp loc args -> let e = (fst $3) args in - let e = - if isPointerType(typeOf e) then - mkCast e !upointType + let e = + if isPointerType(typeOf e) then + mkCast ~e:e ~newt:!upointType else e in - mkStmt - (Loop (mkBlock [ mkStmt + mkStmt + (Loop (mkBlock [ mkStmt (If(e, mkBlock [], - mkBlock [ mkStmt + mkBlock [ mkStmt (Break loc) ], loc)); $5 mkTemp loc args ], loc, None, None))) - } -| instr_list { (fun mkTemp loc args -> + } +| instr_list { (fun mkTemp loc args -> mkStmt (Instr ($1 loc args))) } | ARG_s { let currentArg = $1 in - (fun mkTemp loc args -> + (fun mkTemp loc args -> match getArg currentArg args with Fs s -> s | a -> wrongArgType currentArg "stmt" a) } ; -stmt_list: +stmt_list: /* empty */ { (fun mkTemp loc args -> []) } | ARG_S { let currentArg = $1 in - (fun mkTemp loc args -> - match getArg currentArg args with - | FS sl -> sl + (fun mkTemp loc args -> + match getArg currentArg args with + | FS sl -> sl | a -> wrongArgType currentArg "stmts" a) } -| stmt stmt_list - { (fun mkTemp loc args -> +| stmt stmt_list + { (fun mkTemp loc args -> let this = $1 mkTemp loc args in this :: ($2 mkTemp loc args)) } /* (* We can also have a declaration *) */ -| type_spec attributes decl maybe_init SEMICOLON stmt_list - { (fun mkTemp loc args -> +| type_spec attributes decl maybe_init SEMICOLON stmt_list + { (fun mkTemp loc args -> let tal = (fst $2) args in let ts = (fst $1) tal args in let (n, t, _) = (fst $3) ts args in @@ -1397,35 +1396,35 @@ stmt_list: let v = mkTemp n t in (* Now we parse the rest *) let rest = $6 mkTemp loc ((n, Fv v) :: args) in - (* Now we add the initialization instruction to the + (* Now we add the initialization instruction to the * front *) - match init with + match init with NoInit -> rest - | InitExp e -> - mkStmtOneInstr (Set((Var v, NoOffset), e, loc)) + | InitExp e -> + mkStmtOneInstr (Set((Var v, NoOffset), e, loc)) :: rest | InitCall (f, args) -> - mkStmtOneInstr (Call(Some (Var v, NoOffset), + mkStmtOneInstr (Call(Some (Var v, NoOffset), Lval f, args, loc)) :: rest ) - } + } ; instr_list: - /*(* Set this rule to very low precedence to ensure that we shift as + /*(* Set this rule to very low precedence to ensure that we shift as many instructions as possible *)*/ - instr %prec COMMA + instr %prec COMMA { (fun loc args -> [ ((fst $1) loc args) ]) } | ARG_I { let currentArg = $1 in - (fun loc args -> - match getArg currentArg args with - | FI il -> il + (fun loc args -> + match getArg currentArg args with + | FI il -> il | a -> wrongArgType currentArg "instrs" a) } -| instr instr_list - { (fun loc args -> +| instr instr_list + { (fun loc args -> let this = (fst $1) loc args in this :: ($2 loc args)) } @@ -1435,15 +1434,8 @@ instr_list: maybe_init: | { (fun args -> NoInit) } | EQ expression { (fun args -> InitExp ((fst $2) args)) } -| EQ lval LPAREN arguments RPAREN - { (fun args -> +| EQ lval LPAREN arguments RPAREN + { (fun args -> InitCall((fst $2) args, (fst $4) args)) } ; %% - - - - - - - diff --git a/src/frontc/cabs.ml b/src/frontc/cabs.ml index 59d14be17..04513c27c 100644 --- a/src/frontc/cabs.ml +++ b/src/frontc/cabs.ml @@ -1,11 +1,11 @@ -(* +(* * - * Copyright (c) 2001-2002, + * 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: @@ -35,10 +35,10 @@ * *) -(** This file was originally part of Hugues Casee's frontc 2.0, and has been - * extensively changed since. +(** This file was originally part of Hugues Casee's frontc 2.0, and has been + * extensively changed since. ** -** 1.0 3.22.99 Hugues Cassé First version. +** 1.0 3.22.99 Hugues Cassé First version. ** 2.0 George Necula 12/12/00: Many extensions **) @@ -60,14 +60,16 @@ type typeSpecifier = (* Merge all specifiers into one type *) | Tshort | Tint | Tlong - | Tint64 + | Tint64 (* TODO needed? *) + | Tint128 (* TODO needed? *) | Tfloat + | Tfloat128 (* TODO needed? *) | Tdouble | Tsigned | Tsizet (* used temporarily to translate offsetof() *) | Tunsigned | Tnamed of string - (* each of the following three kinds of specifiers contains a field + (* 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 @@ -81,11 +83,11 @@ type typeSpecifier = (* Merge all specifiers into one type *) and storage = NO_STORAGE | AUTO | STATIC | EXTERN | REGISTER -and funspec = +and funspec = INLINE | VIRTUAL | EXPLICIT and cvspec = - CV_CONST | CV_VOLATILE | CV_RESTRICT + CV_CONST | CV_VOLATILE | CV_RESTRICT | CV_COMPLEX (* Type specifier elements. These appear at the start of a declaration *) (* Everywhere they appear in this file, they appear as a 'spec_elem list', *) @@ -93,7 +95,7 @@ and cvspec = (* 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 + SpecTypedef | SpecCV of cvspec (* const/volatile *) | SpecAttr of attribute (* __attribute__ *) | SpecStorage of storage @@ -124,7 +126,7 @@ and decl_type = (* 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 + | PROTO of decl_type * single_name list * bool (* Prints "decl (args[, ...])". * decl is never a PTR.*) @@ -183,13 +185,13 @@ and file = string * definition list ** statements *) -(* A block contains a list of local label declarations ( GCC's ({ __label__ +(* 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 = +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 = @@ -224,11 +226,11 @@ and statement = asm_details option * (* extra details to guide GCC's optimizer *) cabsloc - (** MS SEH *) + (* MS SEH *) | TRY_EXCEPT of block * expression * block * cabsloc | TRY_FINALLY of block * block * cabsloc - -and for_clause = + +and for_clause = FC_EXP of expression | FC_DECL of definition @@ -259,13 +261,16 @@ and 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 + __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 + | REAL of expression + | IMAG of expression + | CLASSIFYTYPE of expression | EXPR_SIZEOF of expression | TYPE_SIZEOF of specifier * decl_type | EXPR_ALIGNOF of expression @@ -279,15 +284,16 @@ and expression = and constant = | CONST_INT of string (* the textual representation *) | CONST_FLOAT of string (* the textual representaton *) + | CONST_COMPLEX of string (* the textual representation *) | CONST_CHAR of int64 list | CONST_WCHAR of int64 list | CONST_STRING of string - | CONST_WSTRING of int64 list + | 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 + * 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. *) + * passing it to Cil. *) and init_expression = | NO_INIT @@ -299,10 +305,8 @@ and initwhat = | 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 - - diff --git a/src/frontc/cabs2cil.ml b/src/frontc/cabs2cil.ml index dc185e133..cb4de68ad 100644 --- a/src/frontc/cabs2cil.ml +++ b/src/frontc/cabs2cil.ml @@ -1,11 +1,11 @@ (* * - * Copyright (c) 2001-2002, + * 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: @@ -54,7 +54,7 @@ open Cilint open Trace -let mydebugfunction () = +let mydebugfunction () = E.s (error "mydebugfunction") let debugGlobal = false @@ -67,6 +67,15 @@ let forceRLArgEval = ref false (** Leave a certain global alone. Use a negative number to disable. *) let nocil: int ref = ref (-1) +(** Set to true to generate VarDecl "instructions" for all local variables + * In some circumstances, it is unavoidable to generate VarDecls (namely + * for variable length arrays (VLAs)). In these cases, we generate a VarDecl + * even if alwaysGenerateVarDecl is false. + * Under certain conditions (involving GNU computed gotos), it is not possible + * to generate VarDecls for all locals, in these cases we do not generate them + * *) +let alwaysGenerateVarDecl = false + (** Indicates whether we're allowed to duplicate small chunks. *) let allowDuplication: bool ref = ref true @@ -96,7 +105,7 @@ let typeForTypeof: (Cil.typ -> Cil.typ) ref = ref (fun t -> t) types of cabs2cil-introduced temp variables. *) let typeForInsertedVar: (Cil.typ -> Cil.typ) ref = ref (fun t -> t) -(** Like [typeForInsertedVar], but for casts. +(** Like [typeForInsertedVar], but for casts. * Casts in the source code are exempt from this hook. *) let typeForInsertedCast: (Cil.typ -> Cil.typ) ref = ref (fun t -> t) @@ -113,14 +122,14 @@ let attrsForCombinedArg: ((string, string) H.t -> (* ---------- source error message handling ------------- *) let lu = locUnknown -let cabslu = {lineno = -10; - filename = "cabs lu"; +let cabslu = {lineno = -10; + filename = "cabs lu"; byteno = -10; ident = 0;} (** Interface to the Cprint printer *) -let withCprint (f: 'a -> unit) (x: 'a) : unit = +let withCprint (f: 'a -> unit) (x: 'a) : unit = Cprint.commit (); Cprint.flush (); let old = (Whitetrack.getOutput()) in Whitetrack.setOutput !E.logChannel; @@ -130,29 +139,31 @@ let withCprint (f: 'a -> unit) (x: 'a) : unit = Whitetrack.setOutput old -(** Keep a list of the variable ID for the variables that were created to +(** 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 +let allTempVars: 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 prefix p s = let lp = String.length p in let ls = String.length s in lp <= ls && String.sub s 0 lp = p (***** 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 +(* The address of labels are small integers (starting from 0). A computed + * goto is replaced with a switch on the address of the label. We generate + * only one such switch and we'll jump to it from all computed gotos. To + * accomplish this we'll add a local variable to store the target of the * goto. *) -(* The local variable in which to put the detination of the goto and the - * statement where to jump *) +(* The local variable in which to put the destination of the goto and the + * statement where to jump *) let gotoTargetData: (varinfo * stmt) option ref = ref None (* The "addresses" of labels *) @@ -161,38 +172,38 @@ let gotoTargetNextAddr: int ref = ref 0 (********** TRANSPARENT UNION ******) -(* Check if a type is a transparent union, and return the first field if it +(* 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 -> +let isTransparentUnion (t: typ) : fieldinfo option = + match unrollType t with + TComp (comp, _) when not comp.cstruct -> (* Turn transparent unions into the type of their first field *) if hasAttribute "transparent_union" (typeAttrs t) then begin match comp.cfields with f :: _ -> Some f | _ -> E.s (unimp "Empty transparent union: %s" (compFullName comp)) - end else + 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 +(* 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 - ignore (E.log "convLoc at %s: line %d, btye %d\n" l.filename l.lineno l.byteno); + if debugLoc then + ignore (E.log "convLoc at %s: line %d, byte %d\n" l.filename l.lineno l.byteno); {line = l.lineno; file = l.filename; byte = l.byteno;} -let isOldStyleVarArgName n = +let isOldStyleVarArgName n = if !msvcMode then n = "va_alist" else n = "__builtin_va_alist" -let isOldStyleVarArgTypeName n = - if !msvcMode then n = "va_list" || n = "__ccured_va_list" +let isOldStyleVarArgTypeName n = + if !msvcMode then n = "va_list" || n = "__ccured_va_list" else n = "__builtin_va_alist_t" let isVariadicListType t = @@ -213,10 +224,10 @@ let isVariadicListType t = * 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"). + * 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. + * multiply and add to get the desired value. *) (* Given a character constant (like 'a' or 'abc') as a list of 64-bit @@ -231,14 +242,14 @@ let reduce_multichar typ : int64 list -> int64 = let interpret_character_constant char_list = let value = reduce_multichar charType char_list in - if value < (Int64.of_int 256) then + 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(value,IULong,orig_rep)),(TInt(IULong,[])) - else + else (CInt64(value,IULongLong,orig_rep)),(TInt(IULongLong,[])) end @@ -250,38 +261,38 @@ let theFileTypes : global list ref = ref [] let initGlobals () = theFile := []; theFileTypes := [] - -let cabsPushGlobal (g: global) = + +let cabsPushGlobal (g: global) = pushGlobal g ~types:theFileTypes ~variables:theFile -(* 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 +(* 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 +(* Globals that were created due to static local variables. We chose their + * names to be distinct from any global encountered at the time. But we might * see a global with conflicting name later in the file. *) let staticLocals: (string, varinfo) H.t = H.create 13 -(* Typedefs. We chose their names to be distinct from any global encounterd - * at the time. But we might see a global with conflicting name later in the +(* 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 popGlobals () = +let popGlobals () = let rec revonto (tail: global list) = function [] -> tail - | GVarDecl (vi, l) :: rest - when vi.vstorage != Extern && IH.mem mustTurnIntoDef vi.vid -> + | GVarDecl (vi, l) :: rest + when vi.vstorage != Extern && IH.mem mustTurnIntoDef vi.vid -> IH.remove mustTurnIntoDef vi.vid; if vi.vinit.init != None then E.s (E.bug "GVarDecl %s should have empty initializer" vi.vname); @@ -292,11 +303,11 @@ let popGlobals () = revonto (revonto [] !theFile) !theFileTypes (* Like Cil.mkCastT, but it calls typeForInsertedCast *) -let makeCastT ~(e: exp) ~(oldt: typ) ~(newt: typ) = - Cil.mkCastT e oldt (!typeForInsertedCast newt) +let makeCastT ~(e: exp) ~(oldt: typ) ~(newt: typ) = + Cil.mkCastT ~e:e ~oldt:oldt ~newt:(!typeForInsertedCast newt) -let makeCast ~(e: exp) ~(newt: typ) = - makeCastT e (typeOf e) newt +let makeCast ~(e: exp) ~(newt: typ) = + makeCastT ~e:e ~oldt:(typeOf e) ~newt:newt (********* ENVIRONMENTS ***************) @@ -321,12 +332,17 @@ type envdata = * 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 + | 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 + +(* Just like env, except that it simply collects all the information (i.e. entries + * are never removed and it is also not emptied after every file). *) +let environment : (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 @@ -334,79 +350,81 @@ let genv : (string, envdata * location) H.t = H.create 307 * hash table easily *) type undoScope = UndoRemoveFromEnv of string - | UndoResetAlphaCounter of location AL.alphaTableData ref * + | UndoResetAlphaCounter of location AL.alphaTableData ref * location AL.alphaTableData | UndoRemoveFromAlphaTable of string let scopes : undoScope list ref list ref = ref [] -let isAtTopLevel () = +let isAtTopLevel () = !scopes = [] (* When you add to env, you also add it to the current scope *) -let addLocalToEnv (n: string) (d: envdata) = +let addLocalToEnv (n: string) (d: envdata) = (* ignore (E.log "%a: adding local %s to env\n" d_loc !currentLoc n); *) H.add env n (d, !currentLoc); - (* If we are in a scope, then it means we are not at top level. Add the + H.add environment n (d, !currentLoc); + (* 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 _ -> + EnvVar _ -> E.s (E.bug "addLocalToEnv: not in a scope when adding %s!" n) | _ -> () (* We might add types *) end - | s :: _ -> + | s :: _ -> s := (UndoRemoveFromEnv n) :: !s) -let addGlobalToEnv (k: string) (d: envdata) : unit = +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); + H.add environment k (d, !currentLoc); (* Also add it to the global environment *) H.add genv k (d, !currentLoc) - - - -(* 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 + + + +(* Create a new name based on a given name. The new name is formed from a + * prefix (obtained from the given name as the longest prefix that ends with + * a non-digit), followed by a '_' and then by a positive integer suffix. The + * first argument is a table mapping name prefixes with the largest suffix + * used so far for that prefix. The largest suffix is one when only the * version without suffix has been used. *) -let alphaTable : (string, location AL.alphaTableData ref) H.t = H.create 307 - (* vars and enum tags. For composite types we have names like "struct +let alphaTable : (string, location AL.alphaTableData ref) H.t = H.create 307 + (* vars and enum tags. For composite types we have names like "struct * foo" or "union bar" *) -(* 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), +(* To keep different name scopes different, we add prefixes to names + * specifying the kind of name: the kind can be one of "" for variables or + * enum tags, "struct" for structures and unions (they share the name space), * "enum" for enumerations, or "type" for types *) let kindPlusName (kind: string) (origname: string) : string = if kind = "" then origname else kind ^ " " ^ origname - -let stripKind (kind: string) (kindplusname: string) : string = + +let stripKind (kind: string) (kindplusname: string) : string = let l = 1 + String.length kind in - if l > 1 then + if l > 1 then String.sub kindplusname l (String.length kindplusname - l) else kindplusname - + let newAlphaName (globalscope: bool) (* The name should have global scope *) - (kind: string) - (origname: string) : string * location = + (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 + (* If we are in a scope then it means that we are alpha-converting a local + * name. Go and add stuff to reset the state of the alpha table but only to * the top-most scope (that of the enclosing function) *) let rec findEnclosingFun = function [] -> (* At global scope *)() | [s] -> begin - let prefix = AL.getAlphaPrefix lookupname in + let prefix = AL.getAlphaPrefix ~lookupname:lookupname in try let countref = H.find alphaTable prefix in s := (UndoResetAlphaCounter (countref, !countref)) :: !s @@ -415,26 +433,26 @@ let newAlphaName (globalscope: bool) (* The name should have global scope *) end | _ :: rest -> findEnclosingFun rest in - if not globalscope then + if not globalscope then findEnclosingFun !scopes; - let newname, oldloc = - AL.newAlphaName alphaTable None lookupname !currentLoc in + let newname, oldloc = + AL.newAlphaName ~alphaTable:alphaTable ~undolist:None ~lookupname:lookupname ~data:!currentLoc in stripKind kind newname, oldloc - -let explodeString (nullterm: bool) (s: string) : char list = - let rec allChars i acc = + +let explodeString (nullterm: bool) (s: string) : char list = + let rec allChars i acc = if i < 0 then acc else allChars (i - 1) ((String.get s i) :: acc) in - allChars (-1 + String.length s) + allChars (-1 + String.length s) (if nullterm then [Char.chr 0] else []) - -(*** In order to process GNU_BODY expressions we must record that a given + +(*** 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 +let gnu_body_result : (A.statement * ((exp * typ) option ref)) ref = ref (A.NOP cabslu, ref None) (*** When we do statements we need to know the current return type *) @@ -469,7 +487,7 @@ let anonStructName (k: string) (suggested: string) (context: 'a) = let constrExprId = ref 0 -let startFile () = +let startFile () = H.clear env; H.clear genv; H.clear alphaTable; @@ -477,13 +495,13 @@ let startFile () = -let enterScope () = +let enterScope () = scopes := (ref []) :: !scopes - (* Exit a scope and clean the environment. We do not yet delete from + (* Exit a scope and clean the environment. We do not yet delete from * the name table *) -let exitScope () = - let this, rest = +let exitScope () = + let this, rest = match !scopes with car :: cdr -> car, cdr | [] -> E.s (error "Not in a scope") @@ -491,32 +509,32 @@ let exitScope () = scopes := rest; let rec loop = function [] -> () - | UndoRemoveFromEnv n :: t -> + | UndoRemoveFromEnv n :: t -> H.remove env n; loop t | UndoRemoveFromAlphaTable n :: t -> H.remove alphaTable n; loop t - | UndoResetAlphaCounter (vref, oldv) :: t -> + | UndoResetAlphaCounter (vref, oldv) :: t -> vref := oldv; loop t in loop !this -(* Lookup a variable name. Return also the location of the definition. Might +(* Lookup a variable name. Return also the location of the definition. Might * raise Not_found *) -let lookupVar (n: string) : varinfo * location = +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 = + +let lookupGlobalVar (n: string) : varinfo * location = match H.find genv n with (EnvVar vi), loc -> vi, loc | _ -> raise Not_found - -let docEnv () = + +let docEnv () = let acc : (string * (envdata * location)) list ref = ref [] in let doone () = function - EnvVar vi, l -> + EnvVar vi, l -> dprintf "Var(%s,global=%b) (at %a)" vi.vname vi.vglob d_loc l | EnvEnum (tag, typ), l -> dprintf "Enum (at %a)" d_loc l | EnvTyp t, l -> text "typ" @@ -528,22 +546,22 @@ let docEnv () = (* Add a new variable. Do alpha-conversion if necessary *) -let alphaConvertVarAndAddToEnv (addtoenv: bool) (vi: varinfo) : varinfo = +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 + (* 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 + 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 + (* 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 + try let static_local_vi = H.find staticLocals vi.vname in H.remove staticLocals vi.vname; (* Use the new name for the static local *) @@ -551,33 +569,33 @@ let alphaConvertVarAndAddToEnv (addtoenv: bool) (vi: varinfo) : varinfo = (* And continue using the last one *) vi with Not_found -> begin - (* Or perhaps we have seen a typedef which stole our name. This is + (* 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 + 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 -> - E.s (E.error "It seems that we would need to rename global %s (to %s) because of previous occurrence at %a" + with Not_found -> + E.s (E.error "It seems that we would need to rename global %s (to %s) because of previous occurrence at %a" vi.vname newname d_loc 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 + end else begin + (* We have changed the name of a local variable. Can we try to detect + * if the other variable was also local in the same scope? Not for * now. *) copyVarinfo vi newname end end in - (* Store all locals in the slocals (in reversed order). We'll reverse them + (* Store all locals in the slocals (in reversed order). We'll reverse them * and take out the formals at the end of the function *) if not vi.vglob then !currentFunctionFDEC.slocals <- newvi :: !currentFunctionFDEC.slocals; - (if addtoenv then + (if addtoenv then if vi.vglob then addGlobalToEnv vi.vname (EnvVar newvi) else @@ -590,28 +608,28 @@ let alphaConvertVarAndAddToEnv (addtoenv: bool) (vi: varinfo) : varinfo = newvi -(* 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 +(* 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 +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 + 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) -> + | TInt (ik, a) -> let a' = dc a in if a != a' then TInt(ik, a') else t - | TFloat(fk, a) -> + | TFloat(fk, a) -> let a' = dc a in if a != a' then TFloat(fk, a') else t - | TNamed (ti, a) -> + | 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 @@ -620,11 +638,11 @@ let rec stripConstLocalType (t: typ) : typ = end; let a' = dc a in if a != a' then TNamed(ti, a') else t - | TEnum (ei, a) -> + | 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 + + | 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, a) else t @@ -632,10 +650,10 @@ let rec stripConstLocalType (t: typ) : typ = | TComp(ci, a) -> (* Must change both this structure as well as its fields *) List.iter - (fun f -> + (fun f -> let t' = stripConstLocalType f.ftype in if t' != f.ftype then begin - ignore (warnOpt "Stripping \"const\" from field %s of %s" + ignore (warnOpt "Stripping \"const\" from field %s of %s" f.fname (compFullName ci)); f.ftype <- t' end) @@ -644,17 +662,17 @@ let rec stripConstLocalType (t: typ) : typ = (* We never assign functions either *) | TFun(rt, args, va, a) -> t - | TVoid a -> + | TVoid a -> let a' = dc a in if a != a' then TVoid a' else t - | TBuiltin_va_list a -> + | TBuiltin_va_list a -> let a' = dc a in if a != a' then TBuiltin_va_list a' else t let constFoldTypeVisitor = object (self) inherit nopCilVisitor - method vtype t: typ visitAction = + method! vtype t: typ visitAction = match t with - TArray(bt, Some len, a) -> + TArray(bt, Some len, a) -> let len' = constFold true len in ChangeDoChildrenPost ( TArray(bt, Some len', a), @@ -670,8 +688,8 @@ let constFoldType (t:typ) : typ = let typeSigNoAttrs: typ -> typsig = typeSigWithAttrs (fun _ -> []) (* Create a new temporary variable *) -let newTempVar (descr:doc) (descrpure:bool) typ = - if !currentFunctionFDEC == dummyFunDec then +let newTempVar (descr:doc) (descrpure:bool) typ = + if !currentFunctionFDEC == dummyFunDec then E.s (bug "newTempVar called outside a function"); (* ignore (E.log "stripConstLocalType(%a) for temporary\n" d_type typ); *) let t' = (!typeForInsertedVar) (stripConstLocalType typ) in @@ -691,25 +709,25 @@ let newTempVar (descr:doc) (descrpure:bool) typ = vaddrof = false; vreferenced = false; (* sm *) vstorage = NoStorage; - } + } *) -let mkAddrOfAndMark ((b, off) as lval) : exp = +let mkAddrOfAndMark ((b, off) as lval) : exp = (* Mark the vaddrof flag if b is a variable *) - (match b with + (match b with Var vi -> vi.vaddrof <- true | _ -> ()); mkAddrOf lval - + (* Call only on arrays *) -let mkStartOfAndMark ((b, off) as lval) : exp = +let mkStartOfAndMark ((b, off) as lval) : exp = (* Mark the vaddrof flag if b is a variable *) - (match b with + (match b with Var vi -> vi.vaddrof <- true | _ -> ()); let res = StartOf lval in res - + (* Keep a set of self compinfo for composite types *) @@ -717,23 +735,23 @@ 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 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 = +let lookupType (kind: string) + (n: string) : typ * location = try lookupTypeNoError kind n - with Not_found -> + with Not_found -> E.s (error "Cannot find type %s (kind:%s)" n kind) -(* Create the self ref cell and add it to the map. Return also an indication +(* 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) : compinfo * bool = +let createCompInfo (iss: bool) (n: string) : compinfo * bool = (* Add to the self cell set *) let key = (if iss then "struct " else "union ") ^ n in try @@ -745,15 +763,15 @@ let createCompInfo (iss: bool) (n: string) : compinfo * bool = res, true end -(* Create the self ref cell and add it to the map. Return an indication +(* Create the self ref cell and add it to the map. Return an indication * whether this is a new one. *) -let createEnumInfo (n: string) : enuminfo * bool = +let createEnumInfo (n: 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 = { ename = n; eitems = []; + let enum = { ename = n; eitems = []; eattr = []; ereferenced = false; ekind = IInt; } in H.add enumInfoNameEnv n enum; enum, true @@ -761,20 +779,20 @@ let createEnumInfo (n: string) : enuminfo * bool = (* 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 +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 + if kind = "enum" then let enum, isnew = createEnumInfo n in if isnew then cabsPushGlobal (GEnumTagDecl (enum, !currentLoc)); TEnum (enum, a) - else + else let iss = if kind = "struct" then true else false in let self, isnew = createCompInfo iss n in - if isnew then + if isnew then cabsPushGlobal (GCompTagDecl (self, !currentLoc)); TComp (self, a) in @@ -783,23 +801,23 @@ let findCompType (kind: string) (n: string) (a: attributes) = let olda = typeAttrs old in if Util.equals olda a then old else makeForward () with Not_found -> makeForward () - + (* A simple visitor that searchs a statement for labels *) class canDropStmtClass pRes = object inherit nopCilVisitor - - method vstmt s = - if s.labels != [] then + + method! vstmt s = + if s.labels != [] then (pRes := false; SkipChildren) - else + else if !pRes then DoChildren else SkipChildren - method vinst _ = SkipChildren - method vexpr _ = SkipChildren - + method! vinst _ = SkipChildren + method! vexpr _ = SkipChildren + end -let canDropStatement (s: stmt) : bool = +let canDropStatement (s: stmt) : bool = let pRes = ref true in let vis = new canDropStmtClass pRes in ignore (visitCilStmt vis s); @@ -808,40 +826,40 @@ let canDropStatement (s: stmt) : bool = (**** Occasionally we see structs with no name and no fields *) -module BlockChunk = +module BlockChunk = struct type chunk = { stmts: stmt list; - postins: instr list; (* Some instructions to append at - * the ends of statements (in + postins: instr list; (* Some instructions to append at + * the ends of statements (in * reverse order) *) - cases: stmt list; (* A list of case statements - * (statements with Case labels) + cases: stmt list; (* A list of case statements + * (statements with Case labels) * visible at the outer level *) - } + } - let d_chunk () (c: chunk) = + let d_chunk () (c: chunk) = dprintf "@[{ @[%a@] };@?%a@]" (docList ~sep:(chr ';') (d_stmt ())) c.stmts (docList ~sep:(chr ';') (d_instr ())) (List.rev c.postins) - - let empty = + + let empty = { stmts = []; postins = []; cases = []; } - let isEmpty (c: chunk) = + let isEmpty (c: chunk) = c.postins == [] && c.stmts == [] let isNotEmpty (c: chunk) = not (isEmpty c) - let i2c (i: instr) = + let i2c (i: instr) = { empty with postins = [i] } - + (* Occasionally, we'll have to push postins into the statements *) - let pushPostIns (c: chunk) : stmt list = + let pushPostIns (c: chunk) : stmt list = if c.postins = [] then c.stmts else let rec toLast = function - [{skind=Instr il} as s] as stmts -> + [{skind=Instr il; _} as s] as stmts -> s.skind <- Instr (il @ (List.rev c.postins)); stmts @@ -852,98 +870,98 @@ module BlockChunk = compactStmts (toLast c.stmts) - let c2block (c: chunk) : block = + let c2block (c: chunk) : block = { battrs = []; bstmts = pushPostIns c; - } + } - (* Add an instruction at the end. Never refer to this instruction again + (* Add an instruction at the end. Never refer to this instruction again * after you call this *) let (+++) (c: chunk) (i : instr) = {c with postins = i :: c.postins} - (* Append two chunks. Never refer to the original chunks after you call + (* 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: chunk) = + let (@@) (c1: chunk) (c2: chunk) = { stmts = compactStmts (pushPostIns c1 @ c2.stmts); postins = c2.postins; cases = c1.cases @ c2.cases; - } + } let skipChunk = empty - - let returnChunk (e: exp option) (l: location) : chunk = + + let returnChunk (e: exp option) (l: location) : chunk = { stmts = [ mkStmt (Return(e, l)) ]; postins = []; cases = [] } - let ifChunk (be: exp) (l: location) (t: chunk) (e: chunk) : chunk = - + let ifChunk (be: exp) (l: location) (t: chunk) (e: chunk) : chunk = + { stmts = [ mkStmt(If(be, c2block t, c2block e, l))]; postins = []; cases = t.cases @ e.cases; - } + } - (* We can duplicate a chunk if it has a few simple statements, and if + (* 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 + let duplicateChunk (c: chunk) = (* raises Failure if you should not * duplicate this chunk *) if not !allowDuplication then raise (Failure "cannot duplicate: disallowed by user"); if c.cases != [] then raise (Failure "cannot duplicate: has cases") else let pCount = ref (List.length c.postins) in - { stmts = - Util.list_map - (fun s -> - if s.labels != [] then + { stmts = + Util.list_map + (fun s -> + if s.labels != [] then raise (Failure "cannot duplicate: has labels"); - (match s.skind with - If _ | Switch _ | Loop _ | Block _ -> + (match s.skind with + If _ | Switch _ | Loop _ | Block _ -> raise (Failure "cannot duplicate: complex stmt") - | Instr il -> + | Instr il -> pCount := !pCount + List.length il | _ -> 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 + (* 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 *) { s with sid = s.sid}) c.stmts; postins = c.postins; (* There is no shared stuff in instructions *) cases = [] - } + } (* - let duplicateChunk (c: chunk) = + let duplicateChunk (c: chunk) = if isEmpty c then c else raise (Failure ("cannot duplicate: isNotEmpty")) *) (* We can drop a chunk if it does not have labels inside *) let canDrop (c: chunk) = List.for_all canDropStatement c.stmts - let loopChunk (body: chunk) : chunk = + let loopChunk (body: chunk) : chunk = (* Make the statement *) let loop = mkStmt (Loop (c2block body, !currentLoc, None, None)) in { stmts = [ loop (* ; n *) ]; postins = []; cases = body.cases; - } - - let breakChunk (l: location) : chunk = + } + + let breakChunk (l: location) : chunk = { stmts = [ mkStmt (Break l) ]; postins = []; cases = []; - } - - let continueChunk (l: location) : chunk = + } + + let continueChunk (l: location) : chunk = { stmts = [ mkStmt (Continue l) ]; postins = []; cases = [] - } + } (* 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 = + let addGoto (lname: string) (bref: stmt ref) : unit = + let gotos = try H.find backPatchGotos lname with Not_found -> begin @@ -956,11 +974,11 @@ module BlockChunk = (* Keep track of the labels *) let labelStmt : (string, stmt) H.t = H.create 17 - let initLabels () = + let initLabels () = H.clear backPatchGotos; H.clear labelStmt - - let resolveGotos () = + + let resolveGotos () = H.iter (fun lname gotos -> try @@ -971,33 +989,33 @@ module BlockChunk = end) backPatchGotos - (* Get the first statement in a chunk. Might need to change the + (* Get the first statement in a chunk. Might need to change the * statements in the chunk *) - let getFirstInChunk (c: chunk) : stmt * stmt list = + let getFirstInChunk (c: chunk) : stmt * stmt list = (* Get the first statement and add the label to it *) match c.stmts with s :: _ -> s, c.stmts | [] -> (* Add a statement *) let n = mkEmptyStmt () in n, n :: c.stmts - - let consLabel (l: string) (c: chunk) (loc: location) - (in_original_program_text : bool) : chunk = + + let consLabel (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 c in (* Add the label *) - labstmt.labels <- Label (l, loc, in_original_program_text) :: + labstmt.labels <- Label (l, loc, in_original_program_text) :: labstmt.labels; H.add labelStmt l labstmt; if c.stmts == stmts' then c else {c with stmts = stmts'} - let s2c (s:stmt) : chunk = + let s2c (s:stmt) : chunk = { stmts = [ s ]; postins = []; cases = []; - } + } - let gotoChunk (ln: string) (l: location) : chunk = + let gotoChunk (ln: string) (l: location) : chunk = let gref = ref dummyStmt in addGoto ln gref; { stmts = [ mkStmt (Goto (gref, l)) ]; @@ -1014,14 +1032,14 @@ module BlockChunk = let fst, stmts' = getFirstInChunk next in fst.labels <- CaseRange (e, e', l) :: fst.labels; { next with stmts = stmts'; cases = fst :: next.cases} - - let defaultChunk (l: location) (next: chunk) = + + let defaultChunk (l: location) (next: chunk) = let fst, stmts' = getFirstInChunk next in let lb = Default l in fst.labels <- lb :: fst.labels; { next with stmts = stmts'; cases = fst :: next.cases} - + let switchChunk (e: exp) (body: chunk) (l: location) = (* Make the statement *) let defaultSeen = ref false in @@ -1062,7 +1080,7 @@ module BlockChunk = let labels = List.rev_map checkForDefaultAndCast s.labels in s.labels <- if !useCaseRange then labels else caseRangeFold labels; s::acc - end) + end) [] body.cases) in @@ -1070,25 +1088,25 @@ module BlockChunk = { stmts = [ switch (* ; n *) ]; postins = []; cases = []; - } + } - let mkFunctionBody (c: chunk) : block = + let mkFunctionBody (c: chunk) : block = resolveGotos (); initLabels (); if c.cases <> [] then E.s (error "Switch cases not inside a switch statement"); c2block c - + end -open BlockChunk +open BlockChunk (************ 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 +(* 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 = +type loopstate = While | NotWhile of string ref @@ -1097,17 +1115,17 @@ 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 (l: location) : chunk = +let continueOrLabelChunk (l: location) : chunk = match !continues with [] -> E.s (error "continue not in a loop") | While :: _ -> continueChunk l - | NotWhile lr :: _ -> + | NotWhile lr :: _ -> if !lr = "" then begin lr := newLabelName "__Cont" end; gotoChunk !lr l -let consLabContinue (c: chunk) = +let consLabContinue (c: chunk) = match !continues with [] -> E.s (error "labContinue not in a loop") | While :: rest -> c @@ -1131,28 +1149,28 @@ let startLoop iswhile = enter_break_env (); continues := (if iswhile then While else NotWhile (ref "")) :: !continues -let exitLoop () = +let exitLoop () = exit_break_env (); match !continues with [] -> E.s (error "exit Loop not in a loop") | _ :: rest -> continues := rest - + (* In GCC we can have locally declared labels. *) -let genNewLocalLabel (l: string) = - (* Call the newLabelName to register the label name in the alpha conversion +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 +let lookupLabel (l: string) = + try match H.find env (kindPlusName "label" l) with EnvLabel l', _ -> l' | _ -> raise Not_found - with Not_found -> + with Not_found -> l (* Enter all the labels into the alpha renaming table to prevent @@ -1161,21 +1179,21 @@ let lookupLabel (l: string) = class registerLabelsVisitor = object inherit V.nopCabsVisitor - method vstmt s = + method! vstmt s = currentLoc := convLoc (C.get_statementloc s); (match s with | A.LABEL (lbl,_,_) -> - AL.registerAlphaName alphaTable None (kindPlusName "label" lbl) !currentLoc + AL.registerAlphaName ~alphaTable:alphaTable ~undolist:None ~lookupname:(kindPlusName "label" lbl) ~data:!currentLoc | _ -> ()); V.DoChildren end (** ALLOCA ***) -let allocaFun () = +let allocaFun () = if !msvcMode then begin let name = "alloca" in let fdec = emptyFunction name in - fdec.svar.vtype <- + fdec.svar.vtype <- TFun(voidPtrType, Some [ ("len", !typeOfSizeOf, []) ], false, []); fdec.svar end @@ -1184,41 +1202,41 @@ let allocaFun () = even when gcc is invoked with -fno-builtin *) let alloca, _ = lookupGlobalVar "__builtin_alloca" in alloca - -(* Maps local variables that are variable sized arrays to the expression that + +(* 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 +type expAction = + ADrop (* Drop the result. Only the * side-effect is interesting *) | AType (* Only the type of the result is interesting. *) - | ASet of lval * typ (* Put the result in a given lval, - * provided it matches the type. The + | ASet of lval * typ (* Put the result in a given lval, + * provided it matches the type. The * type is the type 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 + | 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 + | AExpLeaveArrayFun (* Do it like an expression, but do + * not convert arrays of functions * into pointers *) (*** Result of compiling conditional expressions *) -type condExpRes = +type condExpRes = CEExp of chunk * exp (* Do a chunk and then an expression *) | CEAnd of condExpRes * condExpRes | CEOr of condExpRes * condExpRes @@ -1228,7 +1246,7 @@ type condExpRes = let rec integralPromotion (t : typ) : typ = (* c.f. ISO 6.3.1.1 *) match unrollType t with TInt (IBool, a) -> TInt (IInt, a) (* _Bool can only be 0 or 1, irrespective of its size *) - | TInt ((IShort|IUShort|IChar|ISChar|IUChar) as ik, a) -> + | TInt ((IShort|IUShort|IChar|ISChar|IUChar) as ik, a) -> if bitsSizeOf t < bitsSizeOf (TInt (IInt, [])) || isSigned ik then TInt(IInt, a) else @@ -1236,7 +1254,7 @@ let rec integralPromotion (t : typ) : typ = (* c.f. ISO 6.3.1.1 *) | TInt _ -> t | TEnum (ei, a) -> integralPromotion (TInt(ei.ekind, a)) (* gcc packed enums can be < int *) | t -> E.s (error "integralPromotion: not expecting %a" d_type t) - + let defaultArgumentPromotion (t : typ) : typ = (* c.f. ISO 6.5.2.2:6 *) match unrollType t with | TFloat (FFloat, a) -> TFloat (FDouble, a) @@ -1245,13 +1263,26 @@ let defaultArgumentPromotion (t : typ) : typ = (* c.f. ISO 6.5.2.2:6 *) let arithmeticConversion (* c.f. ISO 6.3.1.8 *) (t1: typ) (t2: typ) : typ = + let resultingFType fkind1 t1 fkind2 t2 = + (* t1 and t2 are the original types before unrollType, so TNamed is preserved if possible *) + let isComplex f = f = FComplexFloat || f = FComplexDouble || f = FComplexLongDouble in + match fkind1, fkind2 with + | FComplexLongDouble, _ -> t1 + | _, FComplexLongDouble -> t2 + | FLongDouble, other -> if isComplex other then TFloat(FComplexLongDouble, []) else t1 + | other, FLongDouble -> if isComplex other then TFloat(FComplexLongDouble, []) else t2 + | FComplexDouble, other -> t1 + | other, FComplexDouble -> t2 + | FDouble, other -> if isComplex other then TFloat(FComplexDouble, []) else t1 + | other, FDouble -> if isComplex other then TFloat(FComplexDouble, []) else t2 + | FComplexFloat, other -> t1 + | other, FComplexFloat -> t2 + | FFloat, FFloat -> t1 + in match unrollType t1, unrollType t2 with - TFloat(FLongDouble, _), _ -> t1 - | _, TFloat(FLongDouble, _) -> t2 - | TFloat(FDouble, _), _ -> t1 - | _, TFloat (FDouble, _) -> t2 - | TFloat(FFloat, _), _ -> t1 - | _, TFloat (FFloat, _) -> t2 + | TFloat(fkind1, _), TFloat(fkind2, _) -> resultingFType fkind1 t1 fkind2 t2 + | TFloat(_, _), _ -> t1 + | _, TFloat(_, _) -> t2 | _, _ -> begin let t1' = integralPromotion t1 in let t2' = integralPromotion t2 in @@ -1305,38 +1336,38 @@ let arithmeticConversion (* c.f. ISO 6.3.1.8 *) end - + (* Specify whether the cast is from the source code *) -let rec castTo ?(fromsource=false) - (ot : typ) (nt : typ) (e : exp) : (typ * exp ) = - let debugCast = false in - if debugCast then +let rec castTo ?(fromsource=false) + (ot : typ) (nt : typ) (e : exp) : (typ * exp ) = + let debugCast = false in + if debugCast then ignore (E.log "%t: castTo:%s %a->%a\n" d_thisloc (if fromsource then "(source)" else "") d_type ot d_type nt); if not fromsource && Util.equals (typeSig ot) (typeSig nt) then - (* Do not put the cast if it is not necessary, unless it is from the + (* Do not put the cast if it is not necessary, unless it is from the * source. *) - (ot, e) + (ot, e) else begin let nt' = if fromsource then nt else !typeForInsertedCast nt in - let result = (nt', - if !insertImplicitCasts || fromsource then Cil.mkCastT e ot nt' else e) in + let result = (nt', + if !insertImplicitCasts || fromsource then Cil.mkCastT ~e:e ~oldt:ot ~newt:nt' else e) in - if debugCast then - ignore (E.log "castTo: ot=%a nt=%a\n result is %a\n" + if debugCast then + ignore (E.log "castTo: ot=%a nt=%a\n result is %a\n" d_type ot d_type nt' d_plainexp (snd result)); (* Now see if we can have a cast here *) match unrollType ot, unrollType nt' with - TNamed _, _ + TNamed _, _ | _, TNamed _ -> E.s (bug "unrollType failed in castTo") - | TInt(ikindo,_), TInt(ikindn,_) -> + | TInt(ikindo,_), TInt(ikindn,_) -> (* We used to ignore attributes on integer-integer casts. Not anymore *) - (* if ikindo = ikindn then (nt, e) else *) + (* if ikindo = ikindn then (nt, e) else *) result | TPtr (told, _), TPtr(tnew, _) -> result @@ -1345,18 +1376,18 @@ let rec castTo ?(fromsource=false) * function pointers, so we have to accept this explicit cast when it occurs * in the source. *) | TFun _, TPtr _ when fromsource -> result - + | TInt _, TPtr _ -> result - + | TPtr _, TInt _ -> result - + | TArray _, TPtr _ -> result - + | TArray(t1,_,_), TArray(t2,None,_) when Util.equals (typeSig t1) (typeSig t2) -> (nt', e) - + | TPtr _, TArray(_,_,_) -> (nt', e) - + | TEnum _, TInt _ -> result | TFloat _, (TInt _|TEnum _) -> result | (TInt _|TEnum _), TFloat _ -> result @@ -1365,40 +1396,40 @@ let rec castTo ?(fromsource=false) | TEnum _, TEnum _ -> result | TEnum _, TPtr _ -> result - | TBuiltin_va_list _, (TInt _ | TPtr _) -> + | TBuiltin_va_list _, (TInt _ | TPtr _) -> result | (TInt _ | TPtr _), TBuiltin_va_list _ -> ignore (warnOpt "Casting %a to __builtin_va_list" d_type ot); result - | TPtr _, TEnum _ -> + | TPtr _, TEnum _ -> ignore (warnOpt "Casting a pointer into an enumeration type"); result (* The expression is evaluated for its side-effects *) - | (TInt _ | TEnum _ | TPtr _ ), TVoid _ -> + | (TInt _ | TEnum _ | TPtr _ ), TVoid _ -> (ot, e) - (* Even casts between structs are allowed when we are only + (* Even casts between structs are allowed when we are only * modifying some attributes *) - | TComp (comp1, a1), TComp (comp2, a2) when comp1.ckey = comp2.ckey -> + | TComp (comp1, a1), TComp (comp2, a2) 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 + + (* 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(tunion, a1), _ -> begin - match isTransparentUnion ot with + match isTransparentUnion ot with None -> E.s (error "cabs2cil/castTo: illegal cast %a -> %a@!" d_type ot d_type nt') | Some fstfield -> begin (* We do it now only if the expression is an lval *) - let e' = - match e with - Lval lv -> + let e' = + match e with + Lval lv -> Lval (addOffsetLval (Field(fstfield, NoOffset)) lv) | _ -> E.s (unimp "castTo: transparent union expression is not an lval: %a\n" d_exp e) in @@ -1406,11 +1437,11 @@ let rec castTo ?(fromsource=false) castTo ~fromsource:fromsource fstfield.ftype nt' e' end end - | _ -> + | _ -> (* strip attributes for a cleaner error message *) let ot'' = setTypeAttrs ot [] in let nt'' = setTypeAttrs nt' [] in - E.s (error "cabs2cil/castTo: illegal cast %a -> %a@!" + E.s (error "cabs2cil/castTo: illegal cast %a -> %a@!" d_type ot'' d_type nt'') end @@ -1423,7 +1454,7 @@ let checkBool (ot : typ) (e : exp) : bool = | TFloat _ -> true | _ -> E.s (error "castToBool %a" d_type ot) -(* Given an expression that is being coerced to bool, +(* Given an expression that is being coerced to bool, is it a nonzero constant? *) let rec isConstTrue (e:exp): bool = match e with @@ -1434,7 +1465,7 @@ let rec isConstTrue (e:exp): bool = | CastE(_, e) -> isConstTrue e | _ -> false -(* Given an expression that is being coerced to bool, is it zero? +(* Given an expression that is being coerced to bool, is it zero? This is a more general version of Cil.isZero, which only handles integers. On constant expressions, either isConstTrue or isConstFalse will hold. *) let rec isConstFalse (e:exp): bool = @@ -1448,15 +1479,15 @@ let rec isConstFalse (e:exp): bool = (* We have our own version of addAttributes that does not allow duplicates *) -let cabsAddAttributes al0 (al: attributes) : attributes = +let cabsAddAttributes al0 (al: attributes) : attributes = if al0 == [] then al else - List.fold_left - (fun acc (Attr(an, _) as a) -> + List.fold_left + (fun acc (Attr(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 Util.equals a a' then + | a' :: _ -> + if Util.equals a a' then acc (* Already in *) else begin addAttribute a acc (* Keep both attributes *) @@ -1465,7 +1496,7 @@ let cabsAddAttributes al0 (al: attributes) : attributes = al0 - + let cabsTypeAddAttributes a0 t = begin match a0 with @@ -1474,10 +1505,10 @@ let cabsTypeAddAttributes a0 t = t | _ -> (* anything else: add a0 to existing attributes *) - let add (a: attributes) = cabsAddAttributes a0 a in + let addA0To (a: attributes) = cabsAddAttributes a0 a in match t with - TVoid a -> TVoid (add a) - | TInt (ik, a) -> + TVoid a -> TVoid (addA0To 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: *) @@ -1488,14 +1519,14 @@ let cabsTypeAddAttributes a0 t = (* /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.*) +(* attribute, which we used to go out of our way to avoid printing anyway.*) (* DG: Use machine model to pick correct type *) - let ik', a0' = - (* Go over the list of new attributes and come back with a + let ik', a0' = begin + (* 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 + (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 (* #$@!#@ ML! d_type t *) )); @@ -1511,7 +1542,7 @@ let cabsTypeAddAttributes a0 t = | "DI" -> 8 | "TI" -> 16 | "OI" -> 32 - | _ -> raise Not_found in + | _ -> raise Not_found in let nk = intKindForSize size (not (isSigned ik')) in (nk, a0') with Not_found -> @@ -1522,94 +1553,99 @@ let cabsTypeAddAttributes a0 t = | _ -> (ik', a0one :: a0')) (ik, []) a0 + end 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) - | TArray (t, l, a) -> TArray (t, l, add a) - | TFun (t, args, isva, a) -> TFun(t, args, isva, add a) - | TComp (comp, a) -> TComp (comp, add a) - | TNamed (t, a) -> TNamed (t, add a) - | TBuiltin_va_list a -> TBuiltin_va_list (add a) + | TFloat (fk, a) -> + if Cil.hasAttribute "complex" a0 then + TFloat (Cil.getComplexFkind fk, cabsAddAttributes (Cil.dropAttribute "complex" a0) a) + else + TFloat (fk, addA0To a) + | TEnum (enum, a) -> TEnum (enum, addA0To a) + | TPtr (t, a) -> TPtr (t, addA0To a) + | TArray (t, l, a) -> TArray (t, l, addA0To a) + | TFun (t, args, isva, a) -> TFun(t, args, isva, addA0To a) + | TComp (comp, a) -> TComp (comp, addA0To a) + | TNamed (t, a) -> TNamed (t, addA0To a) + | TBuiltin_va_list a -> TBuiltin_va_list (addA0To a) end (* Do types *) - (* Combine the types. Raises the Failure exception with an error message. + (* 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 +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 + | CombineFunarg (* Comparing a function argument type with an old prototype * arg *) - | CombineFunret (* Comparing the return of a function with that from an old + | 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 +(* 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 = +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 = + | TInt (oldik, olda), TInt (ik, a) -> + let combineIK oldk k = if oldk = k then oldk else - (* GCC allows a function definition to have a more precise integer + (* GCC allows a function definition to have a more precise integer * type than a prototype that says "int" *) - if not !msvcMode && oldk = IInt && bitsSizeOf t <= 32 + if not !msvcMode && oldk = IInt && bitsSizeOf t <= 32 && (what = CombineFunarg || what = CombineFunret) then k else raise (Failure "different integer types") in TInt (combineIK oldik ik, cabsAddAttributes olda a) - | TFloat (oldfk, olda), TFloat (fk, a) -> - let combineFK oldk k = + | TFloat (oldfk, olda), TFloat (fk, a) -> + let combineFK oldk k = if oldk = k then oldk else - (* GCC allows a function definition to have a more precise integer + (* GCC allows a function definition to have a more precise integer * type than a prototype that says "double" *) - if not !msvcMode && oldk = FDouble && k = FFloat + if not !msvcMode && oldk = FDouble && k = FFloat && (what = CombineFunarg || what = CombineFunret) then k else raise (Failure "different floating point types") in TFloat (combineFK oldfk fk, cabsAddAttributes olda a) - | TEnum (_, olda), TEnum (ei, 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, + | 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 + + + | 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 + if oldci.cname = ci.cname then TComp (oldci, comb_a) - else + else (* Now maybe they are actually the same *) - if H.mem isomorphicStructs (oldci.cname, ci.cname) then + if H.mem isomorphicStructs (oldci.cname, ci.cname) then (* We know they are the same *) TComp (oldci, comb_a) else begin - (* If one has 0 fields (undefined) while the other has some fields + (* 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, comb_a) else if ci_nrfields = 0 then - TComp (oldci, comb_a) + TComp (oldci, comb_a) else begin (* Make sure that at least they have the same number of fields *) if oldci_nrfields <> ci_nrfields then begin @@ -1625,15 +1661,15 @@ let rec combineTypes (what: combineWhat) (oldt: typ) (t: typ) : typ = 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 + List.iter2 (fun oldf f -> + if oldf.fbitfield <> f.fbitfield then raise (Failure "different structs(bitfield info)"); - if oldf.fattr <> f.fattr then + 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 + with Failure _ as e -> begin (* Our assumption was wrong. Forget the isomorphism *) ignore (E.log "\tFailed in our assumption that %s and %s are isomorphic\n" oldci.cname ci.cname); @@ -1646,59 +1682,63 @@ let rec combineTypes (what: combineWhat) (oldt: typ) (t: typ) : typ = end end - | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) -> - let newbt = combineTypes CombineOther oldbt bt in - let newsz = + | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) -> + let newbt = combineTypes what 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 + | 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) = + let checkEqualSize (machdep: bool) = let oldsz'', sz''= (* cast both to the same type. This prevents complaints such as "((int)1) <> ((char)1)" *) - if machdep then - mkCast oldsz' !typeOfSizeOf, mkCast sz' !typeOfSizeOf + if machdep then + mkCast ~e:oldsz' ~newt:!typeOfSizeOf, mkCast ~e:sz' ~newt:!typeOfSizeOf else oldsz', sz' in - Util.equals (constFold machdep oldsz'') - (constFold machdep sz'') + Util.equals (constFold machdep oldsz'') + (constFold machdep sz'') in - if checkEqualSize false then + if checkEqualSize false then oldsz else if checkEqualSize true then begin - ignore (warn "Array type comparison succeeds only based on machine-dependent constant evaluation: %a and %a" + ignore (warn "Array type comparison succeeds only based on machine-dependent constant evaluation: %a and %a" d_exp oldsz' d_exp sz'); oldsz - end else + end else if what = CombineFunarg then begin + ignore (warn "Array type comparison succeeds based on being lenient for funargs, proceed with caution: %a %a" d_exp oldsz' d_exp sz'); + oldsz + end + else raise (Failure "different array lengths") - + in TArray (newbt, newsz, cabsAddAttributes olda a) - - | TPtr (oldbt, olda), TPtr (bt, a) -> - TPtr (combineTypes CombineOther oldbt bt, cabsAddAttributes olda a) - + + | TPtr (oldbt, olda), TPtr (bt, a) -> + TPtr (combineTypes what oldbt bt, cabsAddAttributes olda a) + | TFun (_, _, _, [Attr("missingproto",_)]), TFun _ -> t - + | TFun (oldrt, oldargs, oldva, olda), TFun (rt, args, va, a) -> - if oldva != va then - raise (Failure "diferent vararg specifiers"); - let defrt = combineTypes - (if what = CombineFundef then CombineFunret else CombineOther) + if oldva != va then + raise (Failure "different vararg specifiers"); + let defrt = combineTypes + (if what = CombineFundef then CombineFunret else CombineOther) oldrt rt in - (* If one does not have arguments, believe the one with the + (* If one does not have arguments, believe the one with the * arguments *) - let newargs, newrt, olda' = + let newargs, newrt, olda' = if oldargs = None then args, defrt, olda else if args = None then oldargs, defrt, olda else let oldargslist = argsToList oldargs in let argslist = argsToList args in - if List.length oldargslist <> List.length argslist then + 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. *) @@ -1706,88 +1746,88 @@ let rec combineTypes (what: combineWhat) (oldt: typ) (t: typ) : typ = List.iter2 (fun (on, _, _) (an, _, _) -> H.replace map on an) oldargslist argslist; - (* Go over the arguments and update the old ones with the + (* Go over the arguments and update the old ones with the * adjusted types *) - 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 + 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 (* Adjust the old type. This hook allows Deputy to do * alpha renaming of dependent attributes. *) let ot' = !typeForCombinedArg map ot in - let t = - combineTypes - (if what = CombineFundef then - CombineFunarg else CombineOther) + let t = + combineTypes + (if what = CombineFundef then + CombineFunarg else CombineOther) ot' at in let a = addAttributes oa aa in (n, t, a)) oldargslist argslist), (let oldrt' = !typeForCombinedArg map oldrt in - combineTypes - (if what = CombineFundef then CombineFunret else CombineOther) + combineTypes + (if what = CombineFundef then CombineFunret else CombineOther) oldrt' rt), !attrsForCombinedArg map olda end 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 olda, TBuiltin_va_list a -> TBuiltin_va_list (cabsAddAttributes olda a) (* Unroll first the new type *) - | _, TNamed (t, a) -> + | _, 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), _ -> + | TNamed (oldt, a), _ -> let res = combineTypes what oldt.ttype t in cabsTypeAddAttributes a res - + | _ -> raise (Failure "different type constructors") let extInlineSuffRe = Str.regexp "\\(.+\\)__extinline" -(* Create and cache varinfo's for globals. Starts with a varinfo but if the - * global has been declared already it might come back with another varinfo. - * Returns the varinfo to use (might be the old one), and an indication +(* 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 debug = false in if not !cacheGlobals then vi, false else - 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 + try (* See if already defined, in the global environment. We could also + * look it up in the whole environment but in that case we might see a + * local. This can happen when we declare an extern variable with * global scope but we are in a local scope. *) - (* We lookup in the environement. If this is extern inline then the name + (* We lookup in the environment. If this is extern inline then the name * was already changed to foo__extinline. We lookup with the old name *) - let lookupname = - if vi.vstorage = Static then - if Str.string_match extInlineSuffRe vi.vname 0 then + let lookupname = + if vi.vstorage = Static then + if Str.string_match extInlineSuffRe vi.vname 0 then Str.matched_group 1 vi.vname else vi.vname else vi.vname in - if debug then + if debug then ignore (E.log "makeGlobalVarinfo isadef=%b vi.vname=%s (lookup = %s)\n" isadef vi.vname lookupname); (* This may throw an exception Not_found *) let oldvi, oldloc = lookupGlobalVar lookupname in if debug then - ignore (E.log " %s already in the env at loc %a\n" + ignore (E.log " %s already in the env at loc %a\n" vi.vname d_loc oldloc); (* New-style extern inline handling: the real definition replaces the extern @@ -1798,9 +1838,9 @@ let makeGlobalVarinfo (isadef: bool) (vi: varinfo) : varinfo * bool = | GFun (fi, l) when fi.svar == oldvi -> GVarDecl(fi.svar, l) | x -> x) !theFile end; - (* It was already defined. We must reuse the varinfo. But clean up the + (* It was already defined. We must reuse the varinfo. But clean up the * storage. *) - let newstorage = (** See 6.2.2 *) + let newstorage = (* See 6.2.2 *) match oldvi.vstorage, vi.vstorage with (* Extern and something else is that thing *) | Extern, other @@ -1813,7 +1853,7 @@ let makeGlobalVarinfo (isadef: bool) (vi: varinfo) : varinfo * bool = | _ -> if vi.vstorage != oldvi.vstorage then ignore (warn - "Inconsistent storage specification for %s. Previous declaration: %a" + "Inconsistent storage specification for %s. Previous declaration: %a" vi.vname d_loc oldloc); vi.vstorage in @@ -1826,92 +1866,94 @@ let makeGlobalVarinfo (isadef: bool) (vi: varinfo) : varinfo * bool = oldvi.vattr <- dropAttribute "section" oldvi.vattr; (* Union the attributes *) oldvi.vattr <- cabsAddAttributes oldvi.vattr vi.vattr; - begin + begin try - oldvi.vtype <- - combineTypes - (if isadef then CombineFundef else CombineOther) + oldvi.vtype <- + combineTypes + (if isadef then CombineFundef else CombineOther) oldvi.vtype vi.vtype; - with Failure reason -> + with Failure reason -> ignore (E.log "old type = %a\n" d_plaintype oldvi.vtype); ignore (E.log "new type = %a\n" d_plaintype vi.vtype); - E.s (error "Declaration of %s does not match previous declaration from %a (%s)." + E.s (error "Declaration of %s does not match previous declaration from %a (%s)." vi.vname d_loc oldloc reason) end; - + (* Found an old one. Keep the location always from the definition *) - if isadef then begin + if isadef then begin oldvi.vdecl <- vi.vdecl; end; oldvi, true - + with Not_found -> begin (* A new one. *) if debug then ignore (E.log " %s not in the env already\n" vi.vname); - (* Announce the name to the alpha conversion table. This will not - * actually change the name of the vi. See the definition of + (* Announce the name to the alpha conversion table. This will not + * actually change the name of the vi. See the definition of * alphaConvertVarAndAddToEnv *) alphaConvertVarAndAddToEnv true vi, false - end + end -let conditionalConversion (t2: typ) (t3: typ) : typ = +let conditionalConversion (t2: typ) (t3: typ) (e2: exp option) (e3:exp) : 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 Util.equals (typeSig t2) (typeSig t3) -> t2 - | TPtr _, TInt _ -> t2 (* most likely comparison with 0 *) - | TInt _, TPtr _ -> t3 (* most likely comparison with 0 *) - - (* When we compare two pointers of diffent type, we combine them - * using the same algorithm when combining multiple declarations of + match unrollType t2, unrollType t3, e2 with + (TInt _ | TEnum _ | TFloat _), + (TInt _ | TEnum _ | TFloat _), _ -> + arithmeticConversion t2 t3 + | TComp (comp2,_), TComp (comp3,_), _ + when comp2.ckey = comp3.ckey -> t2 + | TPtr(_, _), TPtr(TVoid _, _), _ -> + if isNullPtrConstant e3 then t2 else t3 + | TPtr(TVoid _, _), TPtr(_, _), Some e2' -> + if isNullPtrConstant e2' then t3 else t2 + | TPtr _, TPtr _, _ when Util.equals (typeSig t2) (typeSig t3) -> t2 + | TPtr _, TInt _, _ -> t2 (* most likely comparison with int constant 0, if it isn't it would not be valid C *) + | TInt _, TPtr _, _ -> t3 (* most likely comparison with int constant 0, if it isn't it would not be valid C *) + + (* When we compare two pointers of different type, we combine them + * using the same algorithm when combining multiple declarations of * a global *) - | (TPtr _) as t2', (TPtr _ as t3') -> begin - try combineTypes CombineOther t2' t3' + | (TPtr _) as t2', (TPtr _ as t3'), _ -> begin + try combineTypes CombineOther t2' t3' with Failure msg -> begin ignore (warn "A.QUESTION: %a does not match %a (%s)" d_type (unrollType t2) d_type (unrollType t3) msg); t2 (* Just pick one *) end end - | _, _ -> E.s (error "A.QUESTION for invalid combination of types") + | _, _,_ -> E.s (error "A.QUESTION for invalid combination of types") in tresult -(* Some utilitites for doing initializers *) +(* Some utilities for doing initializers *) let debugInit = false -type preInit = +type preInit = | NoInitPre - | SinglePre of exp + | SinglePre of exp | CompoundPre of int ref (* the maximum used index *) * preInit array ref (* an array with initializers *) (* Instructions on how to handle designators *) -type handleDesignators = +type handleDesignators = | Handle (* Handle them yourself *) | DoNotHandle (* Do not handle them your self *) - | HandleAsNext (* First behave as if you have a NEXT_INIT. Useful for going + | HandleAsNext (* First behave as if you have a NEXT_INIT. Useful for going * into nested designators *) | HandleFirst (* Handle only the first designator *) (* Set an initializer *) let rec setOneInit (this: preInit) - (o: offset) (e: exp) : preInit = - match o with + (o: offset) (e: exp) : preInit = + match o with NoOffset -> SinglePre e - | _ -> + | _ -> let idx, (* Index in the current comp *) restoff (* Rest offset *) = - match o with + match o with | Index(Const(CInt64(i,_,_)), off) -> i64_to_int i, off - | Field (f, off) -> + | Field (f, off) -> (* Find the index of the field *) let rec loop (idx: int) = function [] -> E.s (bug "Cannot find field %s" f.fname) @@ -1921,13 +1963,13 @@ let rec setOneInit (this: preInit) loop 0 f.fcomp.cfields, off | _ -> E.s (bug "setOneInit: non-constant index") in - let pMaxIdx, pArray = - match this with + let pMaxIdx, pArray = + match this with NoInitPre -> (* No initializer so far here *) - ref idx, ref (Array.create (max 32 (idx + 1)) NoInitPre) - - | CompoundPre (pMaxIdx, pArray) -> - if !pMaxIdx < idx then begin + 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 @@ -1939,7 +1981,7 @@ let rec setOneInit (this: preInit) end end; pMaxIdx, pArray - | SinglePre e -> + | SinglePre e -> E.s (unimp "Index %d is already initialized" idx) in assert (idx >= 0 && idx < Array.length !pArray); @@ -1947,6 +1989,11 @@ let rec setOneInit (this: preInit) !pArray.(idx) <- this'; CompoundPre (pMaxIdx, pArray) +let rec patchArraySizeZero t = + match t with + | TArray(typ, None, attr) -> TArray(typ, Some(Cil.zero),attr) + | TNamed({tname=n; ttype=typ; treferenced=ref}, attr) -> TNamed({tname=n; ttype=patchArraySizeZero typ; treferenced=ref}, attr) + | _ -> t (* collect a CIL initializer, given the original syntactic initializer * 'preInit'; this returns a type too, since initialization of an array @@ -1957,23 +2004,23 @@ let rec collectInitializer (isconst: bool) (this: preInit) (thistype: typ) : (init * typ) = - if this = NoInitPre then (makeZeroInit thistype), thistype + if this = NoInitPre then (makeZeroInit (patchArraySizeZero thistype)), patchArraySizeZero thistype else - match unrollType thistype, this with + match unrollType thistype, this with | _ , SinglePre e -> SingleInit e, thistype - | TArray (bt, leno, at), CompoundPre (pMaxIdx, pArray) -> + | TArray (bt, leno, at), CompoundPre (pMaxIdx, pArray) -> let (len: int), newtype = (* normal case: use array's declared length, newtype=thistype *) - match leno with + match leno with Some len -> begin - match constFold true len with - Const(CInt64(ni, _, _)) when ni >= 0L -> + match constFold true len with + Const(CInt64(ni, _, _)) when ni >= 0L -> (i64_to_int ni), TArray(bt,leno,at) | _ -> E.s (error "Array length is not a constant expression %a" d_exp len) end - | _ -> + | _ -> (* unsized array case, length comes from initializers - except * they are forbidden inside a struct or union *) if isfield && not isconst then @@ -1982,30 +2029,30 @@ let rec collectInitializer (!pMaxIdx + 1, TArray (bt, Some (integer (!pMaxIdx + 1)), at)) in - if !pMaxIdx >= len then + if !pMaxIdx >= len then E.s (E.bug "collectInitializer: too many initializers(%d >= %d)\n" !pMaxIdx len); (* Missing initializers must be set to zero but this is not done here. * See assignInit. *) - let rec collect (acc: (offset * init) list) (idx: int) = + let rec collect (acc: (offset * init) list) (idx: int) = if idx = -1 then acc else let thisi = fst (collectInitializer isfield isconst !pArray.(idx) bt) in collect ((Index(integer idx, NoOffset), thisi) :: acc) (idx - 1) in - + CompoundInit (newtype, collect [] !pMaxIdx), newtype | TComp (comp, _), CompoundPre (pMaxIdx, pArray) when comp.cstruct -> let rec collect (idx: int) = function [] -> [] - | f :: restf -> - if f.fname = missingFieldName then + | f :: restf -> + if f.fname = missingFieldName then collect (idx + 1) restf - else - let thisi = - if idx > !pMaxIdx then + else + let thisi = + if idx > !pMaxIdx then makeZeroInit f.ftype else collectFieldInitializer isconst !pArray.(idx) f @@ -2018,20 +2065,20 @@ let rec collectInitializer (* Find the field to initialize *) let rec findField (idx: int) = function [] -> E.s (bug "collectInitializer: union") - | _ :: rest when idx < !pMaxIdx && !pArray.(idx) = NoInitPre -> + | _ :: rest when idx < !pMaxIdx && !pArray.(idx) = NoInitPre -> findField (idx + 1) rest - | f :: _ when idx = !pMaxIdx -> - Field(f, NoOffset), + | f :: _ when idx = !pMaxIdx -> + Field(f, NoOffset), collectFieldInitializer isconst !pArray.(idx) f | _ -> E.s (error "Can initialize only one field for union") in - if !msvcMode && !pMaxIdx != 0 then + if !msvcMode && !pMaxIdx != 0 then ignore (warn "On MSVC we can initialize only the first field of a union"); CompoundInit (thistype, [ findField 0 comp.cfields ]), thistype | _ -> E.s (unimp "collectInitializer") - -and collectFieldInitializer + +and collectFieldInitializer (isconst: bool) (this: preInit) (f: fieldinfo) : init = @@ -2040,58 +2087,58 @@ and collectFieldInitializer * structure declaration. *) fst (collectInitializer true isconst this f.ftype) -type stackElem = - InArray of offset * typ * int * int ref (* offset of parent, base type, - * length, current index. If the - * array length is unspecified we +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, + | 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 + +(* 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 +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 + mutable eof: bool; (* The stack is empty and we reached the * end *) - mutable soTyp: typ; (* The type of the subobject. Set using + 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 + mutable soOff: offset; (* The offset of the subobject. Set + * using normalSubobj after setting * stack. *) - curTyp: typ; (* Type of current object. See ISO for + 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. + host: varinfo; (* The host that we are initializing. * For error messages *) } -(* Make a subobject iterator *) -let rec makeSubobj - (host: varinfo) +(* Make a subobject iterator *) +let rec makeSubobj + (host: varinfo) (curTyp: typ) - (curOff: offset) = - let so = - { host = host; curTyp = curTyp; curOff = curOff; + (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 + (* 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 +and normalSubobj (so: subobj) : unit = + match so.stack with + [] -> so.soOff <- so.curOff; so.soTyp <- so.curTyp (* The array is over *) | InArray (parOff, bt, leno, current) :: rest -> if leno = !current then begin (* The array is over *) if debugInit then ignore (E.log "Past the end of array\n"); - so.stack <- rest; + so.stack <- rest; advanceSubobj so end else begin so.soTyp <- bt; @@ -2099,10 +2146,10 @@ and normalSubobj (so: subobj) : unit = end (* The fields are over *) - | InComp (parOff, comp, nextflds) :: rest -> + | InComp (parOff, comp, nextflds) :: rest -> if nextflds == [] then begin (* No more fields here *) if debugInit then ignore (E.log "Past the end of structure\n"); - so.stack <- rest; + so.stack <- rest; advanceSubobj so end else begin let fst = List.hd nextflds in @@ -2111,39 +2158,39 @@ and normalSubobj (so: subobj) : unit = end (* Advance to the next subobject. Always apply to a normalized object *) -and advanceSubobj (so: subobj) : unit = +and advanceSubobj (so: subobj) : unit = if so.eof then E.s (bug "advanceSubobj past end"); match so.stack with - | [] -> if debugInit then ignore (E.log "Setting eof to true\n"); - so.eof <- true - | InArray (parOff, bt, leno, current) :: rest -> + | [] -> if debugInit then ignore (E.log "Setting eof to true\n"); + so.eof <- true + | InArray (parOff, bt, leno, current) :: rest -> if debugInit then ignore (E.log " Advancing to [%d]\n" (!current + 1)); (* so.stack <- InArray (parOff, bt, leno, current + 1) :: rest; *) incr current; normalSubobj so (* The fields are over *) - | InComp (parOff, comp, nextflds) :: rest -> - if debugInit then + | InComp (parOff, comp, nextflds) :: rest -> + if debugInit then ignore (E.log "Advancing past .%s\n" (List.hd nextflds).fname); let flds' = try List.tl nextflds with _ -> E.s (bug "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 = +let fieldsToInit + (comp: compinfo) + (designator: string option) + : fieldinfo list = (* Never look at anonymous fields *) - let flds1 = + let flds1 = List.filter (fun f -> f.fname <> missingFieldName) comp.cfields in - let flds2 = - match designator with + let flds2 = + match designator with None -> flds1 - | Some fn -> + | Some fn -> let rec loop = function [] -> E.s (error "Cannot find designated field %s" fn) | (f :: _) as nextflds when f.fname = fn -> nextflds @@ -2152,18 +2199,18 @@ let fieldsToInit loop flds1 in (* If it is a union we only initialize one field *) - match flds2 with + match flds2 with [] -> [] - | (f :: rest) as toinit -> + | (f :: rest) as toinit -> if comp.cstruct then toinit else [f] - -let integerArrayLength (leno: exp option) : int = + +let integerArrayLength (leno: exp option) : int = match leno with None -> max_int | Some len -> begin - try lenOfArray leno - with LenOfArray -> + try lenOfArray leno + with LenOfArray -> E.s (error "Initializing non-constant-length array\n length=%a" d_exp len) end @@ -2177,13 +2224,13 @@ let isNone (o : 'a option) : bool = let annonCompFieldNameId = ref 0 let annonCompFieldName = "__annonCompField" - - + + (* Utility ***) -let rec replaceLastInList - (lst: A.expression list) - (how: A.expression -> A.expression) : A.expression list= +let rec replaceLastInList + (lst: A.expression list) + (how: A.expression -> A.expression) : A.expression list= match lst with [] -> [] | [e] -> [how e] @@ -2214,28 +2261,28 @@ let convBinOp (bop: A.binary_operator) : binop = | _ -> E.s (error "convBinOp") (**** PEEP-HOLE optimizations ***) -let afterConversion (c: chunk) : chunk = +let afterConversion (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 + (* 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 collapseCallCast = function Call(Some(Var vi, NoOffset), f, args, l), - Set(destlv, CastE (newt, Lval(Var vi', NoOffset)), _) - when (not vi.vglob && + Set(destlv, CastE (newt, Lval(Var vi', NoOffset)), _) + when (not vi.vglob && String.length vi.vname >= 3 && - (* Watch out for the possibility that we have an implied cast in + (* Watch out for the possibility that we have an implied cast in * the call *) - (let tcallres = + (let tcallres = match unrollType (typeOf f) with TFun (rt, _, _, _) -> rt | _ -> E.s (E.bug "Function call to a non-function") - in + in Util.equals (typeSig tcallres) (typeSig vi.vtype) && - Util.equals (typeSig newt) (typeSig (typeOfLval destlv))) && + Util.equals (typeSig newt) (typeSig (typeOfLval destlv))) && IH.mem callTempVars vi.vid && - vi' == vi) + vi' == vi) -> Some [Call(Some destlv, f, args, l)] | i1,i2 -> None in @@ -2246,26 +2293,26 @@ let afterConversion (c: chunk) : chunk = { c with stmts = sl; postins = [] } (***** Try to suggest a name for the anonymous structures *) -let suggestAnonName (nl: A.name list) = - match nl with +let suggestAnonName (nl: A.name list) = + match nl with [] -> "" | (n, _, _, _) :: _ -> n (** Optional constant folding of binary operations *) -let optConstFoldBinOp (machdep: bool) (bop: binop) - (e1: exp) (e2:exp) (t: typ) = - if !lowerConstants then +let optConstFoldBinOp (machdep: bool) (bop: binop) + (e1: exp) (e2:exp) (t: typ) = + if !lowerConstants then constFoldBinOp machdep bop e1 e2 t else BinOp(bop, e1, e2, t) - + (****** TYPE SPECIFIERS *******) -let rec doSpecList (suggestedAnonName: string) (* This string will be part of - * the names for anonymous +let rec doSpecList (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 + (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 *) @@ -2275,23 +2322,23 @@ let rec doSpecList (suggestedAnonName: string) (* This string will be part of (* 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 + * 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 + * 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 + (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 + if !storage <> NoStorage then E.s (error "Multiple storage specifiers"); - let sto' = + let sto' = match st with A.NO_STORAGE -> NoStorage | A.AUTO -> NoStorage @@ -2309,14 +2356,14 @@ let rec doSpecList (suggestedAnonName: string) (* This string will be part of 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 + + 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 n :: (_ :: _ as rest) when not !msvcMode -> + match tspecs with + A.Tnamed n :: (_ :: _ as rest) when not !msvcMode -> (* If rest contains "short" or "long" then drop the Tnamed *) - if List.exists (function A.Tshort -> true + if List.exists (function A.Tshort -> true | A.Tlong -> true | _ -> false) rest then rest else @@ -2325,7 +2372,7 @@ let rec doSpecList (suggestedAnonName: string) (* This string will be part of | _ -> tspecs in (* Sort the type specifiers *) - let sortedspecs = + let sortedspecs = let order = function (* Don't change this *) | A.Tvoid -> 0 | A.Tsigned -> 1 @@ -2339,24 +2386,24 @@ let rec doSpecList (suggestedAnonName: string) (* This string will be part of | A.Tdouble -> 9 | _ -> 10 (* There should be at most one of the others *) in - List.stable_sort (fun ts1 ts2 -> compare (order ts1) (order ts2)) tspecs' + List.stable_sort (fun ts1 ts2 -> 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. + so they will be returned by doSpecAttr and used in the variable + declaration. Testcase: small1/attr9.c *) let an, af, at = cabsPartitionAttributes ~default:AttrType !attrs in attrs := an; (* Save the name attributes for later *) if af <> [] then E.s (error "Invalid position for function type attributes."); at - in + in (* And now try to make sense of it. See ISO 6.7.2 *) - let bt = + let bt = match sortedspecs with [A.Tvoid] -> TVoid [] | [A.Tchar] -> TInt(IChar, []) @@ -2408,15 +2455,16 @@ let rec doSpecList (suggestedAnonName: string) (* This string will be part of | [A.Tdouble] -> TFloat(FDouble, []) | [A.Tlong; A.Tdouble] -> TFloat(FLongDouble, []) + | [A.Tfloat128] -> TFloat(FLongDouble, []) (* TODO: Correct? *) (* Now the other type specifiers *) | [A.Tnamed n] -> begin - if n = "__builtin_va_list" && + if n = "__builtin_va_list" && !Machdep.theMachine.Machdep.__builtin_va_list then begin TBuiltin_va_list [] end else - let t = - match lookupType "type" n with + let t = + match lookupType "type" n with (TNamed _) as x, _ -> x | typ -> E.s (error "Named type %s is not mapped correctly" n) in @@ -2462,8 +2510,8 @@ let rec doSpecList (suggestedAnonName: string) (* This string will be part of (* Create the enuminfo, or use one that was created already for a * forward reference *) - let enum, _ = createEnumInfo n'' in - let a = extraAttrs @ (getTypeAttrs ()) in + let enum, _ = createEnumInfo n'' in + let a = extraAttrs @ (getTypeAttrs ()) in enum.eattr <- doAttributes a; let res = TEnum (enum, []) in let smallest = ref zero_cilint in @@ -2473,11 +2521,11 @@ let rec doSpecList (suggestedAnonName: string) (* This string will be part of 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 + 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 signed types. + constant's type is the smallest type (but at least int) that + will hold the value, with a preference for signed 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 @@ -2491,7 +2539,7 @@ let rec doSpecList (suggestedAnonName: string) (* This string will be part of smallest := i; if compare_cilint i !largest > 0 then largest := i; - if !msvcMode then + if !msvcMode then IInt else (* This matches gcc's behaviour *) @@ -2504,15 +2552,15 @@ let rec doSpecList (suggestedAnonName: string) (* This string will be part of 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 + (* 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 *) addLocalToEnv kname (EnvEnum (i, res)); - - (* add this tag to the list so that it ends up in the real + + (* 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 - + (kname, (newname, i, loc)) :: loop (increm i 1) rest end @@ -2521,20 +2569,20 @@ let rec doSpecList (suggestedAnonName: string) (* This string will be part of | (kname, 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 e in - let e'' = - match getInteger (constFold true e') with - Some n -> - let ik = updateEnum n in - if !lowerConstants then kintegerCilint ik n else e' + let e'' = + match getInteger (constFold true e') with + Some n -> + let ik = updateEnum n in + if !lowerConstants then kintegerCilint ik n else e' | _ -> E.s (error "Constant initializer %a not an integer" d_exp e') in processName kname e'' (convLoc cloc) rest in - + let fields = loop zero eil in (* Now set the right set of items *) enum.eitems <- Util.list_map (fun (_, x) -> x) fields; @@ -2543,7 +2591,7 @@ let rec doSpecList (suggestedAnonName: string) (* This string will be part of let unsigned = compare_cilint !smallest zero_cilint >= 0 in let smallKind = intKindForValue !smallest unsigned in let largeKind = intKindForValue !largest unsigned in - let ekind = + let ekind = if (bytesSizeOfInt smallKind) > (bytesSizeOfInt largeKind) then smallKind else @@ -2555,7 +2603,7 @@ let rec doSpecList (suggestedAnonName: string) (* This string will be part of ekind else if unsigned then IUInt else IInt - else + else ekind end; (* Record the enum name in the environment *) @@ -2563,16 +2611,16 @@ let rec doSpecList (suggestedAnonName: string) (* This string will be part of (* And define the tag *) cabsPushGlobal (GEnumTag (enum, !currentLoc)); res - - - | [A.TtypeofE e] -> + + + | [A.TtypeofE e] -> let (c, e', t) = doExp false e AType in - let t' = - match e' with + let t' = + match e' with StartOf(lv) -> typeOfLval lv (* If this is a string literal, then we treat it as in sizeof*) | Const (CStr s) -> begin - match typeOf e' with + match typeOf e' with TPtr(bt, _) -> (* This is the type of array elements *) TArray(bt, Some (SizeOfStr s), []) | _ -> E.s (bug "The typeOf a string is not a pointer type") @@ -2584,15 +2632,15 @@ let rec doSpecList (suggestedAnonName: string) (* This string will be part of *) !typeForTypeof t' - | [A.TtypeofT (specs, dt)] -> + | [A.TtypeofT (specs, dt)] -> let typ = doOnlyType specs dt in typ - | _ -> + | _ -> E.s (error "Invalid combination of type specifiers") 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 = @@ -2601,30 +2649,28 @@ and convertCVtoAttr (src: A.cvspec list) : A.attribute list = | CV_CONST :: tl -> ("const",[]) :: (convertCVtoAttr tl) | CV_VOLATILE :: tl -> ("volatile",[]) :: (convertCVtoAttr tl) | CV_RESTRICT :: tl -> ("restrict",[]) :: (convertCVtoAttr tl) + | CV_COMPLEX :: tl -> ("complex",[]) :: (convertCVtoAttr tl) -and makeVarInfoCabs +and makeVarInfoCabs ~(isformal: bool) - ~(isglobal: bool) + ~(isglobal: bool) (ldecl : location) (bt, sto, inline, attrs) - (n,ndt,a) - : varinfo = - let vtype, nattr = - doType (AttrName false) - ~allowVarSizeArrays:isformal (* For locals we handle var-sized arrays - before makeVarInfoCabs; for formals - we do it afterwards *) + (n,ndt,a) + : varinfo = + let vtype, nattr = + doType (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in if inline && not (isFunctionType vtype) then ignore (error "inline for a non-function: %s" n); - let t = + let t = if not isglobal && not isformal && not (sto = Static) then begin - (* Sometimes we call this on the formal argument of a function with no + (* 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 + end else vtype in let vi = makeVarinfo isglobal n t in @@ -2634,8 +2680,8 @@ and makeVarInfoCabs vi.vattr <- nattr; vi.vdecl <- ldecl; - if false then - ignore (E.log "Created varinfo %s : %a\n" vi.vname d_type vi.vtype); + if false then + ignore (E.log "Created varinfo %s : %a\n" vi.vname d_type vi.vtype); vi @@ -2643,33 +2689,41 @@ and makeVarInfoCabs and makeVarSizeVarInfo (ldecl : location) spec_res (n,ndt,a) - : varinfo * chunk * exp * bool = - if not !msvcMode then + : varinfo * chunk * bool = + let rec insertArrayLengths (t:typ) (e:exp list):typ = + match t, e with + | TArray (t, None, a), e::es -> TArray(insertArrayLengths t es, Some e, a) + | TArray (t, Some e, a), es -> TArray(insertArrayLengths t es, Some e, a) + | TPtr (t, a), es -> TPtr(insertArrayLengths t es, a) + | a, [] -> a + | a, _ -> E.s (error "Something phishy is going on with VLAs, typ does not have as many arrays of length None as exp we want to substitute"); + in + if not !msvcMode then match isVariableSizedArray ndt with - None -> - makeVarInfoCabs ~isformal:false - ~isglobal:false - ldecl spec_res (n,ndt,a), empty, zero, false - | Some (ndt', se, len) -> - makeVarInfoCabs ~isformal:false - ~isglobal:false - ldecl spec_res (n,ndt',a), se, len, true + None -> + makeVarInfoCabs ~isformal:false + ~isglobal:false + ldecl spec_res (n,ndt,a), empty, false + | Some (ndt', se, len) -> + let vi = makeVarInfoCabs ~isformal:false ~isglobal:false ldecl spec_res (n,ndt',a) in + vi.vtype <- insertArrayLengths vi.vtype len; (* patch the correct length for the array back-in *) + vi, se, true else makeVarInfoCabs ~isformal:false - ~isglobal:false - ldecl spec_res (n,ndt,a), empty, zero, false + ~isglobal:false + ldecl spec_res (n,ndt,a), empty, false -and doAttr (a: A.attribute) : attribute list = +and doAttr (a: A.attribute) : attribute list = (* Strip the leading and trailing underscore *) - let stripUnderscore (n: string) : string = + let stripUnderscore (n: string) : string = let l = String.length n in - let rec start i = - if i >= l then + let rec start i = + if i >= l then E.s (error "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 = + 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 @@ -2679,21 +2733,21 @@ and doAttr (a: A.attribute) : attribute list = match a with | ("__attribute__", []) -> [] (* An empty list of gcc attributes *) | (s, []) -> [Attr (stripUnderscore s, [])] - | (s, el) -> - - let rec attrOfExp (strip: bool) - ?(foldenum=true) + | (s, el) -> + + let rec attrOfExp (strip: bool) + ?(foldenum=true) (a: A.expression) : attrparam = match a with A.VARIABLE n -> begin let n' = if strip then stripUnderscore n else n in - (** See if this is an enumeration *) + (* See if this is an enumeration *) try if not foldenum then raise Not_found; - match H.find env n' with + match H.find env n' with EnvEnum (tag, _), _ -> begin - match getInteger (constFold true tag) with + match getInteger (constFold true tag) with Some i when !lowerConstants -> AInt (cilint_to_int i) | _ -> ACons(n', []) end @@ -2703,9 +2757,9 @@ and doAttr (a: A.attribute) : attribute list = | A.CONSTANT (A.CONST_STRING s) -> AStr s | A.CONSTANT (A.CONST_INT str) -> begin match parseInt str with - Const (CInt64 (v64,_,_)) -> + Const (CInt64 (v64,_,_)) -> AInt (i64_to_int v64) - | _ -> + | _ -> E.s (error "Invalid attribute constant: %s") end | A.CALL(A.VARIABLE n, args) -> begin @@ -2717,24 +2771,24 @@ and doAttr (a: A.attribute) : attribute list = | A.TYPE_SIZEOF (bt, dt) -> ASizeOf (doOnlyType bt dt) | A.EXPR_ALIGNOF e -> AAlignOfE (ae e) | A.TYPE_ALIGNOF (bt, dt) -> AAlignOf (doOnlyType bt dt) - | A.BINARY(A.AND, aa1, aa2) -> + | A.BINARY(A.AND, aa1, aa2) -> ABinOp(LAnd, ae aa1, ae aa2) - | A.BINARY(A.OR, aa1, aa2) -> + | A.BINARY(A.OR, aa1, aa2) -> ABinOp(LOr, ae aa1, ae aa2) - | A.BINARY(abop, aa1, 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.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) - | _ -> + | _ -> ignore (E.log "Invalid expression in attribute: "); withCprint Cprint.print_expression a; E.s (error "cabs2cil: invalid expression") @@ -2744,7 +2798,7 @@ and doAttr (a: A.attribute) : attribute list = (* Sometimes we need to convert attrarg into attr *) let arg2attr = function | ACons (s, args) -> Attr (s, args) - | a -> + | a -> E.s (error "Invalid form of attribute: %a" d_attrparam a); in @@ -2763,21 +2817,21 @@ and doAttributes (al: A.attribute list) : attribute list = (* 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 - ~(default:attributeClass) +and cabsPartitionAttributes + ~(default:attributeClass) (attrs: A.attribute list) : - A.attribute list * A.attribute list * 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 a with + | a :: rest -> + let kind = match doAttr a with [] -> default - | Attr(an, _)::_ -> + | Attr(an, _)::_ -> (try H.find attributeHash an with Not_found -> default) in - match kind with + match kind with AttrName _ -> loop (a::n, f, t) rest - | AttrFunType _ -> + | AttrFunType _ -> loop (n, a::f, t) rest | AttrType -> loop (n, f, a::t) rest in @@ -2785,27 +2839,26 @@ and cabsPartitionAttributes -and doType (nameortype: attributeClass) (* This is AttrName if we are doing - * the type for a name, or AttrType - * if we are doing this type in a +and doType (nameortype: attributeClass) (* This is AttrName if we are doing + * the type for a name, or AttrType + * if we are doing this type in a * typedef *) - ?(allowVarSizeArrays=false) (bt: typ) (* The base type *) - (dt: A.decl_type) - (* Returns the new type and the accumulated name (or type attribute + (dt: A.decl_type) + (* Returns the new type and the accumulated name (or type attribute if nameoftype = AttrType) attributes *) - : typ * attribute list = + : 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 + (* 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) -> + | A.PARENTYPE (a1, d, a2) -> let a1' = doAttributes a1 in - let a1n, a1f, a1t = partitionAttributes AttrType a1' in + let a1n, a1f, a1t = partitionAttributes ~default:AttrType a1' in let a2' = doAttributes a2 in - let a2n, a2f, a2t = partitionAttributes nameortype a2' in + let a2n, a2f, a2t = partitionAttributes ~default:nameortype a2' in (* ignore (E.log "doType: %a @[a1n=%a@!a1f=%a@!a1t=%a@!a2n=%a@!a2f=%a@!a2t=%a@]@!" d_loc !currentLoc d_attrlist a1n d_attrlist a1f d_attrlist a1t d_attrlist a2n d_attrlist a2f d_attrlist a2t); *) @@ -2813,8 +2866,8 @@ and doType (nameortype: attributeClass) (* This is AttrName if we are doing (* ignore (E.log "bt' = %a\n" d_type bt'); *) - let bt'', a1fadded = - match unrollType bt with + let bt'', a1fadded = + match unrollType bt with TFun _ -> cabsTypeAddAttributes a1f bt', true | _ -> bt', false in @@ -2823,9 +2876,9 @@ and doType (nameortype: attributeClass) (* This is AttrName if we are doing (* 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 _ -> + let restyp' = + match unrollType restyp with + TFun _ -> if a1fadded then cabsTypeAddAttributes a2f restyp else @@ -2837,9 +2890,9 @@ and doType (nameortype: attributeClass) (* This is AttrName if we are doing else TPtr(cabsTypeAddAttributes a2f (cabsTypeAddAttributes a1f tf), ap) - | _ -> + | _ -> if a1f <> [] && not a1fadded then - E.s (error "Invalid position for (prefix) function type attributes:%a" + E.s (error "Invalid position for (prefix) function type attributes:%a" d_attrlist a1f); if a2f <> [] then E.s (error "Invalid position for (post) function type attributes:%a" @@ -2852,18 +2905,18 @@ and doType (nameortype: attributeClass) (* This is AttrName if we are doing (* Now add the name attributes and return *) restyp', cabsAddAttributes a1n (cabsAddAttributes a2n nattr) - | A.PTR (al, d) -> + | A.PTR (al, d) -> let al' = doAttributes al in - let an, af, at = partitionAttributes AttrType al' in + let an, af, at = partitionAttributes ~default: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' = + let restyp' = match unrollType restyp with TFun _ -> cabsTypeAddAttributes af restyp | TPtr((TFun _ as tf), ap) -> TPtr(cabsTypeAddAttributes af tf, ap) - | _ -> + | _ -> if af <> [] then E.s (error "Invalid position for function type attributes:%a" d_attrlist af); @@ -2871,63 +2924,63 @@ and doType (nameortype: attributeClass) (* This is AttrName if we are doing in (* Now add the name attributes and return *) restyp', cabsAddAttributes an nattr - - | A.ARRAY (d, al, len) -> - let lo = - match len with - A.NOTHING -> None - | _ -> + + | A.ARRAY (d, al, len) -> + let lo = + match len with + | A.NOTHING -> None + | _ -> + begin (* 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 len in - if not (isIntegralType (typeOf len')) then - E.s (error "Array length %a does not have an integral type."); - if not allowVarSizeArrays then begin - (* Assert that len' is a constant *) - (match constFold true len' with - Const(CInt64(i, ik, _)) -> - (* We want array sizes to be positive *) - let elems = mkCilint ik i in - if compare_cilint elems zero_cilint < 0 then - E.s (error "Length of array is negative"); - | l -> - if isConstant l 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.*) - ignore(warn "Unable to do constant-folding on array length %a. Some CIL operations on this array may fail." - d_exp l) - else - E.s (error "Length of array is not a constant: %a" - d_exp l)) - end; - Some len' + We used to also cast the length to int here, but that's + theoretically too restrictive on 64-bit machines. *) + match doPureExp len with + | Some len' -> + begin + if not (isIntegralType (typeOf len')) then + E.s (error "Array length %a does not have an integral type.") + else + match constFold true len' with + | Const(CInt64(i, ik, _)) -> + (* If len' is a constant, we check that the array size is non-negative *) + let elems = mkCilint ik i in + if compare_cilint elems zero_cilint < 0 then + E.s (error "Length of array is negative") + else + Some len' + | _ -> + (* otherwise we proceed and it is up to the user to ensure that the value is ok *) + Some len' + end + | None -> + (* If this expression is not pure here, we will later patch in the correct expression *) + None + end in let al' = doAttributes al in doDeclType (TArray(bt, lo, al')) acc d - | A.PROTO (d, args, isva) -> + | 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 + (* 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' = + let args', isva' = if args != [] && !msvcMode = not isva then begin - let newisva = ref isva in + let newisva = ref isva in let rec doLast = function - [([A.SpecType (A.Tnamed atn)], (an, A.JUSTBASE, [], _))] - when isOldStyleVarArgTypeName atn && + [([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 @@ -2936,52 +2989,52 @@ and doType (nameortype: attributeClass) (* This is AttrName if we are doing end else (args, isva) in (* Make the argument as for a formal *) - let doOneArg (s, (n, ndt, a, cloc)) : varinfo = + let doOneArg (s, (n, ndt, a, cloc)) : varinfo = let s' = doSpecList n s in - let vi = makeVarInfoCabs ~isformal:true ~isglobal:false + let vi = makeVarInfoCabs ~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). *) + changed to a pointer later, or though typeof). *) addLocalToEnv vi.vname (EnvVar vi); vi in - let targs : varinfo list option = + let targs : varinfo list option = match Util.list_map doOneArg args' with | [] -> None (* No argument list *) - | [t] when isVoidType t.vtype -> + | [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 + (* 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 a' : attributes = - match lo with + let turnArrayIntoPointer (bt: typ) + (lo: exp option) (a: attributes) : typ = + let a' : attributes = + match lo with None -> a - | Some l -> begin + | Some l -> begin (* Transform the length into an attribute expression *) - try + try let la : attrparam = expToAttrParam l in addAttribute (Attr("arraylen", [ la ])) a with NotAnAttrParam _ -> begin ignore (warn "Cannot represent the length of array as an attribute"); - + a (* Leave unchanged *) - end + end end in TPtr(bt, a') in - let rec fixupArgumentTypes (argidx: int) (args: varinfo list) : unit = + let rec fixupArgumentTypes (argidx: int) (args: varinfo list) : unit = match args with [] -> () - | a :: args' -> + | a :: args' -> (match unrollType a.vtype with - TArray(bt,lo,attr) -> + TArray(bt,lo,attr) -> (* Note that for multi-dimensional arrays we strip off only the first TArray and leave bt alone. *) a.vtype <- turnArrayIntoPointer bt lo attr @@ -2989,22 +3042,22 @@ and doType (nameortype: attributeClass) (* This is AttrName if we are doing | TComp (comp, _) -> begin match isTransparentUnion a.vtype with None -> () - | Some fstfield -> - transparentUnionArgs := + | Some fstfield -> + transparentUnionArgs := (argidx, a.vtype) :: !transparentUnionArgs; a.vtype <- fstfield.ftype; end | _ -> ()); fixupArgumentTypes (argidx + 1) args' in - let args = - match targs with + let args = + match targs with None -> None - | Some argl -> + | Some argl -> fixupArgumentTypes 0 argl; Some (Util.list_map (fun a -> (a.vname, a.vtype, a.vattr)) argl) in - let tres = + let tres = match unrollType bt with TArray(t,lo,attr) -> turnArrayIntoPointer t lo attr | _ -> bt @@ -3014,32 +3067,46 @@ and doType (nameortype: attributeClass) (* This is AttrName if we are doing in doDeclType bt [] dt -(* If this is a declarator for a variable size array then turn it into a +(* If this is a declarator for a variable size array then turn it into a pointer type and a length *) -and isVariableSizedArray (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 != A.NOTHING -> +and isVariableSizedArray (dt: A.decl_type): (A.decl_type * chunk * exp list) option = + let isVLA = ref false in + let rec handleTopLevel (dt: A.decl_type): (A.decl_type * chunk * exp list) = + match dt with + | ARRAY (dt, al, lo) when lo != A.NOTHING -> + let dt', chunk', exp' = handleTopLevel dt in (* Try to compile the expression to a constant *) let (se, e', _) = doExp true lo (AExp (Some intType)) in - if isNotEmpty se || not (isConstant e') then begin - res := Some (se, e'); - PTR (al, JUSTBASE) - end else - ARRAY (JUSTBASE, al, lo) - | ARRAY (dt, al, lo) -> ARRAY (findArray dt, al, lo) - | PTR (al, dt) -> PTR (al, findArray dt) - | JUSTBASE -> JUSTBASE - | PARENTYPE (prea, dt, posta) -> PARENTYPE (prea, findArray dt, posta) - | PROTO (dt, f, a) -> PROTO (findArray dt, f, a) + if isNotEmpty se || not (isConstant e') then + begin + isVLA := true; + let new_e = if doPureExp lo = None then [e'] else [] in + ARRAY (dt', al, lo), se @@ chunk', new_e @ exp' (* here we need this to be replaced with the size we just computed *) + end + else + ARRAY (dt', al, lo), chunk', exp' + | ARRAY (dt, al, lo) -> + let dt', chunk', exp' = handleTopLevel dt in + ARRAY (dt', al, lo), chunk', exp' + | PTR (al, dt) -> + let dt', chunk', exp' = handleTopLevel dt in + PTR (al, dt'), chunk', exp' + | JUSTBASE -> + JUSTBASE, empty, [] + | PARENTYPE (prea, dt, posta) -> + let dt', chunk', exp' = handleTopLevel dt in + PARENTYPE (prea, dt', posta), chunk', exp' + | PROTO (dt, f, a) -> + let dt', chunk', exp' = handleTopLevel dt in + PROTO (dt', f, a), chunk', exp' in - let dt' = findArray dt in - match !res with - None -> None - | Some (se, e) -> Some (dt', se, e) + let dt', c, es = handleTopLevel dt in + if !isVLA then + Some(dt', c, es) + else + None -and doOnlyType (specs: A.spec_elem list) (dt: A.decl_type) : typ = +and doOnlyType (specs: A.spec_elem list) (dt: A.decl_type) : typ = let bt',sto,inl,attrs = doSpecList "" specs in if sto <> NoStorage || inl then E.s (error "Storage or inline specifier in type only"); @@ -3052,18 +3119,18 @@ and doOnlyType (specs: A.spec_elem list) (dt: A.decl_type) : typ = and makeCompType (isstruct: bool) (n: string) - (nglist: A.field_group list) - (a: attribute list) = + (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 + (* 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' in - let doFieldGroup ((s: A.spec_elem list), + let doFieldGroup ((s: A.spec_elem list), (nl: (A.name * A.expression option) list)) : 'a list = (* Do the specifiers exactly once *) - let sugg = match nl with + let sugg = match nl with [] -> "" | ((n, _, _, _), _) :: _ -> n in @@ -3071,11 +3138,11 @@ and makeCompType (isstruct: bool) (* Do the fields *) let makeFieldInfo (((n,ndt,a,cloc) : A.name), (widtho : A.expression option)) - : fieldinfo = - if sto <> NoStorage || inl then + : fieldinfo = + if sto <> NoStorage || inl then E.s (error "Storage or inline not allowed for fields"); - let ftype, nattr = - doType (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in + let ftype, nattr = + doType (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in (* check for fields whose type is an undefined struct. This rules out circularity: struct C1 { struct C2 c2; }; //This line is now an error. @@ -3085,8 +3152,8 @@ and makeCompType (isstruct: bool) TComp (ci',_) when not ci'.cdefined -> E.s (error "Type of field %s is an undefined struct." n) | _ -> ()); - let width = - match widtho with + let width = + match widtho with None -> None | Some w -> begin (match unrollType ftype with @@ -3098,15 +3165,15 @@ and makeCompType (isstruct: bool) | None -> E.s (error "bitfield width is not an integer constant") end in - (* If the field is unnamed and its type is a structure of union type + (* If the field is unnamed and its type is a structure of union type * then give it a distinguished name *) - let n' = + let n' = if n = missingFieldName then begin - match unrollType ftype with + match unrollType ftype with TComp _ -> begin incr annonCompFieldNameId; annonCompFieldName ^ (string_of_int !annonCompFieldNameId) - end + end | _ -> n end else n @@ -3117,7 +3184,7 @@ and makeCompType (isstruct: bool) fbitfield = width; fattr = nattr; floc = convLoc cloc - } + } in Util.list_map makeFieldInfo nl in @@ -3125,16 +3192,16 @@ and makeCompType (isstruct: bool) let flds = List.concat (Util.list_map doFieldGroup nglist) 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 coild lead to circularity in - * the type structure. We do a thourough check and then we reuse the type + (* This appears to be a multiply defined structure. This can happen from + * a construct like "typedef struct foo { ... } A, B;". This is dangerous + * because at the time B is processed some forward references in { ... } + * appear as backward references, which could lead to circularity in + * the type structure. We do a thourough check and then we reuse the type * for A *) - let fieldsSig fs = Util.list_map (fun f -> typeSig f.ftype) fs in + let fieldsSig fs = Util.list_map (fun f -> typeSig f.ftype) fs in if not (Util.equals (fieldsSig comp.cfields) (fieldsSig flds)) then ignore (error "%s seems to be multiply defined" (compFullName comp)) - end else + end else comp.cfields <- flds; (* ignore (E.log "makeComp: %s: %a\n" comp.cname d_attrlist a); *) @@ -3150,45 +3217,45 @@ and makeCompType (isstruct: bool) (* Now create a typedef with just this type *) res -and preprocessCast (specs: A.specifier) - (dt: A.decl_type) - (ie: A.init_expression) - : A.specifier * A.decl_type * A.init_expression = +and preprocessCast (specs: A.specifier) + (dt: A.decl_type) + (ie: A.init_expression) + : A.specifier * A.decl_type * A.init_expression = let typ = doOnlyType 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 + (* 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 + (* 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' = + 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), + 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 + (* 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 = + let specs1 = match typ with - TComp (ci, _) -> - Util.list_map - (function - A.SpecType (A.Tstruct ("", flds, [])) -> + TComp (ci, _) -> + Util.list_map + (function + A.SpecType (A.Tstruct ("", flds, [])) -> A.SpecType (A.Tstruct (ci.cname, None, [])) | A.SpecType (A.Tunion ("", flds, [])) -> A.SpecType (A.Tunion (ci.cname, None, [])) | s -> s) specs | _ -> specs in - specs1, dt, ie' + specs1, dt, ie' and getIntConstExp (aexp) : exp = - let c, e, _ = doExp true aexp (AExp None) in - if not (isEmpty c) then + let c, e, _ = doExp true aexp (AExp None) in + if not (isEmpty c) then E.s (error "Constant expression %a has effects" d_exp e); - match e with + match e with (* first, filter for those Const exps that are integers *) | Const (CInt64 _ ) -> e | Const (CEnum _) -> e @@ -3196,7 +3263,7 @@ and getIntConstExp (aexp) : exp = (* other Const expressions are not ok *) | Const _ -> E.s (error "Expected integer constant and got %a" d_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 *) @@ -3210,50 +3277,50 @@ and isIntegerConstant (aexp) : int option = | _ -> None end | _ -> None - + (* Process an expression and in the process do some type checking, * extract the effects as separate statements *) and doExp (asconst: bool) (* This expression is used as a constant *) - (e: A.expression) - (what: expAction) : (chunk * exp * typ) = - (* A subexpression of array type is automatically turned into StartOf(e). - * Similarly an expression of function type is turned into AddrOf. So + (e: A.expression) + (what: expAction) : (chunk * exp * typ) = + (* 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 processArrayFun e t = match e, unrollType t with - (Lval(lv) | CastE(_, Lval lv)), TArray(tbase, _, a) -> + (Lval(lv) | CastE(_, Lval lv)), TArray(tbase, _, a) -> mkStartOfAndMark lv, TPtr(tbase, a) - | (Lval(lv) | CastE(_, Lval lv)), TFun _ -> + | (Lval(lv) | CastE(_, Lval lv)), TFun _ -> mkAddrOfAndMark lv, TPtr(t, []) - | _, (TArray _ | TFun _) -> + | _, (TArray _ | TFun _) -> E.s (error "Array or function expression is not lval: %a@!" d_plainexp e) | _ -> e, t in (* Before we return we call finishExp *) - let finishExp ?(newWhat=what) - (se: chunk) (e: exp) (t: typ) : chunk * exp * typ = - match newWhat with - ADrop + let finishExp ?(newWhat=what) + (se: chunk) (e: exp) (t: typ) : chunk * exp * typ = + match newWhat with + ADrop | AType -> (se, e, t) - | AExpLeaveArrayFun -> - (se, e, t) (* It is important that we do not do "processArrayFun" in - * this case. We exploit this when we process the typeOf + | AExpLeaveArrayFun -> + (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 _ -> + | AExp _ -> let (e', t') = processArrayFun e t in (* - ignore (E.log "finishExp: e'=%a, t'=%a\n" + ignore (E.log "finishExp: e'=%a, t'=%a\n" d_exp e' d_type t'); *) (se, e', t') | ASet (lv, lvt) -> begin (* See if the set was done already *) - match e with - Lval(lv') when lv == lv' -> + match e with + Lval(lv') when lv == lv' -> (se, e, t) - | _ -> + | _ -> let (e', t') = processArrayFun e t in let (t'', e'') = castTo t' lvt e' in (* @@ -3262,18 +3329,18 @@ and doExp (asconst: bool) (* This expression is used as a constant *) (se +++ (Set(lv, e'', !currentLoc)), e'', t'') end in - let rec findField (n: string) (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 + let findField (n: string) (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 [] -> NoOffset (* Did not find *) | fid :: rest when fid.fname = n -> Field(fid, NoOffset) | fid :: rest when prefix annonCompFieldName fid.fname -> begin - match unrollType fid.ftype with - TComp (ci, _) -> + match unrollType fid.ftype with + TComp (ci, _) -> let off = search ci.cfields in - if off = NoOffset then + if off = NoOffset then search rest (* Continue searching *) else Field (fid, off) @@ -3282,7 +3349,7 @@ and doExp (asconst: bool) (* This expression is used as a constant *) | _ :: rest -> search rest in let off = search fidlist in - if off = NoOffset then + if off = NoOffset then E.s (error "Cannot find field %s" n); off in @@ -3301,17 +3368,17 @@ and doExp (asconst: bool) (* This expression is used as a constant *) let envdata = H.find env n in match envdata with EnvVar vi, _ -> - (* if isconst && - not (isFunctionType vi.vtype) && + (* if isconst && + not (isFunctionType vi.vtype) && not (isArrayType vi.vtype)then E.s (error "variable appears in constant"); *) finishExp empty (Lval(var vi)) vi.vtype | EnvEnum (tag, typ), _ -> - if !Cil.lowerConstants then + if !Cil.lowerConstants then finishExp empty tag (typeOf tag) else begin - let ei = - match unrollType typ with + let ei = + match unrollType typ with TEnum(ei, _) -> ei | _ -> assert false in @@ -3320,9 +3387,9 @@ and doExp (asconst: bool) (* This expression is used as a constant *) | _ -> raise Not_found with Not_found -> begin - if isOldStyleVarArgName n then + if isOldStyleVarArgName n then E.s (error "Cannot resolve variable %s. This could be a CIL bug due to the handling of old-style variable argument functions." n) - else + else E.s (error "Cannot resolve variable %s." n) end end @@ -3336,51 +3403,51 @@ and doExp (asconst: bool) (* This expression is used as a constant *) match unrollType t1, unrollType t2 with TPtr(t1e,_), (TInt _|TEnum _) -> e1', t1, e2', t1e | (TInt _|TEnum _), TPtr(t2e,_) -> e2', t2, e1', t2e - | _ -> - E.s (error + | _ -> + E.s (error "Expecting a pointer type in index:@! t1=%a@!t2=%a@!" d_plaintype t1 d_plaintype t2) in (* We have to distinguish the construction based on the type of e1'' *) - let res = - match e1'' with + let res = + match e1'' with StartOf array -> (* A real array indexing operation *) addOffsetLval (Index(e2'', NoOffset)) array | _ -> (* Turn into *(e1 + e2) *) - mkMem (BinOp(IndexPI, e1'', e2'', t1)) NoOffset + mkMem ~addr:(BinOp(IndexPI, e1'', e2'', t1)) ~off:NoOffset in (* Do some optimization of StartOf *) finishExp se (Lval res) tresult - end - | A.UNARY (A.MEMOF, e) -> + end + | A.UNARY (A.MEMOF, e) -> if asconst then ignore (warn "MEMOF in constant"); let (se, e', t) = doExp false e (AExp None) in - let tresult = + let tresult = match unrollType t with | TPtr(te, _) -> te | _ -> E.s (error "Expecting a pointer type in *. Got %a@!" d_plaintype t) in - finishExp se - (Lval (mkMem e' NoOffset)) + finishExp se + (Lval (mkMem ~addr:e' ~off:NoOffset)) tresult - (* e.str = (& e + off(str)). If e = (be + beoff) then e.str = (be + (* e.str = (& e + off(str)). If e = (be + beoff) then e.str = (be * + beoff + off(str)) *) - | A.MEMBEROF (e, str) -> + | A.MEMBEROF (e, str) -> (* member of is actually allowed if we only take the address *) (* if isconst then E.s (error "MEMBEROF in constant"); *) let (se, e', t') = doExp false e (AExp None) in - let lv = - match e' with - Lval x -> x + let lv = + match e' with + Lval x -> x | CastE(_, Lval x) -> x | _ -> E.s (error "Expected an lval in MEMBEROF (field %s)" str) in - let field_offset = + let field_offset = match unrollType t' with TComp (comp, _) -> findField str comp.cfields | _ -> E.s (error "expecting a struct with field %s" str) @@ -3388,38 +3455,37 @@ and doExp (asconst: bool) (* This expression is used as a constant *) let lv' = Lval(addOffsetLval field_offset lv) in let field_type = typeOf lv' in finishExp se lv' field_type - + (* e->str = * (e + off(str)) *) - | A.MEMBEROFPTR (e, str) -> + | A.MEMBEROFPTR (e, str) -> if asconst then ignore (warn "MEMBEROFPTR in constant"); let (se, e', t') = doExp false e (AExp None) in - let pointedt = + let pointedt = match unrollType t' with TPtr(t1, _) -> t1 | TArray(t1,_,_) -> t1 | _ -> E.s (error "expecting a pointer to a struct") in - let field_offset = - match unrollType pointedt with + let field_offset = + match unrollType pointedt with TComp (comp, _) -> findField str comp.cfields - | x -> - E.s (error - "expecting a struct with field %s. Found %a. t1 is %a" + | x -> + E.s (error + "expecting a struct with field %s. Found %a. t1 is %a" str d_type x d_type t') in - let lv' = Lval (mkMem e' field_offset) in + let lv' = Lval (mkMem ~addr:e' ~off:field_offset) in let field_type = typeOf lv' in finishExp se lv' field_type - + | A.CONSTANT ct -> begin - let hasSuffix str = + let hasSuffix str suffix = let l = String.length str in - fun s -> - let ls = String.length s in - l >= ls && s = String.uppercase (String.sub str (l - ls) ls) + let ls = String.length suffix in + l >= ls && String.uppercase_ascii suffix = String.uppercase_ascii (String.sub str (l - ls) ls) in - match ct with + match ct with A.CONST_INT str -> begin let res = parseInt str in finishExp empty res (typeOf res) @@ -3427,29 +3493,29 @@ and doExp (asconst: bool) (* This expression is used as a constant *) (* | A.CONST_WSTRING wstr -> - let len = List.length wstr in + let len = List.length wstr in let wchar_t = !wcharType in - (* We will make an array big enough to contain the wide + (* We will make an array big enough to contain the wide * characters and the wide-null terminator *) let ws_t = TArray(wchar_t, Some (integer len), []) in - let ws = + let ws = makeGlobalVar ("wide_string" ^ string_of_int !lastStructId) ws_t in ws.vstorage <- Static; incr lastStructId; (* Make the initializer. Idx is a wide_char index. *) - let rec loop (idx: int) (s: int64 list) = + let rec loop (idx: int) (s: int64 list) = match s with [] -> [] | wc::rest -> let wc_cilexp = Const (CInt64(wc, IInt, None)) in - (Index(integer idx, NoOffset), + (Index(integer idx, NoOffset), SingleInit (makeCast wc_cilexp wchar_t)) :: loop (idx + 1) rest in (* Add the definition for the array *) - cabsPushGlobal (GVar(ws, + cabsPushGlobal (GVar(ws, {init = Some (CompoundInit(ws_t, loop 0 wstr))}, !currentLoc)); @@ -3457,13 +3523,13 @@ and doExp (asconst: bool) (* This expression is used as a constant *) (TPtr(wchar_t, [])) *) - | A.CONST_WSTRING (ws: int64 list) -> + | A.CONST_WSTRING (ws: int64 list) -> let res = Const(CWStr ((* intlist_to_wstring *) ws)) in finishExp empty res (typeOf res) - | A.CONST_STRING s -> + | A.CONST_STRING s -> (* Maybe we burried __FUNCTION__ in there *) - let s' = + let s' = try let start = String.index s (Char.chr 0) in let l = String.length s in @@ -3480,33 +3546,32 @@ and doExp (asconst: bool) (* This expression is used as a constant *) in let res = Const(CStr s') in finishExp empty res (typeOf res) - + | A.CONST_CHAR char_list -> - let a, b = (interpret_character_constant char_list) in - finishExp empty (Const a) b - + let a, b = (interpret_character_constant char_list) in + finishExp empty (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 + * 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 !wcharType char_list in let result = kinteger64 !wcharKind value in finishExp empty result (typeOf result) - + | A.CONST_FLOAT str -> begin (* Maybe it ends in U or UL. Strip those *) let l = String.length str in - let hasSuffix = hasSuffix str in - let baseint, kind = - if hasSuffix "L" then + let baseint, kind = + if hasSuffix str "L" then String.sub str 0 (l - 1), FLongDouble - else if hasSuffix "F" then + else if hasSuffix str "F" then String.sub str 0 (l - 1), FFloat - else if hasSuffix "D" then + else if hasSuffix str "D" then String.sub str 0 (l - 1), FDouble else str, FDouble @@ -3516,19 +3581,49 @@ and doExp (asconst: bool) (* This expression is used as a constant *) E.log "treating long double constant %s as double constant at %a.\n" str d_loc !currentLoc; try - finishExp empty + finishExp empty (Const(CReal(float_of_string baseint, kind, Some str))) (TFloat(kind,[])) with e -> begin - ignore (E.log "float_of_string %s (%s)\n" str + ignore (E.log "float_of_string %s (%s)\n" str (Printexc.to_string e)); E.hadErrors := true; let res = Const(CStr "booo CONS_FLOAT") in finishExp empty res (typeOf res) end end - end + | A.CONST_COMPLEX str -> begin + (* Maybe it ends in U or UL. Strip those *) + let l = String.length str in + let baseint, kind = + if hasSuffix str "iL" || hasSuffix str "Li" then + String.sub str 0 (l - 2), FComplexLongDouble + else if hasSuffix str "iF" || hasSuffix str "Fi" then + String.sub str 0 (l - 2), FComplexFloat + else if hasSuffix str "iD" || hasSuffix str "Di" then + String.sub str 0 (l - 2), FComplexDouble + else (* A.CONST_COMPLEX always has the suffix i *) + String.sub str 0 (l - 1), FComplexDouble + in + if kind = FLongDouble then + (* We only have 64-bit values in Ocaml *) + E.log "treating long double constant %s as double constant at %a.\n" + str d_loc !currentLoc; + try + finishExp empty + (Const(CReal(float_of_string baseint, kind, + Some str))) + (TFloat(kind,[])) + with e -> begin + ignore (E.log "float_of_string_2 %s (%s)\n" baseint + (Printexc.to_string e)); + E.hadErrors := true; + let res = Const(CStr "booo CONS_FLOAT") in + finishExp empty res (typeOf res) + end + end + end | A.TYPE_SIZEOF (bt, dt) -> let typ = doOnlyType bt dt in @@ -3537,8 +3632,8 @@ and doExp (asconst: bool) (* This expression is used as a constant *) (* Intercept the sizeof("string") *) | A.EXPR_SIZEOF (A.CONSTANT (A.CONST_STRING s)) -> begin (* Process the string first *) - match doExp asconst (A.CONSTANT (A.CONST_STRING s)) (AExp None) with - _, Const(CStr s), _ -> + match doExp asconst (A.CONSTANT (A.CONST_STRING s)) (AExp None) with + _, Const(CStr s), _ -> finishExp empty (SizeOfStr s) !typeOfSizeOf | _ -> E.s (bug "cabs2cil: sizeOfStr") end @@ -3552,7 +3647,7 @@ and doExp (asconst: bool) (* This expression is used as a constant *) d_loc !currentLoc d_plainexp e' d_type t); *) (* !!!! The book says that the expression is not evaluated, so we - * drop the potential side-effects + * drop the potential side-effects if isNotEmpty se then ignore (warn "Warning: Dropping side-effect in EXPR_SIZEOF"); *) @@ -3561,20 +3656,58 @@ and doExp (asconst: bool) (* This expression is used as a constant *) * array we must drop the StartOf *) StartOf(lv) -> SizeOfE (Lval(lv)) - (* Maybe we are taking the sizeof for a CStr. In that case we + (* Maybe we are taking the sizeof for a CStr. In that case we * mean the pointer to the start of the string *) | Const(CStr _) -> SizeOf (charPtrType) (* Maybe we are taking the sizeof a variable-sized array *) | Lval (Var vi, NoOffset) -> begin - try - IH.find varSizeArrays vi.vid - with Not_found -> SizeOfE e' + try + IH.find varSizeArrays vi.vid + with Not_found -> SizeOfE e' end | _ -> SizeOfE e' in finishExp empty size !typeOfSizeOf - + | A.REAL e -> + let (se, e', t) = doExp false e (AExp None) in + let real = Real e' in + finishExp se real (typeOfRealAndImagComponents t) + | A.IMAG e -> + let (se, e', t) = doExp false e (AExp None) in + let imag = Imag e' in + finishExp se imag (typeOfRealAndImagComponents t) + | A.CLASSIFYTYPE e -> + let classify_type t = + match unrollTypeDeep t with (* See gcc/typeclass.h *) + | TVoid _ -> 0 + | TInt (ikind, _) ->begin + match ikind with + | IChar -> 2 + | IBool -> 4 + | _ -> 1 + end + | TFloat (fkind, _) -> begin + match fkind with + | FFloat + | FDouble + | FLongDouble -> 8 + | FComplexFloat + | FComplexDouble + | FComplexLongDouble -> 9 + end + | TEnum _ -> 3 + | TPtr _ -> 5 + | TArray _ -> 14 + | TFun _ -> 10 + | _ -> E.s (E.bug "cabs2cil: failed to classify for __builtin_classify_type") +(* no_type_class = -1, void_type_class 0, integer_type_class 1, char_type_class 2, enumeral_type_class 3, boolean_type_class 4, + pointer_type_class 5, reference_type_class 6, offset_type_class 7, real_type_class 8, + complex_type_class 9, function_type_class 10, method_type_class 11, record_type_class 12, union_type_class 13, array_type_class 14, string_type_class 15, lang_type_class 16 *) + in + let _,_, t = doExp true e (AType) in + let res = Cil.integer (classify_type t) in + finishExp empty (res) (Cil.typeOf res) | A.TYPE_ALIGNOF (bt, dt) -> let typ = doOnlyType bt dt in finishExp empty (AlignOf(typ)) !typeOfSizeOf @@ -3582,7 +3715,7 @@ and doExp (asconst: bool) (* This expression is used as a constant *) | A.EXPR_ALIGNOF e -> let (se, e', t) = doExp false e AExpLeaveArrayFun in (* !!!! The book says that the expression is not evaluated, so we - * drop the potential side-effects + * drop the potential side-effects if isNotEmpty se then ignore (warn "Warning: Dropping side-effect in EXPR_ALIGNOF"); *) @@ -3604,28 +3737,28 @@ and doExp (asconst: bool) (* This expression is used as a constant *) AExp (Some _) -> AExp (Some typ) | AExp None -> what | ADrop | AType | AExpLeaveArrayFun -> what - | ASet (lv, lvt) -> - (* If the cast from typ to lvt would be dropped, then we + | ASet (lv, lvt) -> + (* If the cast from typ to lvt would be dropped, then we * continue with a Set *) - if false && Util.equals (typeSig typ) (typeSig lvt) then + if false && Util.equals (typeSig typ) (typeSig lvt) then what else AExp None (* We'll create a temporary *) in (* Remember here if we have done the Set *) - let (se, e', t'), (needcast: bool) = + let (se, e', t'), (needcast: bool) = match ie' with A.SINGLE_INIT e -> doExp asconst e what', true | A.NO_INIT -> E.s (error "missing expression in cast") | A.COMPOUND_INIT _ -> begin - (* Pretend that we are declaring and initializing a brand new + (* 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 "" s' in - let se1 = + let se1 = if !scopes == [] then begin (* This is a global. Mark the new vars as static *) let spec_res' = @@ -3636,50 +3769,50 @@ and doExp (asconst: bool) (* This expression is used as a constant *) ((newvar, dt', [], cabslu), ie')); empty end else - createLocal spec_res ((newvar, dt', [], cabslu), ie') + createLocal spec_res ((newvar, dt', [], cabslu), ie') in - (* Now pretend that e is just a reference to the newly created + (* Now pretend that e is just a reference to the newly created * variable *) let se, e', t' = doExp asconst (A.VARIABLE newvar) 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 + (* 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 = + let e2, t2 = match unrollType typ, e' with TArray _, StartOf lv -> 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 + (* 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. *) (se1 @@ se, e2, t2), false end in - let (t'', e'') = + 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 + | _ -> + (* 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' + let newtyp, newexp = + if needcast then + castTo ~fromsource:true t' typ e' else t', e' in newtyp, newexp in finishExp se e'' t'' - - | A.UNARY(A.MINUS, e) -> + + | A.UNARY(A.MINUS, e) -> let (se, e', t) = doExp asconst e (AExp None) in if isIntegralType t then let tres = integralPromotion t in - let e'' = + let e'' = match e', tres with | Const(CInt64(i, _, _)), TInt(ik, _) -> kinteger64 ik (Int64.neg i) - | _ -> UnOp(Neg, makeCastT e' t tres, tres) + | _ -> UnOp(Neg, makeCastT ~e:e' ~oldt:t ~newt:tres, tres) in finishExp se e'' tres else @@ -3687,78 +3820,78 @@ and doExp (asconst: bool) (* This expression is used as a constant *) finishExp se (UnOp(Neg,e',t)) t else E.s (error "Unary - on a non-arithmetic type") - - | A.UNARY(A.BNOT, e) -> + + | A.UNARY(A.BNOT, e) -> let (se, e', t) = doExp asconst e (AExp None) in if isIntegralType t then let tres = integralPromotion t in - let e'' = UnOp(BNot, makeCastT e' t tres, tres) in + let e'' = UnOp(BNot, makeCastT ~e:e' ~oldt:t ~newt:tres, tres) in finishExp se e'' tres else E.s (error "Unary ~ on a non-integral type") - - | A.UNARY(A.PLUS, e) -> doExp asconst e what - - + + | A.UNARY(A.PLUS, e) -> doExp asconst e what + + | A.UNARY(A.ADDROF, e) -> begin - match e with + match e with A.COMMA el -> (* GCC extension *) - doExp false + doExp false (A.COMMA (replaceLastInList el (fun e -> A.UNARY(A.ADDROF, e)))) what | A.QUESTION (e1, e2, e3) -> (* GCC extension *) - doExp false + doExp false (A.QUESTION (e1, A.UNARY(A.ADDROF, e2), A.UNARY(A.ADDROF, e3))) what | A.PAREN e1 -> doExp false (A.UNARY(A.ADDROF, e1)) what - | A.VARIABLE s when - isOldStyleVarArgName s - && (match !currentFunctionFDEC.svar.vtype with + | 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 + (* 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 !msvcMode then begin let rec getLast = function [] -> E.s (unimp "old-style variable argument function without real arguments") | [a] -> a - | _ :: rest -> getLast rest + | _ :: rest -> getLast rest in let last = getLast !currentFunctionFDEC.sformals in let res = mkAddrOfAndMark (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 + (* Now we must add to this address to point to the next * argument. Round up to a multiple of 4 *) - let sizeOfLast = + let sizeOfLast = (((bitsSizeOf last.vtype) + 31) / 32) * 4 in - let res'' = + let res'' = BinOp(PlusA, res', kinteger IULong sizeOfLast, tres') in finishExp 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 + 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 asconst - (A.CALL (A.VARIABLE "__builtin_next_arg", + (A.CALL (A.VARIABLE "__builtin_next_arg", [A.CONSTANT (A.CONST_INT "0")])) what end | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) - A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ | + A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ | A.CONSTANT (A.CONST_STRING _) | A.CONSTANT (A.CONST_WSTRING _) | A.CAST (_, A.COMPOUND_INIT _)) -> begin let (se, e', t) = doExp false e (AExp None) in (* ignore (E.log "ADDROF on %a : %a\n" d_plainexp e' d_plaintype t); *) - match e' with - ( Lval x | CastE(_, Lval x)) -> + match e' with + ( Lval x | CastE(_, Lval x)) -> finishExp se (mkAddrOfAndMark x) (TPtr(t, [])) | StartOf (lv) -> @@ -3769,7 +3902,7 @@ and doExp (asconst: bool) (* This expression is used as a constant *) (* string to array *) finishExp se x (TPtr(t, [])) - (* Function names are converted into pointers to the function. + (* 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 se e' t @@ -3780,15 +3913,15 @@ and doExp (asconst: bool) (* This expression is used as a constant *) | _ -> E.s (error "Unexpected operand for addrof") end | A.UNARY((A.PREINCR|A.PREDECR) as uop, e) -> begin - match e with + match e with A.COMMA el -> (* GCC extension *) - doExp asconst - (A.COMMA (replaceLastInList el + doExp asconst + (A.COMMA (replaceLastInList el (fun e -> A.UNARY(uop, e)))) what | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *) - doExp asconst - (A.QUESTION (e1, A.UNARY(uop, e2q), + doExp asconst + (A.QUESTION (e1, A.UNARY(uop, e2q), A.UNARY(uop, e3q))) what | A.PAREN e1 -> @@ -3800,96 +3933,96 @@ and doExp (asconst: bool) (* This expression is used as a constant *) if asconst then ignore (warn "PREINCR or PREDECR in constant"); let (se, e', t) = doExp false e (AExp None) in - let lv = - match e' with + let lv = + match e' with Lval x -> x - | CastE (_, Lval x) -> x (* A GCC extension. The operation is - * done at the cast type. The result + | CastE (_, Lval x) -> x (* A GCC extension. The operation is + * done at the cast type. The result * is also of the cast type *) | _ -> E.s (error "Expected lval for ++ or --") in let tresult, result = doBinOp uop' e' t one intType in - finishExp (se +++ (Set(lv, makeCastT result tresult t, + finishExp (se +++ (Set(lv, makeCastT ~e:result ~oldt:tresult ~newt:t, !currentLoc))) e' t end | _ -> E.s (error "Unexpected operand for prefix -- or ++") end - + | A.UNARY((A.POSINCR|A.POSDECR) as uop, e) -> begin - match e with + match e with A.COMMA el -> (* GCC extension *) - doExp asconst - (A.COMMA (replaceLastInList el + doExp asconst + (A.COMMA (replaceLastInList el (fun e -> A.UNARY(uop, e)))) what | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *) - doExp asconst + doExp asconst (A.QUESTION (e1, A.UNARY(uop, e2q), A.UNARY(uop, e3q))) what | A.PAREN e1 -> doExp asconst (A.UNARY(uop,e1)) what | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) - A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ | + A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ | A.CAST _ (* A GCC extension *) ) -> begin if asconst then ignore (warn "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 (se, e', t) = doExp false e (AExp None) in - let lv = - match e' with + let lv = + match e' with Lval x -> x - | CastE (_, Lval x) -> x (* GCC extension. The addition must - * be be done at the cast type. The - * result of this is also of the cast + | CastE (_, 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 *) | _ -> E.s (error "Expected lval for ++ or --") in let tresult, opresult = doBinOp uop' e' t one intType in - let se', result = - if what <> ADrop && what <> AType then - let descr = (dd_exp () e') + let se', result = + if what <> ADrop && what <> AType then + let descr = (dd_exp () e') ++ (if uop = A.POSINCR then text "++" else text "--") in let tmp = newTempVar descr true t in se +++ (Set(var tmp, e', !currentLoc)), Lval(var tmp) else se, e' in - finishExp - (se' +++ (Set(lv, makeCastT opresult tresult (typeOfLval lv), + finishExp + (se' +++ (Set(lv, makeCastT ~e:opresult ~oldt:tresult ~newt:(typeOfLval lv), !currentLoc))) result t end | _ -> E.s (error "Unexpected operand for suffix ++ or --") end - + | A.BINARY(A.ASSIGN, e1, e2) -> begin - match e1 with + match e1 with A.COMMA el -> (* GCC extension *) - doExp asconst - (A.COMMA (replaceLastInList el + doExp asconst + (A.COMMA (replaceLastInList el (fun e -> A.BINARY(A.ASSIGN, e, e2)))) what | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *) - doExp asconst - (A.QUESTION (e1, A.BINARY(A.ASSIGN, e2q, e2), + doExp asconst + (A.QUESTION (e1, A.BINARY(A.ASSIGN, e2q, e2), A.BINARY(A.ASSIGN, e3q, e2))) what | A.CAST (t, A.SINGLE_INIT e) -> (* GCC extension *) doExp asconst - (A.CAST (t, - A.SINGLE_INIT (A.BINARY(A.ASSIGN, e, + (A.CAST (t, + A.SINGLE_INIT (A.BINARY(A.ASSIGN, e, A.CAST (t, A.SINGLE_INIT e2))))) what - | A.PAREN e1 -> doExp asconst (A.BINARY(A.ASSIGN,e1,e2)) what + | A.PAREN e1 -> doExp asconst (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 ignore (warn "ASSIGN in constant"); let (se1, e1', lvt) = doExp false e1 (AExp None) in - let lv = - match e1' with + let lv = + match e1' with Lval x -> x | _ -> E.s (error "Expected lval for assignment. Got %a" d_plainexp e1') @@ -3901,11 +4034,11 @@ and doExp (asconst: bool) (* This expression is used as a constant *) Test: small1/assign.c *) let needsTemp = match what, lv with (ADrop|AType), _ -> false - | _, (Mem e, off) -> not (isConstant e) + | _, (Mem e, off) -> not (isConstant e) || not (isConstantOffset off) | _, (Var _, off) -> not (isConstantOffset off) in - let tmplv, se3 = + let tmplv, se3 = if needsTemp then let descr = (dd_lval () lv) in let tmp = newTempVar descr true lvt in @@ -3918,28 +4051,28 @@ and doExp (asconst: bool) (* This expression is used as a constant *) end | _ -> E.s (error "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) -> + A.SHL|A.SHR|A.EQ|A.NE|A.LT|A.GT|A.GE|A.LE) as bop, e1, e2) -> let bop' = convBinOp bop in let (se1, e1', t1) = doExp asconst e1 (AExp None) in let (se2, e2', t2) = doExp asconst e2 (AExp None) in let tresult, result = doBinOp bop' e1' t1 e2' t2 in finishExp (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 - match e1 with + match e1 with A.COMMA el -> (* GCC extension *) - doExp asconst - (A.COMMA (replaceLastInList el + doExp asconst + (A.COMMA (replaceLastInList el (fun e -> A.BINARY(bop, e, e2)))) what | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *) - doExp asconst - (A.QUESTION (e1, A.BINARY(bop, e2q, e2), + doExp asconst + (A.QUESTION (e1, A.BINARY(bop, e2q, e2), A.BINARY(bop, e3q, e2))) what | A.PAREN e1 -> doExp asconst (A.BINARY(bop,e1,e2)) what @@ -3948,7 +4081,7 @@ and doExp (asconst: bool) (* This expression is used as a constant *) A.CAST _ (* GCC extension *) ) -> begin if asconst then ignore (warn "op_ASSIGN in constant"); - let bop' = match bop with + let bop' = match bop with A.ADD_ASSIGN -> PlusA | A.SUB_ASSIGN -> MinusA | A.MUL_ASSIGN -> Mult @@ -3962,16 +4095,16 @@ and doExp (asconst: bool) (* This expression is used as a constant *) | _ -> E.s (error "binary +=") in let (se1, e1', t1) = doExp false e1 (AExp None) in - let lv1 = - match e1' with + let lv1 = + match e1' with Lval x -> x - | CastE (_, Lval x) -> x (* GCC extension. The operation and + | CastE (_, Lval x) -> x (* GCC extension. The operation and * the result are at the cast type *) | _ -> E.s (error "Expected lval for assignment with arith") in let (se2, e2', t2) = doExp false e2 (AExp None) in let tresult, result = doBinOp bop' e1' t1 e2' t2 in - (* We must cast the result to the type of the lv1, which may be + (* We must cast the result to the type of the lv1, which may be * different than t1 if lv1 was a Cast *) let tresult', result' = castTo tresult (typeOfLval lv1) result in (* Catch the case of an lval that might depend on itself, @@ -3985,7 +4118,7 @@ and doExp (asconst: bool) (* This expression is used as a constant *) || not (isConstantOffset off) | _, (Var _, off) -> not (isConstantOffset off) in - (* The type of the result is the type of the left-hand side *) + (* The type of the result is the type of the left-hand side *) if needsTemp then let descr = (dd_lval () lv1) in let tmp = var (newTempVar descr true tresult') in @@ -3995,65 +4128,65 @@ and doExp (asconst: bool) (* This expression is used as a constant *) (Lval tmp) t1 else - finishExp (se1 @@ se2 +++ + finishExp (se1 @@ se2 +++ (Set(lv1, result', !currentLoc))) e1' - t1 + t1 end | _ -> E.s (error "Unexpected left operand for assignment with arith") end - - + + | A.BINARY((A.AND|A.OR), _, _) | A.UNARY(A.NOT, _) -> begin let ce = doCondExp asconst e in (* We must normalize the result to 0 or 1 *) match ce with - CEExp (se, ((Const _) as c)) -> + CEExp (se, ((Const _) as c)) -> finishExp se (if isConstTrue c then one else zero) intType | CEExp (se, ((UnOp(LNot, _, _)|BinOp((Lt|Gt|Le|Ge|Eq|Ne|LAnd|LOr), _, _, _)) as e)) -> (* already normalized to 0 or 1 *) finishExp se e intType | CEExp (se, e) -> - let e' = + let e' = let te = typeOf e in let _, zte = castTo intType te zero in - BinOp(Ne, e, zte, te) + BinOp(Ne, e, zte, intType) in finishExp se e' intType - | _ -> + | _ -> let tmp = var (newTempVar (text "") true intType) in finishExp (compileCondExp ce - (empty +++ (Set(tmp, integer 1, + (empty +++ (Set(tmp, integer 1, !currentLoc))) - (empty +++ (Set(tmp, integer 0, - !currentLoc)))) + (empty +++ (Set(tmp, integer 0, + !currentLoc)))) (Lval tmp) intType end - | A.CALL(f, args) -> + | A.CALL(f, args) -> if asconst then - ignore (warn "CALL in constant"); - let (sf, f', ft') = - match f with (* Treat the VARIABLE case separate - * because we might be calling a - * function that does not have a - * prototype. In that case assume it + ignore (warnOpt "CALL in constant"); + let (sf, f', ft') = + match f with (* Treat the VARIABLE case separate + * because we might be calling a + * function that does not have a + * prototype. In that case assume it * takes INTs as arguments *) A.VARIABLE n -> begin try let vi, _ = lookupVar n in - (empty, Lval(var vi), vi.vtype) (* Found. Do not use - * finishExp. Simulate what = + (empty, Lval(var vi), vi.vtype) (* Found. Do not use + * finishExp. Simulate what = * AExp None *) with Not_found -> begin ignore (warnOpt "Calling function %s without prototype." n); - let ftype = TFun(intType, None, false, + let ftype = TFun(intType, None, false, [Attr("missingproto",[])]) in (* Add a prototype to the environment *) - let proto, _ = + let proto, _ = makeGlobalVarinfo false (makeGlobalVar n ftype) in (* Make it EXTERN *) proto.vstorage <- Extern; @@ -4063,110 +4196,111 @@ and doExp (asconst: bool) (* This expression is used as a constant *) (empty, Lval(var proto), ftype) end end - | _ -> doExp false f (AExp None) + | _ -> doExp false f (AExp None) in (* Get the result type and the argument types *) - let (resType, argTypes, isvar, f'') = + let (resType, argTypes, isvar, f'') = match unrollType ft' with TFun(rt,at,isvar,a) -> (rt,at,isvar,f') | TPtr (t, _) -> begin - match unrollType t with - TFun(rt,at,isvar,a) -> (* Make the function pointer + match unrollType t with + TFun(rt,at,isvar,a) -> (* Make the function pointer * explicit *) - let f'' = + let f'' = match f' with AddrOf lv -> Lval(lv) - | _ -> Lval(mkMem f' NoOffset) + | _ -> Lval(mkMem ~addr:f' ~off:NoOffset) in (rt,at,isvar, f'') - | x -> - E.s (error "Unexpected type of the called function %a: %a" + | x -> + E.s (error "Unexpected type of the called function %a: %a" d_exp f' d_type x) end - | x -> E.s (error "Unexpected type of the called function %a: %a" + | x -> E.s (error "Unexpected type of the called function %a: %a" d_exp f' d_type x) in let argTypesList = argsToList argTypes in (* Drop certain qualifiers from the result type *) let resType' = - ref (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 + ref (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'' with + let isSpecialBuiltin = + match f'' with Lval (Var fv, NoOffset) -> fv.vname = "__builtin_stdarg_start" || fv.vname = "__builtin_va_arg" || fv.vname = "__builtin_va_start" || fv.vname = "__builtin_expect" || - fv.vname = "__builtin_next_arg" + fv.vname = "__builtin_next_arg" || + fv.vname = "__builtin_tgmath" | _ -> false in - let isBuiltinChooseExpr = - match f'' with + let isBuiltinChooseExprOrTgmath = + match f'' with Lval (Var fv, NoOffset) -> - fv.vname = "__builtin_choose_expr" + fv.vname = "__builtin_choose_expr" || fv.vname = "__builtin_tgmath" | _ -> false in - - (** If the "--forceRLArgEval" flag was used, make sure + + (* If the "--forceRLArgEval" flag was used, make sure we evaluate args right-to-left. Added by Nathan Cooprider. **) let force_right_to_left_evaluation (c, e, t) = (* If chunk is empty then it is not already evaluated *) (* constants don't need to be pulled out *) - if (!forceRLArgEval && (not (isConstant e)) && - (not isSpecialBuiltin)) then + if (!forceRLArgEval && (not (isConstant e)) && + (not isSpecialBuiltin)) then (* create a temporary *) let tmp = newTempVar (dd_exp () e) true t in (* create an instruction to give the e to the temporary *) - let i = Set(var tmp, e, !currentLoc) in + let i = Set(var tmp, e, !currentLoc) in (* add the instruction to the chunk *) (* change the expression to be the temporary *) - (c +++ i, (Lval(var tmp)), t) + (c +++ i, (Lval(var tmp)), t) else (c, e, t) in (* Do the arguments. In REVERSE order !!! Both GCC and MSVC do this *) - let rec loopArgs - : (string * typ * attributes) list * A.expression list + let rec loopArgs + : (string * typ * attributes) list * A.expression list -> (chunk list * exp list) = function | ([], []) -> ([], []) - | args, [] -> - if not isSpecialBuiltin then - ignore (warnOpt + | args, [] -> + if not isSpecialBuiltin then + ignore (warnOpt "Too few arguments in call to %a." d_exp f'); ([], []) - | ((_, at, _) :: atypes, a :: args) -> + | ((_, 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 + (* 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 false a (AExp None)) in let (_, a'') = castTo att at a' in (sa :: ss, a'' :: args') - + | ([], args) -> (* No more types *) - if not isvar && argTypes != None && not isSpecialBuiltin then + if not isvar && argTypes != None && not isSpecialBuiltin then (* Do not give a warning for functions without a prototype*) ignore (warnOpt "Too many arguments in call to %a" d_exp f'); let rec loop = function [] -> ([], []) - | a :: args -> + | a :: args -> let (ss, args') = loop args in - let (sa, a', at) = force_right_to_left_evaluation + let (sa, a', at) = force_right_to_left_evaluation (doExp false a (AExp None)) in - if isBuiltinChooseExpr then + if isBuiltinChooseExprOrTgmath then (* This built-in function is analogous to the `? :' * operator in C, except that the expression returned - * has its type unaltered by promotion rules. + * has its type unaltered by promotion rules. * -- gcc manual *) (sa :: ss, a' :: args') else @@ -4177,26 +4311,26 @@ and doExp (asconst: bool) (* This expression is used as a constant *) loop args in let (sargsl, args') = loopArgs (argTypesList, args) in - (* Setup some pointer to the elements of the call. We may change + (* Setup some pointer to the elements of the call. We may change * these below *) let sideEffects () = sf @@ (List.fold_left (@@) empty (List.rev sargsl)) in let prechunk: (unit -> chunk) ref = ref sideEffects in (* comes before *) (* Do we actually have a call, or an expression? *) - let piscall: bool ref = ref true in + 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 pis__builtin_va_arg: bool ref = ref false in let pwhat: expAction ref = ref what in (* what to do with result *) - let pres: exp ref = ref zero in (* If we do not have a call, this is + let pres: exp ref = ref zero in (* If we do not have a call, this is * the result *) let prestype: typ ref = ref intType in let rec dropCasts = function CastE (_, e) -> dropCasts e | e -> e in (* Get the name of the last formal *) - let getNameLastFormal () : string = + let getNameLastFormal () : string = match !currentFunctionFDEC.svar.vtype with TFun(_, Some args, true, _) -> begin match List.rev args with @@ -4207,7 +4341,7 @@ and doExp (asconst: bool) (* This expression is used as a constant *) in (* Try to intercept some builtins *) - (match !pf with + (match !pf with Lval(Var fv, NoOffset) -> begin (* Most atomic builtins are overloaded: check the type of the first argument and fix the return type accordingly for those @@ -4218,7 +4352,64 @@ and doExp (asconst: bool) (* This expression is used as a constant *) http://gcc.gnu.org/onlinedocs/gcc/_005f_005fsync-Builtins.html#g_t_005f_005fsync-Builtins http://gcc.gnu.org/onlinedocs/gcc/_005f_005fatomic-Builtins.html *) - if !resType' = TVoid[Attr("overloaded",[])] then begin + if !resType' = TVoid[Attr("overloaded",[])] then + if fv.vname = "__builtin_tgmath" then + match !pargs with + | ptr :: _ -> + begin match typeOf ptr with + (* as per https://gcc.gnu.org/onlinedocs/gcc/Other-Builtins.html *) + | TPtr (TFun (r, args, _, _), _) -> + (* the first pointer to a function determines how many arguments all functions take *) + let numArgs = List.length (argsToList args) in + if numArgs = 0 then + ignore (warn "Invalid call to %s" fv.vname) + else + let rec lastn n list acc = + if n = 0 then + acc + else + lastn (n-1) list ((List.nth list (List.length list -n)) :: acc) + in + let rec firstn n list acc = + if n = 0 then + acc + else + match list with + | l::ls -> firstn (n-1) ls (l :: acc) + | [] -> acc + in + (* to determine the return type, there are several options: *) + let retTypes e = match typeOf e with | TPtr(TFun(r, _, _ , _), _) -> r | _ -> E.s("Invalid call to __builtin_tgmath") in + let retTypes = List.map retTypes (firstn (List.length !pargs - numArgs) !pargs []) in + if List.for_all (fun x -> typeSig x = typeSig r) retTypes then + (* a) all function pointers have the same return type *) + resType' := r + else + (* b) all function pointers have return type t, so we need to determine which one is called *) + (* to get the correct return type *) + (* the arguments passed to the function are the last numArgs arguments. Get their types *) + let argTypes = List.map typeOf (lastn numArgs !pargs []) in + (* the return type is determined by the resulting arithmetic conversion of the argument types *) + (* at least for the uses of this to realize tgmath.h. This could be potentially incorrect for other *) + (* uses of __builtin_tgmath *) + let r = List.fold_left arithmeticConversion (List.nth argTypes 0) argTypes in + (* if the t we determined here is complex, but the return types of all the fptrs are not, the return *) + (* type should not be complex *) + let isComplex t = match t with + | TFloat(f, _) -> f = FComplexFloat || f = FComplexDouble || f = FComplexLongDouble + | _ -> false + in + if List.for_all (fun x -> not (isComplex x)) retTypes then + resType' := typeOfRealAndImagComponents r + else + resType' := r + | _ -> + ignore (warn "Invalid call to %s" fv.vname) + end + | _ -> + ignore (warn "Invalid call to %s" fv.vname) + else + begin match !pargs with ptr :: _ -> begin match typeOf ptr with TPtr (vtype, _) -> @@ -4228,82 +4419,82 @@ and doExp (asconst: bool) (* This expression is used as a constant *) | _ -> ignore (warn "Invalid call to %s" fv.vname) end - + (* Builtins for va_arg functions *) else if fv.vname = "__builtin_va_arg" then begin - match !pargs with + match !pargs with [ marker ; SizeOf resTyp ] -> begin (* Make a variable of the desired type *) - let destlv, destlvtyp = - match !pwhat with + let destlv, destlvtyp = + match !pwhat with ASet (lv, lvt) -> lv, lvt | _ -> var (newTempVar nil true resTyp), resTyp in pwhat := (ASet (destlv, destlvtyp)); pis__builtin_va_arg := true; end - | _ -> + | _ -> ignore (warn "Invalid call to %s" fv.vname); end else if fv.vname = "__builtin_stdarg_start" || fv.vname = "__builtin_va_start" then begin - match !pargs with + match !pargs with marker :: last :: [] -> begin - let isOk = - match dropCasts last with - Lval (Var lastv, NoOffset) -> + let isOk = + match dropCasts last with + Lval (Var lastv, NoOffset) -> lastv.vname = getNameLastFormal () | _ -> false in - if not isOk then + if not isOk then ignore (warn "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 + + (* Check that "lastv" is indeed the last variable in the * prototype and then drop it *) pargs := [ marker ] end - | _ -> + | _ -> ignore (warn "Invalid call to %s" fv.vname); - - (* We have to turn uses of __builtin_varargs_start into uses - * of __builtin_stdarg_start (because we have dropped the + + (* We have to turn uses of __builtin_varargs_start into uses + * of __builtin_stdarg_start (because we have dropped the * __builtin_va_alist argument from this function) *) - + end else if fv.vname = "__builtin_varargs_start" then begin (* Lookup the prototype for the replacement *) - let v, _ = - try lookupGlobalVar "__builtin_stdarg_start" + let v, _ = + try lookupGlobalVar "__builtin_stdarg_start" with Not_found -> E.s (bug "Cannot find __builtin_stdarg_start to replace %s\n" fv.vname) in pf := Lval (var v) end else if fv.vname = "__builtin_next_arg" then begin - match !pargs with + match !pargs with last :: [] -> begin - let isOk = - match dropCasts last with - Lval (Var lastv, NoOffset) -> + let isOk = + match dropCasts last with + Lval (Var lastv, NoOffset) -> lastv.vname = getNameLastFormal () | _ -> false in - if not isOk then + if not isOk then ignore (warn "The argument in call to %s should be the last formal argument" fv.vname); - + pargs := [ ] end - | _ -> + | _ -> ignore (warn "Invalid call to %s" fv.vname); end else if fv.vname = "__builtin_va_arg_pack" then begin - (match !pargs with - [ ] -> begin - piscall := false; + (match !pargs with + [ ] -> begin + piscall := false; pres := SizeOfE !pf; prestype := !typeOfSizeOf end - | _ -> + | _ -> ignore (warn "Invalid call to builtin_va_arg_pack")); end - - (* More weird buitins *) + + (* More weird builtins *) else if fv.vname = "__builtin_object_size" then begin (* Side-effects make __builtin_object_size return -1 or 0 *) if (not (isEmpty (!prechunk ()))) then @@ -4330,27 +4521,27 @@ and doExp (asconst: bool) (* This expression is used as a constant *) prechunk := (fun _ -> empty); (* Constant-fold the argument and see if it is a constant *) - (match !pargs with - [ arg ] -> begin - match constFold true arg with - Const _ -> piscall := false; - pres := integer 1; + (match !pargs with + [ arg ] -> begin + match constFold true arg with + Const _ -> piscall := false; + pres := integer 1; prestype := intType - | _ -> piscall := false; + | _ -> piscall := false; pres := integer 0; prestype := intType end - | _ -> + | _ -> ignore (warn "Invalid call to builtin_constant_p")); end else if fv.vname = "__builtin_choose_expr" then begin (* Constant-fold the argument and see if it is a constant *) - (match !pargs with - [ arg; e1; e2 ] -> begin - match constFold true arg with - (Const _) as x -> - piscall := false; + (match !pargs with + [ arg; e1; e2 ] -> begin + match constFold true arg with + (Const _) as x -> + piscall := false; if isZero x then begin (* Keep only 3rd arg side effects *) prechunk := (fun _ -> sf @@ (List.nth sargsl 2)); @@ -4364,15 +4555,15 @@ and doExp (asconst: bool) (* This expression is used as a constant *) end | _ -> ignore (warn "builtin_choose_expr expects a constant first argument") end - | _ -> + | _ -> ignore (warn "Invalid call to builtin_choose_expr")); end else if fv.vname = "__builtin_types_compatible_p" then begin (* Constant-fold the argument and see if it is a constant *) - (match !pargs with + (match !pargs with [ SizeOf t1; SizeOf t2 ] -> begin (* Drop the side-effects *) prechunk := (fun _ -> empty); - piscall := false; + piscall := false; let compatible = try ignore(combineTypes CombineOther t1 t2); true with Failure _ -> false @@ -4382,7 +4573,7 @@ and doExp (asconst: bool) (* This expression is used as a constant *) pres := integer 0; prestype := intType end - | _ -> + | _ -> ignore (warn "Invalid call to builtin_types_compatible_p")); end end @@ -4390,8 +4581,8 @@ and doExp (asconst: bool) (* This expression is used as a constant *) (* Now we must finish the call *) - if !piscall then begin - let addCall (calldest: lval option) (res: exp) (t: typ) = + if !piscall then begin + let addCall (calldest: lval option) (res: exp) (t: typ) = let prev = !prechunk () in let dest, args = if !pis__builtin_va_arg then begin (* Make an exception here for __builtin_va_arg: @@ -4405,19 +4596,19 @@ and doExp (asconst: bool) (* This expression is used as a constant *) pres := res; prestype := t in - match !pwhat with + match !pwhat with ADrop -> addCall None zero intType | AType -> prestype := !resType' - + | ASet(lv, vtype) when !doCollapseCallCast || (Util.equals (typeSig vtype) (typeSig !resType')) -> (* We can assign the result directly to lv *) addCall (Some lv) (Lval(lv)) vtype - + | _ -> begin - let restype'' = + let restype'' = match !pwhat with AExp (Some t) when !doCollapseCallCast -> t | ASet (_, t) when !pis__builtin_va_arg -> t @@ -4426,75 +4617,76 @@ and doExp (asconst: bool) (* This expression is used as a constant *) let descr = dprintf "%a(%a)" dd_exp !pf (docList ~sep:(text ", ") (dd_exp ())) !pargs in let tmp = newTempVar descr false restype'' in - (* Remember that this variable has been created for this + (* Remember that this variable has been created for this * specific call. We will use this in collapseCallCast. *) IH.add callTempVars tmp.vid (); + IH.add allTempVars tmp.vid (); addCall (Some (var tmp)) (Lval(var tmp)) restype'' end end; - + finishExp (!prechunk ()) !pres !prestype - - | A.COMMA el -> - if asconst then + + | A.COMMA el -> + if asconst then ignore (warn "COMMA in constant"); let rec loop sofar = function - [e] -> + [e] -> let (se, e', t') = doExp false e what in (* Pass on the action *) (sofar @@ se, e', t') (* - finishExp (sofar @@ se) e' t' (* does not hurt to do it twice. + finishExp (sofar @@ se) e' t' (* does not hurt to do it twice. * GN: it seems it does *) *) - | e :: rest -> + | e :: rest -> let (se, _, _) = doExp false e ADrop in loop (sofar @@ se) rest | [] -> E.s (error "empty COMMA expression") in loop empty el - - | A.QUESTION (e1,e2,e3) when what = ADrop -> + + | A.QUESTION (e1,e2,e3) when what = ADrop -> if asconst then ignore (warn "QUESTION with ADrop in constant"); let (se3,_,_) = doExp false e3 ADrop in - let se2 = - match e2 with + let se2 = + match e2 with A.NOTHING -> skipChunk | _ -> let (se2,_,_) = doExp false e2 ADrop in se2 in finishExp (doCondition asconst e1 se2 se3) zero intType - + | A.QUESTION (e1, e2, e3) -> begin (* what is not ADrop *) (* Compile the conditional expression *) let ce1 = doCondExp asconst e1 in - (* Now we must find the type of both branches, in order to compute + (* Now we must find the type of both branches, in order to compute * the type of the result *) - let se2, e2'o (* is an option. None means use e1 *), t2 = - match e2 with + let se2, e2'o (* is an option. None means use e1 *), e_of_t2, t2 = + match e2 with A.NOTHING -> begin (* The same as the type of e1 *) match ce1 with - CEExp (_, e1') -> empty, None, typeOf e1' (* Do not promote + CEExp (_, e1') -> empty, None, Some e1', typeOf e1' (* Do not promote to bool *) - | _ -> empty, None, intType + | _ -> empty, None, None, intType end - | _ -> + | _ -> let se2, e2', t2 = doExp asconst e2 (AExp None) in - se2, Some e2', t2 + se2, Some e2', Some e2', t2 in (* Do e3 for real *) let se3, e3', t3 = doExp asconst e3 (AExp None) in (* Compute the type of the result *) - let tresult = conditionalConversion t2 t3 in + let tresult = conditionalConversion t2 t3 e_of_t2 e3' in match ce1 with - CEExp (se1, e1') when isConstFalse e1' && canDrop se2 -> + CEExp (se1, e1') when isConstFalse e1' && canDrop se2 -> finishExp (se1 @@ se3) (snd (castTo t3 tresult e3')) tresult - | CEExp (se1, e1') when isConstTrue e1' && canDrop se3 -> + | CEExp (se1, e1') when isConstTrue e1' && canDrop se3 -> begin match e2'o with None -> (* use e1' *) finishExp (se1 @@ se2) (snd (castTo t2 tresult e1')) tresult - | Some e2' -> + | Some e2' -> finishExp (se1 @@ se2) (snd (castTo t2 tresult e2')) tresult end | CEExp (se1, e1') when !useLogicalOperators && isEmpty se2 && isEmpty se3 -> @@ -4507,56 +4699,56 @@ and doExp (asconst: bool) (* This expression is used as a constant *) let e3' = snd (castTo t3 tresult e3') in finishExp se1 (Question (e1', e2', e3', tresult)) tresult | _ -> (* Use a conditional *) begin - match e2'o with + match e2'o with None -> (* has form "e1 ? : e3" *) let tmp = var (newTempVar nil true tresult) in let (se1, _, _) = doExp asconst e1 (ASet(tmp, tresult)) in - let (se3, _, _) = finishExp ~newWhat:(ASet(tmp, tresult)) + let (se3, _, _) = finishExp ~newWhat:(ASet(tmp, tresult)) se3 e3' t3 in finishExp (se1 @@ ifChunk (Lval(tmp)) !currentLoc skipChunk se3) (Lval(tmp)) tresult - | Some e2' -> - let lv, lvt = + | Some e2' -> + let lv, lvt = match what with | ASet (lv, lvt) -> lv, lvt - | _ -> + | _ -> let tmp = newTempVar nil true tresult in var tmp, tresult in (* Now add the stmts lv:=e2 and lv:=e3 to se2 and se3 *) - let (se2, _, _) = finishExp ~newWhat:(ASet(lv,lvt)) + let (se2, _, _) = finishExp ~newWhat:(ASet(lv,lvt)) se2 e2' t2 in - let (se3, _, _) = finishExp ~newWhat:(ASet(lv,lvt)) + let (se3, _, _) = finishExp ~newWhat:(ASet(lv,lvt)) se3 e3' t3 in finishExp (doCondition asconst e1 se2 se3) (Lval(lv)) tresult end (* (* Do these only to collect the types *) - let se2, e2', t2' = - match e2 with - A.NOTHING -> (* A GNU thing. Use e1 as e2 *) + let se2, e2', t2' = + match e2 with + A.NOTHING -> (* A GNU thing. Use e1 as e2 *) doExp isconst e1 (AExp None) - | _ -> doExp isconst e2 (AExp None) in + | _ -> doExp isconst e2 (AExp None) in (* Do e3 for real *) let se3, e3', t3' = doExp isconst e3 (AExp None) in (* Compute the type of the result *) let tresult = conditionalConversion e2' t2' e3' t3' in - if (isEmpty se2 || e2 = A.NOTHING) - && isEmpty se3 && isconst then begin - (* Use the Question. This allows Question in initializers without + if (isEmpty se2 || e2 = A.NOTHING) + && isEmpty se3 && isconst then begin + (* Use the Question. This allows Question in initializers without * having to do constant folding *) let se1, e1', t1 = doExp isconst e1 (AExp None) in ignore (checkBool t1 e1'); - let e2'' = - if e2 = A.NOTHING then - makeCastT e1' t1 tresult + let e2'' = + if e2 = A.NOTHING then + makeCastT e1' t1 tresult else makeCastT e2' t2' tresult (* We know se2 is empty *) in let e3'' = makeCastT e3' t3' tresult in - let resexp = + let resexp = match e1' with Const(CInt64(i, _, _)) when i <> Int64.zero -> e2'' | Const(CInt64(z, _, _)) when z = Int64.zero -> e3'' @@ -4564,8 +4756,8 @@ and doExp (asconst: bool) (* This expression is used as a constant *) in finishExp se1 resexp tresult end else begin (* Now use a conditional *) - match e2 with - A.NOTHING -> + match e2 with + A.NOTHING -> let tmp = var (newTempVar tresult) in let (se1, _, _) = doExp isconst e1 (ASet(tmp, tresult)) in let (se3, _, _) = doExp isconst e3 (ASet(tmp, tresult)) in @@ -4573,11 +4765,11 @@ and doExp (asconst: bool) (* This expression is used as a constant *) skipChunk se3) (Lval(tmp)) tresult - | _ -> - let lv, lvt = + | _ -> + let lv, lvt = match what with | ASet (lv, lvt) -> lv, lvt - | _ -> + | _ -> let tmp = newTempVar tresult in var tmp, tresult in @@ -4590,10 +4782,10 @@ and doExp (asconst: bool) (* This expression is used as a constant *) end | A.GNU_BODY b -> begin - (* Find the last A.COMPUTATION and remember it. This one is invoked + (* Find the last A.COMPUTATION and remember it. This one is invoked * on the reversed list of statements. *) - let rec findLastComputation = function - s :: _ -> + let findLastComputation = function + s :: _ -> let rec findLast = function A.SEQUENCE (_, s, loc) -> findLast s | CASE (_, s, _) -> findLast s @@ -4608,12 +4800,12 @@ and doExp (asconst: bool) (* This expression is used as a constant *) (* Save the previous data *) let old_gnu = ! gnu_body_result in let lastComp, isvoidbody = - match what with + match what with ADrop -> (* We are dropping the result *) A.NOP cabslu, true - | _ -> - try findLastComputation (List.rev b.A.bstmts), false - with Not_found -> + | _ -> + try findLastComputation (List.rev b.A.bstmts), false + with Not_found -> E.s (error "Cannot find COMPUTATION in GNU.body") (* A.NOP cabslu, true *) in @@ -4637,7 +4829,7 @@ and doExp (asconst: bool) (* This expression is used as a constant *) finishExp empty (AddrOfLabel gref) voidPtrType end | A.LABELADDR l -> begin - let l = lookupLabel l in (* To support locallly declared labels *) + let l = lookupLabel l in (* To support locally declared labels *) let addrval = try H.find gotoTargetHash l with Not_found -> begin @@ -4647,7 +4839,7 @@ and doExp (asconst: bool) (* This expression is used as a constant *) res end in - finishExp empty (makeCast (integer addrval) voidPtrType) voidPtrType + finishExp empty (makeCast ~e:(integer addrval) ~newt:voidPtrType) voidPtrType end | A.EXPR_PATTERN _ -> E.s (E.bug "EXPR_PATTERN in cabs2cil input") @@ -4659,43 +4851,43 @@ and doExp (asconst: bool) (* This expression is used as a constant *) integer 0, intType) end -(* bop is always the arithmetic version. Change it to the appropriate pointer +(* bop is always the arithmetic version. Change it to the appropriate pointer * version if necessary *) and doBinOp (bop: binop) (e1: exp) (t1: typ) (e2: exp) (t2: typ) : typ * exp = - let doArithmetic () = + let doArithmetic () = let tres = arithmeticConversion t1 t2 in (* Keep the operator since it is arithmetic *) - tres, - optConstFoldBinOp false bop (makeCastT e1 t1 tres) (makeCastT e2 t2 tres) tres + tres, + optConstFoldBinOp false bop (makeCastT ~e:e1 ~oldt:t1 ~newt:tres) (makeCastT ~e:e2 ~oldt:t2 ~newt:tres) tres in - let doArithmeticComp () = + let doArithmeticComp () = let tres = arithmeticConversion t1 t2 in - (* Keep the operator since it is arithemtic *) - intType, - optConstFoldBinOp false bop - (makeCastT e1 t1 tres) (makeCastT e2 t2 tres) intType + (* Keep the operator since it is arithmetic *) + intType, + optConstFoldBinOp false bop + (makeCastT ~e:e1 ~oldt:t1 ~newt:tres) (makeCastT ~e:e2 ~oldt:t2 ~newt:tres) intType in - let doIntegralArithmetic () = + let doIntegralArithmetic () = let tres = unrollType (arithmeticConversion t1 t2) in match tres with - TInt _ -> + TInt _ -> tres, - optConstFoldBinOp false bop - (makeCastT e1 t1 tres) (makeCastT e2 t2 tres) tres + optConstFoldBinOp false bop + (makeCastT ~e:e1 ~oldt:t1 ~newt:tres) (makeCastT ~e:e2 ~oldt:t2 ~newt:tres) tres | _ -> E.s (error "%a operator on a non-integer type" d_binop bop) in - let pointerComparison e1 t1 e2 t2 = + let pointerComparison e1 t1 e2 t2 = (* Cast both sides to an integer *) let commontype = !upointType in intType, - optConstFoldBinOp false bop (makeCastT e1 t1 commontype) - (makeCastT e2 t2 commontype) intType + optConstFoldBinOp false bop (makeCastT ~e:e1 ~oldt:t1 ~newt:commontype) + (makeCastT ~e:e2 ~oldt:t2 ~newt:commontype) intType in match bop with (Mult|Div) -> doArithmetic () | (Mod|BAnd|BOr|BXor) -> doIntegralArithmetic () - | (Shiftlt|Shiftrt) -> (* ISO 6.5.7. Only integral promotions. The result + | (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 *) @@ -4703,65 +4895,65 @@ and doBinOp (bop: binop) (e1: exp) (t1: typ) (e2: exp) (t2: typ) : typ * exp = else let t1' = integralPromotion t1 in let t2' = integralPromotion t2 in - t1', - optConstFoldBinOp false bop (makeCastT e1 t1 t1') (makeCastT e2 t2 t2') t1' + t1', + optConstFoldBinOp false bop (makeCastT ~e:e1 ~oldt:t1 ~newt:t1') (makeCastT ~e:e2 ~oldt:t2 ~newt:t2') t1' - | (PlusA|MinusA) + | (PlusA|MinusA) when isArithmeticType t1 && isArithmeticType t2 -> doArithmetic () - | (Eq|Ne|Lt|Le|Ge|Gt) - when isArithmeticType t1 && isArithmeticType t2 -> + | (Eq|Ne|Lt|Le|Ge|Gt) + when isArithmeticType t1 && isArithmeticType t2 -> doArithmeticComp () - | PlusA when isPointerType t1 && isIntegralType t2 -> - t1, - optConstFoldBinOp false PlusPI e1 - (makeCastT e2 t2 (integralPromotion t2)) t1 - | PlusA when isIntegralType t1 && isPointerType t2 -> - t2, - optConstFoldBinOp false PlusPI e2 - (makeCastT e1 t1 (integralPromotion t1)) t2 - | MinusA when isPointerType t1 && isIntegralType t2 -> - t1, - optConstFoldBinOp false MinusPI e1 - (makeCastT e2 t2 (integralPromotion t2)) t1 + | PlusA when isPointerType t1 && isIntegralType t2 -> + t1, + optConstFoldBinOp false PlusPI e1 + (makeCastT ~e:e2 ~oldt:t2 ~newt:(integralPromotion t2)) t1 + | PlusA when isIntegralType t1 && isPointerType t2 -> + t2, + optConstFoldBinOp false PlusPI e2 + (makeCastT ~e:e1 ~oldt:t1 ~newt:(integralPromotion t1)) t2 + | MinusA when isPointerType t1 && isIntegralType t2 -> + t1, + optConstFoldBinOp false MinusPI e1 + (makeCastT ~e:e2 ~oldt:t2 ~newt:(integralPromotion t2)) t1 | MinusA when isPointerType t1 && isPointerType t2 -> let commontype = t1 in !ptrdiffType, - optConstFoldBinOp false MinusPP (makeCastT e1 t1 commontype) - (makeCastT e2 t2 commontype) !ptrdiffType + optConstFoldBinOp false MinusPP (makeCastT ~e:e1 ~oldt:t1 ~newt:commontype) + (makeCastT ~e:e2 ~oldt:t2 ~newt:commontype) !ptrdiffType | (Le|Lt|Ge|Gt|Eq|Ne) when isPointerType t1 && isPointerType t2 -> pointerComparison e1 t1 e2 t2 - | (Eq|Ne) when isPointerType t1 && isZero e2 -> - pointerComparison e1 t1 (makeCastT zero !upointType t1) t1 - | (Eq|Ne) when isPointerType t2 && isZero e1 -> - pointerComparison (makeCastT zero !upointType t2) t2 e2 t2 + | (Eq|Ne) when isPointerType t1 && isZero e2 -> + pointerComparison e1 t1 (makeCastT ~e:zero ~oldt:!upointType ~newt:t1) t1 + | (Eq|Ne) when isPointerType t2 && isZero e1 -> + pointerComparison (makeCastT ~e:zero ~oldt:!upointType ~newt:t2) t2 e2 t2 - | (Eq|Ne) when isVariadicListType t1 && isZero e2 -> + | (Eq|Ne) when isVariadicListType t1 && isZero e2 -> ignore (warnOpt "Comparison of va_list and zero"); - pointerComparison e1 t1 (makeCastT zero !upointType t1) t1 - | (Eq|Ne) when isVariadicListType t2 && isZero e1 -> + pointerComparison e1 t1 (makeCastT ~e:zero ~oldt:!upointType ~newt:t1) t1 + | (Eq|Ne) when isVariadicListType t2 && isZero e1 -> ignore (warnOpt "Comparison of zero and va_list"); - pointerComparison (makeCastT zero !upointType t2) t2 e2 t2 + pointerComparison (makeCastT ~e:zero ~oldt:!upointType ~newt:t2) t2 e2 t2 | (Eq|Ne|Le|Lt|Ge|Gt) when isPointerType t1 && isArithmeticType t2 -> ignore (warnOpt "Comparison of pointer and non-pointer"); (* Cast both values to upointType *) - doBinOp bop (makeCastT e1 t1 !upointType) !upointType - (makeCastT e2 t2 !upointType) !upointType + doBinOp bop (makeCastT ~e:e1 ~oldt:t1 ~newt:!upointType) !upointType + (makeCastT ~e:e2 ~oldt:t2 ~newt:!upointType) !upointType | (Eq|Ne|Le|Lt|Ge|Gt) when isArithmeticType t1 && isPointerType t2 -> ignore (warnOpt "Comparison of pointer and non-pointer"); (* Cast both values to upointType *) - doBinOp bop (makeCastT e1 t1 !upointType) !upointType - (makeCastT e2 t2 !upointType) !upointType + doBinOp bop (makeCastT ~e:e1 ~oldt:t1 ~newt:!upointType) !upointType + (makeCastT ~e:e2 ~oldt:t2 ~newt:!upointType) !upointType | _ -> E.s (error "Invalid operands to binary operator: %a" d_plainexp (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 +(* 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 (asconst: bool) (** Try to evaluate the conditional expression - * to TRUE or FALSE, because it occurs in a +and doCondExp (asconst: bool) (* Try to evaluate the conditional expression + * to TRUE or FALSE, because it occurs in a * constant *) - (e: A.expression) : condExpRes = + (e: A.expression) : condExpRes = let rec addChunkBeforeCE (c0: chunk) = function CEExp (c, e) -> CEExp (c0 @@ c, e) | CEAnd (ce1, ce2) -> CEAnd (addChunkBeforeCE c0 ce1, ce2) @@ -4773,22 +4965,22 @@ and doCondExp (asconst: bool) (** Try to evaluate the conditional expression | CEAnd (ce1, ce2) | CEOr (ce1, ce2) -> canDropCE ce1 && canDropCE ce2 | CENot (ce1) -> canDropCE ce1 in - match e with + match e with A.BINARY (A.AND, e1, e2) -> begin let ce1 = doCondExp asconst e1 in let ce2 = doCondExp asconst e2 in match ce1, ce2 with - CEExp (se1, ((Const _) as ci1)), _ -> - if isConstTrue ci1 then + CEExp (se1, ((Const _) as ci1)), _ -> + if isConstTrue ci1 then addChunkBeforeCE se1 ce2 - else + else (* se2 might contain labels so we cannot always drop it *) - if canDropCE ce2 then - ce1 - else + if canDropCE ce2 then + ce1 + else CEAnd (ce1, ce2) - | CEExp(se1, e1'), CEExp (se2, e2') when - !useLogicalOperators && isEmpty se2 -> + | CEExp(se1, e1'), CEExp (se2, e2') when + !useLogicalOperators && isEmpty se2 -> CEExp (se1, BinOp(LAnd, e1', e2', intType)) | _ -> CEAnd (ce1, ce2) end @@ -4797,30 +4989,30 @@ and doCondExp (asconst: bool) (** Try to evaluate the conditional expression let ce1 = doCondExp asconst e1 in let ce2 = doCondExp asconst e2 in match ce1, ce2 with - CEExp (se1, (Const(CInt64 _) as ci1)), _ -> - if isConstFalse ci1 then + CEExp (se1, (Const(CInt64 _) as ci1)), _ -> + if isConstFalse ci1 then addChunkBeforeCE se1 ce2 - else + else (* se2 might contain labels so we cannot drop it *) - if canDropCE ce2 then - ce1 - else + if canDropCE ce2 then + ce1 + else CEOr (ce1, ce2) - | CEExp (se1, e1'), CEExp (se2, e2') when + | CEExp (se1, e1'), CEExp (se2, e2') when !useLogicalOperators && isEmpty se2 -> CEExp (se1, BinOp(LOr, e1', e2', intType)) | _ -> CEOr (ce1, ce2) end | A.UNARY(A.NOT, e1) -> begin - match doCondExp asconst e1 with - CEExp (se1, (Const _ as ci1)) -> - if isConstFalse ci1 then - CEExp (se1, one) + match doCondExp asconst e1 with + CEExp (se1, (Const _ as ci1)) -> + if isConstFalse ci1 then + CEExp (se1, one) else CEExp (se1, zero) - | CEExp (se1, e) when isEmpty se1 -> + | CEExp (se1, e) when isEmpty se1 -> let t = typeOf e in if not ((isPointerType t) || (isArithmeticType t))then E.s (error "Bad operand to !"); @@ -4829,134 +5021,126 @@ and doCondExp (asconst: bool) (** Try to evaluate the conditional expression | ce1 -> CENot ce1 end - | _ -> + | _ -> let (se, e, t) = doExp asconst e (AExp None) in ignore (checkBool t e); CEExp (se, if !lowerConstants then constFold asconst e else e) -and compileCondExp (ce: condExpRes) (st: chunk) (sf: chunk) : chunk = - match ce with +and compileCondExp (ce: condExpRes) (st: chunk) (sf: chunk) : chunk = + match ce with | CEAnd (ce1, ce2) -> - let (sf1, sf2) = + let (sf1, sf2) = (* If sf is small then will copy it *) - try (sf, duplicateChunk sf) - with Failure _ -> + try (sf, duplicateChunk sf) + with Failure _ -> let lab = newLabelName "_L" in (gotoChunk lab !currentLoc, consLabel lab sf !currentLoc false) in let st' = compileCondExp ce2 st sf1 in let sf' = sf2 in compileCondExp ce1 st' sf' - - | CEOr (ce1, ce2) -> - let (st1, st2) = + + | CEOr (ce1, ce2) -> + let (st1, st2) = (* If st is small then will copy it *) - try (st, duplicateChunk st) - with Failure _ -> + try (st, duplicateChunk st) + with Failure _ -> let lab = newLabelName "_L" in (gotoChunk lab !currentLoc, consLabel lab st !currentLoc false) in let st' = st1 in let sf' = compileCondExp ce2 st2 sf in compileCondExp ce1 st' sf' - + | CENot ce1 -> compileCondExp ce1 sf st - + | CEExp (se, e) -> begin - match e with + match e with Const(CInt64(i,_,_)) when i <> Int64.zero && canDrop sf -> se @@ st | Const(CInt64(z,_,_)) when z = Int64.zero && canDrop st -> se @@ sf | _ -> se @@ ifChunk e !currentLoc st sf end - + (* A special case for conditionals *) -and doCondition (isconst: bool) (* If we are in constants, we do our best to +and doCondition (isconst: bool) (* If we are in constants, we do our best to * eliminate the conditional *) - (e: A.expression) + (e: A.expression) (st: chunk) - (sf: chunk) : chunk = + (sf: chunk) : chunk = if isEmpty st && isEmpty sf then let se,_,_ = doExp isconst e ADrop in se else compileCondExp (doCondExp isconst e) st sf - -and doPureExp (e : A.expression) : exp = +(* Returns pure expression if there exists one, None otherwise. *) +and doPureExp (e : A.expression) : exp option = let (se, e', _) = doExp true e (AExp None) in - if isNotEmpty se then begin - let msg = - if !useLogicalOperators then - error "doPureExp: not pure" - else - error "doPureExp: could not compute array length, try --useLogicalOperators" - in E.s msg; - end; - e' + if isEmpty se then Some e' else None and doInitializer (vi: varinfo) - (inite: A.init_expression) - (* Return the accumulated chunk, the initializer and the new type (might be + (inite: A.init_expression) + (* Return the accumulated chunk, the initializer and the new type (might be * different for arrays) *) - : chunk * init * typ = + : chunk * init * typ = (* Setup the pre-initializer *) let topPreInit = ref NoInitPre in - if debugInit then - ignore (E.log "\nStarting a new initializer for %s : %a\n" + if debugInit then + ignore (E.log "\nStarting a new initializer for %s : %a\n" vi.vname d_type vi.vtype); - let topSetupInit (o: offset) (e: exp) = - if debugInit then + let topSetupInit (o: offset) (e: exp) = + if debugInit then ignore (E.log " set %a := %a\n" d_lval (Var vi, o) d_exp e); let newinit = setOneInit !topPreInit o e in if newinit != !topPreInit then topPreInit := newinit in - let acc, restl = + let acc, restl = let so = makeSubobj vi vi.vtype NoOffset in doInit (vi.vglob || vi.vstorage = Static) topSetupInit so empty [ (A.NEXT_INIT, inite) ] in - if restl <> [] then + if restl <> [] then ignore (warn "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' = unrollType vi.vtype in - if debugInit then + if debugInit then ignore (E.log "Collecting the initializer for %s\n" vi.vname); let (init, typ'') = collectInitializer false (vi.vglob || vi.vstorage = Static) !topPreInit typ' in if debugInit then - ignore (E.log "Finished the initializer for %s\n init=%a\n typ=%a\n acc=%a\n" + ignore (E.log "Finished the initializer for %s\n init=%a\n typ=%a\n acc=%a\n" vi.vname d_init init d_type typ' d_chunk acc); acc, init, typ'' - -(* Consume some initializers. Watch out here. Make sure we use only + +(* Consume some initializers. Watch out here. Make sure we use only * tail-recursion because these things can be big. *) and doInit - (isconst: bool) - (setone: offset -> exp -> unit) (* Use to announce an intializer *) + (isconst: bool) + (setone: offset -> exp -> unit) (* Use to announce an initializer *) (so: subobj) (acc: chunk) (initl: (A.initwhat * A.init_expression) list) (* Return the resulting chunk along with some unused initializers *) - : chunk * (A.initwhat * A.init_expression) list = + : chunk * (A.initwhat * A.init_expression) list = let whoami () = d_lval () (Var so.host, so.soOff) in - - let initl1 = + + let initl1 = match initl with - | (A.NEXT_INIT, - A.SINGLE_INIT (A.CAST ((s, dt), ie))) :: rest -> + | (A.NEXT_INIT, + A.SINGLE_INIT (A.CAST ((s, dt), ie))) :: rest -> let s', dt', ie' = preprocessCast s dt ie in (A.NEXT_INIT, A.SINGLE_INIT (A.CAST ((s', dt'), ie'))) :: rest | _ -> initl in - (* Sometimes we have a cast in front of a compound (in GCC). This + (* Sometimes we have a cast in front of a compound (in GCC). This * appears as a single initializer. Ignore the cast *) - let initl2 = + let initl2 = match initl1 with (what, A.SINGLE_INIT (A.CAST ((specs, dt), A.COMPOUND_INIT ci))) :: rest -> @@ -4977,29 +5161,29 @@ and doInit ignore (E.log "doInit for %t %s (current %a). Looking at: " whoami (if so.eof then "(eof)" else "") d_lval (Var so.host, so.curOff)); - (match allinitl with + (match allinitl with [] -> ignore (E.log "[]") - | (what, ie) :: _ -> - withCprint + | (what, ie) :: _ -> + withCprint Cprint.print_init_expression (A.COMPOUND_INIT [(what, ie)])); ignore (E.log "\n"); end; - match unrollType so.soTyp, allinitl with + match unrollType so.soTyp, allinitl with _, [] -> acc, [] (* No more initializers return *) (* No more subobjects *) | _, (A.NEXT_INIT, _) :: _ when so.eof -> acc, allinitl - - (* If we are at an array of characters and the initializer is a - * string literal (optionally enclosed in braces) then explode the + + (* 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, + | TArray(bt, leno, _), + (A.NEXT_INIT, (A.SINGLE_INIT(A.CONSTANT (A.CONST_STRING s))| - A.COMPOUND_INIT - [(A.NEXT_INIT, - A.SINGLE_INIT(A.CONSTANT + A.COMPOUND_INIT + [(A.NEXT_INIT, + A.SINGLE_INIT(A.CONSTANT (A.CONST_STRING s)))])) :: restil when (match unrollType bt with TInt((IChar|IUChar|ISChar), _) -> true @@ -5018,7 +5202,7 @@ and doInit * globals, since this array might be a local variable *) if ((isNone leno) || ((String.length s) < (integerArrayLength leno))) then ref [init Int64.zero] - else ref [] + else ref [] in for pos = String.length s - 1 downto 0 do collector := init (Int64.of_int (Char.code (s.[pos]))) :: !collector @@ -5026,13 +5210,13 @@ and doInit !collector in (* Create a separate object for the array *) - let so' = makeSubobj so.host so.soTyp so.soOff in + let so' = makeSubobj so.host so.soTyp so.soOff in (* Go inside the array *) let leno = integerArrayLength leno in so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)]; normalSubobj so'; let acc', initl' = doInit isconst setone so' acc charinits in - if initl' <> [] then + if initl' <> [] then ignore (warn "Too many initializers for character array %t" whoami); (* Advance past the array *) advanceSubobj so; @@ -5040,21 +5224,21 @@ and doInit let res = doInit isconst setone so acc' restil in res - (* If we are at an array of WIDE characters and the initializer is a + (* 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, + | TArray(bt, leno, _), + (A.NEXT_INIT, (A.SINGLE_INIT(A.CONSTANT (A.CONST_WSTRING s)) | - A.COMPOUND_INIT - [(A.NEXT_INIT, - A.SINGLE_INIT(A.CONSTANT + A.COMPOUND_INIT + [(A.NEXT_INIT, + A.SINGLE_INIT(A.CONSTANT (A.CONST_WSTRING s)))])) :: restil when(let bt' = unrollType bt in - match bt' with + match bt' with (* compare bt to wchar_t, ignoring signed vs. unsigned *) TInt _ when (bitsSizeOf bt') = (bitsSizeOf !wcharType) -> true | TInt _ -> @@ -5062,15 +5246,15 @@ and doInit E.s (error "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 !wcharType)) + Int64.sub (Int64.shift_left Int64.one (bitsSizeOf !wcharType)) Int64.one in - let charinits = - let init c = + let charinits = + let init c = if (compare c maxWChar > 0) then (* if c > maxWChar *) E.s (error "cab2cil:doInit:character 0x%Lx too big." c); - A.NEXT_INIT, + A.NEXT_INIT, A.SINGLE_INIT(A.CONSTANT (A.CONST_INT (Int64.to_string c))) in (Util.list_map init s) @ @@ -5082,24 +5266,24 @@ and doInit then [init Int64.zero] else []) (* - Util.list_map - (fun c -> + Util.list_map + (fun c -> if (compare c maxWChar > 0) then (* if c > maxWChar *) E.s (error "cab2cil:doInit:character 0x%Lx too big." c) else - (A.NEXT_INIT, + (A.NEXT_INIT, A.SINGLE_INIT(A.CONSTANT (A.CONST_INT (Int64.to_string c))))) s *) in (* Create a separate object for the array *) - let so' = makeSubobj so.host so.soTyp so.soOff in + let so' = makeSubobj so.host so.soTyp so.soOff in (* Go inside the array *) let leno = integerArrayLength leno in so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)]; normalSubobj so'; let acc', initl' = doInit isconst setone so' acc charinits in - if initl' <> [] then + 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 (!) *) @@ -5108,25 +5292,25 @@ and doInit advanceSubobj so; (* Continue *) doInit isconst setone so acc' restil - - (* If we are at an array and we see a single initializer then it must + + (* If we are at an array and we see a single initializer then it must * be one for the first element *) - | TArray(bt, leno, al), (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil -> + | TArray(bt, leno, al), (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; + so.stack <- InArray(so.soOff, bt, leno, ref 0) :: so.stack; normalSubobj so; (* Start over with the fields *) doInit isconst setone so acc allinitl - (* If we are at a composite and we see a single initializer of the same - * type as the composite then grab it all. If the type is not the same + (* 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 -> + | TComp (comp, _), (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil -> let se, oneinit', t' = doExp isconst oneinit (AExp None) in - if (match unrollType t' with - TComp (comp', _) when comp'.ckey = comp.ckey -> true - | _ -> false) + if (match unrollType t' with + TComp (comp', _) when comp'.ckey = comp.ckey -> true + | _ -> false) then begin (* Initialize the whole struct *) setone so.soOff oneinit'; @@ -5141,31 +5325,31 @@ and doInit end (* A scalar with a single initializer *) - | _, (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil -> + | _, (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil -> let se, oneinit', t' = doExp isconst oneinit (AExp(Some so.soTyp)) in (* - ignore (E.log "oneinit'=%a, t'=%a, so.soTyp=%a\n" + ignore (E.log "oneinit'=%a, t'=%a, so.soTyp=%a\n" d_exp oneinit' d_type t' d_type so.soTyp); *) - setone so.soOff (if !insertImplicitCasts then - makeCastT oneinit' t' so.soTyp + setone so.soOff (if !insertImplicitCasts then + makeCastT ~e:oneinit' ~oldt:t' ~newt:so.soTyp else oneinit'); (* Move on *) - advanceSubobj so; + advanceSubobj so; doInit isconst setone so (acc @@ se) restil - (* An array with a compound initializer. The initializer is for the + (* An array with a compound initializer. The initializer is for the * array elements *) - | TArray (bt, leno, _), (A.NEXT_INIT, A.COMPOUND_INIT initl) :: restil -> + | 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 + let so' = makeSubobj so.host so.soTyp so.soOff in (* Go inside the array *) let leno = integerArrayLength leno in so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)]; normalSubobj so'; let acc', initl' = doInit isconst setone so' acc initl in - if initl' <> [] then + if initl' <> [] then ignore (warn "Too many initializers for array %t" whoami); (* Advance past the array *) advanceSubobj so; @@ -5173,20 +5357,20 @@ and doInit let res = doInit isconst setone so acc' restil in res - (* We have a designator that tells us to select the matching union field. + (* 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 -> + 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 isconst oneinit (AExp None) in let tsig = typeSigNoAttrs t' in let rec findField = function [] -> E.s (error "Cannot find matching union field in cast") - | fi :: rest - when Util.equals (typeSigNoAttrs fi.ftype) tsig + | fi :: rest + when Util.equals (typeSigNoAttrs fi.ftype) tsig -> fi | _ :: rest -> findField rest in @@ -5201,7 +5385,7 @@ and doInit (* Change the designator and redo *) doInit isconst setone so acc [(A.INFIELD_INIT (fi.fname, A.NEXT_INIT), A.SINGLE_INIT oneinit)] - + (* A structure with a composite initializer. We initialize the fields*) | TComp (comp, _), (A.NEXT_INIT, A.COMPOUND_INIT initl) :: restil -> @@ -5229,124 +5413,124 @@ and doInit doInit isconst setone so acc' restil (* A scalar with a initializer surrounded by braces *) - | _, (A.NEXT_INIT, A.COMPOUND_INIT [(A.NEXT_INIT, + | _, (A.NEXT_INIT, A.COMPOUND_INIT [(A.NEXT_INIT, A.SINGLE_INIT oneinit)]) :: restil -> let se, oneinit', t' = doExp isconst oneinit (AExp(Some so.soTyp)) in - setone so.soOff (makeCastT oneinit' t' so.soTyp); + setone so.soOff (makeCastT ~e:oneinit' ~oldt:t' ~newt:so.soTyp); (* Move on *) - advanceSubobj so; + advanceSubobj so; doInit isconst setone so (acc @@ se) restil - | t, (A.NEXT_INIT, _) :: _ -> + | t, (A.NEXT_INIT, _) :: _ -> E.s (unimp "doInit: unexpected NEXT_INIT for %a\n" d_type t); - (* We have a designator *) - | _, (what, ie) :: restil when what != A.NEXT_INIT -> + (* We have a designator *) + | _, (what, ie) :: restil when what != A.NEXT_INIT -> (* Process a designator and position to the designated subobject *) - let rec addressSubobj - (so: subobj) - (what: A.initwhat) - (acc: chunk) : chunk = + let addressSubobj + (so: subobj) + (what: A.initwhat) + (acc: chunk) : chunk = (* Always start from the current element *) - so.stack <- []; so.eof <- false; + so.stack <- []; so.eof <- false; normalSubobj so; - let rec address (what: A.initwhat) (acc: chunk) : chunk = - match what with + 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, _) -> + 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 - + | _ -> E.s (error "Field designator %s not in a struct " fn) end - + | A.ATINDEX_INIT(idx, whatnext) -> begin - match unrollType so.soTyp with - TArray (bt, leno, _) -> + match unrollType so.soTyp with + TArray (bt, leno, _) -> let ilen = integerArrayLength leno in - let nextidx', doidx = - let (doidx, idxe', _) = + let nextidx', doidx = + let (doidx, idxe', _) = doExp true idx (AExp(Some intType)) in match constFold true idxe', isNotEmpty doidx with Const(CInt64(x, _, _)), false -> i64_to_int x, doidx - | _ -> E.s (error + | _ -> E.s (error "INDEX initialization designator is not a constant") in if nextidx' < 0 || nextidx' >= ilen then E.s (error "INDEX designator is outside bounds"); - so.stack <- + so.stack <- InArray(so.soOff, bt, ilen, ref nextidx') :: so.stack; normalSubobj so; address whatnext (acc @@ doidx) - + | _ -> E.s (error "INDEX designator for a non-array") - end - - | A.ATINDEXRANGE_INIT _ -> + end + + | A.ATINDEXRANGE_INIT _ -> E.s (bug "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) -> + | 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 (doidxs, idxs', _) = + | A.ATINDEXRANGE_INIT (idxs, idxe) -> + let (doidxs, idxs', _) = doExp true idxs (AExp(Some intType)) in - let (doidxe, idxe', _) = + let (doidxe, idxe', _) = doExp true idxe (AExp(Some intType)) in - if isNotEmpty doidxs || isNotEmpty doidxe then + if isNotEmpty doidxs || isNotEmpty doidxe then E.s (error "Range designators are not constants"); - let first, last = + let first, last = match constFold true idxs', constFold true idxe' with - Const(CInt64(s, _, _)), - Const(CInt64(e, _, _)) -> + Const(CInt64(s, _, _)), + Const(CInt64(e, _, _)) -> i64_to_int s, i64_to_int e - | _ -> E.s (error + | _ -> E.s (error "INDEX_RANGE initialization designator is not a constant") in - if first < 0 || first > last then - E.s (error + if first < 0 || first > last then + E.s (error "start index larger than end index in range initializer"); - let rec loop (i: int) = + let rec loop (i: int) = if i > last then restil - else + else (top (A.ATINDEX_INIT(A.CONSTANT(A.CONST_INT(string_of_int i)), - A.NEXT_INIT)), ie) - :: loop (i + 1) + A.NEXT_INIT)), ie) + :: loop (i + 1) in doInit isconst setone so acc (loop first) - | A.NEXT_INIT -> (* We have not found any RANGE *) + | A.NEXT_INIT -> (* We have not found any RANGE *) let acc' = addressSubobj so what acc in doInit isconst setone so acc' ((A.NEXT_INIT, ie) :: restil) in expandRange (fun x -> x) what - - | t, (what, ie) :: _ -> - E.s (bug "doInit: cases for t=%a" d_type t) + + | t, (what, ie) :: _ -> + E.s (bug "doInit: cases for t=%a" d_type t) -(* Create and add to the file (if not already added) a global. Return the +(* Create and add to the file (if not already added) a global. Return the * varinfo *) -and createGlobal (specs : (typ * storage * bool * A.attribute list)) - (((n,ndt,a,cloc), inite) : A.init_name) : varinfo = +and createGlobal (specs : (typ * storage * bool * A.attribute list)) + (((n,ndt,a,cloc), inite) : A.init_name) : varinfo = try - if debugGlobal then + if debugGlobal then ignore (E.log "createGlobal: %s\n" n); (* Make a first version of the varinfo *) - let vi = makeVarInfoCabs ~isformal:false + let vi = makeVarInfoCabs ~isformal:false ~isglobal:true (convLoc cloc) specs (n,ndt,a) in - (* Add the variable to the environment before doing the initializer + (* 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 @@ -5355,27 +5539,27 @@ and createGlobal (specs : (typ * storage * bool * A.attribute list)) (* sm: if it's a function prototype, and the storage class *) (* isn't specified, make it 'extern'; this fixes a problem *) (* with no-storage prototype and static definition *) - if vi.vstorage = NoStorage then + if vi.vstorage = NoStorage then (*(trace "sm" (dprintf "adding extern to prototype of %s\n" n));*) vi.vstorage <- Extern; end; let vi, alreadyInEnv = makeGlobalVarinfo (inite != A.NO_INIT) vi in (* - ignore (E.log "createGlobal %a: %s type=%a\n" + ignore (E.log "createGlobal %a: %s type=%a\n" d_loc (convLoc cloc) vi.vname d_plaintype vi.vtype); *) (* Do the initializer and complete the array type if necessary *) - let init : init option = - if inite = A.NO_INIT then + let init : init option = + if inite = A.NO_INIT then None - else + else let se, ie', et = doInitializer vi inite in (* Maybe we now have a better type? Use the type of the * initializer only if it really differs from the type of * the variable. *) if unrollType vi.vtype != unrollType et then vi.vtype <- et; - if isNotEmpty se then + if isNotEmpty se then E.s (error "global initializer"); Some ie' in @@ -5383,16 +5567,16 @@ and createGlobal (specs : (typ * storage * bool * A.attribute list)) try let oldloc = H.find alreadyDefined vi.vname in if init != None then begin - E.s (error "Global %s was already defined at %a" + E.s (error "Global %s was already defined at %a" vi.vname d_loc oldloc); end; - if debugGlobal then + if debugGlobal then ignore (E.log " global %s was already defined\n" vi.vname); (* Do not declare it again *) vi with Not_found -> begin (* Not already defined *) - if debugGlobal then + if debugGlobal then ignore (E.log " first definition for %s\n" vi.vname); if init != None then begin (* weimer: Sat Dec 8 17:43:34 2001 @@ -5419,8 +5603,8 @@ and createGlobal (specs : (typ * storage * bool * A.attribute list)) cabsPushGlobal (GVar(vi, vi.vinit, !currentLoc)); vi end else begin - if not (isFunctionType vi.vtype) - && not (IH.mem mustTurnIntoDef vi.vid) then + if not (isFunctionType vi.vtype) + && not (IH.mem mustTurnIntoDef vi.vid) then begin IH.add mustTurnIntoDef vi.vid true end; @@ -5429,7 +5613,7 @@ and createGlobal (specs : (typ * storage * bool * A.attribute list)) cabsPushGlobal (GVarDecl (vi, !currentLoc)); vi end else begin - if debugGlobal then + if debugGlobal then ignore (E.log " already in env %s\n" vi.vname); vi end @@ -5439,25 +5623,25 @@ and createGlobal (specs : (typ * storage * bool * A.attribute list)) ignore (E.log "error in createGlobal(%s: %a): %s" n d_loc !currentLoc (Printexc.to_string e)); - cabsPushGlobal (dGlobal (dprintf "booo - error in global %s (%t)" + cabsPushGlobal (dGlobal (dprintf "booo - error in global %s (%t)" n d_thisloc) !currentLoc); dummyFunDec.svar end (* - ignore (E.log "Env after processing global %s is:@!%t@!" + ignore (E.log "Env after processing global %s is:@!%t@!" n docEnv); - ignore (E.log "Alpha after processing global %s is:@!%t@!" + ignore (E.log "Alpha after processing global %s is:@!%t@!" n docAlphaTable) *) (* Must catch the Static local variables. Make them global *) -and createLocal ((_, sto, _, _) as specs) - ((((n, ndt, a, cloc) : A.name), - (inite: A.init_expression)) as init_name) +and createLocal ?allow_var_decl:(allow_var_decl=true) ((_, 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 = + let rec isProto (dt: decl_type) : bool = match dt with | PROTO (JUSTBASE, _, _) -> true | PROTO (x, _, _) -> isProto x @@ -5466,53 +5650,53 @@ and createLocal ((_, sto, _, _) as specs) | PTR (_, x) -> isProto x | _ -> false in - match ndt with - (* Maybe we have a function prototype in local scope. Make it global. We + 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 specs init_name in + | _ when isProto ndt -> + let vi = createGlobal specs init_name in (* Add it to the environment to shadow previous decls *) addLocalToEnv n (EnvVar vi); empty - + | _ when sto = Static && !makeStaticGlobal -> - if debugGlobal then + if debugGlobal then ignore (E.log "createGlobal (local static): %s\n" n); - (* Now alpha convert it to make sure that it does not conflict with + (* 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 ~isformal:false - ~isglobal:true + ~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 + (* 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 + (* 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 + (* Maybe this is an array whose length depends on something with local scope, e.g. "static char device[ sizeof(local) ]". Const-fold the type to fix this. *) vi.vtype <- constFoldType vi.vtype; - let init : init option = - if inite = A.NO_INIT then + let init : init option = + if inite = A.NO_INIT then None - else begin + else begin let se, ie', et = doInitializer vi inite in (* Maybe we now have a better type? Use the type of the * initializer only if it really differs from the type of * the variable. *) if unrollType vi.vtype != unrollType et then vi.vtype <- et; - if isNotEmpty se then + if isNotEmpty se then E.s (error "global static initializer has side-effect"); - (* Maybe the initializer refers to the function itself. + (* Maybe the initializer refers to the function itself. Push a prototype for the function, just in case. Hopefully, if does not refer to the locals *) cabsPushGlobal (GVarDecl (!currentFunctionFDEC.svar, !currentLoc)); @@ -5526,74 +5710,46 @@ and createLocal ((_, sto, _, _) as specs) (* Maybe we have an extern declaration. Make it a global *) | _ when sto = Extern -> let vi = createGlobal specs init_name in - (* Add it to the local environment to ensure that it shadows previous + (* 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 + | _ -> + begin + (* Make a variable of potentially variable size. If se0 <> empty then * it is a variable size variable *) - let vi,se0,len,isvarsize = + let vi,se0,isvarsize = makeVarSizeVarInfo loc specs (n, ndt, a) in - let vi = alphaConvertVarAndAddToEnv true vi in (* Replace vi *) - let se1 = - if isvarsize then begin (* Variable-sized array *) - ignore (warn "Variable-sized local variable %s" vi.vname); - (* Make a local variable to keep the length *) - let savelen = - makeVarInfoCabs - ~isformal:false - ~isglobal:false - loc - (!typeOfSizeOf, NoStorage, false, []) - ("__lengthof" ^ vi.vname,JUSTBASE, []) - in - (* Register it *) - let savelen = alphaConvertVarAndAddToEnv true savelen in - (* Compute the sizeof *) - let sizeof = - BinOp(Mult, - SizeOfE (Lval(Mem(Lval(var vi)), NoOffset)), - Lval (var savelen), !typeOfSizeOf) in - (* Register the length *) - IH.add varSizeArrays vi.vid sizeof; - (* There can be no initializer for this *) - if inite != A.NO_INIT then - E.s (error "Variable-sized array cannot have initializer"); - let setlen = se0 +++ - (Set(var savelen, makeCast len savelen.vtype, !currentLoc)) in - (* Initialize the variable *) - let alloca: varinfo = allocaFun () in - if !doCollapseCallCast then - (* do it in one step *) - setlen +++ (Call(Some(var vi), Lval(var alloca), - [ sizeof ], !currentLoc)) - else begin - (* do it in two *) - let rt, _, _, _ = splitFunctionType alloca.vtype in - let tmp = newTempVar (dprintf "alloca(%a)" d_exp sizeof) false rt in - setlen - +++ (Call(Some(var tmp), Lval(var alloca), - [ sizeof ], !currentLoc)) - +++ (Set((var vi), - makeCast (Lval(var tmp)) vi.vtype, !currentLoc)) - end - end else empty + let sevarsize = (* Chunk that is needed to pull out things for variable-length arrays *) + if isvarsize then + begin + if inite != A.NO_INIT then + E.s (error "Variable-sized array cannot have initializer") + else if not allow_var_decl then + E.s (error "VLAs in conjunction with computed gotos are unsupported.") + else + se0 + end + else + empty in + let makevdecl = (isvarsize || alwaysGenerateVarDecl && allow_var_decl) in + let se1 = if makevdecl then sevarsize +++ VarDecl(vi, !currentLoc) else sevarsize in + vi.vhasdeclinstruction <- makevdecl; if inite = A.NO_INIT then se1 (* skipChunk *) else begin let se4, ie', et = doInitializer vi inite in (* Fix the length *) - (match vi.vtype, ie', et with + (match vi.vtype, ie', et with (* We have a length now *) TArray(_,None, _), _, TArray(_, Some _, _) -> vi.vtype <- et (* Initializing a local array *) | TArray(TInt((IChar|IUChar|ISChar), _) as bt, None, a), - SingleInit(Const(CStr s)), _ -> - vi.vtype <- TArray(bt, + SingleInit(Const(CStr s)), _ -> + vi.vtype <- TArray(bt, Some (integer (String.length s + 1)), a) | _, _, _ -> ()); @@ -5607,17 +5763,18 @@ and createLocal ((_, sto, _, _) as specs) (* otherwise create assignments instead of the initialization *) se1 @@ se4 @@ (assignInit (Var vi, NoOffset) ie' et empty) end - -and doAliasFun vtype (thisname:string) (othername:string) + end + +and doAliasFun vtype (thisname:string) (othername:string) (sname:single_name) (loc: cabsloc) : unit = - (* This prototype declares that name is an alias for + (* 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 *) (* d_loc !currentLoc; *) let rt, formals, isva, _ = splitFunctionType vtype in if isva then E.s (error "%a: alias unsupported with varargs." d_loc !currentLoc); - let args = Util.list_map + let args = Util.list_map (fun (n,_,_) -> A.VARIABLE n) (argsToList formals) in let call = A.CALL (A.VARIABLE othername, args) in @@ -5632,24 +5789,24 @@ and doAliasFun vtype (thisname:string) (othername:string) with Not_found -> E.s (bug "error in doDecl") in v.vattr <- dropAttribute "alias" v.vattr - + (* Do one declaration *) and doDecl (isglobal: bool) : A.definition -> chunk = function | A.DECDEF ((s, nl), loc) -> currentLoc := convLoc(loc); (* Do the specifiers exactly once *) - let sugg = - match nl with + let sugg = + match nl with [] -> "" | ((n, _, _, _), _) :: _ -> n in let spec_res = doSpecList sugg s in (* Do all the variables and concatenate the resulting statements *) - let doOneDeclarator (acc: chunk) (name: init_name) = + 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 = + let vtype, nattr = doType (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in (match filterAttributes "alias" nattr with [] -> (* ordinary prototype. *) @@ -5657,7 +5814,7 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function (* E.log "%s is not aliased\n" name *) | [Attr("alias", [AStr othername])] -> if not (isFunctionType vtype) then begin - ignore (warn + ignore (warn "%a: CIL only supports attribute((alias)) for functions.\n" d_loc !currentLoc); ignore (createGlobal spec_res name) @@ -5665,23 +5822,23 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function doAliasFun vtype n othername (s, (n,ndt,a,l)) loc | _ -> E.s (error "Bad alias attribute at %a" d_loc !currentLoc)); acc - end else + end else acc @@ createLocal spec_res name in let res = List.fold_left doOneDeclarator empty nl in (* - ignore (E.log "after doDecl %a: res=%a\n" + ignore (E.log "after doDecl %a: res=%a\n" d_loc !currentLoc d_chunk res); *) res - | A.TYPEDEF (ng, loc) -> + | A.TYPEDEF (ng, loc) -> currentLoc := convLoc(loc); doTypedef ng; empty - | A.ONLYTYPEDEF (s, loc) -> + | A.ONLYTYPEDEF (s, loc) -> currentLoc := convLoc(loc); doOnlyTypedef s; empty @@ -5689,7 +5846,7 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function currentLoc := convLoc(loc); cabsPushGlobal (GAsm (s, !currentLoc)); empty - + | A.PRAGMA (a, loc) when isglobal -> begin currentLoc := convLoc(loc); match doAttr ("dummy", [a]) with @@ -5705,25 +5862,25 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function | _ -> E.s (error "Too many attributes in pragma") end | A.TRANSFORMER (_, _, _) -> E.s (E.bug "TRANSFORMER in cabs2cil input") - | A.EXPRTRANSFORMER (_, _, _) -> + | A.EXPRTRANSFORMER (_, _, _) -> E.s (E.bug "EXPRTRANSFORMER in cabs2cil input") - - (* If there are multiple definitions of extern inline, turn all but the + + (* If there are multiple definitions of extern inline, turn all but the * first into a prototype *) | A.FUNDEF (((specs,(n,dt,a,loc')) : A.single_name), - (body : A.block), loc, _) - when isglobal && isExtern specs && isInline specs - && (H.mem genv (n ^ "__extinline")) -> + (body : A.block), loc, _) + when isglobal && isExtern specs && isInline specs + && (H.mem genv (n ^ "__extinline")) -> currentLoc := convLoc(loc); let othervi, _ = lookupVar (n ^ "__extinline") in - if othervi.vname = n then + if othervi.vname = n then (* The previous entry in the env is also an extern inline version of n. *) ignore (warn "Duplicate extern inline definition for %s ignored" n) else begin (* Otherwise, the previous entry is an ordinary function that happens to be named __extinline. Renaming n to n__extinline - would confict with other, so report an error. *) + would conflict with other, so report an error. *) E.s (unimp("Trying to rename %s to\n %s__extinline, but %s__extinline" ^^ " already exists in the env.\n \"__extinline\" is" ^^ " reserved for CIL.\n") n n n) @@ -5744,12 +5901,12 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function try IH.clear callTempVars; - (* Make the fundec right away, and we'll populate it later. We + (* Make the fundec right away, and we'll populate it later. We * need this throughout the code to create temporaries. *) - currentFunctionFDEC := + currentFunctionFDEC := { svar = makeGlobalVar "@tempname@" voidType; - slocals = []; (* For now we'll put here both the locals and - * the formals. Then "endFunction" will + slocals = []; (* For now we'll put here both the locals and + * the formals. Then "endFunction" will * separate them *) sformals = []; (* Not final yet *) smaxid = 0; @@ -5762,9 +5919,9 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function (* Setup the environment. Add the formals to the locals. Maybe * they need alpha-conv *) enterScope (); (* Start the scope *) - + IH.clear varSizeArrays; - + (* Enter all the function's labels into the alpha conversion table *) ignore (V.visitCabsBlock (new registerLabelsVisitor) body); currentLoc := funloc; (* registerLabelsVisitor changes currentLoc, so reset it *) @@ -5774,38 +5931,38 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function transparentUnionArgs := []; (* Fix the NAME and the STORAGE *) - let _ = + let _ = let bt,sto,inl,attrs = doSpecList n specs in !currentFunctionFDEC.svar.vinline <- inl; - - let ftyp, funattr = + + let ftyp, funattr = doType (AttrName false) bt (A.PARENTYPE(attrs, dt, a)) in !currentFunctionFDEC.svar.vtype <- ftyp; !currentFunctionFDEC.svar.vattr <- funattr; - (* If this is the definition of an extern inline then we change - * its name, by adding the suffix __extinline. We also make it + (* If this is the definition of an extern inline then we change + * its name, by adding the suffix __extinline. We also make it * static *) let n', sto' = let n' = n ^ "__extinline" in if inl && sto = Extern && !Cil.oldstyleExternInline then begin n', Static - end else begin - (* Maybe this is the body of a previous extern inline. Then - * we must take that one out of the environment because it - * is not used from here on. This will also ensure that - * then we make this functions' varinfo we will not think + end else begin + (* Maybe this is the body of a previous extern inline. Then + * we must take that one out of the environment because it + * is not used from here on. This will also ensure that + * then we make this functions' varinfo we will not think * it is a duplicate definition *) (try ignore (lookupVar n'); (* if this succeeds, n' is defined*) let oldvi, _ = lookupVar n in - if oldvi.vname = n' then begin + if oldvi.vname = n' then begin (* oldvi is an extern inline function that has been renamed to n ^ "__extinline". Remove it from the environment. *) H.remove env n; H.remove genv n; H.remove env n'; H.remove genv n' - end + end else (* oldvi is not a renamed extern inline function, and we should do nothing. The reason the lookup @@ -5815,26 +5972,26 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function pass through CIL. See small2/extinline.c*) () with Not_found -> ()); - n, sto + n, sto end in (* Now we have the name and the storage *) !currentFunctionFDEC.svar.vname <- n'; !currentFunctionFDEC.svar.vstorage <- sto' 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 + + (* 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 <- + !currentFunctionFDEC.svar <- fst (makeGlobalVarinfo true !currentFunctionFDEC.svar); - (* 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 + (* 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); @@ -5846,23 +6003,23 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function (* ignore (E.log "makefunvar:%s@! type=%a@! vattr=%a@!" - n d_type thisFunctionVI.vtype + n d_type 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 + (* 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 _ = let (returnType, formals_t, isvararg, funta) = - splitFunctionTypeVI !currentFunctionFDEC.svar + splitFunctionTypeVI !currentFunctionFDEC.svar in (* Record the returnType for doStatement *) currentReturnType := returnType; - - + + (* Create the formals and add them to the environment. *) (* sfg: extract locations for the formals from dt *) let doFormal (loc : location) (fn, ft, fa) = @@ -5873,15 +6030,15 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function f.vattr <- fa; alphaConvertVarAndAddToEnv true f) in - let rec doFormals fl' ll' = + let rec doFormals fl' ll' = begin match (fl', ll') with - | [], _ -> [] - + | [], _ -> [] + | fl, [] -> (* no more locs available *) - List.map (doFormal !currentLoc) fl - - | f::fl, (_,(_,_,_,l))::ll -> + List.map (doFormal !currentLoc) 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 @@ -5893,22 +6050,22 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function let formals = doFormals (argsToList formals_t) fmlocs in (* Recreate the type based on the formals. *) - let ftype = TFun(returnType, + let ftype = TFun(returnType, Some (Util.list_map (fun f -> (f.vname, - f.vtype, - f.vattr)) formals), + f.vtype, + f.vattr)) formals), isvararg, funta) in (* ignore (E.log "Funtype of %s: %a\n" n' d_type ftype); *) - (* Now fix the names of the formals in the type of the function + (* Now fix the names of the formals in the type of the function * as well *) !currentFunctionFDEC.svar.vtype <- ftype; !currentFunctionFDEC.sformals <- formals; 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 + (* 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= @@ -5927,12 +6084,12 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function in (********** Now do the BODY *************) - let _ = + let _ = let stmts = doBody body in (* Finish everything *) exitScope (); - (* Now fill in the computed goto statement with cases. Do this + (* Now fill in the computed goto statement with cases. Do this * before mkFunctionbody which resolves the gotos *) (match !gotoTargetData with Some (switchv, switch) -> @@ -5945,7 +6102,7 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function let default = defaultChunk l - (i2c (Set ((Mem (makeCast (integer 0) intPtrType), + (i2c (Set ((Mem (makeCast ~e:(integer 0) ~newt:intPtrType), NoOffset), integer 0, l))) in @@ -5968,7 +6125,7 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function | _ -> E.s (bug "Unexpected result from switchChunk") in switch.skind <- newswitchkind - + | None -> ()); (* Now finish the body and store it *) !currentFunctionFDEC.sbody <- mkFunctionBody stmts; @@ -5977,49 +6134,49 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function H.clear gotoTargetHash; gotoTargetNextAddr := 0; in - - + + (* ignore (E.log "endFunction %s at %t:@! sformals=%a@! slocals=%a@!" !currentFunctionFDEC.svar.vname d_thisloc - (docList ~sep:(chr ',') (fun v -> text v.vname)) + (docList ~sep:(chr ',') (fun v -> text v.vname)) !currentFunctionFDEC.sformals - (docList ~sep:(chr ',') (fun v -> text v.vname)) + (docList ~sep:(chr ',') (fun v -> text v.vname)) !currentFunctionFDEC.slocals); *) - let rec dropFormals formals locals = + let rec dropFormals formals locals = match formals, locals with [], l -> l - | f :: formals, l :: locals -> - if f != l then - E.s (bug "formal %s is not in locals (found instead %s)" + | f :: formals, l :: locals -> + if f != l then + E.s (bug "formal %s is not in locals (found instead %s)" f.vname l.vname); dropFormals formals locals | _ -> E.s (bug "Too few locals") in - !currentFunctionFDEC.slocals - <- dropFormals !currentFunctionFDEC.sformals + !currentFunctionFDEC.slocals + <- dropFormals !currentFunctionFDEC.sformals (List.rev !currentFunctionFDEC.slocals); setMaxId !currentFunctionFDEC; - - (* Now go over the types of the formals and pull out the formals - * with transparent union type. Replace them with some shadow + + (* 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 _ = 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 + (* A new shadow to be placed in the formals. Use * makeTempVar to update smaxid and all others. *) - let shadow = + let shadow = makeTempVar !currentFunctionFDEC fstfield.ftype in - (* Now take it out of the locals and replace it with - * the current formal. It is not worth optimizing this + (* Now take it out of the locals and replace it with + * the current formal. It is not worth optimizing this * one. *) !currentFunctionFDEC.slocals <- f :: @@ -6035,15 +6192,15 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function in !currentFunctionFDEC.sbody.bstmts <- newbody; (* To make sure sharing with the type is proper *) - setFormals !currentFunctionFDEC newformals; + setFormals !currentFunctionFDEC newformals; in - (* Now see whether we can fall through to the end of the function + (* Now see whether we can fall through to the end of the function * *) - (* 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 + (* 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 @@ -6051,27 +6208,28 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function * return statements are inserted properly. *) let instrFallsThrough (i : instr) = match i with Set _ -> true - | Call (None, Lval (Var e, NoOffset), _, _) -> + | Call (None, Lval (Var e, NoOffset), _, _) -> (* See if this is exit, or if it has the noreturn attribute *) - if e.vname = "exit" then false + if e.vname = "exit" then false else if hasAttribute "noreturn" e.vattr then false else true | Call _ -> true | Asm _ -> true - in - let rec stmtFallsThrough (s: stmt) : bool = + | VarDecl _ -> true + in + let rec stmtFallsThrough (s: stmt) : bool = match s.skind with - Instr(il) -> - List.fold_left (fun acc elt -> + Instr(il) -> + List.fold_left (fun acc elt -> acc && instrFallsThrough elt) true il | Return _ | Break _ | Continue _ -> false | Goto _ | ComputedGoto _ -> false - | If (_, b1, b2, _) -> + | If (_, b1, b2, _) -> blockFallsThrough b1 || blockFallsThrough b2 - | Switch (e, b, targets, _) -> + | Switch (e, b, targets, _) -> (* See if there is a "default" case *) - if not - (List.exists (fun s -> + if not + (List.exists (fun s -> List.exists (function Default _ -> true | _ -> false) s.labels) targets) then begin @@ -6080,20 +6238,20 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function *) true (* We fall through because there is no default *) end else begin - (* We must examine all cases. If any falls through, + (* We must examine all cases. If any falls through, * then the switch falls through. *) blockFallsThrough b || blockCanBreak b end - | Loop (b, _, _, _) -> + | Loop (b, _, _, _) -> (* A loop falls through if it can break. *) blockCanBreak b | Block b -> blockFallsThrough b | TryFinally (b, h, _) -> blockFallsThrough h | TryExcept (b, _, h, _) -> true (* Conservative *) - and blockFallsThrough b = + and blockFallsThrough b = let rec fall = function [] -> true - | s :: rest -> + | s :: rest -> if stmtFallsThrough s then begin (* ignore (E.log "Stmt %a falls through\n" d_stmt s); @@ -6104,16 +6262,16 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function ignore (E.log "Stmt %a DOES NOT fall through\n" d_stmt s); *) - (* If we are not falling thorough then maybe there + (* If we are not falling thorough then maybe there * are labels who are *) labels rest end and labels = function [] -> false (* We have a label, perhaps we can jump here *) - | s :: rest when s.labels <> [] -> + | s :: rest when s.labels <> [] -> (* - ignore (E.log "invoking fall %a: %a\n" + ignore (E.log "invoking fall %a: %a\n" d_loc !currentLoc d_stmt s); *) fall (s :: rest) @@ -6125,39 +6283,39 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function *) res (* will we leave this statement or block with a break command? *) - and stmtCanBreak (s: stmt) : bool = + and stmtCanBreak (s: stmt) : bool = match s.skind with Instr _ | Return _ | Continue _ | Goto _ | ComputedGoto _ -> false | Break _ -> true - | If (_, b1, b2, _) -> + | If (_, b1, b2, _) -> blockCanBreak b1 || blockCanBreak b2 - | Switch _ | Loop _ -> + | Switch _ | Loop _ -> (* switches and loops catch any breaks in their bodies *) false | Block b -> blockCanBreak b | TryFinally (b, h, _) -> blockCanBreak b || blockCanBreak h | TryExcept (b, _, h, _) -> blockCanBreak b || blockCanBreak h - and blockCanBreak b = + and blockCanBreak b = List.exists stmtCanBreak b.bstmts in if blockFallsThrough !currentFunctionFDEC.sbody then begin - let retval = + let retval = match unrollType !currentReturnType with TVoid _ -> None - | (TInt _ | TEnum _ | TFloat _ | TPtr _) as rt -> - ignore (warn "Body of function %s falls-through. Adding a return statement" !currentFunctionFDEC.svar.vname); - Some (makeCastT zero intType rt) + | (TInt _ | TEnum _ | TFloat _ | TPtr _) as rt -> + ignore (warnOpt "Body of function %s falls-through. Adding a return statement" !currentFunctionFDEC.svar.vname); + Some (makeCastT ~e:zero ~oldt:intType ~newt:rt) | _ -> ignore (warn "Body of function %s falls-through and cannot find an appropriate return value" !currentFunctionFDEC.svar.vname); None in - if not (hasAttribute "noreturn" - !currentFunctionFDEC.svar.vattr) then - !currentFunctionFDEC.sbody.bstmts <- - !currentFunctionFDEC.sbody.bstmts + if not (hasAttribute "noreturn" + !currentFunctionFDEC.svar.vattr) then + !currentFunctionFDEC.sbody.bstmts <- + !currentFunctionFDEC.sbody.bstmts @ [mkStmt (Return(retval, endloc))] end; - + (* ignore (E.log "The env after finishing the body of %s:\n%t\n" n docEnv); *) cabsPushGlobal (GFun (!currentFunctionFDEC, funloc)); @@ -6171,24 +6329,24 @@ and doDecl (isglobal: bool) : A.definition -> chunk = function () (* argument of E.withContext *) end (* FUNDEF *) - | LINKAGE (n, loc, dl) -> + | LINKAGE (n, loc, dl) -> currentLoc := convLoc loc; - if n <> "C" then + if n <> "C" then ignore (warn "Encountered linkage specification \"%s\"" n); - if not isglobal then + if not isglobal then E.s (error "Encountered linkage specification in local scope"); (* For now drop the linkage on the floor !!! *) - List.iter - (fun d -> + List.iter + (fun d -> let s = doDecl isglobal d in - if isNotEmpty s then + if isNotEmpty s then E.s (bug "doDecl returns non-empty statement for global")) dl; empty | _ -> E.s (error "unexpected form of declaration") -and doTypedef ((specs, nl): A.name_group) = +and doTypedef ((specs, nl): A.name_group) = try (* Do the specifiers exactly once *) let bt, sto, inl, attrs = doSpecList (suggestAnonName nl) specs in @@ -6200,16 +6358,16 @@ and doTypedef ((specs, nl): A.name_group) = let newTyp, tattr = doType AttrType bt (A.PARENTYPE(attrs, ndt, a)) in let newTyp' = cabsTypeAddAttributes tattr newTyp in - (* Create a new name for the type. Use the same name space as that of - * variables to avoid confusion between variable names and types. This + (* Create a new name for the type. Use the same name space as that of + * variables to avoid confusion between variable names and types. This * is actually necessary in some cases. *) let n', _ = newAlphaName true "" n in let ti = { 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; + (* 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 *) @@ -6222,10 +6380,10 @@ and doTypedef ((specs, nl): A.name_group) = end in List.iter createTypedef nl - with e -> begin + with e -> begin ignore (E.log "Error on A.TYPEDEF (%s)\n" (Printexc.to_string e)); - let fstname = + let fstname = match nl with [] -> "" | (n, _, _, _) :: _ -> n @@ -6233,37 +6391,37 @@ and doTypedef ((specs, nl): A.name_group) = cabsPushGlobal (GAsm ("booo_typedef: " ^ fstname, !currentLoc)) end -and doOnlyTypedef (specs: A.spec_elem list) : unit = +and doOnlyTypedef (specs: A.spec_elem list) : unit = try let bt, sto, inl, attrs = doSpecList "" specs in - if sto <> NoStorage || inl then + if sto <> NoStorage || inl then E.s (error "Storage or inline specifier not allowed in typedef"); - let restyp, nattr = doType AttrType bt (A.PARENTYPE(attrs, + let restyp, nattr = doType AttrType bt (A.PARENTYPE(attrs, A.JUSTBASE, [])) in if nattr <> [] then ignore (warn "Ignoring identifier attribute"); (* doSpec will register the type. *) - match restyp with - TComp(ci, al) -> - ci.cattr <- cabsAddAttributes ci.cattr al; - | TEnum(ei, al) -> + match restyp with + TComp(ci, al) -> + ci.cattr <- cabsAddAttributes ci.cattr al; + | TEnum(ei, al) -> ei.eattr <- cabsAddAttributes ei.eattr al; - | _ -> + | _ -> ignore (warn "Ignoring un-named typedef that does not introduce a struct or enumeration type") - + with e -> begin ignore (E.log "Error on A.ONLYTYPEDEF (%s)\n" (Printexc.to_string e)); cabsPushGlobal (GAsm ("booo_typedef", !currentLoc)) end -and assignInit (lv: lval) - (ie: init) - (iet: typ) - (acc: chunk) : chunk = +and assignInit (lv: lval) + (ie: init) + (iet: typ) + (acc: chunk) : chunk = match ie with - SingleInit e -> - let (_, e'') = castTo iet (typeOfLval lv) e in + SingleInit e -> + let (_, e'') = castTo iet (typeOfLval lv) e in acc +++ (Set(lv, e'', !currentLoc)) | CompoundInit (t, initl) -> begin match unrollType t with @@ -6315,7 +6473,7 @@ and assignInit (lv: lval) | _ -> foldLeftCompound ~implicit:false - ~doinit:(fun off i it acc -> + ~doinit:(fun off i it acc -> assignInit (addOffsetLval off lv) i it acc) ~ct:t ~initl:initl @@ -6323,17 +6481,17 @@ and assignInit (lv: lval) end (* Now define the processors for body and statement *) -and doBody (blk: A.block) : chunk = +and doBody (blk: A.block) : chunk = 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 blk.A.battrs in - let bodychunk = + let bodychunk = afterConversion (List.fold_left (* !!! @ evaluates its arguments backwards *) - (fun prev s -> let res = doStatement s in + (fun prev s -> let res = doStatement s in prev @@ res) empty blk.A.bstmts) @@ -6351,8 +6509,8 @@ and doBody (blk: A.block) : chunk = cases = bodychunk.cases; } end - -and doStatement (s : A.statement) : chunk = + +and doStatement (s : A.statement) : chunk = try match s with A.NOP _ -> skipChunk @@ -6369,7 +6527,7 @@ and doStatement (s : A.statement) : chunk = (* And now do some peep-hole optimizations *) s' - | A.BLOCK (b, loc) -> + | A.BLOCK (b, loc) -> currentLoc := convLoc loc; doBody b @@ -6391,25 +6549,25 @@ and doStatement (s : A.statement) : chunk = currentLoc := loc'; loopChunk ((doCondition false e skipChunk break_cond) @@ s') - - | A.DOWHILE(e,s,loc) -> + + | A.DOWHILE(e,s,loc) -> startLoop false; let s' = doStatement s in let loc' = convLoc loc in currentLoc := loc'; - let s'' = + let s'' = consLabContinue (doCondition false e skipChunk (breakChunk loc')) in exitLoop (); loopChunk (s' @@ s'') - + | A.FOR(fc1,e2,e3,s,loc) -> begin let loc' = convLoc loc in currentLoc := loc'; enterScope (); (* Just in case we have a declaration *) - let (se1, _, _) = - match fc1 with - FC_EXP e1 -> doExp false e1 ADrop + let (se1, _, _) = + match fc1 with + FC_EXP e1 -> doExp false e1 ADrop | FC_DECL d1 -> (doDecl false d1, zero, voidType) in let (se3, _, _) = doExp false e3 ADrop in @@ -6419,28 +6577,28 @@ and doStatement (s : A.statement) : chunk = let s'' = consLabContinue se3 in let break_cond = breakChunk loc' in exitLoop (); - let res = + let res = match e2 with A.NOTHING -> (* This means true *) se1 @@ loopChunk (s' @@ s'') - | _ -> + | _ -> se1 @@ loopChunk ((doCondition false e2 skipChunk break_cond) @@ s' @@ s'') in exitScope (); res end - | A.BREAK loc -> + | A.BREAK loc -> let loc' = convLoc loc in currentLoc := loc'; breakChunk loc' - | A.CONTINUE loc -> + | A.CONTINUE loc -> let loc' = convLoc loc in currentLoc := loc'; continueOrLabelChunk loc' - | A.RETURN (A.NOTHING, loc) -> + | A.RETURN (A.NOTHING, loc) -> let loc' = convLoc loc in currentLoc := loc'; if not (isVoidType !currentReturnType) then @@ -6452,7 +6610,7 @@ and doStatement (s : A.statement) : chunk = currentLoc := loc'; (* Sometimes we return the result of a void function call *) if isVoidType !currentReturnType then begin - ignore (warn "Return statement with a value in function returning void"); + ignore (warnOpt "Return statement with a value in function returning void"); let (se, _, _) = doExp false e ADrop in se @@ returnChunk None loc' end else begin @@ -6463,8 +6621,8 @@ and doStatement (s : A.statement) : chunk = let (et'', e'') = castTo et rt e' in se @@ (returnChunk (Some e'') loc') end - - | A.SWITCH (e, s, loc) -> + + | A.SWITCH (e, s, loc) -> let loc' = convLoc loc in currentLoc := loc'; let (se, e', et) = doExp false e (AExp None) in @@ -6476,8 +6634,8 @@ and doStatement (s : A.statement) : chunk = let s' = doStatement s in exit_break_env (); se @@ (switchChunk e' s' loc') - - | A.CASE (e, s, loc) -> + + | A.CASE (e, s, loc) -> let loc' = convLoc loc in currentLoc := loc'; let (se, e', et) = doExp true e (AExp None) in @@ -6485,8 +6643,8 @@ and doStatement (s : A.statement) : chunk = E.s (error "Case statement with a non-constant"); caseChunk (if !lowerConstants then constFold false e' else e') loc' (doStatement s) - - | A.CASERANGE (el, eh, s, loc) -> + + | A.CASERANGE (el, eh, s, loc) -> let loc' = convLoc loc in currentLoc := loc'; let (sel, el', _) = doExp true el (AExp None) in @@ -6497,20 +6655,20 @@ and doStatement (s : A.statement) : chunk = (if !lowerConstants then constFold false el' else el') (if !lowerConstants then constFold false eh' else eh') loc' (doStatement s) - - | A.DEFAULT (s, loc) -> + + | A.DEFAULT (s, loc) -> let loc' = convLoc loc in currentLoc := loc'; defaultChunk loc' (doStatement s) - - | A.LABEL (l, s, loc) -> + + | A.LABEL (l, s, loc) -> let loc' = convLoc loc in currentLoc := loc'; (* Lookup the label because it might have been locally defined *) consLabel (lookupLabel l) (doStatement s) loc' true - - | A.GOTO (l, loc) -> + + | A.GOTO (l, loc) -> let loc' = convLoc loc in currentLoc := loc'; (* Maybe we need to rename this label *) @@ -6530,36 +6688,37 @@ and doStatement (s : A.statement) : chunk = let se, e', t' = doExp false e (AExp (Some voidPtrType)) in match !gotoTargetData with Some (switchv, switch) -> (* We have already generated this one *) - se - @@ i2c(Set (var switchv, makeCast e' !upointType, loc')) + se + @@ i2c(Set (var switchv, makeCast ~e:e' ~newt:!upointType, loc')) @@ s2c(mkStmt(Goto (ref switch, loc'))) | None -> begin - (* Make a temporary variable *) - let vchunk = createLocal + (* Make a temporary variable, avoiding generation of VarDecl if possible *) + (* as this is unsupported (see below) *) + let vchunk = createLocal ~allow_var_decl:false (!upointType, NoStorage, false, []) - (("__compgoto", A.JUSTBASE, [], loc), A.NO_INIT) + (("__compgoto", A.JUSTBASE, [], loc), A.NO_INIT) in - if not (isEmpty vchunk) then + if not (isEmpty vchunk) then E.s (unimp "Non-empty chunk in creating temporary for goto *"); - let switchv, _ = - try lookupVar "__compgoto" + let switchv, _ = + try lookupVar "__compgoto" with Not_found -> E.s (bug "Cannot find temporary for goto *"); in - (* Make a switch statement. We'll fill in the statements at the + (* Make a switch statement. We'll fill in the statements at the * end of the function *) - let switch = mkStmt (Switch (Lval(var switchv), + let switch = mkStmt (Switch (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 (Set(var switchv, makeCast e' !upointType, loc')) @@ + se @@ i2c (Set(var switchv, makeCast ~e:e' ~newt:!upointType, loc')) @@ s2c switch end end | A.DEFINITION d -> - let s = doDecl false d in + let s = doDecl false d in (* ignore (E.log "Def at %a: %a\n" d_loc !currentLoc d_chunk s); *) @@ -6567,7 +6726,7 @@ and doStatement (s : A.statement) : chunk = - | A.ASM (asmattr, tmpls, details, loc) -> + | A.ASM (asmattr, tmpls, details, loc) -> (* Make sure all the outs are variables *) let loc' = convLoc loc in let attr' = doAttributes asmattr in @@ -6613,32 +6772,32 @@ and doStatement (s : A.statement) : chunk = !stmts @@ (i2c (Asm(attr', tmpls', outs', ins', clobs', loc'))) - | TRY_FINALLY (b, h, loc) -> + | TRY_FINALLY (b, h, loc) -> let loc' = convLoc loc in currentLoc := loc'; let b': chunk = doBody b in let h': chunk = doBody h in - if b'.cases <> [] || h'.cases <> [] then + if b'.cases <> [] || h'.cases <> [] then E.s (error "Try statements cannot contain switch cases"); - + s2c (mkStmt (TryFinally (c2block b', c2block h', loc'))) - - | TRY_EXCEPT (b, e, h, loc) -> + + | TRY_EXCEPT (b, e, h, loc) -> let loc' = convLoc loc in currentLoc := loc'; let b': chunk = doBody b in (* Now do e *) let ((se: chunk), e', t') = doExp false e (AExp None) in let h': chunk = doBody h in - if b'.cases <> [] || h'.cases <> [] || se.cases <> [] then + if b'.cases <> [] || h'.cases <> [] || se.cases <> [] then E.s (error "Try statements cannot contain switch cases"); - (* Now take se and try to convert it to a list of instructions. This + (* Now take se and try to convert it to a list of instructions. This * might not be always possible *) - let il' = - match compactStmts se.stmts with + let il' = + match compactStmts se.stmts with [] -> se.postins | [ s ] -> begin - match s.skind with + match s.skind with Instr il -> il @ se.postins | _ -> E.s (error "Except expression contains unexpected statement") end @@ -6658,9 +6817,9 @@ let rec stripParenLocal e = match e with | _ -> e class stripParenClass : V.cabsVisitor = object (self) - inherit V.nopCabsVisitor as super - - method vexpr e = match e with + inherit V.nopCabsVisitor + + method! vexpr e = match e with | A.PAREN e2 -> V.ChangeDoChildrenPost (stripParenLocal e2,stripParenLocal) | _ -> V.DoChildren @@ -6674,8 +6833,8 @@ let convFile (f : A.file) : Cil.file = Cil.initCIL (); (* make sure we have initialized CIL *) (* remove parentheses from the Cabs *) - let fname,dl = stripParenFile f in - + let fname,dl = stripParenFile f in + (* Clean up the global types *) initGlobals(); startFile (); @@ -6685,16 +6844,16 @@ let convFile (f : A.file) : Cil.file = IH.clear mustTurnIntoDef; H.clear alreadyDefined; H.clear staticLocals; - H.clear typedefs; + H.clear typedefs; H.clear isomorphicStructs; annonCompFieldNameId := 0; - if !E.verboseFlag || !Cilutil.printStages then + if !E.verboseFlag || !Cilutil.printStages then ignore (E.log "Converting CABS->CIL\n"); (* Setup the built-ins, but do not add their prototypes to the file *) - let setupBuiltin name (resTyp, argTypes, isva) = - let v = - makeGlobalVar name (TFun(resTyp, - Some (Util.list_map (fun at -> ("", at, [])) + let setupBuiltin name (resTyp, argTypes, isva) = + let v = + makeGlobalVar name (TFun(resTyp, + Some (Util.list_map (fun at -> ("", at, [])) argTypes), isva, [])) in ignore (alphaConvertVarAndAddToEnv true v); @@ -6704,14 +6863,14 @@ let convFile (f : A.file) : Cil.file = H.iter setupBuiltin Cil.builtinFunctions; let globalidx = ref 0 in - let doOneGlobal (d: A.definition) = + let doOneGlobal (d: A.definition) = let s = doDecl true d in - if isNotEmpty s then + if isNotEmpty s then E.s (bug "doDecl returns non-empty statement for global"); - (* See if this is one of the globals which we can leave alone. Increment + (* See if this is one of the globals which we can leave alone. Increment * globalidx and see if we must leave this alone. *) - if - (match d with + if + (match d with A.DECDEF _ -> true | A.FUNDEF _ -> true | _ -> false) && (incr globalidx; !globalidx = !nocil) then begin @@ -6727,7 +6886,7 @@ let convFile (f : A.file) : Cil.file = flush (Whitetrack.getOutput()); Whitetrack.setOutput old; close_out temp_cabs; - (* Now read everythign in *and create a GText from it *) + (* Now read everything in *and create a GText from it *) let temp_cabs = open_in temp_cabs_name in let buff = Buffer.create 1024 in Buffer.add_string buff "// Start of CABS form\n"; @@ -6735,18 +6894,18 @@ let convFile (f : A.file) : Cil.file = Buffer.add_string buff "// End of CABS form\n"; close_in temp_cabs; (* Try to pop the last thing in the file *) - (match !theFile with + (match !theFile with _ :: rest -> theFile := rest | _ -> ()); (* Insert in the file a GText *) cabsPushGlobal (GText(Buffer.contents buff)) - end + end in List.iter doOneGlobal dl; let globals = ref (popGlobals ()) in IH.clear noProtoFunctions; - IH.clear mustTurnIntoDef; + IH.clear mustTurnIntoDef; H.clear alreadyDefined; H.clear compInfoNameEnv; H.clear enumInfoNameEnv; @@ -6763,4 +6922,4 @@ let convFile (f : A.file) : Cil.file = globals = !globals; globinit = None; globinitcalled = false; - } + } diff --git a/src/frontc/cabs2cil.mli b/src/frontc/cabs2cil.mli index 7bd82f8f0..49ce1d1a7 100644 --- a/src/frontc/cabs2cil.mli +++ b/src/frontc/cabs2cil.mli @@ -1,11 +1,11 @@ (* * - * Copyright (c) 2001-2002, + * 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: @@ -41,7 +41,7 @@ val convFile: Cabs.file -> Cil.file (** Turn on tranformation that forces correct parameter evaluation order *) val forceRLArgEval: bool ref -(** Set this integer to the index of the global to be left in CABS form. Use +(** Set this integer to the index of the global to be left in CABS form. Use * -1 to disable *) val nocil: int ref @@ -74,7 +74,7 @@ val typeForTypeof: (Cil.typ -> Cil.typ) ref types of cabs2cil-introduced temp variables. *) val typeForInsertedVar: (Cil.typ -> Cil.typ) ref -(** Like [typeForInsertedVar], but for casts. +(** Like [typeForInsertedVar], but for casts. * Casts in the source code are exempt from this hook. *) val typeForInsertedCast: (Cil.typ -> Cil.typ) ref @@ -84,3 +84,25 @@ val typeForCombinedArg: ((string, string) Hashtbl.t -> Cil.typ -> Cil.typ) ref (** A hook into the code that merges arguments in function attributes. *) val attrsForCombinedArg: ((string, string) Hashtbl.t -> Cil.attributes -> Cil.attributes) ref + +val allTempVars: unit Inthash.t + +type envdata = + EnvVar of Cil.varinfo (* The name refers to a variable + * (which could also be a function) *) + | EnvEnum of Cil.exp * Cil.typ (* The name refers to an enumeration + * tag for which we know the value + * and the host type *) + | EnvTyp of Cil.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" *) +(** A hashtable containing a mapping of variables, enums, types and labels to varinfo, typ, etc. *) +(* It enables a lookup of the original variable names before the alpha conversion by cabs2cil *) +val environment : (string, envdata * Cil.location) Hashtbl.t diff --git a/src/frontc/cabsvisit.ml b/src/frontc/cabsvisit.ml index 636cd2a78..460dc3281 100644 --- a/src/frontc/cabsvisit.ml +++ b/src/frontc/cabsvisit.ml @@ -1,11 +1,11 @@ (* * - * Copyright (c) 2001-2002, + * 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: @@ -40,45 +40,43 @@ open Cabs open Cabshelper -open Trace -open Pretty module E = Errormsg (* basic interface for a visitor object *) (* Different visiting actions. 'a will be instantiated with exp, instr, etc. *) -type 'a visitAction = - SkipChildren (* Do not visit the children. Return +type 'a visitAction = + SkipChildren (* Do not visit the children. Return * the node as it is *) - | ChangeTo of 'a (* Replace the expression with the + | ChangeTo of 'a (* Replace the expression with the * given one *) - | DoChildren (* Continue with the children of this - * node. Rebuild the node on return - * if any of the children changes + | DoChildren (* Continue with the children of this + * node. Rebuild the node on return + * if any of the children changes * (use == test) *) - | ChangeDoChildrenPost of 'a * ('a -> 'a) (* First consider that the entire - * exp is replaced by the first - * paramenter. Then continue with - * the children. On return rebuild - * the node if any of the children - * has changed and then apply the + | ChangeDoChildrenPost of 'a * ('a -> 'a) (* First consider that the entire + * exp is replaced by the first + * paramenter. 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 nameKind = - NVar (* Variable or function prototype +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 +(* 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 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 + method vvar: string -> string (* use of a variable * names *) method vdef: definition -> definition list visitAction method vtypespec: typeSpecifier -> typeSpecifier visitAction @@ -92,22 +90,22 @@ class type cabsVisitor = object method vEnterScope: unit -> unit method vExitScope: unit -> unit end - -let visitorLocation = ref { filename = ""; - lineno = -1; + +let visitorLocation = ref { filename = ""; + lineno = -1; byteno = -1; ident = 0} - + (* 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) = + method vstmt (s: statement) = visitorLocation := get_statementloc s; DoChildren method vblock (b: block) = DoChildren method vvar (s: string) = s - method vdef (d: definition) = + method vdef (d: definition) = visitorLocation := get_definitionloc d; DoChildren method vtypespec (ts: typeSpecifier) = DoChildren @@ -115,37 +113,37 @@ class nopCabsVisitor : cabsVisitor = object method vname k (s:specifier) (n: name) = DoChildren method vspec (s:specifier) = DoChildren method vattr (a: attribute) = DoChildren - + method vEnterScope () = () method vExitScope () = () end - + (* Map but try not to copy the list unless necessary *) let rec mapNoCopy (f: 'a -> 'a) = function [] -> [] - | (i :: resti) as li -> + | (i :: resti) as li -> let i' = f i in let resti' = mapNoCopy f resti in - if i' != i || resti' != resti then i' :: resti' else li - + if i' != i || resti' != resti then i' :: resti' else li + let rec mapNoCopyList (f: 'a -> 'a list) = function [] -> [] - | (i :: resti) as li -> + | (i :: resti) as li -> let il' = f i in let resti' = mapNoCopyList f resti in match il' with [i'] when i' == i && resti' == resti -> li | _ -> il' @ resti' - + let doVisit (vis: cabsVisitor) - (startvisit: 'a -> 'a visitAction) - (children: cabsVisitor -> 'a -> 'a) - (node: 'a) : 'a = + (startvisit: 'a -> 'a visitAction) + (children: cabsVisitor -> 'a -> 'a) + (node: 'a) : 'a = let action = startvisit node in match action with SkipChildren -> node | ChangeTo node' -> node' - | _ -> + | _ -> let nodepre = match action with ChangeDoChildrenPost (node', _) -> node' | _ -> node @@ -154,17 +152,17 @@ let doVisit (vis: cabsVisitor) match action with ChangeDoChildrenPost (_, f) -> f nodepost | _ -> nodepost - + (* A visitor for lists *) let doVisitList (vis: cabsVisitor) (startvisit: 'a -> 'a list visitAction) (children: cabsVisitor -> 'a -> 'a) - (node: 'a) : 'a list = + (node: 'a) : 'a list = let action = startvisit node in match action with SkipChildren -> [node] | ChangeTo nodes' -> nodes' - | _ -> + | _ -> let nodespre = match action with ChangeDoChildrenPost (nodespre, _) -> nodespre | _ -> [node] @@ -174,16 +172,16 @@ let doVisitList (vis: cabsVisitor) ChangeDoChildrenPost (_, f) -> f nodespost | _ -> nodespost - -let rec visitCabsTypeSpecifier (vis: cabsVisitor) (ts: typeSpecifier) = + +let rec visitCabsTypeSpecifier (vis: cabsVisitor) (ts: typeSpecifier) = doVisit vis vis#vtypespec childrenTypeSpecifier ts - -and childrenTypeSpecifier vis ts = - let childrenFieldGroup ((s, nel) as input) = + +and childrenTypeSpecifier vis ts = + let childrenFieldGroup ((s, nel) as input) = let s' = visitCabsSpecifier vis s in - let doOneField ((n, eo) as input) = + let doOneField ((n, eo) as input) = let n' = visitCabsName vis NField s' n in - let eo' = + let eo' = match eo with None -> None | Some e -> let e' = visitCabsExpression vis e in @@ -212,15 +210,15 @@ and childrenTypeSpecifier vis ts = vis#vExitScope(); if ei' != ei then Tenum( n, Some ei', extraAttrs) else ts | TtypeofE e -> - let e' = visitCabsExpression vis e in + let e' = visitCabsExpression vis e in if e' != e then TtypeofE e' else ts - | TtypeofT (s, dt) -> + | 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 = + +and childrenSpecElem (vis: cabsVisitor) (se: spec_elem) : spec_elem = match se with SpecTypedef | SpecInline | SpecStorage _ | SpecPattern _ -> se | SpecCV _ -> se (* cop out *) @@ -231,32 +229,32 @@ and childrenSpecElem (vis: cabsVisitor) (se: spec_elem) : spec_elem = | [a''] -> SpecAttr a'' | _ -> E.s (E.unimp "childrenSpecElem: visitCabsAttribute returned a list") end - | SpecType ts -> + | SpecType ts -> let ts' = visitCabsTypeSpecifier vis ts in if ts' != ts then SpecType ts' else se - -and visitCabsSpecifier (vis: cabsVisitor) (s: specifier) : specifier = + +and visitCabsSpecifier (vis: cabsVisitor) (s: specifier) : specifier = doVisit vis vis#vspec childrenSpec s -and childrenSpec vis s = mapNoCopy (childrenSpecElem vis) s - +and childrenSpec vis s = mapNoCopy (childrenSpecElem vis) s + -and visitCabsDeclType vis (isfundef: bool) (dt: decl_type) : decl_type = +and visitCabsDeclType vis (isfundef: bool) (dt: decl_type) : decl_type = doVisit vis vis#vdecltype (childrenDeclType isfundef) dt -and childrenDeclType isfundef vis dt = +and childrenDeclType isfundef vis dt = match dt with JUSTBASE -> dt - | PARENTYPE (prea, dt1, posta) -> + | 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 + if prea' != prea || dt1' != dt1 || posta' != posta then PARENTYPE (prea', dt1', posta') else dt - | ARRAY (dt1, al, e) -> + | 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) -> + | 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 @@ -268,90 +266,90 @@ and childrenDeclType isfundef vis dt = (* 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) = + +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 childrenInitNameGroup vis ((s, inl) as input) = + +and childrenInitNameGroup vis ((s, inl) as input) = let s' = visitCabsSpecifier vis s in let inl' = mapNoCopy (childrenInitName vis s') inl in if s' != s || inl' != inl then (s', inl') else input - -and visitCabsName vis (k: nameKind) (s: specifier) - (n: name) : name = + +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 = +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 = + +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 = + +and visitCabsDefinition vis (d: definition) : definition list = doVisitList vis vis#vdef childrenDefinition d -and childrenDefinition vis d = - match d with - FUNDEF (sn, b, l, lend) -> +and childrenDefinition vis d = + match d with + FUNDEF (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 (sn', b', l, lend) else d - - | DECDEF ((s, inl), l) -> + + | DECDEF ((s, inl), l) -> let s' = visitCabsSpecifier vis s in let inl' = mapNoCopy (childrenInitName vis s') inl in if s' != s || inl' != inl then DECDEF ((s', inl'), l) else d - | TYPEDEF (ng, l) -> + | TYPEDEF (ng, l) -> let ng' = childrenNameGroup vis NType ng in if ng' != ng then TYPEDEF (ng', l) else d - | ONLYTYPEDEF (s, l) -> + | ONLYTYPEDEF (s, l) -> let s' = visitCabsSpecifier vis s in if s' != s then ONLYTYPEDEF (s', l) else d | GLOBASM _ -> d - | PRAGMA (e, l) -> + | PRAGMA (e, l) -> let e' = visitCabsExpression vis e in if e' != e then PRAGMA (e', l) else d - | LINKAGE (n, l, dl) -> + | LINKAGE (n, l, dl) -> let dl' = mapNoCopyList (visitCabsDefinition vis) dl in if dl' != dl then LINKAGE (n, l, dl') else d - + | TRANSFORMER _ -> d | EXPRTRANSFORMER _ -> d - -and visitCabsBlock vis (b: block) : block = + +and visitCabsBlock vis (b: block) : block = doVisit vis vis#vblock childrenBlock b -and childrenBlock vis (b: block) : block = +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 + if battrs' != b.battrs || bstmts' != b.bstmts then { blabels = b.blabels; battrs = battrs'; bstmts = bstmts' } else b - -and visitCabsStatement vis (s: statement) : statement list = + +and visitCabsStatement vis (s: statement) : statement list = doVisitList vis vis#vstmt childrenStatement s -and childrenStatement vis s = +and childrenStatement vis s = let ve e = visitCabsExpression vis e in - let vs l s = + let vs l s = match visitCabsStatement vis s with [s'] -> s' | sl -> BLOCK ({blabels = []; battrs = []; bstmts = sl }, l) @@ -361,35 +359,35 @@ and childrenStatement vis s = | COMPUTATION (e, l) -> let e' = ve e in if e' != e then COMPUTATION (e', l) else s - | BLOCK (b, l) -> + | BLOCK (b, l) -> let b' = visitCabsBlock vis b in if b' != b then BLOCK (b', l) else s - | SEQUENCE (s1, s2, l) -> + | SEQUENCE (s1, s2, l) -> let s1' = vs l s1 in let s2' = vs l s2 in if s1' != s1 || s2' != s2 then SEQUENCE (s1', s2', l) else s - | IF (e, s1, s2, l) -> + | 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 IF (e', s1', s2', l) else s - | WHILE (e, s1, l) -> + | WHILE (e, s1, l) -> let e' = ve e in let s1' = vs l s1 in if e' != e || s1' != s1 then WHILE (e', s1', l) else s - | DOWHILE (e, s1, l) -> + | DOWHILE (e, s1, l) -> let e' = ve e in let s1' = vs l s1 in if e' != e || s1' != s1 then DOWHILE (e', s1', l) else s - | FOR (fc1, e2, e3, s4, l) -> + | FOR (fc1, e2, e3, s4, l) -> let _ = vis#vEnterScope () in - let fc1' = + let fc1' = match fc1 with - FC_EXP e1 -> + FC_EXP e1 -> let e1' = ve e1 in if e1' != e1 then FC_EXP e1' else fc1 - | FC_DECL d1 -> - let d1' = + | FC_DECL d1 -> + let d1' = match visitCabsDefinition vis d1 with [d1'] -> d1' | _ -> E.s (E.unimp "visitCabs: for can have only one definition") @@ -400,25 +398,25 @@ and childrenStatement vis s = let e3' = ve e3 in let s4' = vs l s4 in let _ = vis#vExitScope () in - if fc1' != fc1 || e2' != e2 || e3' != e3 || s4' != s4 + if fc1' != fc1 || e2' != e2 || e3' != e3 || s4' != s4 then FOR (fc1', e2', e3', s4', l) else s | BREAK _ | CONTINUE _ | GOTO _ -> s | RETURN (e, l) -> let e' = ve e in if e' != e then RETURN (e', l) else s - | SWITCH (e, s1, l) -> + | SWITCH (e, s1, l) -> let e' = ve e in let s1' = vs l s1 in if e' != e || s1' != s1 then SWITCH (e', s1', l) else s - | CASE (e, s1, l) -> + | CASE (e, s1, l) -> let e' = ve e in let s1' = vs l s1 in if e' != e || s1' != s1 then CASE (e', s1', l) else s - | CASERANGE (e1, e2, s3, l) -> + | 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 + if e1' != e1 || e2' != e2 || s3' != s3 then CASERANGE (e1', e2', s3', l) else s | DEFAULT (s1, l) -> let s1' = vs l s1 in @@ -426,7 +424,7 @@ and childrenStatement vis s = | LABEL (n, s1, l) -> let s1' = vs l s1 in if s1' != s1 then LABEL (n, s1', l) else s - | COMPGOTO (e, l) -> + | COMPGOTO (e, l) -> let e' = ve e in if e' != e then COMPGOTO (e', l) else s | DEFINITION d -> begin @@ -437,8 +435,8 @@ and childrenStatement vis s = let dl' = Util.list_map (fun d' -> DEFINITION d') dl in BLOCK ({blabels = []; battrs = []; bstmts = dl' }, l) end - | ASM (sl, b, details, l) -> - let childrenIdentStringExp ((i,s, e) as input) = + | 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 @@ -452,131 +450,139 @@ and childrenStatement vis s = else Some { aoutputs = outl'; ainputs = inl'; aclobbers = clobs } in - if details' != details then + if details' != details then ASM (sl, b, details', l) else s - | TRY_FINALLY (b1, b2, l) -> + | TRY_FINALLY (b1, b2, l) -> let b1' = visitCabsBlock vis b1 in let b2' = visitCabsBlock vis b2 in if b1' != b1 || b2' != b2 then TRY_FINALLY(b1', b2', l) else s - | TRY_EXCEPT (b1, e, b2, l) -> + | 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 TRY_EXCEPT(b1', e', b2', l) else s - - -and visitCabsExpression vis (e: expression) : expression = + + +and visitCabsExpression vis (e: expression) : expression = doVisit vis vis#vexpr childrenExpression e -and childrenExpression vis e = +and childrenExpression vis e = let ve e = visitCabsExpression vis e in - match e with + match e with NOTHING | LABELADDR _ -> e - | UNARY (uo, e1) -> + | UNARY (uo, e1) -> let e1' = ve e1 in if e1' != e1 then UNARY (uo, e1') else e - | BINARY (bo, e1, e2) -> + | BINARY (bo, e1, e2) -> let e1' = ve e1 in let e2' = ve e2 in if e1' != e1 || e2' != e2 then BINARY (bo, e1', e2') else e - | QUESTION (e1, e2, e3) -> + | 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 + if e1' != e1 || e2' != e2 || e3' != e3 then QUESTION (e1', e2', e3') else e - | CAST ((s, dt), ie) -> + | 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 CAST ((s', dt'), ie') else e - | CALL (f, el) -> + | CALL (f, el) -> let f' = ve f in let el' = mapNoCopy ve el in if f' != f || el' != el then CALL (f', el') else e - | COMMA el -> + | COMMA el -> let el' = mapNoCopy ve el in if el' != el then COMMA (el') else e | CONSTANT _ -> e - | PAREN e1 -> + | PAREN e1 -> let e1' = ve e1 in - if e1' != e1 then PAREN (e1') else e - | VARIABLE s -> + if e1' != e1 then PAREN (e1') else e + | VARIABLE s -> let s' = vis#vvar s in if s' != s then VARIABLE s' else e - | EXPR_SIZEOF (e1) -> + | EXPR_SIZEOF (e1) -> let e1' = ve e1 in if e1' != e1 then EXPR_SIZEOF (e1') else e - | TYPE_SIZEOF (s, dt) -> + | REAL e1 -> + let e1' = ve e1 in + if e1' != e1 then REAL (e1') else e + | IMAG e1 -> + let e1' = ve e1 in + if e1' != e1 then IMAG (e1') else e + | CLASSIFYTYPE e1 -> + let e1' = ve e1 in + if e1' != e1 then CLASSIFYTYPE (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 TYPE_SIZEOF (s' ,dt') else e - | EXPR_ALIGNOF (e1) -> + | EXPR_ALIGNOF (e1) -> let e1' = ve e1 in if e1' != e1 then EXPR_ALIGNOF (e1') else e - | TYPE_ALIGNOF (s, dt) -> + | TYPE_ALIGNOF (s, dt) -> let s' = visitCabsSpecifier vis s in let dt' = visitCabsDeclType vis false dt in if s' != s || dt' != dt then TYPE_ALIGNOF (s' ,dt') else e - | INDEX (e1, e2) -> + | INDEX (e1, e2) -> let e1' = ve e1 in let e2' = ve e2 in if e1' != e1 || e2' != e2 then INDEX (e1', e2') else e - | MEMBEROF (e1, n) -> + | MEMBEROF (e1, n) -> let e1' = ve e1 in if e1' != e1 then MEMBEROF (e1', n) else e - | MEMBEROFPTR (e1, n) -> + | MEMBEROFPTR (e1, n) -> let e1' = ve e1 in if e1' != e1 then MEMBEROFPTR (e1', n) else e - | GNU_BODY b -> + | GNU_BODY b -> let b' = visitCabsBlock vis b in if b' != b then GNU_BODY b' else e | EXPR_PATTERN _ -> e - -and visitCabsInitExpression vis (ie: init_expression) : init_expression = + +and visitCabsInitExpression vis (ie: init_expression) : init_expression = doVisit vis vis#vinitexpr childrenInitExpression ie -and childrenInitExpression vis ie = - let rec childrenInitWhat iw = +and childrenInitExpression vis ie = + let rec childrenInitWhat iw = match iw with NEXT_INIT -> iw - | INFIELD_INIT (n, iw1) -> + | INFIELD_INIT (n, iw1) -> let iw1' = childrenInitWhat iw1 in if iw1' != iw1 then INFIELD_INIT (n, iw1') else iw - | ATINDEX_INIT (e, iw1) -> + | 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) -> + | 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 + match ie with NO_INIT -> ie - | SINGLE_INIT e -> + | 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) = + | 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 = + +and visitCabsAttribute vis (a: attribute) : attribute list = doVisitList vis vis#vattr childrenAttribute a -and childrenAttribute vis ((n, el) as input) = +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 = + +and visitCabsAttributes vis (al: attribute list) : attribute list = mapNoCopyList (visitCabsAttribute vis) al -let visitCabsFile (vis: cabsVisitor) ((fname, f): file) : file = +let visitCabsFile (vis: cabsVisitor) ((fname, f): file) : file = (fname, mapNoCopyList (visitCabsDefinition vis) f) (* end of file *) - diff --git a/src/frontc/cabsvisit.mli b/src/frontc/cabsvisit.mli index d2387892b..4bb05d14a 100644 --- a/src/frontc/cabsvisit.mli +++ b/src/frontc/cabsvisit.mli @@ -1,11 +1,11 @@ (* * - * Copyright (c) 2001-2002, + * 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: @@ -39,39 +39,39 @@ (* interface for cabsvisit.ml *) (* Different visiting actions. 'a will be instantiated with exp, instr, etc. *) -type 'a visitAction = - SkipChildren (* Do not visit the children. Return +type 'a visitAction = + SkipChildren (* Do not visit the children. Return * the node as it is *) - | ChangeTo of 'a (* Replace the expression with the + | ChangeTo of 'a (* Replace the expression with the * given one *) - | DoChildren (* Continue with the children of this - * node. Rebuild the node on return - * if any of the children changes + | DoChildren (* Continue with the children of this + * node. Rebuild the node on return + * if any of the children changes * (use == test) *) - | ChangeDoChildrenPost of 'a * ('a -> 'a) (* First consider that the entire - * exp is replaced by the first - * paramenter. Then continue with - * the children. On return rebuild - * the node if any of the children - * has changed and then apply the + | ChangeDoChildrenPost of 'a * ('a -> 'a) (* First consider that the entire + * exp is replaced by the first + * paramenter. 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 nameKind = - NVar (** Variable or function prototype +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 +(* 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 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 + method vvar: string -> string (* use of a variable * names *) method vdef: Cabs.definition -> Cabs.definition list visitAction method vtypespec: Cabs.typeSpecifier -> Cabs.typeSpecifier visitAction @@ -91,21 +91,21 @@ end class nopCabsVisitor: cabsVisitor -val visitCabsTypeSpecifier: cabsVisitor -> +val visitCabsTypeSpecifier: cabsVisitor -> Cabs.typeSpecifier -> Cabs.typeSpecifier val visitCabsSpecifier: cabsVisitor -> Cabs.specifier -> Cabs.specifier -(** Visits a decl_type. The bool argument is saying whether we are ina - * function definition and thus the scope in a PROTO should extend until the +(** Visits a decl_type. The bool argument is saying whether we are ina + * function definition and thus the scope in a PROTO should extend until the * end of the function *) val visitCabsDeclType: cabsVisitor -> bool -> Cabs.decl_type -> Cabs.decl_type val visitCabsDefinition: cabsVisitor -> Cabs.definition -> Cabs.definition list val visitCabsBlock: cabsVisitor -> Cabs.block -> Cabs.block val visitCabsStatement: cabsVisitor -> Cabs.statement -> Cabs.statement list val visitCabsExpression: cabsVisitor -> Cabs.expression -> Cabs.expression -val visitCabsAttributes: cabsVisitor -> Cabs.attribute list +val visitCabsAttributes: cabsVisitor -> Cabs.attribute list -> Cabs.attribute list -val visitCabsName: cabsVisitor -> nameKind +val visitCabsName: cabsVisitor -> nameKind -> Cabs.specifier -> Cabs.name -> Cabs.name val visitCabsFile: cabsVisitor -> Cabs.file -> Cabs.file diff --git a/src/frontc/clexer.mll b/src/frontc/clexer.mll index ce9351af1..3ba4d55c6 100644 --- a/src/frontc/clexer.mll +++ b/src/frontc/clexer.mll @@ -6,7 +6,7 @@ * 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: @@ -37,7 +37,7 @@ *) (* FrontC -- lexical analyzer ** -** 1.0 3.22.99 Hugues Cassé First version. +** 1.0 3.22.99 Hugues Cass� First version. ** 2.0 George Necula 12/12/00: Many extensions *) { @@ -59,9 +59,9 @@ let addComment c = GrowArray.setg Cabshelper.commentsGA (i+1) (l,c,false) (* track whitespace for the current token *) -let white = ref "" +let white = ref "" let addWhite lexbuf = if not !Whitetrack.enabled then - let w = Lexing.lexeme lexbuf in + let w = Lexing.lexeme lexbuf in white := !white ^ w let clear_white () = white := "" let get_white () = !white @@ -71,7 +71,7 @@ let addLexeme lexbuf = let l = Lexing.lexeme lexbuf in lexeme := !lexeme ^ l let clear_lexeme () = lexeme := "" -let get_extra_lexeme () = !lexeme +let get_extra_lexeme () = !lexeme let int64_to_char value = if (compare value (Int64.of_int 255) > 0) || (compare value Int64.zero < 0) then @@ -91,10 +91,10 @@ let rec intlist_to_string (str: int64 list):string = (String.make 1 this_char) ^ (intlist_to_string rest) (* Some debugging support for line numbers *) -let dbgToken (t: token) = +let dbgToken (t: token) = if false then begin ignore (E.log "%a" insert - (match t with + (match t with IDENT (n, l) -> dprintf "IDENT(%s,%d)\n" n l.Cabs.lineno | LBRACE l -> dprintf "LBRACE(%d)\n" l.Cabs.lineno | RBRACE l -> dprintf "RBRACE(%d)\n" l.Cabs.lineno @@ -113,12 +113,14 @@ let dbgToken (t: token) = let lexicon = H.create 211 let init_lexicon _ = H.clear lexicon; - List.iter + List.iter (fun (key, builder) -> H.add lexicon key builder) [ ("auto", fun loc -> AUTO loc); ("const", fun loc -> CONST loc); ("__const", fun loc -> CONST loc); ("__const__", fun loc -> CONST loc); + ("_Complex", fun loc -> COMPLEX loc); + ("__complex__", fun loc -> COMPLEX loc); ("static", fun loc -> STATIC loc); ("extern", fun loc -> EXTERN loc); ("long", fun loc -> LONG loc); @@ -135,6 +137,8 @@ let init_lexicon _ = ("char", fun loc -> CHAR loc); ("int", fun loc -> INT loc); ("float", fun loc -> FLOAT loc); + ("__float128", fun loc -> FLOAT128 loc); + ("_Float128", fun loc -> FLOAT128 loc); ("double", fun loc -> DOUBLE loc); ("void", fun loc -> VOID loc); ("enum", fun loc -> ENUM loc); @@ -143,25 +147,25 @@ let init_lexicon _ = ("union", fun loc -> UNION loc); ("break", fun loc -> BREAK loc); ("continue", fun loc -> CONTINUE loc); - ("goto", fun loc -> GOTO loc); + ("goto", fun loc -> GOTO loc); ("return", fun loc -> dbgToken (RETURN loc)); ("switch", fun loc -> dbgToken (SWITCH loc)); - ("case", fun loc -> CASE loc); + ("case", fun loc -> CASE loc); ("default", fun loc -> DEFAULT loc); - ("while", fun loc -> WHILE loc); - ("do", fun loc -> DO loc); + ("while", fun loc -> WHILE loc); + ("do", fun loc -> DO loc); ("for", fun loc -> FOR loc); ("if", fun loc -> dbgToken (IF loc)); ("else", fun _ -> ELSE); (*** Implementation specific keywords ***) ("__signed__", fun loc -> SIGNED loc); ("__inline__", fun loc -> INLINE loc); - ("inline", fun loc -> INLINE loc); + ("inline", fun loc -> INLINE loc); ("__inline", fun loc -> INLINE loc); ("_inline", fun loc -> - if !Cprint.msvcMode then + if !Cprint.msvcMode then INLINE loc - else + else IDENT ("_inline", loc)); ("__attribute__", fun loc -> ATTRIBUTE loc); ("__attribute", fun loc -> ATTRIBUTE loc); @@ -174,12 +178,14 @@ let init_lexicon _ = ("asm", fun loc -> ASM loc); ("__typeof__", fun loc -> TYPEOF loc); ("__typeof", fun loc -> TYPEOF loc); - ("typeof", fun loc -> TYPEOF loc); + ("typeof", fun loc -> TYPEOF loc); ("__alignof", fun loc -> ALIGNOF loc); ("__alignof__", fun loc -> ALIGNOF loc); ("__volatile__", fun loc -> VOLATILE loc); ("__volatile", fun loc -> VOLATILE loc); - + ("__real__", fun loc -> REAL loc); + ("__imag__", fun loc -> IMAG loc); + ("__builtin_classify_type", fun loc -> CLASSIFYTYPE loc); ("__FUNCTION__", fun loc -> FUNCTION__ loc); ("__func__", fun loc -> FUNCTION__ loc); (* ISO 6.4.2.2 *) ("__PRETTY_FUNCTION__", fun loc -> PRETTY_FUNCTION__ loc); @@ -190,37 +196,38 @@ let init_lexicon _ = ("restrict", fun loc -> RESTRICT loc); (* ("__extension__", EXTENSION); *) (**** MS VC ***) - ("__int64", fun _ -> INT64 (currentLoc ())); ("__int32", fun loc -> INT loc); - ("_cdecl", fun _ -> MSATTR ("_cdecl", currentLoc ())); + ("__int64", fun _ -> INT64 (currentLoc ())); + ("__int128", fun _ -> INT128 (currentLoc ())); + ("_cdecl", fun _ -> MSATTR ("_cdecl", currentLoc ())); ("__cdecl", fun _ -> MSATTR ("__cdecl", currentLoc ())); - ("_stdcall", fun _ -> MSATTR ("_stdcall", currentLoc ())); + ("_stdcall", fun _ -> MSATTR ("_stdcall", currentLoc ())); ("__stdcall", fun _ -> MSATTR ("__stdcall", currentLoc ())); - ("_fastcall", fun _ -> MSATTR ("_fastcall", currentLoc ())); + ("_fastcall", fun _ -> MSATTR ("_fastcall", currentLoc ())); ("__fastcall", fun _ -> MSATTR ("__fastcall", currentLoc ())); ("__w64", fun _ -> MSATTR("__w64", currentLoc ())); ("__declspec", fun loc -> DECLSPEC loc); - ("__forceinline", fun loc -> INLINE loc); (* !! we turn forceinline + ("__forceinline", fun loc -> INLINE loc); (* !! we turn forceinline * into inline *) ("__try", fun loc -> TRY loc); ("__except", fun loc -> EXCEPT loc); ("__finally", fun loc -> FINALLY loc); (* weimer: some files produced by 'GCC -E' expect this type to be * defined *) - ("__builtin_va_list", + ("__builtin_va_list", fun _ -> NAMED_TYPE ("__builtin_va_list", currentLoc ())); ("__builtin_va_arg", fun loc -> BUILTIN_VA_ARG loc); ("__builtin_types_compatible_p", fun loc -> BUILTIN_TYPES_COMPAT loc); ("__builtin_offsetof", fun loc -> BUILTIN_OFFSETOF loc); (* On some versions of GCC __thread is a regular identifier *) - ("__thread", fun loc -> - if !Machdep.theMachine.Machdep.__thread_is_keyword then + ("__thread", fun loc -> + if !Machdep.theMachine.Machdep.__thread_is_keyword then THREAD loc - else + else IDENT ("__thread", loc)); ] -(* Mark an identifier as a type name. The old mapping is preserved and will +(* Mark an identifier as a type name. The old mapping is preserved and will * be reinstated when we exit this context *) let add_type name = (* ignore (print_string ("adding type name " ^ name ^ "\n")); *) @@ -230,16 +237,16 @@ let context : string list list ref = ref [[]] let push_context _ = context := []::!context -let pop_context _ = +let pop_context _ = match !context with [] -> raise (InternalError "Empty context stack") | con::sub -> (context := sub; - List.iter (fun name -> + List.iter (fun name -> (* ignore (print_string ("removing lexicon for " ^ name ^ "\n")); *) H.remove lexicon name) con) -(* Mark an identifier as a variable name. The old mapping is preserved and +(* Mark an identifier as a variable name. The old mapping is preserved and * will be reinstated when we exit this context *) let add_identifier name = match !context with @@ -247,7 +254,7 @@ let add_identifier name = | con::sub -> (context := (name::con)::sub; (* print_string ("adding IDENT for " ^ name ^ "\n"); *) - H.add lexicon name (fun loc -> + H.add lexicon name (fun loc -> dbgToken (IDENT (name, loc)))) @@ -266,7 +273,7 @@ let scan_ident id = (* ** Buffer processor *) - + let init ~(filename: string) : Lexing.lexbuf = init_lexicon (); @@ -278,7 +285,7 @@ let init ~(filename: string) : Lexing.lexbuf = E.startParsing filename -let finish () = +let finish () = E.finishParsing () (*** Error handling ***) @@ -297,14 +304,14 @@ let scan_escape (char: char) : int64 = | 'v' -> '\011' (* ASCII code 11 *) | 'a' -> '\007' (* ASCII code 7 *) | 'e' | 'E' -> '\027' (* ASCII code 27. This is a GCC extension *) - | '\'' -> '\'' + | '\'' -> '\'' | '"'-> '"' (* '"' *) | '?' -> '?' | '(' when not !Cprint.msvcMode -> '(' | '{' when not !Cprint.msvcMode -> '{' | '[' when not !Cprint.msvcMode -> '[' | '%' when not !Cprint.msvcMode -> '%' - | '\\' -> '\\' + | '\\' -> '\\' | other -> error ("Unrecognized escape sequence: \\" ^ (String.make 1 other)) in Int64.of_int (Char.code result) @@ -366,13 +373,13 @@ let make_char (i:int64):char = (* ISO standard locale-specific function to convert a wide character - * into a sequence of normal characters. Here we work on strings. - * We convert L"Hi" to "H\000i\000" + * into a sequence of normal characters. Here we work on strings. + * We convert L"Hi" to "H\000i\000" matth: this seems unused. let wbtowc wstr = - let len = String.length wstr in - let dest = String.make (len * 2) '\000' in - for i = 0 to len-1 do + let len = String.length wstr in + let dest = String.make (len * 2) '\000' in + for i = 0 to len-1 do dest.[i*2] <- wstr.[i] ; done ; dest @@ -404,9 +411,9 @@ let letter = ['a'- 'z' 'A'-'Z'] let usuffix = ['u' 'U'] let lsuffix = "l"|"L"|"ll"|"LL" -let intsuffix = lsuffix | usuffix | usuffix lsuffix | lsuffix usuffix +let intsuffix = lsuffix | usuffix | usuffix lsuffix | lsuffix usuffix | usuffix ? "i64" - + let hexprefix = '0' ['x' 'X'] @@ -419,8 +426,8 @@ let fraction = '.' decdigit+ let decfloat = (intnum? fraction) |(intnum exponent) |(intnum? fraction exponent) - | (intnum '.') - | (intnum '.' exponent) + | (intnum '.') + | (intnum '.' exponent) let hexfraction = hexdigit* '.' hexdigit+ | hexdigit+ '.' let binexponent = ['p' 'P'] ['+' '-']? decdigit+ @@ -430,15 +437,18 @@ let hexfloat = hexprefix hexfraction binexponent let floatsuffix = ['f' 'F' 'l' 'L'] let floatnum = (decfloat | hexfloat) floatsuffix? -let ident = (letter|'_'|'$')(letter|decdigit|'_'|'$')* +let complexnum = (decfloat | hexfloat) ((['i' 'I'] floatsuffix) | (floatsuffix? ['i' 'I'])) + + +let ident = (letter|'_'|'$')(letter|decdigit|'_'|'$')* let blank = [' ' '\t' '\012' '\r']+ let escape = '\\' _ let hex_escape = '\\' ['x' 'X'] hexdigit+ -let oct_escape = '\\' octdigit octdigit? octdigit? +let oct_escape = '\\' octdigit octdigit? octdigit? (* Pragmas that are not parsed by CIL. We lex them as PRAGMA_LINE tokens *) let no_parse_pragma = - "warning" | "GCC" + "warning" | "GCC" | "STDC" (* Solaris-style pragmas: *) | "ident" | "section" | "option" | "asm" | "use_section" | "weak" | "redefine_extname" @@ -480,22 +490,23 @@ rule initial = | "L'" { CST_WCHAR (chr lexbuf, currentLoc ()) } | '"' { addLexeme lexbuf; (* '"' *) (* matth: BUG: this could be either a regular string or a wide string. - * e.g. if it's the "world" in + * e.g. if it's the "world" in * L"Hello, " "world" * then it should be treated as wide even though there's no L immediately * preceding it. See test/small1/wchar5.c for a failure case. *) try CST_STRING (str lexbuf, currentLoc ()) - with e -> - raise (InternalError - ("str: " ^ + with e -> + raise (InternalError + ("str: " ^ Printexc.to_string e))} | "L\"" { (* weimer: wchar_t string literal *) try CST_WSTRING(str lexbuf, currentLoc ()) - with e -> - raise (InternalError - ("wide string: " ^ + with e -> + raise (InternalError + ("wide string: " ^ Printexc.to_string e))} | floatnum {CST_FLOAT (Lexing.lexeme lexbuf, currentLoc ())} +| complexnum {CST_COMPLEX (Lexing.lexeme lexbuf, currentLoc ())} | hexnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())} | octnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())} | intnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())} @@ -537,7 +548,7 @@ rule initial = | '?' {QUEST} | ':' {COLON} | '~' {TILDE (currentLoc ())} - + | '{' {dbgToken (LBRACE (currentLoc ()))} | '}' {dbgToken (RBRACE (currentLoc ()))} | '[' {LBRACKET} @@ -548,15 +559,15 @@ rule initial = | ',' {COMMA} | '.' {DOT} | "sizeof" {SIZEOF (currentLoc ())} -| "__asm" { if !Cprint.msvcMode then - MSASM (msasm lexbuf, currentLoc ()) +| "__asm" { if !Cprint.msvcMode then + MSASM (msasm lexbuf, currentLoc ()) else (ASM (currentLoc ())) } (* If we see __pragma we eat it and the matching parentheses as well *) | "__pragma" { matchingParsOpen := 0; - let _ = matchingpars lexbuf in + let _ = matchingpars lexbuf in addWhite lexbuf; - initial lexbuf + initial lexbuf } (* sm: tree transformation keywords *) @@ -573,7 +584,7 @@ rule initial = | eof {EOF} | _ {E.parse_error "Invalid symbol"} and comment = - parse + parse "*/" { addWhite lexbuf; [] } (*| '\n' { E.newline (); lex_unescaped comment lexbuf }*) | _ { addWhite lexbuf; lex_comment comment lexbuf } @@ -588,9 +599,9 @@ and matchingpars = parse | blank { addWhite lexbuf; matchingpars lexbuf } | '(' { addWhite lexbuf; incr matchingParsOpen; matchingpars lexbuf } | ')' { addWhite lexbuf; decr matchingParsOpen; - if !matchingParsOpen = 0 then + if !matchingParsOpen = 0 then () - else + else matchingpars lexbuf } | "/*" { addWhite lexbuf; let il = comment lexbuf in @@ -598,7 +609,7 @@ and matchingpars = parse addComment sl; matchingpars lexbuf} | '"' { addWhite lexbuf; (* '"' *) - let _ = str lexbuf in + let _ = str lexbuf in matchingpars lexbuf } | _ { addWhite lexbuf; matchingpars lexbuf } @@ -607,12 +618,12 @@ and matchingpars = parse and hash = parse '\n' { addWhite lexbuf; E.newline (); initial lexbuf} | blank { addWhite lexbuf; hash lexbuf} -| intnum { addWhite lexbuf; (* We are seeing a line number. This is the number for the +| intnum { addWhite lexbuf; (* We are seeing a line number. This is the number for the * next line *) let s = Lexing.lexeme lexbuf in let lineno = try int_of_string s - with Failure ("int_of_string") -> + with Failure _ -> (* the int is too big. *) E.warn "Bad line number in preprocessed file: %s" s; (-1) @@ -621,7 +632,7 @@ and hash = parse (* A file name may follow *) file lexbuf } | "line" { addWhite lexbuf; hash lexbuf } (* MSVC line number info *) - (* For pragmas with irregular syntax, like #pragma warning, + (* For pragmas with irregular syntax, like #pragma warning, * we parse them as a whole line. *) | "pragma" blank (no_parse_pragma as pragmaName) { let here = currentLoc () in @@ -630,27 +641,27 @@ and hash = parse | "pragma" { pragmaLine := true; PRAGMA (currentLoc ()) } | _ { addWhite lexbuf; endline lexbuf} -and file = parse +and file = parse '\n' {addWhite lexbuf; E.newline (); initial lexbuf} | blank {addWhite lexbuf; file lexbuf} | '"' [^ '\012' '\t' '"']* '"' { addWhite lexbuf; (* '"' *) let n = Lexing.lexeme lexbuf in - let n1 = String.sub n 1 + let n1 = String.sub n 1 ((String.length n) - 2) in E.setCurrentFile n1; endline lexbuf} | _ {addWhite lexbuf; endline lexbuf} -and endline = parse +and endline = parse '\n' { addWhite lexbuf; E.newline (); initial lexbuf} | eof { EOF } | _ { addWhite lexbuf; endline lexbuf} and pragma = parse '\n' { E.newline (); "" } -| _ { let cur = Lexing.lexeme lexbuf in - cur ^ (pragma lexbuf) } +| _ { let cur = Lexing.lexeme lexbuf in + cur ^ (pragma lexbuf) } and str = parse '"' {[]} (* no nul terminiation in CST_STRING '"' *) @@ -665,25 +676,25 @@ and chr = parse | oct_escape {lex_oct_escape chr lexbuf} | escape {lex_simple_escape chr lexbuf} | _ {lex_unescaped chr lexbuf} - + and msasm = parse blank { msasm lexbuf } | '{' { msasminbrace lexbuf } -| _ { let cur = Lexing.lexeme lexbuf in +| _ { let cur = Lexing.lexeme lexbuf in cur ^ (msasmnobrace lexbuf) } and msasminbrace = parse '}' { "" } -| _ { let cur = Lexing.lexeme lexbuf in - cur ^ (msasminbrace lexbuf) } +| _ { let cur = Lexing.lexeme lexbuf in + cur ^ (msasminbrace lexbuf) } and msasmnobrace = parse - ['}' ';' '\n'] { lexbuf.Lexing.lex_curr_pos <- + ['}' ';' '\n'] { lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; "" } -| "__asm" { lexbuf.Lexing.lex_curr_pos <- +| "__asm" { lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 5; "" } -| _ { let cur = Lexing.lexeme lexbuf in +| _ { let cur = Lexing.lexeme lexbuf in cur ^ (msasmnobrace lexbuf) } diff --git a/src/frontc/cparser.mly b/src/frontc/cparser.mly index 178714d4d..3da7aba17 100644 --- a/src/frontc/cparser.mly +++ b/src/frontc/cparser.mly @@ -6,7 +6,7 @@ * 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: @@ -36,7 +36,7 @@ * **) (** -** 1.0 3.22.99 Hugues Cassé First version. +** 1.0 3.22.99 Hugues Cass� First version. ** 2.0 George Necula 12/12/00: Practically complete rewrite. *) */ @@ -55,14 +55,14 @@ let print = print_string let getComments () = match !comments with [] -> None - | _ -> + | _ -> let r = Some(String.concat "\n" (List.rev !comments)) in comments := []; r *) -let cabslu = {lineno = -10; - filename = "cabs loc unknown"; +let cabslu = {lineno = -10; + filename = "cabs loc unknown"; byteno = -10; ident = 0;} @@ -84,15 +84,15 @@ let smooth_expression lst = let currentFunctionName = ref "" - + let announceFunctionName ((n, decl, _, _):name) = !Lexerhack.add_identifier n; - (* Start a context that includes the parameter names and the whole body. + (* Start a context that includes the parameter names and the whole body. * Will pop when we finish parsing the function body *) !Lexerhack.push_context (); (* Go through all the parameter names and mark them as identifiers *) let rec findProto = function - PROTO (d, args, _) when isJUSTBASE d -> + PROTO (d, args, _) when isJUSTBASE d -> List.iter (fun (_, (an, _, _, _)) -> !Lexerhack.add_identifier an) args | PROTO (d, _, _) -> findProto d @@ -100,7 +100,7 @@ let announceFunctionName ((n, decl, _, _):name) = | PTR (_, d) -> findProto d | ARRAY (d, _, _) -> findProto d | _ -> parse_error "Cannot find the prototype in a function definition"; - raise Parsing.Parse_error + raise Parsing.Parse_error and isJUSTBASE = function JUSTBASE -> true @@ -112,8 +112,8 @@ let announceFunctionName ((n, decl, _, _):name) = -let applyPointer (ptspecs: attribute list list) (dt: decl_type) - : decl_type = +let applyPointer (ptspecs: attribute list list) (dt: decl_type) + : decl_type = (* Outer specification first *) let rec loop = function [] -> dt @@ -121,7 +121,7 @@ let applyPointer (ptspecs: attribute list list) (dt: decl_type) in loop ptspecs -let doDeclaration (loc: cabsloc) (specs: spec_elem list) (nl: init_name list) : definition = +let doDeclaration (loc: cabsloc) (specs: spec_elem list) (nl: init_name list) : definition = if isTypedef specs then begin (* Tell the lexer about the new type names *) List.iter (fun ((n, _, _, _), _) -> !Lexerhack.add_type n) nl; @@ -132,21 +132,21 @@ let doDeclaration (loc: cabsloc) (specs: spec_elem list) (nl: init_name list) : else begin (* Tell the lexer about the new variable names *) List.iter (fun ((n, _, _, _), _) -> !Lexerhack.add_identifier n) nl; - DECDEF ((specs, nl), loc) + DECDEF ((specs, nl), loc) end let doFunctionDef (loc: cabsloc) (lend: cabsloc) - (specs: spec_elem list) - (n: name) - (b: block) : definition = + (specs: spec_elem list) + (n: name) + (b: block) : definition = let fname = (specs, n) in FUNDEF (fname, b, loc, lend) let doOldParDecl (names: string list) - ((pardefs: name_group list), (isva: bool)) + ((pardefs: name_group list), (isva: bool)) : single_name list * bool = let findOneName n = (* Search in pardefs for the definition for this parameter *) @@ -230,7 +230,7 @@ let transformOffsetOf (speclist, dtype) member = INDEX (replaceBase base, index) | _ -> parse_error "malformed offset expression in __builtin_offsetof"; - raise Parsing.Parse_error + raise Parsing.Parse_error in let memberExpr = replaceBase member in let addrExpr = UNARY (ADDROF, memberExpr) in @@ -246,15 +246,17 @@ let transformOffsetOf (speclist, dtype) member = %token CST_WCHAR %token CST_INT %token CST_FLOAT +%token CST_COMPLEX %token NAMED_TYPE /* Each character is its own list element, and the terminating nul is not included in this list. */ -%token CST_STRING +%token CST_STRING %token CST_WSTRING %token EOF %token CHAR INT BOOL DOUBLE FLOAT VOID INT64 INT32 +%token INT128 FLOAT128 COMPLEX /* C99 */ %token ENUM STRUCT TYPEDEF UNION %token SIGNED UNSIGNED LONG SHORT %token VOLATILE EXTERN STATIC CONST RESTRICT AUTO REGISTER @@ -276,7 +278,7 @@ let transformOffsetOf (speclist, dtype) member = %token INF_INF SUP_SUP %token PLUS_PLUS MINUS_MINUS -%token RPAREN +%token RPAREN %token LPAREN RBRACE %token LBRACE %token LBRACKET RBRACKET @@ -288,13 +290,13 @@ let transformOffsetOf (speclist, dtype) member = %token SWITCH CASE DEFAULT %token WHILE DO FOR %token IF TRY EXCEPT FINALLY -%token ELSE +%token ELSE -%token ATTRIBUTE INLINE ASM TYPEOF FUNCTION__ PRETTY_FUNCTION__ +%token ATTRIBUTE INLINE ASM TYPEOF REAL IMAG FUNCTION__ PRETTY_FUNCTION__ CLASSIFYTYPE %token LABEL__ %token BUILTIN_VA_ARG ATTRIBUTE_USED %token BUILTIN_VA_LIST -%token BLOCKATTRIBUTE +%token BLOCKATTRIBUTE %token BUILTIN_TYPES_COMPAT BUILTIN_OFFSETOF %token DECLSPEC %token MSASM MSATTR @@ -324,8 +326,8 @@ let transformOffsetOf (speclist, dtype) member = %left INF SUP INF_EQ SUP_EQ %left INF_INF SUP_SUP %left PLUS MINUS -%left STAR SLASH PERCENT CONST RESTRICT VOLATILE -%right EXCLAM TILDE PLUS_PLUS MINUS_MINUS CAST RPAREN ADDROF SIZEOF ALIGNOF +%left STAR SLASH PERCENT CONST RESTRICT VOLATILE COMPLEX +%right EXCLAM TILDE PLUS_PLUS MINUS_MINUS CAST RPAREN ADDROF SIZEOF ALIGNOF IMAG REAL CLASSIFYTYPE %left LBRACKET %left DOT ARROW LPAREN LBRACE %right NAMED_TYPE /* We'll use this to handle redefinitions of @@ -350,7 +352,7 @@ let transformOffsetOf (speclist, dtype) member = %type paren_comma_expression %type arguments %type bracket_comma_expression -%type string_list +%type string_list %type wstring_list %type initializer @@ -407,11 +409,11 @@ location: /*** Global Definition ***/ global: | declaration { $1 } -| function_def { $1 } -/*(* Some C header files ar shared with the C++ compiler and have linkage +| function_def { $1 } +/*(* Some C header files ar shared with the C++ compiler and have linkage * specification *)*/ | EXTERN string_constant declaration { LINKAGE (fst $2, (*handleLoc*) (snd $2), [ $3 ]) } -| EXTERN string_constant LBRACE globals RBRACE +| EXTERN string_constant LBRACE globals RBRACE { LINKAGE (fst $2, (*handleLoc*) (snd $2), $4) } | ASM LPAREN string_constant RPAREN SEMICOLON { GLOBASM (fst $3, (*handleLoc*) $1) } @@ -421,7 +423,7 @@ global: * scope it looks too much like a function call *) */ | IDENT LPAREN old_parameter_list_ne RPAREN old_pardef_list SEMICOLON { (* Convert pardecl to new style *) - let pardecl, isva = doOldParDecl $3 $5 in + let pardecl, isva = doOldParDecl $3 $5 in (* Make the function declarator *) doDeclaration ((*handleLoc*) (snd $1)) [] [((fst $1, PROTO(JUSTBASE, pardecl,isva), [], cabslu), @@ -465,7 +467,7 @@ primary_expression: /*(* 6.5.1. *)*/ {VARIABLE (fst $1), snd $1} | constant {CONSTANT (fst $1), snd $1} -| paren_comma_expression +| paren_comma_expression {PAREN (smooth_expression (fst $1)), snd $1} | LPAREN block RPAREN { GNU_BODY (fst3 $2), $1 } @@ -476,7 +478,7 @@ primary_expression: /*(* 6.5.1. *)*/ ; postfix_expression: /*(* 6.5.2 *)*/ -| primary_expression +| primary_expression { $1 } | postfix_expression bracket_comma_expression {INDEX (fst $1, smooth_expression $2), snd $1} @@ -484,18 +486,18 @@ postfix_expression: /*(* 6.5.2 *)*/ {CALL (fst $1, $3), snd $1} | BUILTIN_VA_ARG LPAREN expression COMMA type_name RPAREN { let b, d = $5 in - CALL (VARIABLE "__builtin_va_arg", + CALL (VARIABLE "__builtin_va_arg", [fst $3; TYPE_SIZEOF (b, d)]), $1 } | BUILTIN_TYPES_COMPAT LPAREN type_name COMMA type_name RPAREN { let b1,d1 = $3 in let b2,d2 = $5 in - CALL (VARIABLE "__builtin_types_compatible_p", + CALL (VARIABLE "__builtin_types_compatible_p", [TYPE_SIZEOF(b1,d1); TYPE_SIZEOF(b2,d2)]), $1 } | BUILTIN_OFFSETOF LPAREN type_name COMMA offsetof_member_designator RPAREN { transformOffsetOf $3 $5, $1 } | postfix_expression DOT id_or_typename {MEMBEROF (fst $1, $3), snd $1} -| postfix_expression ARROW id_or_typename +| postfix_expression ARROW id_or_typename {MEMBEROFPTR (fst $1, $3), snd $1} | postfix_expression PLUS_PLUS {UNARY (POSINCR, fst $1), snd $1} @@ -526,6 +528,12 @@ unary_expression: /*(* 6.5.3 *)*/ {EXPR_SIZEOF (fst $2), $1} | SIZEOF LPAREN type_name RPAREN {let b, d = $3 in TYPE_SIZEOF (b, d), $1} +| REAL cast_expression + {REAL (fst $2), $1} +| IMAG cast_expression + {IMAG (fst $2), $1} +| CLASSIFYTYPE cast_expression + {CLASSIFYTYPE (fst $2), $1} | ALIGNOF unary_expression {EXPR_ALIGNOF (fst $2), $1} | ALIGNOF LPAREN type_name RPAREN @@ -536,7 +544,7 @@ unary_expression: /*(* 6.5.3 *)*/ {UNARY (MINUS, fst $2), $1} | STAR cast_expression {UNARY (MEMOF, fst $2), $1} -| AND cast_expression +| AND cast_expression {UNARY (ADDROF, fst $2), $1} | EXCLAM cast_expression {UNARY (NOT, fst $2), $1} @@ -546,7 +554,7 @@ unary_expression: /*(* 6.5.3 *)*/ ; cast_expression: /*(* 6.5.4 *)*/ -| unary_expression +| unary_expression { $1 } | LPAREN type_name RPAREN cast_expression { CAST($2, SINGLE_INIT (fst $4)), $1 } @@ -621,7 +629,7 @@ bitwise_xor_expression: /*(* 6.5.11 *)*/ bitwise_or_expression: /*(* 6.5.12 *)*/ | bitwise_xor_expression - { $1 } + { $1 } | bitwise_or_expression PIPE bitwise_xor_expression {BINARY(BOR, fst $1, fst $3), snd $1} ; @@ -647,7 +655,7 @@ conditional_expression: /*(* 6.5.15 *)*/ {QUESTION (fst $1, $3, fst $5), snd $1} ; -/*(* The C spec says that left-hand sides of assignment expressions are unary +/*(* The C spec says that left-hand sides of assignment expressions are unary * expressions. GCC allows cast expressions in there ! *)*/ assignment_expression: /*(* 6.5.16 *)*/ @@ -671,7 +679,7 @@ assignment_expression: /*(* 6.5.16 *)*/ {BINARY(BOR_ASSIGN, fst $1, fst $3), snd $1} | cast_expression CIRC_EQ assignment_expression {BINARY(XOR_ASSIGN, fst $1, fst $3), snd $1} -| cast_expression INF_INF_EQ assignment_expression +| cast_expression INF_INF_EQ assignment_expression {BINARY(SHL_ASSIGN, fst $1, fst $3), snd $1} | cast_expression SUP_SUP_EQ assignment_expression {BINARY(SHR_ASSIGN, fst $1, fst $3), snd $1} @@ -681,11 +689,12 @@ expression: /*(* 6.5.17 *)*/ assignment_expression { $1 } ; - + constant: CST_INT {CONST_INT (fst $1), snd $1} | CST_FLOAT {CONST_FLOAT (fst $1), snd $1} +| CST_COMPLEX {CONST_COMPLEX (fst $1), snd $1} | CST_CHAR {CONST_CHAR (fst $1), snd $1} | CST_WCHAR {CONST_WCHAR (fst $1), snd $1} | string_constant {CONST_STRING (fst $1), snd $1} @@ -730,13 +739,13 @@ wstring_list: /* Only the first string in the list needs an L, so L"a" "b" is the same * as L"ab" or L"a" L"b". */ -one_string: +one_string: CST_STRING {$1} -| FUNCTION__ {(Cabshelper.explodeStringToInts +| FUNCTION__ {(Cabshelper.explodeStringToInts !currentFunctionName), $1} -| PRETTY_FUNCTION__ {(Cabshelper.explodeStringToInts +| PRETTY_FUNCTION__ {(Cabshelper.explodeStringToInts !currentFunctionName), $1} -; +; init_expression: expression { SINGLE_INIT (fst $1) } @@ -751,23 +760,23 @@ initializer_list_opt: /* empty */ { [] } | initializer_list { $1 } ; -initializer: +initializer: init_designators eq_opt init_expression { ($1, $3) } | gcc_init_designators init_expression { ($1, $2) } | init_expression { (NEXT_INIT, $1) } ; -eq_opt: +eq_opt: EQ { () } /*(* GCC allows missing = *)*/ | /*(* empty *)*/ { () } ; -init_designators: +init_designators: DOT id_or_typename init_designators_opt { INFIELD_INIT($2, $3) } | LBRACKET expression RBRACKET init_designators_opt { ATINDEX_INIT(fst $2, $4) } | LBRACKET expression ELLIPSIS expression RBRACKET { ATINDEXRANGE_INIT(fst $2, fst $4) } -; +; init_designators_opt: /* empty */ { NEXT_INIT } | init_designators { $1 } @@ -777,7 +786,7 @@ gcc_init_designators: /*(* GCC supports these strange things *)*/ id_or_typename COLON { INFIELD_INIT($1, NEXT_INIT) } ; -arguments: +arguments: /* empty */ { [] } | comma_expression { fst $1 } ; @@ -819,7 +828,7 @@ block: /* ISO 6.8.2 */ battrs = $3; bstmts = $4 }, $1, $5 - } + } | error location RBRACE { { blabels = []; battrs = []; bstmts = [] }, @@ -842,7 +851,7 @@ block_element_list: | declaration block_element_list { DEFINITION($1) :: $2 } | statement block_element_list { $1 :: $2 } /*(* GCC accepts a label at the end of a block *)*/ -| IDENT COLON { [ LABEL (fst $1, NOP (snd $1), +| IDENT COLON { [ LABEL (fst $1, NOP (snd $1), snd $1)] } | pragma block_element_list { $2 } ; @@ -851,7 +860,7 @@ local_labels: /* empty */ { [] } | LABEL__ local_label_names SEMICOLON local_labels { $2 @ $4 } ; -local_label_names: +local_label_names: IDENT { [ fst $1 ] } | IDENT COMMA local_label_names { fst $1 :: $3 } ; @@ -895,7 +904,7 @@ statement: | CONTINUE SEMICOLON {CONTINUE ((*handleLoc*) $1)} | GOTO IDENT SEMICOLON {GOTO (fst $2, (*handleLoc*) $1)} -| GOTO STAR comma_expression SEMICOLON +| GOTO STAR comma_expression SEMICOLON { COMPGOTO (smooth_expression (fst $3), (*handleLoc*) $1) } | ASM asmattr LPAREN asmtemplate asmoutputs RPAREN SEMICOLON { ASM ($2, $4, $5, (*handleLoc*) $1) } @@ -903,13 +912,13 @@ statement: | TRY block EXCEPT paren_comma_expression block { let b, _, _ = $2 in let h, _, _ = $5 in - if not !Cprint.msvcMode then + if not !Cprint.msvcMode then parse_error "try/except in GCC code"; TRY_EXCEPT (b, COMMA (fst $4), h, (*handleLoc*) $1) } -| TRY block FINALLY block +| TRY block FINALLY block { let b, _, _ = $2 in let h, _, _ = $4 in - if not !Cprint.msvcMode then + if not !Cprint.msvcMode then parse_error "try/finally in GCC code"; TRY_FINALLY (b, h, (*handleLoc*) $1) } @@ -917,7 +926,7 @@ statement: ; -for_clause: +for_clause: opt_expression SEMICOLON { FC_EXP $1 } | declaration { FC_DECL $1 } ; @@ -925,7 +934,7 @@ for_clause: declaration: /* ISO 6.7.*/ decl_spec_list init_declarator_list SEMICOLON { doDeclaration ((*handleLoc*)(snd $1)) (fst $1) $2 } -| decl_spec_list SEMICOLON +| decl_spec_list SEMICOLON { doDeclaration ((*handleLoc*)(snd $1)) (fst $1) [] } ; init_declarator_list: /* ISO 6.7 */ @@ -935,13 +944,13 @@ init_declarator_list: /* ISO 6.7 */ ; init_declarator: /* ISO 6.7 */ declarator { ($1, NO_INIT) } -| declarator EQ init_expression +| declarator EQ init_expression { ($1, $3) } ; decl_spec_list: /* ISO 6.7 */ /* ISO 6.7.1 */ -| TYPEDEF decl_spec_list_opt { SpecTypedef :: $2, $1 } +| TYPEDEF decl_spec_list_opt { SpecTypedef :: $2, $1 } | EXTERN decl_spec_list_opt { SpecStorage EXTERN :: $2, $1 } | STATIC decl_spec_list_opt { SpecStorage STATIC :: $2, $1 } | AUTO decl_spec_list_opt { SpecStorage AUTO :: $2, $1 } @@ -955,17 +964,17 @@ decl_spec_list: /* ISO 6.7 */ /* specifier pattern variable (must be last in spec list) */ | AT_SPECIFIER LPAREN IDENT RPAREN { [ SpecPattern(fst $3) ], $1 } ; -/* (* In most cases if we see a NAMED_TYPE we must shift it. Thus we declare +/* (* In most cases if we see a NAMED_TYPE we must shift it. Thus we declare * NAMED_TYPE to have right associativity *) */ -decl_spec_list_opt: +decl_spec_list_opt: /* empty */ { [] } %prec NAMED_TYPE | decl_spec_list { fst $1 } ; -/* (* We add this separate rule to handle the special case when an appearance - * of NAMED_TYPE should not be considered as part of the specifiers but as +/* (* We add this separate rule to handle the special case when an appearance + * of NAMED_TYPE should not be considered as part of the specifiers but as * part of the declarator. IDENT has higher precedence than NAMED_TYPE *) */ -decl_spec_list_opt_no_named: +decl_spec_list_opt_no_named: /* empty */ { [] } %prec IDENT | decl_spec_list { fst $1 } ; @@ -977,8 +986,13 @@ type_spec: /* ISO 6.7.2 */ | INT { Tint, $1 } | LONG { Tlong, $1 } | INT64 { Tint64, $1 } +| INT128 { Tint128, $1 } | FLOAT { Tfloat, $1 } +| FLOAT128 { Tfloat128, $1 } | DOUBLE { Tdouble, $1 } +/* | COMPLEX FLOAT { Tfloat, $2 } */ +/* | COMPLEX FLOAT128{ Tfloat128, $2 } */ +/* | COMPLEX DOUBLE { Tdouble, $2 } */ | SIGNED { Tsigned, $1 } | UNSIGNED { Tunsigned, $1 } | STRUCT id_or_typename @@ -1018,24 +1032,24 @@ type_spec: /* ISO 6.7.2 */ | TYPEOF LPAREN type_name RPAREN { let s, d = $3 in TtypeofT (s, d), $1 } ; -struct_decl_list: /* (* ISO 6.7.2. Except that we allow empty structs. We +struct_decl_list: /* (* ISO 6.7.2. Except that we allow empty structs. We * also allow missing field names. *) */ /* empty */ { [] } | decl_spec_list SEMICOLON struct_decl_list - { (fst $1, + { (fst $1, [(missingFieldDecl, None)]) :: $3 } /*(* GCC allows extra semicolons *)*/ | SEMICOLON struct_decl_list { $2 } | decl_spec_list field_decl_list SEMICOLON struct_decl_list - { (fst $1, $2) + { (fst $1, $2) :: $4 } /*(* MSVC allows pragmas in strange places *)*/ | pragma struct_decl_list { $2 } | error SEMICOLON struct_decl_list - { $3 } + { $3 } ; field_decl_list: /* (* ISO 6.7.2 *) */ field_decl { [$1] } @@ -1046,16 +1060,16 @@ field_decl: /* (* ISO 6.7.2. Except that we allow unnamed fields. *) */ | declarator COLON expression attributes { let (n,decl,al,loc) = $1 in let al' = al @ $4 in - ((n,decl,al',loc), Some (fst $3)) } + ((n,decl,al',loc), Some (fst $3)) } | COLON expression { (missingFieldDecl, Some (fst $2)) } ; enum_list: /* (* ISO 6.7.2.2 *) */ enumerator {[$1]} | enum_list COMMA enumerator {$1 @ [$3]} -| enum_list COMMA error { $1 } +| enum_list COMMA error { $1 } ; -enumerator: +enumerator: IDENT {(fst $1, NOTHING, snd $1)} | IDENT EQ expression {(fst $1, fst $3, snd $1)} ; @@ -1090,22 +1104,22 @@ direct_decl: /* (* ISO 6.7.5 *) */ (n, PROTO(decl, params, isva)) } ; -parameter_list_startscope: +parameter_list_startscope: LPAREN { !Lexerhack.push_context () } ; rest_par_list: | /* empty */ { ([], false) } -| parameter_decl rest_par_list1 { let (params, isva) = $2 in - ($1 :: params, isva) +| parameter_decl rest_par_list1 { let (params, isva) = $2 in + ($1 :: params, isva) } ; -rest_par_list1: +rest_par_list1: /* empty */ { ([], false) } | COMMA ELLIPSIS { ([], true) } -| COMMA parameter_decl rest_par_list1 { let (params, isva) = $3 in +| COMMA parameter_decl rest_par_list1 { let (params, isva) = $3 in ($2 :: params, isva) - } -; + } +; parameter_decl: /* (* ISO 6.7.5 *) */ @@ -1113,14 +1127,14 @@ parameter_decl: /* (* ISO 6.7.5 *) */ | decl_spec_list abstract_decl { let d, a = $2 in (fst $1, ("", d, a, cabslu)) } | decl_spec_list { (fst $1, ("", JUSTBASE, [], cabslu)) } -| LPAREN parameter_decl RPAREN { $2 } +| LPAREN parameter_decl RPAREN { $2 } ; /* (* Old style prototypes. Like a declarator *) */ old_proto_decl: pointer_opt direct_old_proto_decl { let (n, decl, a) = $2 in - (n, applyPointer (fst $1) decl, - a, snd $1) + (n, applyPointer (fst $1) decl, + a, snd $1) } ; @@ -1138,7 +1152,7 @@ direct_old_proto_decl: /* (* appears sometimesm but generates a shift-reduce conflict. *) | LPAREN STAR direct_decl LPAREN old_parameter_list_ne RPAREN RPAREN LPAREN RPAREN old_pardef_list - { let par_decl, isva + { let par_decl, isva = doOldParDecl $5 $10 in let n, decl = $3 in (n, PROTO(decl, par_decl, isva), []) @@ -1152,24 +1166,24 @@ old_parameter_list_ne: (fst $1 :: rest) } ; -old_pardef_list: +old_pardef_list: /* empty */ { ([], false) } | decl_spec_list old_pardef SEMICOLON ELLIPSIS - { ([(fst $1, $2)], true) } -| decl_spec_list old_pardef SEMICOLON old_pardef_list + { ([(fst $1, $2)], true) } +| decl_spec_list old_pardef SEMICOLON old_pardef_list { let rest, isva = $4 in - ((fst $1, $2) :: rest, isva) + ((fst $1, $2) :: rest, isva) } ; -old_pardef: +old_pardef: declarator { [$1] } | declarator COMMA old_pardef { $1 :: $3 } | error { [] } ; -pointer: /* (* ISO 6.7.5 *) */ +pointer: /* (* ISO 6.7.5 *) */ STAR attributes pointer_opt { $2 :: fst $3, $1 } ; pointer_opt: @@ -1184,7 +1198,7 @@ type_name: /* (* ISO 6.7.6 *) */ parse_error "attributes in type name"; raise Parsing.Parse_error end; - (fst $1, d) + (fst $1, d) } | decl_spec_list { (fst $1, JUSTBASE) } ; @@ -1193,17 +1207,17 @@ abstract_decl: /* (* ISO 6.7.6. *) */ | pointer { applyPointer (fst $1) JUSTBASE, [] } ; -abs_direct_decl: /* (* ISO 6.7.6. We do not support optional declarator for - * functions. Plus Microsoft attributes. See the +abs_direct_decl: /* (* ISO 6.7.6. We do not support optional declarator for + * functions. Plus Microsoft attributes. See the * discussion for declarator. *) */ | LPAREN attributes abstract_decl RPAREN { let d, a = $3 in PARENTYPE ($2, d, a) } - + | LPAREN error RPAREN - { JUSTBASE } - + { JUSTBASE } + | abs_direct_decl_opt LBRACKET comma_expression_opt RBRACKET { ARRAY($1, [], $3) } /*(* The next should be abs_direct_decl_opt but we get conflicts *)*/ @@ -1211,37 +1225,37 @@ abs_direct_decl: /* (* ISO 6.7.6. We do not support optional declarator for { let (params, isva) = $3 in !Lexerhack.pop_context (); PROTO ($1, params, isva) - } + } ; abs_direct_decl_opt: abs_direct_decl { $1 } | /* empty */ { JUSTBASE } ; function_def: /* (* ISO 6.9.1 *) */ - function_def_start block + function_def_start block { let (loc, specs, decl) = $1 in currentFunctionName := "<__FUNCTION__ used outside any functions>"; - !Lexerhack.pop_context (); (* The context pushed by + !Lexerhack.pop_context (); (* The context pushed by * announceFunctionName *) doFunctionDef ((*handleLoc*) loc) (trd3 $2) specs decl (fst3 $2) - } + } function_def_start: /* (* ISO 6.9.1 *) */ - decl_spec_list declarator + decl_spec_list declarator { announceFunctionName $2; (snd $1, fst $1, $2) - } + } /* (* Old-style function prototype *) */ -| decl_spec_list old_proto_decl +| decl_spec_list old_proto_decl { announceFunctionName $2; (snd $1, fst $1, $2) - } + } /* (* New-style function that does not have a return type *) */ -| IDENT parameter_list_startscope rest_par_list RPAREN +| IDENT parameter_list_startscope rest_par_list RPAREN { let (params, isva) = $3 in - let fdec = + let fdec = (fst $1, PROTO(JUSTBASE, params, isva), [], snd $1) in announceFunctionName fdec; (* Default is int type *) @@ -1255,18 +1269,18 @@ function_def_start: /* (* ISO 6.9.1 *) */ let pardecl, isva = doOldParDecl $3 $5 in (* Make the function declarator *) let fdec = (fst $1, - PROTO(JUSTBASE, pardecl,isva), + PROTO(JUSTBASE, pardecl,isva), [], snd $1) in announceFunctionName fdec; (* Default is int type *) let defSpec = [SpecType Tint] in - (snd $1, defSpec, fdec) + (snd $1, defSpec, fdec) } /* (* No return type and no parameters *) */ | IDENT LPAREN RPAREN { (* Make the function declarator *) let fdec = (fst $1, - PROTO(JUSTBASE, [], false), + PROTO(JUSTBASE, [], false), [], snd $1) in announceFunctionName fdec; (* Default is int type *) @@ -1280,6 +1294,7 @@ cvspec: CONST { SpecCV(CV_CONST), $1 } | VOLATILE { SpecCV(CV_VOLATILE), $1 } | RESTRICT { SpecCV(CV_RESTRICT), $1 } +| COMPLEX { SpecCV(CV_COMPLEX), $1 } ; /*** GCC attributes ***/ @@ -1288,22 +1303,22 @@ attributes: | attribute attributes { fst $1 :: $2 } ; -/* (* In some contexts we can have an inline assembly to specify the name to +/* (* In some contexts we can have an inline assembly to specify the name to * be used for a global. We treat this as a name attribute *) */ attributes_with_asm: /* empty */ { [] } | attribute attributes_with_asm { fst $1 :: $2 } -| ASM LPAREN string_constant RPAREN attributes - { ("__asm__", +| ASM LPAREN string_constant RPAREN attributes + { ("__asm__", [CONSTANT(CONST_STRING (fst $3))]) :: $5 } ; /* things like __attribute__, but no const/volatile */ attribute_nocv: - ATTRIBUTE LPAREN paren_attr_list RPAREN + ATTRIBUTE LPAREN paren_attr_list RPAREN { ("__attribute__", $3), $1 } /*(* -| ATTRIBUTE_USED { ("__attribute__", +| ATTRIBUTE_USED { ("__attribute__", [ VARIABLE "used" ]), $1 } *)*/ | DECLSPEC paren_attr_list_ne { ("__declspec", $2), $1 } @@ -1324,10 +1339,11 @@ attribute: | CONST { ("const", []), $1 } | RESTRICT { ("restrict",[]), $1 } | VOLATILE { ("volatile",[]), $1 } +| STATIC { ("static",[]), $1 } ; /* (* sm: I need something that just includes __attribute__ and nothing more, - * to support them appearing between the 'struct' keyword and the type name. + * to support them appearing between the 'struct' keyword and the type name. * Actually, a declspec can appear there as well (on MSVC) *) */ just_attribute: ATTRIBUTE LPAREN paren_attr_list RPAREN @@ -1343,60 +1359,63 @@ just_attributes: ; /** (* PRAGMAS and ATTRIBUTES *) ***/ -pragma: +pragma: | PRAGMA attr PRAGMA_EOL { PRAGMA ($2, $1) } | PRAGMA attr SEMICOLON PRAGMA_EOL { PRAGMA ($2, $1) } -| PRAGMA_LINE { PRAGMA (VARIABLE (fst $1), +| PRAGMA_LINE { PRAGMA (VARIABLE (fst $1), snd $1) } ; -/* (* We want to allow certain strange things that occur in pragmas, so we - * cannot use directly the language of expressions *) */ -primary_attr: +/* (* We want to allow certain strange things that occur in pragmas, so we + * cannot use directly the language of expressions *) */ +primary_attr: IDENT { VARIABLE (fst $1) } /*(* The NAMED_TYPE here creates conflicts with IDENT *)*/ -| NAMED_TYPE { VARIABLE (fst $1) } -| LPAREN attr RPAREN { $2 } +| NAMED_TYPE { VARIABLE (fst $1) } +| LPAREN attr RPAREN { $2 } | IDENT IDENT { CALL(VARIABLE (fst $1), [VARIABLE (fst $2)]) } | CST_INT { CONSTANT(CONST_INT (fst $1)) } | string_constant { CONSTANT(CONST_STRING (fst $1)) } - /*(* Const when it appears in - * attribute lists, is translated + /*(* Const when it appears in + * attribute lists, is translated * to aconst *)*/ | CONST { VARIABLE "aconst" } | IDENT COLON CST_INT { VARIABLE (fst $1 ^ ":" ^ fst $3) } -/*(* The following rule conflicts with the ? : attributes. We give it a very +/*(* The following rule conflicts with the ? : attributes. We give it a very * low priority *)*/ -| CST_INT COLON CST_INT { VARIABLE (fst $1 ^ ":" ^ fst $3) } +| CST_INT COLON CST_INT { VARIABLE (fst $1 ^ ":" ^ fst $3) } | DEFAULT COLON CST_INT { VARIABLE ("default:" ^ fst $3) } - - /*(** GCC allows this as an - * attribute for functions, + + /*(** GCC allows this as an + * attribute for functions, * synonim for noreturn **)*/ | VOLATILE { VARIABLE ("__noreturn__") } ; postfix_attr: primary_attr { $1 } - /* (* use a VARIABLE "" so that the + /* (* use a VARIABLE "" so that the * parentheses are printed *) */ | IDENT LPAREN RPAREN { CALL(VARIABLE (fst $1), [VARIABLE ""]) } | IDENT paren_attr_list_ne { CALL(VARIABLE (fst $1), $2) } -| postfix_attr ARROW id_or_typename {MEMBEROFPTR ($1, $3)} -| postfix_attr DOT id_or_typename {MEMBEROF ($1, $3)} +| postfix_attr ARROW id_or_typename {MEMBEROFPTR ($1, $3)} +| postfix_attr DOT id_or_typename {MEMBEROF ($1, $3)} | postfix_attr LBRACKET attr RBRACKET {INDEX ($1, $3) } ; -/*(* Since in attributes we use both IDENT and NAMED_TYPE as indentifiers, - * that leads to conflicts for SIZEOF and ALIGNOF. In those cases we require +/*(* Since in attributes we use both IDENT and NAMED_TYPE as indentifiers, + * that leads to conflicts for SIZEOF and ALIGNOF. In those cases we require * that their arguments be expressions, not attributes *)*/ unary_attr: postfix_attr { $1 } -| SIZEOF unary_expression {EXPR_SIZEOF (fst $2) } +| SIZEOF unary_expression { EXPR_SIZEOF (fst $2) } +| REAL unary_expression { REAL (fst $2) } +| IMAG unary_expression { IMAG (fst $2) } +| CLASSIFYTYPE unary_expression { CLASSIFYTYPE (fst $2) } | SIZEOF LPAREN type_name RPAREN {let b, d = $3 in TYPE_SIZEOF (b, d)} @@ -1413,7 +1432,7 @@ unary_attr: cast_attr: unary_attr { $1 } -; +; multiplicative_attr: cast_attr { $1 } @@ -1425,7 +1444,7 @@ multiplicative_attr: additive_attr: multiplicative_attr { $1 } -| additive_attr PLUS multiplicative_attr {BINARY(ADD ,$1 , $3)} +| additive_attr PLUS multiplicative_attr {BINARY(ADD ,$1 , $3)} | additive_attr MINUS multiplicative_attr {BINARY(SUB ,$1 , $3)} ; @@ -1460,7 +1479,7 @@ bitwise_xor_attr: | bitwise_xor_attr CIRC bitwise_and_attr {BINARY(XOR ,$1 , $3)} ; -bitwise_or_attr: +bitwise_or_attr: bitwise_xor_attr { $1 } | bitwise_or_attr PIPE bitwise_xor_attr {BINARY(BOR ,$1 , $3)} ; @@ -1475,10 +1494,10 @@ logical_or_attr: | logical_or_attr PIPE_PIPE logical_and_attr {BINARY(OR ,$1 , $3)} ; -conditional_attr: +conditional_attr: logical_or_attr { $1 } /* This is in conflict for now */ -| logical_or_attr QUEST conditional_attr COLON conditional_attr +| logical_or_attr QUEST conditional_attr COLON conditional_attr { QUESTION($1, $3, $5) } @@ -1494,11 +1513,11 @@ attr_list: /* empty */ { [] } | attr_list_ne { $1 } ; -paren_attr_list_ne: +paren_attr_list_ne: LPAREN attr_list_ne RPAREN { $2 } | LPAREN error RPAREN { [] } ; -paren_attr_list: +paren_attr_list: LPAREN attr_list RPAREN { $2 } | LPAREN error RPAREN { [] } ; @@ -1506,13 +1525,13 @@ paren_attr_list: asmattr: /* empty */ { [] } | VOLATILE asmattr { ("volatile", []) :: $2 } -| CONST asmattr { ("const", []) :: $2 } +| CONST asmattr { ("const", []) :: $2 } ; -asmtemplate: +asmtemplate: one_string_constant { [$1] } | one_string_constant asmtemplate { $1 :: $2 } ; -asmoutputs: +asmoutputs: /* empty */ { None } | COLON asmoperands asminputs { let (ins, clobs) = $3 in @@ -1528,9 +1547,9 @@ asmoperandsne: ; asmoperand: asmopname string_constant LPAREN expression RPAREN { ($1, fst $2, fst $4) } -| asmopname string_constant LPAREN error RPAREN { ($1, fst $2, NOTHING ) } -; -asminputs: +| asmopname string_constant LPAREN error RPAREN { ($1, fst $2, NOTHING ) } +; +asminputs: /* empty */ { ([], []) } | COLON asmoperands asmclobber { ($2, $3) } @@ -1552,8 +1571,5 @@ asmcloberlst_ne: one_string_constant { [$1] } | one_string_constant COMMA asmcloberlst_ne { $1 :: $3 } ; - -%% - - +%% diff --git a/src/frontc/cprint.ml b/src/frontc/cprint.ml index d52e8bb40..c47e0ebe8 100644 --- a/src/frontc/cprint.ml +++ b/src/frontc/cprint.ml @@ -1,4 +1,4 @@ -(* +(* * * Copyright (c) 2001-2003, * George C. Necula @@ -6,7 +6,7 @@ * 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: @@ -41,20 +41,20 @@ ** File: cprint.ml ** Version: 2.1e ** Date: 9.1.99 -** Author: Hugues Cassé +** 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 +** 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: +** 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 +** 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 +** 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'. +** 2.1e 9.1.99 Hugues Cassé Fix, recognize and correctly display '\0'. *) (* George Necula: I changed this pretty dramatically since CABS changed *) @@ -62,13 +62,13 @@ open Cabs open Escape open Whitetrack -let version = "Cprint 2.1e 9.1.99 Hugues Cassé" +let version = "Cprint 2.1e 9.1.99 Hugues Cassé" type loc = { line : int; file : string } let lu = {line = -1; file = "loc unknown";} -let cabslu = {lineno = -10; - filename = "cabs loc unknown"; +let cabslu = {lineno = -10; + filename = "cabs loc unknown"; byteno = -10; ident = 0;} @@ -96,7 +96,7 @@ let current_len = ref 0 let spaces = ref 0 let follow = ref 0 let roll = ref 0 - + (* stub out the old-style manual space functions *) @@ -116,7 +116,7 @@ let print_unescaped_string str = print str (* ** Useful primitives *) -let print_list print_sep print_elt lst = +let print_list print_sep print_elt lst = let _ = List.fold_left (fun com elt -> if com then print_sep (); @@ -129,7 +129,7 @@ let print_list print_sep print_elt lst = let print_commas nl fct lst = print_list (fun () -> print ","; if nl then new_line() else space()) fct lst; print_maybe "," - + let print_string (s:string) = print ("\"" ^ escape_string s ^ "\"") @@ -152,11 +152,12 @@ let rec print_specifiers (specs: spec_elem list) = | STATIC -> "static" | EXTERN -> "extern" | REGISTER -> "register") - | SpecCV cv -> + | SpecCV cv -> printu (match cv with | CV_CONST -> "const" | CV_VOLATILE -> "volatile" - | CV_RESTRICT -> "restrict") + | CV_RESTRICT -> "restrict" + | CV_COMPLEX -> "complex") | SpecAttr al -> print_attribute al; space () | SpecType bt -> print_type_spec bt | SpecPattern name -> printl ["@specifier";"(";name;")"] @@ -173,7 +174,9 @@ and print_type_spec = function | Tint -> print "int " | Tlong -> print "long " | Tint64 -> print "__int64 " + | Tint128 -> print "__int128 " | Tfloat -> print "float " + | Tfloat128 -> print "__float128" | Tdouble -> print "double " | Tsigned -> printu "signed" | Tunsigned -> print "unsigned " @@ -209,10 +212,10 @@ begin end -(* This is the main printer for declarations. It is easy bacause the +(* 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) = function - JUSTBASE -> if n <> "___missing_field_name" then + JUSTBASE -> if n <> "___missing_field_name" then print n else comprint "missing field name" @@ -271,11 +274,11 @@ and print_enum_items items = print "} "; end - + and print_onlytype (specs, dt) = print_specifiers specs; print_decl "" dt - + and print_name ((n, decl, attrs, _) : name) = print_decl n decl; space (); @@ -288,26 +291,26 @@ and print_init_name ((n, i) : init_name) = print "= "; print_init_expression i end - + and print_name_group (specs, names) = print_specifiers specs; print_commas false print_name names - + and print_field_group (specs, fields) = print_specifiers specs; print_commas false print_field fields - -and print_field (name, widtho) = + +and print_field (name, widtho) = print_name name; - (match widtho with + (match widtho with None -> () | Some w -> print " : "; print_expression w) and print_init_name_group (specs, names) = print_specifiers specs; print_commas false print_init_name names - + and print_single_name (specs, name) = print_specifiers specs; print_name name @@ -315,11 +318,11 @@ and print_single_name (specs, name) = and print_params (pars : single_name list) (ell : bool) = print_commas false print_single_name pars; if ell then printl (if pars = [] then ["..."] else [",";"..."]) else () - + and print_old_params pars ell = print_commas false (fun id -> print id) pars; if ell then printl (if pars = [] then ["..."] else [",";"..."]) else () - + (* ** Expression printing @@ -340,7 +343,7 @@ and print_old_params pars ell = ** 3 || ** 2 ? : ** 1 = ?= -** 0 , +** 0 , *) and get_operator exp = match exp with @@ -400,6 +403,9 @@ and get_operator exp = | TYPE_SIZEOF _ -> ("", 16) | EXPR_ALIGNOF exp -> ("", 16) | TYPE_ALIGNOF _ -> ("", 16) + | IMAG exp -> ("", 16) + | REAL exp -> ("", 16) + | CLASSIFYTYPE exp -> ("", 16) | INDEX (exp, idx) -> ("", 15) | MEMBEROF (exp, fld) -> ("", 15) | MEMBEROFPTR (exp, fld) -> ("", 15) @@ -408,31 +414,31 @@ and get_operator exp = and print_comma_exps exps = print_commas false print_expression exps - -and print_init_expression (iexp: init_expression) : unit = - match iexp with + +and print_init_expression (iexp: init_expression) : unit = + match iexp with NO_INIT -> () | SINGLE_INIT e -> print_expression e | COMPOUND_INIT initexps -> let doinitexp = function NEXT_INIT, e -> print_init_expression e - | i, e -> + | i, e -> let rec doinit = function NEXT_INIT -> () | INFIELD_INIT (fn, i) -> printl [".";fn]; doinit i - | ATINDEX_INIT (e, i) -> + | ATINDEX_INIT (e, i) -> print "["; print_expression e; print "]"; doinit i - | ATINDEXRANGE_INIT (s, e) -> - print "["; + | ATINDEXRANGE_INIT (s, e) -> + print "["; print_expression s; print " ... "; print_expression e; print "]" in - doinit i; print " = "; + doinit i; print " = "; print_init_expression e in print "{"; @@ -462,7 +468,7 @@ and print_expression_level (lvl: int) (exp : expression) = print txt; space (); (*print_expression exp2 (if op = SUB then (lvl' + 1) else lvl');*) - print_expression_level (lvl' + 1) exp2 + print_expression_level (lvl' + 1) exp2 (*if (op = SUB) && (lvl <= lvl') then print ")"*) | QUESTION (exp1, exp2, exp3) -> print_expression_level 2 exp1; @@ -475,17 +481,17 @@ and print_expression_level (lvl: int) (exp : expression) = | CAST (typ, iexp) -> print "("; print_onlytype typ; - print ")"; - (* Always print parentheses. In a small number of cases when we print + print ")"; + (* Always print parentheses. In a small number of cases when we print * constants we don't need them *) (match iexp with SINGLE_INIT e -> print_expression_level 15 e - | COMPOUND_INIT _ -> (* print "("; *) - print_init_expression iexp + | COMPOUND_INIT _ -> (* print "("; *) + print_init_expression iexp (* ; print ")" *) | NO_INIT -> print "") - | CALL (VARIABLE "__builtin_va_arg", [arg; TYPE_SIZEOF (bt, dt)]) -> + | CALL (VARIABLE "__builtin_va_arg", [arg; TYPE_SIZEOF (bt, dt)]) -> comprint "variable"; print "__builtin_va_arg"; print "("; @@ -498,12 +504,18 @@ and print_expression_level (lvl: int) (exp : expression) = print "("; print_comma_exps args; print ")" + | CLASSIFYTYPE exp -> + print "__builtin_classify_type"; + print "("; + print_expression_level 1 exp; + print ")" | COMMA exps -> print_comma_exps exps | CONSTANT cst -> (match cst with CONST_INT i -> print i | CONST_FLOAT r -> print r + | CONST_COMPLEX r -> print r | CONST_CHAR c -> print ("'" ^ escape_wstring c ^ "'") | CONST_WCHAR c -> print ("L'" ^ escape_wstring c ^ "'") | CONST_STRING s -> print_string s @@ -526,6 +538,14 @@ and print_expression_level (lvl: int) (exp : expression) = printl ["__alignof__";"("]; print_onlytype (bt, dt); print ")" + | IMAG exp -> + printl ["__imag__";"("]; + print_expression_level 0 exp; + print ")" + | REAL exp -> + printl ["__real__";"("]; + print_expression_level 0 exp; + print ")" | INDEX (exp, idx) -> print_expression_level 16 exp; print "["; @@ -545,7 +565,7 @@ and print_expression_level (lvl: int) (exp : expression) = printl ["@expr";"(";name;")"] in () - + (* ** Statement printing @@ -662,7 +682,7 @@ and print_statement stat = setLoc(loc); printl ["goto";name;";"]; new_line () - | COMPGOTO (exp, loc) -> + | COMPGOTO (exp, loc) -> setLoc(loc); print ("goto *"); print_expression exp; print ";"; new_line () | DEFINITION d -> @@ -677,7 +697,7 @@ and print_statement stat = print_list (fun () -> new_line()) print tlist; (* templates *) print "};" end else begin - print "__asm__ "; + print "__asm__ "; print_attributes attrs; print "("; print_list (fun () -> new_line()) print_string tlist; (* templates *) @@ -699,21 +719,21 @@ and print_statement stat = print ");" end; new_line () - | TRY_FINALLY (b, h, loc) -> + | TRY_FINALLY (b, h, loc) -> setLoc loc; print "__try "; print_block b; print "__finally "; print_block h - | TRY_EXCEPT (b, e, h, loc) -> + | TRY_EXCEPT (b, e, h, loc) -> setLoc loc; print "__try "; print_block b; printl ["__except";"("]; print_expression e; print ")"; print_block h - -and print_block blk = + +and print_block blk = new_line(); print "{"; indent (); @@ -731,7 +751,7 @@ and print_block blk = unindent (); print "}"; new_line () - + and print_substatement stat = match stat with IF _ @@ -755,7 +775,7 @@ and print_substatement stat = (* ** GCC Attributes *) -and print_attribute (name,args) = +and print_attribute (name,args) = if args = [] then printu name else begin print name; @@ -845,7 +865,7 @@ and print_def def = width := oldwidth; force_new_line () - | LINKAGE (n, loc, dl) -> + | LINKAGE (n, loc, dl) -> setLoc (loc); force_new_line (); print "extern "; print_string n; print_string " {"; @@ -915,4 +935,3 @@ let printFile (result : out_channel) ((fname, defs) : file) = let set_tab t = tab := t let set_width w = width := w - diff --git a/src/frontc/dune b/src/frontc/dune new file mode 100644 index 000000000..07182a13c --- /dev/null +++ b/src/frontc/dune @@ -0,0 +1,2 @@ +(ocamllex clexer) +(ocamlyacc cparser) diff --git a/src/frontc/frontc.ml b/src/frontc/frontc.ml index 5a3c24226..3b3e10f16 100644 --- a/src/frontc/frontc.ml +++ b/src/frontc/frontc.ml @@ -1,11 +1,11 @@ (* * - * Copyright (c) 2001-2002, + * 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: @@ -55,8 +55,8 @@ let close_output _ = let set_output filename = close_output (); - let out_chan = try open_out filename - with Sys_error msg -> + let out_chan = try open_out filename + with Sys_error msg -> (output_string stderr ("Error while opening output: " ^ msg); exit 1) in out := Some out_chan; Whitetrack.setOutput out_chan; @@ -122,7 +122,7 @@ begin (* now parse the file we came here to parse *) let cabs = parse_to_cabs_inner fname in - if !E.hadErrors then + if !E.hadErrors then E.s (E.error "There were parsing errors in %s" fname); (* and apply the patch file, return transformed file *) @@ -138,7 +138,7 @@ begin (trace "patch" (dprintf "newpatching %s\n" fname)); let result = (Stats.time "newpatch" (Patch.applyPatch pf) cabs) in - if (!printPatchedFiles) then begin + if (!printPatchedFiles) then begin let outFname:string = fname ^ ".patched" in (trace "patch" (dprintf "printing patched version of %s to %s\n" fname outFname)); @@ -187,7 +187,7 @@ and parse_to_cabs_inner (fname : string) = try if !E.verboseFlag then ignore (E.log "Frontc is parsing %s\n" fname); flush !E.logChannel; - let lexbuf = Clexer.init fname in + let lexbuf = Clexer.init ~filename:fname in let cabs = Stats.time "parse" (Cparser.interpret (Whitetrack.wraplexer clexer)) lexbuf in Whitetrack.setFinalWhite (Clexer.get_white ()); Clexer.finish (); @@ -210,7 +210,7 @@ and parse_to_cabs_inner (fname : string) = raise e end - + (* print to safec.proto.h the prototypes of all functions that are defined *) let printPrototypes ((fname, file) : Cabs.file) : unit = begin @@ -222,12 +222,12 @@ begin let counter : int ref = ref 0 in - let rec loop (d : Cabs.definition) = begin + let loop (d : Cabs.definition) = begin match d with | Cabs.FUNDEF(name, _, loc, _) -> ( match name with | (_, (funcname, Cabs.PROTO(_,_,_), _, _)) -> ( - incr counter; + incr counter; ignore (fprintf chan "\n/* %s from %s:%d */\n" funcname loc.Cabs.filename loc.Cabs.lineno); flush chan; diff --git a/src/frontc/patch.ml b/src/frontc/patch.ml index c2b11b418..6aa5a5730 100644 --- a/src/frontc/patch.ml +++ b/src/frontc/patch.ml @@ -1,11 +1,11 @@ (* * - * Copyright (c) 2001-2002, + * 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: @@ -137,9 +137,9 @@ begin end -(* class to describe how to modify the tree for subtitution *) +(* class to describe how to modify the tree for substitution *) class substitutor (bindings : binding list) = object(self) - inherit nopCabsVisitor as super + inherit nopCabsVisitor (* look in the binding list for a given name *) method findBinding (name : string) : binding = @@ -156,7 +156,7 @@ class substitutor (bindings : binding list) = object(self) Not_found -> raise (BadBind ("name not found: " ^ name)) end - method vexpr (e:expression) : expression visitAction = + method! vexpr (e:expression) : expression visitAction = begin match e with | EXPR_PATTERN(name) -> ( @@ -166,9 +166,9 @@ class substitutor (bindings : binding list) = object(self) ) | _ -> DoChildren end - + (* use of a name *) - method vvar (s:string) : string = + method! vvar (s:string) : string = begin if (isPatternVar s) then ( let nameString = (extractPatternVar s) in @@ -181,7 +181,7 @@ class substitutor (bindings : binding list) = object(self) end (* binding introduction of a name *) - method vname (k: nameKind) (spec: specifier) (n: name) : name visitAction = + method! vname (k: nameKind) (spec: specifier) (n: name) : name visitAction = begin match n with (s (*variable name*), dtype, attrs, loc) -> ( let replacement = (self#vvar s) in (* use replacer from above *) @@ -192,7 +192,7 @@ class substitutor (bindings : binding list) = object(self) ) end - method vspec (specList: specifier) : specifier visitAction = + method! vspec (specList: specifier) : specifier visitAction = begin if verbose then (trace "patchDebug" (dprintf "substitutor: vspec\n")); (printSpec specList); @@ -218,7 +218,7 @@ class substitutor (bindings : binding list) = object(self) match (self#findBinding name) with | BSpecifier(_, replacement) -> ( (trace "patchDebug" (dprintf "replacing pattern %s\n" name)); - replacement + replacement ) | _ -> raise (BadBind ("wrong type: " ^ name)) ) @@ -233,7 +233,7 @@ class substitutor (bindings : binding list) = object(self) DoChildren end - method vtypespec (tspec: typeSpecifier) : typeSpecifier visitAction = + method! vtypespec (tspec: typeSpecifier) : typeSpecifier visitAction = begin match tspec with | Tnamed(str) when (isPatternVar str) -> @@ -258,7 +258,7 @@ let unifyExprFwd : (expression -> expression -> binding list) ref (* substitution for expressions *) let substExpr (bindings : binding list) (expr : expression) : expression = -begin +begin if verbose then (trace "patchDebug" (dprintf "substExpr with %d bindings\n" (List.length bindings))); (printExpr expr); @@ -278,9 +278,9 @@ let d_loc (_:unit) (loc: cabsloc) : doc = (* to apply expression transformers *) class exprTransformer (srcpattern : expression) (destpattern : expression) (patchline : int) (srcloc : cabsloc) = object(self) - inherit nopCabsVisitor as super + inherit nopCabsVisitor - method vexpr (e:expression) : expression visitAction = + method! vexpr (e:expression) : expression visitAction = begin (* see if the source pattern matches this subexpression *) try ( @@ -389,7 +389,7 @@ begin (* recursively invoke myself to try additional patches *) (* since visitCabsDefinition might return a list, I'll try my *) - (* addtional patches on every yielded definition, then collapse *) + (* additional patches on every yielded definition, then collapse *) (* all of them into a single list *) (List.flatten (Util.list_map (fun d -> (patchDefn rest d)) dList)) ) @@ -469,7 +469,7 @@ begin | SpecType(tspec1), SpecType(tspec2) -> (unifyTypeSpecifier tspec1 tspec2) | SpecPattern(name), _ -> - (* record that future occurrances of @specifier(name) will yield this specifier *) + (* record that future occurrences of @specifier(name) will yield this specifier *) if verbose then (trace "patchDebug" (dprintf "found specifier match for %s\n" name)); [BSpecifier(name, [tgt])] diff --git a/src/libmaincil.ml b/src/libmaincil.ml index 11f538f35..29436458d 100644 --- a/src/libmaincil.ml +++ b/src/libmaincil.ml @@ -1,11 +1,11 @@ (* * - * Copyright (c) 2001-2002, + * 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: @@ -49,7 +49,7 @@ open Cil (* print a Cil 'file' to stdout *) let unparseToStdout (cil : file) : unit = begin - dumpFile defaultCilPrinter stdout cil + dumpFile defaultCilPrinter stdout cil.fileName cil end;; (* a visitor to unroll all types - may need to do some magic to keep attributes *) @@ -57,25 +57,25 @@ class unrollVisitorClass = object (self) inherit nopCilVisitor (* variable declaration *) - method vvdec (vi : varinfo) : varinfo visitAction = + method! vvdec (vi : varinfo) : varinfo visitAction = begin vi.vtype <- unrollTypeDeep vi.vtype; (*ignore (E.log "varinfo for %s in file '%s' line %d byte %d\n" vi.vname vi.vdecl.file vi.vdecl.line vi.vdecl.byte);*) SkipChildren end - + (* global: need to unroll fields of compinfo *) - method vglob (g : global) : global list visitAction = + method! vglob (g : global) : global list visitAction = begin match g with - GCompTag(ci, loc) as g -> - let doFieldinfo (fi : fieldinfo) : unit = - fi.ftype <- unrollTypeDeep fi.ftype - in begin + GCompTag(ci, loc) -> + let doFieldinfo (fi : fieldinfo) : unit = + fi.ftype <- unrollTypeDeep fi.ftype + in begin ignore(Util.list_map doFieldinfo ci.cfields); (*ChangeTo [g]*) SkipChildren - end + end | _ -> DoChildren end end;; @@ -102,7 +102,5 @@ Callback.register "cil_unparse" unparseToStdout; (* Callback.register "unroll_type_deep" unrollTypeDeep; *) Callback.register "get_dummy_types" getDummyTypes; -(* initalize CIL *) +(* initialize CIL *) initCIL (); - - diff --git a/src/machdep-ml.c.in b/src/machdep-ml.c.in index 138399fa9..2fb691d45 100644 --- a/src/machdep-ml.c.in +++ b/src/machdep-ml.c.in @@ -101,8 +101,10 @@ int main(int argc, char **argv) { int env = argc == 2 && !strcmp(argv[1], "--env"); int alignof_short, alignof_int, alignof_long, alignof_ptr, alignof_enum, - alignof_float, alignof_double, alignof_longdouble, sizeof_fun, - alignof_fun, alignof_str, alignof_aligned, alignof_longlong, + alignof_float, alignof_double, alignof_longdouble, + alignof_floatcomplex, alignof_doublecomplex, alignof_longdoublecomplex, + sizeof_fun, + alignof_fun, alignof_str, alignof_aligned, alignof_longlong, little_endian, char_is_unsigned, alignof_bool; // The alignment of a short @@ -195,6 +197,33 @@ int main(int argc, char **argv) alignof_longdouble = (intptr_t)(&((struct s1*)0)->ld); } + // The alignment of a float complex + { + struct floatstruct { + char c; + float _Complex f; + }; + alignof_floatcomplex = (intptr_t)(&((struct floatstruct*)0)->f); + } + + // The alignment of double complex + { + struct s1 { + char c; + double _Complex d; + }; + alignof_doublecomplex = (intptr_t)(&((struct s1*)0)->d); + } + + // The alignment of long double complex + { + struct s1 { + char c; + long double _Complex ld; + }; + alignof_longdoublecomplex = (intptr_t)(&((struct s1*)0)->ld); + } + alignof_str = __alignof("a string"); alignof_fun = __alignof(main); @@ -231,7 +260,7 @@ int main(int argc, char **argv) { fprintf(stderr, "Generating CIL_MACHINE machine dependency information string (for CIL)\n"); printf("short=%d,%d int=%d,%d long=%d,%d long_long=%d,%d pointer=%d,%d " - "alignof_enum=%d float=%d,%d double=%d,%d long_double=%d,%d void=%d " + "alignof_enum=%d float=%d,%d double=%d,%d long_double=%d,%d float_complex=%d,%d double_complex=%d,%d long_double_complex=%d,%d void=%d " "bool=%d,%d fun=%d,%d alignof_string=%d max_alignment=%d size_t=%s " "wchar_t=%s char_signed=%s const_string_literals=%s " "big_endian=%s __thread_is_keyword=%s __builtin_va_list=%s " @@ -240,7 +269,8 @@ int main(int argc, char **argv) (int)sizeof(long), alignof_long, (int)sizeof(long long), alignof_longlong, (int)sizeof(int *), alignof_ptr, alignof_enum, (int)sizeof(float), alignof_float, (int)sizeof(double), alignof_double, - (int)sizeof(long double), alignof_longdouble, (int)sizeof(void), + (int)sizeof(long double), alignof_longdouble, (int)sizeof(float _Complex), alignof_floatcomplex, (int)sizeof(double _Complex), alignof_doublecomplex, + (int)sizeof(long double _Complex), alignof_longdoublecomplex, (int)sizeof(void), (int)sizeof(bool), alignof_bool, sizeof_fun, alignof_fun, alignof_str, alignof_aligned, underscore(TYPE_SIZE_T), underscore(TYPE_WCHAR_T), @@ -258,38 +288,44 @@ int main(int argc, char **argv) printf("\t version = \"%s\";\n", VERSION); // Size of certain types - printf("\t sizeof_short = %d;\n", (int)sizeof(short)); - printf("\t sizeof_int = %d;\n", (int)sizeof(int)); - printf("\t sizeof_bool = %d;\n", (int)sizeof(bool)); - printf("\t sizeof_long = %d;\n", (int)sizeof(long)); - printf("\t sizeof_longlong = %d;\n", (int)sizeof(LONGLONG)); - printf("\t sizeof_ptr = %d;\n", (int)sizeof(int *)); - printf("\t sizeof_float = %d;\n", (int)sizeof(float)); - printf("\t sizeof_double = %d;\n", (int)sizeof(double)); - printf("\t sizeof_longdouble = %d;\n", (int)sizeof(long double)); - printf("\t sizeof_void = %d;\n", (int)sizeof(void)); - printf("\t sizeof_fun = %d;\n", (int)sizeof_fun); - printf("\t size_t = \"%s\";\n", TYPE_SIZE_T); - printf("\t wchar_t = \"%s\";\n", TYPE_WCHAR_T); - printf("\t alignof_short = %d;\n", alignof_short); - printf("\t alignof_int = %d;\n", alignof_int); - printf("\t alignof_bool = %d;\n", alignof_bool); - printf("\t alignof_long = %d;\n", alignof_long); - printf("\t alignof_longlong = %d;\n", alignof_longlong); - printf("\t alignof_ptr = %d;\n", alignof_ptr); - printf("\t alignof_enum = %d;\n", alignof_enum); - printf("\t alignof_float = %d;\n", alignof_float); - printf("\t alignof_double = %d;\n", alignof_double); - printf("\t alignof_longdouble = %d;\n", alignof_longdouble); - printf("\t alignof_str = %d;\n", alignof_str); - printf("\t alignof_fun = %d;\n", alignof_fun); - printf("\t alignof_aligned = %d;\n", alignof_aligned); - printf("\t char_is_unsigned = %s;\n", char_is_unsigned ? "true" : "false"); - printf("\t const_string_literals = %s;\n", CONST_STRING_LITERALS); - printf("\t underscore_name = %s;\n", UNDERSCORE_NAME); - printf("\t __builtin_va_list = %s;\n", HAVE_BUILTIN_VA_LIST); - printf("\t __thread_is_keyword = %s;\n", THREAD_IS_KEYWORD); - printf("\t little_endian = %s;\n", little_endian ? "true" : "false"); + printf("\t sizeof_short = %d;\n", (int)sizeof(short)); + printf("\t sizeof_int = %d;\n", (int)sizeof(int)); + printf("\t sizeof_bool = %d;\n", (int)sizeof(bool)); + printf("\t sizeof_long = %d;\n", (int)sizeof(long)); + printf("\t sizeof_longlong = %d;\n", (int)sizeof(LONGLONG)); + printf("\t sizeof_ptr = %d;\n", (int)sizeof(int *)); + printf("\t sizeof_float = %d;\n", (int)sizeof(float)); + printf("\t sizeof_double = %d;\n", (int)sizeof(double)); + printf("\t sizeof_longdouble = %d;\n", (int)sizeof(long double)); + printf("\t sizeof_floatcomplex = %d;\n", (int)sizeof(float _Complex)); + printf("\t sizeof_doublecomplex = %d;\n", (int)sizeof(double _Complex)); + printf("\t sizeof_longdoublecomplex = %d;\n", (int)sizeof(long double _Complex)); + printf("\t sizeof_void = %d;\n", (int)sizeof(void)); + printf("\t sizeof_fun = %d;\n", (int)sizeof_fun); + printf("\t size_t = \"%s\";\n", TYPE_SIZE_T); + printf("\t wchar_t = \"%s\";\n", TYPE_WCHAR_T); + printf("\t alignof_short = %d;\n", alignof_short); + printf("\t alignof_int = %d;\n", alignof_int); + printf("\t alignof_bool = %d;\n", alignof_bool); + printf("\t alignof_long = %d;\n", alignof_long); + printf("\t alignof_longlong = %d;\n", alignof_longlong); + printf("\t alignof_ptr = %d;\n", alignof_ptr); + printf("\t alignof_enum = %d;\n", alignof_enum); + printf("\t alignof_float = %d;\n", alignof_float); + printf("\t alignof_double = %d;\n", alignof_double); + printf("\t alignof_longdouble = %d;\n", alignof_longdouble); + printf("\t alignof_floatcomplex = %d;\n", alignof_floatcomplex); + printf("\t alignof_doublecomplex = %d;\n", alignof_doublecomplex); + printf("\t alignof_longdoublecomplex = %d;\n", alignof_longdoublecomplex); + printf("\t alignof_str = %d;\n", alignof_str); + printf("\t alignof_fun = %d;\n", alignof_fun); + printf("\t alignof_aligned = %d;\n", alignof_aligned); + printf("\t char_is_unsigned = %s;\n", char_is_unsigned ? "true" : "false"); + printf("\t const_string_literals = %s;\n", CONST_STRING_LITERALS); + printf("\t underscore_name = %s;\n", UNDERSCORE_NAME); + printf("\t __builtin_va_list = %s;\n", HAVE_BUILTIN_VA_LIST); + printf("\t __thread_is_keyword = %s;\n", THREAD_IS_KEYWORD); + printf("\t little_endian = %s;\n", little_endian ? "true" : "false"); } return 0; } diff --git a/src/machdepenv.ml b/src/machdepenv.ml index d48767a8f..2707946b7 100644 --- a/src/machdepenv.ml +++ b/src/machdepenv.ml @@ -71,10 +71,16 @@ let modelParse (s:string) : mach = alignof_enum = getInt entries "alignof_enum"; sizeof_float = getSizeof entries "float"; alignof_float = getAlignof entries "float"; + sizeof_floatcomplex = getSizeof entries "float_complex"; + alignof_floatcomplex = getAlignof entries "float_complex"; sizeof_double = getSizeof entries "double"; alignof_double = getAlignof entries "double"; + sizeof_doublecomplex = getSizeof entries "double_complex"; + alignof_doublecomplex = getAlignof entries "double_complex"; sizeof_longdouble = getSizeof entries "long_double"; alignof_longdouble = getAlignof entries "long_double"; + sizeof_longdoublecomplex = getSizeof entries "long_double_complex"; + alignof_longdoublecomplex = getAlignof entries "long_double_complex"; sizeof_void = getSizeof entries "void"; sizeof_fun = getSizeof entries "fun"; alignof_fun = getAlignof entries "fun"; diff --git a/src/main.ml b/src/main.ml index 9d49bf94f..010353899 100644 --- a/src/main.ml +++ b/src/main.ml @@ -1,11 +1,11 @@ (* * - * Copyright (c) 2001-2002, + * 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: @@ -46,11 +46,10 @@ module C = Cil module Fe = Feature module CK = Check module E = Errormsg -open Pretty -type outfile = +type outfile = { fname: string; - fchan: out_channel } + fchan: out_channel } let outChannel : outfile option ref = ref None let mergedChannel : outfile option ref = ref None @@ -59,7 +58,7 @@ let parseOneFile (fname: string) : C.file = (* PARSE and convert to CIL *) if !Cilutil.printStages then ignore (E.log "Parsing %s\n" fname); let cil = F.parse fname () in - + if (not (Feature.enabled "epicenter")) then ( (* sm: remove unused temps to cut down on gcc warnings *) (* (Stats.time "usedVar" Rmtmps.removeUnusedTemps cil); *) @@ -68,7 +67,7 @@ let parseOneFile (fname: string) : C.file = ); cil -let rec processOneFile (cil: C.file) = +let processOneFile (cil: C.file) = begin if !Cilutil.doCheck then begin @@ -80,13 +79,13 @@ let rec processOneFile (cil: C.file) = end end; - (* Scan all the registered features and, if they are + (* Scan all the registered features and, if they are * enabled then run them on the current file *) - List.iter - (fun fdesc -> + List.iter + (fun fdesc -> if fdesc.Fe.fd_enabled then begin - if !E.verboseFlag then - ignore (E.log "Running CIL feature %s (%s)\n" + if !E.verboseFlag then + ignore (E.log "Running CIL feature %s (%s)\n" fdesc.Fe.fd_name fdesc.Fe.fd_description); (* Run the feature, and see how long it takes. *) Stats.time fdesc.Fe.fd_name @@ -106,19 +105,19 @@ let rec processOneFile (cil: C.file) = (match !outChannel with None -> () - | Some c -> Stats.time "printCIL" + | Some c -> Stats.time "printCIL" (C.dumpFile (!C.printerForMaincil) c.fchan c.fname) cil); if !E.hadErrors then E.s (E.error "Error while processing file; see above for details."); end - -(***** MAIN *****) + +(***** MAIN *****) let theMain () = let usageMsg = "Usage: cilly [options] source-files" in (* Processign of output file arguments *) - let openFile (what: string) (takeit: outfile -> unit) (fl: string) = + let openFile (what: string) (takeit: outfile -> unit) (fl: string) = if !E.verboseFlag then ignore (Printf.printf "Setting %s to %s\n" what fl); (try takeit { fname = fl; @@ -135,40 +134,40 @@ let theMain () = (* Load plugins. This needs to be done before command-line arguments are * built. *) - Feature.loadFromEnv "CIL_FEATURES" ["cil.default-features"]; + Feature.loadFromEnv "CIL_FEATURES" ["goblint-cil.default-features"]; Feature.loadFromArgv "--load"; (*********** COMMAND LINE ARGUMENTS *****************) (* Construct the arguments for the features configured from the Makefile *) let blankLine = ("", Arg.Unit (fun _ -> ()), "") in - let featureArgs = + let featureArgs = List.fold_right (fun fdesc acc -> if fdesc.Fe.fd_enabled then (* The feature is enabled by default *) blankLine :: - ("--dont" ^ fdesc.Fe.fd_name, Arg.Unit (fun () -> fdesc.Fe.fd_enabled <- false), + ("--dont" ^ fdesc.Fe.fd_name, Arg.Unit (fun () -> fdesc.Fe.fd_enabled <- false), " Disable " ^ fdesc.Fe.fd_description) :: fdesc.Fe.fd_extraopt @ acc else (* Disabled by default *) blankLine :: - ("--do" ^ fdesc.Fe.fd_name, Arg.Unit (fun () -> fdesc.Fe.fd_enabled <- true), + ("--do" ^ fdesc.Fe.fd_name, Arg.Unit (fun () -> fdesc.Fe.fd_enabled <- true), " Enable " ^ fdesc.Fe.fd_description) :: fdesc.Fe.fd_extraopt @ acc ) (Feature.list_registered ()) [blankLine] in - let featureArgs = + let featureArgs = if Feature.list_registered () = [] then [] else - ("", Arg.Unit (fun () -> ()), " \n\t\tCIL Features") :: featureArgs + ("", Arg.Unit (fun () -> ()), " \n\t\tCIL Features") :: featureArgs in - - let argDescr = Ciloptions.options @ - [ - "--out", Arg.String (openFile "output" + + let argDescr = Ciloptions.options @ + [ + "--out", Arg.String (openFile "output" (fun oc -> outChannel := Some oc)), " the name of the output CIL file.\n\t\t\t\tThe cilly script sets this for you."; "--mergedout", Arg.String (openFile "merged output" @@ -223,15 +222,15 @@ let theMain () = processOneFile one end ;; - (* Define a wrapper for main to + (* Define a wrapper for main to * intercept the exit *) -let failed = ref false +let failed = ref false -let cleanup () = +let cleanup () = if !E.verboseFlag || !Cilutil.printStats then Stats.print stderr "Timings:\n"; - if !E.logChannel != stderr then - close_out (! E.logChannel); + if !E.logChannel != stderr then + close_out (! E.logChannel); (match ! outChannel with Some c -> close_out c.fchan | _ -> ()) @@ -251,11 +250,10 @@ let _ = Sys.set_signal Sys.sigsegv (Sys.Signal_handle handleSEGV); ;; -begin - try - theMain (); +begin + try + theMain (); with F.CabsOnly -> (* this is OK *) () end; cleanup (); exit (if !failed then 1 else 0) - diff --git a/src/mergecil.ml b/src/mergecil.ml index 5bfe364c2..e747c19af 100644 --- a/src/mergecil.ml +++ b/src/mergecil.ml @@ -1,11 +1,11 @@ (* * - * Copyright (c) 2001-2002, + * 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: @@ -34,7 +34,7 @@ * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * *) - + (* 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 @@ -54,7 +54,7 @@ let debugInlines = false let ignore_merge_conflicts = ref false -(* Try to merge structure with the same name. However, do not complain if +(* Try to merge structure with the same name. However, do not complain if * they are not the same *) let mergeSynonyms = true @@ -62,8 +62,8 @@ let mergeSynonyms = true (** Whether to use path compression *) let usePathCompression = false -(* 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 +(* 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 @@ -78,63 +78,63 @@ let mergeGlobals = true (* Return true if 's' starts with the prefix 'p' *) -let prefix p s = +let prefix p s = let lp = String.length p in let ls = String.length s in lp <= ls && String.sub s 0 lp = p -(* A name is identified by the index of the file in which it occurs (starting - * at 0 with the first file) and by the actual name. We'll keep name spaces +(* A name is identified by the index of the file in which it occurs (starting + * at 0 with the first file) and by the actual name. We'll keep name spaces * separate *) (* We define a data structure for the equivalence classes *) -type 'a node = +type 'a node = { nname: string; (* The actual name *) nfidx: int; (* The file index *) ndata: 'a; (* 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. + 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 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 + mutable nrep: 'a 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 + mutable nmergedSyns: bool (* Whether we have merged the synonyms for * the node of this name *) - } + } -let d_nloc () (lo: (location * int) option) : P.doc = - match lo with +let d_nloc () (lo: (location * int) option) : P.doc = + match lo with None -> P.text "None" | Some (l, idx) -> P.dprintf "Some(%d at %a)" idx d_loc l (* Make a node with a self loop. This is quite tricky. *) let mkSelfNode (eq: (int * string, 'a node) H.t) (* The equivalence table *) (syn: (string, 'a node) H.t) (* The synonyms table *) - (fidx: int) (name: string) (data: 'a) - (l: (location * int) option) = + (fidx: int) (name: string) (data: 'a) + (l: (location * int) option) = let rec res = { nname = name; nfidx = fidx; ndata = data; nloc = l; nrep = res; nmergedSyns = false; } in H.add eq (fidx, name) res; (* Add it to the proper table *) - if mergeSynonyms && not (prefix "__anon" name) then - H.add syn name res; + if mergeSynonyms && not (prefix "__anon" name) then + H.add syn name res; res let debugFind = false (* Find the representative with or without path compression *) -let rec find (pathcomp: bool) (nd: 'a node) = +let rec find (pathcomp: bool) (nd: 'a node) = if debugFind then ignore (E.log " find %s(%d)\n" nd.nname nd.nfidx); if nd.nrep == nd then begin @@ -143,49 +143,49 @@ let rec find (pathcomp: bool) (nd: 'a node) = nd end else begin let res = find pathcomp nd.nrep in - if usePathCompression && pathcomp && nd.nrep != res then + 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 +(* 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: 'a node) (nd2: 'a node) : 'a node * (unit -> unit) = +let union (nd1: 'a node) (nd2: 'a node) : 'a node * (unit -> unit) = (* Move to the representatives *) let nd1 = find true nd1 in - let nd2 = find true nd2 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 + (* 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)" + 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 + 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 + 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) -> + match nd1.nloc, nd2.nloc with + Some (_, didx1), Some (_, didx2) -> if didx1 < didx2 then nd1, nd2 else - if didx1 > didx2 then nd2, nd1 + if didx1 > didx2 then nd2, nd1 else begin - ignore (warn - "Merging two elements (%s and %s) in the same file (%d) with the same idx (%d) within the file" + ignore (warn + "Merging two elements (%s and %s) in the same file (%d) with the same idx (%d) within the file" nd1.nname nd2.nname nd1.nfidx didx1); nd1, nd2 end - | _, _ -> (* both none. Does not matter which one we choose. Should + | _, _ -> (* 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 @@ -198,13 +198,13 @@ let union (nd1: 'a node) (nd2: 'a node) : 'a node * (unit -> unit) = if nd1.nloc != None then nd1, nd2 else nd2, nd1 in let oldrep = norep.nrep in - norep.nrep <- rep; + norep.nrep <- rep; rep, (fun () -> norep.nrep <- oldrep) end -(* -let union (nd1: 'a node) (nd2: 'a node) : 'a node * (unit -> unit) = +(* +let union (nd1: 'a node) (nd2: 'a node) : 'a node * (unit -> unit) = if nd1 == nd2 && nd1.nname = "!!!intEnumInfo!!!" then begin - ignore (warn "unioning two identical nodes for %s(%d)" + ignore (warn "unioning two identical nodes for %s(%d)" nd1.nname nd1.nfidx); nd1, fun x -> x end else @@ -216,57 +216,57 @@ let findReplacement (eq: (int * string, 'a node) H.t) (fidx: int) (name: string) : ('a * int) option = - if debugFind then + if debugFind then ignore (E.log "findReplacement for %s(%d)\n" name fidx); try let nd = H.find eq (fidx, name) in if nd.nrep == nd then begin - if debugFind then + if debugFind then ignore (E.log " is a representative\n"); None (* No replacement if this is the representative of its class *) - end else + end else let rep = find pathcomp nd in - if rep != rep.nrep then + if rep != rep.nrep then E.s (bug "find does not return the representative\n"); - if debugFind then + if debugFind then ignore (E.log " RES = %s(%d)\n" rep.nname rep.nfidx); Some (rep.ndata, rep.nfidx) with Not_found -> begin - if debugFind then + if debugFind then ignore (E.log " not found in the map\n"); None end -(* Make a node if one does not already exist. Otherwise return the +(* Make a node if one does not already exist. Otherwise return the * representative *) let getNode (eq: (int * string, 'a node) H.t) (syn: (string, 'a node) H.t) - (fidx: int) (name: string) (data: 'a) - (l: (location * int) option) = + (fidx: int) (name: string) (data: 'a) + (l: (location * int) option) = let debugGetNode = false in - if debugGetNode then + if debugGetNode then ignore (E.log "getNode(%s(%d), %a)\n" name fidx d_nloc l); try let res = H.find eq (fidx, name) in - (match res.nloc, l with + (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 + | Some (old_l, old_idx), Some (l, idx) -> + if old_idx != idx then ignore (warn "Duplicate definition of node %s(%d) at indices %d(%a) and %d(%a)" name fidx old_idx d_loc old_l idx d_loc l) else () | _, _ -> ()); - if debugGetNode then + if debugGetNode then ignore (E.log " node already found\n"); find false res (* No path compression *) with Not_found -> begin let res = mkSelfNode eq syn fidx name data l in - if debugGetNode then + if debugGetNode then ignore (E.log " made a new one\n"); res end @@ -274,12 +274,12 @@ let getNode (eq: (int * string, 'a node) H.t) (* Dump a graph *) -let dumpGraph (what: string) (eq: (int * string, 'a node) H.t) : unit = +let dumpGraph (what: string) (eq: (int * string, 'a node) H.t) : unit = ignore (E.log "Equivalence graph for %s is:\n" what); - H.iter (fun (fidx, name) nd -> - ignore (E.log " %s(%d) %s-> " + H.iter (fun (fidx, name) nd -> + ignore (E.log " %s(%d) %s-> " name fidx (if nd.nloc = None then "(undef)" else "")); - if nd.nrep == nd then + if nd.nrep == nd then ignore (E.log "*\n") else ignore (E.log " %s(%d)\n" nd.nrep.nname nd.nrep.nfidx )) @@ -294,8 +294,8 @@ let sEq: (int * string, compinfo node) H.t = H.create 111 (* Struct + union *) let eEq: (int * string, enuminfo node) H.t = H.create 111 (* Enums *) let tEq: (int * string, typeinfo node) H.t = H.create 111 (* Type names*) let iEq: (int * string, varinfo node) H.t = H.create 111 (* Inlines *) - -(* Sometimes we want to merge synonyms. We keep some tables indexed by names. + +(* Sometimes we want to merge synonyms. We keep some tables indexed by names. * Each name is mapped to multiple exntries *) let vSyn: (string, varinfo node) H.t = H.create 111 (* Not actually used *) let iSyn: (string, varinfo node) H.t = H.create 111 (* Inlines *) @@ -303,7 +303,7 @@ let sSyn: (string, compinfo node) H.t = H.create 111 let eSyn: (string, enuminfo node) H.t = H.create 111 let tSyn: (string, typeinfo node) H.t = H.create 111 -(** A global environment for variables. Put in here only the non-static +(** A global environment for variables. Put in here only the non-static * variables, indexed by their name. *) let vEnv : (string, varinfo node) H.t = H.create 111 @@ -311,25 +311,25 @@ let vEnv : (string, varinfo node) H.t = H.create 111 (* A set of inline functions indexed by their printout ! *) let inlineBodies : (P.doc, varinfo node) H.t = H.create 111 -(** 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 +(** A number of alpha conversion tables. We ought to keep one table for each + * name space. Unfortunately, because of the way the C lexer works, type + * names must be different from variable names!! We one alpha table both for * variables and types. *) -let vtAlpha : (string, location A.alphaTableData ref) H.t - = H.create 57 (* Variables and +let vtAlpha : (string, location A.alphaTableData ref) H.t + = H.create 57 (* Variables and * types *) -let sAlpha : (string, location A.alphaTableData ref) H.t - = H.create 57 (* Structures and - * unions have - * the same name +let sAlpha : (string, location A.alphaTableData ref) H.t + = H.create 57 (* Structures and + * unions have + * the same name * space *) -let eAlpha : (string, location A.alphaTableData ref) H.t +let eAlpha : (string, location A.alphaTableData ref) H.t = H.create 57 (* Enumerations *) -(** 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. +(** 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 @@ -339,17 +339,17 @@ let theFileTypes = ref [] let theFile = ref [] (* add 'g' to the merged file *) -let mergePushGlobal (g: global) : unit = +let mergePushGlobal (g: global) : unit = pushGlobal g ~types:theFileTypes ~variables:theFile - + let mergePushGlobals gl = List.iter mergePushGlobal gl (* 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 +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 @@ -367,12 +367,12 @@ 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 +(** 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 () = +let init () = H.clear sAlpha; H.clear eAlpha; H.clear vtAlpha; @@ -403,7 +403,7 @@ let init () = H.clear emittedVarDecls; H.clear emittedCompDecls; - + H.clear emittedFunDefn; H.clear emittedVarDefn; @@ -437,19 +437,19 @@ type combineWhat = | CombineOther -let rec combineTypes (what: combineWhat) - (oldfidx: int) (oldt: typ) - (fidx: int) (t: typ) : typ = +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 = + | TInt (oldik, olda), TInt (ik, a) -> + let combineIK oldk k = if oldk == k then oldk else - (* GCC allows a function definition to have a more precise integer + (* GCC allows a function definition to have a more precise integer * type than a prototype that says "int" *) - if not !msvcMode && oldk = IInt && bitsSizeOf t <= 32 - && (what = CombineFunarg || what = CombineFunret) - then + if not !msvcMode && oldk = IInt && bitsSizeOf t <= 32 + && (what = CombineFunarg || what = CombineFunret) + then k else ( let msg = @@ -462,14 +462,14 @@ let rec combineTypes (what: combineWhat) in TInt (combineIK oldik ik, addAttributes olda a) - | TFloat (oldfk, olda), TFloat (fk, a) -> - let combineFK oldk k = + | TFloat (oldfk, olda), TFloat (fk, a) -> + let combineFK oldk k = if oldk == k then oldk else - (* GCC allows a function definition to have a more precise integer + (* GCC allows a function definition to have a more precise integer * type than a prototype that says "double" *) - if not !msvcMode && oldk = FDouble && k = FFloat - && (what = CombineFunarg || what = CombineFunret) - then + if not !msvcMode && oldk = FDouble && k = FFloat + && (what = CombineFunarg || what = CombineFunret) + then k else raise (Failure "(different floating point types)") @@ -477,35 +477,35 @@ let rec combineTypes (what: combineWhat) TFloat (combineFK oldfk fk, addAttributes olda a) | TEnum (oldei, olda), TEnum (ei, a) -> - (* Matching enumerations always succeeds. But sometimes it maps both + (* Matching enumerations always succeeds. But sometimes it maps both * enumerations to integers *) matchEnumInfo oldfidx oldei fidx ei; - TEnum (oldei, addAttributes olda a) + TEnum (oldei, addAttributes olda a) (* Strange one. But seems to be handled by GCC *) - | TEnum (oldei, olda) , TInt(IInt, a) -> TEnum(oldei, + | TEnum (oldei, olda) , TInt(IInt, a) -> TEnum(oldei, addAttributes olda a) - (* Strange one. But seems to be handled by GCC. Warning. Here we are + (* 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, addAttributes olda a) + TComp (oldci, addAttributes olda a) - | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) -> + | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) -> let combbt = combineTypes CombineOther oldfidx oldbt fidx bt in - let combinesz = + let combinesz = match oldsz, sz with None, Some _ -> sz | Some _, None -> oldsz | None, None -> oldsz | Some oldsz', Some sz' -> - let samesz = - match constFold true oldsz', constFold true sz' with + let samesz = + match constFold true oldsz', constFold true sz' with Const(CInt64(oldi, _, _)), Const(CInt64(i, _, _)) -> oldi = i | _, _ -> false in @@ -513,9 +513,9 @@ let rec combineTypes (what: combineWhat) raise (Failure "(different array sizes)") in TArray (combbt, combinesz, addAttributes olda a) - - | TPtr (oldbt, olda), TPtr (bt, a) -> - TPtr (combineTypes CombineOther oldfidx oldbt fidx bt, + + | TPtr (oldbt, olda), TPtr (bt, a) -> + TPtr (combineTypes CombineOther oldfidx oldbt fidx bt, addAttributes olda a) (* WARNING: In this case we are leaking types from new to old !! *) @@ -523,35 +523,35 @@ let rec combineTypes (what: combineWhat) | TFun _, TFun (_, _, _, [Attr("missingproto",_)]) -> oldt - + | TFun (oldrt, oldargs, oldva, olda), TFun (rt, args, va, a) -> - let newrt = - combineTypes - (if what = CombineFundef then CombineFunret else CombineOther) - oldfidx oldrt fidx rt + let newrt = + combineTypes + (if what = CombineFundef then CombineFunret else CombineOther) + oldfidx oldrt fidx rt in - if oldva != va then + if oldva != va then raise (Failure "(diferent vararg specifiers)"); - (* If one does not have arguments, believe the one with the + (* If one does not have arguments, believe the one with the * arguments *) - let newargs = + 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 + 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 + (* Go over the arguments and update the old ones with the * adjusted types *) - Some - (List.map2 - (fun (on, ot, oa) (an, at, aa) -> + 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) + let t = + combineTypes + (if what = CombineFundef then + CombineFunarg else CombineOther) oldfidx ot fidx at in let a = addAttributes oa aa in @@ -560,43 +560,43 @@ let rec combineTypes (what: combineWhat) end in TFun (newrt, newargs, oldva, addAttributes olda a) - - | TBuiltin_va_list olda, TBuiltin_va_list a -> + + | TBuiltin_va_list olda, TBuiltin_va_list a -> TBuiltin_va_list (addAttributes olda a) - | TNamed (oldt, olda), TNamed (t, 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) - + TNamed(oldt, addAttributes olda a) + (* Unroll first the new type *) - | _, TNamed (t, a) -> + | _, 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), _ -> + | TNamed (oldt, a), _ -> let res = combineTypes what oldfidx oldt.ttype fidx t in typeAddAttributes a res - + | _ -> ( (* raise (Failure "(different type constructors)") *) - let msg:string = (P.sprint 1000 (P.dprintf "(different type constructors: %a vs. %a)" + let msg:string = (P.sprint ~width:1000 (P.dprintf "(different type constructors: %a vs. %a)" d_type oldt d_type t)) in raise (Failure msg) - ) + ) (* Match two compinfos and throw a Failure if they do not match *) -and matchCompInfo (oldfidx: int) (oldci: compinfo) - (fidx: int) (ci: compinfo) : unit = - if oldci.cstruct <> ci.cstruct then +and matchCompInfo (oldfidx: int) (oldci: compinfo) + (fidx: int) (ci: compinfo) : unit = + if oldci.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 + (* Make the nodes if not already made. Actually return the * representatives *) let oldcinode = getNode sEq sSyn oldfidx oldci.cname oldci None in - let cinode = getNode sEq sSyn fidx ci.cname ci None in + let cinode = getNode sEq sSyn fidx ci.cname ci None in if oldcinode == cinode then (* We already know they are the same *) () else begin @@ -605,81 +605,81 @@ and matchCompInfo (oldfidx: int) (oldci: compinfo) 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 + (* 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. + (* 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 ( let curLoc = !currentLoc in (* d_global blows this away.. *) (trace "merge" (P.dprintf "different # of fields\n%d: %a\n%d: %a\n" old_len d_global (GCompTag(oldci,locUnknown)) len d_global (GCompTag(ci,locUnknown)) - )); + )); currentLoc := curLoc; - let msg = Printf.sprintf - "(different number of fields in %s and %s: %d != %d.)" + let msg = Printf.sprintf + "(different number of fields in %s and %s: %d != %d.)" oldci.cname ci.cname old_len len in raise (Failure msg) ); - (* 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 + (* 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 + (* We check the fields but watch for Failure. We only do the check when + * the lengths are the same. Due to the code above this the other + * possibility is that one of the length is 0, in which case we reuse the * old compinfo. *) (* But what if the old one is the empty one ? *) if old_len = len then begin (try - List.iter2 + List.iter2 (fun oldf f -> - if oldf.fbitfield <> f.fbitfield then + if oldf.fbitfield <> f.fbitfield then raise (Failure "(different bitfield info)"); - if oldf.fattr <> f.fattr then + if oldf.fattr <> f.fattr then raise (Failure "(different field attributes)"); (* Make sure the types are compatible *) - let newtype = + 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 -> begin (* Our assumption was wrong. Forget the isomorphism *) undo (); - let msg = + let msg = P.sprint ~width:80 (P.dprintf "\n\tFailed assumption that %s and %s are isomorphic %s@!%a@!%a" - (compFullName oldci) (compFullName ci) reason + (compFullName oldci) (compFullName ci) reason dn_global (GCompTag(oldci,locUnknown)) dn_global (GCompTag(ci,locUnknown))) in raise (Failure msg) end) 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 + (* 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 + if old_len = 0 then oldci.cfields <- ci.cfields; end; - (* We get here when we succeeded checking that they are equal, or one of + (* 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 = +and matchEnumInfo (oldfidx: int) (oldei: enuminfo) + (fidx: int) (ei: enuminfo) : unit = (* Find the node for this enum, no path compression. *) let oldeinode = getNode eEq eSyn oldfidx oldei.ename oldei None in let einode = getNode eEq eSyn fidx ei.ename ei None in @@ -692,20 +692,20 @@ and matchEnumInfo (oldfidx: int) (oldei: enuminfo) (* Try to match them. But if you cannot just make them both integers *) try (* We do not have a mapping. They better be defined in the same way *) - if List.length oldei.eitems <> List.length ei.eitems then + 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 + (* We check that they are defined in the same way. This is a fairly * conservative check. *) - List.iter2 - (fun (old_iname, old_iv, _) (iname, iv, _) -> - if old_iname <> iname then + List.iter2 + (fun (old_iname, old_iv, _) (iname, iv, _) -> + if old_iname <> iname then raise (Failure "(different names for enumeration items)"); - let samev = - match constFold true old_iv, constFold true iv with + let samev = + match constFold true old_iv, constFold true iv with Const(CInt64(oldi, _, _)), Const(CInt64(i, _, _)) -> oldi = i | _ -> false in - if not samev then + if not samev then raise (Failure "(different values for enumeration items)")) oldei.eitems ei.eitems; (* Set the representative *) @@ -724,11 +724,11 @@ and matchEnumInfo (oldfidx: int) (oldei: enuminfo) 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 +and matchTypeInfo (oldfidx: int) (oldti: typeinfo) + (fidx: int) (ti: typeinfo) : unit = + if oldti.tname = "" || ti.tname = "" then E.s (bug "matchTypeInfo for anonymous type\n"); (* Find the node for this enum, no path compression. *) let oldtnode = getNode tEq tSyn oldfidx oldti.tname oldti None in @@ -745,7 +745,7 @@ and matchTypeInfo (oldfidx: int) (oldti: typeinfo) (try ignore (combineTypes CombineOther oldfidx oldti.ttype fidx ti.ttype); with Failure reason -> begin - let msg = + let msg = P.sprint ~width:80 (P.dprintf "\n\tFailed assumption that %s and %s are isomorphic %s" @@ -757,77 +757,77 @@ and matchTypeInfo (oldfidx: int) (oldti: typeinfo) 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 +(* 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 +(* 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 rec oneFilePass1 (f:file) : unit = +let oneFilePass1 (f:file) : unit = H.add fileNames !currentFidx f.fileName; - if debugMerge || !E.verboseFlag then + if debugMerge || !E.verboseFlag then ignore (E.log "Pre-merging (%d) %s\n" !currentFidx f.fileName); currentDeclIdx := 0; if f.globinitcalled || f.globinit <> None then E.s (E.warn "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 + (* 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) (l: location * int) = - ignore (Alpha.registerAlphaName vtAlpha None vi.vname !currentLoc); + let matchVarinfo (vi: varinfo) (l: location * int) = + ignore (Alpha.registerAlphaName ~alphaTable:vtAlpha ~undolist:None ~lookupname:vi.vname ~data:!currentLoc); (* Make a node for it and put it in vEq *) let vinode = mkSelfNode vEq vSyn !currentFidx vi.vname vi (Some l) in try - let oldvinode = find true (H.find vEnv vi.vname) in - let oldloc, _ = + let oldvinode = find true (H.find vEnv vi.vname) in + let oldloc, _ = match oldvinode.nloc with None -> E.s (bug "old variable is undefined") | Some l -> l in let oldvi = oldvinode.ndata in - (* There is an old definition. We must combine the types. Do this first + (* There is an old definition. We must combine the types. Do this first * because it might fail *) - let newtype = + let newtype = try - combineTypes CombineOther - oldvinode.nfidx oldvi.vtype + combineTypes CombineOther + oldvinode.nfidx oldvi.vtype !currentFidx vi.vtype; with (Failure reason) -> begin (* Go ahead *) let f = if !ignore_merge_conflicts then warn else error in - ignore (f "Incompatible declaration for %s (from %s(%d)).@! Previous was at %a (from %s (%d)) %s " + ignore (f "Incompatible declaration for %s (from %s(%d)).@! Previous was at %a (from %s (%d)) %s " vi.vname (H.find fileNames !currentFidx) !currentFidx - d_loc oldloc - (H.find fileNames oldvinode.nfidx) oldvinode.nfidx + d_loc oldloc + (H.find fileNames oldvinode.nfidx) oldvinode.nfidx reason); raise Not_found end in - let newrep, _ = union oldvinode vinode in - (* We do not want to turn non-"const" globals into "const" one. That - * can happen if one file declares the variable a non-const while + let newrep, _ = union oldvinode vinode in + (* We do not want to turn non-"const" globals into "const" one. That + * can happen if one file declares the variable a non-const while * others declare it as "const". *) - if hasAttribute "const" (typeAttrs vi.vtype) != + if hasAttribute "const" (typeAttrs vi.vtype) != hasAttribute "const" (typeAttrs oldvi.vtype) then begin newrep.ndata.vtype <- typeRemoveAttributes ["const"] newtype; end else begin newrep.ndata.vtype <- newtype; end; (* clean up the storage. *) - let newstorage = - if vi.vstorage = oldvi.vstorage || vi.vstorage = Extern then - oldvi.vstorage - else if oldvi.vstorage = Extern then vi.vstorage - (* Sometimes we turn the NoStorage specifier into Static for inline + let newstorage = + if vi.vstorage = oldvi.vstorage || vi.vstorage = Extern then + oldvi.vstorage + else if oldvi.vstorage = Extern then vi.vstorage + (* Sometimes we turn the NoStorage specifier into Static for inline * functions *) - else if oldvi.vstorage = Static && - vi.vstorage = NoStorage then Static + else if oldvi.vstorage = Static && + vi.vstorage = NoStorage then Static else begin - ignore (warn "Inconsistent storage specification for %s. Now is %a and previous was %a at %a" - vi.vname d_storage vi.vstorage d_storage oldvi.vstorage + ignore (warn "Inconsistent storage specification for %s. Now is %a and previous was %a at %a" + vi.vname d_storage vi.vstorage d_storage oldvi.vstorage d_loc oldloc); vi.vstorage end @@ -835,14 +835,14 @@ let rec oneFilePass1 (f:file) : unit = newrep.ndata.vstorage <- newstorage; newrep.ndata.vattr <- addAttributes oldvi.vattr vi.vattr; () - with Not_found -> (* Not present in the previous files. Remember it for + 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) -> + (function + | GVarDecl (vi, l) | GVar (vi, _, l) -> currentLoc := l; incr currentDeclIdx; vi.vreferenced <- false; @@ -850,61 +850,61 @@ let rec oneFilePass1 (f:file) : unit = matchVarinfo vi (l, !currentDeclIdx); end - | GFun (fdec, l) -> + | GFun (fdec, l) -> currentLoc := l; incr currentDeclIdx; (* Save the names of the formal arguments *) let _, args, _, _ = splitFunctionTypeVI fdec.svar in - H.add formalNames (!currentFidx, fdec.svar.vname) + H.add formalNames (!currentFidx, fdec.svar.vname) (Util.list_map (fun (fn, _, _) -> fn) (argsToList args)); fdec.svar.vreferenced <- false; - (* Force inline functions to be static. *) - (* GN: This turns out to be wrong. inline functions are external, + (* 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 + 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 + if fdec.svar.vinline && mergeInlines then (* Just create the nodes for inline functions *) - ignore (getNode iEq iSyn !currentFidx + ignore (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 + t.treferenced <- false; + if t.tname <> "" then (* The empty names are just for introducing * undefined comp tags *) - ignore (getNode tEq tSyn !currentFidx t.tname t + ignore (getNode tEq tSyn !currentFidx t.tname t (Some (l, !currentDeclIdx))) - else begin (* Go inside and clean the referenced flag for the + else begin (* Go inside and clean the referenced flag for the * declared tags *) - match t.ttype with - TComp (ci, _) -> + match t.ttype with + TComp (ci, _) -> ci.creferenced <- false; (* Create a node for it *) ignore (getNode sEq sSyn !currentFidx ci.cname ci None) - - | TEnum (ei, _) -> + + | TEnum (ei, _) -> ei.ereferenced <- false; ignore (getNode eEq eSyn !currentFidx ei.ename ei None); | _ -> E.s (bug "Anonymous Gtype is not TComp") end - | GCompTag (ci, l) -> + | GCompTag (ci, l) -> incr currentDeclIdx; ci.creferenced <- false; - ignore (getNode sEq sSyn !currentFidx ci.cname ci + ignore (getNode sEq sSyn !currentFidx ci.cname ci (Some (l, !currentDeclIdx))) - | GEnumTag (ei, l) -> + | GEnumTag (ei, l) -> incr currentDeclIdx; ei.ereferenced <- false; - ignore (getNode eEq eSyn !currentFidx ei.ename ei + ignore (getNode eEq eSyn !currentFidx ei.ename ei (Some (l, !currentDeclIdx))) | _ -> ()) @@ -912,25 +912,25 @@ let rec oneFilePass1 (f:file) : unit = (* Try to merge synonyms. Do not give an error if they fail to merge *) -let doMergeSynonyms +let doMergeSynonyms (syn : (string, 'a node) H.t) (eq : (int * string, 'a node) H.t) - (compare : int -> 'a -> int -> 'a -> unit) (* A comparison function that + (compare : int -> 'a -> int -> 'a -> unit) (* A comparison function that * throws Failure if no match *) - : unit = - H.iter (fun n node -> + : unit = + H.iter (fun n node -> if not node.nmergedSyns then begin (* find all the nodes for the same name *) let all = H.find_all syn n in - let rec tryone (classes: 'a node list) (* A number of representatives + let tryone (classes: 'a node list) (* A number of representatives * for this name *) - (nd: 'a node) : 'a node list (* Returns an expanded set - * of classes *) = + (nd: 'a node) : 'a node list (* Returns an expanded set + * of classes *) = 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 -> + | c :: restc -> try compare c.nfidx c.ndata nd.nfidx nd.ndata; (* Success. Stop here the comparison *) @@ -941,33 +941,33 @@ let doMergeSynonyms compareWithClasses classes in (* Start with an empty set of classes for this name *) - let _ = List.fold_left tryone [] all in + let _ = List.fold_left tryone [] all in () end) syn -let matchInlines (oldfidx: int) (oldi: varinfo) - (fidx: int) (i: varinfo) = +let matchInlines (oldfidx: int) (oldi: varinfo) + (fidx: int) (i: varinfo) = let oldinode = getNode iEq iSyn oldfidx oldi.vname oldi None in let inode = getNode iEq iSyn fidx i.vname i None in - if oldinode == inode then - () + if oldinode == inode then + () else 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 + (* There is an old definition. We must combine the types. Do this first * because it might fail *) - oldi.vtype <- - combineTypes CombineOther + oldi.vtype <- + combineTypes CombineOther oldfidx oldi.vtype fidx i.vtype; (* We get here if we have success *) (* Combine the attributes as well *) oldi.vattr <- addAttributes oldi.vattr i.vattr; - (* Do not union them yet because we do not know that they are the same. + (* Do not union them yet because we do not know that they are the same. * We have checked only the types so far *) () end @@ -977,23 +977,23 @@ let matchInlines (oldfidx: int) (oldi: varinfo) * 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 +(** 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 -(** A visitor that renames uses of variables and types *) +(** A visitor that renames uses of variables and types *) class renameVisitorClass = object (self) - inherit nopCilVisitor - - (* This is either a global variable which we took care of, or a local + 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 + method! vvdec (vi: varinfo) = DoChildren - method vglob (g: global) : global list visitAction = + method! vglob (g: global) : global list visitAction = match g with | GVar(v, init, loc) -> let update_init glob = @@ -1022,33 +1022,33 @@ class renameVisitorClass = object (self) (* This is a variable use. See if we must change it *) - method vvrbl (vi: varinfo) : varinfo visitAction = + method! vvrbl (vi: varinfo) : varinfo visitAction = if not vi.vglob then DoChildren else - if vi.vreferenced then begin + if vi.vreferenced then begin H.add varUsedAlready vi.vname (); - DoChildren + DoChildren end else begin match findReplacement true vEq !currentFidx vi.vname with None -> DoChildren - | Some (vi', oldfidx) -> - if debugMerge then + | Some (vi', oldfidx) -> + if debugMerge then ignore (E.log "Renaming use of var %s(%d) to %s(%d)\n" vi.vname !currentFidx vi'.vname oldfidx); - vi'.vreferenced <- true; + vi'.vreferenced <- true; H.add varUsedAlready vi'.vname (); ChangeTo vi' end - - (* The use of a type. Change only those types whose underlying info + + (* The use of a type. Change only those types whose underlying info * is not a root. *) - method vtype (t: typ) = - match t with + method! vtype (t: typ) = + match t with TComp (ci, a) when not ci.creferenced -> begin match findReplacement true sEq !currentFidx ci.cname with None -> DoChildren - | Some (ci', oldfidx) -> - if debugMerge then + | Some (ci', oldfidx) -> + if debugMerge then ignore (E.log "Renaming use of %s(%d) to %s(%d)\n" ci.cname !currentFidx ci'.cname oldfidx); ChangeTo (TComp (ci', visitCilAttributes (self :> cilVisitor) a)) @@ -1056,8 +1056,8 @@ class renameVisitorClass = object (self) | TEnum (ei, a) when not ei.ereferenced -> begin match findReplacement true eEq !currentFidx ei.ename with None -> DoChildren - | Some (ei', _) -> - if ei' == intEnumInfo then + | Some (ei', _) -> + if ei' == intEnumInfo then (* This is actually our friend intEnumInfo *) ChangeTo (TInt(IInt, visitCilAttributes (self :> cilVisitor) a)) else @@ -1067,17 +1067,17 @@ class renameVisitorClass = object (self) | TNamed (ti, a) when not ti.treferenced -> begin match findReplacement true tEq !currentFidx ti.tname with None -> DoChildren - | Some (ti', _) -> + | Some (ti', _) -> ChangeTo (TNamed (ti', visitCilAttributes (self :> cilVisitor) a)) end - + | _ -> DoChildren (* The Field offset might need to be changed to use new compinfo *) - method voffs = function + method! voffs = function Field (f, o) -> begin (* See if the compinfo was changed *) - if f.fcomp.creferenced then + if f.fcomp.creferenced then DoChildren else begin match findReplacement true sEq !currentFidx f.fcomp.cname with @@ -1085,25 +1085,25 @@ class renameVisitorClass = object (self) | Some (ci', oldfidx) -> begin (* First, find out the index of the original field *) let rec indexOf (i: int) = function - [] -> + [] -> E.s (bug "Cannot find field %s in %s(%d)\n" f.fname (compFullName f.fcomp) !currentFidx) | f' :: rest 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 + if List.length ci'.cfields <= index then E.s (bug "Too few fields in replacement %s(%d) for %s(%d)\n" (compFullName ci') oldfidx (compFullName f.fcomp) !currentFidx); - let f' = List.nth ci'.cfields index in + let f' = List.nth ci'.cfields index in ChangeDoChildrenPost (Field (f', o), fun x -> x) end end end | _ -> DoChildren - method vinitoffs o = + method! vinitoffs o = (self#voffs o) (* treat initializer offsets same as lvalue offsets *) end @@ -1111,37 +1111,37 @@ 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) +(** 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 (self) - inherit nopCilVisitor - + inherit nopCilVisitor + (* This is a variable use. See if we must change it *) - method vvrbl (vi: varinfo) : varinfo visitAction = + method! vvrbl (vi: varinfo) : varinfo visitAction = if not vi.vglob then DoChildren else if vi.vreferenced then begin (* Already renamed *) - DoChildren + DoChildren end else begin match findReplacement true vEq !currentFidx vi.vname with None -> DoChildren - | Some (vi', oldfidx) -> - if debugMerge then + | Some (vi', oldfidx) -> + if debugMerge then ignore (E.log "Renaming var %s(%d) to %s(%d)\n" vi.vname !currentFidx vi'.vname oldfidx); - vi'.vreferenced <- true; + vi'.vreferenced <- true; ChangeTo vi' end - (* And rename some declarations of inlines to remove. We cannot drop this + (* And rename some declarations of inlines to remove. We cannot drop this * declaration (see small1/combineinline6) *) - method vglob = function + method! vglob = function GVarDecl(vi, l) when vi.vinline -> begin (* Get the original name *) - let origname = - try H.find originalVarNames vi.vname + let origname = + try H.find originalVarNames vi.vname with Not_found -> vi.vname in (* Now see if this must be replaced *) @@ -1176,18 +1176,18 @@ begin | ComputedGoto(_) -> 131 | Break(_) -> 23 | Continue(_) -> 29 - | If(_,b1,b2,_) -> 31 + 37*(stmtListSum b1.bstmts) + | 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, (il, e), h, _) -> + | TryExcept (b, (il, e), h, _) -> 67 + 83*(stmtListSum b.bstmts) + 97*(stmtListSum h.bstmts) - | TryFinally (b, h, _) -> + | TryFinally (b, h, _) -> 103 + 113*(stmtListSum b.bstmts) + 127*(stmtListSum h.bstmts) in - + (* disabled 2nd and 3rd measure because they appear to get different * values, for the same code, depending on whether the code was just * parsed into CIL or had previously been parsed into CIL, printed @@ -1273,7 +1273,7 @@ begin (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), ye -> @@ -1309,33 +1309,33 @@ begin 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 + (* 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) = - if debugMerge || !E.verboseFlag then - ignore (E.log "Final merging phase (%d): %s\n" +let oneFilePass2 (f: file) = + if debugMerge || !E.verboseFlag then + ignore (E.log "Final merging phase (%d): %s\n" !currentFidx 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 + (* 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 (* Keep a pointer to the contents of the file so far *) let savedTheFile = !theFile in - let processOneGlobal (g: global) : unit = + 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 + let processVarinfo (vi: varinfo) (vloc: location) : varinfo = + if vi.vreferenced then vi (* Already done *) else begin (* Maybe it is static. Rename it then *) if vi.vstorage = Static then begin - let newName, _ = A.newAlphaName vtAlpha None vi.vname !currentLoc in + let newName, _ = A.newAlphaName ~alphaTable:vtAlpha ~undolist:None ~lookupname:vi.vname ~data:!currentLoc in (* Remember the original name *) H.add originalVarNames newName vi.vname; if debugMerge then ignore (E.log "renaming %s at %a to %s\n" @@ -1356,8 +1356,8 @@ let oneFilePass2 (f: file) = end in try - match g with - | GVarDecl (vi, l) as g -> + match g with + | GVarDecl (vi, l) as g -> currentLoc := l; incr currentDeclIdx; let vi' = processVarinfo vi l in @@ -1396,7 +1396,7 @@ let oneFilePass2 (f: file) = to GVarDecl, but that's not convenient to do here. *) true ) - else ( + else ( (* Both GVars have initializers. *) (E.s (error "global var %s at %a has different initializer than %a" vi'.vname d_loc l d_loc prevLoc)); @@ -1410,27 +1410,27 @@ let oneFilePass2 (f: file) = if emitIt then mergePushGlobals (visitCilGlobal renameVisitor (GVar(vi', init, l))) - - | GFun (fdec, l) as g -> + + | GFun (fdec, l) as g -> currentLoc := l; incr currentDeclIdx; (* We apply the renaming *) fdec.svar <- processVarinfo fdec.svar l; (* Get the original name. *) - let origname = - try H.find originalVarNames fdec.svar.vname + 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' + let fdec' = + match visitCilGlobal renameVisitor g with + [GFun(fdec', _)] -> fdec' | _ -> E.s (unimp "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 = + let oldnames, foundthem = try H.find formalNames (!currentFidx, origname), true with Not_found -> begin ignore (warnOpt "Cannot find %s in formalNames" origname); @@ -1439,7 +1439,7 @@ let oneFilePass2 (f: file) = in if foundthem then begin let argl = argsToList args in - if List.length oldnames <> List.length argl then + if List.length oldnames <> List.length argl then E.s (unimp "After merging the function has more arguments"); List.iter2 (fun oldn a -> if oldn <> "" then a.vname <- oldn) @@ -1447,27 +1447,27 @@ let oneFilePass2 (f: file) = (* Reflect them in the type *) setFormals fdec fdec.sformals end; - (** See if we can remove this inline function *) + (* See if we can remove this inline function *) if fdec'.svar.vinline && mergeInlines then begin - let printout = + let printout = (* Temporarily turn of printing of lines *) let oldprintln = !lineDirectiveStyle in lineDirectiveStyle := None; (* Temporarily set the name to all functions in the same way *) let newname = fdec'.svar.vname in fdec'.svar.vname <- "@@alphaname@@"; - (* If we must do alpha conversion then temporarily set the + (* If we must do alpha conversion then temporarily set the * names of the local variables and formals in a standard way *) - let nameId = ref 0 in + let nameId = ref 0 in let oldNames : string list ref = ref [] in - let renameOne (v: varinfo) = - oldNames := v.vname :: !oldNames; + 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 -> + let undoRenameOne (v: varinfo) = + match !oldNames with + n :: rest -> oldNames := rest; v.vname <- n | _ -> E.s (bug "undoRenameOne") @@ -1497,8 +1497,8 @@ let oneFilePass2 (f: file) = res in (* Make a node for this inline function using the original name. *) - let inode = - getNode vEq vSyn !currentFidx origname fdec'.svar + let inode = + getNode vEq vSyn !currentFidx origname fdec'.svar (Some (l, !currentDeclIdx)) in if debugInlines then begin @@ -1506,29 +1506,29 @@ let oneFilePass2 (f: file) = inode.nname inode.nfidx d_nloc inode.nloc !currentDeclIdx); - ignore (E.log + ignore (E.log "Looking for previous definition of inline %s(%d)\n" - origname !currentFidx); + origname !currentFidx); end; try let oldinode = H.find inlineBodies printout in if debugInlines then - ignore (E.log " Matches %s(%d)\n" + ignore (E.log " Matches %s(%d)\n" 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 + (* 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 ignore (warn "Inline function %s because it is used before it is defined" fdec'.svar.vname); - raise Not_found + 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 + (* 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; @@ -1539,11 +1539,11 @@ let oneFilePass2 (f: file) = mergePushGlobal g' end end else begin - (* either the function is not inline, or we're not attempting to + (* 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 + 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 @@ -1561,7 +1561,7 @@ let oneFilePass2 (f: file) = fdec'.svar.vname d_loc l d_loc 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 + * older one to avoid a link error later. I think this is * a reasonable approximation of what ld does. *) (ignore (warn "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 d_loc l curSum d_loc prevLoc @@ -1573,81 +1573,81 @@ let oneFilePass2 (f: file) = (H.add emittedFunDefn fdec'.svar.vname (fdec', l, curSum)) end end else begin - (* not attempting to merge global functions, or it was static + (* not attempting to merge global functions, or it was static * or inline *) mergePushGlobal g' end end - + | GCompTag (ci, l) as g -> begin currentLoc := l; incr currentDeclIdx; - if ci.creferenced then - () + if ci.creferenced then + () else begin match findReplacement true sEq !currentFidx ci.cname with - None -> + None -> (* A new one, we must rename it and keep the definition *) (* Make sure this is root *) - (try + (try let nd = H.find sEq (!currentFidx, ci.cname) in - if nd.nrep != nd then + if nd.nrep != nd then E.s (bug "Setting creferenced for struct %s(%d) which is not root!\n" ci.cname !currentFidx); with Not_found -> begin E.s (bug "Setting creferenced for struct %s(%d) which is not in the sEq!\n" ci.cname !currentFidx); end); - let newname, _ = - A.newAlphaName sAlpha None ci.cname !currentLoc in + let newname, _ = + A.newAlphaName ~alphaTable:sAlpha ~undolist:None ~lookupname:ci.cname ~data:!currentLoc in ci.cname <- newname; - ci.creferenced <- true; + ci.creferenced <- true; ci.ckey <- H.hash (compFullName ci); (* Now we should visit the fields as well *) - H.add emittedCompDecls ci.cname true; (* Remember that we + 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 + (* We are not the representative. Drop this declaration * because we'll not be using it. *) () end - end + end end | GEnumTag (ei, l) as g -> begin currentLoc := l; incr currentDeclIdx; - if ei.ereferenced then - () + if ei.ereferenced then + () else begin - match findReplacement true eEq !currentFidx ei.ename with + match findReplacement true eEq !currentFidx ei.ename with None -> (* We must rename it *) - let newname, _ = - A.newAlphaName eAlpha None ei.ename !currentLoc in + let newname, _ = + A.newAlphaName ~alphaTable:eAlpha ~undolist:None ~lookupname:ei.ename ~data:!currentLoc in ei.ename <- newname; ei.ereferenced <- true; - (* And we must rename the items to using the same name space + (* And we must rename the items to using the same name space * as the variables *) - ei.eitems <- + ei.eitems <- Util.list_map - (fun (n, i, loc) -> - let newname, _ = - A.newAlphaName vtAlpha None n !currentLoc in + (fun (n, i, loc) -> + let newname, _ = + A.newAlphaName ~alphaTable:vtAlpha ~undolist:None ~lookupname:n ~data:!currentLoc in newname, i, loc) ei.eitems; mergePushGlobals (visitCilGlobal renameVisitor g); - | Some (ei', _) -> (* Drop this since we are reusing it from + | Some (ei', _) -> (* Drop this since we are reusing it from * before *) () end end | GCompTagDecl (ci, l) -> begin - currentLoc := l; (* This is here just to introduce an undefined - * structure. But maybe the structure was defined + currentLoc := 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 + (* Do not increment currentDeclIdx because it is not incremented in * pass 1*) - if H.mem emittedCompDecls ci.cname then + if H.mem emittedCompDecls ci.cname then () (* It was already declared *) else begin H.add emittedCompDecls ci.cname true; @@ -1656,65 +1656,65 @@ let oneFilePass2 (f: file) = end end - | GEnumTagDecl (ei, l) -> + | GEnumTagDecl (ei, l) -> currentLoc := l; - (* Do not increment currentDeclIdx because it is not incremented in + (* 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 := l; incr currentDeclIdx; - if ti.treferenced then - () + if ti.treferenced then + () else begin - match findReplacement true tEq !currentFidx ti.tname with + match findReplacement true tEq !currentFidx ti.tname with None -> (* We must rename it and keep it *) - let newname, _ = - A.newAlphaName vtAlpha None ti.tname !currentLoc in + let newname, _ = + A.newAlphaName ~alphaTable:vtAlpha ~undolist:None ~lookupname:ti.tname ~data:!currentLoc in ti.tname <- newname; ti.treferenced <- true; mergePushGlobals (visitCilGlobal renameVisitor g); - | Some (ti', _) ->(* Drop this since we are reusing it from + | Some (ti', _) ->(* Drop this since we are reusing it from * before *) () end end | g -> mergePushGlobals (visitCilGlobal renameVisitor g) with e -> begin - let globStr:string = (P.sprint 1000 (P.dprintf + let globStr:string = (P.sprint ~width:1000 (P.dprintf "error when merging global %a: %s" d_global g (Printexc.to_string e))) in ignore (E.log "%s" globStr); (*"error when merging global: %s" (Printexc.to_string e);*) - mergePushGlobal (GText (P.sprint 80 + mergePushGlobal (GText (P.sprint ~width:80 (P.dprintf "/* error at %t:" d_thisloc))); mergePushGlobal g; mergePushGlobal (GText ("*************** end of error*/")); - raise e + raise e end in (* Now do the real PASS 2 *) List.iter processOneGlobal f.globals; - (* 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 + (* 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 - if debugMerge || !E.verboseFlag then - ignore (E.log "Repeat final merging phase (%d): %s\n" + if debugMerge || !E.verboseFlag then + ignore (E.log "Repeat final merging phase (%d): %s\n" !currentFidx f.fileName); - (* We are going to rescan the globals we have added while processing this + (* 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) = + let rec scanUntil (tail: 'a list) (l: 'a list) = if tail == l then () else - match l with + match l with | [] -> E.s (bug "mergecil: scanUntil could not find the marker\n") - | g :: rest -> + | g :: rest -> theseGlobals := g :: !theseGlobals; scanUntil tail rest in @@ -1723,21 +1723,21 @@ let oneFilePass2 (f: file) = scanUntil savedTheFile !theFile; (* Now reprocess them *) theFile := savedTheFile; - List.iter (fun g -> + 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 + H.iter (fun name _ -> + if not (H.mem inlinesRemoved name) then ignore (warn "Could not remove inline %s. I have no idea why!" name)) inlinesToRemove *) end -let merge (files: file list) (newname: string) : file = +let merge (files: file list) (newname: string) : file = init (); - + (* Make the first pass over the files *) currentFidx := 0; List.iter (fun f -> oneFilePass1 f; incr currentFidx) files; @@ -1747,8 +1747,8 @@ let merge (files: file list) (newname: string) : file = doMergeSynonyms sSyn sEq matchCompInfo; doMergeSynonyms eSyn eEq matchEnumInfo; doMergeSynonyms tSyn tEq matchTypeInfo; - if mergeInlines then begin - (* Copy all the nodes from the iEq to vEq as well. This is needed + 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 *) H.iter (fun k n -> H.add vEq k n) iEq; doMergeSynonyms iSyn iEq matchInlines; @@ -1763,7 +1763,7 @@ let merge (files: file list) (newname: string) : file = dumpGraph "variable" vEq; if mergeInlines then dumpGraph "inline" iEq; end; - (* Make the second pass over the files. This is when we start rewriting the + (* 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; @@ -1773,18 +1773,13 @@ let merge (files: file list) (newname: string) : file = [] -> acc | x :: t -> revonto (x :: acc) t in - let res = + let res = { fileName = newname; globals = revonto (revonto [] !theFile) !theFileTypes; globinit = None; globinitcalled = false;} in init (); (* Make the GC happy *) - (* We have made many renaming changes and sometimes we have just guessed a + (* 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; + uniqueVarNames res; res - - - - - diff --git a/src/ocamlutil/bitmap.ml b/src/ocamlutil/bitmap.ml index 14d26a08b..47248ec48 100644 --- a/src/ocamlutil/bitmap.ml +++ b/src/ocamlutil/bitmap.ml @@ -5,12 +5,12 @@ type t = { mutable nrWords : int; mutable bitmap : int32 array } - (* Enlarge a bitmap to contain at + (* Enlarge a bitmap to contain at * least newWords *) -let enlarge b newWords = - let newbitmap = +let enlarge b newWords = + let newbitmap = if newWords > b.nrWords then - let a = Array.create newWords Int32.zero in + let a = Array.make newWords Int32.zero in Array.blit b.bitmap 0 a 0 b.nrWords; a else @@ -18,28 +18,28 @@ let enlarge b newWords = b.nrWords <- newWords; b.nrBits <- newWords lsl 5; b.bitmap <- newbitmap - + (* Create a new empty bitmap *) -let make size = +let make size = let wrd = (size + 31) lsr 5 in { nrWords = wrd; nrBits = wrd lsl 5; bitmap = Array.make wrd Int32.zero - } + } -let size t = t.nrBits +let size t = t.nrBits (* Make an initialized array *) -let init size how = +let init size how = let wrd = (size + 31) lsr 5 in - let how' w = + let how' w = let first = w lsl 5 in - let last = min size (first + 32) in - let rec loop i acc = - if i >= last then acc + let last = min size (first + 32) in + let rec loop i acc = + if i >= last then acc else let acc' = Int32.shift_left acc 1 in - if how i then loop (i + 1) (Int32.logor acc' Int32.one) + if how i then loop (i + 1) (Int32.logor acc' Int32.one) else loop (i + 1) acc' in loop first Int32.zero @@ -47,21 +47,21 @@ let init size how = { nrWords = wrd; nrBits = wrd lsl 5; bitmap = Array.init wrd how' - } - -let clone b = + } + +let clone b = { nrWords = b.nrWords; nrBits = b.nrBits; bitmap = Array.copy b.bitmap; - } - + } + let cloneEmpty b = { nrWords = b.nrWords; nrBits = b.nrBits; bitmap = Array.make b.nrWords Int32.zero; - } + } -let union b1 b2 = +let union b1 b2 = begin let n = b2.nrWords in if b1.nrWords < n then enlarge b1 n else (); @@ -79,7 +79,7 @@ let union b1 b2 = ! changed end (* lin += (lout - def) *) -let union_except lin lout def = +let union_except lin lout def = begin (* Need to enlarge def to lout *) let n = lout.nrWords in if def.nrWords < n then enlarge def n else (); @@ -92,7 +92,7 @@ let union_except lin lout def = for i=0 to n - 1 do begin let old = alin.(i) in - let nw = Int32.logor old (Int32.logand alout.(i) + let nw = Int32.logor old (Int32.logand alout.(i) (Int32.lognot adef.(i))) in alin.(i) <- nw; changed := (old <> nw) || (!changed) @@ -102,7 +102,7 @@ let union_except lin lout def = end (* b1 *= b2 *) -let inters b1 b2 = +let inters b1 b2 = begin let n = min b1.nrWords b2.nrWords in let a1 = b1.bitmap in @@ -118,7 +118,7 @@ let inters b1 b2 = () end -let emptyInt b start = +let emptyInt b start = let n = b.nrWords in let a = b.bitmap in let rec loop i = i >= n || (a.(i) = Int32.zero && loop (i + 1)) @@ -139,10 +139,10 @@ let equal b1 b2 = if a1.(i) <> a2.(i) then res := false else () end done; - if !res then + if !res then if b1.nrWords > n then emptyInt b1 n - else if b2.nrWords > n then + else if b2.nrWords > n then emptyInt b2 n else true @@ -150,17 +150,17 @@ let equal b1 b2 = false end -let assign b1 b2 = +let assign b1 b2 = begin let n = b2.nrWords in if b1.nrWords < n then enlarge b1 n else (); let a1 = b1.bitmap in let a2 = b2.bitmap in - Array.blit a2 0 a1 0 n + Array.blit a2 0 a1 0 n end (* b1 -= b2 *) -let diff b1 b2 = +let diff b1 b2 = begin let n = min b1.nrWords b2.nrWords in let a1 = b1.bitmap in @@ -168,16 +168,16 @@ let diff b1 b2 = for i=0 to n - 1 do a1.(i) <- Int32.logand a1.(i) (Int32.lognot a2.(i)) done; - if n < b1.nrWords then + if n < b1.nrWords then Array.fill a1 n (b1.nrWords - n) Int32.zero else () end - -let test bmp i = + +let test bmp i = assert (i >= 0); if i >= bmp.nrBits then enlarge bmp ((i lsr 5) + 1) else (); let wrd = i lsr 5 in @@ -185,37 +185,37 @@ let test bmp i = (Int32.logand bmp.bitmap.(wrd) msk) <> Int32.zero -let testAndSetTo bmp i tv = +let testAndSetTo bmp i tv = assert(i >= 0); let wrd = i lsr 5 in let msk = Int32.shift_left Int32.one (i - (wrd lsl 5)) in if i >= bmp.nrBits then enlarge bmp (wrd + 1) else (); let old = Int32.logand bmp.bitmap.(wrd) msk <> 0l in - (if tv then + (if tv then bmp.bitmap.(wrd) <- Int32.logor bmp.bitmap.(wrd) msk else bmp.bitmap.(wrd) <- Int32.logand bmp.bitmap.(wrd) (Int32.lognot msk)); old let setTo bmp i tv = ignore (testAndSetTo bmp i tv) - - (* Iterate over all elements in a + + (* Iterate over all elements in a * bitmap *) let fold f bmp arg = let a = bmp.bitmap in let n = bmp.nrWords in - let rec allWords wrd bit arg = + let rec allWords wrd bit arg = if wrd >= n then arg else - let rec allBits msk bit left arg = - if left = 0 then + let rec allBits msk bit left arg = + if left = 0 then allWords (wrd + 1) bit arg else - allBits (Int32.shift_right msk 1) (bit + 1) (left - 1) - (if Int32.logand msk Int32.one <> Int32.zero then f arg bit + allBits (Int32.shift_right msk 1) (bit + 1) (left - 1) + (if Int32.logand msk Int32.one <> Int32.zero then f arg bit else arg) in - allBits a.(wrd) bit 32 arg + allBits a.(wrd) bit 32 arg in allWords 0 0 arg @@ -224,4 +224,4 @@ let iter f t = fold (fun x y -> f y) t () let toList bmp = fold (fun acc i -> i :: acc) bmp [] -let card bmp = fold (fun acc _ -> acc + 1) bmp 0 +let card bmp = fold (fun acc _ -> acc + 1) bmp 0 diff --git a/src/ocamlutil/errormsg.ml b/src/ocamlutil/errormsg.ml index 2ffee51cf..e3c024917 100644 --- a/src/ocamlutil/errormsg.ml +++ b/src/ocamlutil/errormsg.ml @@ -1,11 +1,11 @@ (* * - * Copyright (c) 2001-2002, + * 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: @@ -44,7 +44,7 @@ let verboseFlag = ref false let colorFlag = ref false -(**** Error reporting ****) +(**** Error reporting ****) exception Error let s (d : 'a) = raise Error @@ -54,13 +54,13 @@ let logChannel : out_channel ref = ref stderr let errorContext = ref [] let pushContext f = errorContext := f :: (!errorContext) -let popContext () = - match !errorContext with +let popContext () = + match !errorContext with _ :: t -> errorContext := t | [] -> s (fprintf !logChannel "Bug: cannot pop error context") -let withContext ctx f x = +let withContext ctx f x = pushContext ctx; try let res = f x in @@ -70,12 +70,12 @@ let withContext ctx f x = popContext (); raise e end - - (* Make sure that showContext calls - * each f with its appropriate - * errorContext as it was when it was + + (* Make sure that showContext calls + * each f with its appropriate + * errorContext as it was when it was * pushed *) -let showContext () = +let showContext () = let rec loop = function [] -> () | f :: rest -> (errorContext := rest; (* Just in case f raises an error *) @@ -83,7 +83,7 @@ let showContext () = loop rest) in let old = !errorContext in - try + try loop old; errorContext := old with e -> begin @@ -91,7 +91,7 @@ let showContext () = raise e end -let contextMessage (name: string) (d: doc) = +let contextMessage (name: string) (d: doc) = ignore (fprintf !logChannel "%s: %a@!" name insert d); showContext () @@ -106,8 +106,8 @@ let cyanEscStr = "\027[36m" let whiteEscStr = "\027[37m" let resetEscStr = "\027[m" -let bug (fmt : ('a,unit,doc,unit) format4) : 'a = - let f d = +let bug (fmt : ('a,unit,doc,unit) format4) : 'a = + let f d = hadErrors := true; if !colorFlag then output_string !logChannel greenEscStr; contextMessage "Bug" d; @@ -126,13 +126,13 @@ let error (fmt : ('a,unit,doc,unit) format4) : 'a = in Pretty.gprintf f fmt -let unimp (fmt : ('a,unit,doc,unit) format4) : 'a = - let f d = hadErrors := true; contextMessage "Unimplemented" d; +let unimp (fmt : ('a,unit,doc,unit) format4) : 'a = + let f d = hadErrors := true; contextMessage "Unimplemented" d; flush !logChannel in Pretty.gprintf f fmt -let warn (fmt : ('a,unit,doc,unit) format4) : 'a = +let warn (fmt : ('a,unit,doc,unit) format4) : 'a = let f d = if !colorFlag then output_string !logChannel yellowEscStr; contextMessage "Warning" d; @@ -141,8 +141,8 @@ let warn (fmt : ('a,unit,doc,unit) format4) : 'a = in Pretty.gprintf f fmt -let warnOpt (fmt : ('a,unit,doc,unit) format4) : 'a = - let f d = +let warnOpt (fmt : ('a,unit,doc,unit) format4) : 'a = + let f d = if !warnFlag then begin if !colorFlag then output_string !logChannel yellowEscStr; contextMessage "Warning" d; @@ -152,12 +152,12 @@ let warnOpt (fmt : ('a,unit,doc,unit) format4) : 'a = Pretty.gprintf f fmt -let log (fmt : ('a,unit,doc,unit) format4) : 'a = - let f d = fprint !logChannel 80 d; flush !logChannel in +let log (fmt : ('a,unit,doc,unit) format4) : 'a = + let f d = fprint !logChannel ~width:80 d; flush !logChannel in Pretty.gprintf f fmt let logg (fmt : ('a,unit,doc,unit) format4) : 'a = - let f d = fprint !logChannel 10000000 d; flush !logChannel in + let f d = fprint !logChannel ~width:10000000 d; flush !logChannel in Pretty.gprintf f fmt let null (fmt : ('a,unit,doc,unit) format4) : 'a = @@ -167,7 +167,7 @@ let null (fmt : ('a,unit,doc,unit) format4) : 'a = let theLexbuf = ref (Lexing.from_string "") -let fail format = Pretty.gprintf (fun x -> Pretty.fprint stderr 80 x; +let fail format = Pretty.gprintf (fun x -> Pretty.fprint stderr ~width:80 x; raise (Failure "")) format @@ -175,7 +175,7 @@ let fail format = Pretty.gprintf (fun x -> Pretty.fprint stderr 80 x; (***** Handling parsing errors ********) type parseinfo = { mutable linenum: int ; (* Current line *) - mutable linestart: int ; (* The position in the buffer where the + mutable linestart: int ; (* The position in the buffer where the * current line starts *) mutable fileName : string ; (* Current file *) mutable hfile : string ; (* High-level file *) @@ -184,8 +184,8 @@ type parseinfo = inchan : in_channel option; (* None, if from a string *) mutable num_errors : int; (* Errors so far *) } - -let dummyinfo = + +let dummyinfo = { linenum = 1; linestart = 0; fileName = "" ; @@ -202,27 +202,28 @@ let setHLine (l: int) : unit = !current.hline <- l let setHFile (f: string) : unit = !current.hfile <- f - + let rem_quotes str = String.sub str 1 ((String.length str) - 2) (* Change \ into / in file names. To avoid complications with escapes *) -let cleanFileName str = - let str1 = - if str <> "" && String.get str 0 = '"' (* '"' ( *) +let cleanFileName str = + let str1 = + if str <> "" && String.get str 0 = '"' (* '"' ( *) then rem_quotes str else str in let l = String.length str1 in - let rec loop (copyto: int) (i: int) = - if i >= l then - String.sub str1 0 copyto - else - let c = String.get str1 i in + let str1 = Bytes.of_string str1 in + let rec loop (copyto: int) (i: int) = + if i >= l then + Bytes.to_string (Bytes.sub str1 0 copyto) + else + let c = Bytes.get str1 i in if c <> '\\' then begin - String.set str1 copyto c; loop (copyto + 1) (i + 1) + Bytes.set str1 copyto c; loop (copyto + 1) (i + 1) end else begin - String.set str1 copyto '/'; - if i < l - 2 && String.get str1 (i + 1) = '\\' then + Bytes.set str1 copyto '/'; + if i < l - 2 && Bytes.get str1 (i + 1) = '\\' then loop (copyto + 1) (i + 2) - else + else loop (copyto + 1) (i + 1) end in @@ -230,25 +231,25 @@ let cleanFileName str = let readingFromStdin = ref false -let startParsing ?(useBasename=true) (fname: string) = +let startParsing ?(useBasename=true) (fname: string) = (* We only support one open file at a time *) if !current != dummyinfo then begin - s (error "Errormsg.startParsing supports only one open file: You want to open %s and %s is still open\n" fname !current.fileName); - end; - let inchan = - try if fname = "-" then begin + s (error "Errormsg.startParsing supports only one open file: You want to open %s and %s is still open\n" fname !current.fileName); + end; + let inchan = + try if fname = "-" then begin readingFromStdin := true; - stdin + stdin end else begin readingFromStdin := false; - open_in fname + open_in fname end - with e -> s (error "Cannot find input file %s (exception %s" + with e -> s (error "Cannot find input file %s (exception %s" fname (Printexc.to_string e)) in let lexbuf = Lexing.from_channel inchan in - let i = - { linenum = 1; linestart = 0; - fileName = + let i = + { linenum = 1; linestart = 0; + fileName = cleanFileName (if useBasename then Filename.basename fname else fname); lexbuf = lexbuf; inchan = Some inchan; hfile = ""; hline = 0; @@ -257,39 +258,39 @@ let startParsing ?(useBasename=true) (fname: string) = current := i; lexbuf -let startParsingFromString ?(file="") ?(line=1) (str: string) = +let startParsingFromString ?(file="") ?(line=1) (str: string) = let lexbuf = Lexing.from_string str in - let i = + let i = { linenum = line; linestart = line - 1; fileName = file; hfile = ""; hline = 0; - lexbuf = lexbuf; + lexbuf = lexbuf; inchan = None; num_errors = 0 } in current := i; lexbuf -let finishParsing () = +let finishParsing () = let i = !current in (match i.inchan with Some c -> close_in c | _ -> ()); current := dummyinfo (* Call this function to announce a new line *) -let newline () = +let newline () = let i = !current in i.linenum <- 1 + i.linenum; i.linestart <- Lexing.lexeme_start i.lexbuf -let newHline () = +let newHline () = let i = !current in i.hline <- 1 + i.hline -let setCurrentLine (i: int) = +let setCurrentLine (i: int) = !current.linenum <- i -let setCurrentFile (n: string) = +let setCurrentFile (n: string) = !current.fileName <- cleanFileName n @@ -297,23 +298,23 @@ let max_errors = 20 (* Stop after 20 errors *) let parse_error (msg: string) : 'a = (* Sometimes the Ocaml parser raises errors in symbol_start and symbol_end *) - let token_start, token_end = + let token_start, token_end = try Parsing.symbol_start (), Parsing.symbol_end () - with e -> begin + with e -> begin ignore (warn "Parsing raised %s\n" (Printexc.to_string e)); 0, 0 end in let i = !current in - let adjStart = + let adjStart = if token_start < i.linestart then 0 else token_start - i.linestart in - let adjEnd = + let adjEnd = if token_end < i.linestart then 0 else token_end - i.linestart in - output_string + output_string stderr - (i.fileName ^ "[" ^ (string_of_int i.linenum) ^ ":" - ^ (string_of_int adjStart) ^ "-" - ^ (string_of_int adjEnd) + (i.fileName ^ "[" ^ (string_of_int i.linenum) ^ ":" + ^ (string_of_int adjStart) ^ "-" + ^ (string_of_int adjEnd) ^ "]" ^ " : " ^ msg); output_string stderr "\n"; @@ -321,7 +322,7 @@ let parse_error (msg: string) : 'a = i.num_errors <- i.num_errors + 1; if i.num_errors > max_errors then begin output_string stderr "Too many errors. Aborting.\n" ; - exit 1 + exit 1 end; hadErrors := true; raise Parsing.Parse_error @@ -330,34 +331,33 @@ let parse_error (msg: string) : 'a = (* More parsing support functions: line, file, char count *) -let getPosition () : int * string * int = - let i = !current in +let getPosition () : int * string * int = + let i = !current in i.linenum, i.fileName, Lexing.lexeme_start i.lexbuf -let getHPosition () = +let getHPosition () = !current.hline, !current.hfile (** Type for source-file locations *) -type location = +type location = { file: string; (** The file name *) line: int; (** The line number *) hfile: string; (** The high-level file name, or "" if not present *) hline: int; (** The high-level line number, or 0 if not present *) - } + } -let d_loc () l = +let d_loc () l = text (l.file ^ ":" ^ string_of_int l.line) - -let d_hloc () (l: location) = + +let d_hloc () (l: location) = dprintf "%s:%d%a" l.file l.line insert (if l.hline > 0 then dprintf " (%s:%d)" l.hfile l.hline else nil) let locUnknown = { file = ""; hfile = ""; line = -1; hline = -1 } -let getLocation () = +let getLocation () = let hl, hf = getHPosition () in let l, f, c = getPosition () in { hfile = hf; hline = hl; - file = f; line = l } - + file = f; line = l } diff --git a/src/ocamlutil/inthash.ml b/src/ocamlutil/inthash.ml index 8d5bd32af..2f95c2576 100644 --- a/src/ocamlutil/inthash.ml +++ b/src/ocamlutil/inthash.ml @@ -23,7 +23,7 @@ let copy h = { size = h.size; data = Array.copy h.data } -let copy_into src dest = +let copy_into src dest = dest.size <- src.size; dest.data <- Array.copy src.data @@ -34,7 +34,7 @@ let resize tbl = let osize = Array.length odata in let nsize = min (2 * osize + 1) Sys.max_array_length in if nsize <> osize then begin - let ndata = Array.create nsize Empty in + let ndata = Array.make nsize Empty in let rec insert_bucket = function Empty -> () | Cons(key, data, rest) -> @@ -71,7 +71,7 @@ let remove_all h key = Empty | Cons(k, i, next) -> if k = key - then begin h.size <- pred h.size; + then begin h.size <- pred h.size; remove_bucket next end else Cons(k, i, remove_bucket next) in let i = (hash key) mod (Array.length h.data) in @@ -160,7 +160,7 @@ let fold (f: int -> 'a -> 'b -> 'b) (h: 'a t) (init: 'b) = !accu -let memoize (h: 'a t) (key: int) (f: int -> 'a) : 'a = +let memoize (h: 'a t) (key: int) (f: int -> 'a) : 'a = let i = (hash key) mod (Array.length h.data) in let rec find_rec key = function Empty -> addit () @@ -175,10 +175,10 @@ let memoize (h: 'a t) (key: int) (f: int -> 'a) : 'a = | Cons(k2, d2, rest2) -> if key = k2 then d2 else match rest2 with - Empty -> addit () + Empty -> addit () | Cons(k3, d3, rest3) -> if key = k3 then d3 else find_rec key rest3 - and addit () = + and addit () = let it = f key in h.data.(i) <- Cons(key, it, h.data.(i)); h.size <- succ h.size; @@ -186,7 +186,7 @@ let memoize (h: 'a t) (key: int) (f: int -> 'a) : 'a = it in find_in_bucket key h.data.(i) - - -let tolist (h: 'a t) : (int * 'a) list = + + +let tolist (h: 'a t) : (int * 'a) list = fold (fun k d acc -> (k, d) :: acc) h [] diff --git a/src/ocamlutil/longarray.ml b/src/ocamlutil/longarray.ml index ed9f533b1..2c5d5b590 100644 --- a/src/ocamlutil/longarray.ml +++ b/src/ocamlutil/longarray.ml @@ -24,7 +24,7 @@ let split_idx (idx: int) : int option = let rec create (len: int) (init: 'a) : 'a t = let len1, len2 = split_len len in - (Array.create len1 init) :: (if len2 > 0 then create len2 init else []) + (Array.make len1 init) :: (if len2 > 0 then create len2 init else []) let rec init (len: int) (fn: int -> 'a) : 'a t = let len1, len2 = split_len len in @@ -40,7 +40,7 @@ let rec blit (src: 'a t) (srcidx: int) Array.blit (List.hd src) 0 (List.hd dst) 0 len1; if len2 > 0 then blit (List.tl src) 0 (List.tl dst) 0 len2 - with Failure ("hd" | "tl") -> + with Failure _ -> raise (Invalid_argument "Longarray.blit") let rec fill (a: 'a t) (idx: int) (len: int) (elt: 'a) : unit = @@ -53,7 +53,7 @@ let rec fill (a: 'a t) (idx: int) (len: int) (elt: 'a) : unit = fill (List.tl a) 0 end2 elt | Some idx' -> fill (List.tl a) idx' len elt - with Failure ("hd" | "tl") -> + with Failure _ -> raise (Invalid_argument "Longarray.fill") let rec length (a: 'a t) : int = @@ -66,7 +66,7 @@ let rec get (a: 'a t) (i: int) : 'a = match split_idx i with | None -> Array.get (List.hd a) i | Some i' -> get (List.tl a) i' - with Failure ("hd" | "tl") -> + with Failure _ -> raise (Invalid_argument "(get) index out of bounds") let rec set (a: 'a t) (i: int) (elt: 'a) : unit = @@ -74,7 +74,7 @@ let rec set (a: 'a t) (i: int) (elt: 'a) : unit = match split_idx i with | None -> Array.set (List.hd a) i elt | Some i' -> set (List.tl a) i' elt - with Failure ("hd" | "tl") -> + with Failure _ -> raise (Invalid_argument "(set) index out of bounds") let rec copy (a: 'a t) : 'a t = @@ -90,7 +90,7 @@ let rec map (fn: 'a -> 'b) (a: 'a t) : 'b t = let docArray ?(sep = chr ',') (doit: int -> 'a -> doc) () (elements: 'a t) = let len = length elements in - if len = 0 then + if len = 0 then nil else let rec loop (acc: doc) i = diff --git a/src/ocamlutil/pretty.ml b/src/ocamlutil/pretty.ml index 41180974f..27c6b642e 100644 --- a/src/ocamlutil/pretty.ml +++ b/src/ocamlutil/pretty.ml @@ -1,11 +1,11 @@ -(* +(* * - * Copyright (c) 2001-2002, + * 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: @@ -36,9 +36,9 @@ *) (******************************************************************************) -(* Pretty printer - This module contains several fast, but sub-optimal heuristics to pretty-print - structured text. +(* Pretty printer + This module contains several fast, but sub-optimal heuristics to pretty-print + structured text. *) let debug = false @@ -49,31 +49,31 @@ let algo = George let fastMode = ref false -(** Whether to print identation or not (for faster printing and smaller +(** Whether to print indentation or not (for faster printing and smaller * output) *) let printIndent = ref true (** Whether to rebalance doc before printing it to avoid stack-overflows *) let flattenBeforePrint = ref true -(******************************************************************************) +(******************************************************************************) (* The doc type and constructors *) -type doc = +type doc = Nil | Text of string | Concat of doc * doc | CText of doc * string | Break - | Line + | Line | LeftFlush | Align - | Unalign + | Unalign | Mark | Unmark (* Break a string at \n *) -let rec breakString (acc: doc) (str: string) : doc = +let rec breakString (acc: doc) (str: string) : doc = (* Printf.printf "breaking string %s\n" str; *) match (try Some (String.index str '\n') with Not_found -> None) with | None -> if acc = Nil then Text str else CText (acc, str) @@ -93,19 +93,19 @@ let rec breakString (acc: doc) (str: string) : doc = end else (* The first is a newline *) breakString (Concat(acc, Line)) (String.sub str (r + 1) (len - r - 1)) - + let nil = Nil let text s = breakString nil s let num i = text (string_of_int i) let num64 i = text (Int64.to_string i) let real f = text (string_of_float f) -let chr c = text (String.make 1 c) +let chr c = text (String.make 1 c) let align = Align let unalign = Unalign let line = Line let leftflush = LeftFlush -let break = Break +let break = Break let mark = Mark let unmark = Unmark @@ -116,9 +116,9 @@ let d_int64 (i: int64) = text (Int64.to_string i) let f_int64 () i = d_int64 i -(* Note that the ++ operator in Ocaml are left-associative. This means - * that if you have a long list of ++ then the whole thing is very unbalanced - * towards the left side. This is the worst possible case since scanning the +(* Note that the ++ operator in Ocaml are left-associative. This means + * that if you have a long list of ++ then the whole thing is very unbalanced + * towards the left side. This is the worst possible case since scanning the * left side of a Concat is the non-tail recursive case. *) let (++) d1 d2 = Concat (d1, d2) @@ -130,22 +130,22 @@ let indent n d = text (String.make n ' ') ++ (align ++ (d ++ unalign)) let markup d = mark ++ d ++ unmark (* Format a sequence. The first argument is a separator *) -let seq ~(sep:doc) ~(doit:'a -> doc) ~(elements: 'a list) = +let seq ~(sep:doc) ~(doit:'a -> doc) ~(elements: 'a list) = let rec loop (acc: doc) = function [] -> acc - | h :: t -> + | h :: t -> let fh = doit h in (* Make sure this is done first *) loop (acc ++ sep ++ fh) t in (match elements with [] -> nil - | h :: t -> + | h :: t -> let fh = doit h in loop fh t) -let docArray ?(sep=chr ',') (doit:int -> 'a -> doc) () (elements:'a array) = +let docArray ?(sep=chr ',') (doit:int -> 'a -> doc) () (elements:'a array) = let len = Array.length elements in - if len = 0 then + if len = 0 then nil else let rec loop (acc: doc) i = @@ -162,8 +162,8 @@ let docOpt delem () = function -let docList ?(sep=chr ',') (doit:'a -> doc) () (elements:'a list) = - seq sep doit elements +let docList ?(sep=chr ',') (doit:'a -> doc) () (elements:'a list) = + seq ~sep:sep ~doit:doit ~elements:elements let insert () d = d @@ -176,7 +176,7 @@ let d_list (sep:string) (doit:unit -> 'a -> doc) () (elts:'a list) : doc = (** Format maps *) module MakeMapPrinter = - functor (Map: sig + functor (Map: sig type key type 'a t val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b @@ -200,7 +200,7 @@ end (** Format sets *) module MakeSetPrinter = - functor (Set: sig + functor (Set: sig type elt type t val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a @@ -219,7 +219,7 @@ struct end -(******************************************************************************) +(******************************************************************************) (* Some debugging stuff *) let dbgprintf x = Printf.fprintf stderr x @@ -227,10 +227,10 @@ let dbgprintf x = Printf.fprintf stderr x let rec dbgPrintDoc = function Nil -> dbgprintf "(Nil)" | Text s -> dbgprintf "(Text %s)" s - | Concat (d1,d2) -> dbgprintf ""; dbgPrintDoc d1; dbgprintf " ++\n "; + | Concat (d1,d2) -> dbgprintf ""; dbgPrintDoc d1; dbgprintf " ++\n "; dbgPrintDoc d2; dbgprintf "" - | CText (d,s) -> dbgPrintDoc d; dbgprintf " ++ \"%s\"" s; - | Break -> dbgprintf "(Break)" + | CText (d,s) -> dbgPrintDoc d; dbgprintf " ++ \"%s\"" s; + | Break -> dbgprintf "(Break)" | Line -> dbgprintf "(Line)" | LeftFlush -> dbgprintf "(LeftFlush)" | Align -> dbgprintf "(Align)" @@ -238,13 +238,13 @@ let rec dbgPrintDoc = function | Mark -> dbgprintf "(Mark)" | Unmark -> dbgprintf "(Unmark)" -(******************************************************************************) +(******************************************************************************) (* The "george" algorithm *) -(* When we construct documents, most of the time they are heavily unbalanced - * towards the left. This is due to the left-associativity of ++ and also to - * the fact that constructors such as docList construct from the let of a - * sequence. We would prefer to shift the imbalance to the right to avoid +(* When we construct documents, most of the time they are heavily unbalanced + * towards the left. This is due to the left-associativity of ++ and also to + * the fact that constructors such as docList construct from the let of a + * sequence. We would prefer to shift the imbalance to the right to avoid * consuming a lot of stack when we traverse the document *) let rec flatten (acc: doc) = function | Concat (d1, d2) -> flatten (flatten acc d2) d1 @@ -253,55 +253,55 @@ let rec flatten (acc: doc) = function | d -> Concat(d, acc) (* We keep a stack of active aligns. *) -type align = - { mutable gainBreak: int; (* This is the gain that is associated with - * taking the break associated with this - * alignment mark. If this is 0, then there +type align = + { mutable gainBreak: int; (* This is the gain that is associated with + * taking the break associated with this + * alignment mark. If this is 0, then there * is no break associated with the mark *) - mutable isTaken: bool ref; (* If breakGain is > 0 then this is a ref - * cell that must be set to true when the - * break is taken. These ref cells are also + mutable isTaken: bool ref; (* If breakGain is > 0 then this is a ref + * cell that must be set to true when the + * break is taken. These ref cells are also * int the "breaks" list *) - deltaFromPrev: int ref; (* The column of this alignment mark - - * the column of the previous mark. - * Shared with the deltaToNext of the + deltaFromPrev: int ref; (* The column of this alignment mark - + * the column of the previous mark. + * Shared with the deltaToNext of the * previous active align *) - deltaToNext: int ref (* The column of the next alignment mark - - * the columns of this one. Shared with + deltaToNext: int ref (* The column of the next alignment mark - + * the columns of this one. Shared with * deltaFromPrev of the next active align *) - } - + } + (* We use references to avoid the need to pass data around all the time *) -let aligns: align list ref = (* The current stack of active alignment marks, +let aligns: align list ref = (* The current stack of active alignment marks, * with the top at the head. Never empty. *) - ref [{ gainBreak = 0; isTaken = ref false; + ref [{ gainBreak = 0; isTaken = ref false; deltaFromPrev = ref 0; deltaToNext = ref 0; }] let topAlignAbsCol = ref 0 (* The absolute column of the top alignment *) -let pushAlign (abscol: int) = +let pushAlign (abscol: int) = let topalign = List.hd !aligns in - let res = - { gainBreak = 0; isTaken = ref false; + let res = + { gainBreak = 0; isTaken = ref false; deltaFromPrev = topalign.deltaToNext; (* Share with the previous *) deltaToNext = ref 0; (* Allocate a new ref *)} in aligns := res :: !aligns; res.deltaFromPrev := abscol - !topAlignAbsCol; topAlignAbsCol := abscol -let popAlign () = +let popAlign () = match !aligns with - top :: t when t != [] -> - aligns := t; + top :: t when t != [] -> + aligns := t; topAlignAbsCol := !topAlignAbsCol - !(top.deltaFromPrev) | _ -> failwith "Unmatched unalign\n" -(** We keep a list of active markup sections. For each one we keep the column +(** We keep a list of active markup sections. For each one we keep the column * we are in *) let activeMarkups: int list ref = ref [] -(* Keep a list of ref cells for the breaks, in the same order that we see +(* Keep a list of ref cells for the breaks, in the same order that we see * them in the document *) let breaks: bool ref list ref = ref [] @@ -317,20 +317,20 @@ let newline () = if debug then dbgprintf "Taking a newline: reseting gain of %d\n" topalign.gainBreak; topalign.gainBreak <- 0; (* Erase the current break info *) - if !breakAllMode && !topAlignAbsCol < !maxCol then + if !breakAllMode && !topAlignAbsCol < !maxCol then breakAllMode := false; !topAlignAbsCol (* This is the new column *) -(* Choose the align with the best gain. We outght to find a better way to - * keep the aligns sorted, especially since they gain never changes (when the +(* Choose the align with the best gain. We ought to find a better way to + * keep the aligns sorted, especially since they gain never changes (when the * align is the top align) *) -let chooseBestGain () : align option = +let chooseBestGain () : align option = let bestGain = ref 0 in let rec loop (breakingAlign: align option) = function [] -> breakingAlign - | a :: resta -> + | a :: resta -> if debug then dbgprintf "Looking at align with gain %d\n" a.gainBreak; if a.gainBreak > !bestGain then begin bestGain := a.gainBreak; @@ -342,28 +342,28 @@ let chooseBestGain () : align option = (* Another one that chooses the break associated with the current align only *) -let chooseLastGain () : align option = +let chooseLastGain () : align option = let topalign = List.hd !aligns in if topalign.gainBreak > 0 then Some topalign else None (* We have just advanced to a new column. See if we must take a line break *) -let movingRight (abscol: int) : int = - (* Keep taking the best break until we get back to the left of maxCol or no +let movingRight (abscol: int) : int = + (* Keep taking the best break until we get back to the left of maxCol or no * more are left *) - let rec tryAgain abscol = - if abscol <= !maxCol then abscol else + let rec tryAgain abscol = + if abscol <= !maxCol then abscol else begin if debug then dbgprintf "Looking for a break to take in column %d\n" abscol; (* Find the best gain there is out there *) - match if !fastMode then None else chooseBestGain () with + match if !fastMode then None else chooseBestGain () with None -> begin (* No breaks are available. Take all breaks from now on *) breakAllMode := true; if debug then dbgprintf "Can't find any breaks\n"; abscol - end + end | Some breakingAlign -> begin let topalign = List.hd !aligns in let theGain = breakingAlign.gainBreak in @@ -372,7 +372,7 @@ let movingRight (abscol: int) : int = breakingAlign.isTaken := true; breakingAlign.gainBreak <- 0; if breakingAlign != topalign then begin - breakingAlign.deltaToNext := + breakingAlign.deltaToNext := !(breakingAlign.deltaToNext) - theGain; topAlignAbsCol := !topAlignAbsCol - theGain end; @@ -383,68 +383,68 @@ let movingRight (abscol: int) : int = tryAgain abscol -(* Keep track of nested align in gprintf. Each gprintf format string must - * have properly nested align/unalign pairs. When the nesting depth surpasses +(* Keep track of nested align in gprintf. Each gprintf format string must + * have properly nested align/unalign pairs. When the nesting depth surpasses * !printDepth then we print ... and we skip until the matching unalign *) let printDepth = ref 10000000 (* WRW: must see whole thing *) let alignDepth = ref 0 let useAlignDepth = true -(** Start an align. Return true if we ahve just passed the threshhold *) -let enterAlign () = +(** Start an align. Return true if we have just passed the threshhold *) +let enterAlign () = incr alignDepth; useAlignDepth && !alignDepth = !printDepth + 1 (** Exit an align *) -let exitAlign () = +let exitAlign () = decr alignDepth -(** See if we are at a low-enough align level (and we should be printing +(** See if we are at a low-enough align level (and we should be printing * normally) *) -let shallowAlign () = +let shallowAlign () = not useAlignDepth || !alignDepth <= !printDepth (* Pass the current absolute column and compute the new column *) -let rec scan (abscol: int) (d: doc) : int = - match d with +let rec scan (abscol: int) (d: doc) : int = + match d with Nil -> abscol | Concat (d1, d2) -> scan (scan abscol d1) d2 - | Text s when shallowAlign () -> - let sl = String.length s in - if debug then + | Text s when shallowAlign () -> + let sl = String.length s in + if debug then dbgprintf "Done string: %s from %d to %d\n" s abscol (abscol + sl); movingRight (abscol + sl) - | CText (d, s) -> + | CText (d, s) -> let abscol' = scan abscol d in if shallowAlign () then begin - let sl = String.length s in - if debug then + let sl = String.length s in + if debug then dbgprintf "Done string: %s from %d to %d\n" s abscol' (abscol' + sl); movingRight (abscol' + sl) end else abscol' - | Align -> - pushAlign abscol; - if enterAlign () then + | Align -> + pushAlign abscol; + if enterAlign () then movingRight (abscol + 3) (* "..." *) else abscol - | Unalign -> exitAlign (); popAlign (); abscol + | Unalign -> exitAlign (); popAlign (); abscol - | Line when shallowAlign () -> (* A forced line break *) - if !activeMarkups != [] then + | Line when shallowAlign () -> (* A forced line break *) + if !activeMarkups != [] then failwith "Line breaks inside markup sections"; newline () | LeftFlush when shallowAlign () -> (* Keep cursor left-flushed *) 0 - | Break when shallowAlign () -> (* An optional line break. Always a space + | Break when shallowAlign () -> (* An optional line break. Always a space * followed by an optional line break *) - if !activeMarkups != [] then + if !activeMarkups != [] then failwith "Line breaks inside markup sections"; let takenref = ref false in breaks := takenref :: !breaks; @@ -453,12 +453,12 @@ let rec scan (abscol: int) (d: doc) : int = takenref := true; newline () end else begin - (* If there was a previous break there it stays not taken, forever. + (* If there was a previous break there it stays not taken, forever. * So we overwrite it. *) topalign.isTaken <- takenref; topalign.gainBreak <- 1 + abscol - !topAlignAbsCol; if debug then - dbgprintf "Registering a break at %d with gain %d\n" + dbgprintf "Registering a break at %d with gain %d\n" (1 + abscol) topalign.gainBreak; movingRight (1 + abscol) end @@ -467,29 +467,29 @@ let rec scan (abscol: int) (d: doc) : int = abscol | Unmark -> begin - match !activeMarkups with - old :: rest -> activeMarkups := rest; + match !activeMarkups with + old :: rest -> activeMarkups := rest; old | [] -> failwith "Too many unmark" end | _ -> (* Align level is too deep *) abscol - -(** Keep a running counter of the newlines we are taking. You can read and + +(** Keep a running counter of the newlines we are taking. You can read and * reset this from user code, if you want *) let countNewLines = ref 0 (* The actual function that takes a document and prints it *) -let emitDoc - (emitString: string -> int -> unit) (* emit a number of copies of a +let emitDoc + (emitString: string -> int -> unit) (* emit a number of copies of a * string *) - (d: doc) = + (d: doc) = let aligns: int list ref = ref [0] in (* A stack of alignment columns *) let wantIndent = ref false in (* Use this function to take a newline *) - (* AB: modified it to flag wantIndent. The actual indentation is done only + (* AB: modified it to flag wantIndent. The actual indentation is done only if leftflush is not encountered *) let newline () = match !aligns with @@ -505,37 +505,37 @@ let emitDoc if !printIndent && !wantIndent then ignore ( match !aligns with [] -> failwith "Ran out of aligns" - | x :: _ -> + | x :: _ -> if x > 0 then emitString " " x; x); - wantIndent := false + wantIndent := false in (* A continuation passing style loop *) - let rec loopCont (abscol: int) (d: doc) (cont: int -> unit) : unit + let rec loopCont (abscol: int) (d: doc) (cont: int -> unit) : unit (* the new column *) = match d with Nil -> cont abscol - | Concat (d1, d2) -> + | Concat (d1, d2) -> loopCont abscol d1 (fun abscol' -> loopCont abscol' d2 cont) - | Text s when shallowAlign () -> + | Text s when shallowAlign () -> let sl = String.length s in indentIfNeeded (); emitString s 1; cont (abscol + sl) - | CText (d, s) -> - loopCont abscol d - (fun abscol' -> - if shallowAlign () then + | CText (d, s) -> + loopCont abscol d + (fun abscol' -> + if shallowAlign () then let sl = String.length s in indentIfNeeded (); - emitString s 1; + emitString s 1; cont (abscol' + sl) else cont abscol') - | Align -> + | Align -> aligns := abscol :: !aligns; if enterAlign () then begin indentIfNeeded (); @@ -547,7 +547,7 @@ let emitDoc | Unalign -> begin match !aligns with [] -> failwith "Unmatched unalign" - | _ :: rest -> + | _ :: rest -> exitAlign (); aligns := rest; cont abscol end @@ -556,23 +556,23 @@ let emitDoc | Break when shallowAlign () -> begin match !breaks with [] -> failwith "Break without a takenref" - | istaken :: rest -> + | istaken :: rest -> breaks := rest; (* Consume the break *) if !istaken then cont (newline ()) else begin indentIfNeeded (); - emitString " " 1; + emitString " " 1; cont (abscol + 1) end end - | Mark -> + | Mark -> activeMarkups := abscol :: !activeMarkups; cont abscol | Unmark -> begin - match !activeMarkups with - old :: rest -> activeMarkups := rest; + match !activeMarkups with + old :: rest -> activeMarkups := rest; cont old | [] -> failwith "Unmark without a mark" end @@ -581,7 +581,7 @@ let emitDoc cont abscol in - loopCont 0 d (fun x -> ()) + loopCont 0 d (fun x -> ()) (* Print a document on a channel *) @@ -589,34 +589,34 @@ let fprint (chn: out_channel) ~(width: int) doc = let doc = if !flattenBeforePrint then flatten Nil doc else doc in (* Save some parameters, to allow for nested calls of these routines. *) maxCol := width; - let old_breaks = !breaks in + let old_breaks = !breaks in breaks := []; - let old_alignDepth = !alignDepth in + let old_alignDepth = !alignDepth in alignDepth := 0; - let old_activeMarkups = !activeMarkups in + let old_activeMarkups = !activeMarkups in activeMarkups := []; ignore (scan 0 doc); breaks := List.rev !breaks; - ignore (emitDoc - (fun s nrcopies -> - for i = 1 to nrcopies do + ignore (emitDoc + (fun s nrcopies -> + for _ = 1 to nrcopies do output_string chn s done) doc); activeMarkups := old_activeMarkups; alignDepth := old_alignDepth; - breaks := old_breaks (* We must do this especially if we don't do emit - * (which consumes breaks) because otherwise we waste + breaks := old_breaks (* We must do this especially if we don't do emit + * (which consumes breaks) because otherwise we waste * memory *) (* Print the document to a string *) -let sprint ~(width : int) doc : string = +let sprint ~(width : int) doc : string = let doc = if !flattenBeforePrint then flatten Nil doc else doc in maxCol := width; - let old_breaks = !breaks in + let old_breaks = !breaks in breaks := []; - let old_activeMarkups = !activeMarkups in + let old_activeMarkups = !activeMarkups in activeMarkups := []; - let old_alignDepth = !alignDepth in + let old_alignDepth = !alignDepth in alignDepth := 0; ignore (scan 0 doc); breaks := List.rev !breaks; @@ -637,22 +637,22 @@ external format_int: string -> int -> string = "caml_format_int" external format_float: string -> float -> string = "caml_format_float" - -let gprintf (finish : doc -> 'b) + +let gprintf (finish : doc -> 'b) (format : ('a, unit, doc, 'b) format4) : 'a = let format = string_of_format format in (* Record the starting align depth *) let startAlignDepth = !alignDepth in (* Special concatenation functions *) - let dconcat (acc: doc) (another: doc) = + let dconcat (acc: doc) (another: doc) = if !alignDepth > !printDepth then acc else acc ++ another in - let dctext1 (acc: doc) (str: string) = - if !alignDepth > !printDepth then acc else + let dctext1 (acc: doc) (str: string) = + if !alignDepth > !printDepth then acc else CText(acc, str) in (* Special finish function *) - let dfinish (dc: doc) : 'b = + let dfinish (dc: doc) : 'b = if !alignDepth <> startAlignDepth then prerr_string ("Unmatched align/unalign in " ^ format ^ "\n"); finish dc @@ -660,16 +660,16 @@ let gprintf (finish : doc -> 'b) let flen = String.length format in (* Reading a format character *) let fget = String.unsafe_get format in - (* Output a literal sequence of - * characters, starting at i. The - * character at i does not need to be - * checked. *) - let rec literal acc i = - let rec skipChars j = - if j >= flen || - (match fget j with - '%' -> true - | '@' -> true + (* Output a literal sequence of + * characters, starting at i. The + * character at i does not need to be + * checked. *) + let rec literal acc i = + let rec skipChars j = + if j >= flen || + (match fget j with + '%' -> true + | '@' -> true | '\n' -> true | _ -> false) then collect (dctext1 acc (String.sub format i (j-i))) j @@ -678,19 +678,19 @@ let gprintf (finish : doc -> 'b) in skipChars (succ i) (* the main collection function *) - and collect (acc: doc) (i: int) = + and collect (acc: doc) (i: int) = if i >= flen then begin - Obj.magic (dfinish acc) + Obj.magic (dfinish acc) end else begin let c = fget i in if c = '%' then begin let j = skip_args (succ i) in match fget j with - '%' -> literal acc j + '%' -> literal acc j | ',' -> collect acc (succ j) | 's' -> Obj.magic(fun s -> - let str = + let str = if j <= i+1 then s else @@ -714,7 +714,7 @@ let gprintf (finish : doc -> 'b) | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' -> Obj.magic(fun n -> collect (dctext1 acc - (format_int (String.sub format i + (format_int (String.sub format i (j-i+1)) n)) (succ j)) (* L, l, and n are the Int64, Int32, and Nativeint modifiers to the integer @@ -722,34 +722,34 @@ let gprintf (finish : doc -> 'b) | 'L' -> if j != i + 1 then (*Int64.format handles simple formats like %d. * Any special flags eaten by skip_args will confuse it. *) - invalid_arg ("dprintf: unimplemented format " + invalid_arg ("dprintf: unimplemented format " ^ (String.sub format i (j-i+1))); let j' = succ j in (* eat the d,i,x etc. *) - let format_spec = "% " in - String.set format_spec 1 (fget j'); (* format_spec = "%x", etc. *) + let format_spec = Bytes.of_string "% " in + Bytes.set format_spec 1 (fget j'); (* format_spec = "%x", etc. *) Obj.magic(fun n -> collect (dctext1 acc - (Int64.format format_spec n)) + (Int64.format (Bytes.to_string format_spec) n)) (succ j')) | 'l' -> - if j != i + 1 then invalid_arg ("dprintf: unimplemented format " + if j != i + 1 then invalid_arg ("dprintf: unimplemented format " ^ (String.sub format i (j-i+1))); let j' = succ j in (* eat the d,i,x etc. *) - let format_spec = "% " in - String.set format_spec 1 (fget j'); (* format_spec = "%x", etc. *) + let format_spec = Bytes.of_string "% " in + Bytes.set format_spec 1 (fget j'); (* format_spec = "%x", etc. *) Obj.magic(fun n -> collect (dctext1 acc - (Int32.format format_spec n)) + (Int32.format (Bytes.to_string format_spec) n)) (succ j')) | 'n' -> - if j != i + 1 then invalid_arg ("dprintf: unimplemented format " + if j != i + 1 then invalid_arg ("dprintf: unimplemented format " ^ (String.sub format i (j-i+1))); let j' = succ j in (* eat the d,i,x etc. *) - let format_spec = "% " in - String.set format_spec 1 (fget j'); (* format_spec = "%x", etc. *) + let format_spec = Bytes.of_string "% " in + Bytes.set format_spec 1 (fget j'); (* format_spec = "%x", etc. *) Obj.magic(fun n -> collect (dctext1 acc - (Nativeint.format format_spec n)) + (Nativeint.format (Bytes.to_string format_spec) n)) (succ j')) | 'f' | 'e' | 'E' | 'g' | 'G' -> Obj.magic(fun f -> @@ -774,7 +774,7 @@ let gprintf (finish : doc -> 'b) (* Now the special format characters *) '[' -> (* align *) - let newacc = + let newacc = if !alignDepth > !printDepth then acc else if !alignDepth = !printDepth then @@ -784,10 +784,10 @@ let gprintf (finish : doc -> 'b) in incr alignDepth; collect newacc (i + 2) - + | ']' -> (* unalign *) decr alignDepth; - let newacc = + let newacc = if !alignDepth >= !printDepth then acc else @@ -798,13 +798,13 @@ let gprintf (finish : doc -> 'b) collect (dconcat acc line) (i + 2) | '?' -> (* soft line break *) collect (dconcat acc (break)) (i + 2) - | '<' -> + | '<' -> collect (dconcat acc mark) (i +1) - | '>' -> + | '>' -> collect (dconcat acc unmark) (i +1) | '^' -> (* left-flushed *) collect (dconcat acc (leftflush)) (i + 2) - | '@' -> + | '@' -> collect (dctext1 acc "@") (i + 2) | c -> invalid_arg ("dprintf: unknown format @" ^ String.make 1 c) @@ -824,7 +824,7 @@ let gprintf (finish : doc -> 'b) in collect Nil 0 -let withPrintDepth dp thunk = +let withPrintDepth dp thunk = let opd = !printDepth in printDepth := dp; thunk (); @@ -835,12 +835,12 @@ let withPrintDepth dp thunk = let flushOften = ref false let dprintf format = gprintf (fun x -> x) format -let fprintf chn format = - let f d = fprint chn 80 d; d in +let fprintf chn format = + let f d = fprint chn ~width:80 d; d in (* weimeric hack begins -- flush output to streams *) let res = gprintf f format in - (* save the value we would have returned, flush the channel and then - * return it -- this allows us to see debug input near infinite loops + (* save the value we would have returned, flush the channel and then + * return it -- this allows us to see debug input near infinite loops * *) if !flushOften then flush chn; res @@ -862,5 +862,5 @@ let getAboutString () : string = (************************************************) -let auto_printer (typ: string) = +let auto_printer (typ: string) = failwith ("Pretty.auto_printer \"" ^ typ ^ "\" only works with you use -pp \"camlp4o pa_prtype.cmo\" when you compile") diff --git a/src/ocamlutil/stats.ml b/src/ocamlutil/stats.ml index 9e5110d18..6809fe300 100644 --- a/src/ocamlutil/stats.ml +++ b/src/ocamlutil/stats.ml @@ -21,27 +21,27 @@ let top = { name = "TOTAL"; ncalls = 0; sub = []; } - (* The stack of current path through - * the hierarchy. The first is the + (* The stack of current path through + * the hierarchy. The first is the * leaf. *) let current : t list ref = ref [top] exception NoPerfCount -let reset (mode: timerModeEnum) : unit = +let reset (mode: timerModeEnum) : unit = top.sub <- []; timerMode := mode -let print chn msg = +let print chn msg = (* Total up *) top.time <- List.fold_left (fun sum f -> sum +. f.time) 0.0 top.sub; - let rec prTree ind node = - (Printf.fprintf chn "%s%-25s %6.3f s" + let rec prTree ind node = + (Printf.fprintf chn "%s%-25s %6.3f s" (String.make ind ' ') node.name node.time); begin if node.ncalls <= 0 then - output_string chn "\n" + output_string chn "\n" else if node.ncalls = 1 then output_string chn " (1 call)\n" else @@ -49,17 +49,17 @@ let print chn msg = end; List.iter (prTree (ind + 2)) (List.rev node.sub) in - Printf.fprintf chn "%s" msg; + Printf.fprintf chn "%s" msg; List.iter (prTree 0) [ top ]; Printf.fprintf chn "Timing used\n"; - let gc = Gc.quick_stat () in - let printM (w: float) : string = + let gc = Gc.quick_stat () in + let printM (w: float) : string = let coeff = float_of_int (Sys.word_size / 8) in Printf.sprintf "%.2fMB" (w *. coeff /. 1000000.0) in - Printf.fprintf chn + Printf.fprintf chn "Memory statistics: total=%s, max=%s, minor=%s, major=%s, promoted=%s\n minor collections=%d major collections=%d compactions=%d\n" - (printM (gc.Gc.minor_words +. gc.Gc.major_words + (printM (gc.Gc.minor_words +. gc.Gc.major_words -. gc.Gc.promoted_words)) (printM (float_of_int gc.Gc.top_heap_words)) (printM gc.Gc.minor_words) @@ -68,23 +68,23 @@ let print chn msg = gc.Gc.minor_collections gc.Gc.major_collections gc.Gc.compactions; - + () - - + + (* Get the current time, in seconds *) -let get_current_time () : float = +let get_current_time () : float = (Unix.times ()).Unix.tms_utime -let repeattime limit str f arg = +let repeattime limit str f arg = (* Find the right stat *) - let stat : t = + let stat : t = let curr = match !current with h :: _ -> h | [] -> assert false in let rec loop = function h :: _ when h.name = str -> h | _ :: rest -> loop rest - | [] -> + | [] -> let nw = {name = str; time = 0.0; ncalls = 0; sub = []} in curr.sub <- nw :: curr.sub; nw @@ -94,7 +94,7 @@ let repeattime limit str f arg = let oldcurrent = !current in current := stat :: oldcurrent; let start = get_current_time () in - let rec repeatf count = + let rec repeatf count = let finish diff = (* count each call to repeattime once *) if !countCalls then stat.ncalls <- stat.ncalls + 1; @@ -125,35 +125,24 @@ let time str f arg = f arg else repeattime 0.0 str f arg - + let lastTime = ref 0.0 -let timethis (f: 'a -> 'b) (arg: 'a) : 'b = +let timethis (f: 'a -> 'b) (arg: 'a) : 'b = let start = get_current_time () in - let res = f arg in - lastTime := get_current_time () -. start; + let res = f arg in + lastTime := get_current_time () -. start; res - + (** Return the cumulative time of all calls to {!Stats.time} and {!Stats.repeattime} with the given label. *) -(* Usually there will be only one occurence in the tree, but summing them all +(* Usually there will be only one occurrence in the tree, but summing them all makes more sense than choosing one arbitrarily *) let lookupTime (label:string) : float = let time : float ref = ref 0.0 in - let rec search (x:t) : unit = + let rec search (x:t) : unit = if x.name = label then time := !time +. x.time; List.iter search x.sub in search top; !time - - - - - - - - - - - diff --git a/src/ocamlutil/trace.ml b/src/ocamlutil/trace.ml index b42928657..936dd1da2 100644 --- a/src/ocamlutil/trace.ml +++ b/src/ocamlutil/trace.ml @@ -1,11 +1,11 @@ (* * - * Copyright (c) 2001-2002, + * 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: @@ -62,9 +62,9 @@ let traceActive (subsys : string) : bool = let rec parseString (str : string) (delim : char) : string list = begin - if (not (String.contains str delim)) then + if (not (String.contains str delim)) then if ((String.length str) = 0) then - [] + [] else [str] @@ -131,7 +131,7 @@ let trace (* see if the subsystem's tracing is turned on *) if (traceActive subsys) then begin - (fprint stderr 80 (* print it *) + (fprint stderr ~width:80 (* print it *) ((traceTag subsys) ++ d)); (* with prepended subsys tag *) (* mb: flush after every message; useful if the program hangs in an infinite loop... *) diff --git a/src/rmtmps.ml b/src/rmtmps.ml index 2034623e6..630a452d1 100644 --- a/src/rmtmps.ml +++ b/src/rmtmps.ml @@ -1,12 +1,12 @@ (* * - * Copyright (c) 2001-2002, + * Copyright (c) 2001-2002, * 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: @@ -78,12 +78,12 @@ let clearReferencedBits file = trace (dprintf "clearing mark: %a\n" d_shortglobal global); info.creferenced <- false - | GVar ({vname = name} as info, _, _) - | GVarDecl ({vname = name} as info, _) -> + | GVar ({vname = name; _} as info, _, _) + | GVarDecl ({vname = name; _} as info, _) -> trace (dprintf "clearing mark: %a\n" d_shortglobal global); info.vreferenced <- false - | GFun ({svar = info} as func, _) -> + | GFun ({svar = info; _} as func, _) -> trace (dprintf "clearing mark: %a\n" d_shortglobal global); info.vreferenced <- false; let clearMark local = @@ -138,14 +138,14 @@ let categorizePragmas file = unions = H.create 0; defines = H.create 1 } in - + (* populate these name collections in light of each pragma *) let considerPragma = let badPragma location pragma = ignore (warnLoc location "Invalid argument to pragma %s" pragma) in - + function | GPragma (Attr ("cilnoremove" as directive, args), location) -> (* a very flexible pragma: can retain typedefs, enums, @@ -192,7 +192,7 @@ let categorizePragmas file = | [Attr("alias", [AStr othername])] -> H.add keepers.defines othername () | _ -> E.s (error "Bad alias attribute at %a" d_loc !currentLoc) - end + end (*** Begin CCured-specific checks: ***) (* these pragmas indirectly require that we keep the function named in @@ -231,7 +231,7 @@ let categorizePragmas file = | _ -> badPragma location directive end - (** end CCured-specific stuff **) + (*** end CCured-specific stuff ***) | _ -> () in @@ -255,7 +255,7 @@ let categorizePragmas file = let amputateFunctionBodies keptGlobals file = let considerGlobal = function - | GFun ({svar = {vname = name} as info}, location) + | GFun ({svar = {vname = name; _} as info; _}, location) when not (H.mem keptGlobals name) -> trace (dprintf "slicing: reducing to prototype: function %s\n" name); GVarDecl (info, location) @@ -274,18 +274,18 @@ let amputateFunctionBodies keptGlobals file = let isPragmaRoot keepers = function - | GType ({tname = name}, _) -> + | GType ({tname = name; _}, _) -> H.mem keepers.typedefs name - | GEnumTag ({ename = name}, _) - | GEnumTagDecl ({ename = name}, _) -> + | GEnumTag ({ename = name; _}, _) + | GEnumTagDecl ({ename = name; _}, _) -> H.mem keepers.enums name - | GCompTag ({cname = name; cstruct = structure}, _) - | GCompTagDecl ({cname = name; cstruct = structure}, _) -> + | GCompTag ({cname = name; cstruct = structure; _}, _) + | GCompTagDecl ({cname = name; cstruct = structure; _}, _) -> let collection = if structure then keepers.structs else keepers.unions in H.mem collection name - | GVar ({vname = name; vattr = attrs}, _, _) - | GVarDecl ({vname = name; vattr = attrs}, _) - | GFun ({svar = {vname = name; vattr = attrs}}, _) -> + | GVar ({vname = name; vattr = attrs; _}, _, _) + | GVarDecl ({vname = name; vattr = attrs; _}, _) + | GFun ({svar = {vname = name; vattr = attrs; _}; _}, _) -> H.mem keepers.defines name || hasAttribute "used" attrs | _ -> @@ -311,7 +311,7 @@ let traceNonRoot reason global = let hasExportingAttribute funvar = - let rec isExportingAttribute = function + let isExportingAttribute = function | Attr ("constructor", []) -> true | Attr ("destructor", []) -> true | _ -> false @@ -341,17 +341,17 @@ let hasExportingAttribute funvar = let isExportedRoot global = let result, reason = match global with - | GVar ({vstorage = Static}, _, _) -> + | GVar ({vstorage = Static; _}, _, _) -> false, "static variable" | GVar _ -> true, "non-static variable" - | GFun ({svar = v}, _) -> begin - if hasExportingAttribute v then + | GFun ({svar = v; _}, _) -> begin + if hasExportingAttribute v then true, "constructor or destructor function" - else if v.vstorage = Static then + else if v.vstorage = Static then false, "static function" else if v.vinline && v.vstorage != Extern - && (!msvcMode || !rmUnusedInlines) then + && (!msvcMode || !rmUnusedInlines) then false, "inline function" else true, "other function" @@ -361,7 +361,7 @@ let isExportedRoot global = | _ -> false, "neither function nor variable" in - trace (dprintf "isExportedRoot %a -> %b, %s@!" + trace (dprintf "isExportedRoot %a -> %b, %s@!" d_shortglobal global result reason); result @@ -381,7 +381,7 @@ let isExportedRoot global = let isCompleteProgramRoot global = let result = match global with - | GFun ({svar = {vname = "main"; vstorage = vstorage}}, _) -> + | GFun ({svar = {vname = "main"; vstorage = vstorage; _}; _}, _) -> vstorage <> Static | GFun (fundec, _) when hasExportingAttribute fundec.svar -> @@ -401,12 +401,12 @@ let isCompleteProgramRoot global = (* This visitor recursively marks all reachable types and variables as used. *) -class markReachableVisitor +class markReachableVisitor ((globalMap: (string, Cil.global) H.t), (currentFunc: fundec option ref)) = object (self) inherit nopCilVisitor - method vglob = function + method! vglob = function | GType (typeinfo, _) -> typeinfo.treferenced <- true; DoChildren @@ -420,31 +420,31 @@ class markReachableVisitor DoChildren | GVar (varinfo, _, _) | GVarDecl (varinfo, _) - | GFun ({svar = varinfo}, _) -> + | GFun ({svar = varinfo; _}, _) -> varinfo.vreferenced <- true; DoChildren | _ -> SkipChildren - method vinst = function - Asm (_, tmpls, _, _, _, _) when !msvcMode -> - (* If we have inline assembly on MSVC, we cannot tell which locals + method! vinst = function + Asm (_, tmpls, _, _, _, _) when !msvcMode -> + (* If we have inline assembly on MSVC, we cannot tell which locals * are referenced. Keep thsem all *) - (match !currentFunc with - Some fd -> - List.iter (fun v -> - let vre = Str.regexp_string (Str.quote v.vname) in - if List.exists (fun tmp -> + (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 + tmpls then v.vreferenced <- true) fd.slocals | _ -> assert false); DoChildren | _ -> DoChildren - method vvrbl v = + method! vvrbl v = if not v.vreferenced then begin let name = v.vname in @@ -452,7 +452,7 @@ class markReachableVisitor trace (dprintf "marking transitive use: global %s\n" name) else trace (dprintf "marking transitive use: local %s\n" name); - + (* If this is a global, we need to keep everything used in its * definition and declarations. *) if v.vglob then @@ -469,13 +469,13 @@ class markReachableVisitor end; SkipChildren - method vexpr (e: exp) = - match e with + method! vexpr (e: exp) = + match e with Const (CEnum (_, _, ei)) -> ei.ereferenced <- true; DoChildren | _ -> DoChildren - method vtype typ = + method! vtype typ = let old : bool = let visitAttrs attrs = ignore (visitCilAttributes (self :> cilVisitor) attrs) @@ -516,7 +516,7 @@ class markReachableVisitor begin trace (dprintf "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 *) visitType ti.ttype; @@ -536,12 +536,12 @@ end let markReachable file isRoot = - (* build a mapping from global names back to their definitions & + (* 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}, _) + | GFun ({svar = info; _}, _) | GVar (info, _, _) | GVarDecl (info, _) -> Hashtbl.add globalMap info.vname global @@ -550,7 +550,7 @@ let markReachable file isRoot = in iterGlobals file considerGlobal; - let currentFunc = ref None in + let currentFunc = ref None in (* mark everything reachable from the global roots *) let visitor = new markReachableVisitor (globalMap, currentFunc) in @@ -558,7 +558,7 @@ let markReachable file isRoot = if isRoot global then begin trace (dprintf "traversing root global: %a\n" d_shortglobal global); - (match global with + (match global with GFun(fd, _) -> currentFunc := Some fd | _ -> currentFunc := None); ignore (visitCilGlobal visitor global) @@ -575,26 +575,26 @@ let markReachable file isRoot = * **********************************************************************) -(* 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 +(* 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. After this cleanup, * every statement's labels will be either a single 'Default' or any * number of 'Case's, in either case possibly preceded by a single 'Label'. *) -let labelsToKeep (ll: label list) : (string * location * bool) * label list = +let labelsToKeep (ll: label list) : (string * location * bool) * label list = let rec loop (sofar: string * location * bool) = function [] -> sofar, [] - | l :: rest -> - let newlabel, keepl = + | l :: rest -> + let newlabel, keepl = match l with | CaseRange _ | Case _ | Default _ -> sofar, true | Label (ln, lloc, isorig) -> begin - match isorig, sofar with - | false, ("", _, _) -> + match isorig, sofar with + | false, ("", _, _) -> (* keep this one only if we have no label so far *) (ln, lloc, isorig), false | false, _ -> sofar, false - | true, (_, _, false) -> - (* this is an original label; prefer it to temporary or + | true, (_, _, false) -> + (* this is an original label; prefer it to temporary or * missing labels *) (ln, lloc, isorig), false | true, _ -> sofar, false @@ -620,19 +620,21 @@ class removeUnusedGoto = object(self) method private pStmtNext (next: stmt) (s: stmt) = match s.skind with (* Else-if: don't call visitCilStmt, recurse manually instead *) - | If(_,t,{ bstmts=[{skind=If _} as elsif]; battrs=[] },_) -> + | If(_,t,{ bstmts=[{skind=If _; _} as elsif]; battrs=[] },_) -> ignore(visitCilBlock (self:>cilVisitor) t); self#pStmtNext next elsif - | If(_,_,({bstmts=[{skind=Goto(gref,_);labels=[]}]; - battrs=[]} as b),_) - | If(_,({bstmts=[{skind=Goto(gref,_);labels=[]}]; + | If(_,_,({bstmts=[{skind=Goto(gref,_);labels=[]; _}]; + battrs=[]} as b),_)when !gref == next -> + b.bstmts <- []; + ignore(visitCilStmt (self:>cilVisitor) s) + | If(_,({bstmts=[{skind=Goto(gref,_);labels=[]; _}]; battrs=[]} as b),_,_) when !gref == next -> b.bstmts <- []; ignore(visitCilStmt (self:>cilVisitor) s) | _ -> ignore(visitCilStmt (self:>cilVisitor) s) - method vblock blk = + method! vblock blk = let rec dofirst = function [] -> () | [x] -> self#pStmtNext invalidStmt x @@ -647,19 +649,19 @@ class removeUnusedGoto = object(self) SkipChildren (* No need to go into expressions or instructions *) - method vexpr _ = SkipChildren - method vinst _ = SkipChildren - method vtype _ = SkipChildren + method! vexpr _ = SkipChildren + method! vinst _ = SkipChildren + method! vtype _ = SkipChildren end - + class markUsedLabels (labelMap: (string, unit) H.t) = object inherit nopCilVisitor - method vstmt (s: stmt) = - match s.skind with - Goto (dest, _) -> + method! vstmt (s: stmt) = + match s.skind with + Goto (dest, _) -> let (ln, _, _), _ = labelsToKeep !dest.labels in - if ln = "" then + if ln = "" then E.s (E.bug "rmtmps: destination of statement does not have labels"); (* Mark it as used *) H.replace labelMap ln (); @@ -667,7 +669,7 @@ class markUsedLabels (labelMap: (string, unit) H.t) = object | _ -> DoChildren - method vexpr e = match e with + method! vexpr e = match e with | AddrOfLabel dest -> let (ln, _, _), _ = labelsToKeep !dest.labels in if ln = "" then @@ -681,7 +683,7 @@ end class removeUnusedLabels (labelMap: (string, unit) H.t) = object inherit nopCilVisitor - method vstmt (s: stmt) = + method! vstmt (s: stmt) = let (ln, lloc, lorig), lrest = labelsToKeep s.labels in (* Check our desired invariants for labels: 'lrest' must be either a single 'Default' or only 'Case's. It is okay for 'lrest' to be @@ -698,9 +700,9 @@ class removeUnusedLabels (labelMap: (string, unit) H.t) = object DoChildren (* No need to go into expressions or instructions *) - method vexpr _ = SkipChildren - method vinst _ = SkipChildren - method vtype _ = SkipChildren + method! vexpr _ = SkipChildren + method! vinst _ = SkipChildren + method! vtype _ = SkipChildren end (*********************************************************************** @@ -715,12 +717,12 @@ 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 *) + (* various macros in glibc's *) "__result"; "__s"; "__s1"; "__s2"; "__s1_len"; "__s2_len"; @@ -734,31 +736,31 @@ let uninteresting = (* optional alpha renaming *) let alpha = "\\(___[0-9]+\\)?" in - + let pattern = "\\(" ^ (String.concat "\\|" names) ^ "\\)" ^ alpha ^ "$" in Str.regexp pattern let removeUnmarked file = let removedLocals = ref [] in - + let filterGlobal global = match global with (* unused global types, variables, and functions are simply removed *) - | GType ({treferenced = false}, _) - | GCompTag ({creferenced = false}, _) - | GCompTagDecl ({creferenced = false}, _) - | GEnumTag ({ereferenced = false}, _) - | GEnumTagDecl ({ereferenced = false}, _) - | GVar ({vreferenced = false}, _, _) - | GVarDecl ({vreferenced = false}, _) - | GFun ({svar = {vreferenced = false}}, _) -> + | GType ({treferenced = false; _}, _) + | GCompTag ({creferenced = false; _}, _) + | GCompTagDecl ({creferenced = false; _}, _) + | GEnumTag ({ereferenced = false; _}, _) + | GEnumTagDecl ({ereferenced = false; _}, _) + | GVar ({vreferenced = false; _}, _, _) + | GVarDecl ({vreferenced = false; _}, _) + | GFun ({svar = {vreferenced = false; _}; _}, _) -> trace (dprintf "removing global: %a\n" d_shortglobal global); false (* retained functions may wish to discard some unused locals *) | GFun (func, _) -> - let rec filterLocal local = + let filterLocal local = if not local.vreferenced then begin (* along the way, record the interesting locals that were removed *) @@ -770,7 +772,7 @@ let removeUnmarked file = local.vreferenced in func.slocals <- List.filter filterLocal func.slocals; - (* We also want to remove unused labels. We do it all here, including + (* 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 (visitCilFunction (new removeUnusedGoto) func); @@ -801,12 +803,12 @@ type rootsFilter = global -> bool let isDefaultRoot = isExportedRoot -let rec removeUnusedTemps ?(isRoot : rootsFilter = isDefaultRoot) file = +let removeUnusedTemps ?(isRoot : rootsFilter = isDefaultRoot) file = if !keepUnused || Trace.traceActive "disableTmpRemoval" then Trace.trace "disableTmpRemoval" (dprintf "temp removal disabled\n") else begin - if !E.verboseFlag then + if !E.verboseFlag then ignore (E.log "Removing unused temporaries\n" ); if Trace.traceActive "printCilTree" then @@ -835,7 +837,7 @@ let rec removeUnusedTemps ?(isRoot : rootsFilter = isDefaultRoot) file = (* print which original source variables were removed *) if false && removedLocals != [] then let count = List.length removedLocals in - if count > 2000 then + if count > 2000 then ignore (E.warn "%d unused local variables removed" count) else ignore (E.warn "%d unused local variables removed:@!%a" diff --git a/test/Makefile b/test/Makefile index 49a73934b..da42a0840 100644 --- a/test/Makefile +++ b/test/Makefile @@ -1,4 +1,4 @@ -# -*- Mode: makefile -*- +# -*- Mode: makefile -*- # Makefile.in for running the test cases for the CIL compiler # Use from the test directory !!! # author: George Necula @@ -99,7 +99,7 @@ ifdef KEEPMERGED CILLY+= --keepmerged endif ifdef MERGEONLY - CILLY+= --keepmerged --onlyMerge --mergeKeepAnnotations + CILLY+= --keepmerged --onlyMerge --mergeKeepAnnotations endif ifdef CABSONLY CILLY+= --cabsonly @@ -123,13 +123,6 @@ ifdef STATS CILLY+= --stats endif -# enable logging of all fn calls in the application -# (see LOGSTYLE, below) -ifdef LOGCALLS - CILLY+= --logcalls -endif - - # when SEPARATE is defined, merging is disabled ifdef SEPARATE CILLY+= --nomerge @@ -179,18 +172,24 @@ endif ############ Small tests SMALL1 := $(TESTDIR)/small1 -test/% : $(SMALL1)/%.c +test/% : $(SMALL1)/%.c cd $(SMALL1); $(CILLY) --nomerge --commPrintLn \ - $(CONLY) $(CFLAGS) $(ASMONLY)$*.s $*.c + $(CONLY) -std=gnu90 $(CFLAGS) $(ASMONLY)$*.s $*.c echo SUCCESS -testobj/% : $(SMALL1)/%.c +testobj/% : $(SMALL1)/%.c cd $(SMALL1); $(CILLY) --nomerge --commPrintLn \ - $(CONLY) $(CFLAGS) $(OBJOUT)$*.o $*.c + $(CONLY) $(CFLAGS) $(OBJOUT)$*.o $*.c -testrun/% : $(SMALL1)/%.c +testrun/% : $(SMALL1)/%.c cd $(SMALL1); $(CILLY) --nomerge --commPrintLn \ - $(CFLAGS) $(EXEOUT)$*.exe $*.c + $(CFLAGS) -std=gnu90 $(EXEOUT)$*.exe $*.c + cd $(SMALL1); ./$*.exe + echo SUCCESS + +testrunc99/% : $(SMALL1)/%.c + cd $(SMALL1); $(CILLY) --nomerge --commPrintLn \ + $(CFLAGS) -std=c99 $(EXEOUT)$*.exe $*.c -lm cd $(SMALL1); ./$*.exe echo SUCCESS @@ -201,7 +200,7 @@ testrungcc/% : $(SMALL1)/%.c mustbegcc echo SUCCESS #preprocessed files: -test_i/% : $(SMALL1)/%.i +test_i/% : $(SMALL1)/%.i cd $(SMALL1); $(CILLY) --nomerge --commPrintLn \ $(CONLY) $(CFLAGS) $(ASMONLY)$*.s $*.i echo SUCCESS @@ -213,7 +212,7 @@ test_i/% : $(SMALL1)/%.i ifdef TARGETS_DEP_QUICKBUILD # with switch to test/Makefile, doesn't do what I want, so no-op #TARGET_DEP := quickbuild - TARGET_DEP := + TARGET_DEP := endif ifndef NOPRINTLN @@ -252,7 +251,8 @@ scott-nolink/%: $(TESTDIR)/small2/%.c $(TARGET_DEP) -OBJDIR := $(CILHOME)/_build/src +OBJDIR_DUNE := $(CILHOME)/../install/default/lib/goblint-cil +OBJDIR_MAKE := $(CILHOME)/_build/src ifdef NATIVECAML CMXA := cmxa CAMLC := ocamlopt @@ -262,7 +262,7 @@ else endif testrun/% : $(SMALL1)/%.ml - $(CAMLC) -I $(OBJDIR) unix.$(CMXA) str.$(CMXA) nums.$(CMXA) \ + ocamlfind $(CAMLC) -I $(OBJDIR_DUNE) -I $(OBJDIR_MAKE) -package zarith unix.$(CMXA) str.$(CMXA) zarith.$(CMXA) \ cil.$(CMXA) \ $(EXEOUT) $(basename $<).exe $< $(basename $<).exe @@ -271,7 +271,7 @@ testrun/% : $(SMALL1)/%.ml combine%: $(SMALL1)/combine%_1.c cd $(SMALL1); \ - $(CILLY) $(CFLAGS) \ + $(CILLY) $(CFLAGS) -std=gnu90 \ $(notdir $(wildcard $(SMALL1)/combine$*_[1-9].c)) \ $(EXEOUT)combine$*.exe cd $(SMALL1); ./combine$*.exe @@ -284,10 +284,17 @@ arcombine: mustbegcc cd $(SMALL1); ./matrix.exe +combinec99%: $(SMALL1)/combine-c99%_1.c + cd $(SMALL1); \ + $(CILLY) $(CFLAGS) -std=c99 --merge \ + $(notdir $(wildcard $(SMALL1)/combine-c99$*_[1-9].c)) \ + $(EXEOUT)combine-c99$*.exe + cd $(SMALL1); ./combine-c99$*.exe + # ww: Scott's structs-edg-stl.c example structs : mustbemanju cd /usr/src/big-examples/; $(CILLY) --nomerge \ - $(CONLY) $(CFLAGS) structs-edg-stl.c + $(CONLY) $(CFLAGS) structs-edg-stl.c echo SUCCESS @@ -336,7 +343,7 @@ runall_syntax/%: $(TESTDIR)/small2/%.c $(TARGET_DEP) # sm: trivial test of combiner MYSAFECC := $(CILLY) -comb: $(TESTDIR)/small2/comb1.c $(TESTDIR)/small2/comb2.c +comb: $(TESTDIR)/small2/comb1.c $(TESTDIR)/small2/comb2.c rm -f $(TESTDIR)/small2/comb.exe cd $(TESTDIR)/small2; \ $(MYSAFECC) comb1.c $(CONLY) $(OBJOUT) comb1.o; \ @@ -348,7 +355,7 @@ comb: $(TESTDIR)/small2/comb1.c $(TESTDIR)/small2/comb2.c #call cilly on a .c file, a .i file, a .s file, and a .o file. #Of course, only the first two are merged. -mixedcomb: $(TESTDIR)/small2/comb1.c $(TESTDIR)/small2/comb2.c +mixedcomb: $(TESTDIR)/small2/comb1.c $(TESTDIR)/small2/comb2.c rm -f $(TESTDIR)/small2/comb.exe cd $(TESTDIR)/small2; \ gcc -E -o comb2.i comb2.c; \ @@ -378,7 +385,7 @@ mergeinline: $(TESTDIR)/small2/mergeinline1.c $(TESTDIR)/small2/mergeinline2.c $(TESTDIR)/small2/mergeinline.exe # sm: test of combiner's ability to report inconsistencies -baddef: $(TESTDIR)/small2/baddef1.c $(TESTDIR)/small2/baddef2.c +baddef: $(TESTDIR)/small2/baddef1.c $(TESTDIR)/small2/baddef2.c cd $(TESTDIR)/small2; $(CC) baddef1.c baddef2.c -o baddef.exe \ && ./baddef.exe rm -f $(TESTDIR)/small2/baddef.exe @@ -392,10 +399,10 @@ baddef: $(TESTDIR)/small2/baddef1.c $(TESTDIR)/small2/baddef2.c ### Generic test -testfile/% : +testfile/% : $(CILLY) /TC $* -testdir/% : +testdir/% : make -C CC="ccured" $* @@ -403,6 +410,3 @@ merge-ar: cd small2; $(CILHOME)/bin/cilly --merge -c merge-ar.c merge-twice-1.c cd small2; $(CILHOME)/bin/cilly --merge --mode=AR cr libmerge.a merge-ar.o merge-twice-1.o cd small2; $(CILHOME)/bin/cilly --merge libmerge.a -o merge-ar - - - diff --git a/test/Makefile.gcc b/test/Makefile.gcc index 8fae4e343..2b460f11f 100644 --- a/test/Makefile.gcc +++ b/test/Makefile.gcc @@ -4,7 +4,9 @@ COMPILERNAME := GNUCC -CC := gcc +ifeq (,$(findstring gcc,$(CC))) + CC := gcc +endif ifdef RELEASELIB # sm: I will leave this here, but only use it for compiling our runtime lib CFLAGS := -D_GNUCC -Wall -O3 diff --git a/test/llvm/Makefile b/test/llvm/Makefile deleted file mode 100644 index a1e5e8d1c..000000000 --- a/test/llvm/Makefile +++ /dev/null @@ -1,32 +0,0 @@ -SOURCES = $(wildcard *.c) -TESTS = $(basename $(SOURCES)) - -CILLY = $(OBJ)/cilly.byte.exe - -all: compare - -big: cfrac - -$(TESTS): %: %.c FORCE - @mkdir -p temp - $(CC) -m32 -E $< -o temp/$@.i - CIL_MACHINE=`$(OBJ)/machdep-ml32.exe --env` \ - $(CILLY) --dollvm --envmachine temp/$@.i >temp/$@.ll - llvm-as -f temp/$@.ll - llc -march=x86 -f temp/$@.bc - $(CC) -m32 -o temp/$@.llvm temp/$@.s - temp/$@.llvm - -compare: - @sh compare-with-gcc $(OBJ) - -cfrac: - make -C cfrac.d - -clean: - rm -rf temp - make -C cfrac.d clean - -FORCE: -.PHONY: FORCE big cfrac - diff --git a/test/llvm/cfrac.d/.gdb_history b/test/llvm/cfrac.d/.gdb_history deleted file mode 100644 index 88499843c..000000000 --- a/test/llvm/cfrac.d/.gdb_history +++ /dev/null @@ -1,92 +0,0 @@ -b main -r 23 -c -bt -r -v 55 -disass -b pdivmode -b pdivmod -r 55 -disp/i $pc -si -r -ni -ni -c -c -r -c -diass -disass -r -c -ni -n -r -c -ni -p $ecx -disass -b *0x4128 -c -ni -b *0x416a -c -si -si -si -b *0x41b7 -c -si -si -p/x $esi -p/x $eax -si -b *0x4237 -c -b *0x423f -c -b *0x4255 -c -si -si -p/x $esi -p/x $eax -si -b *0x42d1 -c -si -b *0x42d9 -c -p/x $esp -p $6 + 84 -p *(void **)$7 -disp *(void **)$7 -p *(short *)$8 -p $esp + 100 -disp *(void **)$10 -b b *0x4475 -b *0x4475 -si -c -si -p $eax -si -p/x $esi -p $eax -p/x $eax -si -si -p/x $esi -disp/x $esi -si -si -si -p/x $edi -si -p *(void **)($esp+24) -si -p/x $edi -si -p $edx -si diff --git a/test/llvm/cfrac.d/Makefile b/test/llvm/cfrac.d/Makefile deleted file mode 100644 index 7826bb90a..000000000 --- a/test/llvm/cfrac.d/Makefile +++ /dev/null @@ -1,68 +0,0 @@ -# -# An implementation of the Continued Fraction Algorithm CFRAC -# -# Dave Barrett -# - -PDIR = . -# removed because I don't want to recompile every time I change header file -#INCF = pfactor.h - -LLCIL = ../../../obj/cilly.byte.exe --dollvm --envmachine -LLCC = llvm-as -CC = gcc -m32 -CFLAGS = -g -DNOMEMOPT $(EXTRACFLAGS) - -BINSRC = cfrac.c -HDR = primes.h seive.h pfactor.h - -PSRC = pops.c pconst.c pio.c \ - pabs.c pneg.c pcmp.c podd.c phalf.c \ - padd.c psub.c pmul.c pdivmod.c psqrt.c ppowmod.c \ - atop.c ptoa.c itop.c utop.c ptou.c errorp.c \ - pfloat.c pidiv.c pimod.c picmp.c - -FSRC = primes.c pcfrac.c pgcd.c - -FOBJS = $(PSRC:.c=.bc) -POBJS = $(FSRC:.c=.bc) -OBJS = $(BINSRC:.c=.bc) $(PSRC:.c=.bc) $(FSRC:.c=.bc) - -%.bc: %.c - @mkdir -p temp - $(CC) -E $(CFLAGS) $< >temp/$*.i - CIL_MACHINE=`../../../obj/machdep-ml32.exe --env 2>/dev/null` \ - $(LLCIL) temp/$*.i >temp/$*.ll - $(LLCC) -o $@ temp/$*.ll - -all: cfrac - ./cfrac 23551 - -cfrac: $(OBJS) - llvm-link -f -o cfrac-all.bc $(OBJS) - #opt -f -std-compile-opts -o cfrac-opt.bc cfrac-all.bc - llc -march=x86 -f cfrac-all.bc - $(CC) -o cfrac cfrac-all.s -lm - -malloc: - -bwgc: - -SRC = Makefile $(HDR) $(BINSRC) - -pgcd.o: $(INC) -pcfrac.o: $(INCF) $(INC) primes.h -primes.o: primes.h - -clean: - rm -rf core temp - rm -f $(OBJS) cfrac - -cleantarget: - rm cfrac - -# -# producer only clean -# -pclean: - rm -f $(OBJS) diff --git a/test/llvm/cfrac.d/README.txt b/test/llvm/cfrac.d/README.txt deleted file mode 100644 index abdd4947a..000000000 --- a/test/llvm/cfrac.d/README.txt +++ /dev/null @@ -1,19 +0,0 @@ - -Test inputs to cfrac program: - -cfrac 23533 -output is: 23533 = 233 * 101 - -cfrac 1000000001930000000057 -output is: 1000000001930000000057 = 100000000003 * 10000000019 - -cfrac 327905606740421458831903 -output is: 327905606740421458831903 = 349394839499 * 938495849597 - - -cfrac 4175764634412486014593803028771 -output is: 4175764634412486014593803028771 = 493849349348447 * 8455543456565693 - -cfrac 41757646344123832613190542166099121 -output is: 41757646344123832613190542166099121 = 49384934934843479 * 845554345656569399 - diff --git a/test/llvm/cfrac.d/atop.c b/test/llvm/cfrac.d/atop.c deleted file mode 100644 index 98f132a82..000000000 --- a/test/llvm/cfrac.d/atop.c +++ /dev/null @@ -1,61 +0,0 @@ -#include -#include "pdefs.h" -#include "pcvt.h" -#include "precision.h" - -/* - * ascii to precision (modeled after atoi) - * leading whitespace skipped - * an optional leading '-' or '+' followed by digits '0'..'9' - * leading 0's Ok - * stops at first unrecognized character - * - * Returns: pUndef if an invalid argument (pUndef or nondigit as 1st digit) - */ -precision atop(chp) - register char *chp; -{ - precision res = pUndef; - precision clump = pUndef; - int sign = 0; - register int ch; - register accumulator temp; - accumulator x; - register int i; - - if (chp != (char *) 0) { - while (isspace(*chp)) chp++; /* skip whitespace */ - if (*chp == '-') { - sign = 1; - ++chp; - } else if (*chp == '+') { - ++chp; - } - if (isdigit(ch = * (unsigned char *) chp)) { - pset(&res, pzero); - pset(&clump, utop(aDigit)); - do { - i = aDigitLog-1; - temp = ch - '0'; - do { - if (!isdigit(ch = * (unsigned char *) ++chp)) goto atoplast; - temp = temp * aBase + (ch - '0'); - } while (--i > 0); - pset(&res, padd(pmul(res, clump), utop(temp))); - } while (isdigit(ch = * (unsigned char *) ++chp)); - goto atopdone; -atoplast: - x = aBase; - while (i++ < aDigitLog-1) { - x *= aBase; - } - pset(&res, padd(pmul(res, utop(x)), utop(temp))); -atopdone: - if (sign) { - pset(&res, pneg(res)); - } - } - } - pdestroy(clump); - return presult(res); -} diff --git a/test/llvm/cfrac.d/cfrac.c b/test/llvm/cfrac.d/cfrac.c deleted file mode 100644 index 1cab80529..000000000 --- a/test/llvm/cfrac.d/cfrac.c +++ /dev/null @@ -1,269 +0,0 @@ -#include -#include -#include -#include -#include /* for findk */ - -#ifdef __STDC__ -#include -#endif -#include "precision.h" -#include "pfactor.h" -#include - -#ifdef __STDC__ -extern unsigned *pfactorbase(precision n, unsigned k, - unsigned *m, unsigned aborts); -extern double pomeranceLpow(double n, double alpha); -#else -extern unsigned *pfactorbase(); -extern double pomeranceLpow(); -#endif - -int verbose = 0; -int debug = 0; - -extern unsigned cfracNabort; -extern unsigned cfracTsolns; -extern unsigned cfracPsolns; -extern unsigned cfracT2solns; -extern unsigned cfracFsolns; - - -extern unsigned short primes[]; -extern unsigned primesize; - -/* - * Return the value of "f(p,d)" from Knuth's exercise 28 - */ -float pfKnuthEx28(p, d) - unsigned p; - precision d; -{ - register float res; - precision k = pUndef; - - (void) pparm(d); - if (p == 2) { - if (peven(d)) { - pset(&k, phalf(d)); - if (peven(k)) { - res = 2.0/3.0 + pfKnuthEx28(2,k)/2.0; /* eliminate powers of 2 */ - } else { /* until only one 2 left in d. */ - res = 1.0/3.0; /* independent of (the now odd) k. Wow! */ - } - } else { /* d now odd */ - pset(&k, phalf(d)); - if (podd(k)) { - res = 1.0/3.0; /* f(2,4k+3): d%8 == 3 or 7 */ - } else { - if (podd(phalf(k))) { - res = 2.0/3.0; /* f(2,8k+5): d%8 == 5 */ - } else { - res = 4.0/3.0; /* f(2,8k+1): d%8 == 1 */ - } - } - } - } else { /* PART 3: p odd, d could still be even (OK) */ - pset(&k, utop(p)); - if peq(ppowmod(d, phalf(psub(k, pone)), k), pone) { - res = (float) (p+p) / (((float) p)*p-1.0); /* beware int overflow! */ - } else { - res = 0.0; - } - } - - pdestroy(k); - pdestroy(d); - if (debug > 1) { - fprintf(stdout, "f(%u,", p); - fprintf(stdout, "d) = %9.7f\n", res); - } - return res; -} - -float plogf(p, n, k) - precision n; - unsigned p, k; -{ - register float res; - - (void) pparm(n); - -#if 0 /* old code for non-float machines; not worth the cost */ - pset(&r, utop(k)); - log2sqrtk = plogb(pipow(r, q >> 1), ptwo); - fplog2p = (f(p,pmul(r,n),q) * plogb(pipow(utop(p),q),ptwo)+(q>>1))/q; -#endif - - res = pfKnuthEx28(p, pmul(itop(k),n)) * log((double) p); - /* res -= log((double) k) * 0.5; */ - - pdestroy(n); - return res; -} - -/* - * Find the best value of k for the given n and m. - * - * Input/Output: - * n - the number to factor - * m - pointer to size of factorbase (0 = select "best" size) - * aborts - the number of early aborts - */ -unsigned findk(n, m, aborts, maxk) - precision n; - register unsigned *m; - unsigned aborts, maxk; -{ - unsigned k, bestk = 0, count, bestcount = 0, maxpm; - float sum, max = -1.0E+15; /* should be small enough */ - unsigned *p; - register unsigned i; - register unsigned short *primePtr; - - (void) pparm(n); - - for (k = 1; k < maxk; k++) { /* maxk should best be m+m? */ - if (debug) { - fputs("kN = ", stdout); - fputp(stdout, pmul(utop(k), n)); putc('\n', stdout); - } - count = *m; - p = pfactorbase(n, k, &count, aborts); - if (p == (unsigned *) 0) { - fprintf(stderr, "couldn't compute factor base in findk\n"); - exit(1); - } - - maxpm = p[count-1]; - - sum = 0.0; - primePtr = primes; - while (*primePtr <= maxpm) { - sum += plogf((unsigned) *primePtr++, n, k); - } - sum -= log((double) k) * 0.5; - if (verbose > 2) fprintf(stdout, "%u: %5.2f", k, sum); - if (debug) fprintf(stdout, " log(k)/2=%5.2f", log((double) k) * 0.5); - if (verbose > 2) { - fputs("\n", stdout); - fflush(stdout); - } - if (sum > max) { - max = sum; - bestk = k; - bestcount = count; - } - free(p); - } - - *m = bestcount; - pdestroy(n); - return bestk; -} - -extern char *optarg; -extern int optind; - -char *progName; - -extern int getopt(); - -int main(argc, argv) - int argc; - char *argv[]; -{ - char *sb = sbrk(0); - unsigned m = 0, k = 0; - unsigned maxCount = 1<<30, count, maxk = 0; - int ch; - precision n = pUndef, f = pUndef; - unsigned aborts = 3; - unsigned *p; - -#ifdef TIMING - timing_init(); -#endif - -#ifdef STATS - setbuf(stdout, NULL); - setbuf(stderr, NULL); - { void malloc_stats(void); atexit(malloc_stats); } -#endif - - progName = *argv; - - while ((ch = getopt(argc, argv, "a:k:i:dv")) != EOF) switch (ch) { - case 'a': - aborts = atoi(optarg); - break; - case 'k': - maxk = atoi(optarg); - break; - case 'i': - maxCount = atoi(optarg); - break; - case 'd': - debug++; - break; - case 'v': - verbose++; - break; - default: -usage: fprintf(stderr, - "usage: %s [-dv] [-a aborts ] [-k maxk ] [-i maxCount ] n [[ m ] k ]\n", - progName); - return 1; - } - argc -= optind; - argv += optind; - - if (argc < 1 || argc > 3) goto usage; - - pset(&n, atop(*argv++)); --argc; - if (argc) { m = atoi(*argv++); --argc; } - if (argc) { k = atoi(*argv++); --argc; } - - if (k == 0) { - if (maxk == 0) { - maxk = m / 2 + 5; - if (verbose) fprintf(stdout, "maxk = %u\n", maxk); - } - k = findk(n, &m, aborts, maxk); - if (verbose) { - fprintf(stdout, "k = %u\n", k); - } - } - - count = maxCount; - - pcfracInit(m, k, aborts); - - pset(&f, pcfrac(n, &count)); - count = maxCount - count; - if (verbose) { - putc('\n', stdout); - fprintf(stdout, "Iterations : %u\n", count); - fprintf(stdout, "Early Aborts : %u\n", cfracNabort); - fprintf(stdout, "Total Partials : %u\n", cfracTsolns); - fprintf(stdout, "Used Partials : %u\n", cfracT2solns); - fprintf(stdout, "Full Solutions : %u\n", cfracPsolns); - fprintf(stdout, "Factor Attempts: %u\n", cfracFsolns); - } - - if (f != pUndef) { - fputp(stdout, n); - fputs(" = ", stdout); - fputp(stdout, f); - fputs(" * ", stdout); - pdivmod(n, f, &n, pNull); - fputp(stdout, n); - putc('\n', stdout); - } - - pdestroy(f); - pdestroy(n); - - return 0; -} diff --git a/test/llvm/cfrac.d/errorp.c b/test/llvm/cfrac.d/errorp.c deleted file mode 100644 index 5868aa441..000000000 --- a/test/llvm/cfrac.d/errorp.c +++ /dev/null @@ -1,27 +0,0 @@ -#include -#include "precision.h" - -/* - * Fatal error (user substitutable) - * - * PNOMEM - out of memory (pcreate) - * PREFCOUNT - refcount negative (pdestroy) - * PUNDEFINED - undefined value referenced (all) - * PDOMAIN - domain error - * pdivmod: divide by zero - * psqrt: negative argument - * POVERFLOW - overflow - * itop: too big - */ -precision errorp(errnum, routine, message) - int errnum; - char *routine; - char *message; -{ - fputs(routine, stderr); - fputs(": ", stderr); - fputs(message, stderr); - fputs("\n", stderr); - abort(); /* remove this line if you want */ - return pUndef; -} diff --git a/test/llvm/cfrac.d/itop.c b/test/llvm/cfrac.d/itop.c deleted file mode 100644 index 87d309af3..000000000 --- a/test/llvm/cfrac.d/itop.c +++ /dev/null @@ -1,25 +0,0 @@ -#include "pdefs.h" -#include "pcvt.h" -#include "precision.h" - -/* - * Integer to Precision - */ -precision itop(i) - register int i; -{ - register digitPtr uPtr; - register precision u = palloc(INTSIZE); - - if (u == pUndef) return u; - - if (u->sign = (i < 0)) i = -i; - uPtr = u->value; - do { - *uPtr++ = modBase(i); - i = divBase(i); - } while (i != 0); - - u->size = (uPtr - u->value); /* normalize */ - return presult(u); -} diff --git a/test/llvm/cfrac.d/ltop.c b/test/llvm/cfrac.d/ltop.c deleted file mode 100644 index 33eaea569..000000000 --- a/test/llvm/cfrac.d/ltop.c +++ /dev/null @@ -1,25 +0,0 @@ -#include "pdefs.h" -#include "pcvt.h" -#include "precision.h" - -/* - * Long to Precision - */ -precision ltop(l) - register long l; -{ - register digitPtr uPtr; - register precision u = palloc(LONGSIZE); - - if (u == pUndef) return u; - - if (u->sign = (l < 0L)) l = -l; - uPtr = u->value; - do { - *uPtr++ = modBase(l); - l = divBase(l); - } while (l != 0); - - u->size = (uPtr - u->value); /* normalize */ - return presult(u); -} diff --git a/test/llvm/cfrac.d/pabs.c b/test/llvm/cfrac.d/pabs.c deleted file mode 100644 index 674cf1b4e..000000000 --- a/test/llvm/cfrac.d/pabs.c +++ /dev/null @@ -1,22 +0,0 @@ -#include "pdefs.h" /* private include file */ -#include "precision.h" /* public include file for forward refs */ -#include - -/* - * absolute value - */ -precision pabs(u) - register precision u; -{ - register precision w; - - (void) pparm(u); - w = palloc(u->size); - if (w == pUndef) return w; - - w->sign = false; - (void) memcpy(w->value, u->value, u->size * sizeof(digit)); - - pdestroy(u); - return presult(w); -} diff --git a/test/llvm/cfrac.d/padd.c b/test/llvm/cfrac.d/padd.c deleted file mode 100644 index 62b93d504..000000000 --- a/test/llvm/cfrac.d/padd.c +++ /dev/null @@ -1,94 +0,0 @@ -#include "pdefs.h" -#include "precision.h" -#include - -#ifdef ASM_16BIT -#include "asm16bit.h" -#endif - -/* - * Add - * - * This will work correctly if -0 is passed as input - */ -precision padd(u, v) - register precision v; -#ifndef ASM_16BIT - precision u; -{ - register digitPtr wPtr, uPtr, vPtr; -#else - register precision u; -{ - register digitPtr wPtr; - digitPtr uPtr; -#endif - precision w; /* function result */ - register accumulator temp; /* 0 <= temp < 2*base */ - register digit carry; /* 0 <= carry <= 1 */ -#ifdef ASM_16BIT - register int size; -#endif - - (void) pparm(u); - (void) pparm(v); - if (u->sign != v->sign) { /* Are we are actually subtracting? */ - w = pUndef; - if (v->sign) { - v->sign = !v->sign; /* can't generate -0 */ - pset(&w, psub(u, v)); - v->sign = !v->sign; - } else { - u->sign = !u->sign; /* can't generate -0 */ - pset(&w, psub(v, u)); - u->sign = !u->sign; - } - } else { - if (u->size < v->size) { /* u is always biggest number */ - w = u; u = v; v = w; - } - - w = palloc(u->size+1); /* there is at most one added digit */ - if (w == pUndef) return w; /* arguments not destroyed */ - - w->sign = u->sign; - - uPtr = u->value; - wPtr = w->value; -#ifndef ASM_16BIT - vPtr = v->value; - carry = 0; - do { /* Add digits in both args */ - temp = *uPtr++ + *vPtr++; /* 0 <= temp < 2*base-1 */ - temp += carry; /* 0 <= temp < 2*base */ - carry = divBase(temp); /* 0 <= carry <= 1 */ - *wPtr++ = modBase(temp); /* mod has positive args */ - } while (vPtr < v->value + v->size); - - while (uPtr < u->value + u->size) { /* propogate carry */ - temp = *uPtr++ + carry; - carry = divBase(temp); - *wPtr++ = modBase(temp); - } - *wPtr = carry; -#else - size = v->size; - temp = u->size - size; - carry = memaddw(wPtr, uPtr, v->value, size); - if (temp > 0) { - memcpy(wPtr + size, uPtr + size, temp * sizeof(digit)); - if (carry) { - carry = memincw(wPtr + size, temp); - } - } - wPtr[u->size] = carry; /* yes, I do mean u->size */ -#endif - if (carry == 0) { - --(w->size); - } - } - - pdestroy(u); - pdestroy(v); - return presult(w); -} diff --git a/test/llvm/cfrac.d/pcfrac.c b/test/llvm/cfrac.d/pcfrac.c deleted file mode 100644 index db002e0b4..000000000 --- a/test/llvm/cfrac.d/pcfrac.c +++ /dev/null @@ -1,702 +0,0 @@ -/* - * pcfrac: Implementation of the continued fraction factoring algoritm - * - * Every two digits additional appears to double the factoring time - * - * Written by Dave Barrett (barrett%asgard@boulder.Colorado.EDU) - */ -#include -#include -#include - -#ifdef __STDC__ -#include -#endif -#include "precision.h" -#include "pfactor.h" - -extern int verbose; - -unsigned cfracNabort = 0; -unsigned cfracTsolns = 0; -unsigned cfracPsolns = 0; -unsigned cfracT2solns = 0; -unsigned cfracFsolns = 0; - -extern unsigned short primes[]; -extern unsigned primesize; - -typedef unsigned *uptr; -typedef uptr uvec; -typedef unsigned char *solnvec; -typedef unsigned char *BitVector; - -typedef struct SolnStruc { - struct SolnStruc *next; - precision x; /* lhs of solution */ - precision t; /* last large prime remaining after factoring */ - precision r; /* accumulated root of pm for powers >= 2 */ - BitVector e; /* bit vector of factorbase powers mod 2 */ -} Soln; - -typedef Soln *SolnPtr; - -#define BPI(x) ((sizeof x[0]) << 3) - -void setBit(bv, bno, value) - register BitVector bv; - register unsigned bno, value; -{ - bv += bno / BPI(bv); - bno %= BPI(bv); - *bv |= ((value != 0) << bno); -} - -unsigned getBit(bv, bno) - register BitVector bv; - register unsigned bno; -{ - register unsigned res; - - bv += bno / BPI(bv); - bno %= BPI(bv); - res = (*bv >> bno) & 1; - - return res; -} - -BitVector newBitVector(value, size) - register solnvec value; - unsigned size; -{ - register BitVector res; - register solnvec vp = value + size; - unsigned msize = ((size + BPI(res)-1) / BPI(res)) * sizeof res[0]; - - res = (BitVector) malloc(msize); - if (res == (BitVector) 0) return res; - - memset(res, '\0', msize); - do { - if (*--vp) { - setBit(res, vp - value, (unsigned) *vp); - } - } while (vp != value); - return res; -} - -void printSoln(stream, prefix, suffix, pm, m, p, t, e) - FILE *stream; - char *prefix, *suffix; - register unsigned *pm, m; - precision p, t; - register solnvec e; -{ - register unsigned i, j = 0; - - for (i = 1; i <= m; i++) j += (e[i] != 0); - - fputs(prefix, stream); - fputp(stream, pparm(p)); fputs(" = ", stream); - if (*e & 1) putc('-', stream); else putc('+', stream); - fputp(stream, pparm(t)); - - if (j >= 1) fputs(" *", stream); - do { - e++; - switch (*e) { - case 0: break; - case 1: fprintf(stream, " %u", *pm); break; - default: - fprintf(stream, " %u^%u", *pm, (unsigned) *e); - } - pm++; - } while (--m); - - fputs(suffix, stream); - fflush(stream); - pdestroy(p); pdestroy(t); -} - -/* - * Combine two solutions - */ -void combineSoln(x, t, e, pm, m, n, bp) - precision *x, *t, n; - uvec pm; - register solnvec e; - unsigned m; - SolnPtr bp; -{ - register unsigned j; - - (void) pparm(n); - if (bp != (SolnPtr) 0) { - pset(x, pmod(pmul(bp->x, *x), n)); - pset(t, pmod(pmul(bp->t, *t), n)); - pset(t, pmod(pmul(bp->r, *t), n)); - e[0] += getBit(bp->e, 0); - } - e[0] &= 1; - for (j = 1; j <= m; j++) { - if (bp != (SolnPtr) 0) e[j] += getBit(bp->e, j); - if (e[j] > 2) { - pset(t, pmod(pmul(*t, - ppowmod(utop(pm[j-1]), utop((unsigned) e[j]>>1), n)), n)); - e[j] &= 1; - } else if (e[j] == 2) { - pset(t, pmod(pmul(*t, utop(pm[j-1])), n)); - e[j] = 0; - } - } - pdestroy(n); -} - -/* - * Create a normalized solution structure from the given inputs - */ -SolnPtr newSoln(n, pm, m, next, x, t, e) - precision n; - unsigned m; - uvec pm; - SolnPtr next; - precision x, t; - solnvec e; -{ - SolnPtr bp = (SolnPtr) malloc(sizeof (Soln)); - - if (bp != (SolnPtr) 0) { - bp->next = next; - bp->x = pnew(x); - bp->t = pnew(t); - bp->r = pnew(pone); - /* - * normalize e, put the result in bp->r and e - */ - combineSoln(&bp->x, &bp->r, e, pm, m, pparm(n), (SolnPtr) 0); - bp->e = newBitVector(e, m+1); /* BitVector */ - } - - pdestroy(n); - return bp; -} - -void freeSoln(p) - register SolnPtr p; -{ - if (p != (SolnPtr) 0) { - pdestroy(p->x); - pdestroy(p->t); - pdestroy(p->r); - free(p->e); /* BitVector */ - free(p); - } -} - -void freeSolns(p) - register SolnPtr p; -{ - register SolnPtr l; - - while (p != (SolnPtr) 0) { - l = p; - p = p->next; - freeSoln(l); - } -} - -SolnPtr findSoln(sp, t) - register SolnPtr sp; - precision t; -{ - (void) pparm(t); - while (sp != (SolnPtr) 0) { - if peq(sp->t, t) break; - sp = sp->next; - } - pdestroy(t); - return sp; -} - -static unsigned pcfrac_k = 1; -static unsigned pcfrac_m = 0; -static unsigned pcfrac_aborts = 3; - -/* - * Structure for early-abort. Last entry must be <(unsigned *) 0, uUndef> - */ -typedef struct { - unsigned *pm; /* bound check occurs before using this pm entry */ - precision bound; /* max allowable residual to prevent abort */ -} EasEntry; - -typedef EasEntry *EasPtr; - -void freeEas(eas) - EasPtr eas; -{ - register EasPtr ep = eas; - - if (ep != (EasPtr) 0) { - while (ep->pm != 0) { - pdestroy(ep->bound); - ep++; - } - free(eas); - } -} - -/* - * Return Pomerance's L^alpha (L = exp(sqrt(log(n)*log(log(n))))) - */ -double pomeranceLpow(n, y) - double n; - double y; -{ - double lnN = log(n); - double res = exp(y * sqrt(lnN * log(lnN))); - return res; -} - -/* - * Pomerance's value 'a' from page 122 "of Computational methods in Number - * Theory", part 1, 1982. - */ -double cfracA(n, aborts) - double n; - unsigned aborts; -{ - return 1.0 / sqrt(6.0 + 2.0 / ((double) aborts + 1.0)); -} - -/* - * Returns 1 if a is a quadratic residue of odd prime p, - * p-1 if non-quadratic residue, 0 otherwise (gcd(a,p)<>1) - */ -#define plegendre(a,p) ppowmod(a, phalf(psub(p, pone)), p) - -/* - * Create a table of small primes of quadratic residues of n - * - * Input: - * n - the number to be factored - * k - the multiple of n to be factored - * *m - the number of primes to generate (0 to select best) - * aborts - the number of early aborts - * - * Assumes that plegendre # 0, for if it is, that pm is a factor of n. - * This algorithm already assumes you've used trial division to eliminate - * all of these! - * - * Returns: the list of primes actually generated (or (unsigned *) 0 if nomem) - * *m changed to reflect the number of elements in the list - */ -uvec pfactorbase(n, k, m, aborts) - precision n; - unsigned k; - unsigned *m, aborts; -{ - double dn, a; - register unsigned short *primePtr = primes; - register unsigned count = *m; - unsigned maxpm = primes[primesize-1]; - unsigned *res = (uvec) 0, *pm; - precision nk = pnew(pmul(pparm(n), utop(k))); - - if (*m == 0) { /* compute a suitable m */ - dn = ptod(nk); - a = cfracA(dn, aborts); - maxpm = (unsigned) (pomeranceLpow(dn, a) + 0.5); - do { - if ((unsigned) *primePtr++ >= maxpm) break; - } while ((unsigned) *primePtr != 1); - count = primePtr - primes; - primePtr = primes; - } - /* - * This m tends to be too small for small n, and becomes closer to - * optimal as n goes to infinity. For 30 digits, best m is ~1.5 this m. - * For 38 digits, best m appears to be ~1.15 this m. It's appears to be - * better to guess too big than too small. - */ - res = (uvec) malloc(count * sizeof (unsigned)); - if (res == (uvec) 0) goto doneMk; - - pm = res; - *pm++ = (unsigned) *primePtr++; /* two is first element */ - count = 1; - if (count != *m) do { - if (picmp(plegendre(nk, utop((unsigned) *primePtr)), 1) <= 0) { /* 0,1 */ - *pm++ = *primePtr; - count++; - if (count == *m) break; - if ((unsigned) *primePtr >= maxpm) break; - } - ++primePtr; - } while (*primePtr != 1); - *m = count; - -doneMk: - pdestroy(nk); - pdestroy(n); - return res; -} - -/* - * Compute Pomerance's early-abort-stragegy - */ -EasPtr getEas(n, k, pm, m, aborts) - precision n; - unsigned k, *pm, m, aborts; -{ - double x = 1.0 / ((double) aborts + 1.0); - double a = 1.0 / sqrt(6.0 + 2.0 * x); - double ax = a * x, csum = 1.0, tia = 0.0; - double dn, dpval, dbound, ci; - unsigned i, j, pval; - - precision bound = pUndef; - EasPtr eas; - - if (aborts == 0) return (EasPtr) 0; - - eas = (EasPtr) malloc((aborts+1) * sizeof (EasEntry)); - if (eas == (EasPtr) 0) return eas; - - dn = ptod(pmul(utop(k), pparm(n))); /* should this be n ? */ - for (i = 1; i <= aborts; i++) { - eas[i-1].pm = (unsigned *) 0; - eas[i-1].bound = pUndef; - tia += ax; - ci = 4.0 * tia * tia / (double) i; - csum -= ci; - dpval = pomeranceLpow(dn, tia); - dbound = pow(dn, 0.5 * csum); - - pval = (unsigned) (dpval + 0.5); - pset(&bound, dtop(dbound)); - for (j = 0; j < m; j++) { - if (pm[j] >= pval) goto foundpm; - } - break; -foundpm: - if (verbose > 1) { - printf(" Abort %u on p = %u (>=%u) and q > ", i, pm[j], pval); - fputp(stdout, bound); putc('\n', stdout); - fflush(stdout); - } - eas[i-1].pm = &pm[j]; - pset(&eas[i-1].bound, bound); - } - eas[i-1].pm = (unsigned *) 0; - eas[i-1].bound = pUndef; - - pdestroy(bound); - pdestroy(n); - - return eas; -} - -/* - * Factor the argument Qn using the primes in pm. Result stored in exponent - * vector e, and residual factor, f. If non-null, eas points to a list of - * early-abort boundaries. - * - * e is set to the number of times each prime in pm divides v. - * - * Returns: - * -2 - if factoring aborted because of early abort - * -1 - factoring failed - * 0 - if result is a "partial" factoring - * 1 - normal return (a "full" factoring) - */ -int pfactorQ(f, t, pm, e, m, eas) - precision *f; - precision t; - register unsigned *pm; - register solnvec e; - register unsigned m; - EasEntry *eas; -{ - precision maxp = pUndef; - unsigned maxpm = pm[m-1], res = 0; - register unsigned *pp = (unsigned *) 0; - - (void) pparm(t); - - if (eas != (EasEntry *) 0) { - pp = eas->pm; - pset(&maxp, eas->bound); - } - - memset((char *) e, '\0', m * sizeof e[0]); /* looks slow here, but isn't */ - - while (peven(t)) { /* assume 2 1st in pm; save time */ - pset(&t, phalf(t)); - (*e)++; - } - --m; - - do { - e++; pm++; - if (pm == pp) { /* check for early abort */ - if (pgt(t, maxp)) { - res = -2; - goto gotSoln; - } - eas++; - pp = eas->pm; - pset(&maxp, eas->bound); - } - while (pimod(t, (int) *pm) == 0) { - pset(&t, pidiv(t, (int) *pm)); - (*e)++; - } - } while (--m != 0); - res = -1; - if (picmp(t, 1) == 0) { - res = 1; - } else if (picmp(pidiv(t, (int) *pm), maxpm) <= 0) { -#if 0 /* it'll never happen; Honest! If so, pm is incorrect. */ - if (picmp(t, maxpm) <= 0) { - fprintf(stderr, "BUG: partial with t < maxpm! t = "); - fputp(stderr, t); putc('\n', stderr); - } -#endif - res = 0; - } -gotSoln: - pset(f, t); - pdestroy(t); pdestroy(maxp); - return res; -} - -/* - * Attempt to factor n using continued fractions (n must NOT be prime) - * - * n - The number to attempt to factor - * maxCount - if non-null, points to the maximum number of iterations to try. - * - * This algorithm may fail if it get's into a cycle or maxCount expires - * If failed, n is returned. - * - * This algorithm will loop indefinitiely in n is prime. - * - * This an implementation of Morrison and Brillhart's algorithm, with - * Pomerance's early abort strategy, and Knuth's method to find best k. - */ -precision pcfrac(n, maxCount) - precision n; - unsigned *maxCount; -{ - unsigned k = pcfrac_k; - unsigned m = pcfrac_m; - unsigned aborts = pcfrac_aborts; - SolnPtr oddt = (SolnPtr) 0, sp, bp, *b; - EasPtr eas = (EasPtr) 0; - uvec pm = (uvec) 0; - solnvec e = (solnvec) 0; - unsigned bsize, s = 0, count = 0; - register unsigned h, j; - int i; - - precision t = pUndef, - r = pUndef, twog = pUndef, u = pUndef, lastU = pUndef, - Qn = pUndef, lastQn = pUndef, An = pUndef, lastAn = pUndef, - x = pUndef, y = pUndef, qn = pUndef, rn = pUndef; - - precision res = pnew(pparm(n)); /* default res is argument */ - - pm = pfactorbase(n, k, &m, aborts); /* m may have been reduced */ - - bsize = (m+2) * sizeof (SolnPtr); - b = (SolnPtr *) malloc(bsize); - if (b == (SolnPtr *) 0) goto nomem; - - e = (solnvec) malloc((m+1) * sizeof e[0]); - if (e == (solnvec) 0) { -nomem: - errorp(PNOMEM, "pcfrac", "out of memory"); - goto bail; - } - - memset(b, '\0', bsize); /* F1: Initialize */ - if (maxCount != (unsigned *) 0) count = *maxCount; - cfracTsolns = cfracPsolns = cfracT2solns = cfracFsolns = cfracNabort = 0; - - eas = getEas(n, k, pm, m, aborts); /* early abort strategy */ - - if (verbose > 1) { - fprintf(stdout, "factorBase[%u]: ", m); - for (j = 0; j < m; j++) { - fprintf(stdout, "%u ", pm[j]); - } - putc('\n', stdout); - fflush(stdout); - } - - pset(&t, pmul(utop(k), n)); /* E1: Initialize */ - pset(&r, psqrt(t)); /* constant: sqrt(k*n) */ - pset(&twog, padd(r, r)); /* constant: 2*sqrt(k*n) */ - pset(&u, twog); /* g + Pn */ - pset(&lastU, twog); - pset(&Qn, pone); - pset(&lastQn, psub(t, pmul(r, r))); - pset(&An, pone); - pset(&lastAn, r); - pset(&qn, pzero); - - do { -F2: - do { - if (--count == 0) goto bail; - pset(&t, An); - pdivmod(padd(pmul(qn, An), lastAn), n, pNull, &An); /* (5) */ - pset(&lastAn, t); - - pset(&t, Qn); - pset(&Qn, padd(pmul(qn, psub(lastU, u)), lastQn)); /* (7) */ - pset(&lastQn, t); - - pset(&lastU, u); - - pset(&qn, pone); /* eliminate 40% of next divmod */ - pset(&rn, psub(u, Qn)); - if (pge(rn, Qn)) { - pdivmod(u, Qn, &qn, &rn); /* (4) */ - } - pset(&u, psub(twog, rn)); /* (6) */ - s = 1-s; - - e[0] = s; - i = pfactorQ(&t, Qn, pm, &e[1], m, eas); /* E3: Factor Qn */ - if (i < -1) cfracNabort++; - /* - * We should (but don't, yet) check to see if we can get a - * factor by a special property of Qn = 1 - */ - if (picmp(Qn, 1) == 0) { - errorp(PDOMAIN, "pcfrac", "cycle encountered; pick bigger k"); - goto bail; /* we ran into a cycle; give up */ - } - } while (i < 0); /* while not a solution */ - - pset(&x, An); /* End of Algorithm E; we now have solution: */ - - if (i == 0) { /* if partial */ - if ((sp = findSoln(oddt, t)) == (SolnPtr) 0) { - cfracTsolns++; - if (verbose >= 2) putc('.', stderr); - if (verbose > 3) printSoln(stdout, "Partial: ","\n", pm,m,x,t,e); - oddt = newSoln(n, pm, m, oddt, x, t, e); - goto F2; /* wait for same t to occur again */ - } - if (verbose > 3) printSoln(stdout, "Partial: ", " -->\n", pm,m,x,t,e); - pset(&t, pone); /* take square root */ - combineSoln(&x, &t, e, pm, m, n, sp); - cfracT2solns++; - if (verbose) putc('#', stderr); - if (verbose > 2) printSoln(stdout, "PartSum: ", "", pm, m, x, t, e); - } else { - combineSoln(&x, &t, e, pm, m, n, (SolnPtr) 0); /* normalize */ - cfracPsolns++; - if (verbose) putc('*', stderr); - if (verbose > 2) printSoln(stdout, "Full: ", "", pm, m, x, t, e); - } - - /* - * Crude gaussian elimination. We should be more effecient about the - * binary vectors here, but this works as it is. - * - * At this point, t must be pone, or t occurred twice - * - * Loop Invariants: e[0:h] even - * t^2 is a product of squares of primes - * b[h]->e[0:h-1] even and b[h]->e[h] odd - */ - h = m+1; - do { - --h; - if (e[h]) { /* F3: Search for odd */ - bp=b[h]; - if (bp == (SolnPtr) 0) { /* F4: Linear dependence? */ - if (verbose > 3) { - printSoln(stdout, " -->\nFullSum: ", "", pm, m, x, t, e); - } - if (verbose > 2) putc('\n', stdout); - b[h] = newSoln(n, pm, m, bp, x, t, e); - goto F2; - } - combineSoln(&x, &t, e, pm, m, n, bp); - } - } while (h != 0); - /* - * F5: Try to Factor: We have a perfect square (has about 50% chance) - */ - cfracFsolns++; - pset(&y, t); /* t is already sqrt'd */ - - switch (verbose) { - case 0: break; - case 1: putc('/', stderr); break; - case 2: putc('\n', stderr); break; - default: ; - putc('\n', stderr); - printSoln(stdout, " -->\nSquare: ", "\n", pm, m, x, t, e); - fputs("x,y: ", stdout); - fputp(stdout, x); fputs(" ", stdout); - fputp(stdout, y); putc('\n', stdout); - fflush(stdout); - } - } while (peq(x, y) || peq(padd(x, y), n)); /* while x = +/- y */ - - pset(&res, pgcd(padd(x, y), n)); /* factor found at last */ - - /* - * Check for degenerate solution. This shouldn't happen. Detects bugs. - */ - if (peq(res, pone) || peq(res, n)) { - fputs("Error! Degenerate solution:\n", stdout); - fputs("x,y: ", stdout); - fputp(stdout, x); fputs(" ", stdout); - fputp(stdout, y); putc('\n', stdout); - fflush(stdout); - abort(); - } - -bail: - /*malloc_stats();*/ - if (maxCount != (unsigned *) 0) *maxCount = count; - - if (b != (SolnPtr *) 0) for (j = 0; j <= m; j++) freeSoln(b[j]); - freeEas(eas); - freeSolns(oddt); - free(e); - free(pm); - - pdestroy(r); pdestroy(twog); pdestroy(u); pdestroy(lastU); - pdestroy(Qn); pdestroy(lastQn); pdestroy(An); pdestroy(lastAn); - pdestroy(x); pdestroy(y); pdestroy(qn); pdestroy(rn); - pdestroy(t); pdestroy(n); - - return presult(res); -} - -/* - * Initialization for pcfrac factoring method - * - * k - An integer multiplier to use for n (k must be < n) - * you can use findk to get a good value. k should be squarefree - * m - The number of primes to use in the factor base - * aborts - the number of early aborts to use - */ -int pcfracInit(m, k, aborts) - unsigned m; - unsigned k; - unsigned aborts; -{ - pcfrac_m = m; - pcfrac_k = k; - pcfrac_aborts = aborts; - return 1; -} diff --git a/test/llvm/cfrac.d/pcmp.c b/test/llvm/cfrac.d/pcmp.c deleted file mode 100644 index 2c8e0b85f..000000000 --- a/test/llvm/cfrac.d/pcmp.c +++ /dev/null @@ -1,68 +0,0 @@ -#include "pdefs.h" -#include "precision.h" - -/* - * Compare to zero (normalization not assumed) - * - * Returns same as pcmp(u, 0); - */ -int pcmpz(u) - register precision u; -{ - register digitPtr uPtr; - register int i; - - (void) pparm(u); - i = 0; - uPtr = u->value; - do { - if (*uPtr++ != 0) { - if (u->sign) i = -1; else i = 1; - break; - } - } while (uPtr < u->value + u->size); - - pdestroy(u); - return i; -} - -/* - * Compare u to v. - * - * Return: < 0 if u < v - * = 0 if u = v - * > 0 if u > v - * - * This routine is the one that assumes results are normalized! - * - no leading 0's - * - no negative 0 - */ -int pcmp(u, v) - precision u, v; -{ - register digitPtr uPtr, vPtr; - register int i; /* should be bigger than posit */ - - (void) pparm(u); - (void) pparm(v); - if (u->sign != v->sign) { - if (u->sign) i = -1; else i = 1; - } else { - i = u->size - v->size; - if (i == 0) { - uPtr = u->value + u->size; - vPtr = v->value + v->size; - do { - if (*--uPtr != *--vPtr) break; - } while (vPtr > v->value); - if (*uPtr > *vPtr) i = 1; - else if (*uPtr < *vPtr) i = -1; - } - - if (u->sign) i = -i; - } - - pdestroy(u); - pdestroy(v); - return i; -} diff --git a/test/llvm/cfrac.d/pconst.c b/test/llvm/cfrac.d/pconst.c deleted file mode 100644 index c00257017..000000000 --- a/test/llvm/cfrac.d/pconst.c +++ /dev/null @@ -1,38 +0,0 @@ -#include "pdefs.h" - -static precisionType pzeroConst = { - (short) 1, /* refcount (read/write!) */ - (posit) 1, /* size */ - (posit) 1, /* digitcount */ - (boolean) 0, /* sign */ - { (digit) 0 } /* value */ -}; - -static precisionType poneConst = { - (short) 1, /* refcount (read/write!) */ - (posit) 1, /* size */ - (posit) 1, /* digitcount */ - (boolean) 0, /* sign */ - { (digit) 1 } /* value */ -}; - -static precisionType ptwoConst = { - (short) 1, /* refcount (read/write!) */ - (posit) 1, /* size */ - (posit) 1, /* digitcount */ - (boolean) 0, /* sign */ - { (digit) 2 } /* value */ -}; - -static precisionType p_oneConst = { - (short) 1, /* refcount (read/write!) */ - (posit) 1, /* size */ - (posit) 1, /* digitcount */ - (boolean) 1, /* sign */ - { (digit) 1 } /* value */ -}; - -precision pzero = &pzeroConst; /* zero */ -precision pone = &poneConst; /* one */ -precision ptwo = &ptwoConst; /* two */ -precision p_one = &p_oneConst; /* negative one */ diff --git a/test/llvm/cfrac.d/pcvt.h b/test/llvm/cfrac.d/pcvt.h deleted file mode 100644 index e2dd72470..000000000 --- a/test/llvm/cfrac.d/pcvt.h +++ /dev/null @@ -1,32 +0,0 @@ -/* - * Machine dependent file used for conversion routines - * (e.g. atop, ptoa, itop, ptoi, etc) - */ - -/* - * For pXtop: (X = {i,u,l,ul,d}) - */ -#define INTSIZE 2 /* floor(log[Base](2*(MAXINT+1))) */ -#define LONGSIZE 2 /* floor(log[Base](2*(MAXLONG+1))) */ -#define DOUBLESIZE 129 /* double precision size = log[base](HUGE) */ - -/* - * For ptoX - */ -#define MAXINT (int) ((unsigned int) ~0 >> 1) -#define MAXLONG (long) ((unsigned long) ~0 >> 1) -#define MAXUNSIGNED (~ (unsigned int) 0) -#define MAXUNSIGNEDLONG (~ (unsigned long) 0L) - -#define MAXACC (~ (accumulator) 0) - -/* - * aBase - Ascii base (ptoa) - * There are aDigits Ascii digits per precision digit, pDigits. - * At least one of { aDigits, pDigits } <= (MAXINT / the maximum posit value). - */ -#define aDigits 525 /* aDigits/pDigits >~= log[aBase](Base) */ -#define pDigits 109 /* 525/109=4.8165>log[10](65536)=4.816479931 */ -#define aBase 10 /* string conversion base */ -#define aDigit 1000000000 /* must be power of aBase < MAXINT */ -#define aDigitLog 9 /* log[aBase] of aDigit */ diff --git a/test/llvm/cfrac.d/pdefs.h b/test/llvm/cfrac.d/pdefs.h deleted file mode 100644 index 68b385f78..000000000 --- a/test/llvm/cfrac.d/pdefs.h +++ /dev/null @@ -1,114 +0,0 @@ -/* - * +------------------------------------------------------------------+ - * | Private Math Library Definitions | - * +------------------------------------------------------------------+ - */ -/* - * Optional assembly language - */ -#ifdef ASM -#include "machineop.h" /* 16-bit integer machine operations */ -#define uModDiv(n, d, qp) umoddiv16(n, d, qp) /* slight help */ -#else -#define uModDiv(n, d, qp) (*(qp) = (n) / (d), (n) % (d)) -#endif -#define uMul(u, v) ((u) * (v)) /* fast enough */ - -/* - * Optional alternate memory allocator - */ -#ifndef MYALLOC -#define allocate(size) (char *) malloc(size) -#define deallocate(p) free(p) -#else -extern char *allocate(); -extern void deallocate(); -#endif - -/* - * These next four types are used only used in this include file - */ -typedef unsigned char u8; /* 8 bits */ -typedef unsigned short u16; /* 16 bits */ -typedef unsigned long u32; /* 32 bits */ -typedef u8 boolean; /* 1 bit */ - -#define BASE 65536 /* Base * (Base-1) <= MAXINT */ - -/* - * Operations on Base (unsigned math) - */ -#define modBase(u) ((u) & 0xffff) /* remainder on Base */ -#define divBase(u) ((u) >> 16) /* divide by Base */ -#define mulBase(u) ((u) << 16) /* multiply by Base */ - -/* - * The type of a variable used to store intermediate results. - * This should be the most efficient unsigned int on your machine. - */ -typedef u32 accumulator; /* 0..(Base * Base) - 1 */ - -/* - * The type of a single digit - */ -typedef u16 digit; /* 0..Base-1 */ - -/* - * The type of a digit index (the largest number of digits - 1) - * Determines the maximum representable precision (not usually changed) - */ -typedef u16 posit; /* 0..size */ - -typedef unsigned short prefc; /* in precision.h also */ -/* - * End of area which needs to be modified - */ - -#define false 0 -#define true 1 - -typedef digit digitString[1]; /* dummy array type */ -typedef digit *digitPtr; - -/* - * A normalized integer has the following attributes: - * -0 cannot occur - * all digits >= size assumed to be 0. (no leading zero's) - * size > 0 - */ -typedef struct { - prefc refcount; /* reference count (must be 1st [for pref]) */ - posit alloc; /* allocated size */ - posit size; /* number of digits */ - boolean sign; /* sign: TRUE negative */ - digitString value; -} precisionType; - -typedef precisionType *precision; - -/* - * Overlay for cache of precisions - */ -typedef struct { - precision next; /* next item in list */ - short count; /* number of items in this sublist */ -} cacheType; - -typedef cacheType *cachePtr; -/* - * Maximum total memory consumed by cache = - * LIMIT * (1 + SIZE * (PrecisionSize + sizeof(digit) * (SIZE-1) / 2)) - */ -#ifndef CACHESIZE -#define CACHESIZE 32 /* size of allocation cache */ -#endif -#define CACHELIMIT 128 /* Determines max mem used by cache */ - -#define PrecisionSize (sizeof(precisionType) - sizeof(digitString)) - -/* - * Function definitions are all in the global include file "mathdefs.h". - */ -extern precision palloc(); /* semi-private */ -extern int pfree(); /* semi-private */ -extern void pnorm(); /* semi-private */ diff --git a/test/llvm/cfrac.d/pdivmod.c b/test/llvm/cfrac.d/pdivmod.c deleted file mode 100644 index ce4a24b16..000000000 --- a/test/llvm/cfrac.d/pdivmod.c +++ /dev/null @@ -1,315 +0,0 @@ -#include "pdefs.h" -#include "precision.h" - -#ifdef DEBUG -#include -#endif - -#ifdef ASM_16BIT -#include "asm16bit.h" -#endif - -/* - * Divide u (dividend) by v (divisor); If non-null, qp and rp are set to - * quotient and remainder. The result returned will be *qp, unless qp is - * NULL, then *rp will be returned if non-null, otherwise pUndef is returned. - * - * Produce: - * - * q (quotient) = u div v (v != 0) - * truncation is toward zero - * - * r (remainder) = u mod v - * = u - u div v * v (v != 0) - * = u (v == 0) - * ( e.g. u == q*v + r ) - * remainder has same sign and dividend - * - * Note: this has opposite convention than the C standard div fuction, - * but the same convention of the typical C "/" operator - * It is also inconvienient for the mod function. - */ -/* - * This algorithm is taken almost verbatum from Knuth Vol 2. - * Please note the following trivial(?) array index - * transformations (since MSD to LSD order is reversed): - * - * q[0..m] to Q[0..m] thus q[i] == Q[m-i] - * r[1..n] R[0..n-1] r[i] == R[n+1-i] - * u[0..m+n] w[0..m+n] u[i] == w[m+n-i] - * v[1..n] x[0..n-1] v[i] == x[n-i] - * - * let N == n - 1 so that n == N + 1 thus: - * - * q[0..m] to Q[0..m] thus q[i] == Q[m-i] - * r[1..n] R[0..N] r[i] == R[N+2-i] - * u[0..m+n] w[0..m+N+1] u[i] == w[m+N+1-i] - * v[1..n] x[0..N] v[i] == x[N+1-i] - */ - -/* - * Note: Be very observent of the usage of uPtr, and vPtr. - * They are used to point to u, v, w, q or r as necessary. - */ -precision pdivmod(u, v, qp, rp) - precision u, v, *qp, *rp; -{ - register digitPtr uPtr, vPtr, qPtr, LastPtr; - - register accumulator temp; /* 0 <= temp < base^2 */ - register digit carry; /* 0 <= carry < 2 */ - register digit hi; /* 0 <= hi < base */ - - register posit n, m; - digit d; /* 0 <= d < base */ - digit qd; /* 0 <= qd < base */ -#ifdef DEBUG - int i; -#endif - - precision q, r, w; /* quotient, remainder, temporary */ - - n = v->size; /* size of v and r */ - - (void) pparm(u); - (void) pparm(v); - if (u->size < n) { - q = pUndef; - r = pUndef; - pset(&q, pzero); - pset(&r, u); - goto done; - } - - m = u->size - n; - - uPtr = u->value + m + n; - vPtr = v->value + n; - - q = palloc(m + 1); - if (q == pUndef) return q; - - q->sign = (u->sign != v->sign); /* can generate -0 */ - - r = palloc(n); - if (r == pUndef) { - pdestroy(q); - return r; - } - r->sign = u->sign; -/* - * watch out! does this function return: q=floor(a/b) or trunc(a/b)? - * it's currently the latter, but every mathmaticion I have talked to - * prefers the former so that a % b returns between 0 to b-1. The - * problem is that this is slower and disagrees with C common practice. - */ - qPtr = q->value + m + 1; - - if (n == 1) { - d = *--vPtr; /* d is only digit of v */ - if (d == 0) { /* divide by zero? */ - q = pnew(errorp(PDOMAIN, "pdivmod", "divide by zero")); - } else { /* single digit divide */ -#ifndef ASM_16BIT - vPtr = r->value + n; - hi = 0; /* hi is current remainder */ - do { - temp = mulBase(hi); /* 0 <= temp <= (base-1)^2 */ - temp += *--uPtr; /* 0 <= temp <= base(base-1) */ - hi = uModDiv(temp, d, --qPtr); /* 0 <= hi < base */ - } while (uPtr > u->value); - *--vPtr = hi; -#else - qPtr -= m + 1; - *(r->value) = memdivw1(qPtr, u->value, m + 1, d); -#endif - } - } else { /* muti digit divide */ - /* - * normalize: multiply u and v by d so hi digit of v > b/2 - */ - d = BASE / (*--vPtr+1); /* high digit of v */ - - w = palloc(n); /* size of v */ - if (w == pUndef) return w; - -#ifndef ASM_16BIT - vPtr = v->value; - uPtr = w->value; /* very confusing. just a temp */ - LastPtr = vPtr + n; - hi = 0; - do { /* single digit multiply */ - temp = uMul(*vPtr++, d); /* 0<= temp <= base(base-1)/2 */ - temp += hi; /* 0 <= temp <= (base^2-1)/2 */ - hi = divBase(temp); /* 0 <= hi < base / 2 */ - *uPtr++ = modBase(temp); /* 0 <= hi < base / 2 */ - } while (vPtr < LastPtr); /* on exit hi == 0 */ -#else - hi = memmulw1(w->value, v->value, n, d); -#endif - - pset(&v, w); - pdestroy(w); - - w = palloc(m + n + 1); - if (w == pUndef) return w; - -#ifndef ASM_16BIT - uPtr = u->value; - vPtr = w->value; /* very confusing. just a temp */ - LastPtr = uPtr + m + n; - do { /* single digit multiply */ - temp = uMul(*uPtr++, d); - temp += hi; - hi = divBase(temp); - *vPtr++ = modBase(temp); - } while (uPtr < LastPtr); - *vPtr = hi; /* note extra digit */ -#else - hi = memmulw1(w->value, u->value, m + n, d); - w->value[m + n] = hi; -#endif - - pset(&u, w); - pdestroy(w); - -#ifdef DEBUG - printf("m = %d n = %d\nd = %d\n", m, n, d); - printf("norm u = "); pshow(u); - printf("norm v = "); pshow(v); -#endif - - uPtr = u->value + m + 1; /* current least significant digit */ - do { - --uPtr; -#ifdef DEBUG - printf(" u = "); - for (i = n; i >= 0; --i) printf("%.*x ", sizeof(digit) * 2, uPtr[i]); - putchar('\n'); - printf(" v = "); - for (i = 1; i < 3; i++) printf("%.*x ", sizeof(digit) * 2, - v->value[n-i]); - putchar('\n'); -#endif -#ifndef ASM_16BIT - vPtr = v->value + n; - LastPtr = uPtr + n; - if (*LastPtr == *--vPtr) { /* guess next digit */ - qd = BASE - 1; - } else { - temp = mulBase(*LastPtr); - temp += *--LastPtr; /* 0 <= temp< base^2 */ - temp = uModDiv(temp, *vPtr, &qd); - --vPtr; - --LastPtr; - while (uMul(*vPtr, qd) > mulBase(temp) + *LastPtr) { - --qd; - temp += vPtr[1]; - if (temp >= BASE) break; /* if so, vPtr*qd <= temp*base */ - } - LastPtr += 2; - } - /* - * Single digit Multiply then Subtract - */ - vPtr = v->value; - carry = 1; /* noborrow bit */ - hi = 0; /* hi digit of multiply */ - do { - /* multiply */ - temp = uMul(qd, *vPtr++); /* 0 <= temp <= (base-1)^2 */ - temp += hi; /* 0 <= temp <= base(base-1) */ - hi = divBase(temp); - temp = modBase(temp); - /* subtract */ - temp = (BASE-1) - temp; /* 0 <= temp < base */ - temp += *uPtr + carry; /* 0 <= temp < 2*base */ - carry = divBase(temp); - *uPtr++ = modBase(temp); /* 0 <= carry < 2 */ - } while (uPtr < LastPtr); - temp = (BASE-1) - hi; - temp += *uPtr + carry; - carry = divBase(temp); - *uPtr = modBase(temp); - uPtr -= n; -#else -#if 0 - carry = !memmulsubw(uPtr, v->value, n, qd); /* 1 if noborrow */ -#endif - carry = !memdivw(uPtr, v->value, n, &qd); /* 1 if noborrow */ -#endif -#ifdef DEBUG - printf(" qhat = %.*x\n", sizeof(digit) * 2, qd); - printf(" new u = "); - for (i = n; i >= 0; --i) printf("%.*x ", sizeof(digit) * 2, uPtr[i]); - putchar('\n'); -#endif - if (carry == 0) { /* Test remainder, add back */ - vPtr = v->value; - LastPtr = uPtr + n; - do { - temp = *uPtr + *vPtr++; - temp += carry; - carry = divBase(temp); - *uPtr++ = modBase(temp); - } while (uPtr < LastPtr); - *uPtr += carry - BASE; /* real strange but works */ - uPtr -= n; - --qd; -#ifdef DEBUG - printf(" decrementing q...adding back\n"); - printf(" fixed u = "); - for (i = n; i >= 0; --i) printf("%.*x ", sizeof(digit) * 2, uPtr[i]); - putchar('\n'); - printf(" newq = %.*x\n", sizeof(digit) * 2, qd); -#endif - } - *--qPtr = qd; /* one leading zero possible */ -#ifdef DEBUG - putchar('\n'); -#endif - } while (uPtr > u->value); - - /* - * Un-normalize to get remainder - */ -#ifndef ASM_16BIT - uPtr = u->value + n; /* skip hi digit (it's zero) */ - vPtr = r->value + n; - hi = 0; /* hi is current remainder */ - do { /* single digit divide */ - temp = mulBase(hi); /* 0<=temp < base^2-(base-1) */ - temp += *--uPtr; /* 0 <= temp < base^2 */ - hi = uModDiv(temp, d, --vPtr); - } while (uPtr > u->value); /* carry will be zero */ -#else - carry = memdivw1(r->value, u->value, n, d); /* always 0 */ -#endif - pnorm(r); /* remainder may have many leading 0's */ - } - - if (m > 0 && qPtr[m] == 0) { - --(q->size); /* normalize */ - } - if (q->size == 1 && *qPtr == 0) q->sign = false; - -done: - - pdestroy(u); - pdestroy(v); - - if (rp == (precision *) -1) { - if (qp != pNull) pset(qp, q); - pdestroy(q); - return presult(r); - } else if (qp == (precision *) -1) { - if (rp != pNull) pset(rp, r); - pdestroy(r); - return presult(q); - } - if (qp != pNull) pset(qp, q); - if (rp != pNull) pset(rp, r); - pdestroy(q); - pdestroy(r); - return pUndef; -} diff --git a/test/llvm/cfrac.d/pfactor.c b/test/llvm/cfrac.d/pfactor.c deleted file mode 100644 index 6c765d158..000000000 --- a/test/llvm/cfrac.d/pfactor.c +++ /dev/null @@ -1,55 +0,0 @@ -#include -#include "precision.h" -#include "pfactor.h" - -void showfactors(); - - -int main(argc, argv) - int argc; - char *argv[]; -{ - precision n = pUndef; - - --argc; - if (argc != 0) { - do { - pset(&n, atop(*++argv)); - showfactors(n); - } while (--argc > 0); - } else { - do { - pset(&n, fgetp(stdin)); - if (n == pUndef) break; - showfactors(n); - } while (1); - } - pdestroy(n); - return 0; -} - -void showfactors(n) - precision n; -{ - precision r = pUndef; - FactorList factors = (FactorList) 0; - - (void) pparm(n); - pset(&r, ptrial(n, (unsigned *) 0, &factors)); - fputp(stdout, n); - fputs(" = ", stdout); - pputfactors(stdout, factors); - if pne(r, pone) { - if pne(r, n) putc('*', stdout); - if (!pprime(r, 16)) { - fputc('(', stdout); fputp(stdout, r); fputc(')', stdout); - } else { - fputp(stdout, r); - } - } - putc('\n', stdout); - - pfreefactors(&factors); - pdestroy(r); - pdestroy(n); -} diff --git a/test/llvm/cfrac.d/pfactor.h b/test/llvm/cfrac.d/pfactor.h deleted file mode 100644 index edd5686e8..000000000 --- a/test/llvm/cfrac.d/pfactor.h +++ /dev/null @@ -1,62 +0,0 @@ -typedef struct Pfs { - struct Pfs *next; - precision factor; - unsigned count; -} Pfactor; - -typedef Pfactor *FactorPtr; -typedef FactorPtr FactorList; -typedef precision (*pfunc)(); /* pointer to func returning precision */ - -#ifndef __STDC__ - -extern int pprime(); /* test whether a number is prime */ -extern precision pnextprime(); /* next prime >= it's argument */ - -extern precision pgcd(); /* greatest common divisor */ -extern precision plcm(); /* least common multiple */ -extern precision peuclid(); /* extended euclid's algorithm */ - -extern precision prho(); /* find factor using rho method */ -extern precision pfermat(); /* find factor using Fermat's method */ -extern precision pcfrac(); /* factor w/continued fractions */ - -extern int prhoInit(); /* alter parameters for rho method */ -extern int pcfracInit(); /* alter paramteres for cfrac method */ - -extern precision ptrial(); /* find factors using trial division */ -extern precision prfactor(); /* recursively factor a number */ - -extern void paddfactor(); /* add a factor to a factorlist */ -extern void pputfactors(); /* print a factorlist */ -extern void pfreefactors(); /* return a factorlist to memory */ - -#else - -extern int pprime(precision, unsigned trialCount); -extern precision pnextprime(precision, unsigned trialCount); - -extern precision pgcd(precision, precision); -extern precision plcm(precision, precision); -extern precision peuclid(precision, precision, precision *, precision *); - -extern precision prho(precision n, unsigned *maxCount); -extern precision pfermat(precision n, unsigned *maxCount); -extern precision pcfrac(precision n, unsigned *maxCount); - -extern int prhoInit(precision c, unsigned batchSize); -extern int pcfracInit(unsigned m, unsigned k, unsigned aborts); - -extern precision ptrial(precision n, unsigned *maxCount, FactorList *); -extern precision prfactor(precision, unsigned *maxCount, pfunc, FactorList *); - -extern void paddfactor(FactorList *, precision); -extern void pfreefactors(FactorList *); - -#ifndef BUFSIZE -#include -#endif - -extern void pputfactors(FILE *, FactorList); - -#endif diff --git a/test/llvm/cfrac.d/pfloat.c b/test/llvm/cfrac.d/pfloat.c deleted file mode 100644 index 63f434456..000000000 --- a/test/llvm/cfrac.d/pfloat.c +++ /dev/null @@ -1,61 +0,0 @@ -/* - * High Precision Math Library Supplement for floating point routines - */ -#include -#include -#include "pdefs.h" -#include "pcvt.h" -#include "precision.h" - -extern precision palloc(); - -/* - * double to precision - */ -precision dtop(f) - register double f; -{ - register digitPtr uPtr; - register precision u; - - u = palloc(DOUBLESIZE); /* pretty big */ - if (u == pUndef) return u; - - if (f < 0.0) { - f = -f; - u->sign = true; - } else { - u->sign = false; - } - uPtr = u->value; - do { - *uPtr++ = fmod(f, (double) BASE); - f = floor(f / (double) BASE); - } while (f != 0.0); - - u->size = (uPtr - u->value); - - return presult(u); -} - -/* - * precision to double (no overflow check) - */ -double ptod(u) - precision u; -{ - register digitPtr uPtr; - register double f; - - (void) pparm(u); - uPtr = u->value + u->size; - f = 0.0; - do { - f = f * (double) BASE + (double) *--uPtr; - } while (uPtr > u->value); - - if (u->sign) f = -f; - - pdestroy(u); - return f; -} diff --git a/test/llvm/cfrac.d/pgcd.c b/test/llvm/cfrac.d/pgcd.c deleted file mode 100644 index a72a8a75c..000000000 --- a/test/llvm/cfrac.d/pgcd.c +++ /dev/null @@ -1,24 +0,0 @@ -#include "precision.h" - -/* - * Euclid's Algorithm - * - * Given u and v, calculated and return their greatest common divisor. - */ -precision pgcd(u, v) - precision u, v; -{ - precision u3 = pnew(pabs(pparm(u))), v3 = pnew(pabs(pparm(v))); - precision q = pUndef, r = pUndef; - - while (pnez(v3)) { - pdivmod(u3, v3, &q, &r); - pset(&u3, v3); - pset(&v3, r); - } - - pdestroy(v3); - pdestroy(q); pdestroy(r); - pdestroy(u); pdestroy(v); - return presult(u3); /* result always positive */ -} diff --git a/test/llvm/cfrac.d/phalf.c b/test/llvm/cfrac.d/phalf.c deleted file mode 100644 index 8658de599..000000000 --- a/test/llvm/cfrac.d/phalf.c +++ /dev/null @@ -1,36 +0,0 @@ -#include -#include "pdefs.h" -#include "precision.h" - -#ifdef ASM_16BIT -#include "asm16bit.h" -#endif - -/* - * Divide a precision by 2 - */ -precision phalf(u) - register precision u; -{ -#ifdef ASM_16BIT - register precision w; - register posit usize; - - pparm(u); - usize = u->size; - w = palloc(usize); - if (w == pUndef) return w; - - w->sign = u->sign; - (void) memcpy(w->value, u->value, usize * sizeof(digit)); - - memlsrw(w->value, usize); /* 68000 assembly language routine */ - if (usize > 1 && w->value[usize-1] == (digit) 0) { /* normalize */ - --(w->size); - } - pdestroy(u); - return presult(w); -#else - return pdiv(u, ptwo); -#endif -} diff --git a/test/llvm/cfrac.d/picmp.c b/test/llvm/cfrac.d/picmp.c deleted file mode 100644 index b94226843..000000000 --- a/test/llvm/cfrac.d/picmp.c +++ /dev/null @@ -1,41 +0,0 @@ -#include "pdefs.h" -#include "precision.h" - -static char cmpError[] = "Second arg not single digit"; - -/* - * Single-digit compare - */ -int picmp(u, v) - register precision u; - register int v; -{ - register int i; - - (void) pparm(u); - - if (u->sign) { - i = -1; - if (v < 0) { - if (-v >= BASE) { - errorp(PDOMAIN, "picmp", cmpError); - } - if (u->size == 1) { - i = - (int) *(u->value) - v; - } - } - } else { - i = 1; - if (v >= 0) { - if (v >= BASE) { - errorp(PDOMAIN, "picmp", cmpError); - } - if (u->size == 1) { - i = (int) *(u->value) - v; - } - } - } - - pdestroy(u); - return i; -} diff --git a/test/llvm/cfrac.d/pidiv.c b/test/llvm/cfrac.d/pidiv.c deleted file mode 100644 index 61c09a750..000000000 --- a/test/llvm/cfrac.d/pidiv.c +++ /dev/null @@ -1,60 +0,0 @@ -#include "pdefs.h" -#include "precision.h" -#ifdef ASM_16BIT -#include "asm16bit.h" -#endif - -/* - * Single-digit divide - */ -precision pidiv(u, v) - register precision u; - int v; -{ -#ifndef ASM_16BIT - register digitPtr uPtr, qPtr; - register accumulator temp; /* 0 <= temp < base^2 */ -#endif - register digit r, d; /* 0 <= r,d < base */ - register posit m; - register precision q; - - (void) pparm(u); - - if (v < 0) d = (digit) -v; else d = (digit) v; - if (d >= BASE) { - q = pnew(errorp(PDOMAIN, "pidiv", "divisor too big for single digit")); - goto done; - } - if (d == 0) { - q = pnew(errorp(PDOMAIN, "pidiv", "divide by zero")); - goto done; - } - m = u->size; - q = palloc(m); - if (q == pUndef) goto done; - -#ifndef ASM_16BIT - qPtr = q->value + m; - uPtr = u->value + m; - r = 0; /* r is current remainder */ - do { - temp = mulBase(r); /* 0 <= temp <= (base-1)^2 */ - temp += *--uPtr; /* 0 <= temp <= base(base-1) */ - r = uModDiv(temp, d, --qPtr); /* 0 <= r < base */ - } while (uPtr > u->value); -#else - r = memdivw1(q->value, u->value, m, d); -#endif - /* - * normalize q - */ - if (m > 1 && q->value[m-1] == 0) { - --(q->size); - } - q->sign = (u->sign != (v < 0)); - if (q->size == 1 && *(q->value) == 0) q->sign = false; -done: - pdestroy(u); - return presult(q); -} diff --git a/test/llvm/cfrac.d/pimod.c b/test/llvm/cfrac.d/pimod.c deleted file mode 100644 index b26536d3c..000000000 --- a/test/llvm/cfrac.d/pimod.c +++ /dev/null @@ -1,48 +0,0 @@ -#include "pdefs.h" -#include "precision.h" -#ifdef ASM_16BIT -#include "asm16bit.h" -#endif - -/* - * Single-digit remainder - */ -int pimod(u, v) - register precision u; - int v; -{ -#ifndef ASM_16BIT - register digitPtr uPtr; - register accumulator temp; /* 0 <= temp < base^2 */ -#endif - register digit r = 0, d; /* 0 <= r,d < base */ - register int res = 0; - - (void) pparm(u); - if (v < 0) d = (digit) -v; else d = (digit) v; - if (d >= BASE) { - errorp(PDOMAIN, "pimod", "divisor too big for single digit"); - goto done; - } - if (d == 0) { - errorp(PDOMAIN, "pimod", "divide by zero"); - goto done; - } -#ifndef ASM_16BIT - uPtr = u->value + u->size; - r = 0; /* r is current remainder */ - do { - temp = mulBase(r); /* 0 <= temp <= (base-1)^2 */ - temp += *--uPtr; /* 0 <= temp <= base(base-1) */ - r = temp % d; /* 0 <= r < base */ - } while (uPtr > u->value); -#else - r = memmodw1(u->value, u->size, d); -#endif - - res = (int) r; - if (u->sign) res = -res; -done: - pdestroy(u); - return res; -} diff --git a/test/llvm/cfrac.d/pio.c b/test/llvm/cfrac.d/pio.c deleted file mode 100644 index 16b5bdaf1..000000000 --- a/test/llvm/cfrac.d/pio.c +++ /dev/null @@ -1,165 +0,0 @@ -#include -#include -#include -#include "pdefs.h" -#include "pcvt.h" -#include "precision.h" - -/* - * Output a string to a file. - * - * Returns: - * the number of characters written - * or EOF if error - */ -static int fouts(stream, chp) - FILE *stream; - register char *chp; -{ - register int count = 0, res = 0; - - if (chp != (char *) 0 && *chp != '\0') do { - count++; - res = putc(*chp, stream); - } while (*++chp != '\0' && res != EOF); - - if (res != EOF) res = count; - return res; -} - -/* - * output the value of a precision to a file (no cr or whitespace) - * - * Returns: - * The number of characters output or EOF if error - */ -int fputp(stream, p) - FILE *stream; - precision p; -{ - int res; - char *chp = ptoa(pparm(p)); - - res = fouts(stream, chp); - deallocate(chp); - pdestroy(p); - return res; -} - -/* - * Output a precision to stdout with a newline (useful from debugger) - */ -int putp(p) - precision p; -{ - int res; - char *chp = ptoa(pparm(p)); - - res = fouts(stdout, chp); - res = putc('\n', stdout); - deallocate(chp); - pdestroy(p); - return res; - -} - -/* - * Output a justified precision - * - * Returns: The number of characters in the precision, or EOF if error - */ -int fprintp(stream, p, minWidth) - FILE *stream; - precision p; - register int minWidth; -{ - int res; - char *chp = ptoa(pparm(p)); - int len; - - len = strlen(chp); - if (minWidth < 0) { /* left-justified */ - res = fouts(stream, chp); - while (minWidth++ < -len) { - putc(' ', stream); - } - } else { - while (minWidth-- > len) { /* right-justified */ - putc(' ', stream); - } - res = fouts(stream, chp); - } - - deallocate(chp); - pdestroy(p); - return res; -} - - -/* - * Read in a precision type - same as atop but with io - * - * leading whitespace skipped - * an optional leading '-' or '+' followed by digits '0'..'9' - * leading 0's Ok - * stops at first unrecognized character - * - * Returns: pUndef if EOF or invalid argument (NULL or nondigit as 1st digit) - */ -precision fgetp(stream) - FILE *stream; -{ - precision res = pUndef; - precision clump = pUndef; - int sign = 0; - register int ch; - register accumulator temp, x; - register int j; - - ch = getc(stream); - if (ch != EOF) { - while (isspace(ch)) ch = getc(stream); /* skip whitespace */ - if (ch == '-') { - sign = 1; - ch = getc(stream); - } else if (ch == '+') { - ch = getc(stream); - } - if (isdigit(ch)) { - pset(&res, pzero); - pset(&clump, utop(aDigit)); - do { - j = aDigitLog-1; - temp = ch - '0'; - do { - if (!isdigit(ch = getc(stream))) goto atoplast; - temp = temp * aBase + (ch - '0'); - } while (--j > 0); - pset(&res, padd(pmul(res, clump), utop(temp))); - } while (isdigit(ch = getc(stream))); - goto atopdone; -atoplast: - x = aBase; - while (j++ < aDigitLog-1) { - x *= aBase; - } - pset(&res, padd(pmul(res, utop(x)), utop(temp))); -atopdone: - if (ch != EOF) ungetc(ch, stream); - if (sign) { - pset(&res, pneg(res)); - } - } else { - if (ch == EOF) { - res = pUndef; - } else { - ungetc(ch, stream); - } - } - } else { - res = pUndef; - } - pdestroy(clump); - if (res == pUndef) return res; - return presult(res); -} diff --git a/test/llvm/cfrac.d/pmul.c b/test/llvm/cfrac.d/pmul.c deleted file mode 100644 index e69a36629..000000000 --- a/test/llvm/cfrac.d/pmul.c +++ /dev/null @@ -1,84 +0,0 @@ -#include "pdefs.h" -#include "precision.h" -#include - -#ifdef ASM_16BIT -#include "asm16bit.h" -#endif - -/* - * Multiply u by v (assumes normalized) - */ -precision pmul(u, v) - register precision v; /* register a5 on 68000 */ -#ifdef ASM_16BIT - register precision u; /* register a4 */ -{ -#else - precision u; -{ - digitPtr vPtr; - register digitPtr uPtr, wPtr, HiDigit; - register accumulator temp; /* 0 <= temp < base * base */ /* d7 */ - register digit vdigit; /* d6 */ -#endif - register digit hi; /* 0 <= hi < base */ /* d5 */ - precision w; - - (void) pparm(u); - (void) pparm(v); - /* - * Check for multiply by zero. Helps prevent wasted storage and -0 - */ - if (peqz(u) || peqz(v)) { - w = palloc(1); - if (w == pUndef) return w; - - w->sign = false; - w->value[0] = 0; - } else { - if (u->size < v->size) { /* u is biggest number (for inner loop speed) */ - w = u; u = v; v = w; - } - - w = palloc(u->size + v->size); - if (w == pUndef) return w; - - w->sign = (u->sign != v->sign); - -#ifndef ASM_16BIT - uPtr = u->value; - vPtr = v->value; - wPtr = w->value + u->size; /* this is correct! */ - do { - *--wPtr = 0; - } while (wPtr > w->value); - - vPtr = v->value; - HiDigit = u->value + u->size; - do { - uPtr = u->value; - wPtr = w->value + (vPtr - v->value); - hi = 0; - vdigit = *vPtr; - do { - temp = uMul(vdigit, *uPtr++); /* 0 <= temp <= (base-1)^2 */ - temp += *wPtr; /* 0 <= temp <= base(base-1) */ - temp += hi; /* 0 <= temp < base * base */ - hi = divBase(temp); /* 0 <= hi < base */ - *wPtr++ = modBase(temp); - } while (uPtr < HiDigit); - *wPtr++ = hi; - } while (++vPtr < v->value + v->size); -#else - hi = memmulw(w->value, u->value, u->size, v->value, v->size); -#endif - if (hi == 0) { - --(w->size); /* normalize */ - } - } - - pdestroy(u); - pdestroy(v); - return presult(w); -} diff --git a/test/llvm/cfrac.d/pneg.c b/test/llvm/cfrac.d/pneg.c deleted file mode 100644 index c78106610..000000000 --- a/test/llvm/cfrac.d/pneg.c +++ /dev/null @@ -1,25 +0,0 @@ -#include "pdefs.h" /* private include file */ -#include "precision.h" /* public include file for forward refs */ -#include - -/* - * negation - */ -precision pneg(u) - register precision u; -{ - precision w; - - (void) pparm(u); - w = palloc(u->size); - if (w == pUndef) return w; - - w->sign = u->sign; - if (pnez(u)) { /* don't create a negative 0 */ - w->sign = !w->sign; - } - (void) memcpy(w->value, u->value, u->size * sizeof(digit)); - - pdestroy(u); - return presult(w); -} diff --git a/test/llvm/cfrac.d/podd.c b/test/llvm/cfrac.d/podd.c deleted file mode 100644 index def95b491..000000000 --- a/test/llvm/cfrac.d/podd.c +++ /dev/null @@ -1,16 +0,0 @@ -#include "pdefs.h" -#include "precision.h" - -/* - * Returns non-zero if u is odd - */ -int podd(u) - precision u; -{ - register int res; - - (void) pparm(u); - res = (*(u->value) & 1); - pdestroy(u); - return res; -} diff --git a/test/llvm/cfrac.d/pops.c b/test/llvm/cfrac.d/pops.c deleted file mode 100644 index e0f204100..000000000 --- a/test/llvm/cfrac.d/pops.c +++ /dev/null @@ -1,317 +0,0 @@ -#ifdef DEBUGOPS -#include -#endif -/* - * High Precision Math Library - * - * Written by Dave Barrett 2/23/83 - * Translated from modcal to pascal 4/30/84 - * Mod portability fixed; removed floor function 5/14/84 - * Fixed numerous bugs and improved robustness 5/21/84 - * Translated to C 6/14/84 - * Changed precision to be determined at run-time 5/19/85 - * Added dynamic allocation 7/21/85 - * Combined unsigned math and integer math 8/01/85 - * Fixed Bug in pcmp 7/20/87 - * Fixed handling of dynamic storage (refcount added) 7/20/87 - * Final debugging of current version 8/22/87 - * Fixed many bugs in various routines, wrote atop 2/07/89 - * Tuned for speed, fixed overflow problems 3/01/89 - * Removed refcounts, more tuning, removed pcreate 3/16/89 - * Added cmp macros, change name of pzero, added pshift 4/29/89 - * Repaired operation order bugs in pdiv, calc.c 5/15/91 - * Added pdiv macro, split out pcmp, pabs, much cleanup 5/21/91 - * - * warning! The mod operation with negative arguments not portable. - * I have therefore avoided it completely with much pain. - * - * The following identities have proven useful: - * - * given: a % b = a - floor(a/b) * b - * then : -a % -b = -(a % b) - * -a % b = -( a % -b) = b - a % b (a % b != 0) - * a % -b = -(-a % b) = a % b - b (a % b != 0) - * - * given: a % b = a - a / b * b - * then : -a % -b = -a % b = -(a % b) - * a % -b = a % b - * - * Also, be very careful of computations in the inner loops. Much - * work has been done to make sure the compiler does not re-arrange - * expressions to cause an overflow. The compiler may still be doing - * unnecessary type conversions. - * - * NOTES: - * - * The ptoa routine creates storage which is likely to be forgotton. - * - * A function returning a result must use the result. If it doesn't - * the storage is never freed. For example: itop(2); by itself - * You must make sure to pdestroy the result. - * - * An error (out of storage) fails to deallocate u and v. - * - * psub, pcmp, pdiv, and pmul all assume normalized arguments. - * - * This file contains the storage management-specific code: - * palloc, pfree, pset -- together these account for 45% of execution time - */ -#include -#include "pdefs.h" /* private include file */ -#include "precision.h" /* public include file for forward refs */ - -cacheType pcache[CACHESIZE]; -static char ident[] = - " @(#) libprecision.a version 2.00 3-May-91 by Dave Barrett\n"; - -/* - * normalize (used by div and sub) - * remove all leading zero's - * force positive sign if result is zero - */ -void pnorm(u) - register precision u; -{ - register digitPtr uPtr; - - uPtr = u->value + u->size; - do { - if (*--uPtr != 0) break; - } while (uPtr > u->value); - - if (uPtr == u->value && *uPtr == 0) u->sign = false; - - u->size = (uPtr - u->value) + 1; /* normalize */ -} - -/* - * Create a number with the given size (private) (very heavily used) - */ -precision palloc(size) - register posit size; -{ - register precision w; - register cacheType *kludge = pcache + size; /* for shitty compilers */ - -#ifndef NOMEMOPT - if (size < CACHESIZE && (w = kludge->next) != pUndef) { - kludge->next = ((cacheType *) w)->next; - --kludge->count; - } else { -#endif - w = (precision) allocate(PrecisionSize + sizeof(digit) * size); - if (w == pUndef) { - w = errorp(PNOMEM, "palloc", "out of memory"); - return w; - } -#ifndef NOMEMOPT - } -#endif - w->refcount = 1; - w->size = w->alloc = size; -#ifdef DEBUGOPS - printf("alloc %.8x\n", w); - fflush(stdout); -#endif - return w; -} - -/* - * (Very heavily used: Called conditionally pdestroy) - * (should be void, but some compilers can't handle it with the macro) - */ -int pfree(u) - register precision u; -{ - register posit size; - register cacheType *kludge; /* for shitty compilers */ - -#ifdef DEBUGOPS - printf("free %.8x\n", u); - fflush(stdout); -#endif - - size = u->alloc; - - kludge = pcache + size; -#ifndef NOMEMOPT - if (size < CACHESIZE && kludge->count < CACHELIMIT) { - ((cacheType *) u)->next = kludge->next; - kludge->next = u; - kludge->count++; - } else { -#endif - deallocate(u); -#ifndef NOMEMOPT - } -#endif - return 0; -} - -/* - * User inteface: - * - * Rules: - * a precision must be initialized to pUndef or to result of pnew. - * a precision pointer must point to a precision or be pNull - * pUndef may not be passed as an rvalue into a function - * pNull may not be passed as an lvalue into a function - * - * presult and pdestroy are the only functions which may be passed pUndef - */ - -/* - * assignment with verification (slower, but helpful for bug detect) - * It would be nice if this routine could detect pointers to incorrect - * or non-living areas of memory. - * - * We can't check for undefined rvalue because we want to allow functions - * to return pUndef, and then let the application check for it after assigning - * it to a variable. - * - * usage: pset(&i, j); - */ -precision psetv(up, v) - register precision *up, v; -{ - register precision u; - -#ifdef DEBUGOPS - printf("psetv %.8x %.8x ", up, v); -#endif -#ifdef DEBUGOPS - printf("->%u", v->refcount); -#endif - if (up == pNull) { - errorp(PDOMAIN, "pset", "lvalue is pNull"); - } - u = *up; -#ifdef DEBUGOPS - printf(" %.8x", u); -#endif - *up = v; - if (v != pUndef) { - v->refcount++; - } - if (u != pUndef) { - if (u->sign & ~1) { /* a minimal check */ - errorp(PDOMAIN, "pset", "invalid precision"); - } - if (--(u->refcount) == 0) { -#ifdef DEBUGOPS - printf("->%u", u->refcount); -#endif - pfree(u); - } - } -#ifdef DEBUGOPS - putchar('\n'); - fflush(stdout); -#endif - return v; -} - -precision pparmv(u) - register precision u; -{ -#ifdef DEBUGOPS - printf("pparm %.8x\n", u); - fflush(stdout); -#endif - if (u == pUndef) { - errorp(PDOMAIN, "pparm", "undefined function argument"); - } - if (u->sign & ~1) { /* a minimal check */ - errorp(PDOMAIN, "pparm", "invalid precision"); - } - u->refcount++; - return u; -} - -/* - * Function version of unsafe pparmq macro - */ -precision pparmf(u) - register precision u; -{ - if (u != pUndef) { - u->refcount++; - } - return u; -} - -/* - * Function version of pdestroy macro - */ -void pdestroyf(u) - register precision u; -{ - if (u != pUndef && --u->refcount == 0) { - pfree(u); - } -} - -#ifndef __GNUC__ /* inline in header file */ -/* - * We cannot allow this to be a macro because of the probability that it's - * argument will be a function (e.g. utop(2)) - */ -precision pnew(u) - register precision u; -{ - u->refcount++; - return u; -} - -/* - * Cannot be a macro because of function argument possibility - */ -precision presult(u) - register precision u; -{ - if (u != pUndef) { - --(u->refcount); - } - return u; -} - -/* - * Quick but dangerous assignment - * - * Assumes: target not pNull and source not pUndef - */ -precision psetq(up, v) - register precision *up, v; -{ - register precision u = *up; /* up may NOT be pNULL! */ - - *up = v; /* up may be &v, OK */ - if (v != pUndef) { /* to allow: x=func(); if (x==pUndef) ... */ - v->refcount++; - } - if (u != pUndef && --(u->refcount) == 0) { - pfree(u); - } - return v; -} -#endif - -#if 0 /* original assignment code */ -precision pset(up, v) - register precision *up, v; -{ - register precision u; - - if (v != pUndef) v->refcount++; - if (up == pNull) { /* useful voiding parameters (pdiv) */ - pdestroy(v); - return pUndef; - } - u = *up; - if (u != pUndef) { /* useful to force initial creation */ - pdestroy(u); - } - *up = v; /* notice that v may be pUndef which is OK! */ - return v; /* no presult! This is a variable */ -} -#endif diff --git a/test/llvm/cfrac.d/ppowmod.c b/test/llvm/cfrac.d/ppowmod.c deleted file mode 100644 index 4528db9b2..000000000 --- a/test/llvm/cfrac.d/ppowmod.c +++ /dev/null @@ -1,28 +0,0 @@ -#include "precision.h" - -/* - * Raise to precision power mod m - */ -precision ppowmod(u, v, m) - precision u, v, m; -{ - precision j = pUndef, i = pUndef, n = pUndef; - - (void) pparm(m); - pset(&i, pparm(u)); - pset(&n, pparm(v)); - pset(&j, pone); - - do { - if (podd(n)) { - pset(&j, pmod(pmul(i, j), m)); - } - pset(&n, phalf(n)); - if (peqz(n)) break; - pset(&i, pmod(pmul(i, i), m)); - } while (1); - - pdestroy(i); pdestroy(n); - pdestroy(u); pdestroy(v); pdestroy(m); - return presult(j); -} diff --git a/test/llvm/cfrac.d/precision.h b/test/llvm/cfrac.d/precision.h deleted file mode 100644 index 188d0083d..000000000 --- a/test/llvm/cfrac.d/precision.h +++ /dev/null @@ -1,281 +0,0 @@ -/* - * Arbitrary precision integer math package - * - * (c) Copyright 1991 by David A. Barrett (barrett@asgard.UUCP) - * - * Not to be used for profit or distributed in systems sold for profit - */ -#ifndef BASE -typedef unsigned short prefc; /* reference counter type */ -typedef prefc *precision; /* this a a private data structure */ -extern int pfree(); /* free (private) */ -#endif - -typedef precision *pvector; /* a vector of precision */ -typedef pvector *parray; /* 2d array */ - -/* - * Error values passed to errorp - */ -#define PNOERROR 0 -#define PNOMEM 1 -#define PREFCOUNT 2 -#define PUNDEFINED 3 -#define PDOMAIN 4 -#define POVERFLOW 5 - -#define pUndef ((precision) 0) /* An undefined value */ -#define pNull ((precision *) 0) - -#define peq(u, v) (pcmp((u), (v)) == 0) -#define pne(u, v) (pcmp((u), (v)) != 0) -#define pgt(u, v) (pcmp((u), (v)) > 0) -#define plt(u, v) (pcmp((u), (v)) < 0) -#define pge(u, v) (pcmp((u), (v)) >= 0) -#define ple(u, v) (pcmp((u), (v)) <= 0) - -#define peqz(u) (pcmpz(u) == 0) -#define pnez(u) (pcmpz(u) != 0) -#define pltz(u) (pcmpz(u) < 0) -#define pgtz(u) (pcmpz(u) > 0) -#define plez(u) (pcmpz(u) <= 0) -#define pgez(u) (pcmpz(u) >= 0) - -#define peven(u) (!podd(u)) -#define pdiv(u,v) (pdivmod(u,v, (precision *) -1, pNull)) -#define pmod(u,v) (pdivmod(u,v, pNull, (precision *) -1)) -#define pdivr(u,v,r) (pdivmod(u,v, (precision *) -1, r)) -#define pmodq(u,v,q) (pdivmod(u,v, q, (precision *) -1)) - -/* - * Application programs should only use the following definitions; - * - * pnew, pdestroy, pparm, presult and pset - * - * Other variants are internal only! - * All are side-effect safe except for pparm and presult. - * -DDEBUG will enable argument checking for pset and pparm - */ -#ifdef __GNUC__ /* inline is NOT ansii! Sigh. */ -static inline precision pnew(precision u) { (* (prefc *) u)++; return u; } -static inline void pdestroy(precision u) { - if (u != pUndef && --(*(prefc *) u) == 0) pfree(u); -} -static inline precision pparmq(precision u) { - if (u != pUndef) (* (prefc *) u)++; return u; -} -static inline precision presult(precision u) { - if (u != pUndef) --(*(prefc *) u); return u; -} -static inline precision psetq(precision *up, precision v) { - precision u = *up; - *up = v; - if (v != pUndef) (* (prefc *) v)++; - if (u != pUndef && --(* (prefc *) u) == 0) pfree(u); - return v; -} -#define pvoid(u) pdestroy(u) -#else -#define pdestroy(u) (void) ((u)!=pUndef&&--(*(prefc *)(u))==0&&pfree(u)) -#define pparmq(u) ((u) != pUndef && (* (prefc *) (u))++, (u)) -#define pvoid(u) pdestroyf(u) -#endif - - -#ifdef PDEBUG -#define pset(u, v) psetv(u, v) -#define pparm(u) pparmv(u) -#else -#define pset(u, v) psetq(u, v) -#define pparm(u) pparmq(u) -#endif - -#ifdef __STDC__ /* if ANSI compiler */ -#ifndef __GNUC__ -extern precision pnew(precision); /* initialization */ -extern precision presult(precision); /* function result */ -extern precision psetq(precision *, precision); /* quick assignment */ -#endif -extern precision psetv(precision *, precision); /* checked assignment */ -extern precision pparmv(precision); /* checked parameter */ -extern precision pparmf(precision); /* unchecked parameter (fn) */ - -extern int pcmpz(precision); /* compare to zero */ -extern int pcmp(precision, precision); /* compare */ -extern int picmp(precision, int); /* single digit cmp */ - -extern precision padd(precision, precision); /* add */ -extern precision psub(precision, precision); /* subtract */ -extern precision pmul(precision, precision); /* multiply */ - -extern precision pdivmod(precision, precision, - precision *q, precision *r); - -extern precision pidiv(precision, int); /* single digit pdiv */ -extern int pimod(precision, int); /* single digit pmod */ -extern void pidivmod(precision, int, /* single pdivmod */ - precision *q, int *r); - -extern precision pneg(precision); /* negate */ -extern precision pabs(precision); /* absolute value */ -extern int podd(precision); /* true if odd */ -extern precision phalf(precision); /* divide by two */ - -extern precision pmin(precision, precision); /* minimum value */ -extern precision pmax(precision, precision); /* maximum value */ - -extern precision prand(precision); /* random number generator */ - -extern precision itop(int); /* int to precision */ -extern precision utop(unsigned); /* unsigned to precision */ -extern precision ltop(long); /* long to precision */ -extern precision ultop(unsigned long); /* unsigned long to precision */ - -extern int ptoi(precision); /* precision to int */ -extern unsigned int ptou(precision); /* precision to unsigned */ -extern long ptol(precision); /* precision to long */ -extern unsigned long ptoul(precision); /* precision to unsigned long */ - -extern precision atop(char *); /* ascii to precision */ -extern char *ptoa(precision); /* precision to ascii */ - -extern int btop(precision *result, /* base to precision */ - char *src, unsigned size, int *digitmap, unsigned radix); - -extern int /* precision to base */ - ptob(precision, char *result, unsigned size, char *alphabet, unsigned radix); - -/* - * Can't do prototyping for these unless stdio.h has been included - */ -#ifdef BUFSIZ -extern precision fgetp(FILE *stream); /* input precision */ -extern int fputp(FILE *stream, precision); /* output precision */ -extern int - fprintp(FILE *stream, precision, int minWidth); /* output within a field */ -#else -extern precision fgetp(); /* input precision */ -extern int fputp(); /* output precision */ -extern int fprintp(); /* output within a field */ -#endif - -extern int putp(precision); /* stdout with '\n' */ - -extern void pshow(precision); /* display debug info */ -extern precision prandnum(); /* debug and profil only */ -extern precision pshift(precision, int); /* shift left */ - -extern precision errorp(int errnum, char *routine, char *message); - -extern precision pzero, pone, ptwo; /* constants 0, 1, and 2 */ -extern precision p_one; /* constant -1 */ - -extern precision psqrt(precision); /* square root */ -extern precision pfactorial(precision); /* factorial */ -extern precision pipow(precision, unsigned); /* unsigned int power */ -extern precision ppow(precision, precision); /* precision power */ -extern precision - ppowmod(precision, precision, precision); /* precision power mod m */ -extern int plogb(precision, precision); /* log base b of n */ - -extern precision dtop(double); /* double to precision */ -extern double ptod(precision); /* precision to double */ - -/* - * vector operations - */ -pvector pvundef(pvector, unsigned size); /* local variable entry */ -void pvdestroy(pvector, unsigned size); /* local variable exit */ - -//pvector pvalloc(unsigned size); /* pvec allocate */ -void pvfree(pvector, unsigned size); /* pvec free */ - -pvector pvset(pvector, unsigned size, precision value); - -#else - -/* - * Function versions of above if you still want side effects - */ - -#ifndef __GNUC__ -extern precision pnew(); /* initialization */ -extern precision presult(); /* function result */ -extern precision psetq(); /* quick assignment */ -#endif -extern precision psetv(); /* checked assignment */ -extern precision pparmv(); /* checked parameter */ -extern precision pparmf(); /* unchecked parameter (fn) */ - -extern int pcmpz(); /* compare to zero */ -extern int pcmp(); /* compare */ -extern int picmp(); /* single digit compare */ - -extern precision padd(); /* add */ -extern precision psub(); /* subtract */ -extern precision pmul(); /* multiply */ - -extern precision pdivmod(); /* divide/remainder */ -extern void pidivmod(); /* single digit divide/remainder */ -extern precision pidiv(); /* single digit divide */ -extern int pimod(); /* single digit remainder */ -extern precision pneg(); /* negate */ -extern precision pabs(); /* absolute value */ -extern int podd(); /* true if odd */ -extern precision phalf(); /* divide by two */ - -extern precision pmin(); /* minimum value */ -extern precision pmax(); /* maximum value */ - -extern precision prand(); /* random number generator */ - -extern precision itop(); /* int to precision */ -extern precision utop(); /* unsigned to precision */ -extern precision ltop(); /* long to precision */ -extern precision ultop(); /* unsigned long to precision */ - -extern int ptoi(); /* precision to int */ -extern unsigned int ptou(); /* precision to unsigned */ -extern long ptol(); /* precision to long */ -extern unsigned long ptoul(); /* precision to unsigned long */ - -extern precision atop(); /* ascii to precision */ -extern char *ptoa(); /* precision to ascii */ - -extern int btop(); /* base to precision */ -extern int ptob(); /* precision to base */ - -extern precision fgetp(); /* input a precision */ -extern int fputp(); /* output a precision */ -extern int putp(); /* output precision '\n' to stdout */ -extern int fprintp(); /* output a precision within a field */ - -extern void pshow(); /* display debug info */ -extern precision prandnum(); /* for debug and profil only */ -extern precision pshift(); /* shift left */ - -extern precision errorp(); /* user-substitutable error handler */ - -extern precision pzero, pone, ptwo; /* constants 0, 1, and 2 */ -extern precision p_one; /* constant -1 */ - -extern precision psqrt(); /* square root */ -extern precision pfactorial(); /* factorial */ -extern precision pipow(); /* unsigned int power */ -extern precision ppow(); /* precision power */ -extern precision ppowmod(); /* precision power mod m */ -extern int plogb(); /* log base b of n */ - -extern precision dtop(); /* double to precision */ -extern double ptod(); /* precision to double */ - -/* - * vector operations - */ -pvector pvundef(); /* local variable entry */ -void pvdestroy(); /* local variable exit */ -pvector pvalloc(); /* pvec allocate */ -void pvfree(); /* pvec free */ -pvector pvset(); /* set each element to scaler */ - -#endif diff --git a/test/llvm/cfrac.d/primes.c b/test/llvm/cfrac.d/primes.c deleted file mode 100644 index f9dbd84be..000000000 --- a/test/llvm/cfrac.d/primes.c +++ /dev/null @@ -1,662 +0,0 @@ -/* - * A table of all primes < 65536 - */ -unsigned int primesize = 6542; - -unsigned short primes[] = { - 2, 3, 5, 7, 11, 13, 17, 19, 23, 29, - 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, - 73, 79, 83, 89, 97, 101, 103, 107, 109, 113, - 127, 131, 137, 139, 149, 151, 157, 163, 167, 173, - 179, 181, 191, 193, 197, 199, 211, 223, 227, 229, - 233, 239, 241, 251, 257, 263, 269, 271, 277, 281, - 283, 293, 307, 311, 313, 317, 331, 337, 347, 349, - 353, 359, 367, 373, 379, 383, 389, 397, 401, 409, - 419, 421, 431, 433, 439, 443, 449, 457, 461, 463, - 467, 479, 487, 491, 499, 503, 509, 521, 523, 541, - 547, 557, 563, 569, 571, 577, 587, 593, 599, 601, - 607, 613, 617, 619, 631, 641, 643, 647, 653, 659, - 661, 673, 677, 683, 691, 701, 709, 719, 727, 733, - 739, 743, 751, 757, 761, 769, 773, 787, 797, 809, - 811, 821, 823, 827, 829, 839, 853, 857, 859, 863, - 877, 881, 883, 887, 907, 911, 919, 929, 937, 941, - 947, 953, 967, 971, 977, 983, 991, 997, 1009, 1013, - 1019, 1021, 1031, 1033, 1039, 1049, 1051, 1061, 1063, 1069, - 1087, 1091, 1093, 1097, 1103, 1109, 1117, 1123, 1129, 1151, - 1153, 1163, 1171, 1181, 1187, 1193, 1201, 1213, 1217, 1223, - 1229, 1231, 1237, 1249, 1259, 1277, 1279, 1283, 1289, 1291, - 1297, 1301, 1303, 1307, 1319, 1321, 1327, 1361, 1367, 1373, - 1381, 1399, 1409, 1423, 1427, 1429, 1433, 1439, 1447, 1451, - 1453, 1459, 1471, 1481, 1483, 1487, 1489, 1493, 1499, 1511, - 1523, 1531, 1543, 1549, 1553, 1559, 1567, 1571, 1579, 1583, - 1597, 1601, 1607, 1609, 1613, 1619, 1621, 1627, 1637, 1657, - 1663, 1667, 1669, 1693, 1697, 1699, 1709, 1721, 1723, 1733, - 1741, 1747, 1753, 1759, 1777, 1783, 1787, 1789, 1801, 1811, - 1823, 1831, 1847, 1861, 1867, 1871, 1873, 1877, 1879, 1889, - 1901, 1907, 1913, 1931, 1933, 1949, 1951, 1973, 1979, 1987, - 1993, 1997, 1999, 2003, 2011, 2017, 2027, 2029, 2039, 2053, - 2063, 2069, 2081, 2083, 2087, 2089, 2099, 2111, 2113, 2129, - 2131, 2137, 2141, 2143, 2153, 2161, 2179, 2203, 2207, 2213, - 2221, 2237, 2239, 2243, 2251, 2267, 2269, 2273, 2281, 2287, - 2293, 2297, 2309, 2311, 2333, 2339, 2341, 2347, 2351, 2357, - 2371, 2377, 2381, 2383, 2389, 2393, 2399, 2411, 2417, 2423, - 2437, 2441, 2447, 2459, 2467, 2473, 2477, 2503, 2521, 2531, - 2539, 2543, 2549, 2551, 2557, 2579, 2591, 2593, 2609, 2617, - 2621, 2633, 2647, 2657, 2659, 2663, 2671, 2677, 2683, 2687, - 2689, 2693, 2699, 2707, 2711, 2713, 2719, 2729, 2731, 2741, - 2749, 2753, 2767, 2777, 2789, 2791, 2797, 2801, 2803, 2819, - 2833, 2837, 2843, 2851, 2857, 2861, 2879, 2887, 2897, 2903, - 2909, 2917, 2927, 2939, 2953, 2957, 2963, 2969, 2971, 2999, - 3001, 3011, 3019, 3023, 3037, 3041, 3049, 3061, 3067, 3079, - 3083, 3089, 3109, 3119, 3121, 3137, 3163, 3167, 3169, 3181, - 3187, 3191, 3203, 3209, 3217, 3221, 3229, 3251, 3253, 3257, - 3259, 3271, 3299, 3301, 3307, 3313, 3319, 3323, 3329, 3331, - 3343, 3347, 3359, 3361, 3371, 3373, 3389, 3391, 3407, 3413, - 3433, 3449, 3457, 3461, 3463, 3467, 3469, 3491, 3499, 3511, - 3517, 3527, 3529, 3533, 3539, 3541, 3547, 3557, 3559, 3571, - 3581, 3583, 3593, 3607, 3613, 3617, 3623, 3631, 3637, 3643, - 3659, 3671, 3673, 3677, 3691, 3697, 3701, 3709, 3719, 3727, - 3733, 3739, 3761, 3767, 3769, 3779, 3793, 3797, 3803, 3821, - 3823, 3833, 3847, 3851, 3853, 3863, 3877, 3881, 3889, 3907, - 3911, 3917, 3919, 3923, 3929, 3931, 3943, 3947, 3967, 3989, - 4001, 4003, 4007, 4013, 4019, 4021, 4027, 4049, 4051, 4057, - 4073, 4079, 4091, 4093, 4099, 4111, 4127, 4129, 4133, 4139, - 4153, 4157, 4159, 4177, 4201, 4211, 4217, 4219, 4229, 4231, - 4241, 4243, 4253, 4259, 4261, 4271, 4273, 4283, 4289, 4297, - 4327, 4337, 4339, 4349, 4357, 4363, 4373, 4391, 4397, 4409, - 4421, 4423, 4441, 4447, 4451, 4457, 4463, 4481, 4483, 4493, - 4507, 4513, 4517, 4519, 4523, 4547, 4549, 4561, 4567, 4583, - 4591, 4597, 4603, 4621, 4637, 4639, 4643, 4649, 4651, 4657, - 4663, 4673, 4679, 4691, 4703, 4721, 4723, 4729, 4733, 4751, - 4759, 4783, 4787, 4789, 4793, 4799, 4801, 4813, 4817, 4831, - 4861, 4871, 4877, 4889, 4903, 4909, 4919, 4931, 4933, 4937, - 4943, 4951, 4957, 4967, 4969, 4973, 4987, 4993, 4999, 5003, - 5009, 5011, 5021, 5023, 5039, 5051, 5059, 5077, 5081, 5087, - 5099, 5101, 5107, 5113, 5119, 5147, 5153, 5167, 5171, 5179, - 5189, 5197, 5209, 5227, 5231, 5233, 5237, 5261, 5273, 5279, - 5281, 5297, 5303, 5309, 5323, 5333, 5347, 5351, 5381, 5387, - 5393, 5399, 5407, 5413, 5417, 5419, 5431, 5437, 5441, 5443, - 5449, 5471, 5477, 5479, 5483, 5501, 5503, 5507, 5519, 5521, - 5527, 5531, 5557, 5563, 5569, 5573, 5581, 5591, 5623, 5639, - 5641, 5647, 5651, 5653, 5657, 5659, 5669, 5683, 5689, 5693, - 5701, 5711, 5717, 5737, 5741, 5743, 5749, 5779, 5783, 5791, - 5801, 5807, 5813, 5821, 5827, 5839, 5843, 5849, 5851, 5857, - 5861, 5867, 5869, 5879, 5881, 5897, 5903, 5923, 5927, 5939, - 5953, 5981, 5987, 6007, 6011, 6029, 6037, 6043, 6047, 6053, - 6067, 6073, 6079, 6089, 6091, 6101, 6113, 6121, 6131, 6133, - 6143, 6151, 6163, 6173, 6197, 6199, 6203, 6211, 6217, 6221, - 6229, 6247, 6257, 6263, 6269, 6271, 6277, 6287, 6299, 6301, - 6311, 6317, 6323, 6329, 6337, 6343, 6353, 6359, 6361, 6367, - 6373, 6379, 6389, 6397, 6421, 6427, 6449, 6451, 6469, 6473, - 6481, 6491, 6521, 6529, 6547, 6551, 6553, 6563, 6569, 6571, - 6577, 6581, 6599, 6607, 6619, 6637, 6653, 6659, 6661, 6673, - 6679, 6689, 6691, 6701, 6703, 6709, 6719, 6733, 6737, 6761, - 6763, 6779, 6781, 6791, 6793, 6803, 6823, 6827, 6829, 6833, - 6841, 6857, 6863, 6869, 6871, 6883, 6899, 6907, 6911, 6917, - 6947, 6949, 6959, 6961, 6967, 6971, 6977, 6983, 6991, 6997, - 7001, 7013, 7019, 7027, 7039, 7043, 7057, 7069, 7079, 7103, - 7109, 7121, 7127, 7129, 7151, 7159, 7177, 7187, 7193, 7207, - 7211, 7213, 7219, 7229, 7237, 7243, 7247, 7253, 7283, 7297, - 7307, 7309, 7321, 7331, 7333, 7349, 7351, 7369, 7393, 7411, - 7417, 7433, 7451, 7457, 7459, 7477, 7481, 7487, 7489, 7499, - 7507, 7517, 7523, 7529, 7537, 7541, 7547, 7549, 7559, 7561, - 7573, 7577, 7583, 7589, 7591, 7603, 7607, 7621, 7639, 7643, - 7649, 7669, 7673, 7681, 7687, 7691, 7699, 7703, 7717, 7723, - 7727, 7741, 7753, 7757, 7759, 7789, 7793, 7817, 7823, 7829, - 7841, 7853, 7867, 7873, 7877, 7879, 7883, 7901, 7907, 7919, - 7927, 7933, 7937, 7949, 7951, 7963, 7993, 8009, 8011, 8017, - 8039, 8053, 8059, 8069, 8081, 8087, 8089, 8093, 8101, 8111, - 8117, 8123, 8147, 8161, 8167, 8171, 8179, 8191, 8209, 8219, - 8221, 8231, 8233, 8237, 8243, 8263, 8269, 8273, 8287, 8291, - 8293, 8297, 8311, 8317, 8329, 8353, 8363, 8369, 8377, 8387, - 8389, 8419, 8423, 8429, 8431, 8443, 8447, 8461, 8467, 8501, - 8513, 8521, 8527, 8537, 8539, 8543, 8563, 8573, 8581, 8597, - 8599, 8609, 8623, 8627, 8629, 8641, 8647, 8663, 8669, 8677, - 8681, 8689, 8693, 8699, 8707, 8713, 8719, 8731, 8737, 8741, - 8747, 8753, 8761, 8779, 8783, 8803, 8807, 8819, 8821, 8831, - 8837, 8839, 8849, 8861, 8863, 8867, 8887, 8893, 8923, 8929, - 8933, 8941, 8951, 8963, 8969, 8971, 8999, 9001, 9007, 9011, - 9013, 9029, 9041, 9043, 9049, 9059, 9067, 9091, 9103, 9109, - 9127, 9133, 9137, 9151, 9157, 9161, 9173, 9181, 9187, 9199, - 9203, 9209, 9221, 9227, 9239, 9241, 9257, 9277, 9281, 9283, - 9293, 9311, 9319, 9323, 9337, 9341, 9343, 9349, 9371, 9377, - 9391, 9397, 9403, 9413, 9419, 9421, 9431, 9433, 9437, 9439, - 9461, 9463, 9467, 9473, 9479, 9491, 9497, 9511, 9521, 9533, - 9539, 9547, 9551, 9587, 9601, 9613, 9619, 9623, 9629, 9631, - 9643, 9649, 9661, 9677, 9679, 9689, 9697, 9719, 9721, 9733, - 9739, 9743, 9749, 9767, 9769, 9781, 9787, 9791, 9803, 9811, - 9817, 9829, 9833, 9839, 9851, 9857, 9859, 9871, 9883, 9887, - 9901, 9907, 9923, 9929, 9931, 9941, 9949, 9967, 9973, 10007, - 10009, 10037, 10039, 10061, 10067, 10069, 10079, 10091, 10093, 10099, - 10103, 10111, 10133, 10139, 10141, 10151, 10159, 10163, 10169, 10177, - 10181, 10193, 10211, 10223, 10243, 10247, 10253, 10259, 10267, 10271, - 10273, 10289, 10301, 10303, 10313, 10321, 10331, 10333, 10337, 10343, - 10357, 10369, 10391, 10399, 10427, 10429, 10433, 10453, 10457, 10459, - 10463, 10477, 10487, 10499, 10501, 10513, 10529, 10531, 10559, 10567, - 10589, 10597, 10601, 10607, 10613, 10627, 10631, 10639, 10651, 10657, - 10663, 10667, 10687, 10691, 10709, 10711, 10723, 10729, 10733, 10739, - 10753, 10771, 10781, 10789, 10799, 10831, 10837, 10847, 10853, 10859, - 10861, 10867, 10883, 10889, 10891, 10903, 10909, 10937, 10939, 10949, - 10957, 10973, 10979, 10987, 10993, 11003, 11027, 11047, 11057, 11059, - 11069, 11071, 11083, 11087, 11093, 11113, 11117, 11119, 11131, 11149, - 11159, 11161, 11171, 11173, 11177, 11197, 11213, 11239, 11243, 11251, - 11257, 11261, 11273, 11279, 11287, 11299, 11311, 11317, 11321, 11329, - 11351, 11353, 11369, 11383, 11393, 11399, 11411, 11423, 11437, 11443, - 11447, 11467, 11471, 11483, 11489, 11491, 11497, 11503, 11519, 11527, - 11549, 11551, 11579, 11587, 11593, 11597, 11617, 11621, 11633, 11657, - 11677, 11681, 11689, 11699, 11701, 11717, 11719, 11731, 11743, 11777, - 11779, 11783, 11789, 11801, 11807, 11813, 11821, 11827, 11831, 11833, - 11839, 11863, 11867, 11887, 11897, 11903, 11909, 11923, 11927, 11933, - 11939, 11941, 11953, 11959, 11969, 11971, 11981, 11987, 12007, 12011, - 12037, 12041, 12043, 12049, 12071, 12073, 12097, 12101, 12107, 12109, - 12113, 12119, 12143, 12149, 12157, 12161, 12163, 12197, 12203, 12211, - 12227, 12239, 12241, 12251, 12253, 12263, 12269, 12277, 12281, 12289, - 12301, 12323, 12329, 12343, 12347, 12373, 12377, 12379, 12391, 12401, - 12409, 12413, 12421, 12433, 12437, 12451, 12457, 12473, 12479, 12487, - 12491, 12497, 12503, 12511, 12517, 12527, 12539, 12541, 12547, 12553, - 12569, 12577, 12583, 12589, 12601, 12611, 12613, 12619, 12637, 12641, - 12647, 12653, 12659, 12671, 12689, 12697, 12703, 12713, 12721, 12739, - 12743, 12757, 12763, 12781, 12791, 12799, 12809, 12821, 12823, 12829, - 12841, 12853, 12889, 12893, 12899, 12907, 12911, 12917, 12919, 12923, - 12941, 12953, 12959, 12967, 12973, 12979, 12983, 13001, 13003, 13007, - 13009, 13033, 13037, 13043, 13049, 13063, 13093, 13099, 13103, 13109, - 13121, 13127, 13147, 13151, 13159, 13163, 13171, 13177, 13183, 13187, - 13217, 13219, 13229, 13241, 13249, 13259, 13267, 13291, 13297, 13309, - 13313, 13327, 13331, 13337, 13339, 13367, 13381, 13397, 13399, 13411, - 13417, 13421, 13441, 13451, 13457, 13463, 13469, 13477, 13487, 13499, - 13513, 13523, 13537, 13553, 13567, 13577, 13591, 13597, 13613, 13619, - 13627, 13633, 13649, 13669, 13679, 13681, 13687, 13691, 13693, 13697, - 13709, 13711, 13721, 13723, 13729, 13751, 13757, 13759, 13763, 13781, - 13789, 13799, 13807, 13829, 13831, 13841, 13859, 13873, 13877, 13879, - 13883, 13901, 13903, 13907, 13913, 13921, 13931, 13933, 13963, 13967, - 13997, 13999, 14009, 14011, 14029, 14033, 14051, 14057, 14071, 14081, - 14083, 14087, 14107, 14143, 14149, 14153, 14159, 14173, 14177, 14197, - 14207, 14221, 14243, 14249, 14251, 14281, 14293, 14303, 14321, 14323, - 14327, 14341, 14347, 14369, 14387, 14389, 14401, 14407, 14411, 14419, - 14423, 14431, 14437, 14447, 14449, 14461, 14479, 14489, 14503, 14519, - 14533, 14537, 14543, 14549, 14551, 14557, 14561, 14563, 14591, 14593, - 14621, 14627, 14629, 14633, 14639, 14653, 14657, 14669, 14683, 14699, - 14713, 14717, 14723, 14731, 14737, 14741, 14747, 14753, 14759, 14767, - 14771, 14779, 14783, 14797, 14813, 14821, 14827, 14831, 14843, 14851, - 14867, 14869, 14879, 14887, 14891, 14897, 14923, 14929, 14939, 14947, - 14951, 14957, 14969, 14983, 15013, 15017, 15031, 15053, 15061, 15073, - 15077, 15083, 15091, 15101, 15107, 15121, 15131, 15137, 15139, 15149, - 15161, 15173, 15187, 15193, 15199, 15217, 15227, 15233, 15241, 15259, - 15263, 15269, 15271, 15277, 15287, 15289, 15299, 15307, 15313, 15319, - 15329, 15331, 15349, 15359, 15361, 15373, 15377, 15383, 15391, 15401, - 15413, 15427, 15439, 15443, 15451, 15461, 15467, 15473, 15493, 15497, - 15511, 15527, 15541, 15551, 15559, 15569, 15581, 15583, 15601, 15607, - 15619, 15629, 15641, 15643, 15647, 15649, 15661, 15667, 15671, 15679, - 15683, 15727, 15731, 15733, 15737, 15739, 15749, 15761, 15767, 15773, - 15787, 15791, 15797, 15803, 15809, 15817, 15823, 15859, 15877, 15881, - 15887, 15889, 15901, 15907, 15913, 15919, 15923, 15937, 15959, 15971, - 15973, 15991, 16001, 16007, 16033, 16057, 16061, 16063, 16067, 16069, - 16073, 16087, 16091, 16097, 16103, 16111, 16127, 16139, 16141, 16183, - 16187, 16189, 16193, 16217, 16223, 16229, 16231, 16249, 16253, 16267, - 16273, 16301, 16319, 16333, 16339, 16349, 16361, 16363, 16369, 16381, - 16411, 16417, 16421, 16427, 16433, 16447, 16451, 16453, 16477, 16481, - 16487, 16493, 16519, 16529, 16547, 16553, 16561, 16567, 16573, 16603, - 16607, 16619, 16631, 16633, 16649, 16651, 16657, 16661, 16673, 16691, - 16693, 16699, 16703, 16729, 16741, 16747, 16759, 16763, 16787, 16811, - 16823, 16829, 16831, 16843, 16871, 16879, 16883, 16889, 16901, 16903, - 16921, 16927, 16931, 16937, 16943, 16963, 16979, 16981, 16987, 16993, - 17011, 17021, 17027, 17029, 17033, 17041, 17047, 17053, 17077, 17093, - 17099, 17107, 17117, 17123, 17137, 17159, 17167, 17183, 17189, 17191, - 17203, 17207, 17209, 17231, 17239, 17257, 17291, 17293, 17299, 17317, - 17321, 17327, 17333, 17341, 17351, 17359, 17377, 17383, 17387, 17389, - 17393, 17401, 17417, 17419, 17431, 17443, 17449, 17467, 17471, 17477, - 17483, 17489, 17491, 17497, 17509, 17519, 17539, 17551, 17569, 17573, - 17579, 17581, 17597, 17599, 17609, 17623, 17627, 17657, 17659, 17669, - 17681, 17683, 17707, 17713, 17729, 17737, 17747, 17749, 17761, 17783, - 17789, 17791, 17807, 17827, 17837, 17839, 17851, 17863, 17881, 17891, - 17903, 17909, 17911, 17921, 17923, 17929, 17939, 17957, 17959, 17971, - 17977, 17981, 17987, 17989, 18013, 18041, 18043, 18047, 18049, 18059, - 18061, 18077, 18089, 18097, 18119, 18121, 18127, 18131, 18133, 18143, - 18149, 18169, 18181, 18191, 18199, 18211, 18217, 18223, 18229, 18233, - 18251, 18253, 18257, 18269, 18287, 18289, 18301, 18307, 18311, 18313, - 18329, 18341, 18353, 18367, 18371, 18379, 18397, 18401, 18413, 18427, - 18433, 18439, 18443, 18451, 18457, 18461, 18481, 18493, 18503, 18517, - 18521, 18523, 18539, 18541, 18553, 18583, 18587, 18593, 18617, 18637, - 18661, 18671, 18679, 18691, 18701, 18713, 18719, 18731, 18743, 18749, - 18757, 18773, 18787, 18793, 18797, 18803, 18839, 18859, 18869, 18899, - 18911, 18913, 18917, 18919, 18947, 18959, 18973, 18979, 19001, 19009, - 19013, 19031, 19037, 19051, 19069, 19073, 19079, 19081, 19087, 19121, - 19139, 19141, 19157, 19163, 19181, 19183, 19207, 19211, 19213, 19219, - 19231, 19237, 19249, 19259, 19267, 19273, 19289, 19301, 19309, 19319, - 19333, 19373, 19379, 19381, 19387, 19391, 19403, 19417, 19421, 19423, - 19427, 19429, 19433, 19441, 19447, 19457, 19463, 19469, 19471, 19477, - 19483, 19489, 19501, 19507, 19531, 19541, 19543, 19553, 19559, 19571, - 19577, 19583, 19597, 19603, 19609, 19661, 19681, 19687, 19697, 19699, - 19709, 19717, 19727, 19739, 19751, 19753, 19759, 19763, 19777, 19793, - 19801, 19813, 19819, 19841, 19843, 19853, 19861, 19867, 19889, 19891, - 19913, 19919, 19927, 19937, 19949, 19961, 19963, 19973, 19979, 19991, - 19993, 19997, 20011, 20021, 20023, 20029, 20047, 20051, 20063, 20071, - 20089, 20101, 20107, 20113, 20117, 20123, 20129, 20143, 20147, 20149, - 20161, 20173, 20177, 20183, 20201, 20219, 20231, 20233, 20249, 20261, - 20269, 20287, 20297, 20323, 20327, 20333, 20341, 20347, 20353, 20357, - 20359, 20369, 20389, 20393, 20399, 20407, 20411, 20431, 20441, 20443, - 20477, 20479, 20483, 20507, 20509, 20521, 20533, 20543, 20549, 20551, - 20563, 20593, 20599, 20611, 20627, 20639, 20641, 20663, 20681, 20693, - 20707, 20717, 20719, 20731, 20743, 20747, 20749, 20753, 20759, 20771, - 20773, 20789, 20807, 20809, 20849, 20857, 20873, 20879, 20887, 20897, - 20899, 20903, 20921, 20929, 20939, 20947, 20959, 20963, 20981, 20983, - 21001, 21011, 21013, 21017, 21019, 21023, 21031, 21059, 21061, 21067, - 21089, 21101, 21107, 21121, 21139, 21143, 21149, 21157, 21163, 21169, - 21179, 21187, 21191, 21193, 21211, 21221, 21227, 21247, 21269, 21277, - 21283, 21313, 21317, 21319, 21323, 21341, 21347, 21377, 21379, 21383, - 21391, 21397, 21401, 21407, 21419, 21433, 21467, 21481, 21487, 21491, - 21493, 21499, 21503, 21517, 21521, 21523, 21529, 21557, 21559, 21563, - 21569, 21577, 21587, 21589, 21599, 21601, 21611, 21613, 21617, 21647, - 21649, 21661, 21673, 21683, 21701, 21713, 21727, 21737, 21739, 21751, - 21757, 21767, 21773, 21787, 21799, 21803, 21817, 21821, 21839, 21841, - 21851, 21859, 21863, 21871, 21881, 21893, 21911, 21929, 21937, 21943, - 21961, 21977, 21991, 21997, 22003, 22013, 22027, 22031, 22037, 22039, - 22051, 22063, 22067, 22073, 22079, 22091, 22093, 22109, 22111, 22123, - 22129, 22133, 22147, 22153, 22157, 22159, 22171, 22189, 22193, 22229, - 22247, 22259, 22271, 22273, 22277, 22279, 22283, 22291, 22303, 22307, - 22343, 22349, 22367, 22369, 22381, 22391, 22397, 22409, 22433, 22441, - 22447, 22453, 22469, 22481, 22483, 22501, 22511, 22531, 22541, 22543, - 22549, 22567, 22571, 22573, 22613, 22619, 22621, 22637, 22639, 22643, - 22651, 22669, 22679, 22691, 22697, 22699, 22709, 22717, 22721, 22727, - 22739, 22741, 22751, 22769, 22777, 22783, 22787, 22807, 22811, 22817, - 22853, 22859, 22861, 22871, 22877, 22901, 22907, 22921, 22937, 22943, - 22961, 22963, 22973, 22993, 23003, 23011, 23017, 23021, 23027, 23029, - 23039, 23041, 23053, 23057, 23059, 23063, 23071, 23081, 23087, 23099, - 23117, 23131, 23143, 23159, 23167, 23173, 23189, 23197, 23201, 23203, - 23209, 23227, 23251, 23269, 23279, 23291, 23293, 23297, 23311, 23321, - 23327, 23333, 23339, 23357, 23369, 23371, 23399, 23417, 23431, 23447, - 23459, 23473, 23497, 23509, 23531, 23537, 23539, 23549, 23557, 23561, - 23563, 23567, 23581, 23593, 23599, 23603, 23609, 23623, 23627, 23629, - 23633, 23663, 23669, 23671, 23677, 23687, 23689, 23719, 23741, 23743, - 23747, 23753, 23761, 23767, 23773, 23789, 23801, 23813, 23819, 23827, - 23831, 23833, 23857, 23869, 23873, 23879, 23887, 23893, 23899, 23909, - 23911, 23917, 23929, 23957, 23971, 23977, 23981, 23993, 24001, 24007, - 24019, 24023, 24029, 24043, 24049, 24061, 24071, 24077, 24083, 24091, - 24097, 24103, 24107, 24109, 24113, 24121, 24133, 24137, 24151, 24169, - 24179, 24181, 24197, 24203, 24223, 24229, 24239, 24247, 24251, 24281, - 24317, 24329, 24337, 24359, 24371, 24373, 24379, 24391, 24407, 24413, - 24419, 24421, 24439, 24443, 24469, 24473, 24481, 24499, 24509, 24517, - 24527, 24533, 24547, 24551, 24571, 24593, 24611, 24623, 24631, 24659, - 24671, 24677, 24683, 24691, 24697, 24709, 24733, 24749, 24763, 24767, - 24781, 24793, 24799, 24809, 24821, 24841, 24847, 24851, 24859, 24877, - 24889, 24907, 24917, 24919, 24923, 24943, 24953, 24967, 24971, 24977, - 24979, 24989, 25013, 25031, 25033, 25037, 25057, 25073, 25087, 25097, - 25111, 25117, 25121, 25127, 25147, 25153, 25163, 25169, 25171, 25183, - 25189, 25219, 25229, 25237, 25243, 25247, 25253, 25261, 25301, 25303, - 25307, 25309, 25321, 25339, 25343, 25349, 25357, 25367, 25373, 25391, - 25409, 25411, 25423, 25439, 25447, 25453, 25457, 25463, 25469, 25471, - 25523, 25537, 25541, 25561, 25577, 25579, 25583, 25589, 25601, 25603, - 25609, 25621, 25633, 25639, 25643, 25657, 25667, 25673, 25679, 25693, - 25703, 25717, 25733, 25741, 25747, 25759, 25763, 25771, 25793, 25799, - 25801, 25819, 25841, 25847, 25849, 25867, 25873, 25889, 25903, 25913, - 25919, 25931, 25933, 25939, 25943, 25951, 25969, 25981, 25997, 25999, - 26003, 26017, 26021, 26029, 26041, 26053, 26083, 26099, 26107, 26111, - 26113, 26119, 26141, 26153, 26161, 26171, 26177, 26183, 26189, 26203, - 26209, 26227, 26237, 26249, 26251, 26261, 26263, 26267, 26293, 26297, - 26309, 26317, 26321, 26339, 26347, 26357, 26371, 26387, 26393, 26399, - 26407, 26417, 26423, 26431, 26437, 26449, 26459, 26479, 26489, 26497, - 26501, 26513, 26539, 26557, 26561, 26573, 26591, 26597, 26627, 26633, - 26641, 26647, 26669, 26681, 26683, 26687, 26693, 26699, 26701, 26711, - 26713, 26717, 26723, 26729, 26731, 26737, 26759, 26777, 26783, 26801, - 26813, 26821, 26833, 26839, 26849, 26861, 26863, 26879, 26881, 26891, - 26893, 26903, 26921, 26927, 26947, 26951, 26953, 26959, 26981, 26987, - 26993, 27011, 27017, 27031, 27043, 27059, 27061, 27067, 27073, 27077, - 27091, 27103, 27107, 27109, 27127, 27143, 27179, 27191, 27197, 27211, - 27239, 27241, 27253, 27259, 27271, 27277, 27281, 27283, 27299, 27329, - 27337, 27361, 27367, 27397, 27407, 27409, 27427, 27431, 27437, 27449, - 27457, 27479, 27481, 27487, 27509, 27527, 27529, 27539, 27541, 27551, - 27581, 27583, 27611, 27617, 27631, 27647, 27653, 27673, 27689, 27691, - 27697, 27701, 27733, 27737, 27739, 27743, 27749, 27751, 27763, 27767, - 27773, 27779, 27791, 27793, 27799, 27803, 27809, 27817, 27823, 27827, - 27847, 27851, 27883, 27893, 27901, 27917, 27919, 27941, 27943, 27947, - 27953, 27961, 27967, 27983, 27997, 28001, 28019, 28027, 28031, 28051, - 28057, 28069, 28081, 28087, 28097, 28099, 28109, 28111, 28123, 28151, - 28163, 28181, 28183, 28201, 28211, 28219, 28229, 28277, 28279, 28283, - 28289, 28297, 28307, 28309, 28319, 28349, 28351, 28387, 28393, 28403, - 28409, 28411, 28429, 28433, 28439, 28447, 28463, 28477, 28493, 28499, - 28513, 28517, 28537, 28541, 28547, 28549, 28559, 28571, 28573, 28579, - 28591, 28597, 28603, 28607, 28619, 28621, 28627, 28631, 28643, 28649, - 28657, 28661, 28663, 28669, 28687, 28697, 28703, 28711, 28723, 28729, - 28751, 28753, 28759, 28771, 28789, 28793, 28807, 28813, 28817, 28837, - 28843, 28859, 28867, 28871, 28879, 28901, 28909, 28921, 28927, 28933, - 28949, 28961, 28979, 29009, 29017, 29021, 29023, 29027, 29033, 29059, - 29063, 29077, 29101, 29123, 29129, 29131, 29137, 29147, 29153, 29167, - 29173, 29179, 29191, 29201, 29207, 29209, 29221, 29231, 29243, 29251, - 29269, 29287, 29297, 29303, 29311, 29327, 29333, 29339, 29347, 29363, - 29383, 29387, 29389, 29399, 29401, 29411, 29423, 29429, 29437, 29443, - 29453, 29473, 29483, 29501, 29527, 29531, 29537, 29567, 29569, 29573, - 29581, 29587, 29599, 29611, 29629, 29633, 29641, 29663, 29669, 29671, - 29683, 29717, 29723, 29741, 29753, 29759, 29761, 29789, 29803, 29819, - 29833, 29837, 29851, 29863, 29867, 29873, 29879, 29881, 29917, 29921, - 29927, 29947, 29959, 29983, 29989, 30011, 30013, 30029, 30047, 30059, - 30071, 30089, 30091, 30097, 30103, 30109, 30113, 30119, 30133, 30137, - 30139, 30161, 30169, 30181, 30187, 30197, 30203, 30211, 30223, 30241, - 30253, 30259, 30269, 30271, 30293, 30307, 30313, 30319, 30323, 30341, - 30347, 30367, 30389, 30391, 30403, 30427, 30431, 30449, 30467, 30469, - 30491, 30493, 30497, 30509, 30517, 30529, 30539, 30553, 30557, 30559, - 30577, 30593, 30631, 30637, 30643, 30649, 30661, 30671, 30677, 30689, - 30697, 30703, 30707, 30713, 30727, 30757, 30763, 30773, 30781, 30803, - 30809, 30817, 30829, 30839, 30841, 30851, 30853, 30859, 30869, 30871, - 30881, 30893, 30911, 30931, 30937, 30941, 30949, 30971, 30977, 30983, - 31013, 31019, 31033, 31039, 31051, 31063, 31069, 31079, 31081, 31091, - 31121, 31123, 31139, 31147, 31151, 31153, 31159, 31177, 31181, 31183, - 31189, 31193, 31219, 31223, 31231, 31237, 31247, 31249, 31253, 31259, - 31267, 31271, 31277, 31307, 31319, 31321, 31327, 31333, 31337, 31357, - 31379, 31387, 31391, 31393, 31397, 31469, 31477, 31481, 31489, 31511, - 31513, 31517, 31531, 31541, 31543, 31547, 31567, 31573, 31583, 31601, - 31607, 31627, 31643, 31649, 31657, 31663, 31667, 31687, 31699, 31721, - 31723, 31727, 31729, 31741, 31751, 31769, 31771, 31793, 31799, 31817, - 31847, 31849, 31859, 31873, 31883, 31891, 31907, 31957, 31963, 31973, - 31981, 31991, 32003, 32009, 32027, 32029, 32051, 32057, 32059, 32063, - 32069, 32077, 32083, 32089, 32099, 32117, 32119, 32141, 32143, 32159, - 32173, 32183, 32189, 32191, 32203, 32213, 32233, 32237, 32251, 32257, - 32261, 32297, 32299, 32303, 32309, 32321, 32323, 32327, 32341, 32353, - 32359, 32363, 32369, 32371, 32377, 32381, 32401, 32411, 32413, 32423, - 32429, 32441, 32443, 32467, 32479, 32491, 32497, 32503, 32507, 32531, - 32533, 32537, 32561, 32563, 32569, 32573, 32579, 32587, 32603, 32609, - 32611, 32621, 32633, 32647, 32653, 32687, 32693, 32707, 32713, 32717, - 32719, 32749, 32771, 32779, 32783, 32789, 32797, 32801, 32803, 32831, - 32833, 32839, 32843, 32869, 32887, 32909, 32911, 32917, 32933, 32939, - 32941, 32957, 32969, 32971, 32983, 32987, 32993, 32999, 33013, 33023, - 33029, 33037, 33049, 33053, 33071, 33073, 33083, 33091, 33107, 33113, - 33119, 33149, 33151, 33161, 33179, 33181, 33191, 33199, 33203, 33211, - 33223, 33247, 33287, 33289, 33301, 33311, 33317, 33329, 33331, 33343, - 33347, 33349, 33353, 33359, 33377, 33391, 33403, 33409, 33413, 33427, - 33457, 33461, 33469, 33479, 33487, 33493, 33503, 33521, 33529, 33533, - 33547, 33563, 33569, 33577, 33581, 33587, 33589, 33599, 33601, 33613, - 33617, 33619, 33623, 33629, 33637, 33641, 33647, 33679, 33703, 33713, - 33721, 33739, 33749, 33751, 33757, 33767, 33769, 33773, 33791, 33797, - 33809, 33811, 33827, 33829, 33851, 33857, 33863, 33871, 33889, 33893, - 33911, 33923, 33931, 33937, 33941, 33961, 33967, 33997, 34019, 34031, - 34033, 34039, 34057, 34061, 34123, 34127, 34129, 34141, 34147, 34157, - 34159, 34171, 34183, 34211, 34213, 34217, 34231, 34253, 34259, 34261, - 34267, 34273, 34283, 34297, 34301, 34303, 34313, 34319, 34327, 34337, - 34351, 34361, 34367, 34369, 34381, 34403, 34421, 34429, 34439, 34457, - 34469, 34471, 34483, 34487, 34499, 34501, 34511, 34513, 34519, 34537, - 34543, 34549, 34583, 34589, 34591, 34603, 34607, 34613, 34631, 34649, - 34651, 34667, 34673, 34679, 34687, 34693, 34703, 34721, 34729, 34739, - 34747, 34757, 34759, 34763, 34781, 34807, 34819, 34841, 34843, 34847, - 34849, 34871, 34877, 34883, 34897, 34913, 34919, 34939, 34949, 34961, - 34963, 34981, 35023, 35027, 35051, 35053, 35059, 35069, 35081, 35083, - 35089, 35099, 35107, 35111, 35117, 35129, 35141, 35149, 35153, 35159, - 35171, 35201, 35221, 35227, 35251, 35257, 35267, 35279, 35281, 35291, - 35311, 35317, 35323, 35327, 35339, 35353, 35363, 35381, 35393, 35401, - 35407, 35419, 35423, 35437, 35447, 35449, 35461, 35491, 35507, 35509, - 35521, 35527, 35531, 35533, 35537, 35543, 35569, 35573, 35591, 35593, - 35597, 35603, 35617, 35671, 35677, 35729, 35731, 35747, 35753, 35759, - 35771, 35797, 35801, 35803, 35809, 35831, 35837, 35839, 35851, 35863, - 35869, 35879, 35897, 35899, 35911, 35923, 35933, 35951, 35963, 35969, - 35977, 35983, 35993, 35999, 36007, 36011, 36013, 36017, 36037, 36061, - 36067, 36073, 36083, 36097, 36107, 36109, 36131, 36137, 36151, 36161, - 36187, 36191, 36209, 36217, 36229, 36241, 36251, 36263, 36269, 36277, - 36293, 36299, 36307, 36313, 36319, 36341, 36343, 36353, 36373, 36383, - 36389, 36433, 36451, 36457, 36467, 36469, 36473, 36479, 36493, 36497, - 36523, 36527, 36529, 36541, 36551, 36559, 36563, 36571, 36583, 36587, - 36599, 36607, 36629, 36637, 36643, 36653, 36671, 36677, 36683, 36691, - 36697, 36709, 36713, 36721, 36739, 36749, 36761, 36767, 36779, 36781, - 36787, 36791, 36793, 36809, 36821, 36833, 36847, 36857, 36871, 36877, - 36887, 36899, 36901, 36913, 36919, 36923, 36929, 36931, 36943, 36947, - 36973, 36979, 36997, 37003, 37013, 37019, 37021, 37039, 37049, 37057, - 37061, 37087, 37097, 37117, 37123, 37139, 37159, 37171, 37181, 37189, - 37199, 37201, 37217, 37223, 37243, 37253, 37273, 37277, 37307, 37309, - 37313, 37321, 37337, 37339, 37357, 37361, 37363, 37369, 37379, 37397, - 37409, 37423, 37441, 37447, 37463, 37483, 37489, 37493, 37501, 37507, - 37511, 37517, 37529, 37537, 37547, 37549, 37561, 37567, 37571, 37573, - 37579, 37589, 37591, 37607, 37619, 37633, 37643, 37649, 37657, 37663, - 37691, 37693, 37699, 37717, 37747, 37781, 37783, 37799, 37811, 37813, - 37831, 37847, 37853, 37861, 37871, 37879, 37889, 37897, 37907, 37951, - 37957, 37963, 37967, 37987, 37991, 37993, 37997, 38011, 38039, 38047, - 38053, 38069, 38083, 38113, 38119, 38149, 38153, 38167, 38177, 38183, - 38189, 38197, 38201, 38219, 38231, 38237, 38239, 38261, 38273, 38281, - 38287, 38299, 38303, 38317, 38321, 38327, 38329, 38333, 38351, 38371, - 38377, 38393, 38431, 38447, 38449, 38453, 38459, 38461, 38501, 38543, - 38557, 38561, 38567, 38569, 38593, 38603, 38609, 38611, 38629, 38639, - 38651, 38653, 38669, 38671, 38677, 38693, 38699, 38707, 38711, 38713, - 38723, 38729, 38737, 38747, 38749, 38767, 38783, 38791, 38803, 38821, - 38833, 38839, 38851, 38861, 38867, 38873, 38891, 38903, 38917, 38921, - 38923, 38933, 38953, 38959, 38971, 38977, 38993, 39019, 39023, 39041, - 39043, 39047, 39079, 39089, 39097, 39103, 39107, 39113, 39119, 39133, - 39139, 39157, 39161, 39163, 39181, 39191, 39199, 39209, 39217, 39227, - 39229, 39233, 39239, 39241, 39251, 39293, 39301, 39313, 39317, 39323, - 39341, 39343, 39359, 39367, 39371, 39373, 39383, 39397, 39409, 39419, - 39439, 39443, 39451, 39461, 39499, 39503, 39509, 39511, 39521, 39541, - 39551, 39563, 39569, 39581, 39607, 39619, 39623, 39631, 39659, 39667, - 39671, 39679, 39703, 39709, 39719, 39727, 39733, 39749, 39761, 39769, - 39779, 39791, 39799, 39821, 39827, 39829, 39839, 39841, 39847, 39857, - 39863, 39869, 39877, 39883, 39887, 39901, 39929, 39937, 39953, 39971, - 39979, 39983, 39989, 40009, 40013, 40031, 40037, 40039, 40063, 40087, - 40093, 40099, 40111, 40123, 40127, 40129, 40151, 40153, 40163, 40169, - 40177, 40189, 40193, 40213, 40231, 40237, 40241, 40253, 40277, 40283, - 40289, 40343, 40351, 40357, 40361, 40387, 40423, 40427, 40429, 40433, - 40459, 40471, 40483, 40487, 40493, 40499, 40507, 40519, 40529, 40531, - 40543, 40559, 40577, 40583, 40591, 40597, 40609, 40627, 40637, 40639, - 40693, 40697, 40699, 40709, 40739, 40751, 40759, 40763, 40771, 40787, - 40801, 40813, 40819, 40823, 40829, 40841, 40847, 40849, 40853, 40867, - 40879, 40883, 40897, 40903, 40927, 40933, 40939, 40949, 40961, 40973, - 40993, 41011, 41017, 41023, 41039, 41047, 41051, 41057, 41077, 41081, - 41113, 41117, 41131, 41141, 41143, 41149, 41161, 41177, 41179, 41183, - 41189, 41201, 41203, 41213, 41221, 41227, 41231, 41233, 41243, 41257, - 41263, 41269, 41281, 41299, 41333, 41341, 41351, 41357, 41381, 41387, - 41389, 41399, 41411, 41413, 41443, 41453, 41467, 41479, 41491, 41507, - 41513, 41519, 41521, 41539, 41543, 41549, 41579, 41593, 41597, 41603, - 41609, 41611, 41617, 41621, 41627, 41641, 41647, 41651, 41659, 41669, - 41681, 41687, 41719, 41729, 41737, 41759, 41761, 41771, 41777, 41801, - 41809, 41813, 41843, 41849, 41851, 41863, 41879, 41887, 41893, 41897, - 41903, 41911, 41927, 41941, 41947, 41953, 41957, 41959, 41969, 41981, - 41983, 41999, 42013, 42017, 42019, 42023, 42043, 42061, 42071, 42073, - 42083, 42089, 42101, 42131, 42139, 42157, 42169, 42179, 42181, 42187, - 42193, 42197, 42209, 42221, 42223, 42227, 42239, 42257, 42281, 42283, - 42293, 42299, 42307, 42323, 42331, 42337, 42349, 42359, 42373, 42379, - 42391, 42397, 42403, 42407, 42409, 42433, 42437, 42443, 42451, 42457, - 42461, 42463, 42467, 42473, 42487, 42491, 42499, 42509, 42533, 42557, - 42569, 42571, 42577, 42589, 42611, 42641, 42643, 42649, 42667, 42677, - 42683, 42689, 42697, 42701, 42703, 42709, 42719, 42727, 42737, 42743, - 42751, 42767, 42773, 42787, 42793, 42797, 42821, 42829, 42839, 42841, - 42853, 42859, 42863, 42899, 42901, 42923, 42929, 42937, 42943, 42953, - 42961, 42967, 42979, 42989, 43003, 43013, 43019, 43037, 43049, 43051, - 43063, 43067, 43093, 43103, 43117, 43133, 43151, 43159, 43177, 43189, - 43201, 43207, 43223, 43237, 43261, 43271, 43283, 43291, 43313, 43319, - 43321, 43331, 43391, 43397, 43399, 43403, 43411, 43427, 43441, 43451, - 43457, 43481, 43487, 43499, 43517, 43541, 43543, 43573, 43577, 43579, - 43591, 43597, 43607, 43609, 43613, 43627, 43633, 43649, 43651, 43661, - 43669, 43691, 43711, 43717, 43721, 43753, 43759, 43777, 43781, 43783, - 43787, 43789, 43793, 43801, 43853, 43867, 43889, 43891, 43913, 43933, - 43943, 43951, 43961, 43963, 43969, 43973, 43987, 43991, 43997, 44017, - 44021, 44027, 44029, 44041, 44053, 44059, 44071, 44087, 44089, 44101, - 44111, 44119, 44123, 44129, 44131, 44159, 44171, 44179, 44189, 44201, - 44203, 44207, 44221, 44249, 44257, 44263, 44267, 44269, 44273, 44279, - 44281, 44293, 44351, 44357, 44371, 44381, 44383, 44389, 44417, 44449, - 44453, 44483, 44491, 44497, 44501, 44507, 44519, 44531, 44533, 44537, - 44543, 44549, 44563, 44579, 44587, 44617, 44621, 44623, 44633, 44641, - 44647, 44651, 44657, 44683, 44687, 44699, 44701, 44711, 44729, 44741, - 44753, 44771, 44773, 44777, 44789, 44797, 44809, 44819, 44839, 44843, - 44851, 44867, 44879, 44887, 44893, 44909, 44917, 44927, 44939, 44953, - 44959, 44963, 44971, 44983, 44987, 45007, 45013, 45053, 45061, 45077, - 45083, 45119, 45121, 45127, 45131, 45137, 45139, 45161, 45179, 45181, - 45191, 45197, 45233, 45247, 45259, 45263, 45281, 45289, 45293, 45307, - 45317, 45319, 45329, 45337, 45341, 45343, 45361, 45377, 45389, 45403, - 45413, 45427, 45433, 45439, 45481, 45491, 45497, 45503, 45523, 45533, - 45541, 45553, 45557, 45569, 45587, 45589, 45599, 45613, 45631, 45641, - 45659, 45667, 45673, 45677, 45691, 45697, 45707, 45737, 45751, 45757, - 45763, 45767, 45779, 45817, 45821, 45823, 45827, 45833, 45841, 45853, - 45863, 45869, 45887, 45893, 45943, 45949, 45953, 45959, 45971, 45979, - 45989, 46021, 46027, 46049, 46051, 46061, 46073, 46091, 46093, 46099, - 46103, 46133, 46141, 46147, 46153, 46171, 46181, 46183, 46187, 46199, - 46219, 46229, 46237, 46261, 46271, 46273, 46279, 46301, 46307, 46309, - 46327, 46337, 46349, 46351, 46381, 46399, 46411, 46439, 46441, 46447, - 46451, 46457, 46471, 46477, 46489, 46499, 46507, 46511, 46523, 46549, - 46559, 46567, 46573, 46589, 46591, 46601, 46619, 46633, 46639, 46643, - 46649, 46663, 46679, 46681, 46687, 46691, 46703, 46723, 46727, 46747, - 46751, 46757, 46769, 46771, 46807, 46811, 46817, 46819, 46829, 46831, - 46853, 46861, 46867, 46877, 46889, 46901, 46919, 46933, 46957, 46993, - 46997, 47017, 47041, 47051, 47057, 47059, 47087, 47093, 47111, 47119, - 47123, 47129, 47137, 47143, 47147, 47149, 47161, 47189, 47207, 47221, - 47237, 47251, 47269, 47279, 47287, 47293, 47297, 47303, 47309, 47317, - 47339, 47351, 47353, 47363, 47381, 47387, 47389, 47407, 47417, 47419, - 47431, 47441, 47459, 47491, 47497, 47501, 47507, 47513, 47521, 47527, - 47533, 47543, 47563, 47569, 47581, 47591, 47599, 47609, 47623, 47629, - 47639, 47653, 47657, 47659, 47681, 47699, 47701, 47711, 47713, 47717, - 47737, 47741, 47743, 47777, 47779, 47791, 47797, 47807, 47809, 47819, - 47837, 47843, 47857, 47869, 47881, 47903, 47911, 47917, 47933, 47939, - 47947, 47951, 47963, 47969, 47977, 47981, 48017, 48023, 48029, 48049, - 48073, 48079, 48091, 48109, 48119, 48121, 48131, 48157, 48163, 48179, - 48187, 48193, 48197, 48221, 48239, 48247, 48259, 48271, 48281, 48299, - 48311, 48313, 48337, 48341, 48353, 48371, 48383, 48397, 48407, 48409, - 48413, 48437, 48449, 48463, 48473, 48479, 48481, 48487, 48491, 48497, - 48523, 48527, 48533, 48539, 48541, 48563, 48571, 48589, 48593, 48611, - 48619, 48623, 48647, 48649, 48661, 48673, 48677, 48679, 48731, 48733, - 48751, 48757, 48761, 48767, 48779, 48781, 48787, 48799, 48809, 48817, - 48821, 48823, 48847, 48857, 48859, 48869, 48871, 48883, 48889, 48907, - 48947, 48953, 48973, 48989, 48991, 49003, 49009, 49019, 49031, 49033, - 49037, 49043, 49057, 49069, 49081, 49103, 49109, 49117, 49121, 49123, - 49139, 49157, 49169, 49171, 49177, 49193, 49199, 49201, 49207, 49211, - 49223, 49253, 49261, 49277, 49279, 49297, 49307, 49331, 49333, 49339, - 49363, 49367, 49369, 49391, 49393, 49409, 49411, 49417, 49429, 49433, - 49451, 49459, 49463, 49477, 49481, 49499, 49523, 49529, 49531, 49537, - 49547, 49549, 49559, 49597, 49603, 49613, 49627, 49633, 49639, 49663, - 49667, 49669, 49681, 49697, 49711, 49727, 49739, 49741, 49747, 49757, - 49783, 49787, 49789, 49801, 49807, 49811, 49823, 49831, 49843, 49853, - 49871, 49877, 49891, 49919, 49921, 49927, 49937, 49939, 49943, 49957, - 49991, 49993, 49999, 50021, 50023, 50033, 50047, 50051, 50053, 50069, - 50077, 50087, 50093, 50101, 50111, 50119, 50123, 50129, 50131, 50147, - 50153, 50159, 50177, 50207, 50221, 50227, 50231, 50261, 50263, 50273, - 50287, 50291, 50311, 50321, 50329, 50333, 50341, 50359, 50363, 50377, - 50383, 50387, 50411, 50417, 50423, 50441, 50459, 50461, 50497, 50503, - 50513, 50527, 50539, 50543, 50549, 50551, 50581, 50587, 50591, 50593, - 50599, 50627, 50647, 50651, 50671, 50683, 50707, 50723, 50741, 50753, - 50767, 50773, 50777, 50789, 50821, 50833, 50839, 50849, 50857, 50867, - 50873, 50891, 50893, 50909, 50923, 50929, 50951, 50957, 50969, 50971, - 50989, 50993, 51001, 51031, 51043, 51047, 51059, 51061, 51071, 51109, - 51131, 51133, 51137, 51151, 51157, 51169, 51193, 51197, 51199, 51203, - 51217, 51229, 51239, 51241, 51257, 51263, 51283, 51287, 51307, 51329, - 51341, 51343, 51347, 51349, 51361, 51383, 51407, 51413, 51419, 51421, - 51427, 51431, 51437, 51439, 51449, 51461, 51473, 51479, 51481, 51487, - 51503, 51511, 51517, 51521, 51539, 51551, 51563, 51577, 51581, 51593, - 51599, 51607, 51613, 51631, 51637, 51647, 51659, 51673, 51679, 51683, - 51691, 51713, 51719, 51721, 51749, 51767, 51769, 51787, 51797, 51803, - 51817, 51827, 51829, 51839, 51853, 51859, 51869, 51871, 51893, 51899, - 51907, 51913, 51929, 51941, 51949, 51971, 51973, 51977, 51991, 52009, - 52021, 52027, 52051, 52057, 52067, 52069, 52081, 52103, 52121, 52127, - 52147, 52153, 52163, 52177, 52181, 52183, 52189, 52201, 52223, 52237, - 52249, 52253, 52259, 52267, 52289, 52291, 52301, 52313, 52321, 52361, - 52363, 52369, 52379, 52387, 52391, 52433, 52453, 52457, 52489, 52501, - 52511, 52517, 52529, 52541, 52543, 52553, 52561, 52567, 52571, 52579, - 52583, 52609, 52627, 52631, 52639, 52667, 52673, 52691, 52697, 52709, - 52711, 52721, 52727, 52733, 52747, 52757, 52769, 52783, 52807, 52813, - 52817, 52837, 52859, 52861, 52879, 52883, 52889, 52901, 52903, 52919, - 52937, 52951, 52957, 52963, 52967, 52973, 52981, 52999, 53003, 53017, - 53047, 53051, 53069, 53077, 53087, 53089, 53093, 53101, 53113, 53117, - 53129, 53147, 53149, 53161, 53171, 53173, 53189, 53197, 53201, 53231, - 53233, 53239, 53267, 53269, 53279, 53281, 53299, 53309, 53323, 53327, - 53353, 53359, 53377, 53381, 53401, 53407, 53411, 53419, 53437, 53441, - 53453, 53479, 53503, 53507, 53527, 53549, 53551, 53569, 53591, 53593, - 53597, 53609, 53611, 53617, 53623, 53629, 53633, 53639, 53653, 53657, - 53681, 53693, 53699, 53717, 53719, 53731, 53759, 53773, 53777, 53783, - 53791, 53813, 53819, 53831, 53849, 53857, 53861, 53881, 53887, 53891, - 53897, 53899, 53917, 53923, 53927, 53939, 53951, 53959, 53987, 53993, - 54001, 54011, 54013, 54037, 54049, 54059, 54083, 54091, 54101, 54121, - 54133, 54139, 54151, 54163, 54167, 54181, 54193, 54217, 54251, 54269, - 54277, 54287, 54293, 54311, 54319, 54323, 54331, 54347, 54361, 54367, - 54371, 54377, 54401, 54403, 54409, 54413, 54419, 54421, 54437, 54443, - 54449, 54469, 54493, 54497, 54499, 54503, 54517, 54521, 54539, 54541, - 54547, 54559, 54563, 54577, 54581, 54583, 54601, 54617, 54623, 54629, - 54631, 54647, 54667, 54673, 54679, 54709, 54713, 54721, 54727, 54751, - 54767, 54773, 54779, 54787, 54799, 54829, 54833, 54851, 54869, 54877, - 54881, 54907, 54917, 54919, 54941, 54949, 54959, 54973, 54979, 54983, - 55001, 55009, 55021, 55049, 55051, 55057, 55061, 55073, 55079, 55103, - 55109, 55117, 55127, 55147, 55163, 55171, 55201, 55207, 55213, 55217, - 55219, 55229, 55243, 55249, 55259, 55291, 55313, 55331, 55333, 55337, - 55339, 55343, 55351, 55373, 55381, 55399, 55411, 55439, 55441, 55457, - 55469, 55487, 55501, 55511, 55529, 55541, 55547, 55579, 55589, 55603, - 55609, 55619, 55621, 55631, 55633, 55639, 55661, 55663, 55667, 55673, - 55681, 55691, 55697, 55711, 55717, 55721, 55733, 55763, 55787, 55793, - 55799, 55807, 55813, 55817, 55819, 55823, 55829, 55837, 55843, 55849, - 55871, 55889, 55897, 55901, 55903, 55921, 55927, 55931, 55933, 55949, - 55967, 55987, 55997, 56003, 56009, 56039, 56041, 56053, 56081, 56087, - 56093, 56099, 56101, 56113, 56123, 56131, 56149, 56167, 56171, 56179, - 56197, 56207, 56209, 56237, 56239, 56249, 56263, 56267, 56269, 56299, - 56311, 56333, 56359, 56369, 56377, 56383, 56393, 56401, 56417, 56431, - 56437, 56443, 56453, 56467, 56473, 56477, 56479, 56489, 56501, 56503, - 56509, 56519, 56527, 56531, 56533, 56543, 56569, 56591, 56597, 56599, - 56611, 56629, 56633, 56659, 56663, 56671, 56681, 56687, 56701, 56711, - 56713, 56731, 56737, 56747, 56767, 56773, 56779, 56783, 56807, 56809, - 56813, 56821, 56827, 56843, 56857, 56873, 56891, 56893, 56897, 56909, - 56911, 56921, 56923, 56929, 56941, 56951, 56957, 56963, 56983, 56989, - 56993, 56999, 57037, 57041, 57047, 57059, 57073, 57077, 57089, 57097, - 57107, 57119, 57131, 57139, 57143, 57149, 57163, 57173, 57179, 57191, - 57193, 57203, 57221, 57223, 57241, 57251, 57259, 57269, 57271, 57283, - 57287, 57301, 57329, 57331, 57347, 57349, 57367, 57373, 57383, 57389, - 57397, 57413, 57427, 57457, 57467, 57487, 57493, 57503, 57527, 57529, - 57557, 57559, 57571, 57587, 57593, 57601, 57637, 57641, 57649, 57653, - 57667, 57679, 57689, 57697, 57709, 57713, 57719, 57727, 57731, 57737, - 57751, 57773, 57781, 57787, 57791, 57793, 57803, 57809, 57829, 57839, - 57847, 57853, 57859, 57881, 57899, 57901, 57917, 57923, 57943, 57947, - 57973, 57977, 57991, 58013, 58027, 58031, 58043, 58049, 58057, 58061, - 58067, 58073, 58099, 58109, 58111, 58129, 58147, 58151, 58153, 58169, - 58171, 58189, 58193, 58199, 58207, 58211, 58217, 58229, 58231, 58237, - 58243, 58271, 58309, 58313, 58321, 58337, 58363, 58367, 58369, 58379, - 58391, 58393, 58403, 58411, 58417, 58427, 58439, 58441, 58451, 58453, - 58477, 58481, 58511, 58537, 58543, 58549, 58567, 58573, 58579, 58601, - 58603, 58613, 58631, 58657, 58661, 58679, 58687, 58693, 58699, 58711, - 58727, 58733, 58741, 58757, 58763, 58771, 58787, 58789, 58831, 58889, - 58897, 58901, 58907, 58909, 58913, 58921, 58937, 58943, 58963, 58967, - 58979, 58991, 58997, 59009, 59011, 59021, 59023, 59029, 59051, 59053, - 59063, 59069, 59077, 59083, 59093, 59107, 59113, 59119, 59123, 59141, - 59149, 59159, 59167, 59183, 59197, 59207, 59209, 59219, 59221, 59233, - 59239, 59243, 59263, 59273, 59281, 59333, 59341, 59351, 59357, 59359, - 59369, 59377, 59387, 59393, 59399, 59407, 59417, 59419, 59441, 59443, - 59447, 59453, 59467, 59471, 59473, 59497, 59509, 59513, 59539, 59557, - 59561, 59567, 59581, 59611, 59617, 59621, 59627, 59629, 59651, 59659, - 59663, 59669, 59671, 59693, 59699, 59707, 59723, 59729, 59743, 59747, - 59753, 59771, 59779, 59791, 59797, 59809, 59833, 59863, 59879, 59887, - 59921, 59929, 59951, 59957, 59971, 59981, 59999, 60013, 60017, 60029, - 60037, 60041, 60077, 60083, 60089, 60091, 60101, 60103, 60107, 60127, - 60133, 60139, 60149, 60161, 60167, 60169, 60209, 60217, 60223, 60251, - 60257, 60259, 60271, 60289, 60293, 60317, 60331, 60337, 60343, 60353, - 60373, 60383, 60397, 60413, 60427, 60443, 60449, 60457, 60493, 60497, - 60509, 60521, 60527, 60539, 60589, 60601, 60607, 60611, 60617, 60623, - 60631, 60637, 60647, 60649, 60659, 60661, 60679, 60689, 60703, 60719, - 60727, 60733, 60737, 60757, 60761, 60763, 60773, 60779, 60793, 60811, - 60821, 60859, 60869, 60887, 60889, 60899, 60901, 60913, 60917, 60919, - 60923, 60937, 60943, 60953, 60961, 61001, 61007, 61027, 61031, 61043, - 61051, 61057, 61091, 61099, 61121, 61129, 61141, 61151, 61153, 61169, - 61211, 61223, 61231, 61253, 61261, 61283, 61291, 61297, 61331, 61333, - 61339, 61343, 61357, 61363, 61379, 61381, 61403, 61409, 61417, 61441, - 61463, 61469, 61471, 61483, 61487, 61493, 61507, 61511, 61519, 61543, - 61547, 61553, 61559, 61561, 61583, 61603, 61609, 61613, 61627, 61631, - 61637, 61643, 61651, 61657, 61667, 61673, 61681, 61687, 61703, 61717, - 61723, 61729, 61751, 61757, 61781, 61813, 61819, 61837, 61843, 61861, - 61871, 61879, 61909, 61927, 61933, 61949, 61961, 61967, 61979, 61981, - 61987, 61991, 62003, 62011, 62017, 62039, 62047, 62053, 62057, 62071, - 62081, 62099, 62119, 62129, 62131, 62137, 62141, 62143, 62171, 62189, - 62191, 62201, 62207, 62213, 62219, 62233, 62273, 62297, 62299, 62303, - 62311, 62323, 62327, 62347, 62351, 62383, 62401, 62417, 62423, 62459, - 62467, 62473, 62477, 62483, 62497, 62501, 62507, 62533, 62539, 62549, - 62563, 62581, 62591, 62597, 62603, 62617, 62627, 62633, 62639, 62653, - 62659, 62683, 62687, 62701, 62723, 62731, 62743, 62753, 62761, 62773, - 62791, 62801, 62819, 62827, 62851, 62861, 62869, 62873, 62897, 62903, - 62921, 62927, 62929, 62939, 62969, 62971, 62981, 62983, 62987, 62989, - 63029, 63031, 63059, 63067, 63073, 63079, 63097, 63103, 63113, 63127, - 63131, 63149, 63179, 63197, 63199, 63211, 63241, 63247, 63277, 63281, - 63299, 63311, 63313, 63317, 63331, 63337, 63347, 63353, 63361, 63367, - 63377, 63389, 63391, 63397, 63409, 63419, 63421, 63439, 63443, 63463, - 63467, 63473, 63487, 63493, 63499, 63521, 63527, 63533, 63541, 63559, - 63577, 63587, 63589, 63599, 63601, 63607, 63611, 63617, 63629, 63647, - 63649, 63659, 63667, 63671, 63689, 63691, 63697, 63703, 63709, 63719, - 63727, 63737, 63743, 63761, 63773, 63781, 63793, 63799, 63803, 63809, - 63823, 63839, 63841, 63853, 63857, 63863, 63901, 63907, 63913, 63929, - 63949, 63977, 63997, 64007, 64013, 64019, 64033, 64037, 64063, 64067, - 64081, 64091, 64109, 64123, 64151, 64153, 64157, 64171, 64187, 64189, - 64217, 64223, 64231, 64237, 64271, 64279, 64283, 64301, 64303, 64319, - 64327, 64333, 64373, 64381, 64399, 64403, 64433, 64439, 64451, 64453, - 64483, 64489, 64499, 64513, 64553, 64567, 64577, 64579, 64591, 64601, - 64609, 64613, 64621, 64627, 64633, 64661, 64663, 64667, 64679, 64693, - 64709, 64717, 64747, 64763, 64781, 64783, 64793, 64811, 64817, 64849, - 64853, 64871, 64877, 64879, 64891, 64901, 64919, 64921, 64927, 64937, - 64951, 64969, 64997, 65003, 65011, 65027, 65029, 65033, 65053, 65063, - 65071, 65089, 65099, 65101, 65111, 65119, 65123, 65129, 65141, 65147, - 65167, 65171, 65173, 65179, 65183, 65203, 65213, 65239, 65257, 65267, - 65269, 65287, 65293, 65309, 65323, 65327, 65353, 65357, 65371, 65381, - 65393, 65407, 65413, 65419, 65423, 65437, 65447, 65449, 65479, 65497, - 65519, 65521, 1 -}; diff --git a/test/llvm/cfrac.d/primes.h b/test/llvm/cfrac.d/primes.h deleted file mode 100644 index 206f480e0..000000000 --- a/test/llvm/cfrac.d/primes.h +++ /dev/null @@ -1,2 +0,0 @@ -extern unsigned int primesize; -extern unsigned short primes[]; diff --git a/test/llvm/cfrac.d/psqrt.c b/test/llvm/cfrac.d/psqrt.c deleted file mode 100644 index 00531a6fd..000000000 --- a/test/llvm/cfrac.d/psqrt.c +++ /dev/null @@ -1,29 +0,0 @@ -#include "precision.h" - -/* - * Square root - */ -precision psqrt(y) - precision y; -{ - int i; - precision x = pUndef, lastx = pUndef; - - i = pcmpz(pparm(y)); - if (i == 0) { /* if y == 0 */ - pset(&lastx, pzero); - } else if (i < 0) { /* if y negative */ - pset(&x, errorp(PDOMAIN, "psqrt", "negative argument")); - } else { - pset(&x, y); - do { - pset(&lastx, x); - pset(&x, phalf(padd(x, pdiv(y, x)))); - } while (plt(x, lastx)); - } - - pdestroy(x); - - pdestroy(y); - return presult(lastx); -} diff --git a/test/llvm/cfrac.d/psub.c b/test/llvm/cfrac.d/psub.c deleted file mode 100644 index d88728790..000000000 --- a/test/llvm/cfrac.d/psub.c +++ /dev/null @@ -1,92 +0,0 @@ -#include "pdefs.h" -#include "precision.h" -#include - -#ifdef ASM_16BIT -#include "asm16bit.h" -#endif - -/* - * Subtract u from v (assumes normalized) - */ -precision psub(u, v) -#ifndef ASM_16BIT - precision u, v; -{ - register digitPtr HiDigit, wPtr, uPtr; - register digitPtr vPtr; -#else - register precision u, v; -{ - register digitPtr wPtr, uPtr; -#endif - precision w; - register accumulator temp; -#ifndef ASM_16BIT - register digit noborrow; -#endif - register int i; - - (void) pparm(u); - (void) pparm(v); - if (u->sign != v->sign) { /* Are we actually adding? */ - w = pUndef; - v->sign = !v->sign; /* may generate -0 */ - pset(&w, padd(u, v)); - v->sign = !v->sign; - } else { - i = pcmp(u, v); - if (u->sign) i = -i; /* compare magnitudes only */ - - if (i < 0) { - w = u; u = v; v = w; /* make u the largest */ - } - - w = palloc(u->size); /* may produce much wasted storage */ - if (w == pUndef) return w; - - if (i < 0) w->sign = !u->sign; else w->sign = u->sign; - - uPtr = u->value; - wPtr = w->value; -#ifndef ASM_16BIT - vPtr = v->value; - noborrow = 1; - - HiDigit = v->value + v->size; /* digits in both args */ - do { - temp = (BASE-1) - *vPtr++; /* 0 <= temp < base */ - temp += *uPtr++; /* 0 <= temp < 2*base-1 */ - temp += noborrow; /* 0 <= temp < 2*base */ - noborrow = divBase(temp); /* 0 <= noborrow <= 1 */ - *wPtr++ = modBase(temp); - } while (vPtr < HiDigit); - - HiDigit = u->value + u->size; /* propagate borrow */ - while (uPtr < HiDigit) { - temp = (BASE-1) + *uPtr++; - temp += noborrow; /* 0 <= temp < 2 * base */ - noborrow = divBase(temp); /* 0 <= noborrow <= 1 */ - *wPtr++ = modBase(temp); - } /* noborrow = 1 */ -#else - i = v->size; - temp = u->size - i; - if (temp > 0) { - memcpy(wPtr + i, uPtr + i, temp * sizeof(digit)); - } - if (memsubw(wPtr, uPtr, v->value, i)) { /* trashes uPtr */ - memdecw(wPtr + i, temp); - } - wPtr += w->size; -#endif - do { /* normalize */ - if (*--wPtr != 0) break; - } while (wPtr > w->value); - w->size = (wPtr - w->value) + 1; - } - - pdestroy(u); - pdestroy(v); - return presult(w); -} diff --git a/test/llvm/cfrac.d/ptoa.c b/test/llvm/cfrac.d/ptoa.c deleted file mode 100644 index 812e8c7f3..000000000 --- a/test/llvm/cfrac.d/ptoa.c +++ /dev/null @@ -1,71 +0,0 @@ -#include -#include "pdefs.h" -#include "pcvt.h" -#include "precision.h" - -/* - * Return the character string decimal value of a Precision - */ -#if (BASE > 10) -#define CONDIGIT(d) ((d) < 10 ? (d) + '0' : (d) + 'a'-10) -#else -#define CONDIGIT(d) ((d) + '0') -#endif - -char *ptoa(u) - precision u; -{ - register accumulator temp; - register char *dPtr; - char *d; - int i = 0; - unsigned int consize; - precision r, v, pbase; - register int j; - - (void) pparm(u); - r = pUndef; - v = pUndef; - pbase = pUndef; - - consize = (unsigned int) u->size; - if (consize > MAXINT / aDigits) { - consize = (consize / pDigits) * aDigits; - } else { - consize = (consize * aDigits) / pDigits; - } - - consize += aDigitLog + 2; /* leading 0's, sign, & '\0' */ - d = (char *) allocate((unsigned int) consize); - if (d == (char *) 0) return d; - - pset(&v, pabs(u)); - pset(&pbase, utop(aDigit)); - - dPtr = d + consize; - *--dPtr = '\0'; /* null terminate string */ - i = u->sign; /* save sign */ - do { - pdivmod(v, pbase, &v, &r); - temp = ptou(r); /* Assumes unsigned and accumulator same! */ - j = aDigitLog; - do { - *--dPtr = CONDIGIT(temp % aBase); /* remainder */ - temp = temp / aBase; - } while (--j > 0); - } while (pnez(v)); - - while (*dPtr == '0') dPtr++; /* toss leading zero's */ - if (*dPtr == '\0') --dPtr; /* but don't waste zero! */ - if (i) *--dPtr = '-'; - if (dPtr > d) { /* ASSUME copied from lower to higher! */ - (void) memmove(d, dPtr, consize - (dPtr - d)); - } - - pdestroy(pbase); - pdestroy(v); - pdestroy(r); - - pdestroy(u); - return d; -} diff --git a/test/llvm/cfrac.d/ptob.c b/test/llvm/cfrac.d/ptob.c deleted file mode 100644 index d5b04c182..000000000 --- a/test/llvm/cfrac.d/ptob.c +++ /dev/null @@ -1,81 +0,0 @@ -#include "pdefs.h" -#include "precision.h" - -/* - * Convert a precision to a given base (the sign is ignored) - * - * Input: - * u - the number to convert - * dest - Where to put the ASCII representation radix - * WARNING! Not '\0' terminated, this is an exact image - * size - the number of digits of dest. - * (alphabet[0] padded on left) - * if size is too small, truncation occurs on left - * alphabet - A mapping from each radix digit to it's character digit - * (note: '\0' is perfectly OK as a digit) - * radix - The size of the alphabet, and the conversion radix - * 2 <= radix < 256. - * - * Returns: - * -1 if invalid radix - * 0 if successful - * >0 the number didn't fit - */ -int ptob(u, dest, size, alphabet, radix) - precision u; /* the number to convert */ - char *dest; /* where to place the converted ascii */ - unsigned int size; /* the size of the result in characters */ - char *alphabet; /* the character set forming the radix */ - register unsigned int radix; /* the size of the character set */ -{ - register accumulator temp; - register unsigned int i; - register char *chp; - unsigned int lgclump; - int res = 0; - - precision r = pUndef, v = pUndef, pbase = pUndef; - - if (radix > 256 || radix < 2) return -1; - if (size == 0) return 1; - - (void) pparm(u); - temp = radix; - i = 1; - while (temp * radix > temp) { - temp *= radix; - i++; - } - lgclump = i; - - pset(&v, pabs(u)); - pset(&pbase, utop(temp)); /* assumes accumulator and int are the same! */ - - chp = dest + size; - do { - pdivmod(v, pbase, &v, &r); - temp = ptou(r); /* assumes accumulator and int are the same! */ - i = lgclump; - do { - *--chp = alphabet[temp % radix]; /* remainder */ - temp = temp / radix; - if (chp == dest) goto bail; - } while (--i > 0); - } while pnez(v); - - if (chp > dest) do { - *--chp = *alphabet; - } while (chp > dest); - -bail: - if (pnez(v) || temp != 0) { /* check for overflow */ - res = 1; - } - - pdestroy(pbase); - pdestroy(v); - pdestroy(r); - - pdestroy(u); - return res; -} diff --git a/test/llvm/cfrac.d/ptou.c b/test/llvm/cfrac.d/ptou.c deleted file mode 100644 index 7106a5d28..000000000 --- a/test/llvm/cfrac.d/ptou.c +++ /dev/null @@ -1,31 +0,0 @@ -#include "pdefs.h" -#include "pcvt.h" -#include "precision.h" - -/* - * Precision to unsigned - */ -unsigned int ptou(u) - precision u; -{ - register digitPtr uPtr; - register accumulator temp; - - (void) pparm(u); - if (u->sign) { - temp = (unsigned int) errorp(PDOMAIN, "ptou", "negative argument"); - } else { - uPtr = u->value + u->size; - temp = 0; - do { - if (temp > divBase(MAXUNSIGNED - *--uPtr)) { - temp = (unsigned int) errorp(POVERFLOW, "ptou", "overflow"); - break; - } - temp = mulBase(temp); - temp += *uPtr; - } while (uPtr > u->value); - } - pdestroy(u); - return (unsigned int) temp; -} diff --git a/test/llvm/cfrac.d/seive.h b/test/llvm/cfrac.d/seive.h deleted file mode 100644 index 2e1cb85d0..000000000 --- a/test/llvm/cfrac.d/seive.h +++ /dev/null @@ -1,3 +0,0 @@ -extern unsigned long seivesize; - -extern unsigned char seive[]; diff --git a/test/llvm/cfrac.d/utop.c b/test/llvm/cfrac.d/utop.c deleted file mode 100644 index 4d87c0415..000000000 --- a/test/llvm/cfrac.d/utop.c +++ /dev/null @@ -1,25 +0,0 @@ -#include "pdefs.h" -#include "pcvt.h" -#include "precision.h" - -/* - * Unsigned to Precision - */ -precision utop(i) - register unsigned int i; -{ - register digitPtr uPtr; - register precision u = palloc(INTSIZE); - - if (u == pUndef) return pUndef; - - u->sign = false; - uPtr = u->value; - do { - *uPtr++ = modBase(i); - i = divBase(i); - } while (i != 0); - - u->size = (uPtr - u->value); - return presult(u); -} diff --git a/test/llvm/compare-with-gcc b/test/llvm/compare-with-gcc deleted file mode 100644 index b8f2c10da..000000000 --- a/test/llvm/compare-with-gcc +++ /dev/null @@ -1,38 +0,0 @@ -#!/bin/sh - -cilly=$1/cilly.byte.exe -CIL_MACHINE=`$1/machdep-ml32.exe --env` -export CIL_MACHINE - -mkdir -p temp - -for test in *.c; do - base=`basename $test .c` - echo -n "$base... " - gcc -o temp/$base.gcc $test - temp/$base.gcc >temp/$base.gcc.output - gcc -m32 -E $test -o temp/$base.i - $cilly --dollvm --envmachine temp/$base.i >temp/$base.ll - if llvm-as -f temp/$base.ll >/dev/null 2>/dev/null && - llc -march=x86 -f temp/$base.bc >/dev/null 2>/dev/null && - gcc -m32 -o temp/$base.llvm temp/$base.s >/dev/null 2>/dev/null && - temp/$base.llvm >temp/$base.llvm.output; then - if cmp temp/$base.gcc.output temp/$base.llvm.output; then - echo PASS - else - failed="$failed $base" - echo RUN FAILED - diff temp/$base.gcc.output temp/$base.llvm.output - fi - else - failed="$failed $base" - echo COMPILE FAILED - fi -done - -echo -if [ -z "$failed" ]; then - echo ALL TESTS PASSED -else - echo $failed FAILED -fi diff --git a/test/llvm/qsort.c b/test/llvm/qsort.c deleted file mode 100644 index f18739f5c..000000000 --- a/test/llvm/qsort.c +++ /dev/null @@ -1,105 +0,0 @@ -#include -#include -#include - -extern char *optarg; -void seq_sort(int base, int n); - -#define DEBUG - -int *from, *to; -int size = 8; -void (*selected_sort)(int base, int n) = seq_sort; - -void usage(void) -{ - fprintf(stderr, "Usage: qsort -sSEED -nSIZE -[123]\n"); - exit(2); -} - -int intopt(int min) -{ - int n = atoi(optarg); - - if (n < min) - usage(); - return n; - -} - -void setup(int argc, char **argv) -{ - int opt, i; - - srand48(42); - - while ((opt = getopt(argc, argv, "s:n:1234")) != -1) - switch (opt) - { - case 's': srand48(intopt(1)); break; - case 'n': size = intopt(2); break; - case '1': selected_sort = seq_sort; break; - default: usage(); - } - - from = malloc(size * sizeof *from); - to = malloc(size * sizeof *to); - - for (i = 0; i < size; i++) - from[i] = lrand48(); -} - -void seq_sort(int base, int n) -{ - int i, j, end_low, start_high; - - if (n <= 1) - return; - - int pivot = from[base]; - j = base; - - for (i = base; i < base + n; i++) - if (from[i] < pivot) - to[j++] = from[i]; - end_low = j; - - for (i = base; i < base + n; i++) - if (from[i] == pivot) - to[j++] = from[i]; - start_high = j; - - for (i = base; i < base + n; i++) - if (from[i] > pivot) - to[j++] = from[i]; - - for (i = base; i < base + n; i++) - from[i] = to[i]; - - seq_sort(base, end_low - base); - seq_sort(start_high, n - (start_high - base)); - -#ifndef NDEBUG - for (i = base + 1; i < base + n; i++) - if (from[i] < from[i - 1]) - { - fprintf(stderr, "missorted\n"); - exit(2); - } -#endif -} - -int main(int argc, char **argv) -{ - int i; - - setup(argc, argv); - - printf("starting sort...\n"); - selected_sort(0, size); -#ifdef DEBUG - for (i = 0; i < size; i++) - printf("%d\n", from[i]); -#endif - return 0; -} diff --git a/test/llvm/test1.c b/test/llvm/test1.c deleted file mode 100644 index 42f6f5bae..000000000 --- a/test/llvm/test1.c +++ /dev/null @@ -1,10 +0,0 @@ -#include - -int x; - -int main(int argc, char **argv) -{ - x = 2; - printf("hello world\n"); - return 0; -} diff --git a/test/llvm/test10.c b/test/llvm/test10.c deleted file mode 100644 index 7cd9cb4ff..000000000 --- a/test/llvm/test10.c +++ /dev/null @@ -1,14 +0,0 @@ -#include - -int x; -char y; - -int main(int argc, char **argv) -{ - y = 7; - x = -y; - if (!argv) - x = -x; - printf("hello world - x is %d\n", x); - return 0; -} diff --git a/test/llvm/test11.c b/test/llvm/test11.c deleted file mode 100644 index 81f184f04..000000000 --- a/test/llvm/test11.c +++ /dev/null @@ -1,15 +0,0 @@ -#include - -int x; -char y; -double z; - -int main(int argc, char **argv) -{ - y = 7; - x = -y; - if (!z) - x = -x; - printf("hello world - x is %d\n", x); - return 0; -} diff --git a/test/llvm/test12.c b/test/llvm/test12.c deleted file mode 100644 index 7de861cf2..000000000 --- a/test/llvm/test12.c +++ /dev/null @@ -1,15 +0,0 @@ -#include - -int x; -char y; -double z; - -int main(int argc, char **argv) -{ - y = 7; - x = -y; - if (z) - x = -x; - printf("hello world - x is %d\n", x); - return 0; -} diff --git a/test/llvm/test13.c b/test/llvm/test13.c deleted file mode 100644 index 2b1395be2..000000000 --- a/test/llvm/test13.c +++ /dev/null @@ -1,18 +0,0 @@ -#include - -int a[20]; - -int f(int *b) -{ - b[0] = 33; - b[2] = 19; - - return b[2]; -} - -int main(int argc, char **argv) -{ - int zz = f(a); - printf("%d\n", zz); - return 0; -} diff --git a/test/llvm/test14.c b/test/llvm/test14.c deleted file mode 100644 index 72c201887..000000000 --- a/test/llvm/test14.c +++ /dev/null @@ -1,24 +0,0 @@ -#include - -int a[20]; - -int f(void) -{ - int *b = a; - int i, sum = 0; - - for (i = 0; i < 20; i++) - b[i] = i * 2; - - for (i = 5; i < 15; i++) - sum += a[i]; - - return sum; -} - -int main(int argc, char **argv) -{ - int zz = f(); - printf("%d\n", zz); - return 0; -} diff --git a/test/llvm/test15.c b/test/llvm/test15.c deleted file mode 100644 index 284d49351..000000000 --- a/test/llvm/test15.c +++ /dev/null @@ -1,14 +0,0 @@ -#include - -struct { - int a, b; -} x; - -int main(int argc, char **argv) -{ - x.a = x.b = 2; - if (argc) - x.b += x.a; - printf("hello world - x.a is %d and x.b is %d\n", x.a, x.b); - return 0; -} diff --git a/test/llvm/test16.c b/test/llvm/test16.c deleted file mode 100644 index 4090ce1f2..000000000 --- a/test/llvm/test16.c +++ /dev/null @@ -1,15 +0,0 @@ -#include - -struct zz { - int a, b; -}; -struct zz x; - -int main(int argc, char **argv) -{ - x.a = x.b = 2; - if (argc) - x.b += x.a; - printf("hello world - x.a is %d and x.b is %d\n", x.a, x.b); - return 0; -} diff --git a/test/llvm/test17.c b/test/llvm/test17.c deleted file mode 100644 index 04820e453..000000000 --- a/test/llvm/test17.c +++ /dev/null @@ -1,19 +0,0 @@ -#include - -int silly(int w) -{ - int a = 7; - - switch (w) { - case 11: return 22; - case 5: a = 9; - case 6: return a * 7; - } - return a; -} - -int main(int argc, char **argv) -{ - printf("hello world - %d %d %d %d\n", silly(0), silly(11), silly(5), silly(6)); - return 0; -} diff --git a/test/llvm/test18.c b/test/llvm/test18.c deleted file mode 100644 index b12accc7c..000000000 --- a/test/llvm/test18.c +++ /dev/null @@ -1,16 +0,0 @@ -#include - -void silly(int *w) -{ - (*w)++; -} - -int main(int argc, char **argv) -{ - int zz = 9; - - silly(&zz); - - printf("hello world - %d\n", zz); - return 0; -} diff --git a/test/llvm/test19.c b/test/llvm/test19.c deleted file mode 100644 index daac78490..000000000 --- a/test/llvm/test19.c +++ /dev/null @@ -1,9 +0,0 @@ -#include - -struct fun { int x, y; double z; } a = { 1, 12, 32.3 }; - -int main(int argc, char **argv) -{ - printf("hello world %d %d %f\n", a.x, a.y, a.z); - return 0; -} diff --git a/test/llvm/test2.c b/test/llvm/test2.c deleted file mode 100644 index 5898a29f9..000000000 --- a/test/llvm/test2.c +++ /dev/null @@ -1,12 +0,0 @@ -#include - -int x; - -int main(int argc, char **argv) -{ - x = 2; - if (argc) - x = -x; - printf("hello world - %d args, and x is %d\n", -argc, x); - return 0; -} diff --git a/test/llvm/test20.c b/test/llvm/test20.c deleted file mode 100644 index 2d63070cf..000000000 --- a/test/llvm/test20.c +++ /dev/null @@ -1,9 +0,0 @@ -#include - -struct fun { int x, y; double z; } a = { 1 }; - -int main(int argc, char **argv) -{ - printf("hello world %d %d %f\n", a.x, a.y, a.z); - return 0; -} diff --git a/test/llvm/test21.c b/test/llvm/test21.c deleted file mode 100644 index 19049bf38..000000000 --- a/test/llvm/test21.c +++ /dev/null @@ -1,9 +0,0 @@ -#include - -struct fun { int x, y; struct { int a, b; } z; } a = { 1, .z = { 33, 44 } }; - -int main(int argc, char **argv) -{ - printf("hello world %d %d %d\n", a.x, a.y, a.z.b); - return 0; -} diff --git a/test/llvm/test22.c b/test/llvm/test22.c deleted file mode 100644 index b82afc48f..000000000 --- a/test/llvm/test22.c +++ /dev/null @@ -1,10 +0,0 @@ -#include - -struct fun { int x, y; struct { int a, b; } z; } a = { 1, .z = { 33, 44 } }; - -int main(int argc, char **argv) -{ - a.z.b = 19; - printf("hello world %d %d %d\n", a.x, a.y, a.z.b); - return 0; -} diff --git a/test/llvm/test23.c b/test/llvm/test23.c deleted file mode 100644 index 5049fd664..000000000 --- a/test/llvm/test23.c +++ /dev/null @@ -1,9 +0,0 @@ -#include - -int a[4] = { 0, 4, 7, -1 }; - -int main(int argc, char **argv) -{ - printf("hello world %d %d %d\n", a[1], a[2], a[3]); - return 0; -} diff --git a/test/llvm/test24.c b/test/llvm/test24.c deleted file mode 100644 index bc9fb03a1..000000000 --- a/test/llvm/test24.c +++ /dev/null @@ -1,9 +0,0 @@ -#include - -int a[4] = { 0, 4, 7 }; - -int main(int argc, char **argv) -{ - printf("hello world %d %d %d\n", a[1], a[2], a[3]); - return 0; -} diff --git a/test/llvm/test25.c b/test/llvm/test25.c deleted file mode 100644 index b27753ea4..000000000 --- a/test/llvm/test25.c +++ /dev/null @@ -1,9 +0,0 @@ -#include - -int a[4][4] = { 0, 4, 7 }; - -int main(int argc, char **argv) -{ - printf("hello world %d %d %d\n", a[0][1], a[2][2], a[0][3]); - return 0; -} diff --git a/test/llvm/test26.c b/test/llvm/test26.c deleted file mode 100644 index 11ad7bf21..000000000 --- a/test/llvm/test26.c +++ /dev/null @@ -1,9 +0,0 @@ -#include - -char s[] = "fun"; - -int main(int argc, char **argv) -{ - printf("hello world %d %d %d\n", s[0], s[1], s[3]); - return 0; -} diff --git a/test/llvm/test27.c b/test/llvm/test27.c deleted file mode 100644 index a1e2a9755..000000000 --- a/test/llvm/test27.c +++ /dev/null @@ -1,9 +0,0 @@ -#include - -char *s = "fun"; - -int main(int argc, char **argv) -{ - printf("hello world %d %d %d\n", s[0], s[1], s[3]); - return 0; -} diff --git a/test/llvm/test28.c b/test/llvm/test28.c deleted file mode 100644 index 838efab95..000000000 --- a/test/llvm/test28.c +++ /dev/null @@ -1,9 +0,0 @@ -#include - -char *s[] = { "fun", "baz" }; - -int main(int argc, char **argv) -{ - printf("hello world %d %d %s\n", s[0][0], s[0][1], s[1]); - return 0; -} diff --git a/test/llvm/test29.c b/test/llvm/test29.c deleted file mode 100644 index d2b33e942..000000000 --- a/test/llvm/test29.c +++ /dev/null @@ -1,11 +0,0 @@ -#include - -int a = 1, b = 2; -int *s[] = { &a, &b }; - -int main(int argc, char **argv) -{ - *s[0] = 22; - printf("hello world %d %d\n", a, b); - return 0; -} diff --git a/test/llvm/test3.c b/test/llvm/test3.c deleted file mode 100644 index 218ebe590..000000000 --- a/test/llvm/test3.c +++ /dev/null @@ -1,18 +0,0 @@ -#include - -int f(void) -{ - int a[20]; - - a[0] = 33; - a[2] = 19; - - return a[2]; -} - -int main(int argc, char **argv) -{ - int zz = f(); - printf("%d\n", zz); - return 0; -} diff --git a/test/llvm/test30.c b/test/llvm/test30.c deleted file mode 100644 index cafb9e46b..000000000 --- a/test/llvm/test30.c +++ /dev/null @@ -1,11 +0,0 @@ -#include - -char s1[] = "aa", s2[] = "bb"; - -char *s[] = { s1, s2 }; - -int main(int argc, char **argv) -{ - printf("hello world %d %d\n", s[0][1], s[1][0]); - return 0; -} diff --git a/test/llvm/test31.c b/test/llvm/test31.c deleted file mode 100644 index 5a3c2fe55..000000000 --- a/test/llvm/test31.c +++ /dev/null @@ -1,16 +0,0 @@ -#include - -void silly(int *w) -{ - w[1]++; -} - -int main(int argc, char **argv) -{ - int zz[2] = { 3, 5}; - - silly(zz); - - printf("hello world - %d\n", zz[1]); - return 0; -} diff --git a/test/llvm/test32.c b/test/llvm/test32.c deleted file mode 100644 index 8b5b6ac14..000000000 --- a/test/llvm/test32.c +++ /dev/null @@ -1,11 +0,0 @@ -#include - -char s1[] = "aa", s2[] = "bb"; - -char *s[] = { s1 + 1, s2 }; - -int main(int argc, char **argv) -{ - printf("hello world %d %d\n", s[0][0], s[1][0]); - return 0; -} diff --git a/test/llvm/test33.c b/test/llvm/test33.c deleted file mode 100644 index f5f64c4cd..000000000 --- a/test/llvm/test33.c +++ /dev/null @@ -1,11 +0,0 @@ -#include - -char s1[] = "aa", s2[] = "bb"; - -char *s[] = { s1 + 2 - 1, s2 }; - -int main(int argc, char **argv) -{ - printf("hello world %d %d\n", s[0][0], s[1][0]); - return 0; -} diff --git a/test/llvm/test34.c b/test/llvm/test34.c deleted file mode 100644 index a6e0a7ed7..000000000 --- a/test/llvm/test34.c +++ /dev/null @@ -1,11 +0,0 @@ -#include - -char s1[] = "aa", s2[] = "bb"; - -char *s[] = { &s1[1], s2 }; - -int main(int argc, char **argv) -{ - printf("hello world %d %d\n", s[0][0], s[1][0]); - return 0; -} diff --git a/test/llvm/test35.c b/test/llvm/test35.c deleted file mode 100644 index 9a7d569ef..000000000 --- a/test/llvm/test35.c +++ /dev/null @@ -1,13 +0,0 @@ -#include - -char s1[] = "aa", s2[] = "bb"; - -long s[] = { (long)s1, (long)s2 }; - -int main(int argc, char **argv) -{ - char *fun = (char *)s[1]; - - printf("hello world %ld %ld\n", fun[0], fun[2]); - return 0; -} diff --git a/test/llvm/test36.c b/test/llvm/test36.c deleted file mode 100644 index b2ebae98b..000000000 --- a/test/llvm/test36.c +++ /dev/null @@ -1,24 +0,0 @@ -#include - -struct a { - int x, y; -} z; - -struct a g(struct a b) -{ - b.x++; - return b; -} - -void f(void) -{ - z = g(z); -} - -int main(int argc, char **argv) -{ - z.x = 22; - f(); - printf("hello world %d %d\n", z.x, z.y); - return 0; -} diff --git a/test/llvm/test37.c b/test/llvm/test37.c deleted file mode 100644 index 9a491e598..000000000 --- a/test/llvm/test37.c +++ /dev/null @@ -1,26 +0,0 @@ -#include - -struct a { - int x, y; -} z; - -struct a g(struct a b) -{ - b.x++; - return b; -} - -void f(void) -{ - struct a tt = z; - - z = g(tt); -} - -int main(int argc, char **argv) -{ - z.x = 22; - f(); - printf("hello world %d %d\n", z.x, z.y); - return 0; -} diff --git a/test/llvm/test38.c b/test/llvm/test38.c deleted file mode 100644 index f20ba4c2e..000000000 --- a/test/llvm/test38.c +++ /dev/null @@ -1,10 +0,0 @@ -#include - -static int x; - -int main(int argc, char **argv) -{ - x = 2; - printf("hello world %d\n", x); - return 0; -} diff --git a/test/llvm/test39.c b/test/llvm/test39.c deleted file mode 100644 index b1d2c4d83..000000000 --- a/test/llvm/test39.c +++ /dev/null @@ -1,9 +0,0 @@ -#include - -static int x = 99; - -int main(int argc, char **argv) -{ - printf("hello world %d\n", x); - return 0; -} diff --git a/test/llvm/test4.c b/test/llvm/test4.c deleted file mode 100644 index 113d97139..000000000 --- a/test/llvm/test4.c +++ /dev/null @@ -1,18 +0,0 @@ -#include - -int a[20]; - -int f(void) -{ - a[0] = 33; - a[2] = 19; - - return a[2]; -} - -int main(int argc, char **argv) -{ - int zz = f(); - printf("%d\n", zz); - return 0; -} diff --git a/test/llvm/test40.c b/test/llvm/test40.c deleted file mode 100644 index 5ba69bfc4..000000000 --- a/test/llvm/test40.c +++ /dev/null @@ -1,8 +0,0 @@ -#include -#include - -int main(int argc, char **argv) -{ - wprintf(L"hello world\n"); - return 0; -} diff --git a/test/llvm/test41.c b/test/llvm/test41.c deleted file mode 100644 index c7a1a5e48..000000000 --- a/test/llvm/test41.c +++ /dev/null @@ -1,22 +0,0 @@ -#include -#include - -int sum(int s0, ...) -{ - va_list args; - int s = s0, n; - - va_start(args, s0); - while (n = va_arg(args, int)) - s += n; - va_end(args); - - return s; -} - -int main(int argc, char **argv) -{ - int x = sum(4, 3, 32, 22, 0); - printf("hello world %d\n", x); - return 0; -} diff --git a/test/llvm/test42.c b/test/llvm/test42.c deleted file mode 100644 index 435f47187..000000000 --- a/test/llvm/test42.c +++ /dev/null @@ -1,30 +0,0 @@ -#include -#include - -int sum(int s0, ...) -{ - va_list args, copy; - int s = s0, n; - - va_start(args, s0); - while (n = va_arg(args, int)) - { - if (s == s0) - va_copy(copy, args); - s += n; - } - va_end(args); - - while (n = va_arg(copy, int)) - s += n; - va_end(copy); - - return s; -} - -int main(int argc, char **argv) -{ - int x = sum(4, 3, 32, 22, 0); - printf("hello world %d\n", x); - return 0; -} diff --git a/test/llvm/test43.c b/test/llvm/test43.c deleted file mode 100644 index ea333f6b5..000000000 --- a/test/llvm/test43.c +++ /dev/null @@ -1,18 +0,0 @@ -#include -#include - -void myprintf(char *extra, char *fmt, ...) -{ - va_list pargs; - - fputs(extra, stdout); putc(':', stdout); - va_start(pargs, fmt); - vprintf(fmt, pargs); - va_end(pargs); -} - -int main(int argc, char **argv) -{ - myprintf("yes", "hello world %d\n", 12); - return 0; -} diff --git a/test/llvm/test44.c b/test/llvm/test44.c deleted file mode 100644 index a3c488a28..000000000 --- a/test/llvm/test44.c +++ /dev/null @@ -1,24 +0,0 @@ -#include -#include - -int blah(void); - -double sum(int s0, ...) -{ - va_list args; - double s = s0, n; - - va_start(args, s0); - while (n = va_arg(args, int)) - s += n; - va_end(args); - - return s; -} - -int main(int argc, char **argv) -{ - double x = sum(4, 3, 32, 22, 0); - printf("hello world %f\n", x); - return 0; -} diff --git a/test/llvm/test45.c b/test/llvm/test45.c deleted file mode 100644 index 7cdd26eb2..000000000 --- a/test/llvm/test45.c +++ /dev/null @@ -1,10 +0,0 @@ -#include - -int f(void) { return 2; } - -int main(int argc, char **argv) -{ - f(); - printf("hello world\n"); - return 0; -} diff --git a/test/llvm/test46.c b/test/llvm/test46.c deleted file mode 100644 index 41a7ac69c..000000000 --- a/test/llvm/test46.c +++ /dev/null @@ -1,24 +0,0 @@ -#include - -int a[10][20]; -int (*b)[20] = a; - -int f(void) -{ - int i, sum = 0; - - for (i = 0; i < 20; i++) - b[1][i] = i * 2; - - for (i = 5; i < 15; i++) - sum += a[1][i]; - - return sum; -} - -int main(int argc, char **argv) -{ - int zz = f(); - printf("%d\n", zz); - return 0; -} diff --git a/test/llvm/test47.c b/test/llvm/test47.c deleted file mode 100644 index ceb31870c..000000000 --- a/test/llvm/test47.c +++ /dev/null @@ -1,27 +0,0 @@ -#include - -int a[10][20]; -int (*b)[20] = a; - -int f(void) -{ - int i, sum1 = 0, sum2 = 0; - - for (i = 0; i < 20; i++) - b[1][i] = i * 2; - - for (i = 5; i < 15; i++) - sum1 += a[1][i]; - - for (i = 5; i < 15; i++) - sum2 += b[1][i]; - - return sum1 == sum2; -} - -int main(int argc, char **argv) -{ - int zz = f(); - printf("%d\n", zz); - return 0; -} diff --git a/test/llvm/test48.c b/test/llvm/test48.c deleted file mode 100644 index 89d63e93c..000000000 --- a/test/llvm/test48.c +++ /dev/null @@ -1,31 +0,0 @@ -#include - -struct fun { - int x, y; -}; - -struct fun a[10][20]; -struct fun (*b)[20] = a; - -int f(void) -{ - int i, sum1 = 0, sum2 = 0; - - for (i = 0; i < 20; i++) - b[1][i].x = i * 2; - - for (i = 5; i < 15; i++) - sum1 += a[1][i].x; - - for (i = 5; i < 15; i++) - sum2 += b[1][i].x; - - return (sum1 == sum2); -} - -int main(int argc, char **argv) -{ - int zz = f(); - printf("%d\n", zz); - return 0; -} diff --git a/test/llvm/test49.c b/test/llvm/test49.c deleted file mode 100644 index d50147933..000000000 --- a/test/llvm/test49.c +++ /dev/null @@ -1,23 +0,0 @@ -#include - -struct fun { - int x, y; -}; - -struct fun d; -struct fun *c = &d; - -int f(void) -{ - c->x = 11; - d.x = 12; - - return c->x + d.x; -} - -int main(int argc, char **argv) -{ - int zz = f(); - printf("%d\n", zz); - return 0; -} diff --git a/test/llvm/test5.c b/test/llvm/test5.c deleted file mode 100644 index 64fa90349..000000000 --- a/test/llvm/test5.c +++ /dev/null @@ -1,10 +0,0 @@ -#include - -int main(int argc, char **argv) -{ - int x = 2; - if (argc) - x = -x; - printf("hello world - %d args, and x is %d\n", -argc, x); - return 0; -} diff --git a/test/llvm/test50.c b/test/llvm/test50.c deleted file mode 100644 index fb4074507..000000000 --- a/test/llvm/test50.c +++ /dev/null @@ -1,24 +0,0 @@ -#include - -int a[10][20]; -int (*b)[20] = a; - -int f(void) -{ - int i, sum = 0, *c = b[1]; - - for (i = 0; i < 20; i++) - c[i] = i * 2; - - for (i = 5; i < 15; i++) - sum += a[1][i]; - - return sum; -} - -int main(int argc, char **argv) -{ - int zz = f(); - printf("%d\n", zz); - return 0; -} diff --git a/test/llvm/test51.c b/test/llvm/test51.c deleted file mode 100644 index 46f0e5f85..000000000 --- a/test/llvm/test51.c +++ /dev/null @@ -1,29 +0,0 @@ -#include - -int x(void) -{ - int a, b; - - b = 1; - a = b; - b = 2; - - return a; -} - -int y(void) -{ - int b, a; - - b = 1; - a = b; - b = 2; - - return a; -} - -int main(int argc, char **argv) -{ - printf("hello world %d %d\n", x(), y()); - return 0; -} diff --git a/test/llvm/test52.c b/test/llvm/test52.c deleted file mode 100644 index c30f25534..000000000 --- a/test/llvm/test52.c +++ /dev/null @@ -1,5 +0,0 @@ -int main(int argc, char **argv) -{ - printf("hello world\n"); - return 0; -} diff --git a/test/llvm/test53.c b/test/llvm/test53.c deleted file mode 100644 index c22939205..000000000 --- a/test/llvm/test53.c +++ /dev/null @@ -1,10 +0,0 @@ -#include - -double x; - -int main(int argc, char **argv) -{ - x = -1.0E+15; - printf("hello world %g\n", x); - return 0; -} diff --git a/test/llvm/test54.c b/test/llvm/test54.c deleted file mode 100644 index 9707c64c9..000000000 --- a/test/llvm/test54.c +++ /dev/null @@ -1,23 +0,0 @@ -typedef struct { - int *value; -} precisionType; - -typedef precisionType *precision; - - - -void pnorm(u) - precision u; -{ - int *uPtr; - - uPtr = u->value; - do { - if (*--uPtr != 0) break; - } while (uPtr > u->value); -} - -int main(int argc, char **argv) -{ - return 0; -} diff --git a/test/llvm/test55.c b/test/llvm/test55.c deleted file mode 100644 index e8239b880..000000000 --- a/test/llvm/test55.c +++ /dev/null @@ -1,22 +0,0 @@ -#include - -struct fun -{ - int x; -} a = { 32 }; - -void pfun2(struct fun **z) -{ -} - -void pfun(struct fun *z) -{ - pfun2(&z); - printf("%d\n", z->x); -} - -int main(int argc, char **argv) -{ - pfun(&a); - return 0; -} diff --git a/test/llvm/test56.c b/test/llvm/test56.c deleted file mode 100644 index ea2b72e9b..000000000 --- a/test/llvm/test56.c +++ /dev/null @@ -1,14 +0,0 @@ -#include - -unsigned short a = 50336, b = 1995; - -int sum(void) -{ - return a + b; -} - -int main(int argc, char **argv) -{ - printf("hello world %d\n", sum()); - return 0; -} diff --git a/test/llvm/test57.c b/test/llvm/test57.c deleted file mode 100644 index c829add8f..000000000 --- a/test/llvm/test57.c +++ /dev/null @@ -1,9 +0,0 @@ -#include - -float a = 3; - -int main(int argc, char **argv) -{ - printf("hello world %g\n", a); - return 0; -} diff --git a/test/llvm/test58.c b/test/llvm/test58.c deleted file mode 100644 index 9622ef265..000000000 --- a/test/llvm/test58.c +++ /dev/null @@ -1,14 +0,0 @@ -#include - -float a = 3; - -void f(double x) -{ - printf("hello %g\n", x); -} - -int main(int argc, char **argv) -{ - f(a); - return 0; -} diff --git a/test/llvm/test59.c b/test/llvm/test59.c deleted file mode 100644 index d15d01212..000000000 --- a/test/llvm/test59.c +++ /dev/null @@ -1,27 +0,0 @@ -#include -#include - -typedef __builtin_va_list __gnuc_va_list; - -extern int vfprintf (FILE *__restrict __s, __const char *__restrict __format, - __gnuc_va_list __arg); - -int wprintf (__const char *__restrict __fmt, __gnuc_va_list __arg) -{ - return vfprintf (stdout, __fmt, __arg); -} - -void xprintf(__const char *__restrict __fmt, ...) -{ - va_list vl; - - va_start(vl, __fmt); - wprintf(__fmt, vl); - va_end(vl); -} - -int main() -{ - xprintf("foo\n"); - return 0; -} diff --git a/test/llvm/test6.c b/test/llvm/test6.c deleted file mode 100644 index 2b36f26f9..000000000 --- a/test/llvm/test6.c +++ /dev/null @@ -1,20 +0,0 @@ -#include - -int a[20]; - -int f(void) -{ - int *b = a; - - b[0] = 33; - b[2] = 19; - - return b[2]; -} - -int main(int argc, char **argv) -{ - int zz = f(); - printf("%d\n", zz); - return 0; -} diff --git a/test/llvm/test7.c b/test/llvm/test7.c deleted file mode 100644 index 8007fa97b..000000000 --- a/test/llvm/test7.c +++ /dev/null @@ -1,14 +0,0 @@ -#include - -int x; -char y; - -int main(int argc, char **argv) -{ - y = 7; - x = y; - if (argc) - x = -x; - printf("hello world - x is %d\n", x); - return 0; -} diff --git a/test/llvm/test8.c b/test/llvm/test8.c deleted file mode 100644 index 233f3e018..000000000 --- a/test/llvm/test8.c +++ /dev/null @@ -1,14 +0,0 @@ -#include - -int x; -char y; - -int main(int argc, char **argv) -{ - y = 7; - x = -y; - if (argc) - x = -x; - printf("hello world - x is %d\n", x); - return 0; -} diff --git a/test/llvm/test9.c b/test/llvm/test9.c deleted file mode 100644 index 23f7767dd..000000000 --- a/test/llvm/test9.c +++ /dev/null @@ -1,14 +0,0 @@ -#include - -int x; -char y; - -int main(int argc, char **argv) -{ - y = 7; - x = -y; - if (argv) - x = -x; - printf("hello world - x is %d\n", x); - return 0; -} diff --git a/test/small1/array_formal.c b/test/small1/array_formal.c index 31fc6030f..6c948a834 100755 --- a/test/small1/array_formal.c +++ b/test/small1/array_formal.c @@ -27,18 +27,17 @@ int test2(int n, int ra[n][100]) { // Here, *ra has type int[n], so sizeof(*ra) == 4*n. // But CIL doesn't support arrays with non-constant sizes. -/* int test3(int n, int ra[5][n]) { printf("sizeof(ra) = %d. sizeof(*ra) = %d\n", sizeof(ra), sizeof(*ra)); if (sizeof(ra) != sizeof(int*)) E(31); if (sizeof(*ra) != n*sizeof(int)) E(32); return n; } -*/ int main() { foo(10,0); test(10,0); test2(10,0); + test3(10,0); SUCCESS; } diff --git a/test/small1/array_multi_varsize.c b/test/small1/array_multi_varsize.c index 3b973baa0..620cbf17c 100755 --- a/test/small1/array_multi_varsize.c +++ b/test/small1/array_multi_varsize.c @@ -1,6 +1,6 @@ #include "testharness.h" -// Variable-sized multidimensionnal arrays +// Variable-sized multidimensional arrays void foo(int n, int a[n][n]); int main(void) @@ -11,7 +11,7 @@ int main(void) } void foo(int n, int a[n][n]) { - + double b[n]; a[0][n-1] = 0; b[n-1] = 0.0; @@ -26,4 +26,3 @@ void foo(int n, int a[n][n]) { // as (n * sizeof(*b)) if (sizeof(b) != (n * sizeof(double))) E(3); } - diff --git a/test/small1/array_varsize.c b/test/small1/array_varsize.c index 9738ac68c..2f83ab9ef 100755 --- a/test/small1/array_varsize.c +++ b/test/small1/array_varsize.c @@ -2,30 +2,56 @@ // Variable-sized arrays void foo(int n, int a[n]); +void foo2(int n, int a[30][n]); +void foo3(int n, int a[n][30]); int main(void) { int a[40]; foo(40, a); SUCCESS; + + int n = 30; + int b[n][n]; + b[29][0] = 0; + foo2(30, b); + foo3(30, b); +} + +int somefunction() { + return 42; } //Two variable-sized arrays -//In CIL, a is changed to a pointer, and b uses alloca +//In CIL, a is changed to a pointer, and b is left alone void foo(int n, int a[n]) { - - double b[n]; - a[n-1] = 0; - b[n-1] = 0.0; - printf("sizeof(a) = %d, sizeof(b) = %d\n", sizeof(a), sizeof(b)); - - //formals should be promoted to pointers (int*, in this case) - int* p = a; - p++; - if (sizeof(a) != sizeof(p)) E(2); - - //locals should keep their array type. CIL rewrites sizeof(b) - // as (n * sizeof(*b)) - if (sizeof(b) != (n * sizeof(double))) E(3); + + double b[n]; + a[n-1] = 0; + b[n-1] = 0.0; + printf("sizeof(a) = %d, sizeof(b) = %d\n", sizeof(a), sizeof(b)); + + + int m = 78; + char boom[n][somefunction()]; + char boom2[somefunction()][n]; + char boom3[somefunction()][somefunction()]; + char boom4[somefunction()][17][somefunction()][m]; + + //formals should be promoted to pointers (int*, in this case) + int* p = a; + p++; + if (sizeof(a) != sizeof(p)) E(2); + + //locals should keep their array type. CIL rewrites sizeof(b) + // as (n * sizeof(*b)) + if (sizeof(b) != (n * sizeof(double))) E(3); } +void foo2(int n, int a[30][n]) { + if(a[29][0] != 0) E(4); +} + +void foo3(int n, int a[n][30]) { + if(a[29][0] != 0) E(4); +} diff --git a/test/small1/asm4.c b/test/small1/asm4.c index 193044b2c..6d4a65878 100644 --- a/test/small1/asm4.c +++ b/test/small1/asm4.c @@ -34,7 +34,7 @@ main (int argc, gu64t2 = (__extension__ ( 0xa77a0a30026b631dULL)) ; - + (void)( { if (!( sizeof (gint8) == 1 )) g_log (((gchar*) 0) , G_LOG_LEVEL_ERROR, "file %s: line %d (%s): assertion failed: (%s)", "type-test.c", 47, __PRETTY_FUNCTION__, "sizeof (gint8) == 1"); }) ; (void)( { if (!( sizeof (gint16) == 2 )) g_log (((gchar*) 0) , G_LOG_LEVEL_ERROR, "file %s: line %d (%s): assertion failed: (%s)", "type-test.c", 48, __PRETTY_FUNCTION__, "sizeof (gint16) == 2"); }) ; (void)( { if (!( sizeof (gint32) == 4 )) g_log (((gchar*) 0) , G_LOG_LEVEL_ERROR, "file %s: line %d (%s): assertion failed: (%s)", "type-test.c", 49, __PRETTY_FUNCTION__, "sizeof (gint32) == 4"); }) ; @@ -42,13 +42,11 @@ main (int argc, (void)( { if (!( sizeof (gint64) == 8 )) g_log (((gchar*) 0) , G_LOG_LEVEL_ERROR, "file %s: line %d (%s): assertion failed: (%s)", "type-test.c", 51, __PRETTY_FUNCTION__, "sizeof (gint64) == 8"); }) ; #if defined(i386) || defined(__x86_64__) - (void)( { if (!( ((__extension__ ({ register guint16 __v; if (__builtin_constant_p ( gu16t1 )) __v = ((guint16) ( (((guint16) ( gu16t1 ) & (guint16) 0x00ffU) << 8) | (((guint16) ( gu16t1 ) & (guint16) 0xff00U) >> 8))) ; else __asm__ __const__ ("rorw $8, %w0" : "=r" (__v) : "0" ((guint16) ( gu16t1 ))); __v; })) ) == gu16t2 )) g_log (((gchar*) 0) , G_LOG_LEVEL_ERROR, "file %s: line %d (%s): assertion failed: (%s)", "type-test.c", 54, __PRETTY_FUNCTION__, "GUINT16_SWAP_LE_BE (gu16t1) == gu16t2"); }) ; - (void)( { if (!( ((__extension__ ({ register guint32 __v; if (__builtin_constant_p ( gu32t1 )) __v = ((guint32) ( (((guint32) ( gu32t1 ) & (guint32) 0x000000ffU) << 24) | (((guint32) ( gu32t1 ) & (guint32) 0x0000ff00U) << 8) | (((guint32) ( gu32t1 ) & (guint32) 0x00ff0000U) >> 8) | (((guint32) ( gu32t1 ) & (guint32) 0xff000000U) >> 24))) ; else __asm__ __const__ ("rorw $8, %w0\n\t" "rorl $16, %0\n\t" "rorw $8, %w0" : "=r" (__v) : "0" ((guint32) ( gu32t1 ))); __v; })) ) == gu32t2 )) g_log (((gchar*) 0) , G_LOG_LEVEL_ERROR, "file %s: line %d (%s): assertion failed: (%s)", "type-test.c", 55, __PRETTY_FUNCTION__, "GUINT32_SWAP_LE_BE (gu32t1) == gu32t2"); }) ; + (void)( { if (!( ((__extension__ ({ register guint16 __v; if (__builtin_constant_p ( gu16t1 )) __v = ((guint16) ( (((guint16) ( gu16t1 ) & (guint16) 0x00ffU) << 8) | (((guint16) ( gu16t1 ) & (guint16) 0xff00U) >> 8))) ; else __asm__ ("rorw $8, %w0" : "=r" (__v) : "0" ((guint16) ( gu16t1 ))); __v; })) ) == gu16t2 )) g_log (((gchar*) 0) , G_LOG_LEVEL_ERROR, "file %s: line %d (%s): assertion failed: (%s)", "type-test.c", 54, __PRETTY_FUNCTION__, "GUINT16_SWAP_LE_BE (gu16t1) == gu16t2"); }) ; + (void)( { if (!( ((__extension__ ({ register guint32 __v; if (__builtin_constant_p ( gu32t1 )) __v = ((guint32) ( (((guint32) ( gu32t1 ) & (guint32) 0x000000ffU) << 24) | (((guint32) ( gu32t1 ) & (guint32) 0x0000ff00U) << 8) | (((guint32) ( gu32t1 ) & (guint32) 0x00ff0000U) >> 8) | (((guint32) ( gu32t1 ) & (guint32) 0xff000000U) >> 24))) ; else __asm__ ("rorw $8, %w0\n\t" "rorl $16, %0\n\t" "rorw $8, %w0" : "=r" (__v) : "0" ((guint32) ( gu32t1 ))); __v; })) ) == gu32t2 )) g_log (((gchar*) 0) , G_LOG_LEVEL_ERROR, "file %s: line %d (%s): assertion failed: (%s)", "type-test.c", 55, __PRETTY_FUNCTION__, "GUINT32_SWAP_LE_BE (gu32t1) == gu32t2"); }) ; - (void)( { if (!( ((__extension__ ({ union { guint64 __ll; guint32 __l[2]; } __r; if (__builtin_constant_p ( gu64t1 )) __r.__ll = ((guint64) ( (((guint64) ( gu64t1 ) & (guint64) (__extension__ ( 0x00000000000000ffULL)) ) << 56) | (((guint64) ( gu64t1 ) & (guint64) (__extension__ ( 0x000000000000ff00ULL)) ) << 40) | (((guint64) ( gu64t1 ) & (guint64) (__extension__ ( 0x0000000000ff0000ULL)) ) << 24) | (((guint64) ( gu64t1 ) & (guint64) (__extension__ ( 0x00000000ff000000ULL)) ) << 8) | (((guint64) ( gu64t1 ) & (guint64) (__extension__ ( 0x000000ff00000000ULL)) ) >> 8) | (((guint64) ( gu64t1 ) & (guint64) (__extension__ ( 0x0000ff0000000000ULL)) ) >> 24) | (((guint64) ( gu64t1 ) & (guint64) (__extension__ ( 0x00ff000000000000ULL)) ) >> 40) | (((guint64) ( gu64t1 ) & (guint64) (__extension__ ( 0xff00000000000000ULL)) ) >> 56))) ; else { union { guint64 __ll; guint32 __l[2]; } __w; __w.__ll = ((guint64) gu64t1 ); __r.__l[0] = ((__extension__ ({ register guint32 __v; if (__builtin_constant_p ( __w.__l[1] )) __v = ((guint32) ( (((guint32) ( __w.__l[1] ) & (guint32) 0x000000ffU) << 24) | (((guint32) ( __w.__l[1] ) & (guint32) 0x0000ff00U) << 8) | (((guint32) ( __w.__l[1] ) & (guint32) 0x00ff0000U) >> 8) | (((guint32) ( __w.__l[1] ) & (guint32) 0xff000000U) >> 24))) ; else __asm__ __const__ ("rorw $8, %w0\n\t" "rorl $16, %0\n\t" "rorw $8, %w0" : "=r" (__v) : "0" ((guint32) ( __w.__l[1] ))); __v; })) ) ; __r.__l[1] = ((__extension__ ({ register guint32 __v; if (__builtin_constant_p ( __w.__l[0] )) __v = ((guint32) ( (((guint32) ( __w.__l[0] ) & (guint32) 0x000000ffU) << 24) | (((guint32) ( __w.__l[0] ) & (guint32) 0x0000ff00U) << 8) | (((guint32) ( __w.__l[0] ) & (guint32) 0x00ff0000U) >> 8) | (((guint32) ( __w.__l[0] ) & (guint32) 0xff000000U) >> 24))) ; else __asm__ __const__ ("rorw $8, %w0\n\t" "rorl $16, %0\n\t" "rorw $8, %w0" : "=r" (__v) : "0" ((guint32) ( __w.__l[0] ))); __v; })) ) ; } __r.__ll; })) ) == gu64t2 )) g_log (((gchar*) 0) , G_LOG_LEVEL_ERROR, "file %s: line %d (%s): assertion failed: (%s)", "type-test.c", 57, __PRETTY_FUNCTION__, "GUINT64_SWAP_LE_BE (gu64t1) == gu64t2"); }) ; + (void)( { if (!( ((__extension__ ({ union { guint64 __ll; guint32 __l[2]; } __r; if (__builtin_constant_p ( gu64t1 )) __r.__ll = ((guint64) ( (((guint64) ( gu64t1 ) & (guint64) (__extension__ ( 0x00000000000000ffULL)) ) << 56) | (((guint64) ( gu64t1 ) & (guint64) (__extension__ ( 0x000000000000ff00ULL)) ) << 40) | (((guint64) ( gu64t1 ) & (guint64) (__extension__ ( 0x0000000000ff0000ULL)) ) << 24) | (((guint64) ( gu64t1 ) & (guint64) (__extension__ ( 0x00000000ff000000ULL)) ) << 8) | (((guint64) ( gu64t1 ) & (guint64) (__extension__ ( 0x000000ff00000000ULL)) ) >> 8) | (((guint64) ( gu64t1 ) & (guint64) (__extension__ ( 0x0000ff0000000000ULL)) ) >> 24) | (((guint64) ( gu64t1 ) & (guint64) (__extension__ ( 0x00ff000000000000ULL)) ) >> 40) | (((guint64) ( gu64t1 ) & (guint64) (__extension__ ( 0xff00000000000000ULL)) ) >> 56))) ; else { union { guint64 __ll; guint32 __l[2]; } __w; __w.__ll = ((guint64) gu64t1 ); __r.__l[0] = ((__extension__ ({ register guint32 __v; if (__builtin_constant_p ( __w.__l[1] )) __v = ((guint32) ( (((guint32) ( __w.__l[1] ) & (guint32) 0x000000ffU) << 24) | (((guint32) ( __w.__l[1] ) & (guint32) 0x0000ff00U) << 8) | (((guint32) ( __w.__l[1] ) & (guint32) 0x00ff0000U) >> 8) | (((guint32) ( __w.__l[1] ) & (guint32) 0xff000000U) >> 24))) ; else __asm__ ("rorw $8, %w0\n\t" "rorl $16, %0\n\t" "rorw $8, %w0" : "=r" (__v) : "0" ((guint32) ( __w.__l[1] ))); __v; })) ) ; __r.__l[1] = ((__extension__ ({ register guint32 __v; if (__builtin_constant_p ( __w.__l[0] )) __v = ((guint32) ( (((guint32) ( __w.__l[0] ) & (guint32) 0x000000ffU) << 24) | (((guint32) ( __w.__l[0] ) & (guint32) 0x0000ff00U) << 8) | (((guint32) ( __w.__l[0] ) & (guint32) 0x00ff0000U) >> 8) | (((guint32) ( __w.__l[0] ) & (guint32) 0xff000000U) >> 24))) ; else __asm__ ("rorw $8, %w0\n\t" "rorl $16, %0\n\t" "rorw $8, %w0" : "=r" (__v) : "0" ((guint32) ( __w.__l[0] ))); __v; })) ) ; } __r.__ll; })) ) == gu64t2 )) g_log (((gchar*) 0) , G_LOG_LEVEL_ERROR, "file %s: line %d (%s): assertion failed: (%s)", "type-test.c", 57, __PRETTY_FUNCTION__, "GUINT64_SWAP_LE_BE (gu64t1) == gu64t2"); }) ; #endif return 0; } - - diff --git a/test/small1/builtin3.c b/test/small1/builtin3.c index c2fc03e79..7a1f8aa9f 100755 --- a/test/small1/builtin3.c +++ b/test/small1/builtin3.c @@ -7,7 +7,7 @@ int main (void) int x = 0; int b = __builtin_constant_p (x++); - int arr[]; + int* arr; __builtin_constant_p (x++); diff --git a/test/small1/c99-bool.c b/test/small1/c99-bool.c new file mode 100644 index 000000000..2f2074321 --- /dev/null +++ b/test/small1/c99-bool.c @@ -0,0 +1,20 @@ +#include +#include +#include "testharness.h" +int main(void) +{ + bool b = 17; + _Bool b1 = 17; + + if(b == 1) { + + } else { + E(1); + } + + if(b1 == 1) { + + } else { + E(2); + } +} diff --git a/test/small1/c99-complex.c b/test/small1/c99-complex.c new file mode 100644 index 000000000..85ae7f4e4 --- /dev/null +++ b/test/small1/c99-complex.c @@ -0,0 +1,246 @@ +#include +#include +#include +#include "testharness.h" + +void forlong() { + long double complex z1 = 1.0il + 1; + printf("I * I = %.1Lf%+.1Lfi\n", creal(z1), cimag(z1)); + + long double complex z2 = pow(_Complex_I, 2); // imaginary unit squared + printf("pow(I, 2) = %.1Lf%+.1Lfi\n", creal(z2), cimag(z2)); + + double long PI = acos(-1); + double long complex z3 = exp(I * PI); // Euler's formula + printf("exp(I*PI) = %.1Lf%+.1Lfi\n", creal(z3), cimag(z3)); + + double long complex z4 = 1+2*I, z5 = 1-2*I; // conjugates + printf("(1+2i)*(1-2i) = %.Lf%+.Lfi\n", creal(z4*z5), cimag(z4*z5)); +} + +int main(void) +{ + double complex x0 = 1.0i + 17; + double complex x1 = 1.0iF + 0.5; + double complex x00 = 1.0Fi + 0.5; + + if(sizeof(double complex) != sizeof(1.0iF + 0.5)) { + E(1); + } + + double d = creal(x1); + double i = cimag(x1); + + double j = __imag__(1.0if); + + if(d != 0.5) + E(2); + + if(i != 1.0 || j != 1.0) + E(3); + + double complex z1 = 1.0iF + 1; + printf("I * I = %.1f%+.1fi\n", creal(z1), cimag(z1)); + + double complex z2 = pow(_Complex_I, 2); // imaginary unit squared + printf("pow(I, 2) = %.1f%+.1fi\n", creal(z2), cimag(z2)); + + double PI = acos(-1); + double complex z3 = exp(I * PI); // Euler's formula + printf("exp(I*PI) = %.1f%+.1fi\n", creal(z3), cimag(z3)); + + double complex z4 = 1+2*I, z5 = 1-2*I; // conjugates + printf("(1+2i)*(1-2i) = %.1f%+.1fi\n", creal(z4*z5), cimag(z4*z5)); + + forlong(); + return 0; +} + +void parsedebug() { + __real__ (1.0iF); + __real__ (2); + 0 + __real__(2); + __real__(2) + 0; + (sizeof (__real__ (1.0iF) + __real__ (2)) > sizeof (double) && __builtin_classify_type (__real__ (1.0iF) + __real__ (2)) == 8); + + + (__extension__ ((sizeof (__real__ (1.0iF) + __real__ (2)) > sizeof (double) && __builtin_classify_type (__real__ ( + + 1.0iF + + ) + __real__ ( + + 2 + + )) == 8) ? ((__builtin_classify_type (( + + 1.0iF + ) + ( + + 2 + + )) != 9) ? (__typeof ((__typeof__ (*(0 ? (__typeof__ (0 ? (__typeof__ ((__typeof__ (+( + + 1.0iF + + ))) 0) *) 0 : (void *) (!((__builtin_classify_type (__real__ ((__typeof__ (+( + 1.0iF + ))) 0)) == 8))))) 0 : (__typeof__ (0 ? (__typeof__ (0 ? (double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 1.0iF + ))) 0) == 1))))) 0 : (__typeof__ (0 ? (_Complex double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 1.0iF + ))) 0) == 9 && __builtin_classify_type (__real__ ((__typeof__ (+( + 1.0iF + ))) 0)) == 1))))) 0)) 0))) 0 + (__typeof__ (*(0 ? (__typeof__ (0 ? (__typeof__ ((__typeof__ (+( + 2 + ))) 0) *) 0 : (void *) (!((__builtin_classify_type (__real__ ((__typeof__ (+( + 2 + ))) 0)) == 8))))) 0 : (__typeof__ (0 ? (__typeof__ (0 ? (double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 2 + ))) 0) == 1))))) 0 : (__typeof__ (0 ? (_Complex double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 2 + ))) 0) == 9 && __builtin_classify_type (__real__ ((__typeof__ (+( + 2 + ))) 0)) == 1))))) 0)) 0))) 0)) powl ( + 1.0iF + , + 2 + ) : (__typeof ((__typeof__ (*(0 ? (__typeof__ (0 ? (__typeof__ ((__typeof__ (+( + 1.0iF + ))) 0) *) 0 : (void *) (!((__builtin_classify_type (__real__ ((__typeof__ (+( + 1.0iF + ))) 0)) == 8))))) 0 : (__typeof__ (0 ? (__typeof__ (0 ? (double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 1.0iF + ))) 0) == 1))))) 0 : (__typeof__ (0 ? (_Complex double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 1.0iF + ))) 0) == 9 && __builtin_classify_type (__real__ ((__typeof__ (+( + 1.0iF + ))) 0)) == 1))))) 0)) 0))) 0 + (__typeof__ (*(0 ? (__typeof__ (0 ? (__typeof__ ((__typeof__ (+( + 2 + ))) 0) *) 0 : (void *) (!((__builtin_classify_type (__real__ ((__typeof__ (+( + 2 + ))) 0)) == 8))))) 0 : (__typeof__ (0 ? (__typeof__ (0 ? (double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 2 + ))) 0) == 1))))) 0 : (__typeof__ (0 ? (_Complex double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 2 + ))) 0) == 9 && __builtin_classify_type (__real__ ((__typeof__ (+( + 2 + ))) 0)) == 1))))) 0)) 0))) 0)) cpowl ( + 1.0iF + , + 2 + )) : (sizeof (+__real__ ( + 1.0iF + )) == sizeof (double) || sizeof (+__real__ ( + 2 + )) == sizeof (double) || __builtin_classify_type (__real__ ( + 1.0iF + )) != 8 || __builtin_classify_type (__real__ ( + 2 + )) != 8) ? ((__builtin_classify_type (( + 1.0iF + ) + ( + 2 + )) != 9) ? (__typeof ((__typeof__ (*(0 ? (__typeof__ (0 ? (__typeof__ ((__typeof__ (+( + 1.0iF + ))) 0) *) 0 : (void *) (!((__builtin_classify_type (__real__ ((__typeof__ (+( + 1.0iF + ))) 0)) == 8))))) 0 : (__typeof__ (0 ? (__typeof__ (0 ? (double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 1.0iF + ))) 0) == 1))))) 0 : (__typeof__ (0 ? (_Complex double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 1.0iF + ))) 0) == 9 && __builtin_classify_type (__real__ ((__typeof__ (+( + 1.0iF + ))) 0)) == 1))))) 0)) 0))) 0 + (__typeof__ (*(0 ? (__typeof__ (0 ? (__typeof__ ((__typeof__ (+( + 2 + ))) 0) *) 0 : (void *) (!((__builtin_classify_type (__real__ ((__typeof__ (+( + 2 + ))) 0)) == 8))))) 0 : (__typeof__ (0 ? (__typeof__ (0 ? (double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 2 + ))) 0) == 1))))) 0 : (__typeof__ (0 ? (_Complex double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 2 + ))) 0) == 9 && __builtin_classify_type (__real__ ((__typeof__ (+( + 2 + ))) 0)) == 1))))) 0)) 0))) 0)) pow ( + 1.0iF + , + 2 + ) : (__typeof ((__typeof__ (*(0 ? (__typeof__ (0 ? (__typeof__ ((__typeof__ (+( + 1.0iF + ))) 0) *) 0 : (void *) (!((__builtin_classify_type (__real__ ((__typeof__ (+( + 1.0iF + ))) 0)) == 8))))) 0 : (__typeof__ (0 ? (__typeof__ (0 ? (double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 1.0iF + ))) 0) == 1))))) 0 : (__typeof__ (0 ? (_Complex double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 1.0iF + ))) 0) == 9 && __builtin_classify_type (__real__ ((__typeof__ (+( + 1.0iF + ))) 0)) == 1))))) 0)) 0))) 0 + (__typeof__ (*(0 ? (__typeof__ (0 ? (__typeof__ ((__typeof__ (+( + 2 + ))) 0) *) 0 : (void *) (!((__builtin_classify_type (__real__ ((__typeof__ (+( + 2 + ))) 0)) == 8))))) 0 : (__typeof__ (0 ? (__typeof__ (0 ? (double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 2 + ))) 0) == 1))))) 0 : (__typeof__ (0 ? (_Complex double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 2 + ))) 0) == 9 && __builtin_classify_type (__real__ ((__typeof__ (+( + 2 + ))) 0)) == 1))))) 0)) 0))) 0)) cpow ( + 1.0iF + , + 2 + )) : ((__builtin_classify_type (( + 1.0iF + ) + ( + 2 + )) != 9) ? (__typeof ((__typeof__ (*(0 ? (__typeof__ (0 ? (__typeof__ ((__typeof__ (+( + 1.0iF + ))) 0) *) 0 : (void *) (!((__builtin_classify_type (__real__ ((__typeof__ (+( + 1.0iF + ))) 0)) == 8))))) 0 : (__typeof__ (0 ? (__typeof__ (0 ? (double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 1.0iF + ))) 0) == 1))))) 0 : (__typeof__ (0 ? (_Complex double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 1.0iF + ))) 0) == 9 && __builtin_classify_type (__real__ ((__typeof__ (+( + 1.0iF + ))) 0)) == 1))))) 0)) 0))) 0 + (__typeof__ (*(0 ? (__typeof__ (0 ? (__typeof__ ((__typeof__ (+( + 2 + ))) 0) *) 0 : (void *) (!((__builtin_classify_type (__real__ ((__typeof__ (+( + 2 + ))) 0)) == 8))))) 0 : (__typeof__ (0 ? (__typeof__ (0 ? (double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 2 + ))) 0) == 1))))) 0 : (__typeof__ (0 ? (_Complex double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 2 + ))) 0) == 9 && __builtin_classify_type (__real__ ((__typeof__ (+( + 2 + ))) 0)) == 1))))) 0)) 0))) 0)) powf ( + 1.0iF + , + 2 + ) : (__typeof ((__typeof__ (*(0 ? (__typeof__ (0 ? (__typeof__ ((__typeof__ (+( + 1.0iF + ))) 0) *) 0 : (void *) (!((__builtin_classify_type (__real__ ((__typeof__ (+( + 1.0iF + ))) 0)) == 8))))) 0 : (__typeof__ (0 ? (__typeof__ (0 ? (double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 1.0iF + ))) 0) == 1))))) 0 : (__typeof__ (0 ? (_Complex double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 1.0iF + ))) 0) == 9 && __builtin_classify_type (__real__ ((__typeof__ (+( + 1.0iF + ))) 0)) == 1))))) 0)) 0))) 0 + (__typeof__ (*(0 ? (__typeof__ (0 ? (__typeof__ ((__typeof__ (+( + 2 + ))) 0) *) 0 : (void *) (!((__builtin_classify_type (__real__ ((__typeof__ (+( + 2 + ))) 0)) == 8))))) 0 : (__typeof__ (0 ? (__typeof__ (0 ? (double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 2 + ))) 0) == 1))))) 0 : (__typeof__ (0 ? (_Complex double *) 0 : (void *) (!((__builtin_classify_type ((__typeof__ (+( + 2 + ))) 0) == 9 && __builtin_classify_type (__real__ ((__typeof__ (+( + 2 + ))) 0)) == 1))))) 0)) 0))) 0)) cpowf ( + 1.0iF + , + 2 + )))) + ; +} diff --git a/test/small1/c99-float-pragma.c b/test/small1/c99-float-pragma.c new file mode 100644 index 000000000..d98789c65 --- /dev/null +++ b/test/small1/c99-float-pragma.c @@ -0,0 +1,85 @@ +// Adapted from https://github.com/sosy-lab/sv-benchmarks/blob/master/c/floats-cbmc-regression/float-rounding1.c +// For license see below +#include +void reach_error() { assert(0); } +#ifdef __GNUC__ +#include +#include + +// Should work without this as it defaults to off. +// It is explicitly ignored by GCC +#pragma STDC FENV_ACCESS OFF + +void roundingTest (float f1, float f2) { + // (Re)Set to the default rounding mode. + fesetround(FE_TONEAREST); + + // With round to nearest, should get 0x1.000002p+0f + float roundToNearestSum = f1 + f2; + if(!(roundToNearestSum == 0x1.000002p+0f)) {reach_error();} + + // Change the rounding mode + fesetround(FE_DOWNWARD); + + // Should now round down to 0x1p+0; + float roundDownSum = f1 + f2; + if(!(roundDownSum == 0x1.0p+0f)) {reach_error();} + + return; +} +#endif + +int main (void) +{ + #ifdef __GNUC__ + float f1 = 0x1.0p+0; + float f2 = 0x1.8p-24; + + // Test with constant folding + roundingTest(f1,f2); + + #endif + + return 0; +} + +/* +(C) 2001-2016, Daniel Kroening, Edmund Clarke, +Computer Science Department, University of Oxford +Computer Science Department, Carnegie Mellon University + +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. All advertising materials mentioning features or use of this software + must display the following acknowledgement: + + This product includes software developed by Daniel Kroening, + Edmund Clarke, + Computer Science Department, University of Oxford + Computer Science Department, Carnegie Mellon University + + 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 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 HOLDER 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. */ diff --git a/test/small1/c99-predefined.c b/test/small1/c99-predefined.c new file mode 100644 index 000000000..13d2d6f15 --- /dev/null +++ b/test/small1/c99-predefined.c @@ -0,0 +1,11 @@ +#include +int main(void) +{ + printf("%s\n", __FILE__); + printf("%d\n", __LINE__); + printf("%s\n", __func__); + printf("%s\n", __DATE__); + printf("%s\n", __TIME__); + printf("%ld\n", __STDC_VERSION__); + return 0; +} diff --git a/test/small1/c99-struct.c b/test/small1/c99-struct.c new file mode 100644 index 000000000..f016adf8d --- /dev/null +++ b/test/small1/c99-struct.c @@ -0,0 +1,57 @@ +#include +int *p = (int[]){2, 4}; + +struct point { + int x, y; +}; + +struct fops { + int open, read, write, close; +}; + +struct fam { + int i; + int arr[]; +}; + +void foo( struct point p1, struct point p2) +{ + int a[6] = { [4] = 29, [2] = 15 }; + struct { int x,y; } ar[ 4] = { [1].x=23, [3].y=34, [1].y=-1, [1].x=12}; + struct fops f2 = { .open=0, .close=1, .read=2}; + + struct fam *s = malloc(sizeof(struct fam) + 17ul*sizeof(int)); + s->arr[5] = 12; +} + +void copy2( char* restrict s1, char* restrict s2, int n) +{ + while (n--) + *s1++ = *s2++; +} + +// Compound literals: Example from: https://en.cppreference.com/w/c/language/compound_literal +int f(void) +{ + struct s {int i;} *p = 0, *q; + int j = 0; +again: + q = p, p = &((struct s){ j++ }); + if (j < 2) goto again; // note; if a loop were used, it would end scope here, + // which would terminate the lifetime of the compound literal + // leaving p as a dangling pointer + return p == q && q->i == 1; // always returns 1 +} + +int main() { + struct point p1 = { 2, 4}; // this is standard + p1 = (struct point){ 1, 3}; // this is new + + // passing to the function + foo( (struct point){ 10, 11}, (struct point){ 1, 2}); + + // constructing an array + char **sx = (char *[]){ "Adam", "Eva", "Simon"}; + + return 0; +} diff --git a/test/small1/c99-tgmath.c b/test/small1/c99-tgmath.c new file mode 100644 index 000000000..ee0ef4b26 --- /dev/null +++ b/test/small1/c99-tgmath.c @@ -0,0 +1,41 @@ +#include +#include +#include +#include "testharness.h" + +int main(void) +{ + float f1 = 1.0f; + f1 = fabs(f1); + float f = fabs(1.0f); + double d = fabs(1.0); + long double l = fabs(1.0l); + + float _Complex fc = 3.25f + 0.1if; + // should directly have type float and not float _Complex + float f2 = fabs(fc); + + double _Complex fcd = 3.25 + 0.1i; + double f2d = fabs(fcd); + + // Those two calls should both have the same return type + double _Complex idk = pow(fc, fcd); + double _Complex idk2 = pow(fcd, fc); + + // Those should directly have type int not going through any casting + int i = ilogb(d); + int j = ilogb(f); + + long double idk3 = scalbn(l, 1); + + if(f != 1.0f) + E(1); + + if(d != 1.0) + E(2); + + if(l != 1.0l) + E(3); + + return 0; +} diff --git a/test/small1/c99-universal-character-names.c b/test/small1/c99-universal-character-names.c new file mode 100644 index 000000000..d9a502644 --- /dev/null +++ b/test/small1/c99-universal-character-names.c @@ -0,0 +1,3 @@ +int main() { + int \u03B1 = 5; +} diff --git a/test/small1/combine-c99inline_1.c b/test/small1/combine-c99inline_1.c new file mode 100644 index 000000000..644905b30 --- /dev/null +++ b/test/small1/combine-c99inline_1.c @@ -0,0 +1,4 @@ +#include "stdio.h" +void add(int x, int y) { + printf("Called non-inline\n"); +} diff --git a/test/small1/combine-c99inline_2.c b/test/small1/combine-c99inline_2.c new file mode 100644 index 000000000..521031bd3 --- /dev/null +++ b/test/small1/combine-c99inline_2.c @@ -0,0 +1,7 @@ +#include "stdio.h" +inline void add(int i, int j) { printf("Called inline\n"); } + +int main() { + add(4, 5); + return 0; +} diff --git a/test/small1/combine21_1.c b/test/small1/combine21_1.c index f1df3e401..f498c23e2 100755 --- a/test/small1/combine21_1.c +++ b/test/small1/combine21_1.c @@ -1,5 +1,9 @@ static int gflag; +// This is not considered correct code in GNU11, but is ok in GNU90. +// -std=gnu90 used to be the default, but since GCC 5.1.0 it is -std=gnu11 +// To account for this, -std=gnu90 was added to the regressions tests +// To make it GNU11, add extern __inline void testit ( int flag ) { gflag = flag; diff --git a/test/small1/land_expr.c b/test/small1/land_expr.c new file mode 100644 index 000000000..c7ef0bc5c --- /dev/null +++ b/test/small1/land_expr.c @@ -0,0 +1,7 @@ +int main (int argc, char* argv[]) +{ + signed char a = 7; + signed char b = 1; + b = (1 && a) ; + return 0; +} diff --git a/test/small1/large_unsigned_long.c b/test/small1/large_unsigned_long.c new file mode 100644 index 000000000..a589c66a1 --- /dev/null +++ b/test/small1/large_unsigned_long.c @@ -0,0 +1,12 @@ +#include +#include +int main(){ + // Previously, CIL assigned "-3" here. + // This previously erroneous behavior cannot be really tested for, so it has to be manually inspected. + unsigned long long x = 18446744073709551613ul; + x = 18446744073709551613ul; + if (x <= 18446744073709551612ull){ + assert(0); + } + return 0; +} diff --git a/test/small1/macro_hidden.c b/test/small1/macro_hidden.c new file mode 100644 index 000000000..2e537764c --- /dev/null +++ b/test/small1/macro_hidden.c @@ -0,0 +1,9 @@ +#define hidden __attribute__((__visibility__("hidden"))) +hidden int x; +int main() +{ + x = 17; + + return 0; + +} diff --git a/test/small1/simplify_structs1.c b/test/small1/simplify_structs1.c deleted file mode 100755 index 3225b873d..000000000 --- a/test/small1/simplify_structs1.c +++ /dev/null @@ -1,41 +0,0 @@ - -struct two { - int i_1; - int i_2; -}; - -struct nosplit { - // Don't split this struct. - // (Or if you do, handle the array assignment correctly.) - int i_5; - int i_6[10]; -}; - -struct three { - int i_0; - struct two i_1and2; - struct nosplit i_56; -}; - -struct three global = { 0, {10, 20}}; -//Try an external declaration: -extern struct three bar(struct three arg); -extern void barvoid(struct three arg); - -extern struct three externstruct; //not split - -int main() { - struct three local1 = externstruct; - struct three local2 = externstruct; - struct three local3 = local2; - - barvoid(local1); //local1 is split - local3 = bar(local2); //local2 is not split, but the args to bar are - - barvoid(global); //global is not split, but the args to barvoid are - - externstruct = bar(externstruct); - - - return 0; -} diff --git a/test/small1/simplify_structs2.c b/test/small1/simplify_structs2.c deleted file mode 100755 index fa56f7b3e..000000000 --- a/test/small1/simplify_structs2.c +++ /dev/null @@ -1,52 +0,0 @@ -#include "testharness.h" - -struct list { - struct list* back; - int i; - struct list* next; -}; - -#define NULL 0 -struct list node1 = {NULL, 29, NULL}; -struct list node2 = {&node1, 30, &node1}; - -void foo() { - struct list local = node2; - if (local.next == 0 || local.i != 30) E(1); - - //Test that this is an "atomic" operation. - //If we naively split this into two assignments, - // local.next will change and *(local.next) will get the wrong value for - // the second half of the assigment. - local = *(local.next); - if (local.next != 0 || local.i != 29) E(2); - - //Likewise, check that writing local.back (the first field of the struct) - //doesn't cause problems. - local = node2; - local = *(local.back); - if (local.next != 0 || local.i != 29) E(3); - -} - - -//make sure split args are passed in the right order -struct list node3 = {NULL, 40, &node2}; -void equalToNode3(struct list arg){ - if ((arg.back != node3.back) - ||(arg.i != node3.i) - ||(arg.next != node3.next)) { - E(10); - } -} - -int main() { - struct list local_node3 = node3; - - foo(); - - equalToNode3(local_node3); //pass from a split var - equalToNode3(node3); //pass from a nonsplit var - - SUCCESS; -} diff --git a/test/small1/simplify_volatile.c b/test/small1/simplify_volatile.c deleted file mode 100644 index ad0c6cb54..000000000 --- a/test/small1/simplify_volatile.c +++ /dev/null @@ -1,8 +0,0 @@ -struct M { - int foo[1]; -} volatile m; - -int main() -{ - return &m.foo; -} diff --git a/test/small1/var_named_hidden.c b/test/small1/var_named_hidden.c new file mode 100644 index 000000000..5071d61ed --- /dev/null +++ b/test/small1/var_named_hidden.c @@ -0,0 +1,9 @@ +__attribute__((visibility("hidden"))) int x; +int main() +{ + int hidden; + hidden = 0; + + return 0; + +} diff --git a/test/testcil b/test/testcil index a92132a9a..3a73ac21c 100755 --- a/test/testcil +++ b/test/testcil @@ -1,3 +1,3 @@ #!/bin/sh -eval 'exec perl -S ./testcil.pl ${1+"$@"}' +eval 'exec perl -I . -S ./testcil.pl ${1+"$@"}' if 0; diff --git a/test/testcil.pl b/test/testcil.pl index 353e20028..cdab1dc6e 100644 --- a/test/testcil.pl +++ b/test/testcil.pl @@ -61,10 +61,10 @@ # 1001 - Parsing # 1002 - cabs2cil # 1003 - Compilation -# 1004 - Running +# 1004 - Running -my %commonerrors = +my %commonerrors = ("^Parsing " => sub { $_[1]->{instage} = 1001; }, "^Converting CABS" => sub { $_[1]->{instage} = 1002; }, @@ -73,27 +73,27 @@ # We are seeing an error from make. Try to classify it based on the stage # in which we are - "^make: \\*\\*\\*" => - sub { + "^make: \\*\\*\\*" => + sub { if($_[1]->{ErrorCode} == 0) { $_[1]->{ErrorCode} = $_[1]->{instage}; }}, - + #"[sS]yntax error" => sub { $_[1]->{ErrorCode} = 1000; }, - + # Collect some more parameters # Now error messages - "^((Error|Bug|Unimplemented): .+)\$" + "^((Error|Bug|Unimplemented): .+)\$" => sub { if(! defined $_[1]->{ErrorMsg}) { $_[1]->{ErrorMsg} = $_[2];} }, "^(.+ : error .+)\$" => sub { if(! defined $_[1]->{ErrorMsg}) { $_[1]->{ErrorMsg} = $_[2];} }, - "^(.+:\\d+: (Error|Unimplemented|Bug):.+)\$" + "^(.+:\\d+: (Error|Unimplemented|Bug):.+)\$" => sub { if(! defined $_[1]->{ErrorMsg}) { $_[1]->{ErrorMsg} = $_[2];} }, "^(.+: fatal error.+)\$" => sub { if(! defined $_[1]->{ErrorMsg}) { $_[1]->{ErrorMsg} = $_[2];} }, - "^stackdump: Dumping stack trace" => + "^stackdump: Dumping stack trace" => sub { if(! defined $_[1]->{ErrorMsg}) { $_[1]->{ErrorMsg} = $_[2];} }, @@ -104,7 +104,7 @@ "^TOTAL\\s+([\\d.]+) s" => sub { $_[1]->{CURE} = $_[2]; }, ); - + # Add a test. # command is the base name of the tests + space separated arguments # extrargs are passed on the command line for each test @@ -113,7 +113,7 @@ sub addTest { my($command, %extrafields) = @_; my $self = $main::globalTEST; - my ($name, $extraargs) = + my ($name, $extraargs) = ($command =~ /^(\S+) ?(.*)$/); # name is first word my $theargs = $self->testCommandExtras($extraargs); @@ -121,10 +121,17 @@ sub addTest { my %patterns = %commonerrors; my $kind; + my $ccvar; + if ($ENV{'CC'} ne "gcc") { + $ccvar = "CC=gcc-9"; + } else { + $ccvar = ""; + } + my $tst = $self->newTest(Name => $name, Dir => ".", - Cmd => "$make " . $name . $theargs, + Cmd => "$ccvar $make " . $name . $theargs, Group => [ ], Patterns => \%patterns); # Add the extra fields @@ -158,27 +165,6 @@ sub addToGroup { $self->addGroups($name, @groups); } - -# Start with a few tests that must be run first -$TEST->newTest( - Name => "!inittests0", - Dir => "..", - Cmd => "$make all", - Group => ['ALWAYS']); -$TEST->newTest( - Name => "!inittests2", - Dir => "..", - Cmd => "$make all _GNUCC=1", - Group => ['ALWAYS']); - - -# build the documentation, to make sure that it still builds -$TEST->newTest( - Name => "doc", - Dir => "..", - Cmd => "$make doc", - Group => ["doc"]); - # Now add tests addTest("testrun/const-array-init WARNINGS_ARE_ERRORS=1"); addTest("testrun/const-struct-init WARNINGS_ARE_ERRORS=1"); @@ -210,7 +196,7 @@ sub addToGroup { addTest("testrun/question2"); addTest("testrun/question3 USE_LOGICAL_OPERATORS=1"); addTest("test/argcast"); -addBadComment("test/argcast", +addBadComment("test/argcast", "Notbug. CIL bases type for implicit functions based on first call's argument."); addTest("test/array1"); addTest("test/array2"); @@ -244,7 +230,7 @@ sub addToGroup { addTest("test/packed2 _GNUCC=1"); addTest("test/bitfield"); addTest("testrun/bitfield3"); - + addTest("testrun/bitfield2"); addTest("testrun/call2 "); addTest("test/cast1"); @@ -275,14 +261,14 @@ sub addToGroup { addTest("testrun/enum2"); addTest("test/func"); addTest("test/funcarg "); -addBadComment("test/funcarg", +addBadComment("test/funcarg", "Bug. In parser (argument of function type)"); addTest("testrun/func2"); addTest("testrun/func3"); addTest("testrun/func4"); addTest("test/func10 "); -addBadComment("test/func10", +addBadComment("test/func10", "Bug. Cannot parse some strange K&R function definition"); addTest("test/globals"); addTest("test/globals2 "); @@ -325,7 +311,7 @@ sub addToGroup { addTest("testrun/inline2 _GNUCC=1"); addTest("test/inline3 _GNUCC=1"); addTest("test/decl2 _GNUCC=1"); -addBadComment("test/decl2", +addBadComment("test/decl2", "Bug. An old-style argument type should go through the default type conversion before being added to the function's type."); addTest("test/jmp_buf"); addTest("test/linux_atomic _GNUCC=1"); @@ -340,7 +326,7 @@ sub addToGroup { addTest("testrun/perror1"); addTest("test/pure"); addTest("testrun/post-assign "); -addBadComment("testrun/post-assign", +addBadComment("testrun/post-assign", "Minor. CIL does not have the same evaluation order for ++ as gcc"); addTest("test/printf "); addTest("test/printf_const "); @@ -389,9 +375,11 @@ sub addToGroup { addTest("test/scope12 "); addTest("test/voidstar"); addTest("testrun/memcpy1"); +addTest("testrun/land_expr"); + addTest("test/noreturn "); - + addTest("test/constrexpr "); addTest("testrun/flexible-array-member "); @@ -417,8 +405,8 @@ sub addToGroup { addTest("testrun/wchar3"); addTest("testrun/wchar4"); addTest("testrun/wchar5 "); -addTest("testrun/wchar6"); -addTest("testrun/wchar7"); +addTest("testrun/wchar6"); +addTest("testrun/wchar7"); addTest("testrun/escapes"); addTest("test-bad1/wchar-bad "); addTest("testrun/addrof3 _GNUCC=1"); @@ -470,7 +458,7 @@ sub addToGroup { addTest("arcombine _GNUCC=1"); addTest("testrun/funptr1"); addTest("testrun/typespec1 _GNUCC=1"); -addBadComment("testrun/typespec1", +addBadComment("testrun/typespec1", "Notbug. GCC 4 no longer allows this, so the error is fine."); addTest("testrun/returnvoid "); addTest("testrun/returnvoid1 "); @@ -479,17 +467,17 @@ sub addToGroup { addTest("testrun/void _GNUCC=1"); addTest("test/voidtypedef "); addTest("testrun/wrongnumargs "); -addBadComment("testrun/wrongnumargs", +addBadComment("testrun/wrongnumargs", "Notbug. Should fail since we don't pad argument lists"); addTest("test/restrict EXTRAARGS=-std=c9x _GNUCC=1"); addTest("test/restrict1 _GNUCC=1"); addTest("testrun/rmtmps1 "); addTest("testrun/rmtmps2 _GNUCC=1"); addTest("test/proto1 "); -addBadComment("test/proto1", +addBadComment("test/proto1", "Bug. CIL doesn't like pointers to old-style functions..."); addTest("test/proto2 "); -addBadComment("test/proto2", +addBadComment("test/proto2", "Bug. In parser (precedences)"); addTest("testrun/struct1 "); addTest("testrun/voidarg "); @@ -502,13 +490,13 @@ sub addToGroup { addTest("runall/extinline "); addTest("testrun/rmtmps-attr "); -addBadComment("testrun/rmtmps-attr", +addBadComment("testrun/rmtmps-attr", "Bug. A limitation of our support for attributes"); - + addTest("testrun/vsp"); addTest("test/cpp-2 "); -addBadComment("test/cpp-2", +addBadComment("test/cpp-2", "Bug. In parser (empty pragmas)"); addTest("test/cpp-3 _GNUCC=1"); @@ -516,7 +504,7 @@ sub addToGroup { addTest("testrungcc/enum3a _GNUCC=1"); addTest("testrungcc/enum3b _GNUCC=1"); addTest("testrungcc/enum3c _GNUCC=1"); -addBadComment("testrungcc/enum3c", +addBadComment("testrungcc/enum3c", "Limitation. CIL constant folder doesn't consider x << y constant if y is strange (negative or bigger than #bits in x's type)"); addTest("testrungcc/enum3d _GNUCC=1"); addTest("testrungcc/enum3e _GNUCC=1"); @@ -530,7 +518,7 @@ sub addToGroup { if($win32) { - addTest("testrun/extern_init _MSVC=1"); + addTest("testrun/extern_init _MSVC=1"); addTest("testrun/msvc2 _MSVC=1"); addTest("testrun/msvc3 _MSVC=1"); addTest("testrun/msvc4 _MSVC=1"); @@ -549,20 +537,12 @@ sub addToGroup { addTest("test/duplicate "); addTest("testrun/simon6"); - + addTest("testrun/stringsize"); addTest("testrun/min "); -addTest("test/simplify_structs1 USECILLY=1 EXTRAARGS=--dosimplify"); -addTest("testrun/simplify_structs2 USECILLY=1 EXTRAARGS=--dosimplify"); - -addTest("test/tempname EXTRAARGS=--dosimplify"); - -addTest("test/simplify_volatile EXTRAARGS=--dosimplify"); -addBadComment("test/simplify_volatile", "Bug. Simplification of volatile structures with array members fails."); - addTest("testrun/typeof1 "); addTest("testrun/semicolon _GNUCC=1"); @@ -587,7 +567,7 @@ sub addToGroup { addTest("test/sync-3 _GNUCC=1"); addTest("testrun/comparisons"); addTest("testrun/assign"); - + @@ -712,56 +692,72 @@ sub addToGroup { addTest("testrun/extinline2"); addTest("test/extinline3"); addTest("testrun/bool"); +addTest("testrun/var_named_hidden"); +addTest("testrun/macro_hidden"); addTest("testrun/booleanOp USE_LOGICAL_OPERATORS=1"); addTest("test/va_arg_pack"); addTest("testrun/compound1"); addBadComment("testrun/compound1", "Notbug. Undefined behavior (probably)."); addTest("testrun/compound2"); +addTest("testrun/large_unsigned_long"); addTest("test/shell-escape SHELL_ESCAPE=1"); +# c99 readiness tests +addTest("testrunc99/c99-bool"); +addTest("testrunc99/c99-predefined"); +addTest("testrunc99/c99-struct"); +addTest("testrunc99/c99-complex"); +addTest("testrunc99/c99-universal-character-names"); +addBadComment("testrunc99/c99-universal-character-names", "Universal character names are not yet supported"); +addTest("testrunc99/c99-tgmath"); +addTest("testrunc99/c99-float-pragma"); +addTest("combinec99inline"); +addBadComment("combinec99inline", "C99 inline semantic not fully supported."); + + # ---------------- c-torture ------------- ## if we have the c-torture tests add them ## But only if the ctorture group was specfied my $ctorture = '/usr/local/src/gcc/gcc/testsuite/gcc.c-torture'; -if(-d $ctorture && +if(-d $ctorture && defined $TEST->{option}->{group} && grep { $_ eq 'ctorture'} @{$TEST->{option}->{group}}) { - + # Omit some tests because they use __complex__ my @omit = ('compile/20000804-1', 'compile/20001222-1', 'compile/941019-1', 'compile/981223-1', 'compile/991213-1', 'compile/20010605-2', - 'compile/960512-1', 'compile/complex-1', - 'compile/complex-2', 'compile/complex-4', + 'compile/960512-1', 'compile/complex-1', + 'compile/complex-2', 'compile/complex-4', 'compile/complex-5', 'execute/complex-2', 'execute/complex-5', - 'execute/960512-1', 'execute/complex-4', + 'execute/960512-1', 'execute/complex-4', 'execute/complex-1', 'execute/20010605-2'); # Also omit those with inner functions - push @omit, + push @omit, ('compile/951116-1', 'compile/920415-1', - 'execute/920415-1', 'compile/20010605-1', + 'execute/920415-1', 'compile/20010605-1', 'execute/20010605-1', 'compile/20011023-1', 'compile/20010903-2', 'execute/comp-goto-2', 'execute/nestfunc-2', 'execute/921215-1', 'execute/920428-2', 'execute/921017-1', - 'execute/nest-stdar-1', 'execute/nestfunc-3', 'execute/920501-7', - 'execute/920721-4', 'execute/920612-2', 'execute/20010209', + 'execute/nest-stdar-1', 'execute/nestfunc-3', 'execute/920501-7', + 'execute/920721-4', 'execute/920612-2', 'execute/20010209', 'execute/931002-1', 'execute/nestfunc-1', 'execute/20000822-1', 'compile/930506-2', 'execute/20010209-1'); - # Read the compile tests + # Read the compile tests my @tortures; - foreach my $tortdir ('compile', 'execute', 'compat') { - @tortures = - map { $_ =~ m|$ctorture/$tortdir/(.+)\.c|; $1 } + foreach my $tortdir ('compile', 'execute', 'compat') { + @tortures = + map { $_ =~ m|$ctorture/$tortdir/(.+)\.c|; $1 } (glob "$ctorture/$tortdir/*.c"); # Remove those that were produced in previous runs @tortures = grep { $_ !~ m|cil$| } @tortures; # Remove those that we know should fail - @tortures = grep { my $t = "$tortdir/$_"; + @tortures = grep { my $t = "$tortdir/$_"; ! grep { $_ =~ m|$t|} @omit } @tortures; foreach my $tst (@tortures) { - addTest("tort/$tortdir/$tst _GNUCC=1"); + addTest("tort/$tortdir/$tst _GNUCC=1"); $TEST->addGroups("tort/$tortdir/$tst", 'ctorture'); } } @@ -815,14 +811,14 @@ sub extraOptions { return ( @supopt, "--cildebug!", - "--noremake!", + "--noremake!", ); } sub extraHelpMessage { my($self) = @_; - + my ($scriptname, $extra) = $self->SUPER::extraHelpMessage(); return ("testcil", $extra . << "EOF"); @@ -830,7 +826,7 @@ sub extraHelpMessage { Additional arguments for SafeC test harness --cildebug Use the debug versions of everything (default is false) --noremake Does not try to remake the executable before each test. - (so that you can modify the sources while the test + (so that you can modify the sources while the test is running) Default log file is safec.log EOF