--- /dev/null
+Makefile
+autom4te.cache
+config.log
+config.status
--- /dev/null
+.svn
+.cvsignore
+.distexclude
+web
+debian
+config.status
+test/Makefile
+cil/doc
+cil/test
+cil/config.status
+cil/Makefile
+cil/cil.spec
+cil/config.mk
+cil/bin/cilly.bat
+cil/bin/patcher.bat
+cil/bin/CilConfig.pm
+cil/ocamlutil/perfcount.c
+cil/config.h
+doc/comment.sty
+doc/deputycode.pl
+doc/deputy.tex
+doc/fullpage.sty
+doc/header.html
+doc/header.html.in
+doc/hevea.sty
+doc/html
+doc/index.html
+doc/index.html.in
+doc/TODO
--- /dev/null
+Copyright (c) 2006,
+ Jeremy Condit <jcondit@cs.berkeley.edu>
+ Matthew Harren <matth@cs.berkeley.edu>
+ Zachary Anderson <zra@cs.berkeley.edu>
+ George C. Necula <necula@cs.berkeley.edu>
+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.
+
+
+(See http://www.opensource.org/licenses/bsd-license.php)
--- /dev/null
+# Makefile for Deputy, based on the CIL Makefiles.
+# Jeremy Condit <jcondit@cs.berkeley.edu>
+#
+#
+# Please edit Makefile.in, not Makefile!
+
+ifndef ARCHOS
+ ARCHOS = @ARCHOS@
+endif
+
+# It is important to build without NATIVECAML first,to generate the
+# proper dependencies
+all: patch
+ $(MAKE) -C cil cillib NATIVECAML=
+ifndef BYTECODE
+ $(MAKE) -C cil cillib NATIVECAML=1
+endif
+ $(MAKE) deputy deputylib
+ifndef BYTECODE
+ $(MAKE) deputy deputylib NATIVECAML=1
+# For some strange reason the bytecode cil library is remade, which triggers
+# a remake of the deputy.byte.exe, but not the .asm.exe. This means that
+# we keep using the bytecode version of deputy. We force the .asm version to
+# be the most recent one
+ touch obj/$(ARCHOS)/deputy.asm.exe
+endif
+# $(MAKE) -f src/instrumenter/Makefile
+
+# Look out for outdated Makefile; if it's out of date, this will automatically
+# re-run ./config.status, then re-exec make with the same arguments.
+Makefile: config.status Makefile.in
+ @echo "Rebuilding the Makefile"
+ ./$<
+
+config.status: configure
+ ./$@ --recheck
+
+configure: configure.ac
+ autoconf
+
+
+DEPUTY_VERSION = @DEPUTY_VERSION@
+
+ifdef RELEASE
+ UNSAFE := 1
+endif
+
+ifndef DEPUTYHOME
+ DEPUTYHOME = @DEPUTYHOME@
+endif
+
+ifeq (@USE_CVCL@, yes)
+ ifndef CVCLLIB
+ CVCLLIB = @CVCLLIB@
+ endif
+ ifndef CVCLINC
+ CVCLINC = @CVCLINC@
+ endif
+ ifndef OCAMLINC
+ OCAMLINC = @OCAMLINC@
+ endif
+endif
+
+ifeq (@USE_YICES@, yes)
+ ifndef YICESLIB
+ YICESLIB = @YICESLIB@
+ endif
+ ifndef YICESINC
+ YICESINC = @YICESINC@
+ endif
+ ifndef OCAMLINC
+ OCAMLINC = @OCAMLINC@
+ endif
+endif
+
+ifeq (@USE_SATURN@, yes)
+ ifndef SATURNHOME
+ SATURNHOME = @SATURNHOME@
+ endif
+endif
+
+#
+# Deputy executable
+#
+
+OBJDIR = obj/$(ARCHOS)
+DEPENDDIR = obj/.depend
+
+SOURCEDIRS = src src/infer src/optimizer src/optimizer/xhtml \
+ src/optimizer/ptranal/cilPtrAnal src/instrumenter \
+ src/optimizer/oct/mineOct
+
+ifeq (@USE_CVCL@, yes)
+ SOURCEDIRS += src/optimizer/solver/cvclSolver
+#else
+# SOURCEDIRS += src/optimizer/solver/nullSolver
+endif
+
+ifeq (@USE_YICES@, yes)
+ SOURCEDIRS += src/optimizer/solver/yicesSolver
+else
+ SOURCEDIRS += src/optimizer/solver/nullSolver
+endif
+
+ifeq (@USE_SATURN@, yes)
+ SOURCEDIRS += src/optimizer/modref/saturnModRef
+else
+ SOURCEDIRS += src/optimizer/modref/zraModRef
+endif
+
+MODULES = doptions dutil dattrs dcanonexp dcheckdef dsolverfront
+ifeq (@USE_CVCL@, yes)
+ MODULES += cvcl
+endif
+
+ifeq (@USE_YICES@, yes)
+ MODULES += yices
+endif
+MODULES += solverInterface ptrnode unionfind dvararg markptr \
+ type solver controlflow inferkinds \
+ doptimutil dpatch dprecfinder dptranal dmodref \
+ dflowinsens dflowsens dfwdsubst ddupcelim \
+ dloopoptim dcheckstrengthen dcheckhoister dfailfinder\
+ oct doctanalysis dnonnullfinder xML xHTML dfdatbrowser\
+ doptimmain dglobinit dlocals dpoly dcheck \
+ dtaint dinstrumenter dinfer main
+
+COMPILEFLAGS = -I cil/obj/$(ARCHOS)
+LINKFLAGS = -I cil/obj/$(ARCHOS)
+
+# For building interface to octagon library
+CAML_CFLAGS += -ccopt -Isrc/optimizer/oct/mineOct
+MINE_OCT_CMODULES = oct_ocaml oct_sem oct_util
+
+ifeq (@USE_SATURN@, yes)
+ COMPILEFLAGS += -I $(SATURNHOME)/bdb
+ COMPILEFLAGS += -I $(SATURNHOME)/lang
+ COMPILEFLAGS += -I $(SATURNHOME)/util
+ COMPILEFLAGS += -I $(SATURNHOME)/mlevent
+
+ LINKFLAGS += -I $(SATURNHOME)/bdb
+ LINKFLAGS += -I $(SATURNHOME)/lang
+ LINKFLAGS += -I $(SATURNHOME)/util
+ LINKFLAGS += -I $(SATURNHOME)/mlevent
+endif
+
+ifeq (@USE_CVCL@, yes)
+ ifdef NATIVECAML
+ ENDLINKFLAGS = -cclib -L$(CVCLLIB) -cclib -lcvclite -cclib -lstdc++ -cclib -lgmp
+ else
+ ENDLINKFLAGS = -cclib -L$(CVCLLIB) -cclib -lcvclite -cclib -lstdc++ -cclib -lgmp
+ endif
+else
+ ENDLINKFLAGS =
+endif
+
+ifeq (@USE_YICES@, yes)
+ ifdef NATIVECAML
+ ENDLINKFLAGS = -cclib -L$(YICESLIB) -cclib -lyices -cclib -lstdc++ -cclib -lgmp
+ else
+ ENDLINKFLAGS = -cclib -L$(YICESLIB) -cclib -lyices -cclib -lstdc++ -cclib -lgmp
+ endif
+else
+ ENDLINKFLAGS =
+endif
+
+ifeq (@USE_SATURN@, yes)
+ ENDLINKFLAGS = -cclib -ldb -cclib -lz -cclib -levent
+else
+ ENDLINKFLAGS =
+endif
+
+ifeq (@USE_CVCL@, yes)
+ CAML_CFLAGS += -ccopt -I$(OCAMLINC) -ccopt -I$(CVCLINC)
+endif
+
+ifeq (@USE_YICES@, yes)
+ CAML_CFLAGS += -ccopt -I$(OCAMLINC) -ccopt -I$(YICESINC)
+endif
+
+include cil/ocamlutil/Makefile.ocaml
+
+PROJECT_EXECUTABLE = $(OBJDIR)/deputy$(EXE)
+PROJECT_MODULES = $(MODULES)
+ifeq (@USE_CVCL@, yes)
+ CVCL_CMODULES = cvcl_ocaml_wrappers
+else
+ CVCL_CMODULES =
+endif
+
+ifeq (@USE_YICES@, yes)
+ YICES_CMODULES = yices_ocaml_wrappers
+else
+ YICES_CMODULES =
+endif
+
+ifeq (@USE_SATURN@, yes)
+ SATURN_EXT_CMODS += $(SATURNHOME)/bdb/cl_bdb
+ SATURN_EXT_CMODS += $(SATURNHOME)/mlevent/event_stubs
+ SATURN_EXT_CMODS += $(SATURNHOME)/util/gzstr
+endif
+
+PROJECT_CMODULES = $(CVCL_CMODULES) $(YICES_CMODULES) $(MINE_OCT_CMODULES)
+EXT_PROJ_CMODS = $(SATURN_EXT_CMODS)
+
+PROJECT_LIBS = unix str cil nums
+
+ifeq (@USE_SATURN@, yes)
+ EXT_PROJ_MODS += vector prioqueue clpautil signal bdb libevent \
+ flags streamio hashcons spec specio
+endif
+
+# find the cil library
+vpath %.$(CMXA) cil/obj/$(ARCHOS)
+
+# Make sure that the Deputy files depend on the CIL library
+# Choose just one file on which everybody depends
+$(OBJDIR)/doptions.$(CMO): cil.$(CMXA)
+$(OBJDIR)/markptr.cmi $(OBJDIR)/ptrnode.cmi $(OBJDIR)/inferkinds.cmi: \
+ cil/obj/$(ARCHOS)/cil.cmi
+
+$(PROJECT_EXECUTABLE) : $(PROJECT_MODULES:%=$(OBJDIR)/%.$(CMO)) \
+ $(PROJECT_CMODULES:%=$(OBJDIR)/%.$(CMC)) \
+ cil.$(CMXA)
+ @$(NARRATIVE) "Linking $(COMPILETOWHAT) $@ $(LINKMSG)"
+ $(AT)$(CAMLLINK) -verbose -o $@ \
+ $(PROJECT_LIBS:%=%.$(CMXA)) \
+ $(EXT_PROJ_MODS:%=%.$(CMO)) \
+ $(PROJECT_MODULES:%=$(OBJDIR)/%.$(CMO)) \
+ $(EXT_PROJ_CMODS:%=%.$(OBJ)) \
+ $(PROJECT_CMODULES:%=$(OBJDIR)/%.$(CMC)) \
+ $(ENDLINKFLAGS)
+
+deputy: $(PROJECT_EXECUTABLE)
+
+#
+# Deputy runtime library
+#
+
+include cil/Makefile.gcc
+
+DEPUTY_LIBC = $(OBJDIR)/deputy_libc.$(OBJ)
+DEPUTY_LIBC_DEBUG = $(OBJDIR)/deputy_libc_debug.$(OBJ)
+DEPUTY_LINUX = $(OBJDIR)/deputy_linux.$(OBJ)
+
+#INSTR_LIB = $(OBJDIR)/instr_glob_state.$(OBJ)
+
+$(DEPUTY_LIBC): lib/deputy_libc.c include/deputy/checks.h
+ $(CC) $(CONLY) -g -O3 -D_GNUCC $(WARNALL) \
+ $(INC)$(DEPUTYHOME)/include $(OBJOUT)$@ $<
+
+#$(INSTR_LIB): lib/instr_glob_state.c
+# $(CC) $(CONLY) -g -O3 -D_GNUCC $(WARNALL) \
+# `oct-config --cflags` $(INC)$(DEPUTYHOME)/include $(OBJOUT)$@ $<
+
+ifeq (@USE_LINUX@, yes) # USE_LINUX
+LINUX_DIR = @LINUX_DIR@
+$(DEPUTY_LINUX): lib/deputy_linux.c
+ $(CC) -O -g -D__KERNEL__ \
+ -I$(LINUX_DIR)/include \
+ -I$(LINUX_DIR)/include/asm-i386/mach-default \
+ -Iinclude \
+ -include $(LINUX_DIR)/include/linux/nodeputy.h \
+ $(CONLY) $(OBJOUT)$@ $^
+else
+$(DEPUTY_LINUX): lib/deputy_linux.c
+endif
+
+deputylib: $(DEPUTY_LIBC) $(DEPUTY_LINUX) #$(INSTR_LIB)
+
+#
+# Patched libc includes
+#
+
+PATCH = $(DEPUTYHOME)/include/libc_patch.h
+PATCH_PP = $(PATCH:.h=.i)
+
+$(PATCH_PP): $(PATCH)
+ $(CC) -E -include $(DEPUTYHOME)/include/deputy/annots.h -o $@ $^
+
+.PHONY: patch
+patch: $(PATCH_PP)
+
+#
+# Testing and cleanup
+#
+
+quicktest:
+ cd test/small && make runall/deref1 runall/infer1 && \
+ echo && echo "*** Quicktest was successful" && echo
+
+clean:
+ rm -f $(OBJDIR)/*.* $(DEPENDDIR)/*.*
+
+realclean: cleancaml
+ cd cil && make clean
+
+#
+# Distribution
+#
+
+# Make a distribution that excludes certain files. We exclude the
+# toplevel Makefile from here, since otherwise it's difficult to avoid
+# excluding *all* Makefiles, which would be bad.
+dist: realclean
+ cd .. && mv deputy deputy-$(DEPUTY_VERSION) && \
+ tar zcvf deputy-$(DEPUTY_VERSION).tar.gz \
+ --exclude-from deputy-$(DEPUTY_VERSION)/.distexclude \
+ --exclude deputy-$(DEPUTY_VERSION)/Makefile \
+ deputy-$(DEPUTY_VERSION) && \
+ mv deputy-$(DEPUTY_VERSION) deputy
+
+#
+# Documentation
+#
+# make doc - creates the documentation
+# make publish_doc - creates the documentation and puts it on the web page
+#
+
+doc/deputy.1.gz: doc/deputy.1
+ gzip -c $< > $@
+
+doc/deputypp.tex: doc/deputycode.pl doc/deputy.tex
+ -rm -rf doc/html/deputy
+ -mkdir doc/html/deputy
+ -mkdir doc/html/deputy/examples
+ cd doc; perl deputycode.pl deputy.tex deputypp.tex
+
+# Documentation generated from latex files using "hevea"
+texdoc: doc/deputypp.tex
+# Create the version document
+ cd doc/html/deputy; echo "\def\deputyversion{@DEPUTY_VERSION@}">deputy.version.tex
+ cd doc/html/deputy; hevea -exec xxdate.exe ../../deputypp
+ cd doc/html/deputy; hevea -exec xxdate.exe ../../deputypp
+ cd doc/html/deputy; mv deputypp.html deputy.html
+ cd doc/html/deputy; hacha -o deputytoc.html deputy.html
+ cp -f doc/index.html doc/html/deputy/index.html
+ cp -f doc/header.html doc/html/deputy
+
+pdfdoc: doc/deputypp.tex
+ cd doc; echo "\def\deputyversion{@DEPUTY_VERSION@}" >deputy.version.tex
+ cd doc; pdflatex deputypp.tex
+ cd doc; mv deputypp.pdf html/deputy/DEPUTY.pdf
+
+.PHONY: doc texdoc pdfdoc
+doc: texdoc pdfdoc
+
+DEPUTY_HTML_DEST = /var/www/deputy
+publish_distrib: publish_doc
+
+publish_doc: doc
+ if test -d $(DEPUTY_HTML_DEST); then \
+ cp -rf doc/html/deputy/* $(DEPUTY_HTML_DEST); \
+ echo "Done publishing doc"; \
+ else \
+ error "Cannot publish because $(DEPUTY_HTML_DEST) does not exist" ; \
+ fi
+
+#
+# Installation
+#
+
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+
+BINDISTRIB_BIN = bin/deputy $(OBJDIR)/deputy.asm.exe $(OBJDIR)/deputy.byte.exe
+BINDISTRIB_LIB = lib/Deputy.pm cil/bin/CilConfig.pm cil/lib/Cilly.pm \
+ cil/lib/KeptFile.pm cil/lib/TempFile.pm cil/lib/OutputFile.pm \
+ $(OBJDIR)/deputy_libc.o
+BINDISTRIB_INCLUDE = include/libc_patch.i
+BINDISTRIB_INCLUDE_DEPUTY = include/deputy/annots.h include/deputy/checks.h
+
+BINDISTRIB_ALL = $(BINDISTRIB_BIN) $(BINDISTRIB_LIB) \
+ $(BINDISTRIB_INCLUDE) $(BINDISTRIB_INCLUDE_DEPUTY)
+
+prefix = @prefix@
+exec_prefix = @exec_prefix@
+libdir = @libdir@
+pkglibdir = $(libdir)/deputy
+
+install-base: $(BINDISTRIB_ALL)
+ $(INSTALL) -d $(DESTDIR)$(prefix)/bin
+ $(INSTALL) -d $(DESTDIR)$(pkglibdir)
+ $(INSTALL) -d $(DESTDIR)$(pkglibdir)/bin
+ $(INSTALL) -d $(DESTDIR)$(pkglibdir)/lib
+ $(INSTALL) -d $(DESTDIR)$(pkglibdir)/include/deputy
+ $(INSTALL_PROGRAM) $(BINDISTRIB_BIN) $(DESTDIR)$(pkglibdir)/bin
+ $(INSTALL_DATA) $(BINDISTRIB_LIB) $(DESTDIR)$(pkglibdir)/lib
+ $(INSTALL_DATA) $(BINDISTRIB_INCLUDE) $(DESTDIR)$(pkglibdir)/include
+ $(INSTALL_DATA) $(BINDISTRIB_INCLUDE_DEPUTY) \
+ $(DESTDIR)$(pkglibdir)/include/deputy
+ ln -sf ../lib/deputy/bin/deputy $(DESTDIR)$(prefix)/bin/deputy
+
+# We handle the man page separately, since Debian has its own utility
+# for installing man pages, whereas RPM wants us to do it.
+
+BINDISTRIB_MAN = doc/deputy.1.gz
+
+install-man: $(BINDISTRIB_MAN)
+ $(INSTALL) -d $(DESTDIR)$(prefix)/man/man1
+ $(INSTALL_DATA) $(BINDISTRIB_MAN) $(DESTDIR)$(prefix)/man/man1
+
+# And now for normal users who want everything installed...
+
+install: install-base install-man
+
+#
+# Install the web interface
+#
+
+installweb: all $(DEPUTY_HTML_DEST)
+# Copy over the files needed for running Deputy
+ mkdir -p $(DEPUTY_HTML_DEST)/bin
+ cp bin/deputy $(DEPUTY_HTML_DEST)/bin
+ mkdir -p $(DEPUTY_HTML_DEST)/cil
+ mkdir -p $(DEPUTY_HTML_DEST)/cil/bin
+# Now copy over CilConfig.pm but change the directory names
+ cat cil/bin/CilConfig.pm \
+ | sed -e 's|@DEPUTYHOME@|$(DEPUTY_HTML_DEST)|g' \
+ >$(DEPUTY_HTML_DEST)/cil/bin/CilConfig.pm
+
+ mkdir -p $(DEPUTY_HTML_DEST)/obj/@ARCHOS@
+ cp $(foreach f, deputy.asm.exe deputy_libc.o, \
+ obj/@ARCHOS@/$(f)) \
+ $(DEPUTY_HTML_DEST)/obj/@ARCHOS@
+
+ mkdir -p $(DEPUTY_HTML_DEST)/cil/lib
+ cp $(foreach f, Cilly.pm KeptFile.pm \
+ TempFile.pm OutputFile.pm, \
+ cil/lib/$(f)) \
+ $(DEPUTY_HTML_DEST)/cil/lib
+
+ mkdir -p $(DEPUTY_HTML_DEST)/lib
+ cp lib/Deputy.pm $(DEPUTY_HTML_DEST)/lib
+
+ mkdir -p $(DEPUTY_HTML_DEST)/include
+ cp -r include $(DEPUTY_HTML_DEST)
+
+ mkdir -p $(DEPUTY_HTML_DEST)/web/tmp
+ chmod a+wx $(DEPUTY_HTML_DEST)/web/tmp
+ cp $(foreach f, .htaccess web-driver.cgi index.html, \
+ web/$(f)) \
+ $(DEPUTY_HTML_DEST)/web
+ chmod a+x $(DEPUTY_HTML_DEST)/web/web-driver.cgi
+
+ mkdir -p $(DEPUTY_HTML_DEST)/test/small
+ chmod a+w $(DEPUTY_HTML_DEST)/test/small
+ cp $(foreach f, array2.c, \
+ test/small/$(f)) \
+ $(DEPUTY_HTML_DEST)/test/small
--- /dev/null
+DeputyConfig.pm
+patcher.bat
--- /dev/null
+#!/usr/bin/perl
+#
+# Copyright (c) 2006,
+# George C. Necula <necula@cs.berkeley.edu>
+# Jeremy Condit <jcondit@cs.berkeley.edu>
+# Matt Harren <matth@cs.berkeley.edu>
+# 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.
+#
+
+#
+# The main driver for the Deputy system.
+#
+
+use strict;
+
+use FindBin;
+use lib "$FindBin::RealBin/../lib";
+use lib "$FindBin::RealBin/../cil/bin";
+use lib "$FindBin::RealBin/../cil/lib";
+
+use CilConfig;
+use Deputy;
+
+$::deputyhome = "$FindBin::RealBin/..";
+
+# Now force the libc patch.
+if (! grep { $_ eq "--linux" } @ARGV) {
+ push @ARGV, "--patch=$::deputyhome/include/libc_patch.i";
+}
+
+Deputy->new(@ARGV)->doit();
+
+exit(0);
--- /dev/null
+camlprim0.obj
+*.a
+*.o
+*.obj
+*.i
+*.pdb
+*.s
+*.asm
+*.out
+allheaders
+allcfiles
+allmlfiles
+.emacs.desktop
+out
+site-config.mk
+__scalar2pointer.txt
+*.log
+tmp*
+*.log.prev
+make.out*
+odoc
+Makefile
+Makefile.features
+config.status
+*.tar.gz
+.ccuredrc
+allsrcs
+TEMP_cil-distrib
+TEMP_ccured_distrib
+.gdbinit
+autom4te*.cache
+config.h
+cil.spec
+cvss.txt
+configure.lineno
+confstat*
+config.mk
+TEMP_cil-bindistrib
--- /dev/null
+#!/bin/sh -x
+
+autoconf
--- /dev/null
+
+ (For more complete installation instructions see the documentation in
+ doc/html.)
+
+ Building from source (see below for installing binary distributions)
+---------------------------------------------------------------------
+
+ 1. If you use Windows, you must first install cygwin.
+
+ 2. You must install OCaml version 3.08 or higher (see instructions at
+ http://caml.inria.fr/ocaml). The recommended build process is using
+ the cygwin version of ocaml.
+
+ You can also build with Microsoft Visual Studio, but you must still have
+ cygwin during the build process. See msvcbuild.cmd.
+
+ 3. Download and unpack the distribution.
+
+ 4. Run ./configure (from within bash if on Windows)
+
+ 5. Run make
+
+ 6. Run make check
+
+ Now you can start using bin/cilly and bin/ccured as explained in the
+ documentation (in doc/html).
+
+
+ Installing binary distributions (Windows-only)
+-----------------------------------------------
+
+ 1. Unpack the installation package
+
+ 2. Change CILHOME to the full path of the diretory where you put cil, in
+ the following files: bin/CilConfig.pm, bin/cilly.bat, bin/patcher.bat
+ 3. Go to test/small1 directory and run
+ ..\..\cilly /c hello.c
+
+
+
+
\ No newline at end of file
--- /dev/null
+Copyright (c) 2001-2007,
+ George C. Necula <necula@cs.berkeley.edu>
+ Scott McPeak <smcpeak@cs.berkeley.edu>
+ Wes Weimer <weimer@cs.berkeley.edu>
+ Ben Liblit <liblit@cs.wisc.edu>
+ Matt Harren <matth@cs.berkeley.edu>
+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.
+
+
+(See http://www.opensource.org/licenses/bsd-license.php)
--- /dev/null
+# -*-makefile-*-
+# Makefile for CCured. The gcc part
+
+
+COMPILERNAME := GNUCC
+
+CC := gcc
+ifdef RELEASELIB
+ # sm: I will leave this here, but only use it for compiling our runtime lib
+ CFLAGS := -D_GNUCC -Wall -O3
+else
+ CFLAGS := -D_GNUCC -Wall -g -ggdb -D_DEBUG
+endif
+
+# dsw: added optional -pg flag
+ifdef USE_PG
+ CFLAGS += -pg
+endif
+
+ifdef NO_OPTIMIZATION
+ OPT_O2 :=
+else
+ OPT_O2 := -O2
+endif
+CONLY := -c
+OBJOUT := -o
+OBJEXT := o
+LIBEXT := a
+EXEOUT := -o
+LDEXT :=
+DEF := -D
+ASMONLY := -S -o
+WARNALL := -Wall
+# sm: shuffled around a couple things so I could use CPPSTART for patch2
+CPPSTART := gcc -E -x c -Dx86_LINUX -D_GNUCC -I/usr/include/sys
+CPPOUT := -o %o
+CPP := $(CPPSTART) -include fixup.h %i $(CPPOUT)
+INC := -I
+
+# sm: disable patching for now ('true' has no output)
+# (set it to 'echo' to re-enable)
+ifndef PATCHECHO
+ PATCHECHO := echo
+endif
+
+AR := ar
+LIBOUT := -rs
+
+# The system include files to be patched
+PATCH_SYSINCLUDES := crypt.h ctype.h fcntl.h glob.h grp.h malloc.h netdb.h \
+ pthread.h pwd.h signal.h stdarg.h stdio.h stdlib.h \
+ string.h time.h unistd.h varargs.h arpa/inet.h \
+ sys/cdefs.h sys/fcntl.h sys/ioctl.h sys/socket.h \
+ sys/stat.h sys/types.h sys/uio.h malloc.h setjmp.h
+
+ifneq ($(ARCHOS), x86_WIN32)
+PATCH_SYSINCLUDES += sys/shm.h
+endif
+
+# dsw & sm: DON'T DO THIS. See comment in ccured_GNUCC.patch, search for 'sys/io.h'.
+# PATCH_SYSINCLUDES += sys/io.h
+
+# matth: reent.h is only in Cygwin, and Cygwin defines struct sigaction
+# in sys/signal.h:
+ifeq ($(ARCHOS), x86_WIN32)
+PATCH_SYSINCLUDES += sys/reent.h sys/signal.h
+endif
+
+# matth: these files are not in Cygwin
+ifeq ($(ARCHOS), x86_LINUX)
+PATCH_SYSINCLUDES += nl_types.h bits/sigaction.h bits/select.h sys/prctl.h \
+ libgen.h shadow.h
+endif
+
+
--- /dev/null
+# -*- Mode: makefile -*-
+
+# Makefile for the cil wrapper
+# @do_not_edit@ Makefile.in
+#
+# author: George Necula
+
+#
+# If you want to add extra CIL features, you do not always need to change
+# this file. Just invoke
+# ./configure EXTRASRCDIRS=/home/foodir EXTRAFEATURES="foo bar"
+# This will add two features that must be defined in foo.ml and bar.ml
+#
+
+# Debugging. Set ECHO= to debug this Makefile
+.PHONY: setup quickbuild doc distrib machdep cilversion
+ECHO = @
+
+# It is important to build quickbuild first,to generate the proper dependencies
+all: quickbuild setup
+
+# Now add the defines for the CIL features
+include Makefile.features
+
+
+# look out for outdated Makefile; if it's out of date, this will automatically
+# re-run ./config.status, then re-exec make with the same arguments
+Makefile: config.status Makefile.in
+ ./$<
+
+config.status: configure
+ ./$@ --recheck
+
+configure: configure.in aclocal.m4
+ autoconf
+
+ocamlutil/perfcount.c: config.status ocamlutil/perfcount.c.in
+ ./$<
+
+@DEFAULT_COMPILER@=1
+
+
+
+ifdef RELEASE
+ NATIVECAML := 1
+ UNSAFE := 1
+endif
+
+ifndef ARCHOS
+ ARCHOS=@ARCHOS@
+endif
+
+# Put here all the byproducts of make
+OBJDIR := obj/$(ARCHOS)
+DEPENDDIR := obj/.depend
+
+CILLY_FEATURES :=
+ifdef USE_BLOCKINGGRAPH
+ CILLY_FEATURES += blockinggraph
+endif
+ifdef USE_ZRAPP
+ CILLY_FEATURES += rmciltmps zrapp
+endif
+# Add the EXTRAFEATURES
+CILLY_FEATURES += @EXTRAFEATURES@
+
+ # Now rules to make cilly
+CILLY_LIBRARY_MODULES = pretty inthash errormsg alpha trace stats util clist \
+ cilutil escape longarray growArray\
+ cabs cabshelper cabsvisit whitetrack cprint lexerhack machdep machdepenv cparser clexer \
+ cilversion cil cillower formatparse formatlex formatcil cabs2cil \
+ patch frontc check mergecil \
+ dataflow dominators bitmap ssa ciltools \
+ usedef logcalls logwrites rmtmps \
+ callgraph epicenter heapify \
+ setp uref olf ptranal \
+ canonicalize heap oneret partial simplemem simplify \
+ dataslicing sfi expcompare\
+ cfg liveness reachingdefs deadcodeelim availexps \
+ availexpslv predabst\
+ testcil \
+ $(CILLY_FEATURES) \
+ ciloptions feature_config
+# ww: we don't want "main" in an external cil library (cil.cma),
+# otherwise every program that links against that library will get
+# main's argument checking and whatnot ...
+CILLY_MODULES = $(CILLY_LIBRARY_MODULES) main
+CILLY_CMODULES = perfcount
+CILLY_LIBS = unix str
+
+SOURCEDIRS += src src/frontc src/ext src/ext/pta ocamlutil @EXTRASRCDIRS@
+MLLS += clexer.mll formatlex.mll
+MLYS += cparser.mly formatparse.mly
+MODULES += $(CILLY_MODULES) libmaincil
+
+BEFOREDEPS += $(OBJDIR)/machdep.ml
+BEFOREDEPS += $(OBJDIR)/cilversion.ml
+BEFOREDEPS += $(OBJDIR)/feature_config.ml
+
+ # Include now the common set of rules for OCAML
+include ocamlutil/Makefile.ocaml
+
+
+ # Now the rule to make cilly
+
+cilly: $(OBJDIR)/cilly$(EXE)
+$(OBJDIR)/cilly$(EXE) : $(CILLY_MODULES:%=$(OBJDIR)/%.$(CMO)) \
+ $(CILLY_CMODULES:%=$(OBJDIR)/%.$(CMC))
+ @$(NARRATIVE) "Linking $(COMPILETOWHAT) $@ $(LINKMSG)"
+ $(AT)$(CAMLLINK) -verbose -o $@ \
+ $(CILLY_LIBS:%=%.$(CMXA)) \
+ $(CILLY_LIBS:%=-cclib -l%) \
+ $^
+
+
+quickbuild: cilversion machdep cilly
+
+# Setup also makes the native code versions
+#
+# sm: cillib is only built with NATIVECAML=1 because it builds libcil.a,
+# which requires native-code .cmx compiled modules... could break it
+# into two targets so we build cil.cma both ways, but no one is using
+# cil.cma now so I'll leave it alone
+setup: cilversion machdep
+ $(MAKE) cilly NATIVECAML=
+ $(MAKE) cilly NATIVECAML=1
+ $(MAKE) cillib NATIVECAML=
+ $(MAKE) cillib NATIVECAML=1
+
+# Create the machine dependency module
+# If the cl command cannot be run then the MSVC part will be identical to GCC
+.PHONY : machdep
+machdep: $(OBJDIR)/machdep.ml
+$(OBJDIR)/machdep.ml : src/machdep-ml.c configure.in Makefile.in
+ rm -f $@
+ mkdir -p $(OBJDIR)
+ echo "(* This module was generated automatically by code in Makefile and $(<F) *)" >$@
+# Now generate the type definition
+ echo "type mach = {" >> $@
+ echo " version_major: int; (* Major version number *)" >> $@
+ echo " version_minor: int; (* Minor version number *)" >> $@
+ echo " version: string; (* gcc version string *)" >> $@
+ echo " underscore_name: bool; (* If assembly names have leading underscore *)" >> $@
+ echo " sizeof_short: int; (* Size of \"short\" *)" >> $@
+ echo " sizeof_int: int; (* Size of \"int\" *)" >> $@
+ echo " sizeof_long: int ; (* Size of \"long\" *)" >> $@
+ echo " sizeof_longlong: int; (* Size of \"long long\" *)" >> $@
+ echo " sizeof_ptr: int; (* Size of pointers *)" >> $@
+ echo " sizeof_enum: int; (* Size of enum types *)" >> $@
+ echo " sizeof_float: int; (* Size of \"float\" *)" >> $@
+ echo " sizeof_double: int; (* Size of \"double\" *)" >> $@
+ echo " sizeof_longdouble: int; (* Size of \"long double\" *)" >> $@
+ echo " sizeof_void: int; (* Size of \"void\" *)" >> $@
+ echo " sizeof_fun: int; (* Size of function *)" >> $@
+ echo " size_t: string; (* Type of \"sizeof(T)\" *)" >> $@
+ echo " wchar_t: string; (* Type of \"wchar_t\" *)" >> $@
+ echo " alignof_short: int; (* Alignment of \"short\" *)" >> $@
+ echo " alignof_int: int; (* Alignment of \"int\" *)" >> $@
+ echo " alignof_long: int; (* Alignment of \"long\" *)" >> $@
+ echo " alignof_longlong: int; (* Alignment of \"long long\" *)" >> $@
+ echo " alignof_ptr: int; (* Alignment of pointers *)" >> $@
+ echo " alignof_enum: int; (* Alignment of enum types *)" >> $@
+ echo " alignof_float: int; (* Alignment of \"float\" *)" >> $@
+ echo " alignof_double: int; (* Alignment of \"double\" *)" >> $@
+ echo " alignof_longdouble: int; (* Alignment of \"long double\" *)" >> $@
+ 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 *)" >> $@
+ echo " char_is_unsigned: bool; (* Whether \"char\" is unsigned *)">> $@
+ echo " const_string_literals: bool; (* Whether string literals have const chars *)">> $@
+ echo " little_endian: bool; (* whether the machine is little endian *)">>$@
+ echo " __thread_is_keyword: bool; (* whether __thread is a keyword *)">>$@
+ echo " __builtin_va_list: bool; (* whether __builtin_va_list is builtin (gccism) *)">>$@
+ echo "}" >> $@
+ if gcc -D_GNUCC $< -o $(OBJDIR)/machdep-ml.exe ;then \
+ echo "machdep-ml.exe created succesfully." \
+ ;else \
+ rm -f $@; exit 1 \
+ ;fi
+ echo "let gcc = {" >>$@
+ $(OBJDIR)/machdep-ml.exe >>$@
+ echo " underscore_name = @UNDERSCORE_NAME@ ;" >> $@
+ echo " __builtin_va_list = @HAVE_BUILTIN_VA_LIST@ ;" >>$@
+ echo " __thread_is_keyword = @THREAD_IS_KEYWORD@ ;" >>$@
+ echo "}" >>$@
+ if cl /D_MSVC $< /Fe$(OBJDIR)/machdep-ml.exe /Fo$(OBJDIR)/machdep-ml.obj ;then \
+ echo "let hasMSVC = true" >>$@ \
+ ;else \
+ echo "let hasMSVC = false" >>$@ ;fi
+ echo "let msvc = {" >>$@
+ $(OBJDIR)/machdep-ml.exe >>$@
+ echo " underscore_name = true ;" >> $@
+ echo " __builtin_va_list = @HAVE_BUILTIN_VA_LIST@ ;" >>$@
+ echo " __thread_is_keyword = @THREAD_IS_KEYWORD@ ;" >>$@
+ echo "}" >>$@
+ echo "let theMachine : mach ref = ref gcc" >>$@
+
+
+#
+# Create the version information module
+.PHONY: cilversion
+cilversion: $(OBJDIR)/cilversion.ml
+$(OBJDIR)/cilversion.ml: src/cilversion.ml.in config.status
+ rm -f $@
+ ./config.status --file=$@:$<
+
+# build two libraries
+.PHONY: cillib libcil
+ifeq ($(NATIVECAML),1)
+cillib: $(OBJDIR)/cil.$(CMXA) $(OBJDIR)/libcil.a
+else
+cillib: $(OBJDIR)/cil.$(CMXA)
+endif
+
+
+$(OBJDIR)/feature_config.ml: config.status
+ rm -f $(OBJDIR)/feature_config.*
+ echo "(* This module was generated automatically by code in Makefile.in *)" >$@
+# The Cilly feature options. A list of Cil.featureDescr
+ echo "open Cil" >>$@
+ echo "let features : featureDescr list = [" >> $@
+ifdef USE_BLOCKINGGRAPH
+ echo " Blockinggraph.feature;" >> $@
+endif
+ifdef USE_RAND
+ echo " Rand.feature;" >> $@
+endif
+ifdef USE_ARITHABS
+ echo " Arithabs.feature;" >>$@
+endif
+ifdef USE_ZRAPP
+ echo " Zrapp.feature;" >> $@
+endif
+# Now the extra features, with the first letter capitalized
+ echo -n " (* EXTRAFEATURES: *)" >> $@
+ echo \
+ $(foreach f,@EXTRAFEATURES@, \
+ "\n "`echo $f | cut -c 1 | tr "[a-z]" "[A-Z]"``echo $f | cut -c 2-`".feature;") \
+ | perl -pe 's/\\n/\n/g' >> $@
+ echo "]" >>$@
+
+
+
+
+
+
+OCAML_CIL_LIB_MODULES := $(CILLY_LIBRARY_MODULES)
+OCAML_CIL_LIB_CMODULES := perfcount
+
+# list of modules to use for building a library; remove 'main'
+# and add 'libmaincil'
+OCAML_CIL_C_LIB_MODULES := $(CILLY_MODULES:main=) libmaincil
+
+# Build an OCAML library (CMA / CMXA) that exports our Cil stuff
+$(OBJDIR)/cil.$(CMXA): $(OCAML_CIL_LIB_CMODULES:%=$(OBJDIR)/lib%.a) \
+ $(OCAML_CIL_LIB_MODULES:%=$(OBJDIR)/%.$(CMO))
+ $(CAMLLINK) -a -o $@ -ccopt -L$(pkglibdir) \
+ $(OCAML_CIL_LIB_CMODULES:%=-cclib -l%) \
+ $(OCAML_CIL_LIB_MODULES:%=$(OBJDIR)/%.$(CMO))
+
+$(OBJDIR)/libperfcount.a: %: %($(OBJDIR)/perfcount.$(CMC))
+ ranlib $@
+
+# sm: for Simon: build a library of CIL functions which can
+# be called from C code; this is like the target above, except
+# it is callable from C instead of from Ocaml
+ifeq ($(NATIVECAML),1)
+$(OBJDIR)/libcil.a: $(OCAML_CIL_LIB_CMODULES:%=$(OBJDIR)/lib%.a) \
+ $(OCAML_CIL_LIB_MODULES:%=$(OBJDIR)/%.$(CMO))
+ ocamlopt -output-obj -o $@ $(CILLY_LIBS:%=%.cmxa) $^
+else
+$(OBJDIR)/libcil.a:
+ @echo "Can only build $@ when NATIVECAML is 1."
+ exit 2
+endif
+
+# Test cil
+ifdef _MSVC
+TESTCILARG=--MSVC --testcil "bash msvctestcil"
+else
+TESTCILARG= --testcil "bash gcctestcil"
+endif
+
+.PHONY: testcil
+testcil: $(OBJDIR)/cilly$(EXE)
+ cd test; ../$(OBJDIR)/cilly$(EXE) $(TESTCILARG)
+
+.PHONY: odoc texdoc pdfdoc
+
+###
+### DOCUMENTATION
+###
+### The following are available
+###
+### make doc - creates the documentation
+### make publish_doc - creates the documentation and puts it on the web page
+
+ODOC_FILES = ocamlutil/pretty.mli ocamlutil/errormsg.mli \
+ ocamlutil/clist.mli \
+ ocamlutil/stats.mli src/cil.mli src/formatcil.mli \
+ ocamlutil/alpha.mli src/cillower.mli \
+ src/ext/cfg.mli src/ext/dataflow.mli \
+ src/ext/dominators.mli
+
+
+# Documentation generated by "ocamldoc"
+odoc: $(OBJDIR)/pretty.cmi $(OBJDIR)/cil.cmi
+ -rm -rf doc/html/cil/api doc/html/cil/api-latex
+ -mkdir -p doc/html/cil/api
+ -mkdir -p doc/html/cil/api-latex
+ -rm -f doc/ocamldoc.sty
+ ocamldoc -d doc/html/cil/api -v -stars \
+ -html \
+ -t "CIL API Documentation (version @CIL_VERSION@)" \
+ -I $(OBJDIR) -hide Pervasives $(ODOC_FILES)
+
+doc/cilpp.tex: doc/cilcode.pl doc/cil.tex
+ -rm -rf doc/html/cil
+ -mkdir doc/html/cil
+ -mkdir doc/html/cil/examples
+ cd doc; perl cilcode.pl cil.tex >cilpp.tex.tmp
+ mv doc/cilpp.tex.tmp $@
+
+# Documentation generated from latex files using "hevea"
+texdoc: doc/cilpp.tex
+# Create the version document
+ cd doc/html/cil; echo "\def\cilversion{@CIL_VERSION@}" >cil.version.tex
+ cd doc/html/cil; echo "\def\ccuredversion{@CCURED_VERSION@}" >>cil.version.tex
+ cd doc/html/cil; hevea -exec xxdate.exe ../../cilpp
+ cd doc/html/cil; hevea -exec xxdate.exe ../../cilpp
+ cd doc/html/cil; mv cilpp.html cil.html
+ cd doc/html/cil; hacha -o ciltoc.html cil.html
+ cp -f doc/index.html doc/html/cil/index.html
+ cp -f doc/header.html doc/html/cil
+
+pdfdoc: doc/cilpp.tex $(OBJDIR)/pretty.cmi $(OBJDIR)/cil.cmi
+ cd doc; echo "\def\cilversion{@CIL_VERSION@}" >cil.version.tex
+ cd doc; echo "\def\ccuredversion{@CCURED_VERSION@}" >>cil.version.tex
+ cd doc; pdflatex cilpp.tex; pdflatex cilpp.tex
+ cd doc; mv cilpp.pdf html/cil/CIL.pdf
+ ocamldoc -o doc/cil-api.tex -v -stars \
+ -latex \
+ -t "CIL API Documentation (version @CIL_VERSION@)" \
+ -I $(OBJDIR) -hide Pervasives $(ODOC_FILES)
+
+ cd doc ; TEXINPUTS="$$TEXINPUTS:/usr/local/lib/ocaml/ocamldoc:/usr/lib/ocaml/ocamldoc" pdflatex cil-api.tex
+ cd doc ; mv cil-api.pdf html/cil/CIL-API.pdf
+
+
+# You should usually run this twice to get all of the references linked
+# correctly.
+doc: texdoc pdfdoc odoc
+
+
+#----------------------------------------------------------------------
+# Generate the CIL distribution
+# This will create a file cil.tar.gz. It includes the HTML documentation
+# so that people can use it even if they don't have ocamldoc, hevea etc.
+
+.PHONY: distrib distrib-nocheck checkdistrib
+CIL_TAR_GZ:=cil-@CIL_VERSION@.tar.gz
+## Make a distribution and check it
+distrib: distrib-nocheck checkdistrib
+
+# Work in a temporary directory
+TEMP_DIR = TEMP_cil-distrib
+
+# The tar archive members will be relative to this directory
+TOP_DIR = $(TEMP_DIR)/cil
+
+DISTRIB_ROOT = README LICENSE INSTALL Makefile.in \
+ config.h.in config.mk.in Makefile.gcc Makefile.msvc \
+ configure configure.in install-sh config.guess config.sub \
+ cil.spec cil.spec.in \
+ _tags \
+ aclocal.m4 \
+ cil.itarget \
+ cil.odocl \
+ myocamlbuild.ml
+
+DISTRIB_SRC = cilutil.ml cil.ml cil.mli check.ml check.mli \
+ rmtmps.ml rmtmps.mli formatlex.mll formatparse.mly \
+ formatcil.mli formatcil.ml testcil.ml \
+ mergecil.ml mergecil.mli main.ml machdep-ml.c \
+ ciloptions.ml ciloptions.mli libmaincil.ml \
+ escape.ml escape.mli cillower.mli cillower.ml \
+ _tags \
+ cil.mllib \
+ cilversion.ml.in
+
+DISTRIB_OCAMLUTIL = pretty.ml pretty.mli errormsg.ml errormsg.mli \
+ trace.ml trace.mli stats.ml stats.mli util.ml util.mli \
+ inthash.ml inthash.mli alpha.ml alpha.mli \
+ intmap.ml intmap.mli clist.ml clist.mli \
+ longarray.ml longarray.mli \
+ growArray.ml growArray.mli \
+ bitmap.ml bitmap.mli \
+ perfcount.c.in Makefile.ocaml \
+ _tags
+
+
+DISTRIB_SRC_FRONTC = cabs.ml cabshelper.ml cprint.ml clexer.mli clexer.mll \
+ cparser.mly whitetrack.mli whitetrack.ml lexerhack.ml \
+ cabs2cil.ml cabs2cil.mli frontc.ml frontc.mli \
+ cabsvisit.mli cabsvisit.ml patch.mli patch.ml
+
+DISTRIB_SRC_EXT = logcalls.ml logcalls.mli \
+ astslicer.ml heap.ml partial.ml \
+ logwrites.ml heapify.ml callgraph.ml callgraph.mli \
+ epicenter.ml usedef.ml ciltools.ml \
+ deadcodeelim.ml availexps.ml \
+ dataflow.ml dataflow.mli \
+ dominators.ml dominators.mli \
+ ssa.ml ssa.mli \
+ stackoverflow.mli stackoverflow.ml \
+ canonicalize.ml canonicalize.mli \
+ oneret.ml oneret.mli sfi.ml \
+ simplemem.ml simplify.ml \
+ blockinggraph.ml blockinggraph.mli \
+ dataslicing.ml dataslicing.mli \
+ _tags \
+ reachingdefs.ml \
+ cfg.ml cfg.mli \
+ liveness.ml \
+ expcompare.ml \
+ availexpslv.ml \
+ predabst.ml
+
+DISTRIB_SRC_EXT_PTA = setp.ml setp.mli golf.ml golf.mli \
+ ptranal.ml ptranal.mli \
+ steensgaard.mli steensgaard.ml \
+ uref.ml uref.mli olf.ml olf.mli
+
+DISTRIB_LIB = Cilly.pm KeptFile.pm OutputFile.pm TempFile.pm
+
+DISTRIB_BIN = CilConfig.pm.in cilly cilly.bat.in \
+ patcher patcher.bat.in test-bad teetwo
+
+DISTRIB_SMALL1=hello.c func.c init.c init1.c wchar1.c vararg1.c testharness.h
+
+distrib-nocheck: $(DISTRIB_ROOT) doc
+ # Create the distribution from scratch
+ rm -rf $(TEMP_DIR)
+ mkdir $(TEMP_DIR)
+
+ rm -rf $(CIL_TAR_GZ)
+ mkdir $(TOP_DIR) \
+ $(TOP_DIR)/bin \
+ $(TOP_DIR)/doc \
+ $(TOP_DIR)/doc/api \
+ $(TOP_DIR)/debian \
+ $(TOP_DIR)/lib \
+ $(TOP_DIR)/obj \
+ $(TOP_DIR)/obj/.depend \
+ $(TOP_DIR)/src \
+ $(TOP_DIR)/src/frontc \
+ $(TOP_DIR)/src/ext \
+ $(TOP_DIR)/src/ext/pta \
+ $(TOP_DIR)/test \
+ $(TOP_DIR)/test/small1 \
+ $(TOP_DIR)/ocamlutil
+
+ cp $(patsubst %,%,$(DISTRIB_ROOT)) $(TOP_DIR)
+
+ cp $(patsubst %,src/%,$(DISTRIB_SRC)) $(TOP_DIR)/src
+ cp $(patsubst %,ocamlutil/%,$(DISTRIB_OCAMLUTIL)) $(TOP_DIR)/ocamlutil
+ cp $(patsubst %,src/ext/%,$(DISTRIB_SRC_EXT)) $(TOP_DIR)/src/ext
+ cp $(patsubst %,src/ext/pta/%,$(DISTRIB_SRC_EXT_PTA)) \
+ $(TOP_DIR)/src/ext/pta
+ cp $(patsubst %,src/frontc/%,$(DISTRIB_SRC_FRONTC)) \
+ $(TOP_DIR)/src/frontc
+ cp $(patsubst %,lib/%,$(DISTRIB_LIB)) $(TOP_DIR)/lib
+ cp $(patsubst %,bin/%,$(DISTRIB_BIN)) $(TOP_DIR)/bin
+ cp $(patsubst %,test/small1/%,$(DISTRIB_SMALL1)) $(TOP_DIR)/test/small1
+
+ cp -r doc/html/cil/* $(TOP_DIR)/doc
+ cp debian/* $(TOP_DIR)/debian
+
+# Delete all Subversion metadata directories
+ find $(TEMP_DIR) -name .svn -print0 | xargs --null --no-run-if-empty rm -rf
+
+# Now make the TAR ball
+ cd $(TEMP_DIR); tar cfz $(CIL_TAR_GZ) cil
+ mv $(TEMP_DIR)/$(CIL_TAR_GZ) .
+
+# rm -rf $(TEMP_DIR)
+
+## Check a distribution
+checkdistrib:
+ cd $(TOP_DIR) && ./configure && \
+ $(MAKE) && $(MAKE) quicktest
+
+distclean: clean
+ rm -f src/frontc/cparser.output
+ rm -f src/formatparse.output
+ rm -f ocamlutil/perfcount.c
+ rm -f bin/cilly.bat
+ rm -f bin/patcher.bat
+ rm -f bin/CilConfig.pm
+ rm -f config.log
+ rm -f config.h
+ rm -f Makefile
+
+## Publish the distribution
+CILHTMLDEST=/var/www/cil
+publish_distrib: publish_doc
+ if test -d $(CILHTMLDEST); then \
+ cp -rf doc/html/cil/* $(CILHTMLDEST); \
+ cp -f $(CIL_TAR_GZ) $(CILHTMLDEST)/distrib; \
+ ln -sf $(CILHTMLDEST)/distrib/$(CIL_TAR_GZ) $(CILHTMLDEST)/distrib/cil-latest.tar.gz ; \
+ echo "Publish succeeded"; \
+ else \
+ error "Cannot publish because $(CILHTMLDEST) does not exist" ; \
+ fi
+
+publish_doc: doc
+ if test -d $(CILHTMLDEST); then \
+ cp -rf doc/html/cil/* $(CILHTMLDEST); echo "Done publishing doc"; \
+ else \
+ error "Cannot publish because $(CILHTMLDEST) does not exist" ; \
+ fi
+
+cleancheck:
+ rm -f test/small1/*.o
+ rm -f test/small1/hello
+ rm -f test/small1/vararg1
+ rm -f test/small1/wchar1
+
+clean: cleancaml cleancheck
+
+
+# Now include the compiler specific stuff
+ifdef _MSVC
+ include Makefile.msvc
+else
+ ifdef _GNUCC
+ include Makefile.gcc
+ endif
+endif
+
+test/%:
+ bin/cilly $(CONLY) test/small1/$*.c $(OBJOUT)test/small1/$*.o
+
+testrun/%:
+ bin/cilly test/small1/$*.c $(OBJOUT)test/small1/$*
+ test/small1/$*
+
+
+
+.PHONY: quicktest
+quicktest: $(patsubst %,test/%,func init init1) \
+ $(patsubst %,testrun/%,hello wchar1 vararg1)
+
+.PHONY: check
+check: quicktest
+
+############# Binary distribution ################
+.PHONY: bindistrb checkbindistrib
+
+BINCIL_TAR_GZ:=cil-win32-@CIL_VERSION@.tar.gz
+
+# Work in a temporary directory
+BINTEMP_DIR = TEMP_cil-bindistrib
+
+# The tar archive members will be relative to this directory
+BINTOP_DIR = $(BINTEMP_DIR)/cil
+
+BINDISTRIB_ROOT = README LICENSE
+
+BINDISTRIB_LIB = Cilly.pm KeptFile.pm OutputFile.pm TempFile.pm
+
+BINDISTRIB_BIN = CilConfig.pm.in cilly cilly.bat.in \
+ patcher patcher.bat.in
+
+BINDISTRIB_OBJ = cilly.byte.exe cilly.asm.exe
+
+BINDISTRIB_SMALL1=hello.c
+
+bindistrib-nocheck: $(BINDISTRIB_ROOT) obj/x86_WIN32/cilly.asm.exe
+ # Create the distribution from scratch
+ rm -rf $(BINTEMP_DIR)
+ mkdir $(BINTEMP_DIR)
+
+ mkdir $(BINTOP_DIR) \
+ $(BINTOP_DIR)/obj \
+ $(BINTOP_DIR)/doc \
+ $(BINTOP_DIR)/lib \
+ $(BINTOP_DIR)/bin \
+ $(BINTOP_DIR)/doc/api \
+ $(BINTOP_DIR)/obj/.depend \
+ $(BINTOP_DIR)/obj/x86_WIN32 \
+ $(BINTOP_DIR)/test \
+ $(BINTOP_DIR)/test/small1
+
+ cp $(patsubst %,%,$(BINDISTRIB_ROOT)) $(BINTOP_DIR)
+ cp $(patsubst %,lib/%,$(BINDISTRIB_LIB)) $(BINTOP_DIR)/lib
+ cat bin/CilConfig.pm.in \
+ | sed -e "s|@||g" \
+ | sed -e "s|CC|cl|" \
+ | sed -e "s|DEFAULT_CIL_MODE|MSVC|" \
+ | sed -e "s|ARCHOS|x86_WIN32|" \
+ > $(BINTOP_DIR)/bin/CilConfig.pm
+ cat bin/patcher.bat.in | sed -e "s|@||g" >$(BINTOP_DIR)/bin/patcher.bat
+ cp bin/patcher $(BINTOP_DIR)/bin
+ cp bin/cilly $(BINTOP_DIR)/bin
+ cat bin/cilly.bat.in | sed -e "s|@||g" > $(BINTOP_DIR)/bin/cilly.bat
+ cp $(patsubst %,test/small1/%,$(BINDISTRIB_SMALL1)) \
+ $(BINTOP_DIR)/test/small1
+ cp $(patsubst %,obj/x86_WIN32/%,$(BINDISTRIB_OBJ)) \
+ $(BINTOP_DIR)/obj/x86_WIN32
+
+ cp -r doc/html/cil/* $(BINTOP_DIR)/doc
+# Delete all CVS directories
+ if find $(BINTEMP_DIR) -name CVS -print >cvss.txt ; then \
+ rm -rf `cat cvss.txt` ;fi
+# Now make the TAR ball
+ cd $(BINTEMP_DIR); tar cfz $(BINCIL_TAR_GZ) cil
+ mv $(BINTEMP_DIR)/$(BINCIL_TAR_GZ) .
+
+# rm -rf $(TEMP_DIR)
+
+## Check a distribution
+checkbindistrib:
+
+########################################################################
+
+
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+
+prefix = @prefix@
+exec_prefix = @exec_prefix@
+datarootdir = @datarootdir@
+libdir = @libdir@
+pkglibdir = $(libdir)/cil
+datadir = @datadir@
+pkgdatadir = $(datadir)/cil
+
+all_distrib := $(DISTRIB_OCAMLUTIL) $(DISTRIB_SRC) $(DISTRIB_SRC_FRONTC) $(DISTRIB_SRC_EXT) $(DISTRIB_SRC_EXT_PTA)
+all_ml := $(filter %.ml, $(all_distrib))
+all_mli := $(filter %.mli, $(all_distrib))
+install_ml := $(filter $(OCAML_CIL_LIB_MODULES:=.ml), $(all_ml))
+install_cmx := $(install_ml:%.ml=$(OBJDIR)/%.cmx)
+install_mli := $(filter $(OCAML_CIL_LIB_MODULES:=.mli), $(all_mli))
+install_cmi := $(install_mli:%.mli=$(OBJDIR)/%.cmi)
+install_cma := $(addprefix $(OBJDIR)/cil., cma cmxa a)
+install_lib := $(OCAML_CIL_LIB_CMODULES:%=$(OBJDIR)/lib%.a)
+
+install: $(install_cmi) $(install_cma) $(install_lib)
+ $(INSTALL) -d $(DESTDIR)$(pkglibdir)
+ $(INSTALL_DATA) $(install_cma) $(DESTDIR)$(pkglibdir)
+ $(INSTALL_DATA) $(install_cmi) $(DESTDIR)$(pkglibdir)
+ $(INSTALL_DATA) $(install_cmx) $(DESTDIR)$(pkglibdir)
+ $(INSTALL_DATA) $(install_lib) $(DESTDIR)$(pkglibdir)
+ $(INSTALL) -d $(DESTDIR)$(pkgdatadir)
+ $(INSTALL_DATA) $(addprefix lib/, $(filter %.pm, $(DISTRIB_LIB))) $(DESTDIR)$(pkgdatadir)
+
+cil.spec: cil.spec.in
+ ./config.status $@
+
+rpms: distrib
+ rpmbuild -ta $(CIL_TAR_GZ)
+
--- /dev/null
+#
+# Makefile for CCured. The Microsoft Visual C part
+#
+COMPILERNAME=MSVC
+
+CC:=cl /nologo
+ifdef RELEASELIB
+#matth: we need the frame pointer for CHECK_GETFRAME, so
+# use /Oy- to prevent that optimization.
+ CFLAGS:=/DRELEASE /D_MSVC /Ox /Ob2 /G6 /Oy-
+else
+ CFLAGS:=/D_DEBUG /D_MSVC /Zi /MLd
+endif
+CONLY:=/c
+
+OPT_O2:= /Ox /Ob2 /G6
+
+OBJOUT:=/Fo
+OBJEXT:=obj
+
+EXEOUT:=/Fe
+LIBEXT:=lib
+LDEXT:=.exe
+
+DEF:=/D
+ASMONLY:=/Fa
+INC:=/I
+
+CPPSTART:=cl /Dx86_WIN32 /D_MSVC /E /TC /I./lib /DCCURED
+CPPOUT:= >%o
+CPP:=$(CPPSTART) /FI fixup.h %i $(CPPOUT)
+
+PATCHECHO:=echo
+
+AR:=lib
+LIBOUT:=/OUT:
+
+# The system include files to be patched
+PATCH_SYSINCLUDES:=stdio.h ctype.h string.h io.h stdarg.h crtdbg.h \
+ varargs.h stdlib.h time.h malloc.h
+
+
--- /dev/null
+
+TODO list
+
+
+CIL
+------
+
+Front-end
+ - trigraph sequences (??:, ...) ISO 5.2.1.1
+ - name spaces for struct/enum/union are the same ISO 6.2.3
+ - check integer conversion ISO 6.3.1.1
+ - character constants (type, value, escapes) ISO 6.4.4.4
+ - string literals (value, escapes) ISO 6.4.5
+ - punctuation tokens ISO 6.4.6
+ - default argument promotions in function calls ISO 6.5.2.2
+ - compound literals ISO 6.5.2.5. Missing fields initialized to 0!!
+ - check that long long is properly done in type specs ISO 6.7.2
+ - Initialization ISO 6.7.8
+
+- MSVC has a bug in the handling of shift operators: arithemtic conversions
+are applies on both operands instead of just integral promotions. We duplicate
+this bug in doBinOp in cabs2cil.
+
+ - we should allow the user to specify a logging function that takes
+ printf()-style arguments (rather than hardcoding syslog/printk/printf).
+
+ - the restrict attribute is dropped in cabs2cil
+
+ - struct and union must share the name space
+
+ - when merging we use too much memory. We should be droping the references to
+ the CABS files once we convert each one to CIL.
+
+CCURED
+==============
+
+ - if we use memcpy to copy some stuff from local variables to the heap we
+ might be moving stack pointers that way. The only way to prevent that is to
+ disallow storing stack pointers in local variables that are arrays or whose
+ address is taken.
+
+ - in box.ml offsetOfFirstScalar looks only at the first field of a union.
+
+ - in box.ml when we check tags we check all fields in a union. This is sound
+ but excessive.
+
+(2) Make a file with global declarations of common functions like strcpy().
+ These declarations should include pointer annotations and should be
+ used instead of the ones that appear in the source.
+?(9) Find some way to describe [recursive] types at runtime and use them as
+ tags.
+
+
+ - on MSVC we turn on 32-bit packing of stuff
+
+ - Writing or reading unaligned pointers is not allowed.
+
+ - Right now when we try to read a pointer and we don't find one in tags, we
+ overwrite the base part of the pointer to be read with 0. But this might
+ have undesired side-effects.
+
+ - I wonder what do we do when casting between abstract types (struct foo *
+ where struct foo is not defined)
+
+ - change CHECK_RETURNPTR and CHECK_STOREPTR so that the range checked
+ is 512K (instead of 1 meg) for Linux Kernel Drivers.
+
+ - add a flag that effectively puts #pragma box(off) / #pragma box(on)
+ around all global initializers in a file.
+
+
+ - turning interface char* into ROSTRING is unsound. This is done even when
+ the item is subject to writes.
+
+ - printf is not quite safe. If we do not manage to verify statically the
+ arguments we should be calling a wrapper. Do we do that?
+
+ - in a SEQ pointer we must keep the end = null if the poiner is an integer.
+ Else there is trouble when we cast to FSEQ. Can we cast integers into FSEQ?
+
+
+ - sm: because wild area lengths have word-level granularity, we can't protect
+ the final 0 of a char array unless the alignment works out; solutions
+ include changing granularity to bytes (painful) or changing the array-
+ expander to ensure alignment (potentially wasteful of a few bytes here
+ and there)
--- /dev/null
+
+ See the documentation in doc/html.
--- /dev/null
+# subdirectories containing source code
+"ocamlutil": include
+"src": include
--- /dev/null
+dnl check whether integer types $1 and $2 are the same
+
+AC_DEFUN([__CIL_CHECK_INTEGER_TYPE_TYPE], [
+ if test -z "$real_type"; then
+ AC_COMPILE_IFELSE(AC_LANG_SOURCE([
+#include <stddef.h>
+#include <wchar.h>
+/* We define a prototype with one type and the function with
+ another type. This will result in compilation error
+ unless the types are really identical. */
+$2 foo($2 x);
+$1 foo($1 x) { return x; }]),
+ real_type='$2')
+ fi
+])
+
+
+dnl check whether integer type $1 is the
+dnl the signed or unsigned variant of $2
+
+AC_DEFUN([__CIL_CHECK_INTEGER_TYPE_SIGNS], [
+ __CIL_CHECK_INTEGER_TYPE_TYPE([$1], [$2])
+ __CIL_CHECK_INTEGER_TYPE_TYPE([$1], [unsigned $2])
+])
+
+
+dnl set configuration macro $2 to a string representing
+dnl the real integer type corresponding to typedef $1
+
+AC_DEFUN([CIL_CHECK_INTEGER_TYPE], [
+ AC_MSG_CHECKING([for real definition of $1])
+ real_type=''
+ __CIL_CHECK_INTEGER_TYPE_SIGNS([$1], int)
+ __CIL_CHECK_INTEGER_TYPE_SIGNS([$1], long)
+ __CIL_CHECK_INTEGER_TYPE_SIGNS([$1], short)
+ __CIL_CHECK_INTEGER_TYPE_SIGNS([$1], char)
+ if test -z "$real_type"; then
+ AC_MSG_ERROR([cannot find definition of $1])
+ fi
+ AC_DEFINE_UNQUOTED([$2], "[$real_type]")
+ AC_MSG_RESULT([$real_type])
+])
+
+
+# I find it useful to mark generated files as read-only so I don't
+# accidentally edit them (and them lose my changes when ./configure
+# runs again); I had originally done the chmod after AC_OUTPUT, but
+# the problem is then the chmod doesn't run inside ./config.status
+
+# CIL_CONFIG_FILES(filename)
+# do AC_CONFIG_FILES(filename, chmod a-w filename)
+define([CIL_CONFIG_FILES],
+[{
+ if test -f [$1].in; then
+ AC_CONFIG_FILES([$1], chmod a-w [$1])
+ else
+ true
+ #echo "skipping [$1] because it's not in this distribution"
+ fi
+}])
+define([CIL_CONFIG_EXE_FILES],
+[{
+ if test -f [$1].in; then
+ AC_CONFIG_FILES([$1], [chmod a-w,a+x $1])
+ else
+ true
+ #echo "skipping [$1] because it's not in this distribution"
+ fi
+}])
--- /dev/null
+scaninfer.bat
+ccured.bat
+cilly.bat
+patcher.bat
+CilConfig.pm
\ No newline at end of file
--- /dev/null
+
+$::archos = "@ARCHOS@";
+$::cc = "@CC@";
+$::cilhome = "@CILHOME@";
+$::default_mode = "@DEFAULT_CIL_MODE@";
+
--- /dev/null
+#!/bin/sh
+# apply my CABS transformer to a file
+
+if [ "$3" = "" ]; then
+ echo "usage: $0 [-debug] input.c patch.xform output.c"
+ exit 0
+fi
+
+args=""
+if [ "$1" = "-debug" ]; then
+ args="--tr sm,patch,patchDebug,patchTime"
+ shift
+fi
+
+exec `dirname $0`/../obj/x86_LINUX/cilly.byte.exe $args \
+ --cabsonly "$3" --patchFile "$2" "$1"
--- /dev/null
+#!/usr/bin/perl
+# A simple use of the Cilly module
+#
+#
+#
+# Copyright (c) 2001-2002,
+# George C. Necula <necula@cs.berkeley.edu>
+# Scott McPeak <smcpeak@cs.berkeley.edu>
+# Wes Weimer <weimer@cs.berkeley.edu>
+# 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.
+#
+use strict;
+use Data::Dumper;
+use FindBin;
+use lib "$FindBin::Bin";
+use lib "$FindBin::Bin/../lib"; # The libraries are in the lib directory
+# Read the configuration script
+use CilConfig;
+
+use Cilly;
+
+$::default_is_merge = 0;
+my $stub = CilCompiler->new(@ARGV);
+
+$stub->setVersion ();
+
+# print Dumper($stub);
+$stub->doit();
+
+
+# Define here your favorite compiler by overriding Merger methods
+package CilCompiler;
+use File::Basename;
+use strict;
+BEGIN {
+ @CilCompiler::ISA = qw(Cilly);
+ $CilCompiler::base = "$::cilhome/obj/$::archos/cilly";
+ # Use the most recent version of cilly
+ $CilCompiler::mtime_asm = int((stat("$CilCompiler::base.asm.exe"))[9]);
+ $CilCompiler::mtime_byte = int((stat("$CilCompiler::base.byte.exe"))[9]);
+ $CilCompiler::use_debug =
+ grep(/--bytecode/, @ARGV) ||
+ grep(/--ocamldebug/, @ARGV) ||
+ ($CilCompiler::mtime_asm < $CilCompiler::mtime_byte);
+ $CilCompiler::compiler =
+ $CilCompiler::base .
+ ($CilCompiler::use_debug ? ".byte" : ".asm") . ".exe";
+ if($CilCompiler::use_debug) {
+ $ENV{"OCAMLRUNPARAM"} = "b" . $ENV{"OCAMLRUNPARAM"};
+ }
+}
+
+# We need to customize the collection of arguments
+sub collectOneArgument {
+ my($self, $arg, $pargs) = @_;
+ if($arg =~ m|--transval=(.+)$|) {
+ $self->{TRANSVAL} = $1; return 1;
+ }
+ if($arg eq '--ocamldebug') {
+ $self->{OCAMLDEBUG} = 1; return 1;
+ }
+ if($arg eq '--cabsonly') {
+ $self->{CABSONLY} = 1; return 1;
+ }
+ # See if the super class understands this
+ return $self->SUPER::collectOneArgument($arg, $pargs);
+}
+
+sub usage {
+ print "Usage: cilly [options] [gcc_or_mscl arguments]\n";
+}
+
+sub helpMessage {
+ my($self) = @_;
+ # Print first the original
+ $self->SUPER::helpMessage();
+ print <<EOF;
+
+ All other arguments starting with -- are passed to the Cilly process.
+
+The following are the arguments of the Cilly process
+EOF
+ my @cmd = ($CilCompiler::compiler, '-help');
+ $self->runShell(@cmd);
+}
+
+
+sub CillyCommand {
+ my ($self, $ppsrc, $dest) = @_;
+
+ my $aftercil;
+ my @cmd = ($CilCompiler::compiler);
+
+ if(defined $ENV{OCAMLDEBUG} || $self->{OCAMLDEBUG}) {
+ print "OCAMLDEBUG is on\n";
+ my @idirs = ("src", "src/frontc", "src/ccured", "src/ext",
+ "ocamlutil",
+ "obj/$::archos");
+ my @iflags = map { ('-I', "$::cilhome/$_") } @idirs;
+ unshift @cmd, 'ocamldebug', '-emacs', @iflags;
+ }
+ if($::docxx) {
+ push @cmd, '--cxx';
+ }
+ if($self->{CABSONLY}) {
+ $aftercil = $self->cilOutputFile($dest, 'cabs.c');
+ push @cmd, '--cabsonly', $aftercil;
+ } else {
+ if(defined $self->{CILLY_OUT}) {
+ $aftercil = new OutputFile($dest, $self->{CILLY_OUT});
+ return ($aftercil, @cmd);
+ }
+ $aftercil = $self->cilOutputFile($dest, 'cil.c');
+ }
+ return ($aftercil, @cmd, '--out', $aftercil);
+}
+
+sub MergeCommand {
+ my ($self, $ppsrc, $dir, $base) = @_;
+
+ return ('', $CilCompiler::compiler);
+}
+
+
+1;
--- /dev/null
+perl @CILHOME@/bin/cilly %*
--- /dev/null
+#!/usr/bin/perl
+# A Perl script that patches a bunch of files
+#
+#
+#
+# Copyright (c) 2001-2002,
+# George C. Necula <necula@cs.berkeley.edu>
+# Scott McPeak <smcpeak@cs.berkeley.edu>
+# Wes Weimer <weimer@cs.berkeley.edu>
+# 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.
+#
+use strict;
+use File::Basename;
+use File::Copy;
+use Getopt::Long; # Command-line option processing
+use Data::Dumper;
+use FindBin;
+use lib "$FindBin::Bin";
+use lib "$FindBin::Bin/../lib";
+# Read the configuration script
+use CilConfig;
+
+$::iswin32 = $^O eq 'MSWin32' || $^O eq 'cygwin';
+# matth: On cygwin, ^O is either MSWin32 or cygwin, depending on how you build
+# perl. We don't care about the distinction, so just treat all windows
+# platforms the same when looking at "system=cygwin" tags on patches.
+$::platform = $::iswin32 ? 'cygwin' : $^O;
+
+
+# Set filename parsing according to current operating system.
+File::Basename::fileparse_set_fstype($^O);
+
+sub printHelp {
+ print <<EOL;
+Patch include files
+Usage: patcher [options] args
+
+options:
+ --help Prints this help message
+ --verbose Prints a lot of information about what is being done
+ --mode=xxx What tool to emulate:
+ GNUCC - GNU CC
+ MSVC - MS VC cl compiler
+ EDG - EDG front end
+
+ --dest=xxx The destination directory. Will make one if it does not exist
+ --patch=xxx Patch file (can be specified multiple times)
+
+ --ufile=xxx A user-include file to be patched (treated as \#include "xxx")
+ --sfile=xxx A system-include file to be patched (treated as \#include <xxx>)
+
+ --clean Remove all files in the destination directory
+ --skipmissing Skip patches for files whose original cannot be found
+ --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
+ --dumpversion Print the version name used for the current compiler
+
+ All of the other arguments are passed to the preprocessor.
+
+We will use \"$::platform\" as your system type.
+
+Send bugs to necula\@cs.berkeley.edu.
+EOL
+}
+
+
+my %option;
+&Getopt::Long::Configure("pass_through");
+&Getopt::Long::GetOptions
+ (\%option,
+ "--help", # Display help information
+ "--verbose|v", # Display information about programs invoked
+ "--mode=s", # The mode (GNUCC, MSVC)
+ "--dest=s", # The destination directory
+ "--patch=s@", # Patch files
+ "--ufile=s@", # User include files
+ "--sfile=s@", # System include files
+ "--stdoutpp", # pp to stdout
+ "--skipmissing",
+ "--dumpversion",
+ "--clean",
+ );
+
+if($option{help}) {
+ &printHelp();
+ exit 0;
+}
+
+# print Dumper({"option" => \%option, "ARGV" => \@ARGV});
+
+my $cversion; # Compiler version
+my $cname; # Compiler name
+my @patches; # A list of the patches to apply
+
+my $ppargs = join(' ', @ARGV);
+
+my %groups;
+
+&findCompilerVersion();
+
+if($option{dumpversion}) {
+ print $cversion;
+ exit 0;
+}
+
+# Find the destination directory
+if(!defined($option{dest})) {
+ die "Must give a --dest directory\n";
+}
+if(! -d $option{dest}) {
+ die "The destination directory $option{dest} does not exist\n";
+}
+
+if($option{clean}) {
+ # Find the destination directory for a dummy file
+ my $dest = &destinationFileName("");
+ chop $dest; # The final /
+ print "Cleaning all files in $dest\n";
+ (!system("rm -rf $dest")) || die "Cannot remove directory\n";
+ exit 0;
+}
+
+print "Patching files for $cname version $cversion\n";
+
+# Prepare the patches
+if(defined($option{patch})) {
+ my $pFile;
+ foreach $pFile (@{$option{patch}}) {
+ &preparePatchFile($pFile);
+ }
+}
+
+# print Dumper(\@patches);
+
+my $file;
+foreach $file (@{$option{ufile}}) {
+ &patchOneFile($file, 0);
+}
+foreach $file (@{$option{sfile}}) {
+ &patchOneFile($file, 1);
+}
+
+# Now check whether we have used all the patches
+my $hadError = 0;
+foreach my $patch (@patches) {
+ # It was optional
+ if(defined $patch->{FLAGS}->{optional} ||
+ defined $patch->{FLAGS}->{disabled}) { next; }
+ # It was for another system
+ if(defined $patch->{FLAGS}->{system} &&
+ $patch->{FLAGS}->{system} ne $::platform) { next; }
+ # Its group was done
+ if(defined $patch->{FLAGS}->{group}) {
+ if(! defined $groups{$patch->{FLAGS}->{group}}) {
+ $hadError = 1;
+ print "None of the following patches from group $patch->{FLAGS}->{group} was used:\n";
+ foreach my $gp (@patches) {
+ if($gp->{FLAGS}->{group} eq $patch->{FLAGS}->{group}) {
+ print "\tfrom $gp->{PATCHFILE} at $gp->{PATCHLINENO}\n";
+ }
+ }
+ $groups{$patch->{FLAGS}->{group}} = 1; # We're done with it
+ }
+ next;
+ }
+ # It was not in a group and was not optional
+ if(! defined $patch->{USED}) {
+ $hadError = 1;
+ print "Non-optional patch was not used:\n\tfrom $patch->{PATCHFILE} at $patch->{PATCHLINENO}\n";
+ next;
+ }
+}
+exit $hadError;
+
+
+############# SUBROUTINES
+sub findCompilerVersion {
+ $cname = "";
+ $cversion = 0;
+ if($option{mode} eq "GNUCC") {
+ $cname = "GNU CC";
+ open(VER, "$::cc -dumpversion $ppargs|")
+ || die "Cannot start $cname";
+ while(<VER>) {
+ # sm: had to modify this to match "egcs-2.91.66", which is
+ # how egcs responds to the -dumpversion request
+ if($_ =~ m|^(\d+\S+)| ||
+ $_ =~ m|^(egcs-\d+\S+)|) {
+ $cversion = "gcc_$1";
+ close(VER) || die "Cannot start $cname\n";
+ return;
+ }
+ }
+ die "Cannot find the version for GCC\n";
+ }
+ if($option{mode} eq "MSVC") {
+ $cname = "Microsoft cl";
+ $ppargs =~ s|/nologo||g;
+ open(VER, "cl $ppargs 2>&1|") || die "Cannot start $cname: cl $ppargs\n";
+ while(<VER>) {
+ if($_ =~ m|Compiler Version (\S+) |) {
+ $cversion = "cl_$1";
+ close(VER);
+ return;
+ }
+ }
+ die "Cannot find the version for Microsoft CL\n";
+ }
+ die "You must specify a --mode (either GNUCC or MSVC)";
+}
+
+sub lineDirective {
+ my ($fileName, $lineno) = @_;
+ if($::iswin32) {
+ $fileName =~ s|\\|/|g;
+ }
+ if($option{mode} eq "GNUCC" || $option{mode} eq "MSVC") {
+ return "#line $lineno \"$fileName\"\n";
+ }
+ if($option{mode} eq "EDG") {
+ return "# $lineno \"$fileName\"\n";
+ }
+ die "lineDirective: invalid mode";
+}
+
+# Find the absolute name for a file
+sub patchOneFile {
+ my ($fname, $issys) = @_;
+ my $fname1 = $issys ? "<$fname>" : "\"$fname\"";
+ print "Patching $fname1\n";
+ my $preprocfile = "__topreproc";
+ unlink "$preprocfile.i";
+ open(TOPREPROC, ">$preprocfile.c") || die "Cannot open preprocessor file";
+ print TOPREPROC "#include $fname1\n";
+ close(TOPREPROC);
+ # Do not test for error while running the preprocessor because the
+ # error might be due to an #error directive
+ my $preproccmd = "";
+ if($option{mode} eq "GNUCC") {
+ $preproccmd = "$::cc -E $ppargs $preprocfile.c >$preprocfile.i";
+ if ($^O ne 'MSWin32') { # Windows has no /dev/null
+ # ignore stderr (e.g. #error directives)
+ $preproccmd .= " 2>/dev/null";
+ }
+ } elsif($option{mode} eq "MSVC") {
+ if($option{stdoutpp}) {
+ $preproccmd = "cl /nologo /E $ppargs >$preprocfile.i";
+ } else {
+ $preproccmd = "cl /nologo /P $ppargs $preprocfile.c";
+ }
+ } else { die "Invalid --mode"; }
+
+ if(system($preproccmd) && $option{mode} eq "MSVC" ) {
+ # For some reason the gcc returns spurious error codes
+ die "Error running preprocessor: $preproccmd"
+ }
+
+ # Now scan the resulting file and get the real name of the file
+ my $absname = "";
+ open(PPOUT, "<$preprocfile.i") || die "Cannot find $preprocfile.i";
+ while(<PPOUT>) {
+ if($_ =~ m|^\#.+\"(.+$fname)\"|) {
+ $absname = $1;
+ last;
+ }
+ }
+ close(PPOUT);
+ unlink "$preprocfile.c";
+ unlink "$preprocfile.i";
+
+ # Did we find the original file?
+ if($absname eq "") {
+ if($option{skipmissing}) {
+ # Skip this file, mkaing all relevant patches optional
+ print " Original header file not found; skipping...\n";
+ foreach my $patch (@patches) {
+ my $infile = $patch->{FLAGS}->{file};
+ if(defined $infile && $fname =~ m|$infile$|) {
+ $patch->{FLAGS}->{optional} = 1;
+ }
+ }
+ return;
+ } else {
+ die "Cannot find the absolute name of $fname1 in $preprocfile.i\n";
+ }
+ }
+
+ # If we fail then maybe we are using cygwin paths in a Win32 system
+ if($option{mode} eq "GNUCC" && $::iswin32) {
+ open(WINNAME, "cygpath -w $absname|")
+ || die "Cannot run cygpath to convert $absname to a Windows name";
+ $absname = <WINNAME>;
+ if($absname =~ m|\n$|) {
+ chop $absname;
+ }
+ # print "Converted $fileName to $newName\n";
+ close(WINNAME) || die "Cannot run cygpath to convert $absname";
+ }
+ if(! -f $absname) { #matth: we need to do this test after calling cygpath
+ die "Cannot find the absolute name of $fname1 (\"$absname\")\n";
+ }
+ print " Absolute name is $absname\n";
+ # Decide where to put the result
+ my $dest = &destinationFileName($fname);
+ print " Destination is $dest\n";
+ &applyPatches($absname, $dest);
+}
+
+# Is absolute path name?
+sub isAbsolute {
+ my($name) = @_;
+ if($::iswin32) {
+ return ($name =~ m%^([a-zA-Z]:)?[/\\]%);
+ } else {
+ return ($name =~ m%^[/\\]%);
+ }
+}
+
+# Compute the destination file name and create all necessary directories
+sub destinationFileName {
+ my ($fname) = @_;
+ if(&isAbsolute($fname)) {
+ die "Cannot process files that have absolute names\n";
+ }
+ my $dest = $option{dest} . "/" . $cversion;
+ # Break the file name into components
+ my @fnamecomp = split(m%[/\\]%, $fname);
+ # Add one component at a time
+ do {
+ if(! -d $dest) {
+ (mkdir $dest, 0777) || die "Cannot create directory $dest\n";
+ }
+ my $comp = shift @fnamecomp;
+ $dest .= ('/' . $comp);
+ } while($#fnamecomp >= 0);
+ return $dest;
+}
+#####################################################################
+# Patching of files
+#
+sub preparePatchFile {
+ my ($pFile) = @_;
+ open(PFILE, "<$pFile") ||
+ die "Cannot read patch file $pFile\n";
+ my $patchLineNo = 0;
+ my $patchStartLine = 0;
+ NextPattern:
+ while(<PFILE>) {
+ $patchLineNo ++;
+ if($_ !~ m|^<<<(.*)$|) {
+ next;
+ }
+ # Process the flags
+ my @patchflags = split(/\s*,\s*/, $1);
+ my %valueflags;
+ foreach my $flg (@patchflags) {
+ $flg = &trimSpaces($flg);
+ if($flg =~ m|^(.+)\s*=\s*(.+)$|) {
+ $valueflags{$1} = $2;
+ } else {
+ $valueflags{$flg} = 1;
+ }
+ }
+ # Now we have found the start
+ $_ = <PFILE>;
+ $patchLineNo ++;
+ my $current_pattern = [];
+ my @all_patterns = ();
+ if($_ =~ m|^===|) {
+ if(! defined $valueflags{ateof} &&
+ ! defined $valueflags{atsof}) {
+ die "A pattern is missing in $pFile";
+ }
+ goto AfterPattern;
+ }
+ if($_ eq "") {
+ die "A pattern is missing in $pFile";
+ }
+ push @{$current_pattern}, $_;
+
+ while(<PFILE>) {
+ $patchLineNo ++;
+ if($_ =~ m|^===|) {
+ last;
+ }
+ if($_ =~ m%^\|\|\|%) {
+ # This is an alternate pattern
+ push @all_patterns, $current_pattern;
+ $current_pattern = [];
+ next;
+ }
+ push @{$current_pattern}, $_;
+ }
+ AfterPattern:
+ # Finish off the last pattern
+ push @all_patterns, $current_pattern;
+ if($_ !~ m|^===|) {
+ die "No separator found after pattern in $pFile";
+ }
+ $patchStartLine = $patchLineNo + 1;
+ my $replacement = "";
+ # If we have more than one non-optional pattern with no group
+ # specified, then create a group
+ if(@all_patterns > 1 &&
+ ! defined $valueflags{group} &&
+ ! defined $valueflags{optional}) {
+ $valueflags{group} = $pFile . "_$patchStartLine";
+ }
+ while(<PFILE>) {
+ $patchLineNo ++;
+ if($_ =~ m|^>>>|) {
+ # For each alternate pattern
+ my $patt;
+ foreach $patt (@all_patterns) {
+ # Maybe the @__pattern__@ string appears in the replacement
+ my $pattern_repl = join('', @{$patt});
+ my $nrlines = int(@{$patt});
+ my $local_repl = $replacement;
+ $local_repl =~ s/\@__pattern__\@/$pattern_repl/g;
+ # Strip the spaces from patterns
+ my @pattern_no_space = ();
+ my $i;
+ foreach $i (@{$patt}) {
+ $i =~ s/\s+//g;
+ push @pattern_no_space, $i;
+ }
+ push @patches, { HEAD => $pattern_no_space[0],
+ FLAGS => \%valueflags,
+ NRLINES => $nrlines,
+ PATTERNS => \@pattern_no_space,
+ REPLACE => $local_repl,
+ PATCHFILE => $pFile,
+ PATCHLINENO => $patchStartLine,
+ };
+ }
+ next NextPattern;
+ }
+ $replacement .= $_;
+ }
+ die "Unfinished replacement for pattern in $pFile";
+ }
+ close(PFILE) ||
+ die "Cannot close patch file $pFile\n";
+ print "Loaded patches from $pFile\n";
+ # print Dumper(\@patches); die "Here\n";
+
+}
+
+sub trimSpaces {
+ my($str) = @_;
+ if($str =~ m|^\s+(\S.*)$|) {
+ $str = $1;
+ }
+ if($str =~ m|^(.*\S)\s+$|) {
+ $str = $1;
+ }
+ return $str;
+}
+
+
+my @includeReadAhead = ();
+sub readIncludeLine {
+ my($infile) = @_;
+ if($#includeReadAhead < 0) {
+ my $newLine = <$infile>;
+ return $newLine;
+ } else {
+ return shift @includeReadAhead;
+ }
+}
+
+sub undoReadIncludeLine {
+ my($line) = @_;
+ push @includeReadAhead, $line;
+}
+
+sub applyPatches {
+ my($in, $out) = @_;
+ # Initialize all the patches
+ my $patch;
+ # And remember the EOF patches that are applicable here
+ my @eof_patches = ();
+ foreach $patch (@patches) {
+ $patch->{USE} = 1;
+ my $infile = $patch->{FLAGS}->{file};
+ if(defined $infile && $in !~ m|$infile$|) {
+# print "Will not use patch ",
+# &lineDirective($patch->{PATCHFILE},$patch->{PATCHLINENO});
+ $patch->{USE} = 0;
+ next;
+ }
+ # Disable the system specific patterns
+ if(defined $patch->{FLAGS}->{system} &&
+ $patch->{FLAGS}->{system} ne $::platform) {
+ $patch->{USE} = 0;
+ next;
+ }
+ # Disable also (for now) the patches that must be applied at EOF
+ if(defined $patch->{FLAGS}->{ateof} ||
+ defined $patch->{FLAGS}->{atsof} ||
+ defined $patch->{FLAGS}->{disabled} ) {
+ $patch->{USE} = 0;
+ push @eof_patches, $patch;
+ }
+
+ }
+
+ open(OUT, ">$out") || die "Cannot open patch output file $out";
+ open(IN, "<$in") || die "Cannot open patch input file $in";
+
+ @includeReadAhead = ();
+
+ my $lineno = 0;
+ my $line; # The current line
+
+ # the file name that should be printed in the line directives
+ my $lineDirectiveFile = $in;
+ # Now apply the SOF patches
+ foreach my $patch (@eof_patches) {
+ if(defined $patch->{FLAGS}->{atsof}) {
+ my $line = &applyOnePatch($patch, &lineDirective($in, $lineno));
+ print OUT $line;
+ }
+ }
+
+ while($line = &readIncludeLine(\*IN)) {
+ $lineno ++;
+ # Now we have a line to print out. See if it needs patching
+ my $patch;
+ my @lines = ($line); # A number of lines
+ my $nrLines = 1; # How many lines
+ my $toundo = 0;
+ NextPatch:
+ foreach $patch (@patches) {
+ if(! $patch->{USE}) { next; } # We are not using this patch
+ my $line_no_spaces = $line;
+ $line_no_spaces =~ s/\s+//g;
+ if($line_no_spaces eq $patch->{HEAD}) {
+ # Now see if all the lines match
+ my $patNrLines = $patch->{NRLINES};
+ if($patNrLines > 1) {
+ # Make sure we have enough lines
+ while($nrLines < $patNrLines) {
+ push @lines, &readIncludeLine(\*IN);
+ $nrLines ++;
+ $toundo ++;
+ }
+ my @checkLines = @{$patch->{PATTERNS}};
+ my $i;
+ # print "check: ", join(":", @checkLines);
+ # print "with $nrLines lines: ", join("+", @lines);
+ for($i=0;$i<$patNrLines;$i++) {
+ $line_no_spaces = $lines[$i];
+ $line_no_spaces =~ s/\s+//g;
+ if($checkLines[$i] ne $line_no_spaces) {
+ # print "No match for $patch->{HEAD}\n";
+ next NextPatch;
+ }
+ }
+ }
+ # print "Using patch from $patch->{PATCHFILE}:$patch->{PATCHLINENO} at $in:$lineno\n";
+ # Now replace
+ $lineno += ($patNrLines - 1);
+ $toundo -= ($patNrLines - 1);
+ $line = &applyOnePatch($patch, &lineDirective($in, $lineno + 1));
+ last;
+ }
+ }
+ print OUT $line;
+ # Now undo all but the first line
+ my $i;
+ for($i=$nrLines - $toundo;$i<$nrLines;$i++) {
+ &undoReadIncludeLine($lines[$i]);
+ }
+ }
+ close(IN) || die "Cannot close file $in";
+ # Now apply the EOF patches
+ foreach $patch (@eof_patches) {
+ if(defined $patch->{FLAGS}->{ateof}) {
+ my $line = &applyOnePatch($patch, &lineDirective($in, $lineno));
+ print OUT $line;
+ }
+ }
+
+ close(OUT);
+ return 1;
+}
+
+
+sub applyOnePatch {
+ my($patch, $after) = @_;
+ my $line = &lineDirective($patch->{PATCHFILE},
+ $patch->{PATCHLINENO});
+ $line .= $patch->{REPLACE};
+ $line .= $after;
+ # Mark that we have used this group
+ $patch->{USED} = 1;
+ if(defined $patch->{FLAGS}->{group}) {
+ $groups{$patch->{FLAGS}->{group}} = 1;
+ }
+ return $line;
+}
--- /dev/null
+perl @CILHOME@/bin/patcher %*
--- /dev/null
+#!/bin/bash
+# run a command, sending stdout to one file and stderr to another,
+# but also sending both to this process' stdout/stderr, respectively
+
+if [ "$3" = "" ]; then
+ echo "usage: $0 stdout-file stderr-file cmd [args..]"
+ exit 0
+fi
+
+stdoutFile="$1"
+stderrFile="$2"
+command="$3"
+shift
+shift
+shift
+
+result=0
+handler() {
+ # this signal means the underlying command exit erroneously,
+ # though we don't know the code
+ echo "The command failed!"
+ result=2
+}
+trap handler SIGUSR1
+
+# dup my stdout/err on fd 3,4
+exec 3>&1
+exec 4>&2
+
+
+# run the command with tees to duplicate the data
+mypid=$$
+# echo "mypid = $mypid, command=$command, args=$@, stdout=$stdoutFile, stderr=$stderrFile"
+(("$command" "$@" || kill -s USR1 $mypid) | tee "$stdoutFile" >&3) 2>&1 | tee "$stderrFile" >&4
+
+exit $result
--- /dev/null
+#!/bin/sh
+# run a regression test containing one or more intentional failures
+#
+# To create a source file to be processed by this script do the following:
+# - the file should be a standalone program with main without any arguments
+# You can add other files as part of the CFLAGS variable
+# - add a comment
+# // NUMERRORS n
+# where n is the number of errors to be tested by this file
+#
+# This file is processed n+1 times. The first time, it should succeed (main returns or
+# exits with code 0) and the other n times it should fail.
+# For each run the preprocessor variable ERROR is defined to be
+# be k (0 <= k <= n).
+# You can mark certain lines in your program so that they are used ONLY in a certain run: put the
+# following comment after a line to make it appear only in the run with ERROR == 3
+#
+# some_code; // ERROR(3)
+#
+#
+# Furthermore, for each run that is intended to fail you can specify a string that
+# must appear in the output.
+#
+# some_code; // ERROR(3):this string must appear in output
+#
+# Do not put any spaces around the :
+#
+# Simple example:
+#
+# #define E(n) {printf("Error %d\n", n); exit(n); }
+# #define SUCCESS {printf("Success\n"); exit(0); }
+#
+# // NUMERRORS 3
+# int main() {
+#
+# char char x; // ERROR(1):invalid type specifier
+# int y;
+# int z = ++y;
+# // This conditional should be true
+# if(z == y) E(2); // ERROR(2):Error 2
+#
+# #if ERROR == 3
+# z = (++y, y--);
+# if(z == y + 1) E(3); // ERROR(3):Error 3
+# #endif
+#
+# SUCCESS;
+# }
+#
+#
+# set RUNONLY=n to run only the test case n
+#
+
+if [ "$1" = "" ]; then
+ # most parameters are passed by name, instead of as positional
+ # arguments, for better impedance match with Makefile; but it's
+ # good to have at least 1 positional arg so when it's missing I
+ # can easily tell, and print this message
+ echo "usage: CILHOME=... CILLY=... CFLAGS=... $0 source-file.c"
+ echo "You can also set RUNONLY=n to run only the nth iteration"
+ exit 0
+fi
+echo "CILLY=$CILLY"
+echo "CFLAGS=$CFLAGS"
+srcfile="$1"
+# Construct the name of the temporary file to use
+srcfilenoext=`echo $srcfile | sed s/.c\$//`
+tmpname="$srcfilenoext-tmp"
+
+# for GCC, use "# xx foo.c". For MSVC, use "#line xx foo.c"
+if [ "$_MSVC" != "" ]; then
+ LINEOPT="line"
+ OUTFLAG="/Fe"
+ OUTEXT=".exe"
+else
+ LINEOPT=""
+ OUTFLAG="-o "
+ OUTEXT=".exe" # So that I can delete the executables
+fi
+
+# Start it in the right directory
+# cd "$CILLYHOME/test/small2" || exit
+
+# read how many failure cases are in the file; expect line of form
+# "// NUMERRORS n"
+numcases=`grep NUMERRORS "$srcfile" | perl -e '$_ = <>; m|(\d+)|; print $1;'`
+if [ -z "$numcases" ]; then
+ echo "didn't find a string of form NUMERRORS <n> in the file"
+ exit 2
+fi
+echo "there are $numcases failure cases in this file"
+
+
+# iterate through the cases; first case (0) is where no errors are present
+i=0
+if [ "$RUNONLY" != "" ] ;then
+ i=$RUNONLY
+fi
+while [ $i -le $numcases ]; do
+ echo
+ echo
+ echo "********************** Iteration $i"
+ echo
+ echo
+ # generate a temporary file; first hide the ERROR tags which identify
+ # the current test, then remove all remaining ERROR lines
+ # (syntax for errors has parentheses so if I have >=10 cases I don't
+ # run into problems where e.g. ERROR1 is a substring of ERROR10)
+ # use the little perl script to put line number directives where we remove
+ # lines
+ echo "generating test $i"
+ rm -f $tmpname.c 2>/dev/null
+ ( echo "#define ERROR $i"; echo "#$LINEOPT 1 \"$srcfile\"";cat "$srcfile") |\
+ sed "s|ERROR($i)|(selected: $i)|" | \
+ perl -e 'my $ln = 0; while(<>) { if($_ =~ m|ERROR\(|) { print "#'$LINEOPT' $ln\n"; } else { print $_; }; $ln ++}' \
+ > "$tmpname.c"
+ chmod a-w "$tmpname.c"
+
+ # Grab the errorline for this test case
+ themsg=`cat "$srcfile" | grep "ERROR($i).*:" | sed "s/^.*ERROR.*://" `
+ if [ "x$themsg" != "x" ] ;then
+ echo "Expecting error message:$themsg"
+ fi
+
+ # compile this with our tool
+ rm -f test-bad.out test-bad.err ${tmpname}$OUTEXT
+ echo $CILLY $CFLAGS $tmpname.c ${OUTFLAG}${tmpname}$OUTEXT
+ $CILHOME/bin/teetwo test-bad.out test-bad.err \
+ $CILLY $CFLAGS -DERROR=$i $tmpname.c ${OUTFLAG}${tmpname}$OUTEXT
+ # cat test-bad.out test-bad.err
+ status=$?
+ runit=1
+ if [ $status != 0 ]; then
+ if [ $i = 0 ] ;then
+ echo "The 0th iteration failed to CURE! It is supposed to succeed."
+ exit $status
+ else
+ if [ "x$themsg" != "x" ] ;then
+ echo "grep \"$themsg\" test-bad.out test-bad.err"
+ if ! grep "$themsg" test-bad.out test-bad.err ;then
+ echo "The ${i}th iteration failed to CURE but cannot find: $themsg"
+ exit 3
+ else
+ echo "The ${i}th iteration failed to CURE, as expected!"
+ fi
+ else
+ echo "The ${i}th iteration failed to CURE. We expected some failure!"
+ fi
+ runit=0
+ fi
+ fi
+
+ # run it
+ if [ $runit != 0 ]; then
+ echo "./$tmpname$OUTEXT"
+ rm -f test-bad.out test-bad.err
+ if $CILHOME/bin/teetwo test-bad.out test-bad.err ./$tmpname$OUTEXT ; then
+ # cat test-bad.out test-bad.err
+ if [ $i = 0 ]; then
+ # expected success on 0th iteration
+ echo "(succeeded as expected)"
+ else
+ # unexpected success on >0th iteration
+ echo "The ${i}th iteration did not fail! It is supposed to fail."
+ exit 2
+ fi
+ else
+ # cat test-bad.out test-bad.err
+ if [ $i = 0 ]; then
+ # unexpected failure on 0th iteration
+ echo "The 0th iteration failed! It is supposed to succeed."
+ #cat $tmpname.c
+ exit 2
+ else
+ # expected failure on >0th iteration
+ if [ "x$themsg" != "x" ] ;then
+ echo "grep \"$themsg\" test-bad.out test-bad.err"
+ if ! grep "$themsg" test-bad.out test-bad.err ;then
+ echo "The ${i}th iteration failed but cannot find:$themsg"
+ exit 3
+ fi
+ fi
+ echo "(failed as expected)"
+ fi
+ fi
+ fi
+
+ # possibly bail after 0th
+ if [ "$TESTBADONCE" != "" ]; then
+ echo "bailing after 0th iteration because TESTBADONCE is set"
+ exit 0
+ fi
+ if [ "$RUNONLY" != "" ]; then
+ echo "bailing after ${RUNONLY}th iteration because RUNONLY is set"
+ exit 0
+ fi
+
+ i=`expr $i + 1`
+done
+
+echo "all $numcases cases in $srcfile failed as expected"
+
--- /dev/null
+doc/cil.otarget
+src/cil.otarget
--- /dev/null
+Name: cil
+Version: @CIL_VERSION@
+Release: 1
+License: BSD
+URL: http://hal.cs.berkeley.edu/cil/
+Source0: %{name}-%{version}.tar.gz
+BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-buildroot
+BuildRequires: gcc
+BuildRequires: hevea
+BuildRequires: ocaml >= 3.08
+BuildRequires: perl >= 5.6.1
+
+# No ELF executables or shared libraries
+%define debug_package %{nil}
+
+
+########################################################################
+#
+# Package cil
+#
+
+Summary: OCaml library for C program analysis and transformation
+Group: Development/Libraries
+Requires: perl >= 5.6.1
+
+%description
+CIL (C Intermediate Language) is a high-level representation along
+with a set of tools that permit easy analysis and source-to-source
+transformation of C programs.
+
+This package provides Perl modules which are useful for building
+compiler wrappers. A wrapper can use CIL to transform C code before
+passing it along to the native C compiler.
+
+%files
+%defattr(-,root,root,-)
+%doc LICENSE
+%{_datadir}/%{name}
+
+
+########################################################################
+#
+# Package cil-devel
+#
+
+%package devel
+
+Summary: OCaml library for C program analysis and transformation
+Group: Development/Libraries
+Requires: ocaml >= 3.04
+
+%description devel
+CIL (C Intermediate Language) is a high-level representation along
+with a set of tools that permit easy analysis and source-to-source
+transformation of C programs.
+
+This package provides OCaml interfaces and an OCaml library which form
+the CIL API.
+
+%files devel
+%defattr(-,root,root,-)
+%doc LICENSE
+%{_libdir}/%{name}
+
+
+########################################################################
+#
+# General scripts
+#
+
+%prep
+%setup -q -n %{name}
+
+%build
+%configure
+make cilversion machdep
+make cillib NATIVECAML=
+make cillib NATIVECAML=1
+
+%install
+rm -rf $RPM_BUILD_ROOT
+make DESTDIR=%buildroot install
+
+%clean
+rm -rf $RPM_BUILD_ROOT
+
+
+%changelog
+* Tue Aug 5 2003 Ben Liblit <liblit@cs.berkeley.edu>
+- Initial build.
--- /dev/null
+#! /bin/sh
+# Attempt to guess a canonical system name.
+# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+# 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
+# Inc.
+
+timestamp='2006-05-13'
+
+# This file is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA
+# 02110-1301, USA.
+#
+# As a special exception to the GNU General Public License, if you
+# distribute this file as part of a program that contains a
+# configuration script generated by Autoconf, you may include it under
+# the same distribution terms that you use for the rest of that program.
+
+
+# Originally written by Per Bothner <per@bothner.com>.
+# Please send patches to <config-patches@gnu.org>. Submit a context
+# diff and a properly formatted ChangeLog entry.
+#
+# This script attempts to guess a canonical system name similar to
+# config.sub. If it succeeds, it prints the system name on stdout, and
+# exits with 0. Otherwise, it exits with 1.
+#
+# The plan is that this can be called by configure scripts if you
+# don't specify an explicit build system type.
+
+me=`echo "$0" | sed -e 's,.*/,,'`
+
+usage="\
+Usage: $0 [OPTION]
+
+Output the configuration name of the system \`$me' is run on.
+
+Operation modes:
+ -h, --help print this help, then exit
+ -t, --time-stamp print date of last modification, then exit
+ -v, --version print version number, then exit
+
+Report bugs and patches to <config-patches@gnu.org>."
+
+version="\
+GNU config.guess ($timestamp)
+
+Originally written by Per Bothner.
+Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005
+Free Software Foundation, Inc.
+
+This is free software; see the source for copying conditions. There is NO
+warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
+
+help="
+Try \`$me --help' for more information."
+
+# Parse command line
+while test $# -gt 0 ; do
+ case $1 in
+ --time-stamp | --time* | -t )
+ echo "$timestamp" ; exit ;;
+ --version | -v )
+ echo "$version" ; exit ;;
+ --help | --h* | -h )
+ echo "$usage"; exit ;;
+ -- ) # Stop option processing
+ shift; break ;;
+ - ) # Use stdin as input.
+ break ;;
+ -* )
+ echo "$me: invalid option $1$help" >&2
+ exit 1 ;;
+ * )
+ break ;;
+ esac
+done
+
+if test $# != 0; then
+ echo "$me: too many arguments$help" >&2
+ exit 1
+fi
+
+trap 'exit 1' 1 2 15
+
+# CC_FOR_BUILD -- compiler used by this script. Note that the use of a
+# compiler to aid in system detection is discouraged as it requires
+# temporary files to be created and, as you can see below, it is a
+# headache to deal with in a portable fashion.
+
+# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still
+# use `HOST_CC' if defined, but it is deprecated.
+
+# Portable tmp directory creation inspired by the Autoconf team.
+
+set_cc_for_build='
+trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ;
+trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ;
+: ${TMPDIR=/tmp} ;
+ { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } ||
+ { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } ||
+ { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } ||
+ { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ;
+dummy=$tmp/dummy ;
+tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ;
+case $CC_FOR_BUILD,$HOST_CC,$CC in
+ ,,) echo "int x;" > $dummy.c ;
+ for c in cc gcc c89 c99 ; do
+ if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then
+ CC_FOR_BUILD="$c"; break ;
+ fi ;
+ done ;
+ if test x"$CC_FOR_BUILD" = x ; then
+ CC_FOR_BUILD=no_compiler_found ;
+ fi
+ ;;
+ ,,*) CC_FOR_BUILD=$CC ;;
+ ,*,*) CC_FOR_BUILD=$HOST_CC ;;
+esac ; set_cc_for_build= ;'
+
+# This is needed to find uname on a Pyramid OSx when run in the BSD universe.
+# (ghazi@noc.rutgers.edu 1994-08-24)
+if (test -f /.attbin/uname) >/dev/null 2>&1 ; then
+ PATH=$PATH:/.attbin ; export PATH
+fi
+
+UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown
+UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown
+UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown
+UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown
+
+# Note: order is significant - the case branches are not exclusive.
+
+case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
+ *:NetBSD:*:*)
+ # NetBSD (nbsd) targets should (where applicable) match one or
+ # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*,
+ # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently
+ # switched to ELF, *-*-netbsd* would select the old
+ # object file format. This provides both forward
+ # compatibility and a consistent mechanism for selecting the
+ # object file format.
+ #
+ # Note: NetBSD doesn't particularly care about the vendor
+ # portion of the name. We always set it to "unknown".
+ sysctl="sysctl -n hw.machine_arch"
+ UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \
+ /usr/sbin/$sysctl 2>/dev/null || echo unknown)`
+ case "${UNAME_MACHINE_ARCH}" in
+ armeb) machine=armeb-unknown ;;
+ arm*) machine=arm-unknown ;;
+ sh3el) machine=shl-unknown ;;
+ sh3eb) machine=sh-unknown ;;
+ *) machine=${UNAME_MACHINE_ARCH}-unknown ;;
+ esac
+ # The Operating System including object format, if it has switched
+ # to ELF recently, or will in the future.
+ case "${UNAME_MACHINE_ARCH}" in
+ arm*|i386|m68k|ns32k|sh3*|sparc|vax)
+ eval $set_cc_for_build
+ if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \
+ | grep __ELF__ >/dev/null
+ then
+ # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout).
+ # Return netbsd for either. FIX?
+ os=netbsd
+ else
+ os=netbsdelf
+ fi
+ ;;
+ *)
+ os=netbsd
+ ;;
+ esac
+ # The OS release
+ # Debian GNU/NetBSD machines have a different userland, and
+ # thus, need a distinct triplet. However, they do not need
+ # kernel version information, so it can be replaced with a
+ # suitable tag, in the style of linux-gnu.
+ case "${UNAME_VERSION}" in
+ Debian*)
+ release='-gnu'
+ ;;
+ *)
+ release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'`
+ ;;
+ esac
+ # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM:
+ # contains redundant information, the shorter form:
+ # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used.
+ echo "${machine}-${os}${release}"
+ exit ;;
+ *:OpenBSD:*:*)
+ UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'`
+ echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE}
+ exit ;;
+ *:ekkoBSD:*:*)
+ echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE}
+ exit ;;
+ *:SolidBSD:*:*)
+ echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE}
+ exit ;;
+ macppc:MirBSD:*:*)
+ echo powerppc-unknown-mirbsd${UNAME_RELEASE}
+ exit ;;
+ *:MirBSD:*:*)
+ echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE}
+ exit ;;
+ alpha:OSF1:*:*)
+ case $UNAME_RELEASE in
+ *4.0)
+ UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'`
+ ;;
+ *5.*)
+ UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'`
+ ;;
+ esac
+ # According to Compaq, /usr/sbin/psrinfo has been available on
+ # OSF/1 and Tru64 systems produced since 1995. I hope that
+ # covers most systems running today. This code pipes the CPU
+ # types through head -n 1, so we only detect the type of CPU 0.
+ ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1`
+ case "$ALPHA_CPU_TYPE" in
+ "EV4 (21064)")
+ UNAME_MACHINE="alpha" ;;
+ "EV4.5 (21064)")
+ UNAME_MACHINE="alpha" ;;
+ "LCA4 (21066/21068)")
+ UNAME_MACHINE="alpha" ;;
+ "EV5 (21164)")
+ UNAME_MACHINE="alphaev5" ;;
+ "EV5.6 (21164A)")
+ UNAME_MACHINE="alphaev56" ;;
+ "EV5.6 (21164PC)")
+ UNAME_MACHINE="alphapca56" ;;
+ "EV5.7 (21164PC)")
+ UNAME_MACHINE="alphapca57" ;;
+ "EV6 (21264)")
+ UNAME_MACHINE="alphaev6" ;;
+ "EV6.7 (21264A)")
+ UNAME_MACHINE="alphaev67" ;;
+ "EV6.8CB (21264C)")
+ UNAME_MACHINE="alphaev68" ;;
+ "EV6.8AL (21264B)")
+ UNAME_MACHINE="alphaev68" ;;
+ "EV6.8CX (21264D)")
+ UNAME_MACHINE="alphaev68" ;;
+ "EV6.9A (21264/EV69A)")
+ UNAME_MACHINE="alphaev69" ;;
+ "EV7 (21364)")
+ UNAME_MACHINE="alphaev7" ;;
+ "EV7.9 (21364A)")
+ UNAME_MACHINE="alphaev79" ;;
+ esac
+ # A Pn.n version is a patched version.
+ # A Vn.n version is a released version.
+ # A Tn.n version is a released field test version.
+ # A Xn.n version is an unreleased experimental baselevel.
+ # 1.2 uses "1.2" for uname -r.
+ echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'`
+ exit ;;
+ Alpha\ *:Windows_NT*:*)
+ # How do we know it's Interix rather than the generic POSIX subsystem?
+ # Should we change UNAME_MACHINE based on the output of uname instead
+ # of the specific Alpha model?
+ echo alpha-pc-interix
+ exit ;;
+ 21064:Windows_NT:50:3)
+ echo alpha-dec-winnt3.5
+ exit ;;
+ Amiga*:UNIX_System_V:4.0:*)
+ echo m68k-unknown-sysv4
+ exit ;;
+ *:[Aa]miga[Oo][Ss]:*:*)
+ echo ${UNAME_MACHINE}-unknown-amigaos
+ exit ;;
+ *:[Mm]orph[Oo][Ss]:*:*)
+ echo ${UNAME_MACHINE}-unknown-morphos
+ exit ;;
+ *:OS/390:*:*)
+ echo i370-ibm-openedition
+ exit ;;
+ *:z/VM:*:*)
+ echo s390-ibm-zvmoe
+ exit ;;
+ *:OS400:*:*)
+ echo powerpc-ibm-os400
+ exit ;;
+ arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*)
+ echo arm-acorn-riscix${UNAME_RELEASE}
+ exit ;;
+ arm:riscos:*:*|arm:RISCOS:*:*)
+ echo arm-unknown-riscos
+ exit ;;
+ SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*)
+ echo hppa1.1-hitachi-hiuxmpp
+ exit ;;
+ Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*)
+ # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE.
+ if test "`(/bin/universe) 2>/dev/null`" = att ; then
+ echo pyramid-pyramid-sysv3
+ else
+ echo pyramid-pyramid-bsd
+ fi
+ exit ;;
+ NILE*:*:*:dcosx)
+ echo pyramid-pyramid-svr4
+ exit ;;
+ DRS?6000:unix:4.0:6*)
+ echo sparc-icl-nx6
+ exit ;;
+ DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*)
+ case `/usr/bin/uname -p` in
+ sparc) echo sparc-icl-nx7; exit ;;
+ esac ;;
+ sun4H:SunOS:5.*:*)
+ echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ exit ;;
+ sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*)
+ echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ exit ;;
+ i86pc:SunOS:5.*:*)
+ echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ exit ;;
+ sun4*:SunOS:6*:*)
+ # According to config.sub, this is the proper way to canonicalize
+ # SunOS6. Hard to guess exactly what SunOS6 will be like, but
+ # it's likely to be more like Solaris than SunOS4.
+ echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ exit ;;
+ sun4*:SunOS:*:*)
+ case "`/usr/bin/arch -k`" in
+ Series*|S4*)
+ UNAME_RELEASE=`uname -v`
+ ;;
+ esac
+ # Japanese Language versions have a version number like `4.1.3-JL'.
+ echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'`
+ exit ;;
+ sun3*:SunOS:*:*)
+ echo m68k-sun-sunos${UNAME_RELEASE}
+ exit ;;
+ sun*:*:4.2BSD:*)
+ UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null`
+ test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3
+ case "`/bin/arch`" in
+ sun3)
+ echo m68k-sun-sunos${UNAME_RELEASE}
+ ;;
+ sun4)
+ echo sparc-sun-sunos${UNAME_RELEASE}
+ ;;
+ esac
+ exit ;;
+ aushp:SunOS:*:*)
+ echo sparc-auspex-sunos${UNAME_RELEASE}
+ exit ;;
+ # The situation for MiNT is a little confusing. The machine name
+ # can be virtually everything (everything which is not
+ # "atarist" or "atariste" at least should have a processor
+ # > m68000). The system name ranges from "MiNT" over "FreeMiNT"
+ # to the lowercase version "mint" (or "freemint"). Finally
+ # the system name "TOS" denotes a system which is actually not
+ # MiNT. But MiNT is downward compatible to TOS, so this should
+ # be no problem.
+ atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*)
+ echo m68k-atari-mint${UNAME_RELEASE}
+ exit ;;
+ atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*)
+ echo m68k-atari-mint${UNAME_RELEASE}
+ exit ;;
+ *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*)
+ echo m68k-atari-mint${UNAME_RELEASE}
+ exit ;;
+ milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*)
+ echo m68k-milan-mint${UNAME_RELEASE}
+ exit ;;
+ hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*)
+ echo m68k-hades-mint${UNAME_RELEASE}
+ exit ;;
+ *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*)
+ echo m68k-unknown-mint${UNAME_RELEASE}
+ exit ;;
+ m68k:machten:*:*)
+ echo m68k-apple-machten${UNAME_RELEASE}
+ exit ;;
+ powerpc:machten:*:*)
+ echo powerpc-apple-machten${UNAME_RELEASE}
+ exit ;;
+ RISC*:Mach:*:*)
+ echo mips-dec-mach_bsd4.3
+ exit ;;
+ RISC*:ULTRIX:*:*)
+ echo mips-dec-ultrix${UNAME_RELEASE}
+ exit ;;
+ VAX*:ULTRIX*:*:*)
+ echo vax-dec-ultrix${UNAME_RELEASE}
+ exit ;;
+ 2020:CLIX:*:* | 2430:CLIX:*:*)
+ echo clipper-intergraph-clix${UNAME_RELEASE}
+ exit ;;
+ mips:*:*:UMIPS | mips:*:*:RISCos)
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+#ifdef __cplusplus
+#include <stdio.h> /* for printf() prototype */
+ int main (int argc, char *argv[]) {
+#else
+ int main (argc, argv) int argc; char *argv[]; {
+#endif
+ #if defined (host_mips) && defined (MIPSEB)
+ #if defined (SYSTYPE_SYSV)
+ printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0);
+ #endif
+ #if defined (SYSTYPE_SVR4)
+ printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0);
+ #endif
+ #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD)
+ printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0);
+ #endif
+ #endif
+ exit (-1);
+ }
+EOF
+ $CC_FOR_BUILD -o $dummy $dummy.c &&
+ dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` &&
+ SYSTEM_NAME=`$dummy $dummyarg` &&
+ { echo "$SYSTEM_NAME"; exit; }
+ echo mips-mips-riscos${UNAME_RELEASE}
+ exit ;;
+ Motorola:PowerMAX_OS:*:*)
+ echo powerpc-motorola-powermax
+ exit ;;
+ Motorola:*:4.3:PL8-*)
+ echo powerpc-harris-powermax
+ exit ;;
+ Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*)
+ echo powerpc-harris-powermax
+ exit ;;
+ Night_Hawk:Power_UNIX:*:*)
+ echo powerpc-harris-powerunix
+ exit ;;
+ m88k:CX/UX:7*:*)
+ echo m88k-harris-cxux7
+ exit ;;
+ m88k:*:4*:R4*)
+ echo m88k-motorola-sysv4
+ exit ;;
+ m88k:*:3*:R3*)
+ echo m88k-motorola-sysv3
+ exit ;;
+ AViiON:dgux:*:*)
+ # DG/UX returns AViiON for all architectures
+ UNAME_PROCESSOR=`/usr/bin/uname -p`
+ if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ]
+ then
+ if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \
+ [ ${TARGET_BINARY_INTERFACE}x = x ]
+ then
+ echo m88k-dg-dgux${UNAME_RELEASE}
+ else
+ echo m88k-dg-dguxbcs${UNAME_RELEASE}
+ fi
+ else
+ echo i586-dg-dgux${UNAME_RELEASE}
+ fi
+ exit ;;
+ M88*:DolphinOS:*:*) # DolphinOS (SVR3)
+ echo m88k-dolphin-sysv3
+ exit ;;
+ M88*:*:R3*:*)
+ # Delta 88k system running SVR3
+ echo m88k-motorola-sysv3
+ exit ;;
+ XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3)
+ echo m88k-tektronix-sysv3
+ exit ;;
+ Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD)
+ echo m68k-tektronix-bsd
+ exit ;;
+ *:IRIX*:*:*)
+ echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'`
+ exit ;;
+ ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX.
+ echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id
+ exit ;; # Note that: echo "'`uname -s`'" gives 'AIX '
+ i*86:AIX:*:*)
+ echo i386-ibm-aix
+ exit ;;
+ ia64:AIX:*:*)
+ if [ -x /usr/bin/oslevel ] ; then
+ IBM_REV=`/usr/bin/oslevel`
+ else
+ IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE}
+ fi
+ echo ${UNAME_MACHINE}-ibm-aix${IBM_REV}
+ exit ;;
+ *:AIX:2:3)
+ if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+ #include <sys/systemcfg.h>
+
+ main()
+ {
+ if (!__power_pc())
+ exit(1);
+ puts("powerpc-ibm-aix3.2.5");
+ exit(0);
+ }
+EOF
+ if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy`
+ then
+ echo "$SYSTEM_NAME"
+ else
+ echo rs6000-ibm-aix3.2.5
+ fi
+ elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then
+ echo rs6000-ibm-aix3.2.4
+ else
+ echo rs6000-ibm-aix3.2
+ fi
+ exit ;;
+ *:AIX:*:[45])
+ IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'`
+ if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then
+ IBM_ARCH=rs6000
+ else
+ IBM_ARCH=powerpc
+ fi
+ if [ -x /usr/bin/oslevel ] ; then
+ IBM_REV=`/usr/bin/oslevel`
+ else
+ IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE}
+ fi
+ echo ${IBM_ARCH}-ibm-aix${IBM_REV}
+ exit ;;
+ *:AIX:*:*)
+ echo rs6000-ibm-aix
+ exit ;;
+ ibmrt:4.4BSD:*|romp-ibm:BSD:*)
+ echo romp-ibm-bsd4.4
+ exit ;;
+ ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and
+ echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to
+ exit ;; # report: romp-ibm BSD 4.3
+ *:BOSX:*:*)
+ echo rs6000-bull-bosx
+ exit ;;
+ DPX/2?00:B.O.S.:*:*)
+ echo m68k-bull-sysv3
+ exit ;;
+ 9000/[34]??:4.3bsd:1.*:*)
+ echo m68k-hp-bsd
+ exit ;;
+ hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*)
+ echo m68k-hp-bsd4.4
+ exit ;;
+ 9000/[34678]??:HP-UX:*:*)
+ HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`
+ case "${UNAME_MACHINE}" in
+ 9000/31? ) HP_ARCH=m68000 ;;
+ 9000/[34]?? ) HP_ARCH=m68k ;;
+ 9000/[678][0-9][0-9])
+ if [ -x /usr/bin/getconf ]; then
+ sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null`
+ sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null`
+ case "${sc_cpu_version}" in
+ 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0
+ 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1
+ 532) # CPU_PA_RISC2_0
+ case "${sc_kernel_bits}" in
+ 32) HP_ARCH="hppa2.0n" ;;
+ 64) HP_ARCH="hppa2.0w" ;;
+ '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20
+ esac ;;
+ esac
+ fi
+ if [ "${HP_ARCH}" = "" ]; then
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+
+ #define _HPUX_SOURCE
+ #include <stdlib.h>
+ #include <unistd.h>
+
+ int main ()
+ {
+ #if defined(_SC_KERNEL_BITS)
+ long bits = sysconf(_SC_KERNEL_BITS);
+ #endif
+ long cpu = sysconf (_SC_CPU_VERSION);
+
+ switch (cpu)
+ {
+ case CPU_PA_RISC1_0: puts ("hppa1.0"); break;
+ case CPU_PA_RISC1_1: puts ("hppa1.1"); break;
+ case CPU_PA_RISC2_0:
+ #if defined(_SC_KERNEL_BITS)
+ switch (bits)
+ {
+ case 64: puts ("hppa2.0w"); break;
+ case 32: puts ("hppa2.0n"); break;
+ default: puts ("hppa2.0"); break;
+ } break;
+ #else /* !defined(_SC_KERNEL_BITS) */
+ puts ("hppa2.0"); break;
+ #endif
+ default: puts ("hppa1.0"); break;
+ }
+ exit (0);
+ }
+EOF
+ (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy`
+ test -z "$HP_ARCH" && HP_ARCH=hppa
+ fi ;;
+ esac
+ if [ ${HP_ARCH} = "hppa2.0w" ]
+ then
+ eval $set_cc_for_build
+
+ # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating
+ # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler
+ # generating 64-bit code. GNU and HP use different nomenclature:
+ #
+ # $ CC_FOR_BUILD=cc ./config.guess
+ # => hppa2.0w-hp-hpux11.23
+ # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess
+ # => hppa64-hp-hpux11.23
+
+ if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) |
+ grep __LP64__ >/dev/null
+ then
+ HP_ARCH="hppa2.0w"
+ else
+ HP_ARCH="hppa64"
+ fi
+ fi
+ echo ${HP_ARCH}-hp-hpux${HPUX_REV}
+ exit ;;
+ ia64:HP-UX:*:*)
+ HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`
+ echo ia64-hp-hpux${HPUX_REV}
+ exit ;;
+ 3050*:HI-UX:*:*)
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+ #include <unistd.h>
+ int
+ main ()
+ {
+ long cpu = sysconf (_SC_CPU_VERSION);
+ /* The order matters, because CPU_IS_HP_MC68K erroneously returns
+ true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct
+ results, however. */
+ if (CPU_IS_PA_RISC (cpu))
+ {
+ switch (cpu)
+ {
+ case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break;
+ case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break;
+ case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break;
+ default: puts ("hppa-hitachi-hiuxwe2"); break;
+ }
+ }
+ else if (CPU_IS_HP_MC68K (cpu))
+ puts ("m68k-hitachi-hiuxwe2");
+ else puts ("unknown-hitachi-hiuxwe2");
+ exit (0);
+ }
+EOF
+ $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` &&
+ { echo "$SYSTEM_NAME"; exit; }
+ echo unknown-hitachi-hiuxwe2
+ exit ;;
+ 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* )
+ echo hppa1.1-hp-bsd
+ exit ;;
+ 9000/8??:4.3bsd:*:*)
+ echo hppa1.0-hp-bsd
+ exit ;;
+ *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*)
+ echo hppa1.0-hp-mpeix
+ exit ;;
+ hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* )
+ echo hppa1.1-hp-osf
+ exit ;;
+ hp8??:OSF1:*:*)
+ echo hppa1.0-hp-osf
+ exit ;;
+ i*86:OSF1:*:*)
+ if [ -x /usr/sbin/sysversion ] ; then
+ echo ${UNAME_MACHINE}-unknown-osf1mk
+ else
+ echo ${UNAME_MACHINE}-unknown-osf1
+ fi
+ exit ;;
+ parisc*:Lites*:*:*)
+ echo hppa1.1-hp-lites
+ exit ;;
+ C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*)
+ echo c1-convex-bsd
+ exit ;;
+ C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*)
+ if getsysinfo -f scalar_acc
+ then echo c32-convex-bsd
+ else echo c2-convex-bsd
+ fi
+ exit ;;
+ C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*)
+ echo c34-convex-bsd
+ exit ;;
+ C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*)
+ echo c38-convex-bsd
+ exit ;;
+ C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*)
+ echo c4-convex-bsd
+ exit ;;
+ CRAY*Y-MP:*:*:*)
+ echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+ exit ;;
+ CRAY*[A-Z]90:*:*:*)
+ echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \
+ | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \
+ -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \
+ -e 's/\.[^.]*$/.X/'
+ exit ;;
+ CRAY*TS:*:*:*)
+ echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+ exit ;;
+ CRAY*T3E:*:*:*)
+ echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+ exit ;;
+ CRAY*SV1:*:*:*)
+ echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+ exit ;;
+ *:UNICOS/mp:*:*)
+ echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+ exit ;;
+ F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*)
+ FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'`
+ FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'`
+ FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'`
+ echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
+ exit ;;
+ 5000:UNIX_System_V:4.*:*)
+ FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'`
+ FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'`
+ echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
+ exit ;;
+ i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*)
+ echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE}
+ exit ;;
+ sparc*:BSD/OS:*:*)
+ echo sparc-unknown-bsdi${UNAME_RELEASE}
+ exit ;;
+ *:BSD/OS:*:*)
+ echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE}
+ exit ;;
+ *:FreeBSD:*:*)
+ case ${UNAME_MACHINE} in
+ pc98)
+ echo i386-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;
+# amd64)
+# echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;
+ *)
+ echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;
+ esac
+ exit ;;
+ i*:CYGWIN*:*)
+ echo ${UNAME_MACHINE}-pc-cygwin
+ exit ;;
+ i*:MINGW*:*)
+ echo ${UNAME_MACHINE}-pc-mingw32
+ exit ;;
+ i*:windows32*:*)
+ # uname -m includes "-pc" on this system.
+ echo ${UNAME_MACHINE}-mingw32
+ exit ;;
+ i*:PW*:*)
+ echo ${UNAME_MACHINE}-pc-pw32
+ exit ;;
+ x86:Interix*:[345]*)
+ echo i586-pc-interix${UNAME_RELEASE}
+ exit ;;
+ EM64T:Interix*:[345]*)
+ echo x86_64-unknown-interix${UNAME_RELEASE}
+ exit ;;
+ [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*)
+ echo i${UNAME_MACHINE}-pc-mks
+ exit ;;
+ i*:Windows_NT*:* | Pentium*:Windows_NT*:*)
+ # How do we know it's Interix rather than the generic POSIX subsystem?
+ # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we
+ # UNAME_MACHINE based on the output of uname instead of i386?
+ echo i586-pc-interix
+ exit ;;
+ i*:UWIN*:*)
+ echo ${UNAME_MACHINE}-pc-uwin
+ exit ;;
+ amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*)
+ echo x86_64-unknown-cygwin
+ exit ;;
+ p*:CYGWIN*:*)
+ echo powerpcle-unknown-cygwin
+ exit ;;
+ prep*:SunOS:5.*:*)
+ echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ exit ;;
+ *:GNU:*:*)
+ # the GNU system
+ echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'`
+ exit ;;
+ *:GNU/*:*:*)
+ # other systems with GNU libc and userland
+ echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu
+ exit ;;
+ i*86:Minix:*:*)
+ echo ${UNAME_MACHINE}-pc-minix
+ exit ;;
+ arm*:Linux:*:*)
+ echo ${UNAME_MACHINE}-unknown-linux-gnu
+ exit ;;
+ cris:Linux:*:*)
+ echo cris-axis-linux-gnu
+ exit ;;
+ crisv32:Linux:*:*)
+ echo crisv32-axis-linux-gnu
+ exit ;;
+ frv:Linux:*:*)
+ echo frv-unknown-linux-gnu
+ exit ;;
+ ia64:Linux:*:*)
+ echo ${UNAME_MACHINE}-unknown-linux-gnu
+ exit ;;
+ m32r*:Linux:*:*)
+ echo ${UNAME_MACHINE}-unknown-linux-gnu
+ exit ;;
+ m68*:Linux:*:*)
+ echo ${UNAME_MACHINE}-unknown-linux-gnu
+ exit ;;
+ mips:Linux:*:*)
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+ #undef CPU
+ #undef mips
+ #undef mipsel
+ #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL)
+ CPU=mipsel
+ #else
+ #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB)
+ CPU=mips
+ #else
+ CPU=
+ #endif
+ #endif
+EOF
+ eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n '
+ /^CPU/{
+ s: ::g
+ p
+ }'`"
+ test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; }
+ ;;
+ mips64:Linux:*:*)
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+ #undef CPU
+ #undef mips64
+ #undef mips64el
+ #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL)
+ CPU=mips64el
+ #else
+ #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB)
+ CPU=mips64
+ #else
+ CPU=
+ #endif
+ #endif
+EOF
+ eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n '
+ /^CPU/{
+ s: ::g
+ p
+ }'`"
+ test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; }
+ ;;
+ or32:Linux:*:*)
+ echo or32-unknown-linux-gnu
+ exit ;;
+ ppc:Linux:*:*)
+ echo powerpc-unknown-linux-gnu
+ exit ;;
+ ppc64:Linux:*:*)
+ echo powerpc64-unknown-linux-gnu
+ exit ;;
+ alpha:Linux:*:*)
+ case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in
+ EV5) UNAME_MACHINE=alphaev5 ;;
+ EV56) UNAME_MACHINE=alphaev56 ;;
+ PCA56) UNAME_MACHINE=alphapca56 ;;
+ PCA57) UNAME_MACHINE=alphapca56 ;;
+ EV6) UNAME_MACHINE=alphaev6 ;;
+ EV67) UNAME_MACHINE=alphaev67 ;;
+ EV68*) UNAME_MACHINE=alphaev68 ;;
+ esac
+ objdump --private-headers /bin/sh | grep ld.so.1 >/dev/null
+ if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi
+ echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC}
+ exit ;;
+ parisc:Linux:*:* | hppa:Linux:*:*)
+ # Look for CPU level
+ case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in
+ PA7*) echo hppa1.1-unknown-linux-gnu ;;
+ PA8*) echo hppa2.0-unknown-linux-gnu ;;
+ *) echo hppa-unknown-linux-gnu ;;
+ esac
+ exit ;;
+ parisc64:Linux:*:* | hppa64:Linux:*:*)
+ echo hppa64-unknown-linux-gnu
+ exit ;;
+ s390:Linux:*:* | s390x:Linux:*:*)
+ echo ${UNAME_MACHINE}-ibm-linux
+ exit ;;
+ sh64*:Linux:*:*)
+ echo ${UNAME_MACHINE}-unknown-linux-gnu
+ exit ;;
+ sh*:Linux:*:*)
+ echo ${UNAME_MACHINE}-unknown-linux-gnu
+ exit ;;
+ sparc:Linux:*:* | sparc64:Linux:*:*)
+ echo ${UNAME_MACHINE}-unknown-linux-gnu
+ exit ;;
+ vax:Linux:*:*)
+ echo ${UNAME_MACHINE}-dec-linux-gnu
+ exit ;;
+ x86_64:Linux:*:*)
+ echo x86_64-unknown-linux-gnu
+ exit ;;
+ i*86:Linux:*:*)
+ # The BFD linker knows what the default object file format is, so
+ # first see if it will tell us. cd to the root directory to prevent
+ # problems with other programs or directories called `ld' in the path.
+ # Set LC_ALL=C to ensure ld outputs messages in English.
+ ld_supported_targets=`cd /; LC_ALL=C ld --help 2>&1 \
+ | sed -ne '/supported targets:/!d
+ s/[ ][ ]*/ /g
+ s/.*supported targets: *//
+ s/ .*//
+ p'`
+ case "$ld_supported_targets" in
+ elf32-i386)
+ TENTATIVE="${UNAME_MACHINE}-pc-linux-gnu"
+ ;;
+ a.out-i386-linux)
+ echo "${UNAME_MACHINE}-pc-linux-gnuaout"
+ exit ;;
+ coff-i386)
+ echo "${UNAME_MACHINE}-pc-linux-gnucoff"
+ exit ;;
+ "")
+ # Either a pre-BFD a.out linker (linux-gnuoldld) or
+ # one that does not give us useful --help.
+ echo "${UNAME_MACHINE}-pc-linux-gnuoldld"
+ exit ;;
+ esac
+ # Determine whether the default compiler is a.out or elf
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+ #include <features.h>
+ #ifdef __ELF__
+ # ifdef __GLIBC__
+ # if __GLIBC__ >= 2
+ LIBC=gnu
+ # else
+ LIBC=gnulibc1
+ # endif
+ # else
+ LIBC=gnulibc1
+ # endif
+ #else
+ #if defined(__INTEL_COMPILER) || defined(__PGI) || defined(__SUNPRO_C) || defined(__SUNPRO_CC)
+ LIBC=gnu
+ #else
+ LIBC=gnuaout
+ #endif
+ #endif
+ #ifdef __dietlibc__
+ LIBC=dietlibc
+ #endif
+EOF
+ eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n '
+ /^LIBC/{
+ s: ::g
+ p
+ }'`"
+ test x"${LIBC}" != x && {
+ echo "${UNAME_MACHINE}-pc-linux-${LIBC}"
+ exit
+ }
+ test x"${TENTATIVE}" != x && { echo "${TENTATIVE}"; exit; }
+ ;;
+ i*86:DYNIX/ptx:4*:*)
+ # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there.
+ # earlier versions are messed up and put the nodename in both
+ # sysname and nodename.
+ echo i386-sequent-sysv4
+ exit ;;
+ i*86:UNIX_SV:4.2MP:2.*)
+ # Unixware is an offshoot of SVR4, but it has its own version
+ # number series starting with 2...
+ # I am not positive that other SVR4 systems won't match this,
+ # I just have to hope. -- rms.
+ # Use sysv4.2uw... so that sysv4* matches it.
+ echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION}
+ exit ;;
+ i*86:OS/2:*:*)
+ # If we were able to find `uname', then EMX Unix compatibility
+ # is probably installed.
+ echo ${UNAME_MACHINE}-pc-os2-emx
+ exit ;;
+ i*86:XTS-300:*:STOP)
+ echo ${UNAME_MACHINE}-unknown-stop
+ exit ;;
+ i*86:atheos:*:*)
+ echo ${UNAME_MACHINE}-unknown-atheos
+ exit ;;
+ i*86:syllable:*:*)
+ echo ${UNAME_MACHINE}-pc-syllable
+ exit ;;
+ i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.0*:*)
+ echo i386-unknown-lynxos${UNAME_RELEASE}
+ exit ;;
+ i*86:*DOS:*:*)
+ echo ${UNAME_MACHINE}-pc-msdosdjgpp
+ exit ;;
+ i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*)
+ UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'`
+ if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then
+ echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL}
+ else
+ echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL}
+ fi
+ exit ;;
+ i*86:*:5:[678]*)
+ # UnixWare 7.x, OpenUNIX and OpenServer 6.
+ case `/bin/uname -X | grep "^Machine"` in
+ *486*) UNAME_MACHINE=i486 ;;
+ *Pentium) UNAME_MACHINE=i586 ;;
+ *Pent*|*Celeron) UNAME_MACHINE=i686 ;;
+ esac
+ echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION}
+ exit ;;
+ i*86:*:3.2:*)
+ if test -f /usr/options/cb.name; then
+ UNAME_REL=`sed -n 's/.*Version //p' </usr/options/cb.name`
+ echo ${UNAME_MACHINE}-pc-isc$UNAME_REL
+ elif /bin/uname -X 2>/dev/null >/dev/null ; then
+ UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')`
+ (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486
+ (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \
+ && UNAME_MACHINE=i586
+ (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \
+ && UNAME_MACHINE=i686
+ (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \
+ && UNAME_MACHINE=i686
+ echo ${UNAME_MACHINE}-pc-sco$UNAME_REL
+ else
+ echo ${UNAME_MACHINE}-pc-sysv32
+ fi
+ exit ;;
+ pc:*:*:*)
+ # Left here for compatibility:
+ # uname -m prints for DJGPP always 'pc', but it prints nothing about
+ # the processor, so we play safe by assuming i386.
+ echo i386-pc-msdosdjgpp
+ exit ;;
+ Intel:Mach:3*:*)
+ echo i386-pc-mach3
+ exit ;;
+ paragon:*:*:*)
+ echo i860-intel-osf1
+ exit ;;
+ i860:*:4.*:*) # i860-SVR4
+ if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then
+ echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4
+ else # Add other i860-SVR4 vendors below as they are discovered.
+ echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4
+ fi
+ exit ;;
+ mini*:CTIX:SYS*5:*)
+ # "miniframe"
+ echo m68010-convergent-sysv
+ exit ;;
+ mc68k:UNIX:SYSTEM5:3.51m)
+ echo m68k-convergent-sysv
+ exit ;;
+ M680?0:D-NIX:5.3:*)
+ echo m68k-diab-dnix
+ exit ;;
+ M68*:*:R3V[5678]*:*)
+ test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;;
+ 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0)
+ OS_REL=''
+ test -r /etc/.relid \
+ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid`
+ /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
+ && { echo i486-ncr-sysv4.3${OS_REL}; exit; }
+ /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \
+ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;;
+ 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*)
+ /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
+ && { echo i486-ncr-sysv4; exit; } ;;
+ m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*)
+ echo m68k-unknown-lynxos${UNAME_RELEASE}
+ exit ;;
+ mc68030:UNIX_System_V:4.*:*)
+ echo m68k-atari-sysv4
+ exit ;;
+ TSUNAMI:LynxOS:2.*:*)
+ echo sparc-unknown-lynxos${UNAME_RELEASE}
+ exit ;;
+ rs6000:LynxOS:2.*:*)
+ echo rs6000-unknown-lynxos${UNAME_RELEASE}
+ exit ;;
+ PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.0*:*)
+ echo powerpc-unknown-lynxos${UNAME_RELEASE}
+ exit ;;
+ SM[BE]S:UNIX_SV:*:*)
+ echo mips-dde-sysv${UNAME_RELEASE}
+ exit ;;
+ RM*:ReliantUNIX-*:*:*)
+ echo mips-sni-sysv4
+ exit ;;
+ RM*:SINIX-*:*:*)
+ echo mips-sni-sysv4
+ exit ;;
+ *:SINIX-*:*:*)
+ if uname -p 2>/dev/null >/dev/null ; then
+ UNAME_MACHINE=`(uname -p) 2>/dev/null`
+ echo ${UNAME_MACHINE}-sni-sysv4
+ else
+ echo ns32k-sni-sysv
+ fi
+ exit ;;
+ PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort
+ # says <Richard.M.Bartel@ccMail.Census.GOV>
+ echo i586-unisys-sysv4
+ exit ;;
+ *:UNIX_System_V:4*:FTX*)
+ # From Gerald Hewes <hewes@openmarket.com>.
+ # How about differentiating between stratus architectures? -djm
+ echo hppa1.1-stratus-sysv4
+ exit ;;
+ *:*:*:FTX*)
+ # From seanf@swdc.stratus.com.
+ echo i860-stratus-sysv4
+ exit ;;
+ i*86:VOS:*:*)
+ # From Paul.Green@stratus.com.
+ echo ${UNAME_MACHINE}-stratus-vos
+ exit ;;
+ *:VOS:*:*)
+ # From Paul.Green@stratus.com.
+ echo hppa1.1-stratus-vos
+ exit ;;
+ mc68*:A/UX:*:*)
+ echo m68k-apple-aux${UNAME_RELEASE}
+ exit ;;
+ news*:NEWS-OS:6*:*)
+ echo mips-sony-newsos6
+ exit ;;
+ R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*)
+ if [ -d /usr/nec ]; then
+ echo mips-nec-sysv${UNAME_RELEASE}
+ else
+ echo mips-unknown-sysv${UNAME_RELEASE}
+ fi
+ exit ;;
+ BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only.
+ echo powerpc-be-beos
+ exit ;;
+ BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only.
+ echo powerpc-apple-beos
+ exit ;;
+ BePC:BeOS:*:*) # BeOS running on Intel PC compatible.
+ echo i586-pc-beos
+ exit ;;
+ SX-4:SUPER-UX:*:*)
+ echo sx4-nec-superux${UNAME_RELEASE}
+ exit ;;
+ SX-5:SUPER-UX:*:*)
+ echo sx5-nec-superux${UNAME_RELEASE}
+ exit ;;
+ SX-6:SUPER-UX:*:*)
+ echo sx6-nec-superux${UNAME_RELEASE}
+ exit ;;
+ Power*:Rhapsody:*:*)
+ echo powerpc-apple-rhapsody${UNAME_RELEASE}
+ exit ;;
+ *:Rhapsody:*:*)
+ echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE}
+ exit ;;
+ *:Darwin:*:*)
+ UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown
+ case $UNAME_PROCESSOR in
+ unknown) UNAME_PROCESSOR=powerpc ;;
+ esac
+ echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE}
+ exit ;;
+ *:procnto*:*:* | *:QNX:[0123456789]*:*)
+ UNAME_PROCESSOR=`uname -p`
+ if test "$UNAME_PROCESSOR" = "x86"; then
+ UNAME_PROCESSOR=i386
+ UNAME_MACHINE=pc
+ fi
+ echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE}
+ exit ;;
+ *:QNX:*:4*)
+ echo i386-pc-qnx
+ exit ;;
+ NSE-?:NONSTOP_KERNEL:*:*)
+ echo nse-tandem-nsk${UNAME_RELEASE}
+ exit ;;
+ NSR-?:NONSTOP_KERNEL:*:*)
+ echo nsr-tandem-nsk${UNAME_RELEASE}
+ exit ;;
+ *:NonStop-UX:*:*)
+ echo mips-compaq-nonstopux
+ exit ;;
+ BS2000:POSIX*:*:*)
+ echo bs2000-siemens-sysv
+ exit ;;
+ DS/*:UNIX_System_V:*:*)
+ echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE}
+ exit ;;
+ *:Plan9:*:*)
+ # "uname -m" is not consistent, so use $cputype instead. 386
+ # is converted to i386 for consistency with other x86
+ # operating systems.
+ if test "$cputype" = "386"; then
+ UNAME_MACHINE=i386
+ else
+ UNAME_MACHINE="$cputype"
+ fi
+ echo ${UNAME_MACHINE}-unknown-plan9
+ exit ;;
+ *:TOPS-10:*:*)
+ echo pdp10-unknown-tops10
+ exit ;;
+ *:TENEX:*:*)
+ echo pdp10-unknown-tenex
+ exit ;;
+ KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*)
+ echo pdp10-dec-tops20
+ exit ;;
+ XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*)
+ echo pdp10-xkl-tops20
+ exit ;;
+ *:TOPS-20:*:*)
+ echo pdp10-unknown-tops20
+ exit ;;
+ *:ITS:*:*)
+ echo pdp10-unknown-its
+ exit ;;
+ SEI:*:*:SEIUX)
+ echo mips-sei-seiux${UNAME_RELEASE}
+ exit ;;
+ *:DragonFly:*:*)
+ echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`
+ exit ;;
+ *:*VMS:*:*)
+ UNAME_MACHINE=`(uname -p) 2>/dev/null`
+ case "${UNAME_MACHINE}" in
+ A*) echo alpha-dec-vms ; exit ;;
+ I*) echo ia64-dec-vms ; exit ;;
+ V*) echo vax-dec-vms ; exit ;;
+ esac ;;
+ *:XENIX:*:SysV)
+ echo i386-pc-xenix
+ exit ;;
+ i*86:skyos:*:*)
+ echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//'
+ exit ;;
+ i*86:rdos:*:*)
+ echo ${UNAME_MACHINE}-pc-rdos
+ exit ;;
+esac
+
+#echo '(No uname command or uname output not recognized.)' 1>&2
+#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2
+
+eval $set_cc_for_build
+cat >$dummy.c <<EOF
+#ifdef _SEQUENT_
+# include <sys/types.h>
+# include <sys/utsname.h>
+#endif
+main ()
+{
+#if defined (sony)
+#if defined (MIPSEB)
+ /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed,
+ I don't know.... */
+ printf ("mips-sony-bsd\n"); exit (0);
+#else
+#include <sys/param.h>
+ printf ("m68k-sony-newsos%s\n",
+#ifdef NEWSOS4
+ "4"
+#else
+ ""
+#endif
+ ); exit (0);
+#endif
+#endif
+
+#if defined (__arm) && defined (__acorn) && defined (__unix)
+ printf ("arm-acorn-riscix\n"); exit (0);
+#endif
+
+#if defined (hp300) && !defined (hpux)
+ printf ("m68k-hp-bsd\n"); exit (0);
+#endif
+
+#if defined (NeXT)
+#if !defined (__ARCHITECTURE__)
+#define __ARCHITECTURE__ "m68k"
+#endif
+ int version;
+ version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`;
+ if (version < 4)
+ printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version);
+ else
+ printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version);
+ exit (0);
+#endif
+
+#if defined (MULTIMAX) || defined (n16)
+#if defined (UMAXV)
+ printf ("ns32k-encore-sysv\n"); exit (0);
+#else
+#if defined (CMU)
+ printf ("ns32k-encore-mach\n"); exit (0);
+#else
+ printf ("ns32k-encore-bsd\n"); exit (0);
+#endif
+#endif
+#endif
+
+#if defined (__386BSD__)
+ printf ("i386-pc-bsd\n"); exit (0);
+#endif
+
+#if defined (sequent)
+#if defined (i386)
+ printf ("i386-sequent-dynix\n"); exit (0);
+#endif
+#if defined (ns32000)
+ printf ("ns32k-sequent-dynix\n"); exit (0);
+#endif
+#endif
+
+#if defined (_SEQUENT_)
+ struct utsname un;
+
+ uname(&un);
+
+ if (strncmp(un.version, "V2", 2) == 0) {
+ printf ("i386-sequent-ptx2\n"); exit (0);
+ }
+ if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */
+ printf ("i386-sequent-ptx1\n"); exit (0);
+ }
+ printf ("i386-sequent-ptx\n"); exit (0);
+
+#endif
+
+#if defined (vax)
+# if !defined (ultrix)
+# include <sys/param.h>
+# if defined (BSD)
+# if BSD == 43
+ printf ("vax-dec-bsd4.3\n"); exit (0);
+# else
+# if BSD == 199006
+ printf ("vax-dec-bsd4.3reno\n"); exit (0);
+# else
+ printf ("vax-dec-bsd\n"); exit (0);
+# endif
+# endif
+# else
+ printf ("vax-dec-bsd\n"); exit (0);
+# endif
+# else
+ printf ("vax-dec-ultrix\n"); exit (0);
+# endif
+#endif
+
+#if defined (alliant) && defined (i860)
+ printf ("i860-alliant-bsd\n"); exit (0);
+#endif
+
+ exit (1);
+}
+EOF
+
+$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` &&
+ { echo "$SYSTEM_NAME"; exit; }
+
+# Apollos put the system type in the environment.
+
+test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; }
+
+# Convex versions that predate uname can use getsysinfo(1)
+
+if [ -x /usr/convex/getsysinfo ]
+then
+ case `getsysinfo -f cpu_type` in
+ c1*)
+ echo c1-convex-bsd
+ exit ;;
+ c2*)
+ if getsysinfo -f scalar_acc
+ then echo c32-convex-bsd
+ else echo c2-convex-bsd
+ fi
+ exit ;;
+ c34*)
+ echo c34-convex-bsd
+ exit ;;
+ c38*)
+ echo c38-convex-bsd
+ exit ;;
+ c4*)
+ echo c4-convex-bsd
+ exit ;;
+ esac
+fi
+
+cat >&2 <<EOF
+$0: unable to guess system type
+
+This script, last modified $timestamp, has failed to recognize
+the operating system you are using. It is advised that you
+download the most up to date version of the config scripts from
+
+ http://savannah.gnu.org/cgi-bin/viewcvs/*checkout*/config/config/config.guess
+and
+ http://savannah.gnu.org/cgi-bin/viewcvs/*checkout*/config/config/config.sub
+
+If the version you run ($0) is already up to date, please
+send the following data and any information you think might be
+pertinent to <config-patches@gnu.org> in order to provide the needed
+information to handle your system.
+
+config.guess timestamp = $timestamp
+
+uname -m = `(uname -m) 2>/dev/null || echo unknown`
+uname -r = `(uname -r) 2>/dev/null || echo unknown`
+uname -s = `(uname -s) 2>/dev/null || echo unknown`
+uname -v = `(uname -v) 2>/dev/null || echo unknown`
+
+/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null`
+/bin/uname -X = `(/bin/uname -X) 2>/dev/null`
+
+hostinfo = `(hostinfo) 2>/dev/null`
+/bin/universe = `(/bin/universe) 2>/dev/null`
+/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null`
+/bin/arch = `(/bin/arch) 2>/dev/null`
+/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null`
+/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null`
+
+UNAME_MACHINE = ${UNAME_MACHINE}
+UNAME_RELEASE = ${UNAME_RELEASE}
+UNAME_SYSTEM = ${UNAME_SYSTEM}
+UNAME_VERSION = ${UNAME_VERSION}
+EOF
+
+exit 1
+
+# Local variables:
+# eval: (add-hook 'write-file-hooks 'time-stamp)
+# time-stamp-start: "timestamp='"
+# time-stamp-format: "%:y-%02m-%02d"
+# time-stamp-end: "'"
+# End:
--- /dev/null
+#undef HAVE_WCHAR_T
+
+#undef HAVE_STDLIB_H
+
+#undef HAVE_STRINGS_H
+
+#undef HAVE_SYS_TIME_H
+
+#undef HAVE_UNISTD_H
+
+#undef HAVE_CONST
+
+#undef HAVE_INLINE
+
+#undef HAVE_TIME_H
+
+#undef HAVE_MEMCP
+
+#undef HAVE_MKDIR
+
+#undef HAVE_SELECT
+
+#undef HAVE_SOCKET
+
+#undef TYPE_SIZE_T
+
+#undef TYPE_WCHAR_T
--- /dev/null
+# A bunch of variables -*- Mode: makefile -*-
+export ARCHOS=@ARCHOS@
+export HAS_MSVC=@HAS_MSVC@
+export CILHOME=@CILHOME@
+export DEFAULT_COMPILER=@DEFAULT_COMPILER@
+export @DEFAULT_COMPILER@=1
--- /dev/null
+#! /bin/sh
+# Configuration validation subroutine script.
+# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+# 2000, 2001, 2002 Free Software Foundation, Inc.
+
+timestamp='2002-11-30'
+
+# This file is (in principle) common to ALL GNU software.
+# The presence of a machine in this file suggests that SOME GNU software
+# can handle that machine. It does not imply ALL GNU software can.
+#
+# This file is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place - Suite 330,
+# Boston, MA 02111-1307, USA.
+
+# As a special exception to the GNU General Public License, if you
+# distribute this file as part of a program that contains a
+# configuration script generated by Autoconf, you may include it under
+# the same distribution terms that you use for the rest of that program.
+
+# Please send patches to <config-patches@gnu.org>. Submit a context
+# diff and a properly formatted ChangeLog entry.
+#
+# Configuration subroutine to validate and canonicalize a configuration type.
+# Supply the specified configuration type as an argument.
+# If it is invalid, we print an error message on stderr and exit with code 1.
+# Otherwise, we print the canonical config type on stdout and succeed.
+
+# This file is supposed to be the same for all GNU packages
+# and recognize all the CPU types, system types and aliases
+# that are meaningful with *any* GNU software.
+# Each package is responsible for reporting which valid configurations
+# it does not support. The user should be able to distinguish
+# a failure to support a valid configuration from a meaningless
+# configuration.
+
+# The goal of this file is to map all the various variations of a given
+# machine specification into a single specification in the form:
+# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM
+# or in some cases, the newer four-part form:
+# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM
+# It is wrong to echo any other type of specification.
+
+me=`echo "$0" | sed -e 's,.*/,,'`
+
+usage="\
+Usage: $0 [OPTION] CPU-MFR-OPSYS
+ $0 [OPTION] ALIAS
+
+Canonicalize a configuration name.
+
+Operation modes:
+ -h, --help print this help, then exit
+ -t, --time-stamp print date of last modification, then exit
+ -v, --version print version number, then exit
+
+Report bugs and patches to <config-patches@gnu.org>."
+
+version="\
+GNU config.sub ($timestamp)
+
+Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
+Free Software Foundation, Inc.
+
+This is free software; see the source for copying conditions. There is NO
+warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
+
+help="
+Try \`$me --help' for more information."
+
+# Parse command line
+while test $# -gt 0 ; do
+ case $1 in
+ --time-stamp | --time* | -t )
+ echo "$timestamp" ; exit 0 ;;
+ --version | -v )
+ echo "$version" ; exit 0 ;;
+ --help | --h* | -h )
+ echo "$usage"; exit 0 ;;
+ -- ) # Stop option processing
+ shift; break ;;
+ - ) # Use stdin as input.
+ break ;;
+ -* )
+ echo "$me: invalid option $1$help"
+ exit 1 ;;
+
+ *local*)
+ # First pass through any local machine types.
+ echo $1
+ exit 0;;
+
+ * )
+ break ;;
+ esac
+done
+
+case $# in
+ 0) echo "$me: missing argument$help" >&2
+ exit 1;;
+ 1) ;;
+ *) echo "$me: too many arguments$help" >&2
+ exit 1;;
+esac
+
+# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any).
+# Here we must recognize all the valid KERNEL-OS combinations.
+maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'`
+case $maybe_os in
+ nto-qnx* | linux-gnu* | freebsd*-gnu* | netbsd*-gnu* | storm-chaos* | os2-emx* | rtmk-nova*)
+ os=-$maybe_os
+ basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`
+ ;;
+ *)
+ basic_machine=`echo $1 | sed 's/-[^-]*$//'`
+ if [ $basic_machine != $1 ]
+ then os=`echo $1 | sed 's/.*-/-/'`
+ else os=; fi
+ ;;
+esac
+
+### Let's recognize common machines as not being operating systems so
+### that things like config.sub decstation-3100 work. We also
+### recognize some manufacturers as not being operating systems, so we
+### can provide default operating systems below.
+case $os in
+ -sun*os*)
+ # Prevent following clause from handling this invalid input.
+ ;;
+ -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \
+ -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \
+ -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \
+ -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\
+ -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \
+ -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \
+ -apple | -axis)
+ os=
+ basic_machine=$1
+ ;;
+ -sim | -cisco | -oki | -wec | -winbond)
+ os=
+ basic_machine=$1
+ ;;
+ -scout)
+ ;;
+ -wrs)
+ os=-vxworks
+ basic_machine=$1
+ ;;
+ -chorusos*)
+ os=-chorusos
+ basic_machine=$1
+ ;;
+ -chorusrdb)
+ os=-chorusrdb
+ basic_machine=$1
+ ;;
+ -hiux*)
+ os=-hiuxwe2
+ ;;
+ -sco5)
+ os=-sco3.2v5
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -sco4)
+ os=-sco3.2v4
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -sco3.2.[4-9]*)
+ os=`echo $os | sed -e 's/sco3.2./sco3.2v/'`
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -sco3.2v[4-9]*)
+ # Don't forget version if it is 3.2v4 or newer.
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -sco*)
+ os=-sco3.2v2
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -udk*)
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -isc)
+ os=-isc2.2
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -clix*)
+ basic_machine=clipper-intergraph
+ ;;
+ -isc*)
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -lynx*)
+ os=-lynxos
+ ;;
+ -ptx*)
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'`
+ ;;
+ -windowsnt*)
+ os=`echo $os | sed -e 's/windowsnt/winnt/'`
+ ;;
+ -psos*)
+ os=-psos
+ ;;
+ -mint | -mint[0-9]*)
+ basic_machine=m68k-atari
+ os=-mint
+ ;;
+esac
+
+# Decode aliases for certain CPU-COMPANY combinations.
+case $basic_machine in
+ # Recognize the basic CPU types without company name.
+ # Some are omitted here because they have special meanings below.
+ 1750a | 580 \
+ | a29k \
+ | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \
+ | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \
+ | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr \
+ | clipper \
+ | d10v | d30v | dlx | dsp16xx \
+ | fr30 | frv \
+ | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \
+ | i370 | i860 | i960 | ia64 \
+ | ip2k \
+ | m32r | m68000 | m68k | m88k | mcore \
+ | mips | mipsbe | mipseb | mipsel | mipsle \
+ | mips16 \
+ | mips64 | mips64el \
+ | mips64vr | mips64vrel \
+ | mips64orion | mips64orionel \
+ | mips64vr4100 | mips64vr4100el \
+ | mips64vr4300 | mips64vr4300el \
+ | mips64vr5000 | mips64vr5000el \
+ | mipsisa32 | mipsisa32el \
+ | mipsisa64 | mipsisa64el \
+ | mipsisa64sb1 | mipsisa64sb1el \
+ | mipsisa64sr71k | mipsisa64sr71kel \
+ | mipstx39 | mipstx39el \
+ | mn10200 | mn10300 \
+ | ns16k | ns32k \
+ | openrisc | or32 \
+ | pdp10 | pdp11 | pj | pjl \
+ | powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \
+ | pyramid \
+ | sh | sh[1234] | sh3e | sh[34]eb | shbe | shle | sh[1234]le | sh3ele \
+ | sh64 | sh64le \
+ | sparc | sparc64 | sparc86x | sparclet | sparclite | sparcv9 | sparcv9b \
+ | strongarm \
+ | tahoe | thumb | tic80 | tron \
+ | v850 | v850e \
+ | we32k \
+ | x86 | xscale | xstormy16 | xtensa \
+ | z8k)
+ basic_machine=$basic_machine-unknown
+ ;;
+ m6811 | m68hc11 | m6812 | m68hc12)
+ # Motorola 68HC11/12.
+ basic_machine=$basic_machine-unknown
+ os=-none
+ ;;
+ m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k)
+ ;;
+
+ # We use `pc' rather than `unknown'
+ # because (1) that's what they normally are, and
+ # (2) the word "unknown" tends to confuse beginning users.
+ i*86 | x86_64)
+ basic_machine=$basic_machine-pc
+ ;;
+ # Object if more than one company name word.
+ *-*-*)
+ echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
+ exit 1
+ ;;
+ # Recognize the basic CPU types with company name.
+ 580-* \
+ | a29k-* \
+ | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \
+ | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \
+ | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \
+ | arm-* | armbe-* | armle-* | armeb-* | armv*-* \
+ | avr-* \
+ | bs2000-* \
+ | c[123]* | c30-* | [cjt]90-* | c4x-* | c54x-* \
+ | clipper-* | cydra-* \
+ | d10v-* | d30v-* | dlx-* \
+ | elxsi-* \
+ | f30[01]-* | f700-* | fr30-* | frv-* | fx80-* \
+ | h8300-* | h8500-* \
+ | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \
+ | i*86-* | i860-* | i960-* | ia64-* \
+ | ip2k-* \
+ | m32r-* \
+ | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \
+ | m88110-* | m88k-* | mcore-* \
+ | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \
+ | mips16-* \
+ | mips64-* | mips64el-* \
+ | mips64vr-* | mips64vrel-* \
+ | mips64orion-* | mips64orionel-* \
+ | mips64vr4100-* | mips64vr4100el-* \
+ | mips64vr4300-* | mips64vr4300el-* \
+ | mips64vr5000-* | mips64vr5000el-* \
+ | mipsisa32-* | mipsisa32el-* \
+ | mipsisa64-* | mipsisa64el-* \
+ | mipsisa64sb1-* | mipsisa64sb1el-* \
+ | mipsisa64sr71k-* | mipsisa64sr71kel-* \
+ | mipstx39 | mipstx39el \
+ | none-* | np1-* | ns16k-* | ns32k-* \
+ | orion-* \
+ | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \
+ | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \
+ | pyramid-* \
+ | romp-* | rs6000-* \
+ | sh-* | sh[1234]-* | sh3e-* | sh[34]eb-* | shbe-* \
+ | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \
+ | sparc-* | sparc64-* | sparc86x-* | sparclet-* | sparclite-* \
+ | sparcv9-* | sparcv9b-* | strongarm-* | sv1-* | sx?-* \
+ | tahoe-* | thumb-* | tic30-* | tic4x-* | tic54x-* | tic80-* | tron-* \
+ | v850-* | v850e-* | vax-* \
+ | we32k-* \
+ | x86-* | x86_64-* | xps100-* | xscale-* | xstormy16-* \
+ | xtensa-* \
+ | ymp-* \
+ | z8k-*)
+ ;;
+ # Recognize the various machine names and aliases which stand
+ # for a CPU type and a company and sometimes even an OS.
+ 386bsd)
+ basic_machine=i386-unknown
+ os=-bsd
+ ;;
+ 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc)
+ basic_machine=m68000-att
+ ;;
+ 3b*)
+ basic_machine=we32k-att
+ ;;
+ a29khif)
+ basic_machine=a29k-amd
+ os=-udi
+ ;;
+ adobe68k)
+ basic_machine=m68010-adobe
+ os=-scout
+ ;;
+ alliant | fx80)
+ basic_machine=fx80-alliant
+ ;;
+ altos | altos3068)
+ basic_machine=m68k-altos
+ ;;
+ am29k)
+ basic_machine=a29k-none
+ os=-bsd
+ ;;
+ amdahl)
+ basic_machine=580-amdahl
+ os=-sysv
+ ;;
+ amiga | amiga-*)
+ basic_machine=m68k-unknown
+ ;;
+ amigaos | amigados)
+ basic_machine=m68k-unknown
+ os=-amigaos
+ ;;
+ amigaunix | amix)
+ basic_machine=m68k-unknown
+ os=-sysv4
+ ;;
+ apollo68)
+ basic_machine=m68k-apollo
+ os=-sysv
+ ;;
+ apollo68bsd)
+ basic_machine=m68k-apollo
+ os=-bsd
+ ;;
+ aux)
+ basic_machine=m68k-apple
+ os=-aux
+ ;;
+ balance)
+ basic_machine=ns32k-sequent
+ os=-dynix
+ ;;
+ c90)
+ basic_machine=c90-cray
+ os=-unicos
+ ;;
+ convex-c1)
+ basic_machine=c1-convex
+ os=-bsd
+ ;;
+ convex-c2)
+ basic_machine=c2-convex
+ os=-bsd
+ ;;
+ convex-c32)
+ basic_machine=c32-convex
+ os=-bsd
+ ;;
+ convex-c34)
+ basic_machine=c34-convex
+ os=-bsd
+ ;;
+ convex-c38)
+ basic_machine=c38-convex
+ os=-bsd
+ ;;
+ cray | j90)
+ basic_machine=j90-cray
+ os=-unicos
+ ;;
+ crds | unos)
+ basic_machine=m68k-crds
+ ;;
+ cris | cris-* | etrax*)
+ basic_machine=cris-axis
+ ;;
+ da30 | da30-*)
+ basic_machine=m68k-da30
+ ;;
+ decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn)
+ basic_machine=mips-dec
+ ;;
+ decsystem10* | dec10*)
+ basic_machine=pdp10-dec
+ os=-tops10
+ ;;
+ decsystem20* | dec20*)
+ basic_machine=pdp10-dec
+ os=-tops20
+ ;;
+ delta | 3300 | motorola-3300 | motorola-delta \
+ | 3300-motorola | delta-motorola)
+ basic_machine=m68k-motorola
+ ;;
+ delta88)
+ basic_machine=m88k-motorola
+ os=-sysv3
+ ;;
+ dpx20 | dpx20-*)
+ basic_machine=rs6000-bull
+ os=-bosx
+ ;;
+ dpx2* | dpx2*-bull)
+ basic_machine=m68k-bull
+ os=-sysv3
+ ;;
+ ebmon29k)
+ basic_machine=a29k-amd
+ os=-ebmon
+ ;;
+ elxsi)
+ basic_machine=elxsi-elxsi
+ os=-bsd
+ ;;
+ encore | umax | mmax)
+ basic_machine=ns32k-encore
+ ;;
+ es1800 | OSE68k | ose68k | ose | OSE)
+ basic_machine=m68k-ericsson
+ os=-ose
+ ;;
+ fx2800)
+ basic_machine=i860-alliant
+ ;;
+ genix)
+ basic_machine=ns32k-ns
+ ;;
+ gmicro)
+ basic_machine=tron-gmicro
+ os=-sysv
+ ;;
+ go32)
+ basic_machine=i386-pc
+ os=-go32
+ ;;
+ h3050r* | hiux*)
+ basic_machine=hppa1.1-hitachi
+ os=-hiuxwe2
+ ;;
+ h8300hms)
+ basic_machine=h8300-hitachi
+ os=-hms
+ ;;
+ h8300xray)
+ basic_machine=h8300-hitachi
+ os=-xray
+ ;;
+ h8500hms)
+ basic_machine=h8500-hitachi
+ os=-hms
+ ;;
+ harris)
+ basic_machine=m88k-harris
+ os=-sysv3
+ ;;
+ hp300-*)
+ basic_machine=m68k-hp
+ ;;
+ hp300bsd)
+ basic_machine=m68k-hp
+ os=-bsd
+ ;;
+ hp300hpux)
+ basic_machine=m68k-hp
+ os=-hpux
+ ;;
+ hp3k9[0-9][0-9] | hp9[0-9][0-9])
+ basic_machine=hppa1.0-hp
+ ;;
+ hp9k2[0-9][0-9] | hp9k31[0-9])
+ basic_machine=m68000-hp
+ ;;
+ hp9k3[2-9][0-9])
+ basic_machine=m68k-hp
+ ;;
+ hp9k6[0-9][0-9] | hp6[0-9][0-9])
+ basic_machine=hppa1.0-hp
+ ;;
+ hp9k7[0-79][0-9] | hp7[0-79][0-9])
+ basic_machine=hppa1.1-hp
+ ;;
+ hp9k78[0-9] | hp78[0-9])
+ # FIXME: really hppa2.0-hp
+ basic_machine=hppa1.1-hp
+ ;;
+ hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893)
+ # FIXME: really hppa2.0-hp
+ basic_machine=hppa1.1-hp
+ ;;
+ hp9k8[0-9][13679] | hp8[0-9][13679])
+ basic_machine=hppa1.1-hp
+ ;;
+ hp9k8[0-9][0-9] | hp8[0-9][0-9])
+ basic_machine=hppa1.0-hp
+ ;;
+ hppa-next)
+ os=-nextstep3
+ ;;
+ hppaosf)
+ basic_machine=hppa1.1-hp
+ os=-osf
+ ;;
+ hppro)
+ basic_machine=hppa1.1-hp
+ os=-proelf
+ ;;
+ i370-ibm* | ibm*)
+ basic_machine=i370-ibm
+ ;;
+# I'm not sure what "Sysv32" means. Should this be sysv3.2?
+ i*86v32)
+ basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
+ os=-sysv32
+ ;;
+ i*86v4*)
+ basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
+ os=-sysv4
+ ;;
+ i*86v)
+ basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
+ os=-sysv
+ ;;
+ i*86sol2)
+ basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
+ os=-solaris2
+ ;;
+ i386mach)
+ basic_machine=i386-mach
+ os=-mach
+ ;;
+ i386-vsta | vsta)
+ basic_machine=i386-unknown
+ os=-vsta
+ ;;
+ iris | iris4d)
+ basic_machine=mips-sgi
+ case $os in
+ -irix*)
+ ;;
+ *)
+ os=-irix4
+ ;;
+ esac
+ ;;
+ isi68 | isi)
+ basic_machine=m68k-isi
+ os=-sysv
+ ;;
+ m88k-omron*)
+ basic_machine=m88k-omron
+ ;;
+ magnum | m3230)
+ basic_machine=mips-mips
+ os=-sysv
+ ;;
+ merlin)
+ basic_machine=ns32k-utek
+ os=-sysv
+ ;;
+ mingw32)
+ basic_machine=i386-pc
+ os=-mingw32
+ ;;
+ miniframe)
+ basic_machine=m68000-convergent
+ ;;
+ *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*)
+ basic_machine=m68k-atari
+ os=-mint
+ ;;
+ mips3*-*)
+ basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`
+ ;;
+ mips3*)
+ basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown
+ ;;
+ mmix*)
+ basic_machine=mmix-knuth
+ os=-mmixware
+ ;;
+ monitor)
+ basic_machine=m68k-rom68k
+ os=-coff
+ ;;
+ morphos)
+ basic_machine=powerpc-unknown
+ os=-morphos
+ ;;
+ msdos)
+ basic_machine=i386-pc
+ os=-msdos
+ ;;
+ mvs)
+ basic_machine=i370-ibm
+ os=-mvs
+ ;;
+ ncr3000)
+ basic_machine=i486-ncr
+ os=-sysv4
+ ;;
+ netbsd386)
+ basic_machine=i386-unknown
+ os=-netbsd
+ ;;
+ netwinder)
+ basic_machine=armv4l-rebel
+ os=-linux
+ ;;
+ news | news700 | news800 | news900)
+ basic_machine=m68k-sony
+ os=-newsos
+ ;;
+ news1000)
+ basic_machine=m68030-sony
+ os=-newsos
+ ;;
+ news-3600 | risc-news)
+ basic_machine=mips-sony
+ os=-newsos
+ ;;
+ necv70)
+ basic_machine=v70-nec
+ os=-sysv
+ ;;
+ next | m*-next )
+ basic_machine=m68k-next
+ case $os in
+ -nextstep* )
+ ;;
+ -ns2*)
+ os=-nextstep2
+ ;;
+ *)
+ os=-nextstep3
+ ;;
+ esac
+ ;;
+ nh3000)
+ basic_machine=m68k-harris
+ os=-cxux
+ ;;
+ nh[45]000)
+ basic_machine=m88k-harris
+ os=-cxux
+ ;;
+ nindy960)
+ basic_machine=i960-intel
+ os=-nindy
+ ;;
+ mon960)
+ basic_machine=i960-intel
+ os=-mon960
+ ;;
+ nonstopux)
+ basic_machine=mips-compaq
+ os=-nonstopux
+ ;;
+ np1)
+ basic_machine=np1-gould
+ ;;
+ nsr-tandem)
+ basic_machine=nsr-tandem
+ ;;
+ op50n-* | op60c-*)
+ basic_machine=hppa1.1-oki
+ os=-proelf
+ ;;
+ or32 | or32-*)
+ basic_machine=or32-unknown
+ os=-coff
+ ;;
+ OSE68000 | ose68000)
+ basic_machine=m68000-ericsson
+ os=-ose
+ ;;
+ os68k)
+ basic_machine=m68k-none
+ os=-os68k
+ ;;
+ pa-hitachi)
+ basic_machine=hppa1.1-hitachi
+ os=-hiuxwe2
+ ;;
+ paragon)
+ basic_machine=i860-intel
+ os=-osf
+ ;;
+ pbd)
+ basic_machine=sparc-tti
+ ;;
+ pbb)
+ basic_machine=m68k-tti
+ ;;
+ pc532 | pc532-*)
+ basic_machine=ns32k-pc532
+ ;;
+ pentium | p5 | k5 | k6 | nexgen | viac3)
+ basic_machine=i586-pc
+ ;;
+ pentiumpro | p6 | 6x86 | athlon | athlon_*)
+ basic_machine=i686-pc
+ ;;
+ pentiumii | pentium2)
+ basic_machine=i686-pc
+ ;;
+ pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*)
+ basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ pentiumpro-* | p6-* | 6x86-* | athlon-*)
+ basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ pentiumii-* | pentium2-*)
+ basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ pn)
+ basic_machine=pn-gould
+ ;;
+ power) basic_machine=power-ibm
+ ;;
+ ppc) basic_machine=powerpc-unknown
+ ;;
+ ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ ppcle | powerpclittle | ppc-le | powerpc-little)
+ basic_machine=powerpcle-unknown
+ ;;
+ ppcle-* | powerpclittle-*)
+ basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ ppc64) basic_machine=powerpc64-unknown
+ ;;
+ ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ ppc64le | powerpc64little | ppc64-le | powerpc64-little)
+ basic_machine=powerpc64le-unknown
+ ;;
+ ppc64le-* | powerpc64little-*)
+ basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ ps2)
+ basic_machine=i386-ibm
+ ;;
+ pw32)
+ basic_machine=i586-unknown
+ os=-pw32
+ ;;
+ rom68k)
+ basic_machine=m68k-rom68k
+ os=-coff
+ ;;
+ rm[46]00)
+ basic_machine=mips-siemens
+ ;;
+ rtpc | rtpc-*)
+ basic_machine=romp-ibm
+ ;;
+ s390 | s390-*)
+ basic_machine=s390-ibm
+ ;;
+ s390x | s390x-*)
+ basic_machine=s390x-ibm
+ ;;
+ sa29200)
+ basic_machine=a29k-amd
+ os=-udi
+ ;;
+ sb1)
+ basic_machine=mipsisa64sb1-unknown
+ ;;
+ sb1el)
+ basic_machine=mipsisa64sb1el-unknown
+ ;;
+ sequent)
+ basic_machine=i386-sequent
+ ;;
+ sh)
+ basic_machine=sh-hitachi
+ os=-hms
+ ;;
+ sparclite-wrs | simso-wrs)
+ basic_machine=sparclite-wrs
+ os=-vxworks
+ ;;
+ sps7)
+ basic_machine=m68k-bull
+ os=-sysv2
+ ;;
+ spur)
+ basic_machine=spur-unknown
+ ;;
+ st2000)
+ basic_machine=m68k-tandem
+ ;;
+ stratus)
+ basic_machine=i860-stratus
+ os=-sysv4
+ ;;
+ sun2)
+ basic_machine=m68000-sun
+ ;;
+ sun2os3)
+ basic_machine=m68000-sun
+ os=-sunos3
+ ;;
+ sun2os4)
+ basic_machine=m68000-sun
+ os=-sunos4
+ ;;
+ sun3os3)
+ basic_machine=m68k-sun
+ os=-sunos3
+ ;;
+ sun3os4)
+ basic_machine=m68k-sun
+ os=-sunos4
+ ;;
+ sun4os3)
+ basic_machine=sparc-sun
+ os=-sunos3
+ ;;
+ sun4os4)
+ basic_machine=sparc-sun
+ os=-sunos4
+ ;;
+ sun4sol2)
+ basic_machine=sparc-sun
+ os=-solaris2
+ ;;
+ sun3 | sun3-*)
+ basic_machine=m68k-sun
+ ;;
+ sun4)
+ basic_machine=sparc-sun
+ ;;
+ sun386 | sun386i | roadrunner)
+ basic_machine=i386-sun
+ ;;
+ sv1)
+ basic_machine=sv1-cray
+ os=-unicos
+ ;;
+ symmetry)
+ basic_machine=i386-sequent
+ os=-dynix
+ ;;
+ t3d)
+ basic_machine=alpha-cray
+ os=-unicos
+ ;;
+ t3e)
+ basic_machine=alphaev5-cray
+ os=-unicos
+ ;;
+ t90)
+ basic_machine=t90-cray
+ os=-unicos
+ ;;
+ tic4x | c4x*)
+ basic_machine=tic4x-unknown
+ os=-coff
+ ;;
+ tic54x | c54x*)
+ basic_machine=tic54x-unknown
+ os=-coff
+ ;;
+ tx39)
+ basic_machine=mipstx39-unknown
+ ;;
+ tx39el)
+ basic_machine=mipstx39el-unknown
+ ;;
+ toad1)
+ basic_machine=pdp10-xkl
+ os=-tops20
+ ;;
+ tower | tower-32)
+ basic_machine=m68k-ncr
+ ;;
+ udi29k)
+ basic_machine=a29k-amd
+ os=-udi
+ ;;
+ ultra3)
+ basic_machine=a29k-nyu
+ os=-sym1
+ ;;
+ v810 | necv810)
+ basic_machine=v810-nec
+ os=-none
+ ;;
+ vaxv)
+ basic_machine=vax-dec
+ os=-sysv
+ ;;
+ vms)
+ basic_machine=vax-dec
+ os=-vms
+ ;;
+ vpp*|vx|vx-*)
+ basic_machine=f301-fujitsu
+ ;;
+ vxworks960)
+ basic_machine=i960-wrs
+ os=-vxworks
+ ;;
+ vxworks68)
+ basic_machine=m68k-wrs
+ os=-vxworks
+ ;;
+ vxworks29k)
+ basic_machine=a29k-wrs
+ os=-vxworks
+ ;;
+ w65*)
+ basic_machine=w65-wdc
+ os=-none
+ ;;
+ w89k-*)
+ basic_machine=hppa1.1-winbond
+ os=-proelf
+ ;;
+ xps | xps100)
+ basic_machine=xps100-honeywell
+ ;;
+ ymp)
+ basic_machine=ymp-cray
+ os=-unicos
+ ;;
+ z8k-*-coff)
+ basic_machine=z8k-unknown
+ os=-sim
+ ;;
+ none)
+ basic_machine=none-none
+ os=-none
+ ;;
+
+# Here we handle the default manufacturer of certain CPU types. It is in
+# some cases the only manufacturer, in others, it is the most popular.
+ w89k)
+ basic_machine=hppa1.1-winbond
+ ;;
+ op50n)
+ basic_machine=hppa1.1-oki
+ ;;
+ op60c)
+ basic_machine=hppa1.1-oki
+ ;;
+ romp)
+ basic_machine=romp-ibm
+ ;;
+ rs6000)
+ basic_machine=rs6000-ibm
+ ;;
+ vax)
+ basic_machine=vax-dec
+ ;;
+ pdp10)
+ # there are many clones, so DEC is not a safe bet
+ basic_machine=pdp10-unknown
+ ;;
+ pdp11)
+ basic_machine=pdp11-dec
+ ;;
+ we32k)
+ basic_machine=we32k-att
+ ;;
+ sh3 | sh4 | sh3eb | sh4eb | sh[1234]le | sh3ele)
+ basic_machine=sh-unknown
+ ;;
+ sh64)
+ basic_machine=sh64-unknown
+ ;;
+ sparc | sparcv9 | sparcv9b)
+ basic_machine=sparc-sun
+ ;;
+ cydra)
+ basic_machine=cydra-cydrome
+ ;;
+ orion)
+ basic_machine=orion-highlevel
+ ;;
+ orion105)
+ basic_machine=clipper-highlevel
+ ;;
+ mac | mpw | mac-mpw)
+ basic_machine=m68k-apple
+ ;;
+ pmac | pmac-mpw)
+ basic_machine=powerpc-apple
+ ;;
+ *-unknown)
+ # Make sure to match an already-canonicalized machine name.
+ ;;
+ *)
+ echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
+ exit 1
+ ;;
+esac
+
+# Here we canonicalize certain aliases for manufacturers.
+case $basic_machine in
+ *-digital*)
+ basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'`
+ ;;
+ *-commodore*)
+ basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'`
+ ;;
+ *)
+ ;;
+esac
+
+# Decode manufacturer-specific aliases for certain operating systems.
+
+if [ x"$os" != x"" ]
+then
+case $os in
+ # First match some system type aliases
+ # that might get confused with valid system types.
+ # -solaris* is a basic system type, with this one exception.
+ -solaris1 | -solaris1.*)
+ os=`echo $os | sed -e 's|solaris1|sunos4|'`
+ ;;
+ -solaris)
+ os=-solaris2
+ ;;
+ -svr4*)
+ os=-sysv4
+ ;;
+ -unixware*)
+ os=-sysv4.2uw
+ ;;
+ -gnu/linux*)
+ os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'`
+ ;;
+ # First accept the basic system types.
+ # The portable systems comes first.
+ # Each alternative MUST END IN A *, to match a version number.
+ # -sysv* is not here because it comes later, after sysvr4.
+ -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \
+ | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\
+ | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \
+ | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \
+ | -aos* \
+ | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \
+ | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \
+ | -hiux* | -386bsd* | -netbsd* | -openbsd* | -freebsd* | -riscix* \
+ | -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \
+ | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \
+ | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \
+ | -chorusos* | -chorusrdb* \
+ | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \
+ | -mingw32* | -linux-gnu* | -uxpv* | -beos* | -mpeix* | -udk* \
+ | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \
+ | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \
+ | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \
+ | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \
+ | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \
+ | -powermax* | -dnix*)
+ # Remember, each alternative MUST END IN *, to match a version number.
+ ;;
+ -qnx*)
+ case $basic_machine in
+ x86-* | i*86-*)
+ ;;
+ *)
+ os=-nto$os
+ ;;
+ esac
+ ;;
+ -nto-qnx*)
+ ;;
+ -nto*)
+ os=`echo $os | sed -e 's|nto|nto-qnx|'`
+ ;;
+ -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \
+ | -windows* | -osx | -abug | -netware* | -os9* | -beos* \
+ | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*)
+ ;;
+ -mac*)
+ os=`echo $os | sed -e 's|mac|macos|'`
+ ;;
+ -linux*)
+ os=`echo $os | sed -e 's|linux|linux-gnu|'`
+ ;;
+ -sunos5*)
+ os=`echo $os | sed -e 's|sunos5|solaris2|'`
+ ;;
+ -sunos6*)
+ os=`echo $os | sed -e 's|sunos6|solaris3|'`
+ ;;
+ -opened*)
+ os=-openedition
+ ;;
+ -wince*)
+ os=-wince
+ ;;
+ -osfrose*)
+ os=-osfrose
+ ;;
+ -osf*)
+ os=-osf
+ ;;
+ -utek*)
+ os=-bsd
+ ;;
+ -dynix*)
+ os=-bsd
+ ;;
+ -acis*)
+ os=-aos
+ ;;
+ -atheos*)
+ os=-atheos
+ ;;
+ -386bsd)
+ os=-bsd
+ ;;
+ -ctix* | -uts*)
+ os=-sysv
+ ;;
+ -nova*)
+ os=-rtmk-nova
+ ;;
+ -ns2 )
+ os=-nextstep2
+ ;;
+ -nsk*)
+ os=-nsk
+ ;;
+ # Preserve the version number of sinix5.
+ -sinix5.*)
+ os=`echo $os | sed -e 's|sinix|sysv|'`
+ ;;
+ -sinix*)
+ os=-sysv4
+ ;;
+ -triton*)
+ os=-sysv3
+ ;;
+ -oss*)
+ os=-sysv3
+ ;;
+ -svr4)
+ os=-sysv4
+ ;;
+ -svr3)
+ os=-sysv3
+ ;;
+ -sysvr4)
+ os=-sysv4
+ ;;
+ # This must come after -sysvr4.
+ -sysv*)
+ ;;
+ -ose*)
+ os=-ose
+ ;;
+ -es1800*)
+ os=-ose
+ ;;
+ -xenix)
+ os=-xenix
+ ;;
+ -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*)
+ os=-mint
+ ;;
+ -none)
+ ;;
+ *)
+ # Get rid of the `-' at the beginning of $os.
+ os=`echo $os | sed 's/[^-]*-//'`
+ echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2
+ exit 1
+ ;;
+esac
+else
+
+# Here we handle the default operating systems that come with various machines.
+# The value should be what the vendor currently ships out the door with their
+# machine or put another way, the most popular os provided with the machine.
+
+# Note that if you're going to try to match "-MANUFACTURER" here (say,
+# "-sun"), then you have to tell the case statement up towards the top
+# that MANUFACTURER isn't an operating system. Otherwise, code above
+# will signal an error saying that MANUFACTURER isn't an operating
+# system, and we'll never get to this point.
+
+case $basic_machine in
+ *-acorn)
+ os=-riscix1.2
+ ;;
+ arm*-rebel)
+ os=-linux
+ ;;
+ arm*-semi)
+ os=-aout
+ ;;
+ # This must come before the *-dec entry.
+ pdp10-*)
+ os=-tops20
+ ;;
+ pdp11-*)
+ os=-none
+ ;;
+ *-dec | vax-*)
+ os=-ultrix4.2
+ ;;
+ m68*-apollo)
+ os=-domain
+ ;;
+ i386-sun)
+ os=-sunos4.0.2
+ ;;
+ m68000-sun)
+ os=-sunos3
+ # This also exists in the configure program, but was not the
+ # default.
+ # os=-sunos4
+ ;;
+ m68*-cisco)
+ os=-aout
+ ;;
+ mips*-cisco)
+ os=-elf
+ ;;
+ mips*-*)
+ os=-elf
+ ;;
+ or32-*)
+ os=-coff
+ ;;
+ *-tti) # must be before sparc entry or we get the wrong os.
+ os=-sysv3
+ ;;
+ sparc-* | *-sun)
+ os=-sunos4.1.1
+ ;;
+ *-be)
+ os=-beos
+ ;;
+ *-ibm)
+ os=-aix
+ ;;
+ *-wec)
+ os=-proelf
+ ;;
+ *-winbond)
+ os=-proelf
+ ;;
+ *-oki)
+ os=-proelf
+ ;;
+ *-hp)
+ os=-hpux
+ ;;
+ *-hitachi)
+ os=-hiux
+ ;;
+ i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent)
+ os=-sysv
+ ;;
+ *-cbm)
+ os=-amigaos
+ ;;
+ *-dg)
+ os=-dgux
+ ;;
+ *-dolphin)
+ os=-sysv3
+ ;;
+ m68k-ccur)
+ os=-rtu
+ ;;
+ m88k-omron*)
+ os=-luna
+ ;;
+ *-next )
+ os=-nextstep
+ ;;
+ *-sequent)
+ os=-ptx
+ ;;
+ *-crds)
+ os=-unos
+ ;;
+ *-ns)
+ os=-genix
+ ;;
+ i370-*)
+ os=-mvs
+ ;;
+ *-next)
+ os=-nextstep3
+ ;;
+ *-gould)
+ os=-sysv
+ ;;
+ *-highlevel)
+ os=-bsd
+ ;;
+ *-encore)
+ os=-bsd
+ ;;
+ *-sgi)
+ os=-irix
+ ;;
+ *-siemens)
+ os=-sysv4
+ ;;
+ *-masscomp)
+ os=-rtu
+ ;;
+ f30[01]-fujitsu | f700-fujitsu)
+ os=-uxpv
+ ;;
+ *-rom68k)
+ os=-coff
+ ;;
+ *-*bug)
+ os=-coff
+ ;;
+ *-apple)
+ os=-macos
+ ;;
+ *-atari*)
+ os=-mint
+ ;;
+ *)
+ os=-none
+ ;;
+esac
+fi
+
+# Here we handle the case where we know the os, and the CPU type, but not the
+# manufacturer. We pick the logical manufacturer.
+vendor=unknown
+case $basic_machine in
+ *-unknown)
+ case $os in
+ -riscix*)
+ vendor=acorn
+ ;;
+ -sunos*)
+ vendor=sun
+ ;;
+ -aix*)
+ vendor=ibm
+ ;;
+ -beos*)
+ vendor=be
+ ;;
+ -hpux*)
+ vendor=hp
+ ;;
+ -mpeix*)
+ vendor=hp
+ ;;
+ -hiux*)
+ vendor=hitachi
+ ;;
+ -unos*)
+ vendor=crds
+ ;;
+ -dgux*)
+ vendor=dg
+ ;;
+ -luna*)
+ vendor=omron
+ ;;
+ -genix*)
+ vendor=ns
+ ;;
+ -mvs* | -opened*)
+ vendor=ibm
+ ;;
+ -ptx*)
+ vendor=sequent
+ ;;
+ -vxsim* | -vxworks* | -windiss*)
+ vendor=wrs
+ ;;
+ -aux*)
+ vendor=apple
+ ;;
+ -hms*)
+ vendor=hitachi
+ ;;
+ -mpw* | -macos*)
+ vendor=apple
+ ;;
+ -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*)
+ vendor=atari
+ ;;
+ -vos*)
+ vendor=stratus
+ ;;
+ esac
+ basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"`
+ ;;
+esac
+
+echo $basic_machine$os
+exit 0
+
+# Local variables:
+# eval: (add-hook 'write-file-hooks 'time-stamp)
+# time-stamp-start: "timestamp='"
+# time-stamp-format: "%:y-%02m-%02d"
+# time-stamp-end: "'"
+# End:
--- /dev/null
+#! /bin/sh
+# Guess values for system-dependent variables and create Makefiles.
+# Generated by GNU Autoconf 2.61.
+#
+# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
+# 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+# This configure script is free software; the Free Software Foundation
+# gives unlimited permission to copy, distribute and modify it.
+## --------------------- ##
+## M4sh Initialization. ##
+## --------------------- ##
+
+# Be more Bourne compatible
+DUALCASE=1; export DUALCASE # for MKS sh
+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
+ emulate sh
+ NULLCMD=:
+ # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
+ # is contrary to our usage. Disable this feature.
+ alias -g '${1+"$@"}'='"$@"'
+ setopt NO_GLOB_SUBST
+else
+ case `(set -o) 2>/dev/null` in
+ *posix*) set -o posix ;;
+esac
+
+fi
+
+
+
+
+# PATH needs CR
+# Avoid depending upon Character Ranges.
+as_cr_letters='abcdefghijklmnopqrstuvwxyz'
+as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
+as_cr_Letters=$as_cr_letters$as_cr_LETTERS
+as_cr_digits='0123456789'
+as_cr_alnum=$as_cr_Letters$as_cr_digits
+
+# The user is always right.
+if test "${PATH_SEPARATOR+set}" != set; then
+ echo "#! /bin/sh" >conf$$.sh
+ echo "exit 0" >>conf$$.sh
+ chmod +x conf$$.sh
+ if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then
+ PATH_SEPARATOR=';'
+ else
+ PATH_SEPARATOR=:
+ fi
+ rm -f conf$$.sh
+fi
+
+# Support unset when possible.
+if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then
+ as_unset=unset
+else
+ as_unset=false
+fi
+
+
+# IFS
+# We need space, tab and new line, in precisely that order. Quoting is
+# there to prevent editors from complaining about space-tab.
+# (If _AS_PATH_WALK were called with IFS unset, it would disable word
+# splitting by setting IFS to empty value.)
+as_nl='
+'
+IFS=" "" $as_nl"
+
+# Find who we are. Look in the path if we contain no directory separator.
+case $0 in
+ *[\\/]* ) as_myself=$0 ;;
+ *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break
+done
+IFS=$as_save_IFS
+
+ ;;
+esac
+# We did not find ourselves, most probably we were run as `sh COMMAND'
+# in which case we are not to be found in the path.
+if test "x$as_myself" = x; then
+ as_myself=$0
+fi
+if test ! -f "$as_myself"; then
+ echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
+ { (exit 1); exit 1; }
+fi
+
+# Work around bugs in pre-3.0 UWIN ksh.
+for as_var in ENV MAIL MAILPATH
+do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var
+done
+PS1='$ '
+PS2='> '
+PS4='+ '
+
+# NLS nuisances.
+for as_var in \
+ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \
+ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \
+ LC_TELEPHONE LC_TIME
+do
+ if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then
+ eval $as_var=C; export $as_var
+ else
+ ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var
+ fi
+done
+
+# Required to use basename.
+if expr a : '\(a\)' >/dev/null 2>&1 &&
+ test "X`expr 00001 : '.*\(...\)'`" = X001; then
+ as_expr=expr
+else
+ as_expr=false
+fi
+
+if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then
+ as_basename=basename
+else
+ as_basename=false
+fi
+
+
+# Name of the executable.
+as_me=`$as_basename -- "$0" ||
+$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
+ X"$0" : 'X\(//\)$' \| \
+ X"$0" : 'X\(/\)' \| . 2>/dev/null ||
+echo X/"$0" |
+ sed '/^.*\/\([^/][^/]*\)\/*$/{
+ s//\1/
+ q
+ }
+ /^X\/\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\/\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+
+# CDPATH.
+$as_unset CDPATH
+
+
+if test "x$CONFIG_SHELL" = x; then
+ if (eval ":") 2>/dev/null; then
+ as_have_required=yes
+else
+ as_have_required=no
+fi
+
+ if test $as_have_required = yes && (eval ":
+(as_func_return () {
+ (exit \$1)
+}
+as_func_success () {
+ as_func_return 0
+}
+as_func_failure () {
+ as_func_return 1
+}
+as_func_ret_success () {
+ return 0
+}
+as_func_ret_failure () {
+ return 1
+}
+
+exitcode=0
+if as_func_success; then
+ :
+else
+ exitcode=1
+ echo as_func_success failed.
+fi
+
+if as_func_failure; then
+ exitcode=1
+ echo as_func_failure succeeded.
+fi
+
+if as_func_ret_success; then
+ :
+else
+ exitcode=1
+ echo as_func_ret_success failed.
+fi
+
+if as_func_ret_failure; then
+ exitcode=1
+ echo as_func_ret_failure succeeded.
+fi
+
+if ( set x; as_func_ret_success y && test x = \"\$1\" ); then
+ :
+else
+ exitcode=1
+ echo positional parameters were not saved.
+fi
+
+test \$exitcode = 0) || { (exit 1); exit 1; }
+
+(
+ as_lineno_1=\$LINENO
+ as_lineno_2=\$LINENO
+ test \"x\$as_lineno_1\" != \"x\$as_lineno_2\" &&
+ test \"x\`expr \$as_lineno_1 + 1\`\" = \"x\$as_lineno_2\") || { (exit 1); exit 1; }
+") 2> /dev/null; then
+ :
+else
+ as_candidate_shells=
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ case $as_dir in
+ /*)
+ for as_base in sh bash ksh sh5; do
+ as_candidate_shells="$as_candidate_shells $as_dir/$as_base"
+ done;;
+ esac
+done
+IFS=$as_save_IFS
+
+
+ for as_shell in $as_candidate_shells $SHELL; do
+ # Try only shells that exist, to save several forks.
+ if { test -f "$as_shell" || test -f "$as_shell.exe"; } &&
+ { ("$as_shell") 2> /dev/null <<\_ASEOF
+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
+ emulate sh
+ NULLCMD=:
+ # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
+ # is contrary to our usage. Disable this feature.
+ alias -g '${1+"$@"}'='"$@"'
+ setopt NO_GLOB_SUBST
+else
+ case `(set -o) 2>/dev/null` in
+ *posix*) set -o posix ;;
+esac
+
+fi
+
+
+:
+_ASEOF
+}; then
+ CONFIG_SHELL=$as_shell
+ as_have_required=yes
+ if { "$as_shell" 2> /dev/null <<\_ASEOF
+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
+ emulate sh
+ NULLCMD=:
+ # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
+ # is contrary to our usage. Disable this feature.
+ alias -g '${1+"$@"}'='"$@"'
+ setopt NO_GLOB_SUBST
+else
+ case `(set -o) 2>/dev/null` in
+ *posix*) set -o posix ;;
+esac
+
+fi
+
+
+:
+(as_func_return () {
+ (exit $1)
+}
+as_func_success () {
+ as_func_return 0
+}
+as_func_failure () {
+ as_func_return 1
+}
+as_func_ret_success () {
+ return 0
+}
+as_func_ret_failure () {
+ return 1
+}
+
+exitcode=0
+if as_func_success; then
+ :
+else
+ exitcode=1
+ echo as_func_success failed.
+fi
+
+if as_func_failure; then
+ exitcode=1
+ echo as_func_failure succeeded.
+fi
+
+if as_func_ret_success; then
+ :
+else
+ exitcode=1
+ echo as_func_ret_success failed.
+fi
+
+if as_func_ret_failure; then
+ exitcode=1
+ echo as_func_ret_failure succeeded.
+fi
+
+if ( set x; as_func_ret_success y && test x = "$1" ); then
+ :
+else
+ exitcode=1
+ echo positional parameters were not saved.
+fi
+
+test $exitcode = 0) || { (exit 1); exit 1; }
+
+(
+ as_lineno_1=$LINENO
+ as_lineno_2=$LINENO
+ test "x$as_lineno_1" != "x$as_lineno_2" &&
+ test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2") || { (exit 1); exit 1; }
+
+_ASEOF
+}; then
+ break
+fi
+
+fi
+
+ done
+
+ if test "x$CONFIG_SHELL" != x; then
+ for as_var in BASH_ENV ENV
+ do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var
+ done
+ export CONFIG_SHELL
+ exec "$CONFIG_SHELL" "$as_myself" ${1+"$@"}
+fi
+
+
+ if test $as_have_required = no; then
+ echo This script requires a shell more modern than all the
+ echo shells that I found on your system. Please install a
+ echo modern shell, or manually run the script under such a
+ echo shell if you do have one.
+ { (exit 1); exit 1; }
+fi
+
+
+fi
+
+fi
+
+
+
+(eval "as_func_return () {
+ (exit \$1)
+}
+as_func_success () {
+ as_func_return 0
+}
+as_func_failure () {
+ as_func_return 1
+}
+as_func_ret_success () {
+ return 0
+}
+as_func_ret_failure () {
+ return 1
+}
+
+exitcode=0
+if as_func_success; then
+ :
+else
+ exitcode=1
+ echo as_func_success failed.
+fi
+
+if as_func_failure; then
+ exitcode=1
+ echo as_func_failure succeeded.
+fi
+
+if as_func_ret_success; then
+ :
+else
+ exitcode=1
+ echo as_func_ret_success failed.
+fi
+
+if as_func_ret_failure; then
+ exitcode=1
+ echo as_func_ret_failure succeeded.
+fi
+
+if ( set x; as_func_ret_success y && test x = \"\$1\" ); then
+ :
+else
+ exitcode=1
+ echo positional parameters were not saved.
+fi
+
+test \$exitcode = 0") || {
+ echo No shell found that supports shell functions.
+ echo Please tell autoconf@gnu.org about your system,
+ echo including any error possibly output before this
+ echo message
+}
+
+
+
+ as_lineno_1=$LINENO
+ as_lineno_2=$LINENO
+ test "x$as_lineno_1" != "x$as_lineno_2" &&
+ test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || {
+
+ # Create $as_me.lineno as a copy of $as_myself, but with $LINENO
+ # uniformly replaced by the line number. The first 'sed' inserts a
+ # line-number line after each line using $LINENO; the second 'sed'
+ # does the real work. The second script uses 'N' to pair each
+ # line-number line with the line containing $LINENO, and appends
+ # trailing '-' during substitution so that $LINENO is not a special
+ # case at line end.
+ # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the
+ # scripts with optimization help from Paolo Bonzini. Blame Lee
+ # E. McMahon (1931-1989) for sed's syntax. :-)
+ sed -n '
+ p
+ /[$]LINENO/=
+ ' <$as_myself |
+ sed '
+ s/[$]LINENO.*/&-/
+ t lineno
+ b
+ :lineno
+ N
+ :loop
+ s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/
+ t loop
+ s/-\n.*//
+ ' >$as_me.lineno &&
+ chmod +x "$as_me.lineno" ||
+ { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2
+ { (exit 1); exit 1; }; }
+
+ # Don't try to exec as it changes $[0], causing all sort of problems
+ # (the dirname of $[0] is not the place where we might find the
+ # original and so on. Autoconf is especially sensitive to this).
+ . "./$as_me.lineno"
+ # Exit status is that of the last command.
+ exit
+}
+
+
+if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then
+ as_dirname=dirname
+else
+ as_dirname=false
+fi
+
+ECHO_C= ECHO_N= ECHO_T=
+case `echo -n x` in
+-n*)
+ case `echo 'x\c'` in
+ *c*) ECHO_T=' ';; # ECHO_T is single tab character.
+ *) ECHO_C='\c';;
+ esac;;
+*)
+ ECHO_N='-n';;
+esac
+
+if expr a : '\(a\)' >/dev/null 2>&1 &&
+ test "X`expr 00001 : '.*\(...\)'`" = X001; then
+ as_expr=expr
+else
+ as_expr=false
+fi
+
+rm -f conf$$ conf$$.exe conf$$.file
+if test -d conf$$.dir; then
+ rm -f conf$$.dir/conf$$.file
+else
+ rm -f conf$$.dir
+ mkdir conf$$.dir
+fi
+echo >conf$$.file
+if ln -s conf$$.file conf$$ 2>/dev/null; then
+ as_ln_s='ln -s'
+ # ... but there are two gotchas:
+ # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.
+ # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.
+ # In both cases, we have to default to `cp -p'.
+ ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
+ as_ln_s='cp -p'
+elif ln conf$$.file conf$$ 2>/dev/null; then
+ as_ln_s=ln
+else
+ as_ln_s='cp -p'
+fi
+rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
+rmdir conf$$.dir 2>/dev/null
+
+if mkdir -p . 2>/dev/null; then
+ as_mkdir_p=:
+else
+ test -d ./-p && rmdir ./-p
+ as_mkdir_p=false
+fi
+
+if test -x / >/dev/null 2>&1; then
+ as_test_x='test -x'
+else
+ if ls -dL / >/dev/null 2>&1; then
+ as_ls_L_option=L
+ else
+ as_ls_L_option=
+ fi
+ as_test_x='
+ eval sh -c '\''
+ if test -d "$1"; then
+ test -d "$1/.";
+ else
+ case $1 in
+ -*)set "./$1";;
+ esac;
+ case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in
+ ???[sx]*):;;*)false;;esac;fi
+ '\'' sh
+ '
+fi
+as_executable_p=$as_test_x
+
+# Sed expression to map a string onto a valid CPP name.
+as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
+
+# Sed expression to map a string onto a valid variable name.
+as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"
+
+
+
+exec 7<&0 </dev/null 6>&1
+
+# Name of the host.
+# hostname on some systems (SVR3.2, Linux) returns a bogus exit status,
+# so uname gets run too.
+ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q`
+
+#
+# Initializations.
+#
+ac_default_prefix=/usr/local
+ac_clean_files=
+ac_config_libobj_dir=.
+LIBOBJS=
+cross_compiling=no
+subdirs=
+MFLAGS=
+MAKEFLAGS=
+SHELL=${CONFIG_SHELL-/bin/sh}
+
+# Identity of this package.
+PACKAGE_NAME=
+PACKAGE_TARNAME=
+PACKAGE_VERSION=
+PACKAGE_STRING=
+PACKAGE_BUGREPORT=
+
+ac_unique_file="src/cil.mli"
+# Factoring default headers for most tests.
+ac_includes_default="\
+#include <stdio.h>
+#ifdef HAVE_SYS_TYPES_H
+# include <sys/types.h>
+#endif
+#ifdef HAVE_SYS_STAT_H
+# include <sys/stat.h>
+#endif
+#ifdef STDC_HEADERS
+# include <stdlib.h>
+# include <stddef.h>
+#else
+# ifdef HAVE_STDLIB_H
+# include <stdlib.h>
+# endif
+#endif
+#ifdef HAVE_STRING_H
+# if !defined STDC_HEADERS && defined HAVE_MEMORY_H
+# include <memory.h>
+# endif
+# include <string.h>
+#endif
+#ifdef HAVE_STRINGS_H
+# include <strings.h>
+#endif
+#ifdef HAVE_INTTYPES_H
+# include <inttypes.h>
+#endif
+#ifdef HAVE_STDINT_H
+# include <stdint.h>
+#endif
+#ifdef HAVE_UNISTD_H
+# include <unistd.h>
+#endif"
+
+ac_subst_vars='SHELL
+PATH_SEPARATOR
+PACKAGE_NAME
+PACKAGE_TARNAME
+PACKAGE_VERSION
+PACKAGE_STRING
+PACKAGE_BUGREPORT
+exec_prefix
+prefix
+program_transform_name
+bindir
+sbindir
+libexecdir
+datarootdir
+datadir
+sysconfdir
+sharedstatedir
+localstatedir
+includedir
+oldincludedir
+docdir
+infodir
+htmldir
+dvidir
+pdfdir
+psdir
+libdir
+localedir
+mandir
+DEFS
+ECHO_C
+ECHO_N
+ECHO_T
+LIBS
+build_alias
+host_alias
+target_alias
+CC
+CFLAGS
+LDFLAGS
+CPPFLAGS
+ac_ct_CC
+EXEEXT
+OBJEXT
+INSTALL_PROGRAM
+INSTALL_SCRIPT
+INSTALL_DATA
+build
+build_cpu
+build_vendor
+build_os
+host
+host_cpu
+host_vendor
+host_os
+target
+target_cpu
+target_vendor
+target_os
+CPP
+GREP
+EGREP
+LIBOBJS
+ARCHOS
+CILHOME
+HAS_MSVC
+DEFAULT_COMPILER
+DEFAULT_CIL_MODE
+CIL_VERSION_MAJOR
+CIL_VERSION_MINOR
+CIL_VERSION_REV
+CIL_VERSION
+CYCLES_PER_USEC
+HAS_PERFCOUNT
+HAVE_BUILTIN_VA_LIST
+THREAD_IS_KEYWORD
+UNDERSCORE_NAME
+EXTRAFEATURES
+EXTRASRCDIRS
+LTLIBOBJS'
+ac_subst_files=''
+ ac_precious_vars='build_alias
+host_alias
+target_alias
+CC
+CFLAGS
+LDFLAGS
+LIBS
+CPPFLAGS
+CPP'
+
+
+# Initialize some variables set by options.
+ac_init_help=
+ac_init_version=false
+# The variables have the same names as the options, with
+# dashes changed to underlines.
+cache_file=/dev/null
+exec_prefix=NONE
+no_create=
+no_recursion=
+prefix=NONE
+program_prefix=NONE
+program_suffix=NONE
+program_transform_name=s,x,x,
+silent=
+site=
+srcdir=
+verbose=
+x_includes=NONE
+x_libraries=NONE
+
+# Installation directory options.
+# These are left unexpanded so users can "make install exec_prefix=/foo"
+# and all the variables that are supposed to be based on exec_prefix
+# by default will actually change.
+# Use braces instead of parens because sh, perl, etc. also accept them.
+# (The list follows the same order as the GNU Coding Standards.)
+bindir='${exec_prefix}/bin'
+sbindir='${exec_prefix}/sbin'
+libexecdir='${exec_prefix}/libexec'
+datarootdir='${prefix}/share'
+datadir='${datarootdir}'
+sysconfdir='${prefix}/etc'
+sharedstatedir='${prefix}/com'
+localstatedir='${prefix}/var'
+includedir='${prefix}/include'
+oldincludedir='/usr/include'
+docdir='${datarootdir}/doc/${PACKAGE}'
+infodir='${datarootdir}/info'
+htmldir='${docdir}'
+dvidir='${docdir}'
+pdfdir='${docdir}'
+psdir='${docdir}'
+libdir='${exec_prefix}/lib'
+localedir='${datarootdir}/locale'
+mandir='${datarootdir}/man'
+
+ac_prev=
+ac_dashdash=
+for ac_option
+do
+ # If the previous option needs an argument, assign it.
+ if test -n "$ac_prev"; then
+ eval $ac_prev=\$ac_option
+ ac_prev=
+ continue
+ fi
+
+ case $ac_option in
+ *=*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;;
+ *) ac_optarg=yes ;;
+ esac
+
+ # Accept the important Cygnus configure options, so we can diagnose typos.
+
+ case $ac_dashdash$ac_option in
+ --)
+ ac_dashdash=yes ;;
+
+ -bindir | --bindir | --bindi | --bind | --bin | --bi)
+ ac_prev=bindir ;;
+ -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)
+ bindir=$ac_optarg ;;
+
+ -build | --build | --buil | --bui | --bu)
+ ac_prev=build_alias ;;
+ -build=* | --build=* | --buil=* | --bui=* | --bu=*)
+ build_alias=$ac_optarg ;;
+
+ -cache-file | --cache-file | --cache-fil | --cache-fi \
+ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c)
+ ac_prev=cache_file ;;
+ -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \
+ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)
+ cache_file=$ac_optarg ;;
+
+ --config-cache | -C)
+ cache_file=config.cache ;;
+
+ -datadir | --datadir | --datadi | --datad)
+ ac_prev=datadir ;;
+ -datadir=* | --datadir=* | --datadi=* | --datad=*)
+ datadir=$ac_optarg ;;
+
+ -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \
+ | --dataroo | --dataro | --datar)
+ ac_prev=datarootdir ;;
+ -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \
+ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*)
+ datarootdir=$ac_optarg ;;
+
+ -disable-* | --disable-*)
+ ac_feature=`expr "x$ac_option" : 'x-*disable-\(.*\)'`
+ # Reject names that are not valid shell variable names.
+ expr "x$ac_feature" : ".*[^-._$as_cr_alnum]" >/dev/null &&
+ { echo "$as_me: error: invalid feature name: $ac_feature" >&2
+ { (exit 1); exit 1; }; }
+ ac_feature=`echo $ac_feature | sed 's/[-.]/_/g'`
+ eval enable_$ac_feature=no ;;
+
+ -docdir | --docdir | --docdi | --doc | --do)
+ ac_prev=docdir ;;
+ -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*)
+ docdir=$ac_optarg ;;
+
+ -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv)
+ ac_prev=dvidir ;;
+ -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*)
+ dvidir=$ac_optarg ;;
+
+ -enable-* | --enable-*)
+ ac_feature=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'`
+ # Reject names that are not valid shell variable names.
+ expr "x$ac_feature" : ".*[^-._$as_cr_alnum]" >/dev/null &&
+ { echo "$as_me: error: invalid feature name: $ac_feature" >&2
+ { (exit 1); exit 1; }; }
+ ac_feature=`echo $ac_feature | sed 's/[-.]/_/g'`
+ eval enable_$ac_feature=\$ac_optarg ;;
+
+ -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \
+ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \
+ | --exec | --exe | --ex)
+ ac_prev=exec_prefix ;;
+ -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \
+ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \
+ | --exec=* | --exe=* | --ex=*)
+ exec_prefix=$ac_optarg ;;
+
+ -gas | --gas | --ga | --g)
+ # Obsolete; use --with-gas.
+ with_gas=yes ;;
+
+ -help | --help | --hel | --he | -h)
+ ac_init_help=long ;;
+ -help=r* | --help=r* | --hel=r* | --he=r* | -hr*)
+ ac_init_help=recursive ;;
+ -help=s* | --help=s* | --hel=s* | --he=s* | -hs*)
+ ac_init_help=short ;;
+
+ -host | --host | --hos | --ho)
+ ac_prev=host_alias ;;
+ -host=* | --host=* | --hos=* | --ho=*)
+ host_alias=$ac_optarg ;;
+
+ -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht)
+ ac_prev=htmldir ;;
+ -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \
+ | --ht=*)
+ htmldir=$ac_optarg ;;
+
+ -includedir | --includedir | --includedi | --included | --include \
+ | --includ | --inclu | --incl | --inc)
+ ac_prev=includedir ;;
+ -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \
+ | --includ=* | --inclu=* | --incl=* | --inc=*)
+ includedir=$ac_optarg ;;
+
+ -infodir | --infodir | --infodi | --infod | --info | --inf)
+ ac_prev=infodir ;;
+ -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*)
+ infodir=$ac_optarg ;;
+
+ -libdir | --libdir | --libdi | --libd)
+ ac_prev=libdir ;;
+ -libdir=* | --libdir=* | --libdi=* | --libd=*)
+ libdir=$ac_optarg ;;
+
+ -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \
+ | --libexe | --libex | --libe)
+ ac_prev=libexecdir ;;
+ -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \
+ | --libexe=* | --libex=* | --libe=*)
+ libexecdir=$ac_optarg ;;
+
+ -localedir | --localedir | --localedi | --localed | --locale)
+ ac_prev=localedir ;;
+ -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*)
+ localedir=$ac_optarg ;;
+
+ -localstatedir | --localstatedir | --localstatedi | --localstated \
+ | --localstate | --localstat | --localsta | --localst | --locals)
+ ac_prev=localstatedir ;;
+ -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \
+ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*)
+ localstatedir=$ac_optarg ;;
+
+ -mandir | --mandir | --mandi | --mand | --man | --ma | --m)
+ ac_prev=mandir ;;
+ -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)
+ mandir=$ac_optarg ;;
+
+ -nfp | --nfp | --nf)
+ # Obsolete; use --without-fp.
+ with_fp=no ;;
+
+ -no-create | --no-create | --no-creat | --no-crea | --no-cre \
+ | --no-cr | --no-c | -n)
+ no_create=yes ;;
+
+ -no-recursion | --no-recursion | --no-recursio | --no-recursi \
+ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r)
+ no_recursion=yes ;;
+
+ -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \
+ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \
+ | --oldin | --oldi | --old | --ol | --o)
+ ac_prev=oldincludedir ;;
+ -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \
+ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \
+ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*)
+ oldincludedir=$ac_optarg ;;
+
+ -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)
+ ac_prev=prefix ;;
+ -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)
+ prefix=$ac_optarg ;;
+
+ -program-prefix | --program-prefix | --program-prefi | --program-pref \
+ | --program-pre | --program-pr | --program-p)
+ ac_prev=program_prefix ;;
+ -program-prefix=* | --program-prefix=* | --program-prefi=* \
+ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*)
+ program_prefix=$ac_optarg ;;
+
+ -program-suffix | --program-suffix | --program-suffi | --program-suff \
+ | --program-suf | --program-su | --program-s)
+ ac_prev=program_suffix ;;
+ -program-suffix=* | --program-suffix=* | --program-suffi=* \
+ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*)
+ program_suffix=$ac_optarg ;;
+
+ -program-transform-name | --program-transform-name \
+ | --program-transform-nam | --program-transform-na \
+ | --program-transform-n | --program-transform- \
+ | --program-transform | --program-transfor \
+ | --program-transfo | --program-transf \
+ | --program-trans | --program-tran \
+ | --progr-tra | --program-tr | --program-t)
+ ac_prev=program_transform_name ;;
+ -program-transform-name=* | --program-transform-name=* \
+ | --program-transform-nam=* | --program-transform-na=* \
+ | --program-transform-n=* | --program-transform-=* \
+ | --program-transform=* | --program-transfor=* \
+ | --program-transfo=* | --program-transf=* \
+ | --program-trans=* | --program-tran=* \
+ | --progr-tra=* | --program-tr=* | --program-t=*)
+ program_transform_name=$ac_optarg ;;
+
+ -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd)
+ ac_prev=pdfdir ;;
+ -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*)
+ pdfdir=$ac_optarg ;;
+
+ -psdir | --psdir | --psdi | --psd | --ps)
+ ac_prev=psdir ;;
+ -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*)
+ psdir=$ac_optarg ;;
+
+ -q | -quiet | --quiet | --quie | --qui | --qu | --q \
+ | -silent | --silent | --silen | --sile | --sil)
+ silent=yes ;;
+
+ -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
+ ac_prev=sbindir ;;
+ -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
+ | --sbi=* | --sb=*)
+ sbindir=$ac_optarg ;;
+
+ -sharedstatedir | --sharedstatedir | --sharedstatedi \
+ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \
+ | --sharedst | --shareds | --shared | --share | --shar \
+ | --sha | --sh)
+ ac_prev=sharedstatedir ;;
+ -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \
+ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \
+ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \
+ | --sha=* | --sh=*)
+ sharedstatedir=$ac_optarg ;;
+
+ -site | --site | --sit)
+ ac_prev=site ;;
+ -site=* | --site=* | --sit=*)
+ site=$ac_optarg ;;
+
+ -srcdir | --srcdir | --srcdi | --srcd | --src | --sr)
+ ac_prev=srcdir ;;
+ -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)
+ srcdir=$ac_optarg ;;
+
+ -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \
+ | --syscon | --sysco | --sysc | --sys | --sy)
+ ac_prev=sysconfdir ;;
+ -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \
+ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*)
+ sysconfdir=$ac_optarg ;;
+
+ -target | --target | --targe | --targ | --tar | --ta | --t)
+ ac_prev=target_alias ;;
+ -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)
+ target_alias=$ac_optarg ;;
+
+ -v | -verbose | --verbose | --verbos | --verbo | --verb)
+ verbose=yes ;;
+
+ -version | --version | --versio | --versi | --vers | -V)
+ ac_init_version=: ;;
+
+ -with-* | --with-*)
+ ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`
+ # Reject names that are not valid shell variable names.
+ expr "x$ac_package" : ".*[^-._$as_cr_alnum]" >/dev/null &&
+ { echo "$as_me: error: invalid package name: $ac_package" >&2
+ { (exit 1); exit 1; }; }
+ ac_package=`echo $ac_package | sed 's/[-.]/_/g'`
+ eval with_$ac_package=\$ac_optarg ;;
+
+ -without-* | --without-*)
+ ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'`
+ # Reject names that are not valid shell variable names.
+ expr "x$ac_package" : ".*[^-._$as_cr_alnum]" >/dev/null &&
+ { echo "$as_me: error: invalid package name: $ac_package" >&2
+ { (exit 1); exit 1; }; }
+ ac_package=`echo $ac_package | sed 's/[-.]/_/g'`
+ eval with_$ac_package=no ;;
+
+ --x)
+ # Obsolete; use --with-x.
+ with_x=yes ;;
+
+ -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \
+ | --x-incl | --x-inc | --x-in | --x-i)
+ ac_prev=x_includes ;;
+ -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \
+ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*)
+ x_includes=$ac_optarg ;;
+
+ -x-libraries | --x-libraries | --x-librarie | --x-librari \
+ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l)
+ ac_prev=x_libraries ;;
+ -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \
+ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*)
+ x_libraries=$ac_optarg ;;
+
+ -*) { echo "$as_me: error: unrecognized option: $ac_option
+Try \`$0 --help' for more information." >&2
+ { (exit 1); exit 1; }; }
+ ;;
+
+ *=*)
+ ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='`
+ # Reject names that are not valid shell variable names.
+ expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null &&
+ { echo "$as_me: error: invalid variable name: $ac_envvar" >&2
+ { (exit 1); exit 1; }; }
+ eval $ac_envvar=\$ac_optarg
+ export $ac_envvar ;;
+
+ *)
+ # FIXME: should be removed in autoconf 3.0.
+ echo "$as_me: WARNING: you should use --build, --host, --target" >&2
+ expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null &&
+ echo "$as_me: WARNING: invalid host type: $ac_option" >&2
+ : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}
+ ;;
+
+ esac
+done
+
+if test -n "$ac_prev"; then
+ ac_option=--`echo $ac_prev | sed 's/_/-/g'`
+ { echo "$as_me: error: missing argument to $ac_option" >&2
+ { (exit 1); exit 1; }; }
+fi
+
+# Be sure to have absolute directory names.
+for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \
+ datadir sysconfdir sharedstatedir localstatedir includedir \
+ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \
+ libdir localedir mandir
+do
+ eval ac_val=\$$ac_var
+ case $ac_val in
+ [\\/$]* | ?:[\\/]* ) continue;;
+ NONE | '' ) case $ac_var in *prefix ) continue;; esac;;
+ esac
+ { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
+ { (exit 1); exit 1; }; }
+done
+
+# There might be people who depend on the old broken behavior: `$host'
+# used to hold the argument of --host etc.
+# FIXME: To remove some day.
+build=$build_alias
+host=$host_alias
+target=$target_alias
+
+# FIXME: To remove some day.
+if test "x$host_alias" != x; then
+ if test "x$build_alias" = x; then
+ cross_compiling=maybe
+ echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host.
+ If a cross compiler is detected then cross compile mode will be used." >&2
+ elif test "x$build_alias" != "x$host_alias"; then
+ cross_compiling=yes
+ fi
+fi
+
+ac_tool_prefix=
+test -n "$host_alias" && ac_tool_prefix=$host_alias-
+
+test "$silent" = yes && exec 6>/dev/null
+
+
+ac_pwd=`pwd` && test -n "$ac_pwd" &&
+ac_ls_di=`ls -di .` &&
+ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` ||
+ { echo "$as_me: error: Working directory cannot be determined" >&2
+ { (exit 1); exit 1; }; }
+test "X$ac_ls_di" = "X$ac_pwd_ls_di" ||
+ { echo "$as_me: error: pwd does not report name of working directory" >&2
+ { (exit 1); exit 1; }; }
+
+
+# Find the source files, if location was not specified.
+if test -z "$srcdir"; then
+ ac_srcdir_defaulted=yes
+ # Try the directory containing this script, then the parent directory.
+ ac_confdir=`$as_dirname -- "$0" ||
+$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$0" : 'X\(//\)[^/]' \| \
+ X"$0" : 'X\(//\)$' \| \
+ X"$0" : 'X\(/\)' \| . 2>/dev/null ||
+echo X"$0" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)[^/].*/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+ srcdir=$ac_confdir
+ if test ! -r "$srcdir/$ac_unique_file"; then
+ srcdir=..
+ fi
+else
+ ac_srcdir_defaulted=no
+fi
+if test ! -r "$srcdir/$ac_unique_file"; then
+ test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .."
+ { echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2
+ { (exit 1); exit 1; }; }
+fi
+ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work"
+ac_abs_confdir=`(
+ cd "$srcdir" && test -r "./$ac_unique_file" || { echo "$as_me: error: $ac_msg" >&2
+ { (exit 1); exit 1; }; }
+ pwd)`
+# When building in place, set srcdir=.
+if test "$ac_abs_confdir" = "$ac_pwd"; then
+ srcdir=.
+fi
+# Remove unnecessary trailing slashes from srcdir.
+# Double slashes in file names in object file debugging info
+# mess up M-x gdb in Emacs.
+case $srcdir in
+*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;;
+esac
+for ac_var in $ac_precious_vars; do
+ eval ac_env_${ac_var}_set=\${${ac_var}+set}
+ eval ac_env_${ac_var}_value=\$${ac_var}
+ eval ac_cv_env_${ac_var}_set=\${${ac_var}+set}
+ eval ac_cv_env_${ac_var}_value=\$${ac_var}
+done
+
+#
+# Report the --help message.
+#
+if test "$ac_init_help" = "long"; then
+ # Omit some internal or obsolete options to make the list less imposing.
+ # This message is too long to be a string in the A/UX 3.1 sh.
+ cat <<_ACEOF
+\`configure' configures this package to adapt to many kinds of systems.
+
+Usage: $0 [OPTION]... [VAR=VALUE]...
+
+To assign environment variables (e.g., CC, CFLAGS...), specify them as
+VAR=VALUE. See below for descriptions of some of the useful variables.
+
+Defaults for the options are specified in brackets.
+
+Configuration:
+ -h, --help display this help and exit
+ --help=short display options specific to this package
+ --help=recursive display the short help of all the included packages
+ -V, --version display version information and exit
+ -q, --quiet, --silent do not print \`checking...' messages
+ --cache-file=FILE cache test results in FILE [disabled]
+ -C, --config-cache alias for \`--cache-file=config.cache'
+ -n, --no-create do not create output files
+ --srcdir=DIR find the sources in DIR [configure dir or \`..']
+
+Installation directories:
+ --prefix=PREFIX install architecture-independent files in PREFIX
+ [$ac_default_prefix]
+ --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX
+ [PREFIX]
+
+By default, \`make install' will install all the files in
+\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify
+an installation prefix other than \`$ac_default_prefix' using \`--prefix',
+for instance \`--prefix=\$HOME'.
+
+For better control, use the options below.
+
+Fine tuning of the installation directories:
+ --bindir=DIR user executables [EPREFIX/bin]
+ --sbindir=DIR system admin executables [EPREFIX/sbin]
+ --libexecdir=DIR program executables [EPREFIX/libexec]
+ --sysconfdir=DIR read-only single-machine data [PREFIX/etc]
+ --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com]
+ --localstatedir=DIR modifiable single-machine data [PREFIX/var]
+ --libdir=DIR object code libraries [EPREFIX/lib]
+ --includedir=DIR C header files [PREFIX/include]
+ --oldincludedir=DIR C header files for non-gcc [/usr/include]
+ --datarootdir=DIR read-only arch.-independent data root [PREFIX/share]
+ --datadir=DIR read-only architecture-independent data [DATAROOTDIR]
+ --infodir=DIR info documentation [DATAROOTDIR/info]
+ --localedir=DIR locale-dependent data [DATAROOTDIR/locale]
+ --mandir=DIR man documentation [DATAROOTDIR/man]
+ --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE]
+ --htmldir=DIR html documentation [DOCDIR]
+ --dvidir=DIR dvi documentation [DOCDIR]
+ --pdfdir=DIR pdf documentation [DOCDIR]
+ --psdir=DIR ps documentation [DOCDIR]
+_ACEOF
+
+ cat <<\_ACEOF
+
+System types:
+ --build=BUILD configure for building on BUILD [guessed]
+ --host=HOST cross-compile to build programs to run on HOST [BUILD]
+ --target=TARGET configure for building compilers for TARGET [HOST]
+_ACEOF
+fi
+
+if test -n "$ac_init_help"; then
+
+ cat <<\_ACEOF
+
+Optional Packages:
+ --with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
+ --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
+ --with-blockinggraph enable the blocking graph feature
+ --with-zrapp enable the zrapp pretty-printer
+
+Some influential environment variables:
+ CC C compiler command
+ CFLAGS C compiler flags
+ LDFLAGS linker flags, e.g. -L<lib dir> if you have libraries in a
+ nonstandard directory <lib dir>
+ LIBS libraries to pass to the linker, e.g. -l<library>
+ CPPFLAGS C/C++/Objective C preprocessor flags, e.g. -I<include dir> if
+ you have headers in a nonstandard directory <include dir>
+ CPP C preprocessor
+
+Use these variables to override the choices made by `configure' or to help
+it to find libraries and programs with nonstandard names/locations.
+
+_ACEOF
+ac_status=$?
+fi
+
+if test "$ac_init_help" = "recursive"; then
+ # If there are subdirs, report their specific --help.
+ for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue
+ test -d "$ac_dir" || continue
+ ac_builddir=.
+
+case "$ac_dir" in
+.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
+*)
+ ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'`
+ # A ".." for each directory in $ac_dir_suffix.
+ ac_top_builddir_sub=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,/..,g;s,/,,'`
+ case $ac_top_builddir_sub in
+ "") ac_top_builddir_sub=. ac_top_build_prefix= ;;
+ *) ac_top_build_prefix=$ac_top_builddir_sub/ ;;
+ esac ;;
+esac
+ac_abs_top_builddir=$ac_pwd
+ac_abs_builddir=$ac_pwd$ac_dir_suffix
+# for backward compatibility:
+ac_top_builddir=$ac_top_build_prefix
+
+case $srcdir in
+ .) # We are building in place.
+ ac_srcdir=.
+ ac_top_srcdir=$ac_top_builddir_sub
+ ac_abs_top_srcdir=$ac_pwd ;;
+ [\\/]* | ?:[\\/]* ) # Absolute name.
+ ac_srcdir=$srcdir$ac_dir_suffix;
+ ac_top_srcdir=$srcdir
+ ac_abs_top_srcdir=$srcdir ;;
+ *) # Relative name.
+ ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix
+ ac_top_srcdir=$ac_top_build_prefix$srcdir
+ ac_abs_top_srcdir=$ac_pwd/$srcdir ;;
+esac
+ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix
+
+ cd "$ac_dir" || { ac_status=$?; continue; }
+ # Check for guested configure.
+ if test -f "$ac_srcdir/configure.gnu"; then
+ echo &&
+ $SHELL "$ac_srcdir/configure.gnu" --help=recursive
+ elif test -f "$ac_srcdir/configure"; then
+ echo &&
+ $SHELL "$ac_srcdir/configure" --help=recursive
+ else
+ echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2
+ fi || ac_status=$?
+ cd "$ac_pwd" || { ac_status=$?; break; }
+ done
+fi
+
+test -n "$ac_init_help" && exit $ac_status
+if $ac_init_version; then
+ cat <<\_ACEOF
+configure
+generated by GNU Autoconf 2.61
+
+Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
+2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+This configure script is free software; the Free Software Foundation
+gives unlimited permission to copy, distribute and modify it.
+_ACEOF
+ exit
+fi
+cat >config.log <<_ACEOF
+This file contains any messages produced by compilers while
+running configure, to aid debugging if configure makes a mistake.
+
+It was created by $as_me, which was
+generated by GNU Autoconf 2.61. Invocation command line was
+
+ $ $0 $@
+
+_ACEOF
+exec 5>>config.log
+{
+cat <<_ASUNAME
+## --------- ##
+## Platform. ##
+## --------- ##
+
+hostname = `(hostname || uname -n) 2>/dev/null | sed 1q`
+uname -m = `(uname -m) 2>/dev/null || echo unknown`
+uname -r = `(uname -r) 2>/dev/null || echo unknown`
+uname -s = `(uname -s) 2>/dev/null || echo unknown`
+uname -v = `(uname -v) 2>/dev/null || echo unknown`
+
+/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown`
+/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown`
+
+/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown`
+/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown`
+/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown`
+/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown`
+/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown`
+/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown`
+/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown`
+
+_ASUNAME
+
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ echo "PATH: $as_dir"
+done
+IFS=$as_save_IFS
+
+} >&5
+
+cat >&5 <<_ACEOF
+
+
+## ----------- ##
+## Core tests. ##
+## ----------- ##
+
+_ACEOF
+
+
+# Keep a trace of the command line.
+# Strip out --no-create and --no-recursion so they do not pile up.
+# Strip out --silent because we don't want to record it for future runs.
+# Also quote any args containing shell meta-characters.
+# Make two passes to allow for proper duplicate-argument suppression.
+ac_configure_args=
+ac_configure_args0=
+ac_configure_args1=
+ac_must_keep_next=false
+for ac_pass in 1 2
+do
+ for ac_arg
+ do
+ case $ac_arg in
+ -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;;
+ -q | -quiet | --quiet | --quie | --qui | --qu | --q \
+ | -silent | --silent | --silen | --sile | --sil)
+ continue ;;
+ *\'*)
+ ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
+ esac
+ case $ac_pass in
+ 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;;
+ 2)
+ ac_configure_args1="$ac_configure_args1 '$ac_arg'"
+ if test $ac_must_keep_next = true; then
+ ac_must_keep_next=false # Got value, back to normal.
+ else
+ case $ac_arg in
+ *=* | --config-cache | -C | -disable-* | --disable-* \
+ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \
+ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \
+ | -with-* | --with-* | -without-* | --without-* | --x)
+ case "$ac_configure_args0 " in
+ "$ac_configure_args1"*" '$ac_arg' "* ) continue ;;
+ esac
+ ;;
+ -* ) ac_must_keep_next=true ;;
+ esac
+ fi
+ ac_configure_args="$ac_configure_args '$ac_arg'"
+ ;;
+ esac
+ done
+done
+$as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; }
+$as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export ac_configure_args1; }
+
+# When interrupted or exit'd, cleanup temporary files, and complete
+# config.log. We remove comments because anyway the quotes in there
+# would cause problems or look ugly.
+# WARNING: Use '\'' to represent an apostrophe within the trap.
+# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug.
+trap 'exit_status=$?
+ # Save into config.log some information that might help in debugging.
+ {
+ echo
+
+ cat <<\_ASBOX
+## ---------------- ##
+## Cache variables. ##
+## ---------------- ##
+_ASBOX
+ echo
+ # The following way of writing the cache mishandles newlines in values,
+(
+ for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do
+ eval ac_val=\$$ac_var
+ case $ac_val in #(
+ *${as_nl}*)
+ case $ac_var in #(
+ *_cv_*) { echo "$as_me:$LINENO: WARNING: Cache variable $ac_var contains a newline." >&5
+echo "$as_me: WARNING: Cache variable $ac_var contains a newline." >&2;} ;;
+ esac
+ case $ac_var in #(
+ _ | IFS | as_nl) ;; #(
+ *) $as_unset $ac_var ;;
+ esac ;;
+ esac
+ done
+ (set) 2>&1 |
+ case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #(
+ *${as_nl}ac_space=\ *)
+ sed -n \
+ "s/'\''/'\''\\\\'\'''\''/g;
+ s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p"
+ ;; #(
+ *)
+ sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
+ ;;
+ esac |
+ sort
+)
+ echo
+
+ cat <<\_ASBOX
+## ----------------- ##
+## Output variables. ##
+## ----------------- ##
+_ASBOX
+ echo
+ for ac_var in $ac_subst_vars
+ do
+ eval ac_val=\$$ac_var
+ case $ac_val in
+ *\'\''*) ac_val=`echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
+ esac
+ echo "$ac_var='\''$ac_val'\''"
+ done | sort
+ echo
+
+ if test -n "$ac_subst_files"; then
+ cat <<\_ASBOX
+## ------------------- ##
+## File substitutions. ##
+## ------------------- ##
+_ASBOX
+ echo
+ for ac_var in $ac_subst_files
+ do
+ eval ac_val=\$$ac_var
+ case $ac_val in
+ *\'\''*) ac_val=`echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
+ esac
+ echo "$ac_var='\''$ac_val'\''"
+ done | sort
+ echo
+ fi
+
+ if test -s confdefs.h; then
+ cat <<\_ASBOX
+## ----------- ##
+## confdefs.h. ##
+## ----------- ##
+_ASBOX
+ echo
+ cat confdefs.h
+ echo
+ fi
+ test "$ac_signal" != 0 &&
+ echo "$as_me: caught signal $ac_signal"
+ echo "$as_me: exit $exit_status"
+ } >&5
+ rm -f core *.core core.conftest.* &&
+ rm -f -r conftest* confdefs* conf$$* $ac_clean_files &&
+ exit $exit_status
+' 0
+for ac_signal in 1 2 13 15; do
+ trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal
+done
+ac_signal=0
+
+# confdefs.h avoids OS command line length limits that DEFS can exceed.
+rm -f -r conftest* confdefs.h
+
+# Predefined preprocessor variables.
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_NAME "$PACKAGE_NAME"
+_ACEOF
+
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_TARNAME "$PACKAGE_TARNAME"
+_ACEOF
+
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_VERSION "$PACKAGE_VERSION"
+_ACEOF
+
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_STRING "$PACKAGE_STRING"
+_ACEOF
+
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT"
+_ACEOF
+
+
+# Let the site file select an alternate cache file if it wants to.
+# Prefer explicitly selected file to automatically selected ones.
+if test -n "$CONFIG_SITE"; then
+ set x "$CONFIG_SITE"
+elif test "x$prefix" != xNONE; then
+ set x "$prefix/share/config.site" "$prefix/etc/config.site"
+else
+ set x "$ac_default_prefix/share/config.site" \
+ "$ac_default_prefix/etc/config.site"
+fi
+shift
+for ac_site_file
+do
+ if test -r "$ac_site_file"; then
+ { echo "$as_me:$LINENO: loading site script $ac_site_file" >&5
+echo "$as_me: loading site script $ac_site_file" >&6;}
+ sed 's/^/| /' "$ac_site_file" >&5
+ . "$ac_site_file"
+ fi
+done
+
+if test -r "$cache_file"; then
+ # Some versions of bash will fail to source /dev/null (special
+ # files actually), so we avoid doing that.
+ if test -f "$cache_file"; then
+ { echo "$as_me:$LINENO: loading cache $cache_file" >&5
+echo "$as_me: loading cache $cache_file" >&6;}
+ case $cache_file in
+ [\\/]* | ?:[\\/]* ) . "$cache_file";;
+ *) . "./$cache_file";;
+ esac
+ fi
+else
+ { echo "$as_me:$LINENO: creating cache $cache_file" >&5
+echo "$as_me: creating cache $cache_file" >&6;}
+ >$cache_file
+fi
+
+# Check that the precious variables saved in the cache have kept the same
+# value.
+ac_cache_corrupted=false
+for ac_var in $ac_precious_vars; do
+ eval ac_old_set=\$ac_cv_env_${ac_var}_set
+ eval ac_new_set=\$ac_env_${ac_var}_set
+ eval ac_old_val=\$ac_cv_env_${ac_var}_value
+ eval ac_new_val=\$ac_env_${ac_var}_value
+ case $ac_old_set,$ac_new_set in
+ set,)
+ { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5
+echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;}
+ ac_cache_corrupted=: ;;
+ ,set)
+ { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5
+echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;}
+ ac_cache_corrupted=: ;;
+ ,);;
+ *)
+ if test "x$ac_old_val" != "x$ac_new_val"; then
+ { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5
+echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}
+ { echo "$as_me:$LINENO: former value: $ac_old_val" >&5
+echo "$as_me: former value: $ac_old_val" >&2;}
+ { echo "$as_me:$LINENO: current value: $ac_new_val" >&5
+echo "$as_me: current value: $ac_new_val" >&2;}
+ ac_cache_corrupted=:
+ fi;;
+ esac
+ # Pass precious variables to config.status.
+ if test "$ac_new_set" = set; then
+ case $ac_new_val in
+ *\'*) ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;;
+ *) ac_arg=$ac_var=$ac_new_val ;;
+ esac
+ case " $ac_configure_args " in
+ *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy.
+ *) ac_configure_args="$ac_configure_args '$ac_arg'" ;;
+ esac
+ fi
+done
+if $ac_cache_corrupted; then
+ { echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5
+echo "$as_me: error: changes in the environment can compromise the build" >&2;}
+ { { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5
+echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;}
+ { (exit 1); exit 1; }; }
+fi
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+
+
+ac_config_headers="$ac_config_headers config.h"
+
+
+# sm: require a late-enough autoconf; this is the version number
+# that's on manju, so I assume it's ok
+
+
+#
+# Assign here the CIL version numbers
+CIL_VERSION_MAJOR=1
+CIL_VERSION_MINOR=3
+CIL_VERSION_REV=6
+CIL_VERSION=$CIL_VERSION_MAJOR.$CIL_VERSION_MINOR.$CIL_VERSION_REV
+
+
+# make sure I haven't forgotten to run autoconf
+if test configure -ot configure.in; then
+ { { echo "$as_me:$LINENO: error: configure is older than configure.in; you forgot to run autoconf" >&5
+echo "$as_me: error: configure is older than configure.in; you forgot to run autoconf" >&2;}
+ { (exit 1); exit 1; }; }
+fi
+
+# check for C compiler; this typically finds gcc; it sets the
+# variable CC to whatever it finds, which then gets substituted
+# 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
+{ echo "$as_me:$LINENO: checking for $ac_word" >&5
+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }
+if test "${ac_cv_prog_CC+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_CC="${ac_tool_prefix}gcc"
+ echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+done
+IFS=$as_save_IFS
+
+fi
+fi
+CC=$ac_cv_prog_CC
+if test -n "$CC"; then
+ { echo "$as_me:$LINENO: result: $CC" >&5
+echo "${ECHO_T}$CC" >&6; }
+else
+ { echo "$as_me:$LINENO: result: no" >&5
+echo "${ECHO_T}no" >&6; }
+fi
+
+
+fi
+if test -z "$ac_cv_prog_CC"; then
+ ac_ct_CC=$CC
+ # Extract the first word of "gcc", so it can be a program name with args.
+set dummy gcc; ac_word=$2
+{ echo "$as_me:$LINENO: checking for $ac_word" >&5
+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }
+if test "${ac_cv_prog_ac_ct_CC+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_CC="gcc"
+ echo "$as_me:$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
+ { echo "$as_me:$LINENO: result: $ac_ct_CC" >&5
+echo "${ECHO_T}$ac_ct_CC" >&6; }
+else
+ { echo "$as_me:$LINENO: result: no" >&5
+echo "${ECHO_T}no" >&6; }
+fi
+
+ if test "x$ac_ct_CC" = x; then
+ CC=""
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ echo "$as_me:$LINENO: WARNING: In the future, Autoconf will not detect cross-tools
+whose name does not start with the host triplet. If you think this
+configuration is useful to you, please write to autoconf@gnu.org." >&5
+echo "$as_me: WARNING: In the future, Autoconf will not detect cross-tools
+whose name does not start with the host triplet. If you think this
+configuration is useful to you, please write to autoconf@gnu.org." >&2;}
+ac_tool_warned=yes ;;
+esac
+ CC=$ac_ct_CC
+ fi
+else
+ CC="$ac_cv_prog_CC"
+fi
+
+if test -z "$CC"; then
+ if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args.
+set dummy ${ac_tool_prefix}cc; ac_word=$2
+{ echo "$as_me:$LINENO: checking for $ac_word" >&5
+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }
+if test "${ac_cv_prog_CC+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_CC="${ac_tool_prefix}cc"
+ echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+done
+IFS=$as_save_IFS
+
+fi
+fi
+CC=$ac_cv_prog_CC
+if test -n "$CC"; then
+ { echo "$as_me:$LINENO: result: $CC" >&5
+echo "${ECHO_T}$CC" >&6; }
+else
+ { echo "$as_me:$LINENO: result: no" >&5
+echo "${ECHO_T}no" >&6; }
+fi
+
+
+ fi
+fi
+if test -z "$CC"; then
+ # Extract the first word of "cc", so it can be a program name with args.
+set dummy cc; ac_word=$2
+{ echo "$as_me:$LINENO: checking for $ac_word" >&5
+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }
+if test "${ac_cv_prog_CC+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ if test -n "$CC"; then
+ ac_cv_prog_CC="$CC" # Let the user override the test.
+else
+ ac_prog_rejected=no
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$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"
+ echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+done
+IFS=$as_save_IFS
+
+if test $ac_prog_rejected = yes; then
+ # We found a bogon in the path, so make sure we never use it.
+ set dummy $ac_cv_prog_CC
+ shift
+ if test $# != 0; then
+ # We chose a different compiler from the bogus one.
+ # However, it has the same basename, so the bogon will be chosen
+ # first if we set CC to just the basename; use the full file name.
+ shift
+ ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@"
+ fi
+fi
+fi
+fi
+CC=$ac_cv_prog_CC
+if test -n "$CC"; then
+ { echo "$as_me:$LINENO: result: $CC" >&5
+echo "${ECHO_T}$CC" >&6; }
+else
+ { echo "$as_me:$LINENO: result: no" >&5
+echo "${ECHO_T}no" >&6; }
+fi
+
+
+fi
+if test -z "$CC"; then
+ if test -n "$ac_tool_prefix"; then
+ for ac_prog in cl.exe
+ do
+ # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args.
+set dummy $ac_tool_prefix$ac_prog; ac_word=$2
+{ echo "$as_me:$LINENO: checking for $ac_word" >&5
+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }
+if test "${ac_cv_prog_CC+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_CC="$ac_tool_prefix$ac_prog"
+ echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+done
+IFS=$as_save_IFS
+
+fi
+fi
+CC=$ac_cv_prog_CC
+if test -n "$CC"; then
+ { echo "$as_me:$LINENO: result: $CC" >&5
+echo "${ECHO_T}$CC" >&6; }
+else
+ { echo "$as_me:$LINENO: result: no" >&5
+echo "${ECHO_T}no" >&6; }
+fi
+
+
+ test -n "$CC" && break
+ done
+fi
+if test -z "$CC"; then
+ ac_ct_CC=$CC
+ for ac_prog in cl.exe
+do
+ # Extract the first word of "$ac_prog", so it can be a program name with args.
+set dummy $ac_prog; ac_word=$2
+{ echo "$as_me:$LINENO: checking for $ac_word" >&5
+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }
+if test "${ac_cv_prog_ac_ct_CC+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_CC="$ac_prog"
+ echo "$as_me:$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
+ { echo "$as_me:$LINENO: result: $ac_ct_CC" >&5
+echo "${ECHO_T}$ac_ct_CC" >&6; }
+else
+ { echo "$as_me:$LINENO: result: no" >&5
+echo "${ECHO_T}no" >&6; }
+fi
+
+
+ test -n "$ac_ct_CC" && break
+done
+
+ if test "x$ac_ct_CC" = x; then
+ CC=""
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ echo "$as_me:$LINENO: WARNING: In the future, Autoconf will not detect cross-tools
+whose name does not start with the host triplet. If you think this
+configuration is useful to you, please write to autoconf@gnu.org." >&5
+echo "$as_me: WARNING: In the future, Autoconf will not detect cross-tools
+whose name does not start with the host triplet. If you think this
+configuration is useful to you, please write to autoconf@gnu.org." >&2;}
+ac_tool_warned=yes ;;
+esac
+ CC=$ac_ct_CC
+ fi
+fi
+
+fi
+
+
+test -z "$CC" && { { echo "$as_me:$LINENO: error: no acceptable C compiler found in \$PATH
+See \`config.log' for more details." >&5
+echo "$as_me: error: no acceptable C compiler found in \$PATH
+See \`config.log' for more details." >&2;}
+ { (exit 1); exit 1; }; }
+
+# Provide some information about the compiler.
+echo "$as_me:$LINENO: checking for C compiler version" >&5
+ac_compiler=`set X $ac_compile; echo $2`
+{ (ac_try="$ac_compiler --version >&5"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compiler --version >&5") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }
+{ (ac_try="$ac_compiler -v >&5"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compiler -v >&5") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }
+{ (ac_try="$ac_compiler -V >&5"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compiler -V >&5") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }
+
+cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+ac_clean_files_save=$ac_clean_files
+ac_clean_files="$ac_clean_files a.out a.exe b.out"
+# Try to create an executable without -o first, disregard a.out.
+# It will help us diagnose broken compilers, and finding out an intuition
+# of exeext.
+{ echo "$as_me:$LINENO: checking for C compiler default output file name" >&5
+echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6; }
+ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'`
+#
+# List of possible output files, starting from the most likely.
+# The algorithm is not robust to junk in `.', hence go to wildcards (a.*)
+# only as a last resort. b.out is created by i960 compilers.
+ac_files='a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out'
+#
+# The IRIX 6 linker writes into existing files which may not be
+# executable, retaining their permissions. Remove them first so a
+# subsequent execution test works.
+ac_rmfiles=
+for ac_file in $ac_files
+do
+ case $ac_file in
+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.o | *.obj ) ;;
+ * ) ac_rmfiles="$ac_rmfiles $ac_file";;
+ esac
+done
+rm -f $ac_rmfiles
+
+if { (ac_try="$ac_link_default"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_link_default") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; then
+ # Autoconf-2.13 could set the ac_cv_exeext variable to `no'.
+# So ignore a value of `no', otherwise this would lead to `EXEEXT = no'
+# in a Makefile. We should not override ac_cv_exeext if it was cached,
+# so that the user can short-circuit this test for compilers unknown to
+# Autoconf.
+for ac_file in $ac_files ''
+do
+ test -f "$ac_file" || continue
+ case $ac_file in
+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.o | *.obj )
+ ;;
+ [ab].out )
+ # We found the default executable, but exeext='' is most
+ # certainly right.
+ break;;
+ *.* )
+ if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no;
+ then :; else
+ ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
+ fi
+ # We set ac_cv_exeext here because the later test for it is not
+ # safe: cross compilers may not add the suffix if given an `-o'
+ # argument, so we may need to know it at that point already.
+ # Even if this section looks crufty: it has the advantage of
+ # actually working.
+ break;;
+ * )
+ break;;
+ esac
+done
+test "$ac_cv_exeext" = no && ac_cv_exeext=
+
+else
+ ac_file=''
+fi
+
+{ echo "$as_me:$LINENO: result: $ac_file" >&5
+echo "${ECHO_T}$ac_file" >&6; }
+if test -z "$ac_file"; then
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+{ { echo "$as_me:$LINENO: error: C compiler cannot create executables
+See \`config.log' for more details." >&5
+echo "$as_me: error: C compiler cannot create executables
+See \`config.log' for more details." >&2;}
+ { (exit 77); exit 77; }; }
+fi
+
+ac_exeext=$ac_cv_exeext
+
+# Check that the compiler produces executables we can run. If not, either
+# the compiler is broken, or we cross compile.
+{ echo "$as_me:$LINENO: checking whether the C compiler works" >&5
+echo $ECHO_N "checking whether the C compiler works... $ECHO_C" >&6; }
+# FIXME: These cross compiler hacks should be removed for Autoconf 3.0
+# If not cross compiling, check that we can run a simple program.
+if test "$cross_compiling" != yes; then
+ if { ac_try='./$ac_file'
+ { (case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_try") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; }; then
+ cross_compiling=no
+ else
+ if test "$cross_compiling" = maybe; then
+ cross_compiling=yes
+ else
+ { { echo "$as_me:$LINENO: error: cannot run C compiled programs.
+If you meant to cross compile, use \`--host'.
+See \`config.log' for more details." >&5
+echo "$as_me: error: cannot run C compiled programs.
+If you meant to cross compile, use \`--host'.
+See \`config.log' for more details." >&2;}
+ { (exit 1); exit 1; }; }
+ fi
+ fi
+fi
+{ echo "$as_me:$LINENO: result: yes" >&5
+echo "${ECHO_T}yes" >&6; }
+
+rm -f a.out a.exe conftest$ac_cv_exeext b.out
+ac_clean_files=$ac_clean_files_save
+# Check that the compiler produces executables we can run. If not, either
+# the compiler is broken, or we cross compile.
+{ echo "$as_me:$LINENO: checking whether we are cross compiling" >&5
+echo $ECHO_N "checking whether we are cross compiling... $ECHO_C" >&6; }
+{ echo "$as_me:$LINENO: result: $cross_compiling" >&5
+echo "${ECHO_T}$cross_compiling" >&6; }
+
+{ echo "$as_me:$LINENO: checking for suffix of executables" >&5
+echo $ECHO_N "checking for suffix of executables... $ECHO_C" >&6; }
+if { (ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_link") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; then
+ # If both `conftest.exe' and `conftest' are `present' (well, observable)
+# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will
+# work properly (i.e., refer to `conftest.exe'), while it won't with
+# `rm'.
+for ac_file in conftest.exe conftest conftest.*; do
+ test -f "$ac_file" || continue
+ case $ac_file in
+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.o | *.obj ) ;;
+ *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
+ break;;
+ * ) break;;
+ esac
+done
+else
+ { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link
+See \`config.log' for more details." >&5
+echo "$as_me: error: cannot compute suffix of executables: cannot compile and link
+See \`config.log' for more details." >&2;}
+ { (exit 1); exit 1; }; }
+fi
+
+rm -f conftest$ac_cv_exeext
+{ echo "$as_me:$LINENO: result: $ac_cv_exeext" >&5
+echo "${ECHO_T}$ac_cv_exeext" >&6; }
+
+rm -f conftest.$ac_ext
+EXEEXT=$ac_cv_exeext
+ac_exeext=$EXEEXT
+{ echo "$as_me:$LINENO: checking for suffix of object files" >&5
+echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6; }
+if test "${ac_cv_objext+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.o conftest.obj
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; then
+ for ac_file in conftest.o conftest.obj conftest.*; do
+ test -f "$ac_file" || continue;
+ case $ac_file in
+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf ) ;;
+ *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'`
+ break;;
+ esac
+done
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+{ { echo "$as_me:$LINENO: error: cannot compute suffix of object files: cannot compile
+See \`config.log' for more details." >&5
+echo "$as_me: error: cannot compute suffix of object files: cannot compile
+See \`config.log' for more details." >&2;}
+ { (exit 1); exit 1; }; }
+fi
+
+rm -f conftest.$ac_cv_objext conftest.$ac_ext
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_objext" >&5
+echo "${ECHO_T}$ac_cv_objext" >&6; }
+OBJEXT=$ac_cv_objext
+ac_objext=$OBJEXT
+{ echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5
+echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6; }
+if test "${ac_cv_c_compiler_gnu+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+int
+main ()
+{
+#ifndef __GNUC__
+ choke me
+#endif
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ ac_compiler_gnu=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_compiler_gnu=no
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ac_cv_c_compiler_gnu=$ac_compiler_gnu
+
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5
+echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6; }
+GCC=`test $ac_compiler_gnu = yes && echo yes`
+ac_test_CFLAGS=${CFLAGS+set}
+ac_save_CFLAGS=$CFLAGS
+{ echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5
+echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6; }
+if test "${ac_cv_prog_cc_g+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ ac_save_c_werror_flag=$ac_c_werror_flag
+ ac_c_werror_flag=yes
+ ac_cv_prog_cc_g=no
+ CFLAGS="-g"
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ ac_cv_prog_cc_g=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ CFLAGS=""
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ :
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_c_werror_flag=$ac_save_c_werror_flag
+ CFLAGS="-g"
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ ac_cv_prog_cc_g=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ ac_c_werror_flag=$ac_save_c_werror_flag
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5
+echo "${ECHO_T}$ac_cv_prog_cc_g" >&6; }
+if test "$ac_test_CFLAGS" = set; then
+ CFLAGS=$ac_save_CFLAGS
+elif test $ac_cv_prog_cc_g = yes; then
+ if test "$GCC" = yes; then
+ CFLAGS="-g -O2"
+ else
+ CFLAGS="-g"
+ fi
+else
+ if test "$GCC" = yes; then
+ CFLAGS="-O2"
+ else
+ CFLAGS=
+ fi
+fi
+{ echo "$as_me:$LINENO: checking for $CC option to accept ISO C89" >&5
+echo $ECHO_N "checking for $CC option to accept ISO C89... $ECHO_C" >&6; }
+if test "${ac_cv_prog_cc_c89+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ ac_cv_prog_cc_c89=no
+ac_save_CC=$CC
+cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <stdarg.h>
+#include <stdio.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */
+struct buf { int x; };
+FILE * (*rcsopen) (struct buf *, struct stat *, int);
+static char *e (p, i)
+ char **p;
+ int i;
+{
+ return p[i];
+}
+static char *f (char * (*g) (char **, int), char **p, ...)
+{
+ char *s;
+ va_list v;
+ va_start (v,p);
+ s = g (p, va_arg (v,int));
+ va_end (v);
+ return s;
+}
+
+/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has
+ function prototypes and stuff, but not '\xHH' hex character constants.
+ These don't provoke an error unfortunately, instead are silently treated
+ as 'x'. The following induces an error, until -std is added to get
+ proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an
+ array size at least. It's necessary to write '\x00'==0 to get something
+ that's true only with -std. */
+int osf4_cc_array ['\x00' == 0 ? 1 : -1];
+
+/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters
+ inside strings and character constants. */
+#define FOO(x) 'x'
+int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1];
+
+int test (int i, double x);
+struct s1 {int (*f) (int a);};
+struct s2 {int (*f) (double a);};
+int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int);
+int argc;
+char **argv;
+int
+main ()
+{
+return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1];
+ ;
+ return 0;
+}
+_ACEOF
+for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \
+ -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__"
+do
+ CC="$ac_save_CC $ac_arg"
+ rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ ac_cv_prog_cc_c89=$ac_arg
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext
+ test "x$ac_cv_prog_cc_c89" != "xno" && break
+done
+rm -f conftest.$ac_ext
+CC=$ac_save_CC
+
+fi
+# AC_CACHE_VAL
+case "x$ac_cv_prog_cc_c89" in
+ x)
+ { echo "$as_me:$LINENO: result: none needed" >&5
+echo "${ECHO_T}none needed" >&6; } ;;
+ xno)
+ { echo "$as_me:$LINENO: result: unsupported" >&5
+echo "${ECHO_T}unsupported" >&6; } ;;
+ *)
+ CC="$CC $ac_cv_prog_cc_c89"
+ { echo "$as_me:$LINENO: result: $ac_cv_prog_cc_c89" >&5
+echo "${ECHO_T}$ac_cv_prog_cc_c89" >&6; } ;;
+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
+
+
+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
+ { { echo "$as_me:$LINENO: error: cannot find install-sh or install.sh in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" >&5
+echo "$as_me: error: cannot find install-sh or install.sh in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" >&2;}
+ { (exit 1); exit 1; }; }
+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
+# incompatible versions:
+# SysV /etc/install, /usr/sbin/install
+# SunOS /usr/etc/install
+# IRIX /sbin/install
+# AIX /bin/install
+# AmigaOS /C/install, which installs bootblocks on floppy discs
+# AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag
+# AFS /usr/afsws/bin/install, which mishandles nonexistent args
+# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff"
+# OS/2's system install, which has a completely different semantic
+# ./install, which can be erroneously created by make from ./install.sh.
+{ echo "$as_me:$LINENO: checking for a BSD-compatible install" >&5
+echo $ECHO_N "checking for a BSD-compatible install... $ECHO_C" >&6; }
+if test -z "$INSTALL"; then
+if test "${ac_cv_path_install+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ # Account for people who put trailing slashes in PATH elements.
+case $as_dir/ in
+ ./ | .// | /cC/* | \
+ /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \
+ ?:\\/os2\\/install\\/* | ?:\\/OS2\\/INSTALL\\/* | \
+ /usr/ucb/* ) ;;
+ *)
+ # OSF1 and SCO ODT 3.0 have their own names for install.
+ # Don't use installbsd from OSF since it installs stuff as root
+ # by default.
+ for ac_prog in ginstall scoinst install; do
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; }; then
+ if test $ac_prog = install &&
+ grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then
+ # AIX install. It has an incompatible calling convention.
+ :
+ elif test $ac_prog = install &&
+ grep pwplus "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then
+ # program-specific install script used by HP pwplus--don't use.
+ :
+ else
+ ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c"
+ break 3
+ fi
+ fi
+ done
+ done
+ ;;
+esac
+done
+IFS=$as_save_IFS
+
+
+fi
+ if test "${ac_cv_path_install+set}" = set; then
+ INSTALL=$ac_cv_path_install
+ else
+ # As a last resort, use the slow shell script. Don't cache a
+ # value for INSTALL within a source directory, because that will
+ # break other packages using the cache if that directory is
+ # removed, or if the value is a relative name.
+ INSTALL=$ac_install_sh
+ fi
+fi
+{ echo "$as_me:$LINENO: result: $INSTALL" >&5
+echo "${ECHO_T}$INSTALL" >&6; }
+
+# Use test -z because SunOS4 sh mishandles braces in ${var-val}.
+# It thinks the first close brace ends the variable substitution.
+test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}'
+
+test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}'
+
+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 ||
+ { { echo "$as_me:$LINENO: error: cannot run $SHELL $ac_aux_dir/config.sub" >&5
+echo "$as_me: error: cannot run $SHELL $ac_aux_dir/config.sub" >&2;}
+ { (exit 1); exit 1; }; }
+
+{ echo "$as_me:$LINENO: checking build system type" >&5
+echo $ECHO_N "checking build system type... $ECHO_C" >&6; }
+if test "${ac_cv_build+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&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 &&
+ { { echo "$as_me:$LINENO: error: cannot guess build type; you must specify one" >&5
+echo "$as_me: error: cannot guess build type; you must specify one" >&2;}
+ { (exit 1); exit 1; }; }
+ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` ||
+ { { echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $ac_build_alias failed" >&5
+echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $ac_build_alias failed" >&2;}
+ { (exit 1); exit 1; }; }
+
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_build" >&5
+echo "${ECHO_T}$ac_cv_build" >&6; }
+case $ac_cv_build in
+*-*-*) ;;
+*) { { echo "$as_me:$LINENO: error: invalid value of canonical build" >&5
+echo "$as_me: error: invalid value of canonical build" >&2;}
+ { (exit 1); exit 1; }; };;
+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
+
+
+{ echo "$as_me:$LINENO: checking host system type" >&5
+echo $ECHO_N "checking host system type... $ECHO_C" >&6; }
+if test "${ac_cv_host+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&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` ||
+ { { echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $host_alias failed" >&5
+echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $host_alias failed" >&2;}
+ { (exit 1); exit 1; }; }
+fi
+
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_host" >&5
+echo "${ECHO_T}$ac_cv_host" >&6; }
+case $ac_cv_host in
+*-*-*) ;;
+*) { { echo "$as_me:$LINENO: error: invalid value of canonical host" >&5
+echo "$as_me: error: invalid value of canonical host" >&2;}
+ { (exit 1); exit 1; }; };;
+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
+
+
+{ echo "$as_me:$LINENO: checking target system type" >&5
+echo $ECHO_N "checking target system type... $ECHO_C" >&6; }
+if test "${ac_cv_target+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ if test "x$target_alias" = x; then
+ ac_cv_target=$ac_cv_host
+else
+ ac_cv_target=`$SHELL "$ac_aux_dir/config.sub" $target_alias` ||
+ { { echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $target_alias failed" >&5
+echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $target_alias failed" >&2;}
+ { (exit 1); exit 1; }; }
+fi
+
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_target" >&5
+echo "${ECHO_T}$ac_cv_target" >&6; }
+case $ac_cv_target in
+*-*-*) ;;
+*) { { echo "$as_me:$LINENO: error: invalid value of canonical target" >&5
+echo "$as_me: error: invalid value of canonical target" >&2;}
+ { (exit 1); exit 1; }; };;
+esac
+target=$ac_cv_target
+ac_save_IFS=$IFS; IFS='-'
+set x $ac_cv_target
+shift
+target_cpu=$1
+target_vendor=$2
+shift; shift
+# Remember, the first character of IFS is used to create $*,
+# except with old shells:
+target_os=$*
+IFS=$ac_save_IFS
+case $target_os in *\ *) target_os=`echo "$target_os" | sed 's/ /-/g'`;; esac
+
+
+# The aliases save the names the user supplied, while $host etc.
+# will get canonicalized.
+test -n "$target_alias" &&
+ test "$program_prefix$program_suffix$program_transform_name" = \
+ NONENONEs,x,x, &&
+ program_prefix=${target_alias}-
+
+
+# ---------------- generic functions -----------------
+# debugging diagnostic; set to 'echo' to debug or 'true' for production
+# (technically you're not supposed to use shell functions in
+# configure scripts, because some-obscure-sh somewhere doesn't
+# support them.. but they're too convenient to not use)
+diagnostic() {
+ #echo "$@"
+ true "$@"
+}
+
+# determine if a binary is in the path
+binaryExists() {
+ # on cygwin, 'which' always returns success, so use 'type' instead
+ if type "$1" >/dev/null 2>&1; then
+ return 0
+ else
+ return 1
+ fi
+}
+
+
+# -------------- portable configuration ----------------
+# this specifies the root of the source tree; it's just the
+# directory where ./configure runs, except on cygwin, which
+# overrides this below
+CILHOME=`pwd`
+
+DEFAULT_COMPILER=_GNUCC
+DEFAULT_CIL_MODE=GNUCC
+
+# is the microsoft compiler available?
+# hmm.. I think we should check the version or something, because
+# sometimes people have Common Lisp's interpreter called 'cl' ..
+{ echo "$as_me:$LINENO: checking for msvc cl.exe (optional)" >&5
+echo $ECHO_N "checking for msvc cl.exe (optional)... $ECHO_C" >&6; }
+# See if CC points to the MS compiler
+if "$CC" 2>&1 | grep "Microsoft" >/dev/null; then
+ { echo "$as_me:$LINENO: result: found, set as default" >&5
+echo "${ECHO_T}found, set as default" >&6; }
+ HAS_MSVC=yes
+ DEFAULT_COMPILER=_MSVC
+ DEFAULT_CIL_MODE=MSVC
+else
+ if cl 2>&1 | grep "Microsoft" >/dev/null ;then
+ { echo "$as_me:$LINENO: result: found" >&5
+echo "${ECHO_T}found" >&6; }
+ HAS_MSVC=yes
+ else
+ { echo "$as_me:$LINENO: result: not found" >&5
+echo "${ECHO_T}not found" >&6; }
+ HAS_MSVC=no
+ fi
+fi
+
+# is ocaml available?
+# needed binaries: ocamllex ocamlyacc ocamldep ocamlopt ocamlc
+ocamlDownloadInstructions="
+ OCaml can be downloaded from http://caml.inria.fr/ocaml/.
+ After downloading and unpacking the source distribution, in the ocaml
+ directory, do
+ ./configure
+ make world
+ make opt
+ make install
+ Then come back here and re-run ./configure."
+
+# required major/minor.
+# required major/minor
+reqMaj=3
+reqMin=08
+knownMaj=3
+knownMin=10
+{ echo "$as_me:$LINENO: checking ocaml version is at least $reqMaj.$reqMin" >&5
+echo $ECHO_N "checking ocaml version is at least $reqMaj.$reqMin... $ECHO_C" >&6; }
+if binaryExists ocamlc; then
+ # what version?
+ ver=`ocamlc -v | grep version | sed 's/^.*version //'`
+ diagnostic "ver is $ver"
+ # major: anything before the .
+ major=`echo $ver | sed 's/\..*$//'`
+ diagnostic "major is $major"
+ # minor: numbers after the .
+ # (the outer level of bracket-quotation protects the inner brackets)
+ minor=`echo $ver | sed 's/^[^.]*\.\([0-9][0-9]*\).*$/\1/'`
+ diagnostic "minor is $minor"
+
+ # I would think autoconf would already have a facility for doing
+ # these kinds of major/minor version checks, but I can't find it
+ if test $major -gt $reqMaj -o $major -ge $reqMaj -a $minor -ge $reqMin; then
+ { echo "$as_me:$LINENO: result: version is $ver, ok" >&5
+echo "${ECHO_T}version is $ver, ok" >&6; }
+
+ # sm: added this test when we found that CCured needed to be changed
+ # a little when 3.06 came out (it had previously worked with 3.04)
+ if test "$major" -gt $knownMaj -o "$major" -ge $knownMaj -a "$minor" -gt $knownMin; then
+ { echo "$as_me:$LINENO: WARNING: Your ocaml version is $ver, but the latest version this program
+ is known to work with is $knownMaj.$knownMin. If you have
+ trouble compiling, please try using an earlier version
+ or see if there is a later version of this program." >&5
+echo "$as_me: WARNING: Your ocaml version is $ver, but the latest version this program
+ is known to work with is $knownMaj.$knownMin. If you have
+ trouble compiling, please try using an earlier version
+ or see if there is a later version of this program." >&2;}
+ fi
+ else
+ { { echo "$as_me:$LINENO: error:
+ I found OCaml version $ver; this program requires at least $reqMaj.$reqMin.
+ Please download a newer OCaml distribution.
+ $ocamlDownloadInstructions
+ " >&5
+echo "$as_me: error:
+ I found OCaml version $ver; this program requires at least $reqMaj.$reqMin.
+ Please download a newer OCaml distribution.
+ $ocamlDownloadInstructions
+ " >&2;}
+ { (exit 1); exit 1; }; }
+ fi
+
+ # check for existence of other binaries
+ { echo "$as_me:$LINENO: checking existence of related ocaml tools" >&5
+echo $ECHO_N "checking existence of related ocaml tools... $ECHO_C" >&6; }
+ if binaryExists ocamllex && \
+ binaryExists ocamlyacc && \
+ binaryExists ocamldep && \
+ binaryExists ocamlopt; then
+ { echo "$as_me:$LINENO: result: ok" >&5
+echo "${ECHO_T}ok" >&6; }
+ else
+ { { echo "$as_me:$LINENO: error:
+ At least one of ocamllex, ocamlyacc, ocamldep or ocamlopt is missing.
+ In particular, ocamlopt requires you to \"make opt\" when building
+ OCaml from source. Please make sure all these tools are built and
+ in the path.
+ " >&5
+echo "$as_me: error:
+ At least one of ocamllex, ocamlyacc, ocamldep or ocamlopt is missing.
+ In particular, ocamlopt requires you to \"make opt\" when building
+ OCaml from source. Please make sure all these tools are built and
+ in the path.
+ " >&2;}
+ { (exit 1); exit 1; }; }
+ fi
+else
+ { { echo "$as_me:$LINENO: error:
+ The \"ocamlc\" OCaml compiler was not found in the path: $PATH.
+
+ Most of this program is written in the OCaml language, so its compiler
+ is required.
+ $ocamlDownloadInstructions
+ " >&5
+echo "$as_me: error:
+ The \"ocamlc\" OCaml compiler was not found in the path: $PATH.
+
+ Most of this program is written in the OCaml language, so its compiler
+ is required.
+ $ocamlDownloadInstructions
+ " >&2;}
+ { (exit 1); exit 1; }; }
+fi
+
+#
+# ------------------- Perl ----------------
+#
+{ echo "$as_me:$LINENO: checking for Perl" >&5
+echo $ECHO_N "checking for Perl... $ECHO_C" >&6; }
+ if ! binaryExists perl; then
+ { { echo "$as_me:$LINENO: error:
+ perl not found.
+ You need perl version 5.6.1 or later for CIL.
+ You can get perl at http://www.cpan.org/src/index.html .
+ " >&5
+echo "$as_me: error:
+ perl not found.
+ You need perl version 5.6.1 or later for CIL.
+ You can get perl at http://www.cpan.org/src/index.html .
+ " >&2;}
+ { (exit 1); exit 1; }; }
+ fi
+
+ # sm: oh how nice it would be to just say "use English;
+ # print($PERL_VERSION)", but that appears broken on 5.6.1.. so I'm
+ # trying to say "caret right-bracket", but then that would run afoul
+ # of autoconf's quoting characters, so I use the "quadrigraph" ]
+ # to stand for right-bracket. what a mess.
+ perlver=`perl -e 'print($]);'`
+ if perl -e "exit( $perlver >= 5.006001 );"; then
+ { { echo "$as_me:$LINENO: error:
+ Found perl version $perlver, but at least 5.6.1 is required.
+ You can get a newer perl at http://www.cpan.org/src/index.html .
+ " >&5
+echo "$as_me: error:
+ Found perl version $perlver, but at least 5.6.1 is required.
+ You can get a newer perl at http://www.cpan.org/src/index.html .
+ " >&2;}
+ { (exit 1); exit 1; }; }
+ fi
+
+ perlport=`perl -e "print $^O;"`
+ case "$perlport" in
+ cygwin)
+ ;;
+ MSWin32) # ActivePerl
+ ;;
+ linux)
+ ;;
+ freebsd)
+ ;;
+ openbsd)
+ ;;
+ darwin) # Mac OS X
+ ;;
+ solaris)
+ ;;
+ *)
+ { { echo "$as_me:$LINENO: error:
+ Unsupported Perl port $perlport -- sorry.
+ cygwin, MSWin32 (ActivePerl), linux, freebsd, openbsd, darwin,
+ and solaris are the supported ports.
+ " >&5
+echo "$as_me: error:
+ Unsupported Perl port $perlport -- sorry.
+ cygwin, MSWin32 (ActivePerl), linux, freebsd, openbsd, darwin,
+ and solaris are the supported ports.
+ " >&2;}
+ { (exit 1); exit 1; }; }
+ esac
+{ echo "$as_me:$LINENO: result: found version $perlver, port $perlport" >&5
+echo "${ECHO_T}found version $perlver, port $perlport" >&6; }
+
+ # The cygwin port has some bugs in the File::Spec module
+if test "$perlport" = "cygwin" ;then
+ { echo "$as_me:$LINENO: checking for known cygwin Perl bug in File::Spec" >&5
+echo $ECHO_N "checking for known cygwin Perl bug in File::Spec... $ECHO_C" >&6; }
+ perlfixres=`perl -e '
+ use File::Spec;
+ if(File::Spec->file_name_is_absolute("C:/test")) {
+ print "no bug found"; exit 0;
+ } else {
+ print "bug";
+ foreach $d (@INC) {
+ if(-f "$d/File/Spec/Unix.pm") {
+ open(IN, "<$d/File/Spec/Unix.pm");
+ open(OUT, ">$d/File/Spec/Unix.pm.fixed")
+ || die "Cannot open $d/File/Spec/Unix.pm.fixed";
+ while(<IN>) {
+ if($_ =~ m|sub file_name_is_absolute|) {
+ print OUT $_;
+ print OUT scalar(<IN>);
+ print OUT <<EOF;
+ if(\\$^O eq \"cygwin\") {
+ return scalar(\\$file =~ m{^(\\[a-z\\]:)?\\[\\\\\\\\/\\]}is);
+};
+EOF
+ next;
+ }
+ print OUT $_;
+ }
+ close(OUT);
+ close(IN);
+ system("mv -f $d/File/Spec/Unix.pm.fixed $d/File/Spec/Unix.pm");
+ }
+ }
+ }
+ '`
+ # See if it was indeed fixed
+ if test "$perlfixres" = "bug" ;then
+ perlfixres=`perl -e '
+ use File::Spec;
+ if(File::Spec->file_name_is_absolute("C:/test")) {
+ print "bug fixed"; exit 0;
+ } else {
+ print "cannot fix bug"; exit 1;
+ }'`
+ fi
+ if test "x$perlfixres" = "x" ;then
+ { { echo "$as_me:$LINENO: error:
+ Cannot run perl
+ " >&5
+echo "$as_me: error:
+ Cannot run perl
+ " >&2;}
+ { (exit 1); exit 1; }; }
+ elif test "$perlfixres" = "cannot fix bug" ;then
+ { { echo "$as_me:$LINENO: error:
+ Found a bug but cannot fix it.
+ " >&5
+echo "$as_me: error:
+ Found a bug but cannot fix it.
+ " >&2;}
+ { (exit 1); exit 1; }; }
+ else
+ { echo "$as_me:$LINENO: result: $perlfixres" >&5
+echo "${ECHO_T}$perlfixres" >&6; }
+ fi
+fi
+
+#
+# Now setup the performance counters
+#
+# At runtime, we'll try to get the cycle speed from /proc/cpuinfo
+# or FreeBSD sysctl. This means binaries can be moved to different computers.
+# CYCLES_PER_USEC is only a backup in case these aren't available.
+# (See the subversion history for the old code that read /proc/cpuinfo here.)
+{ echo "$as_me:$LINENO: checking if performance counters are usable" >&5
+echo $ECHO_N "checking if performance counters are usable... $ECHO_C" >&6; }
+# Create a C file from src/perfcount.c.in
+rm -f ./cycles.exe
+if gcc -DCONFIGURATION_ONLY \
+ -x c ocamlutil/perfcount.c.in -lm -o ./cycles.exe >/dev/null 2>&1; then
+
+ if CYCLES_PER_USEC=`./cycles.exe 2>&1` ;then
+ { echo "$as_me:$LINENO: result: ok ($CYCLES_PER_USEC cycles per us)" >&5
+echo "${ECHO_T}ok ($CYCLES_PER_USEC cycles per us)" >&6; }
+ else
+ # Print what we got
+ { echo "$as_me:$LINENO: result: no ($CYCLES_PER_USEC)" >&5
+echo "${ECHO_T}no ($CYCLES_PER_USEC)" >&6; }
+ CYCLES_PER_USEC=0
+ fi
+else
+ CYCLES_PER_USEC=0
+ { echo "$as_me:$LINENO: result: no (cannot compile perfcount.c)" >&5
+echo "${ECHO_T}no (cannot compile perfcount.c)" >&6; }
+fi
+rm -f ./cycles.exe
+
+if test "$CYCLES_PER_USEC" != "0" ;then
+ HAS_PERFCOUNT=1
+else
+ HAS_PERFCOUNT=0
+fi
+
+# additional tools we might check for:
+# - gnu make
+
+#
+# -------------------- GCC --------------
+#
+
+{ echo "$as_me:$LINENO: checking for gcc version" >&5
+echo $ECHO_N "checking for gcc version... $ECHO_C" >&6; }
+
+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
+{ echo "$as_me:$LINENO: checking how to run the C preprocessor" >&5
+echo $ECHO_N "checking how to run the C preprocessor... $ECHO_C" >&6; }
+# On Suns, sometimes $CPP names a directory.
+if test -n "$CPP" && test -d "$CPP"; then
+ CPP=
+fi
+if test -z "$CPP"; then
+ if test "${ac_cv_prog_CPP+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ # Double quotes because CPP needs to be expanded
+ for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp"
+ do
+ ac_preproc_ok=false
+for ac_c_preproc_warn_flag in '' yes
+do
+ # Use a header file that comes with gcc, so configuring glibc
+ # with a fresh cross-compiler works.
+ # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
+ # <limits.h> exists even on freestanding compilers.
+ # On the NeXT, cc -E runs the code through the compiler's parser,
+ # not just through cpp. "Syntax error" is here to catch this case.
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#ifdef __STDC__
+# include <limits.h>
+#else
+# include <assert.h>
+#endif
+ Syntax error
+_ACEOF
+if { (ac_try="$ac_cpp conftest.$ac_ext"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } >/dev/null && {
+ test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ }; then
+ :
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ # Broken: fails on valid input.
+continue
+fi
+
+rm -f conftest.err conftest.$ac_ext
+
+ # OK, works on sane cases. Now check whether nonexistent headers
+ # can be detected and how.
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <ac_nonexistent.h>
+_ACEOF
+if { (ac_try="$ac_cpp conftest.$ac_ext"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } >/dev/null && {
+ test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ }; then
+ # Broken: success on invalid input.
+continue
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ # Passes both tests.
+ac_preproc_ok=:
+break
+fi
+
+rm -f conftest.err conftest.$ac_ext
+
+done
+# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped.
+rm -f conftest.err conftest.$ac_ext
+if $ac_preproc_ok; then
+ break
+fi
+
+ done
+ ac_cv_prog_CPP=$CPP
+
+fi
+ CPP=$ac_cv_prog_CPP
+else
+ ac_cv_prog_CPP=$CPP
+fi
+{ echo "$as_me:$LINENO: result: $CPP" >&5
+echo "${ECHO_T}$CPP" >&6; }
+ac_preproc_ok=false
+for ac_c_preproc_warn_flag in '' yes
+do
+ # Use a header file that comes with gcc, so configuring glibc
+ # with a fresh cross-compiler works.
+ # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
+ # <limits.h> exists even on freestanding compilers.
+ # On the NeXT, cc -E runs the code through the compiler's parser,
+ # not just through cpp. "Syntax error" is here to catch this case.
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#ifdef __STDC__
+# include <limits.h>
+#else
+# include <assert.h>
+#endif
+ Syntax error
+_ACEOF
+if { (ac_try="$ac_cpp conftest.$ac_ext"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } >/dev/null && {
+ test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ }; then
+ :
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ # Broken: fails on valid input.
+continue
+fi
+
+rm -f conftest.err conftest.$ac_ext
+
+ # OK, works on sane cases. Now check whether nonexistent headers
+ # can be detected and how.
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <ac_nonexistent.h>
+_ACEOF
+if { (ac_try="$ac_cpp conftest.$ac_ext"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } >/dev/null && {
+ test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ }; then
+ # Broken: success on invalid input.
+continue
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ # Passes both tests.
+ac_preproc_ok=:
+break
+fi
+
+rm -f conftest.err conftest.$ac_ext
+
+done
+# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped.
+rm -f conftest.err conftest.$ac_ext
+if $ac_preproc_ok; then
+ :
+else
+ { { echo "$as_me:$LINENO: error: C preprocessor \"$CPP\" fails sanity check
+See \`config.log' for more details." >&5
+echo "$as_me: error: C preprocessor \"$CPP\" fails sanity check
+See \`config.log' for more details." >&2;}
+ { (exit 1); exit 1; }; }
+fi
+
+ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+
+
+{ echo "$as_me:$LINENO: checking for grep that handles long lines and -e" >&5
+echo $ECHO_N "checking for grep that handles long lines and -e... $ECHO_C" >&6; }
+if test "${ac_cv_path_GREP+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ # Extract the first word of "grep ggrep" to use in msg output
+if test -z "$GREP"; then
+set dummy grep ggrep; ac_prog_name=$2
+if test "${ac_cv_path_GREP+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ ac_path_GREP_found=false
+# Loop through the user's path and test for each of PROGNAME-LIST
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_prog in grep ggrep; do
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext"
+ { test -f "$ac_path_GREP" && $as_test_x "$ac_path_GREP"; } || continue
+ # Check for GNU ac_path_GREP and select it if it is found.
+ # Check for GNU $ac_path_GREP
+case `"$ac_path_GREP" --version 2>&1` in
+*GNU*)
+ ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;;
+*)
+ ac_count=0
+ echo $ECHO_N "0123456789$ECHO_C" >"conftest.in"
+ while :
+ do
+ cat "conftest.in" "conftest.in" >"conftest.tmp"
+ mv "conftest.tmp" "conftest.in"
+ cp "conftest.in" "conftest.nl"
+ echo 'GREP' >> "conftest.nl"
+ "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break
+ diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break
+ ac_count=`expr $ac_count + 1`
+ if test $ac_count -gt ${ac_path_GREP_max-0}; then
+ # Best one so far, save it but keep looking for a better one
+ ac_cv_path_GREP="$ac_path_GREP"
+ ac_path_GREP_max=$ac_count
+ fi
+ # 10*(2^10) chars as input seems more than enough
+ test $ac_count -gt 10 && break
+ done
+ rm -f conftest.in conftest.tmp conftest.nl conftest.out;;
+esac
+
+
+ $ac_path_GREP_found && break 3
+ done
+done
+
+done
+IFS=$as_save_IFS
+
+
+fi
+
+GREP="$ac_cv_path_GREP"
+if test -z "$GREP"; then
+ { { echo "$as_me:$LINENO: error: no acceptable $ac_prog_name could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&5
+echo "$as_me: error: no acceptable $ac_prog_name could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&2;}
+ { (exit 1); exit 1; }; }
+fi
+
+else
+ ac_cv_path_GREP=$GREP
+fi
+
+
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_path_GREP" >&5
+echo "${ECHO_T}$ac_cv_path_GREP" >&6; }
+ GREP="$ac_cv_path_GREP"
+
+
+{ echo "$as_me:$LINENO: checking for egrep" >&5
+echo $ECHO_N "checking for egrep... $ECHO_C" >&6; }
+if test "${ac_cv_path_EGREP+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ if echo a | $GREP -E '(a|b)' >/dev/null 2>&1
+ then ac_cv_path_EGREP="$GREP -E"
+ else
+ # Extract the first word of "egrep" to use in msg output
+if test -z "$EGREP"; then
+set dummy egrep; ac_prog_name=$2
+if test "${ac_cv_path_EGREP+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ ac_path_EGREP_found=false
+# Loop through the user's path and test for each of PROGNAME-LIST
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_prog in egrep; do
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext"
+ { test -f "$ac_path_EGREP" && $as_test_x "$ac_path_EGREP"; } || continue
+ # Check for GNU ac_path_EGREP and select it if it is found.
+ # Check for GNU $ac_path_EGREP
+case `"$ac_path_EGREP" --version 2>&1` in
+*GNU*)
+ ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;;
+*)
+ ac_count=0
+ echo $ECHO_N "0123456789$ECHO_C" >"conftest.in"
+ while :
+ do
+ cat "conftest.in" "conftest.in" >"conftest.tmp"
+ mv "conftest.tmp" "conftest.in"
+ cp "conftest.in" "conftest.nl"
+ echo 'EGREP' >> "conftest.nl"
+ "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break
+ diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break
+ ac_count=`expr $ac_count + 1`
+ if test $ac_count -gt ${ac_path_EGREP_max-0}; then
+ # Best one so far, save it but keep looking for a better one
+ ac_cv_path_EGREP="$ac_path_EGREP"
+ ac_path_EGREP_max=$ac_count
+ fi
+ # 10*(2^10) chars as input seems more than enough
+ test $ac_count -gt 10 && break
+ done
+ rm -f conftest.in conftest.tmp conftest.nl conftest.out;;
+esac
+
+
+ $ac_path_EGREP_found && break 3
+ done
+done
+
+done
+IFS=$as_save_IFS
+
+
+fi
+
+EGREP="$ac_cv_path_EGREP"
+if test -z "$EGREP"; then
+ { { echo "$as_me:$LINENO: error: no acceptable $ac_prog_name could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&5
+echo "$as_me: error: no acceptable $ac_prog_name could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&2;}
+ { (exit 1); exit 1; }; }
+fi
+
+else
+ ac_cv_path_EGREP=$EGREP
+fi
+
+
+ fi
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_path_EGREP" >&5
+echo "${ECHO_T}$ac_cv_path_EGREP" >&6; }
+ EGREP="$ac_cv_path_EGREP"
+
+
+{ echo "$as_me:$LINENO: checking for ANSI C header files" >&5
+echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6; }
+if test "${ac_cv_header_stdc+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <stdlib.h>
+#include <stdarg.h>
+#include <string.h>
+#include <float.h>
+
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ ac_cv_header_stdc=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_cv_header_stdc=no
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+
+if test $ac_cv_header_stdc = yes; then
+ # SunOS 4.x string.h does not declare mem*, contrary to ANSI.
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <string.h>
+
+_ACEOF
+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
+ $EGREP "memchr" >/dev/null 2>&1; then
+ :
+else
+ ac_cv_header_stdc=no
+fi
+rm -f conftest*
+
+fi
+
+if test $ac_cv_header_stdc = yes; then
+ # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI.
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <stdlib.h>
+
+_ACEOF
+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
+ $EGREP "free" >/dev/null 2>&1; then
+ :
+else
+ ac_cv_header_stdc=no
+fi
+rm -f conftest*
+
+fi
+
+if test $ac_cv_header_stdc = yes; then
+ # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi.
+ if test "$cross_compiling" = yes; then
+ :
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <ctype.h>
+#include <stdlib.h>
+#if ((' ' & 0x0FF) == 0x020)
+# define ISLOWER(c) ('a' <= (c) && (c) <= 'z')
+# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c))
+#else
+# define ISLOWER(c) \
+ (('a' <= (c) && (c) <= 'i') \
+ || ('j' <= (c) && (c) <= 'r') \
+ || ('s' <= (c) && (c) <= 'z'))
+# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c))
+#endif
+
+#define XOR(e, f) (((e) && !(f)) || (!(e) && (f)))
+int
+main ()
+{
+ int i;
+ for (i = 0; i < 256; i++)
+ if (XOR (islower (i), ISLOWER (i))
+ || toupper (i) != TOUPPER (i))
+ return 2;
+ return 0;
+}
+_ACEOF
+rm -f conftest$ac_exeext
+if { (ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_link") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
+ { (case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_try") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; }; then
+ :
+else
+ echo "$as_me: program exited with status $ac_status" >&5
+echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+( exit $ac_status )
+ac_cv_header_stdc=no
+fi
+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
+fi
+
+
+fi
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5
+echo "${ECHO_T}$ac_cv_header_stdc" >&6; }
+if test $ac_cv_header_stdc = yes; then
+
+cat >>confdefs.h <<\_ACEOF
+#define STDC_HEADERS 1
+_ACEOF
+
+fi
+
+# On IRIX 5.3, sys/types and inttypes.h are conflicting.
+
+
+
+
+
+
+
+
+
+for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \
+ inttypes.h stdint.h unistd.h
+do
+as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
+{ echo "$as_me:$LINENO: checking for $ac_header" >&5
+echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; }
+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+$ac_includes_default
+
+#include <$ac_header>
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ eval "$as_ac_Header=yes"
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ eval "$as_ac_Header=no"
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+ac_res=`eval echo '${'$as_ac_Header'}'`
+ { echo "$as_me:$LINENO: result: $ac_res" >&5
+echo "${ECHO_T}$ac_res" >&6; }
+if test `eval echo '${'$as_ac_Header'}'` = yes; then
+ cat >>confdefs.h <<_ACEOF
+#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
+_ACEOF
+
+fi
+
+done
+
+
+{ echo "$as_me:$LINENO: checking for __builtin_va_list" >&5
+echo $ECHO_N "checking for __builtin_va_list... $ECHO_C" >&6; }
+if test "${ac_cv_type___builtin_va_list+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+$ac_includes_default
+typedef __builtin_va_list ac__type_new_;
+int
+main ()
+{
+if ((ac__type_new_ *) 0)
+ return 0;
+if (sizeof (ac__type_new_))
+ return 0;
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ ac_cv_type___builtin_va_list=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_cv_type___builtin_va_list=no
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_type___builtin_va_list" >&5
+echo "${ECHO_T}$ac_cv_type___builtin_va_list" >&6; }
+if test $ac_cv_type___builtin_va_list = yes; then
+ HAVE_BUILTIN_VA_LIST=true
+else
+ HAVE_BUILTIN_VA_LIST=false
+fi
+
+{ echo "$as_me:$LINENO: checking if __thread is a keyword" >&5
+echo $ECHO_N "checking if __thread is a keyword... $ECHO_C" >&6; }
+cat >conftest.$ac_ext <<_ACEOF
+int main(int __thread) { return 0; }
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ THREAD_IS_KEYWORD=false
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ THREAD_IS_KEYWORD=true
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+{ echo "$as_me:$LINENO: result: $THREAD_IS_KEYWORD" >&5
+echo "${ECHO_T}$THREAD_IS_KEYWORD" >&6; }
+
+# Does gcc add underscores to identifiers to make assembly labels?
+# (I think MSVC always does)
+{ echo "$as_me:$LINENO: checking if gcc adds underscores to assembly labels." >&5
+echo $ECHO_N "checking if gcc adds underscores to assembly labels.... $ECHO_C" >&6; }
+cat >conftest.$ac_ext <<_ACEOF
+int main() { __asm__("jmp _main"); }
+_ACEOF
+rm -f conftest.$ac_objext conftest$ac_exeext
+if { (ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_link") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest$ac_exeext &&
+ $as_test_x conftest$ac_exeext; then
+ UNDERSCORE_NAME=true
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ UNDERSCORE_NAME=false
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \
+ conftest$ac_exeext conftest.$ac_ext
+{ echo "$as_me:$LINENO: result: $UNDERSCORE_NAME" >&5
+echo "${ECHO_T}$UNDERSCORE_NAME" >&6; }
+
+
+# ----------- some stuff 'autoscan' put here --------------
+# (autoscan is part of the autoconf distribution)
+
+# checks for header files
+{ echo "$as_me:$LINENO: checking for ANSI C header files" >&5
+echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6; }
+if test "${ac_cv_header_stdc+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <stdlib.h>
+#include <stdarg.h>
+#include <string.h>
+#include <float.h>
+
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ ac_cv_header_stdc=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_cv_header_stdc=no
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+
+if test $ac_cv_header_stdc = yes; then
+ # SunOS 4.x string.h does not declare mem*, contrary to ANSI.
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <string.h>
+
+_ACEOF
+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
+ $EGREP "memchr" >/dev/null 2>&1; then
+ :
+else
+ ac_cv_header_stdc=no
+fi
+rm -f conftest*
+
+fi
+
+if test $ac_cv_header_stdc = yes; then
+ # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI.
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <stdlib.h>
+
+_ACEOF
+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
+ $EGREP "free" >/dev/null 2>&1; then
+ :
+else
+ ac_cv_header_stdc=no
+fi
+rm -f conftest*
+
+fi
+
+if test $ac_cv_header_stdc = yes; then
+ # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi.
+ if test "$cross_compiling" = yes; then
+ :
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <ctype.h>
+#include <stdlib.h>
+#if ((' ' & 0x0FF) == 0x020)
+# define ISLOWER(c) ('a' <= (c) && (c) <= 'z')
+# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c))
+#else
+# define ISLOWER(c) \
+ (('a' <= (c) && (c) <= 'i') \
+ || ('j' <= (c) && (c) <= 'r') \
+ || ('s' <= (c) && (c) <= 'z'))
+# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c))
+#endif
+
+#define XOR(e, f) (((e) && !(f)) || (!(e) && (f)))
+int
+main ()
+{
+ int i;
+ for (i = 0; i < 256; i++)
+ if (XOR (islower (i), ISLOWER (i))
+ || toupper (i) != TOUPPER (i))
+ return 2;
+ return 0;
+}
+_ACEOF
+rm -f conftest$ac_exeext
+if { (ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_link") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
+ { (case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_try") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; }; then
+ :
+else
+ echo "$as_me: program exited with status $ac_status" >&5
+echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+( exit $ac_status )
+ac_cv_header_stdc=no
+fi
+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
+fi
+
+
+fi
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5
+echo "${ECHO_T}$ac_cv_header_stdc" >&6; }
+if test $ac_cv_header_stdc = yes; then
+
+cat >>confdefs.h <<\_ACEOF
+#define STDC_HEADERS 1
+_ACEOF
+
+fi
+
+
+
+
+
+
+for ac_header in stdlib.h strings.h sys/time.h unistd.h wchar.h
+do
+as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then
+ { echo "$as_me:$LINENO: checking for $ac_header" >&5
+echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; }
+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+fi
+ac_res=`eval echo '${'$as_ac_Header'}'`
+ { echo "$as_me:$LINENO: result: $ac_res" >&5
+echo "${ECHO_T}$ac_res" >&6; }
+else
+ # Is the header compilable?
+{ echo "$as_me:$LINENO: checking $ac_header usability" >&5
+echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6; }
+cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+$ac_includes_default
+#include <$ac_header>
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ ac_header_compiler=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_header_compiler=no
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+{ echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
+echo "${ECHO_T}$ac_header_compiler" >&6; }
+
+# Is the header present?
+{ echo "$as_me:$LINENO: checking $ac_header presence" >&5
+echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6; }
+cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <$ac_header>
+_ACEOF
+if { (ac_try="$ac_cpp conftest.$ac_ext"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } >/dev/null && {
+ test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ }; then
+ ac_header_preproc=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_header_preproc=no
+fi
+
+rm -f conftest.err conftest.$ac_ext
+{ echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
+echo "${ECHO_T}$ac_header_preproc" >&6; }
+
+# So? What about this header?
+case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
+ yes:no: )
+ { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
+echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
+ { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5
+echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}
+ ac_header_preproc=yes
+ ;;
+ no:yes:* )
+ { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
+echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}
+ { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5
+echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}
+ { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5
+echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}
+ { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5
+echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;}
+ { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
+echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
+ { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5
+echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}
+
+ ;;
+esac
+{ echo "$as_me:$LINENO: checking for $ac_header" >&5
+echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; }
+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ eval "$as_ac_Header=\$ac_header_preproc"
+fi
+ac_res=`eval echo '${'$as_ac_Header'}'`
+ { echo "$as_me:$LINENO: result: $ac_res" >&5
+echo "${ECHO_T}$ac_res" >&6; }
+
+fi
+if test `eval echo '${'$as_ac_Header'}'` = yes; then
+ cat >>confdefs.h <<_ACEOF
+#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
+_ACEOF
+
+fi
+
+done
+
+
+# checks for typedefs, structures, and compiler characteristics
+{ echo "$as_me:$LINENO: checking for an ANSI C-conforming const" >&5
+echo $ECHO_N "checking for an ANSI C-conforming const... $ECHO_C" >&6; }
+if test "${ac_cv_c_const+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+int
+main ()
+{
+/* FIXME: Include the comments suggested by Paul. */
+#ifndef __cplusplus
+ /* Ultrix mips cc rejects this. */
+ typedef int charset[2];
+ const charset cs;
+ /* SunOS 4.1.1 cc rejects this. */
+ char const *const *pcpcc;
+ char **ppc;
+ /* NEC SVR4.0.2 mips cc rejects this. */
+ struct point {int x, y;};
+ static struct point const zero = {0,0};
+ /* AIX XL C 1.02.0.0 rejects this.
+ It does not let you subtract one const X* pointer from another in
+ an arm of an if-expression whose if-part is not a constant
+ expression */
+ const char *g = "string";
+ pcpcc = &g + (g ? g-g : 0);
+ /* HPUX 7.0 cc rejects these. */
+ ++pcpcc;
+ ppc = (char**) pcpcc;
+ pcpcc = (char const *const *) ppc;
+ { /* SCO 3.2v4 cc rejects this. */
+ char *t;
+ char const *s = 0 ? (char *) 0 : (char const *) 0;
+
+ *t++ = 0;
+ if (s) return 0;
+ }
+ { /* Someone thinks the Sun supposedly-ANSI compiler will reject this. */
+ int x[] = {25, 17};
+ const int *foo = &x[0];
+ ++foo;
+ }
+ { /* Sun SC1.0 ANSI compiler rejects this -- but not the above. */
+ typedef const int *iptr;
+ iptr p = 0;
+ ++p;
+ }
+ { /* AIX XL C 1.02.0.0 rejects this saying
+ "k.c", line 2.27: 1506-025 (S) Operand must be a modifiable lvalue. */
+ struct s { int j; const int *ap[3]; };
+ struct s *b; b->j = 5;
+ }
+ { /* ULTRIX-32 V3.1 (Rev 9) vcc rejects this */
+ const int foo = 10;
+ if (!foo) return 0;
+ }
+ return !cs[0] && !zero.x;
+#endif
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ ac_cv_c_const=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_cv_c_const=no
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_c_const" >&5
+echo "${ECHO_T}$ac_cv_c_const" >&6; }
+if test $ac_cv_c_const = no; then
+
+cat >>confdefs.h <<\_ACEOF
+#define const
+_ACEOF
+
+fi
+
+{ echo "$as_me:$LINENO: checking for inline" >&5
+echo $ECHO_N "checking for inline... $ECHO_C" >&6; }
+if test "${ac_cv_c_inline+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ ac_cv_c_inline=no
+for ac_kw in inline __inline__ __inline; do
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#ifndef __cplusplus
+typedef int foo_t;
+static $ac_kw foo_t static_foo () {return 0; }
+$ac_kw foo_t foo () {return 0; }
+#endif
+
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ ac_cv_c_inline=$ac_kw
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ test "$ac_cv_c_inline" != no && break
+done
+
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_c_inline" >&5
+echo "${ECHO_T}$ac_cv_c_inline" >&6; }
+
+
+case $ac_cv_c_inline in
+ inline | yes) ;;
+ *)
+ case $ac_cv_c_inline in
+ no) ac_val=;;
+ *) ac_val=$ac_cv_c_inline;;
+ esac
+ cat >>confdefs.h <<_ACEOF
+#ifndef __cplusplus
+#define inline $ac_val
+#endif
+_ACEOF
+ ;;
+esac
+
+{ echo "$as_me:$LINENO: checking whether time.h and sys/time.h may both be included" >&5
+echo $ECHO_N "checking whether time.h and sys/time.h may both be included... $ECHO_C" >&6; }
+if test "${ac_cv_header_time+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <sys/types.h>
+#include <sys/time.h>
+#include <time.h>
+
+int
+main ()
+{
+if ((struct tm *) 0)
+return 0;
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ ac_cv_header_time=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_cv_header_time=no
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_header_time" >&5
+echo "${ECHO_T}$ac_cv_header_time" >&6; }
+if test $ac_cv_header_time = yes; then
+
+cat >>confdefs.h <<\_ACEOF
+#define TIME_WITH_SYS_TIME 1
+_ACEOF
+
+fi
+
+
+# checks for library functions; more autoscan stuff
+{ echo "$as_me:$LINENO: checking for working memcmp" >&5
+echo $ECHO_N "checking for working memcmp... $ECHO_C" >&6; }
+if test "${ac_cv_func_memcmp_working+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ if test "$cross_compiling" = yes; then
+ ac_cv_func_memcmp_working=no
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+$ac_includes_default
+int
+main ()
+{
+
+ /* Some versions of memcmp are not 8-bit clean. */
+ char c0 = '\100', c1 = '\200', c2 = '\201';
+ if (memcmp(&c0, &c2, 1) >= 0 || memcmp(&c1, &c2, 1) >= 0)
+ return 1;
+
+ /* The Next x86 OpenStep bug shows up only when comparing 16 bytes
+ or more and with at least one buffer not starting on a 4-byte boundary.
+ William Lewis provided this test program. */
+ {
+ char foo[21];
+ char bar[21];
+ int i;
+ for (i = 0; i < 4; i++)
+ {
+ char *a = foo + i;
+ char *b = bar + i;
+ strcpy (a, "--------01111111");
+ strcpy (b, "--------10000000");
+ if (memcmp (a, b, 16) >= 0)
+ return 1;
+ }
+ return 0;
+ }
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest$ac_exeext
+if { (ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_link") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
+ { (case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_try") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; }; then
+ ac_cv_func_memcmp_working=yes
+else
+ echo "$as_me: program exited with status $ac_status" >&5
+echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+( exit $ac_status )
+ac_cv_func_memcmp_working=no
+fi
+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
+fi
+
+
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_func_memcmp_working" >&5
+echo "${ECHO_T}$ac_cv_func_memcmp_working" >&6; }
+test $ac_cv_func_memcmp_working = no && case " $LIBOBJS " in
+ *" memcmp.$ac_objext "* ) ;;
+ *) LIBOBJS="$LIBOBJS memcmp.$ac_objext"
+ ;;
+esac
+
+
+
+
+
+
+for ac_func in mkdir select socket __sysv_signal
+do
+as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
+{ echo "$as_me:$LINENO: checking for $ac_func" >&5
+echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6; }
+if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
+ For example, HP-UX 11i <limits.h> declares gettimeofday. */
+#define $ac_func innocuous_$ac_func
+
+/* System header to define __stub macros and hopefully few prototypes,
+ which can conflict with char $ac_func (); below.
+ Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
+ <limits.h> exists even on freestanding compilers. */
+
+#ifdef __STDC__
+# include <limits.h>
+#else
+# include <assert.h>
+#endif
+
+#undef $ac_func
+
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
+ builtin and then its argument prototype would still apply. */
+#ifdef __cplusplus
+extern "C"
+#endif
+char $ac_func ();
+/* The GNU C library defines this for functions which it implements
+ to always fail with ENOSYS. Some functions are actually named
+ something starting with __ and the normal name is an alias. */
+#if defined __stub_$ac_func || defined __stub___$ac_func
+choke me
+#endif
+
+int
+main ()
+{
+return $ac_func ();
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext conftest$ac_exeext
+if { (ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_link") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest$ac_exeext &&
+ $as_test_x conftest$ac_exeext; then
+ eval "$as_ac_var=yes"
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ eval "$as_ac_var=no"
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \
+ conftest$ac_exeext conftest.$ac_ext
+fi
+ac_res=`eval echo '${'$as_ac_var'}'`
+ { echo "$as_me:$LINENO: result: $ac_res" >&5
+echo "${ECHO_T}$ac_res" >&6; }
+if test `eval echo '${'$as_ac_var'}'` = yes; then
+ cat >>confdefs.h <<_ACEOF
+#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
+_ACEOF
+
+fi
+done
+
+
+# Find out the true definitions of some integer types
+
+ { echo "$as_me:$LINENO: checking for real definition of size_t" >&5
+echo $ECHO_N "checking for real definition of size_t... $ECHO_C" >&6; }
+ real_type=''
+
+
+ if test -z "$real_type"; then
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+#include <stddef.h>
+#include <wchar.h>
+/* We define a prototype with one type and the function with
+ another type. This will result in compilation error
+ unless the types are really identical. */
+int foo(int x);
+size_t foo(size_t x) { return x; }
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ real_type='int'
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ fi
+
+
+ if test -z "$real_type"; then
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+#include <stddef.h>
+#include <wchar.h>
+/* We define a prototype with one type and the function with
+ another type. This will result in compilation error
+ unless the types are really identical. */
+unsigned int foo(unsigned int x);
+size_t foo(size_t x) { return x; }
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ real_type='unsigned int'
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ fi
+
+
+
+
+ if test -z "$real_type"; then
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+#include <stddef.h>
+#include <wchar.h>
+/* We define a prototype with one type and the function with
+ another type. This will result in compilation error
+ unless the types are really identical. */
+long foo(long x);
+size_t foo(size_t x) { return x; }
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ real_type='long'
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ fi
+
+
+ if test -z "$real_type"; then
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+#include <stddef.h>
+#include <wchar.h>
+/* We define a prototype with one type and the function with
+ another type. This will result in compilation error
+ unless the types are really identical. */
+unsigned long foo(unsigned long x);
+size_t foo(size_t x) { return x; }
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ real_type='unsigned long'
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ fi
+
+
+
+
+ if test -z "$real_type"; then
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+#include <stddef.h>
+#include <wchar.h>
+/* We define a prototype with one type and the function with
+ another type. This will result in compilation error
+ unless the types are really identical. */
+short foo(short x);
+size_t foo(size_t x) { return x; }
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ real_type='short'
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ fi
+
+
+ if test -z "$real_type"; then
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+#include <stddef.h>
+#include <wchar.h>
+/* We define a prototype with one type and the function with
+ another type. This will result in compilation error
+ unless the types are really identical. */
+unsigned short foo(unsigned short x);
+size_t foo(size_t x) { return x; }
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ real_type='unsigned short'
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ fi
+
+
+
+
+ if test -z "$real_type"; then
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+#include <stddef.h>
+#include <wchar.h>
+/* We define a prototype with one type and the function with
+ another type. This will result in compilation error
+ unless the types are really identical. */
+char foo(char x);
+size_t foo(size_t x) { return x; }
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ real_type='char'
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ fi
+
+
+ if test -z "$real_type"; then
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+#include <stddef.h>
+#include <wchar.h>
+/* We define a prototype with one type and the function with
+ another type. This will result in compilation error
+ unless the types are really identical. */
+unsigned char foo(unsigned char x);
+size_t foo(size_t x) { return x; }
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ real_type='unsigned char'
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ fi
+
+
+ if test -z "$real_type"; then
+ { { echo "$as_me:$LINENO: error: cannot find definition of size_t" >&5
+echo "$as_me: error: cannot find definition of size_t" >&2;}
+ { (exit 1); exit 1; }; }
+ fi
+ cat >>confdefs.h <<_ACEOF
+#define TYPE_SIZE_T "$real_type"
+_ACEOF
+
+ { echo "$as_me:$LINENO: result: $real_type" >&5
+echo "${ECHO_T}$real_type" >&6; }
+
+
+ { echo "$as_me:$LINENO: checking for real definition of wchar_t" >&5
+echo $ECHO_N "checking for real definition of wchar_t... $ECHO_C" >&6; }
+ real_type=''
+
+
+ if test -z "$real_type"; then
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+#include <stddef.h>
+#include <wchar.h>
+/* We define a prototype with one type and the function with
+ another type. This will result in compilation error
+ unless the types are really identical. */
+int foo(int x);
+wchar_t foo(wchar_t x) { return x; }
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ real_type='int'
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ fi
+
+
+ if test -z "$real_type"; then
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+#include <stddef.h>
+#include <wchar.h>
+/* We define a prototype with one type and the function with
+ another type. This will result in compilation error
+ unless the types are really identical. */
+unsigned int foo(unsigned int x);
+wchar_t foo(wchar_t x) { return x; }
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ real_type='unsigned int'
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ fi
+
+
+
+
+ if test -z "$real_type"; then
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+#include <stddef.h>
+#include <wchar.h>
+/* We define a prototype with one type and the function with
+ another type. This will result in compilation error
+ unless the types are really identical. */
+long foo(long x);
+wchar_t foo(wchar_t x) { return x; }
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ real_type='long'
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ fi
+
+
+ if test -z "$real_type"; then
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+#include <stddef.h>
+#include <wchar.h>
+/* We define a prototype with one type and the function with
+ another type. This will result in compilation error
+ unless the types are really identical. */
+unsigned long foo(unsigned long x);
+wchar_t foo(wchar_t x) { return x; }
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ real_type='unsigned long'
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ fi
+
+
+
+
+ if test -z "$real_type"; then
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+#include <stddef.h>
+#include <wchar.h>
+/* We define a prototype with one type and the function with
+ another type. This will result in compilation error
+ unless the types are really identical. */
+short foo(short x);
+wchar_t foo(wchar_t x) { return x; }
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ real_type='short'
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ fi
+
+
+ if test -z "$real_type"; then
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+#include <stddef.h>
+#include <wchar.h>
+/* We define a prototype with one type and the function with
+ another type. This will result in compilation error
+ unless the types are really identical. */
+unsigned short foo(unsigned short x);
+wchar_t foo(wchar_t x) { return x; }
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ real_type='unsigned short'
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ fi
+
+
+
+
+ if test -z "$real_type"; then
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+#include <stddef.h>
+#include <wchar.h>
+/* We define a prototype with one type and the function with
+ another type. This will result in compilation error
+ unless the types are really identical. */
+char foo(char x);
+wchar_t foo(wchar_t x) { return x; }
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ real_type='char'
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ fi
+
+
+ if test -z "$real_type"; then
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+#include <stddef.h>
+#include <wchar.h>
+/* We define a prototype with one type and the function with
+ another type. This will result in compilation error
+ unless the types are really identical. */
+unsigned char foo(unsigned char x);
+wchar_t foo(wchar_t x) { return x; }
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ real_type='unsigned char'
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ fi
+
+
+ if test -z "$real_type"; then
+ { { echo "$as_me:$LINENO: error: cannot find definition of wchar_t" >&5
+echo "$as_me: error: cannot find definition of wchar_t" >&2;}
+ { (exit 1); exit 1; }; }
+ fi
+ cat >>confdefs.h <<_ACEOF
+#define TYPE_WCHAR_T "$real_type"
+_ACEOF
+
+ { echo "$as_me:$LINENO: result: $real_type" >&5
+echo "${ECHO_T}$real_type" >&6; }
+
+
+
+# ----------- platform-specific code -------------
+# $target is typically processor-vendor-os
+case "$target" in
+
+ *86*linux*)
+ { echo "$as_me:$LINENO: result: configuring for linux/x86" >&5
+echo "${ECHO_T}configuring for linux/x86" >&6; }
+
+ ARCHOS=x86_LINUX
+ ;;
+
+ *86*openbsd*)
+ { echo "$as_me:$LINENO: result: configuring for OpenBSD/x86" >&5
+echo "${ECHO_T}configuring for OpenBSD/x86" >&6; }
+
+ ARCHOS=x86_OPENBSD
+ ;;
+
+ *i386*freebsd*|*amd64*freebsd*)
+
+ if test x"${ARCH}" = x""; then
+ ARCH=`uname -p`
+ fi
+
+ { echo "$as_me:$LINENO: result: configuring for freebsd/${ARCH}" >&5
+echo "${ECHO_T}configuring for freebsd/${ARCH}" >&6; }
+
+ ARCHOS=${ARCH}_FREEBSD
+ ;;
+
+
+ # Mac OS X
+ *86*darwin*)
+ { echo "$as_me:$LINENO: result: configuring for darwin/x86" >&5
+echo "${ECHO_T}configuring for darwin/x86" >&6; }
+
+ ARCHOS=x86_DARWIN
+ ;;
+
+ *powerpc*darwin*)
+ { echo "$as_me:$LINENO: result: configuring for powerpc/darwin" >&5
+echo "${ECHO_T}configuring for powerpc/darwin" >&6; }
+
+ ARCHOS=ppc_DARWIN
+ ;;
+
+ # cygwin
+ *86*cygwin*)
+ { echo "$as_me:$LINENO: result: configuring for Cygwin on win32/x86" >&5
+echo "${ECHO_T}configuring for Cygwin on win32/x86" >&6; }
+
+ ARCHOS=x86_WIN32
+
+ # override CILHOME; even on cygwin we want forward slashes
+ # sm: I folded this into what I hope will be the only
+ # case-analysis of machine type
+ #CILHOME=`cygpath -wa "$CILHOME" | sed -e "s/\\\\\/\\//g"`
+ # Try to use the Unix paths even on cygwin. The newest versions of make
+ # do not like colons in file names
+ CILHOME=`cygpath -u "$CILHOME"`
+ CC=`which $CC`
+ CC=`cygpath -wa "$CC" | sed -e "s/\\\\\/\\//g"`
+ ;;
+
+ # Solaris
+ *sparc*solaris*)
+ { echo "$as_me:$LINENO: result: configuring for SPARC/Solaris" >&5
+echo "${ECHO_T}configuring for SPARC/Solaris" >&6; }
+
+ ARCHOS=sparc_SOLARIS
+ ;;
+
+ *)
+ { { echo "$as_me:$LINENO: error:
+ Unsupported platform $target -- sorry.
+ ./configure supports these platforms:
+ on x86: Linux, Win32(with Cygwin), FreeBSD, OpenBSD, and Mac OS X
+ on amd64: FreeBSD
+ on PowerPC: Mac OS X
+ on SPARC: Solaris
+ " >&5
+echo "$as_me: error:
+ Unsupported platform $target -- sorry.
+ ./configure supports these platforms:
+ on x86: Linux, Win32(with Cygwin), FreeBSD, OpenBSD, and Mac OS X
+ on amd64: FreeBSD
+ on PowerPC: Mac OS X
+ on SPARC: Solaris
+ " >&2;}
+ { (exit 1); exit 1; }; }
+ ;;
+esac
+
+# Make the object directory if not already present
+as_ac_File=`echo "ac_cv_file_obj/$ARCHOS" | $as_tr_sh`
+{ echo "$as_me:$LINENO: checking for obj/$ARCHOS" >&5
+echo $ECHO_N "checking for obj/$ARCHOS... $ECHO_C" >&6; }
+if { as_var=$as_ac_File; eval "test \"\${$as_var+set}\" = set"; }; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ test "$cross_compiling" = yes &&
+ { { echo "$as_me:$LINENO: error: cannot check for file existence when cross compiling" >&5
+echo "$as_me: error: cannot check for file existence when cross compiling" >&2;}
+ { (exit 1); exit 1; }; }
+if test -r "obj/$ARCHOS"; then
+ eval "$as_ac_File=yes"
+else
+ eval "$as_ac_File=no"
+fi
+fi
+ac_res=`eval echo '${'$as_ac_File'}'`
+ { echo "$as_me:$LINENO: result: $ac_res" >&5
+echo "${ECHO_T}$ac_res" >&6; }
+if test `eval echo '${'$as_ac_File'}'` = yes; then
+ :
+else
+ { echo "$as_me:$LINENO: result: creating obj/$ARCHOS" >&5
+echo "${ECHO_T}creating obj/$ARCHOS" >&6; };
+ mkdir -p obj/$ARCHOS
+fi
+
+
+{ echo "$as_me:$LINENO: checking delete the obj/$ARCHOS/feature_config.ml and obj/$ARCHOS/machdep.ml file" >&5
+echo $ECHO_N "checking delete the obj/$ARCHOS/feature_config.ml and obj/$ARCHOS/machdep.ml file... $ECHO_C" >&6; }
+rm -f obj/$ARCHOS/machdep.ml
+rm -f obj/.depend/machdep.d
+rm -f obj/$ARCHOS/feature_config.ml
+rm -f obj/.depend/feature_config.d
+{ echo "$as_me:$LINENO: result: done" >&5
+echo "${ECHO_T}done" >&6; }
+
+
+
+#
+# CIL features
+#
+#
+
+# Set the defaults
+
+
+# Give a space-separated list of features with the defaults
+features="blockinggraph=no zrapp=no"
+
+
+# Check whether --with-blockinggraph was given.
+if test "${with_blockinggraph+set}" = set; then
+ withval=$with_blockinggraph;
+fi
+
+
+# Check whether --with-zrapp was given.
+if test "${with_zrapp+set}" = set; then
+ withval=$with_zrapp;
+fi
+
+
+# Now add any features specified in the command-line
+
+features="$features $EXTRAFEATURES"
+
+rm -f Makefile.features
+echo "# -*- Mode: makefile -*-">Makefile.features
+echo "# This file was generated automatically by ./configure.in">>Makefile.features
+echo "# We will not need this once configure supports multiline variables">>Makefile.features
+
+for f_val in $features
+do
+ # If there is no =, then we default to yes
+ if ! (echo $f_val | grep "=" >/dev/null) ;then f_val="$f_val=yes"; fi
+ # echo "Testing feature $f_val"
+ f=`echo $f_val | sed -e s%=.*$%%`
+ { echo "$as_me:$LINENO: checking whether to use CIL feature $f" >&5
+echo $ECHO_N "checking whether to use CIL feature $f... $ECHO_C" >&6; }
+ # default value from "features"
+ defval=`echo $f_val | sed -e s%^.*=%%`
+ # current value
+ getcurval="echo \${with_$f:=$defval}"
+ curval=`eval $getcurval`
+ { echo "$as_me:$LINENO: result: $curval" >&5
+echo "${ECHO_T}$curval" >&6; }
+ if test $curval = yes ;then
+ CIL_FEATURES="$CIL_FEATURES $f"
+ f_up=`echo $f | tr a-z A-Z`
+ echo "export USE_$f_up=yes">>Makefile.features
+ fi
+done
+echo "TYPE_SIZE_T=\"$TYPE_SIZE_T\"" >>Makefile.features
+echo "TYPE_WCHAR_T=\"$TYPE_WCHAR_T\"" >>Makefile.features
+chmod -w Makefile.features
+
+
+# ----------------- finish up -------------------
+# names of the variables that get substituted in files; for example,
+# write @ARCHOS@ somewhere in a written file to get it substituted
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# finish the configure script and generate various files; ./configure
+# will apply variable substitutions to <filename>.in to generate <filename>;
+
+{
+ if test -f Makefile.in; then
+ ac_config_files="$ac_config_files Makefile"
+
+ else
+ true
+ #echo "skipping [Makefile] because it's not in this distribution"
+ fi
+}
+{
+ if test -f cil.spec.in; then
+ ac_config_files="$ac_config_files cil.spec"
+
+ else
+ true
+ #echo "skipping [cil.spec] because it's not in this distribution"
+ fi
+}
+{
+ if test -f config.mk.in; then
+ ac_config_files="$ac_config_files config.mk"
+
+ else
+ true
+ #echo "skipping [config.mk] because it's not in this distribution"
+ fi
+}
+{
+ if test -f test/Makefile.in; then
+ ac_config_files="$ac_config_files test/Makefile"
+
+ else
+ true
+ #echo "skipping [test/Makefile] because it's not in this distribution"
+ fi
+}
+{
+ if test -f bin/cilly.bat.in; then
+ ac_config_files="$ac_config_files bin/cilly.bat"
+
+ else
+ true
+ #echo "skipping [bin/cilly.bat] because it's not in this distribution"
+ fi
+}
+{
+ if test -f bin/patcher.bat.in; then
+ ac_config_files="$ac_config_files bin/patcher.bat"
+
+ else
+ true
+ #echo "skipping [bin/patcher.bat] because it's not in this distribution"
+ fi
+}
+{
+ if test -f bin/CilConfig.pm.in; then
+ ac_config_files="$ac_config_files bin/CilConfig.pm"
+
+ else
+ true
+ #echo "skipping [bin/CilConfig.pm] because it's not in this distribution"
+ fi
+}
+{
+ if test -f doc/index.html.in; then
+ ac_config_files="$ac_config_files doc/index.html"
+
+ else
+ true
+ #echo "skipping [doc/index.html] because it's not in this distribution"
+ fi
+}
+{
+ if test -f doc/header.html.in; then
+ ac_config_files="$ac_config_files doc/header.html"
+
+ else
+ true
+ #echo "skipping [doc/header.html] because it's not in this distribution"
+ fi
+}
+{
+ if test -f ocamlutil/perfcount.c.in; then
+ ac_config_files="$ac_config_files ocamlutil/perfcount.c"
+
+ else
+ true
+ #echo "skipping [ocamlutil/perfcount.c] because it's not in this distribution"
+ fi
+}
+
+cat >confcache <<\_ACEOF
+# This file is a shell script that caches the results of configure
+# tests run on this system so they can be shared between configure
+# scripts and configure runs, see configure's option --config-cache.
+# It is not useful on other systems. If it contains results you don't
+# want to keep, you may remove or edit it.
+#
+# config.status only pays attention to the cache file if you give it
+# the --recheck option to rerun configure.
+#
+# `ac_cv_env_foo' variables (set or unset) will be overridden when
+# loading this file, other *unset* `ac_cv_foo' will be assigned the
+# following values.
+
+_ACEOF
+
+# The following way of writing the cache mishandles newlines in values,
+# but we know of no workaround that is simple, portable, and efficient.
+# So, we kill variables containing newlines.
+# Ultrix sh set writes to stderr and can't be redirected directly,
+# and sets the high bit in the cache file unless we assign to the vars.
+(
+ for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do
+ eval ac_val=\$$ac_var
+ case $ac_val in #(
+ *${as_nl}*)
+ case $ac_var in #(
+ *_cv_*) { echo "$as_me:$LINENO: WARNING: Cache variable $ac_var contains a newline." >&5
+echo "$as_me: WARNING: Cache variable $ac_var contains a newline." >&2;} ;;
+ esac
+ case $ac_var in #(
+ _ | IFS | as_nl) ;; #(
+ *) $as_unset $ac_var ;;
+ esac ;;
+ esac
+ done
+
+ (set) 2>&1 |
+ case $as_nl`(ac_space=' '; set) 2>&1` in #(
+ *${as_nl}ac_space=\ *)
+ # `set' does not quote correctly, so add quotes (double-quote
+ # substitution turns \\\\ into \\, and sed turns \\ into \).
+ sed -n \
+ "s/'/'\\\\''/g;
+ s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p"
+ ;; #(
+ *)
+ # `set' quotes correctly as required by POSIX, so do not add quotes.
+ sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
+ ;;
+ esac |
+ sort
+) |
+ sed '
+ /^ac_cv_env_/b end
+ t clear
+ :clear
+ s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/
+ t end
+ s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/
+ :end' >>confcache
+if diff "$cache_file" confcache >/dev/null 2>&1; then :; else
+ if test -w "$cache_file"; then
+ test "x$cache_file" != "x/dev/null" &&
+ { echo "$as_me:$LINENO: updating cache $cache_file" >&5
+echo "$as_me: updating cache $cache_file" >&6;}
+ cat confcache >$cache_file
+ else
+ { echo "$as_me:$LINENO: not updating unwritable cache $cache_file" >&5
+echo "$as_me: not updating unwritable cache $cache_file" >&6;}
+ fi
+fi
+rm -f confcache
+
+test "x$prefix" = xNONE && prefix=$ac_default_prefix
+# Let make expand exec_prefix.
+test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'
+
+DEFS=-DHAVE_CONFIG_H
+
+ac_libobjs=
+ac_ltlibobjs=
+for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue
+ # 1. Remove the extension, and $U if already installed.
+ ac_script='s/\$U\././;s/\.o$//;s/\.obj$//'
+ ac_i=`echo "$ac_i" | sed "$ac_script"`
+ # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR
+ # will be set to the directory where LIBOBJS objects are built.
+ ac_libobjs="$ac_libobjs \${LIBOBJDIR}$ac_i\$U.$ac_objext"
+ ac_ltlibobjs="$ac_ltlibobjs \${LIBOBJDIR}$ac_i"'$U.lo'
+done
+LIBOBJS=$ac_libobjs
+
+LTLIBOBJS=$ac_ltlibobjs
+
+
+
+: ${CONFIG_STATUS=./config.status}
+ac_clean_files_save=$ac_clean_files
+ac_clean_files="$ac_clean_files $CONFIG_STATUS"
+{ echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5
+echo "$as_me: creating $CONFIG_STATUS" >&6;}
+cat >$CONFIG_STATUS <<_ACEOF
+#! $SHELL
+# Generated by $as_me.
+# Run this file to recreate the current configuration.
+# Compiler output produced by configure, useful for debugging
+# configure, is in config.log if it exists.
+
+debug=false
+ac_cs_recheck=false
+ac_cs_silent=false
+SHELL=\${CONFIG_SHELL-$SHELL}
+_ACEOF
+
+cat >>$CONFIG_STATUS <<\_ACEOF
+## --------------------- ##
+## M4sh Initialization. ##
+## --------------------- ##
+
+# Be more Bourne compatible
+DUALCASE=1; export DUALCASE # for MKS sh
+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
+ emulate sh
+ NULLCMD=:
+ # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
+ # is contrary to our usage. Disable this feature.
+ alias -g '${1+"$@"}'='"$@"'
+ setopt NO_GLOB_SUBST
+else
+ case `(set -o) 2>/dev/null` in
+ *posix*) set -o posix ;;
+esac
+
+fi
+
+
+
+
+# PATH needs CR
+# Avoid depending upon Character Ranges.
+as_cr_letters='abcdefghijklmnopqrstuvwxyz'
+as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
+as_cr_Letters=$as_cr_letters$as_cr_LETTERS
+as_cr_digits='0123456789'
+as_cr_alnum=$as_cr_Letters$as_cr_digits
+
+# The user is always right.
+if test "${PATH_SEPARATOR+set}" != set; then
+ echo "#! /bin/sh" >conf$$.sh
+ echo "exit 0" >>conf$$.sh
+ chmod +x conf$$.sh
+ if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then
+ PATH_SEPARATOR=';'
+ else
+ PATH_SEPARATOR=:
+ fi
+ rm -f conf$$.sh
+fi
+
+# Support unset when possible.
+if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then
+ as_unset=unset
+else
+ as_unset=false
+fi
+
+
+# IFS
+# We need space, tab and new line, in precisely that order. Quoting is
+# there to prevent editors from complaining about space-tab.
+# (If _AS_PATH_WALK were called with IFS unset, it would disable word
+# splitting by setting IFS to empty value.)
+as_nl='
+'
+IFS=" "" $as_nl"
+
+# Find who we are. Look in the path if we contain no directory separator.
+case $0 in
+ *[\\/]* ) as_myself=$0 ;;
+ *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break
+done
+IFS=$as_save_IFS
+
+ ;;
+esac
+# We did not find ourselves, most probably we were run as `sh COMMAND'
+# in which case we are not to be found in the path.
+if test "x$as_myself" = x; then
+ as_myself=$0
+fi
+if test ! -f "$as_myself"; then
+ echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
+ { (exit 1); exit 1; }
+fi
+
+# Work around bugs in pre-3.0 UWIN ksh.
+for as_var in ENV MAIL MAILPATH
+do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var
+done
+PS1='$ '
+PS2='> '
+PS4='+ '
+
+# NLS nuisances.
+for as_var in \
+ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \
+ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \
+ LC_TELEPHONE LC_TIME
+do
+ if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then
+ eval $as_var=C; export $as_var
+ else
+ ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var
+ fi
+done
+
+# Required to use basename.
+if expr a : '\(a\)' >/dev/null 2>&1 &&
+ test "X`expr 00001 : '.*\(...\)'`" = X001; then
+ as_expr=expr
+else
+ as_expr=false
+fi
+
+if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then
+ as_basename=basename
+else
+ as_basename=false
+fi
+
+
+# Name of the executable.
+as_me=`$as_basename -- "$0" ||
+$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
+ X"$0" : 'X\(//\)$' \| \
+ X"$0" : 'X\(/\)' \| . 2>/dev/null ||
+echo X/"$0" |
+ sed '/^.*\/\([^/][^/]*\)\/*$/{
+ s//\1/
+ q
+ }
+ /^X\/\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\/\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+
+# CDPATH.
+$as_unset CDPATH
+
+
+
+ as_lineno_1=$LINENO
+ as_lineno_2=$LINENO
+ test "x$as_lineno_1" != "x$as_lineno_2" &&
+ test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || {
+
+ # Create $as_me.lineno as a copy of $as_myself, but with $LINENO
+ # uniformly replaced by the line number. The first 'sed' inserts a
+ # line-number line after each line using $LINENO; the second 'sed'
+ # does the real work. The second script uses 'N' to pair each
+ # line-number line with the line containing $LINENO, and appends
+ # trailing '-' during substitution so that $LINENO is not a special
+ # case at line end.
+ # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the
+ # scripts with optimization help from Paolo Bonzini. Blame Lee
+ # E. McMahon (1931-1989) for sed's syntax. :-)
+ sed -n '
+ p
+ /[$]LINENO/=
+ ' <$as_myself |
+ sed '
+ s/[$]LINENO.*/&-/
+ t lineno
+ b
+ :lineno
+ N
+ :loop
+ s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/
+ t loop
+ s/-\n.*//
+ ' >$as_me.lineno &&
+ chmod +x "$as_me.lineno" ||
+ { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2
+ { (exit 1); exit 1; }; }
+
+ # Don't try to exec as it changes $[0], causing all sort of problems
+ # (the dirname of $[0] is not the place where we might find the
+ # original and so on. Autoconf is especially sensitive to this).
+ . "./$as_me.lineno"
+ # Exit status is that of the last command.
+ exit
+}
+
+
+if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then
+ as_dirname=dirname
+else
+ as_dirname=false
+fi
+
+ECHO_C= ECHO_N= ECHO_T=
+case `echo -n x` in
+-n*)
+ case `echo 'x\c'` in
+ *c*) ECHO_T=' ';; # ECHO_T is single tab character.
+ *) ECHO_C='\c';;
+ esac;;
+*)
+ ECHO_N='-n';;
+esac
+
+if expr a : '\(a\)' >/dev/null 2>&1 &&
+ test "X`expr 00001 : '.*\(...\)'`" = X001; then
+ as_expr=expr
+else
+ as_expr=false
+fi
+
+rm -f conf$$ conf$$.exe conf$$.file
+if test -d conf$$.dir; then
+ rm -f conf$$.dir/conf$$.file
+else
+ rm -f conf$$.dir
+ mkdir conf$$.dir
+fi
+echo >conf$$.file
+if ln -s conf$$.file conf$$ 2>/dev/null; then
+ as_ln_s='ln -s'
+ # ... but there are two gotchas:
+ # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.
+ # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.
+ # In both cases, we have to default to `cp -p'.
+ ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
+ as_ln_s='cp -p'
+elif ln conf$$.file conf$$ 2>/dev/null; then
+ as_ln_s=ln
+else
+ as_ln_s='cp -p'
+fi
+rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
+rmdir conf$$.dir 2>/dev/null
+
+if mkdir -p . 2>/dev/null; then
+ as_mkdir_p=:
+else
+ test -d ./-p && rmdir ./-p
+ as_mkdir_p=false
+fi
+
+if test -x / >/dev/null 2>&1; then
+ as_test_x='test -x'
+else
+ if ls -dL / >/dev/null 2>&1; then
+ as_ls_L_option=L
+ else
+ as_ls_L_option=
+ fi
+ as_test_x='
+ eval sh -c '\''
+ if test -d "$1"; then
+ test -d "$1/.";
+ else
+ case $1 in
+ -*)set "./$1";;
+ esac;
+ case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in
+ ???[sx]*):;;*)false;;esac;fi
+ '\'' sh
+ '
+fi
+as_executable_p=$as_test_x
+
+# Sed expression to map a string onto a valid CPP name.
+as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
+
+# Sed expression to map a string onto a valid variable name.
+as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"
+
+
+exec 6>&1
+
+# Save the log message, to keep $[0] and so on meaningful, and to
+# report actual input values of CONFIG_FILES etc. instead of their
+# values after options handling.
+ac_log="
+This file was extended by $as_me, which was
+generated by GNU Autoconf 2.61. Invocation command line was
+
+ CONFIG_FILES = $CONFIG_FILES
+ CONFIG_HEADERS = $CONFIG_HEADERS
+ CONFIG_LINKS = $CONFIG_LINKS
+ CONFIG_COMMANDS = $CONFIG_COMMANDS
+ $ $0 $@
+
+on `(hostname || uname -n) 2>/dev/null | sed 1q`
+"
+
+_ACEOF
+
+cat >>$CONFIG_STATUS <<_ACEOF
+# Files that config.status was made for.
+config_files="$ac_config_files"
+config_headers="$ac_config_headers"
+
+_ACEOF
+
+cat >>$CONFIG_STATUS <<\_ACEOF
+ac_cs_usage="\
+\`$as_me' instantiates files from templates according to the
+current configuration.
+
+Usage: $0 [OPTIONS] [FILE]...
+
+ -h, --help print this help, then exit
+ -V, --version print version number and configuration settings, then exit
+ -q, --quiet do not print progress messages
+ -d, --debug don't remove temporary files
+ --recheck update $as_me by reconfiguring in the same conditions
+ --file=FILE[:TEMPLATE]
+ instantiate the configuration file FILE
+ --header=FILE[:TEMPLATE]
+ instantiate the configuration header FILE
+
+Configuration files:
+$config_files
+
+Configuration headers:
+$config_headers
+
+Report bugs to <bug-autoconf@gnu.org>."
+
+_ACEOF
+cat >>$CONFIG_STATUS <<_ACEOF
+ac_cs_version="\\
+config.status
+configured by $0, generated by GNU Autoconf 2.61,
+ with options \\"`echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\"
+
+Copyright (C) 2006 Free Software Foundation, Inc.
+This config.status script is free software; the Free Software Foundation
+gives unlimited permission to copy, distribute and modify it."
+
+ac_pwd='$ac_pwd'
+srcdir='$srcdir'
+INSTALL='$INSTALL'
+_ACEOF
+
+cat >>$CONFIG_STATUS <<\_ACEOF
+# If no file are specified by the user, then we need to provide default
+# value. By we need to know if files were specified by the user.
+ac_need_defaults=:
+while test $# != 0
+do
+ case $1 in
+ --*=*)
+ ac_option=`expr "X$1" : 'X\([^=]*\)='`
+ ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'`
+ ac_shift=:
+ ;;
+ *)
+ ac_option=$1
+ ac_optarg=$2
+ ac_shift=shift
+ ;;
+ esac
+
+ case $ac_option in
+ # Handling of the options.
+ -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
+ ac_cs_recheck=: ;;
+ --version | --versio | --versi | --vers | --ver | --ve | --v | -V )
+ echo "$ac_cs_version"; exit ;;
+ --debug | --debu | --deb | --de | --d | -d )
+ debug=: ;;
+ --file | --fil | --fi | --f )
+ $ac_shift
+ CONFIG_FILES="$CONFIG_FILES $ac_optarg"
+ ac_need_defaults=false;;
+ --header | --heade | --head | --hea )
+ $ac_shift
+ CONFIG_HEADERS="$CONFIG_HEADERS $ac_optarg"
+ ac_need_defaults=false;;
+ --he | --h)
+ # Conflict between --help and --header
+ { echo "$as_me: error: ambiguous option: $1
+Try \`$0 --help' for more information." >&2
+ { (exit 1); exit 1; }; };;
+ --help | --hel | -h )
+ echo "$ac_cs_usage"; exit ;;
+ -q | -quiet | --quiet | --quie | --qui | --qu | --q \
+ | -silent | --silent | --silen | --sile | --sil | --si | --s)
+ ac_cs_silent=: ;;
+
+ # This is an error.
+ -*) { echo "$as_me: error: unrecognized option: $1
+Try \`$0 --help' for more information." >&2
+ { (exit 1); exit 1; }; } ;;
+
+ *) ac_config_targets="$ac_config_targets $1"
+ ac_need_defaults=false ;;
+
+ esac
+ shift
+done
+
+ac_configure_extra_args=
+
+if $ac_cs_silent; then
+ exec 6>/dev/null
+ ac_configure_extra_args="$ac_configure_extra_args --silent"
+fi
+
+_ACEOF
+cat >>$CONFIG_STATUS <<_ACEOF
+if \$ac_cs_recheck; then
+ echo "running CONFIG_SHELL=$SHELL $SHELL $0 "$ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6
+ CONFIG_SHELL=$SHELL
+ export CONFIG_SHELL
+ exec $SHELL "$0"$ac_configure_args \$ac_configure_extra_args --no-create --no-recursion
+fi
+
+_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF
+exec 5>>config.log
+{
+ echo
+ sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX
+## Running $as_me. ##
+_ASBOX
+ echo "$ac_log"
+} >&5
+
+_ACEOF
+cat >>$CONFIG_STATUS <<_ACEOF
+_ACEOF
+
+cat >>$CONFIG_STATUS <<\_ACEOF
+
+# Handling of arguments.
+for ac_config_target in $ac_config_targets
+do
+ case $ac_config_target in
+ "config.h") CONFIG_HEADERS="$CONFIG_HEADERS config.h" ;;
+ "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;
+ "cil.spec") CONFIG_FILES="$CONFIG_FILES cil.spec" ;;
+ "config.mk") CONFIG_FILES="$CONFIG_FILES config.mk" ;;
+ "test/Makefile") CONFIG_FILES="$CONFIG_FILES test/Makefile" ;;
+ "bin/cilly.bat") CONFIG_FILES="$CONFIG_FILES bin/cilly.bat" ;;
+ "bin/patcher.bat") CONFIG_FILES="$CONFIG_FILES bin/patcher.bat" ;;
+ "bin/CilConfig.pm") CONFIG_FILES="$CONFIG_FILES bin/CilConfig.pm" ;;
+ "doc/index.html") CONFIG_FILES="$CONFIG_FILES doc/index.html" ;;
+ "doc/header.html") CONFIG_FILES="$CONFIG_FILES doc/header.html" ;;
+ "ocamlutil/perfcount.c") CONFIG_FILES="$CONFIG_FILES ocamlutil/perfcount.c" ;;
+
+ *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5
+echo "$as_me: error: invalid argument: $ac_config_target" >&2;}
+ { (exit 1); exit 1; }; };;
+ esac
+done
+
+
+# If the user did not use the arguments to specify the items to instantiate,
+# then the envvar interface is used. Set only those that are not.
+# We use the long form for the default assignment because of an extremely
+# bizarre bug on SunOS 4.1.3.
+if $ac_need_defaults; then
+ test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files
+ test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers
+fi
+
+# Have a temporary directory for convenience. Make it in the build tree
+# simply because there is no reason against having it here, and in addition,
+# creating and moving files from /tmp can sometimes cause problems.
+# Hook for its removal unless debugging.
+# Note that there is a small window in which the directory will not be cleaned:
+# after its creation but before its name has been assigned to `$tmp'.
+$debug ||
+{
+ tmp=
+ trap 'exit_status=$?
+ { test -z "$tmp" || test ! -d "$tmp" || rm -fr "$tmp"; } && exit $exit_status
+' 0
+ trap '{ (exit 1); exit 1; }' 1 2 13 15
+}
+# Create a (secure) tmp directory for tmp files.
+
+{
+ tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` &&
+ test -n "$tmp" && test -d "$tmp"
+} ||
+{
+ tmp=./conf$$-$RANDOM
+ (umask 077 && mkdir "$tmp")
+} ||
+{
+ echo "$me: cannot create a temporary directory in ." >&2
+ { (exit 1); exit 1; }
+}
+
+#
+# Set up the sed scripts for CONFIG_FILES section.
+#
+
+# No need to generate the scripts if there are no CONFIG_FILES.
+# This happens for instance when ./config.status config.h
+if test -n "$CONFIG_FILES"; then
+
+_ACEOF
+
+
+
+ac_delim='%!_!# '
+for ac_last_try in false false false false false :; do
+ cat >conf$$subs.sed <<_ACEOF
+SHELL!$SHELL$ac_delim
+PATH_SEPARATOR!$PATH_SEPARATOR$ac_delim
+PACKAGE_NAME!$PACKAGE_NAME$ac_delim
+PACKAGE_TARNAME!$PACKAGE_TARNAME$ac_delim
+PACKAGE_VERSION!$PACKAGE_VERSION$ac_delim
+PACKAGE_STRING!$PACKAGE_STRING$ac_delim
+PACKAGE_BUGREPORT!$PACKAGE_BUGREPORT$ac_delim
+exec_prefix!$exec_prefix$ac_delim
+prefix!$prefix$ac_delim
+program_transform_name!$program_transform_name$ac_delim
+bindir!$bindir$ac_delim
+sbindir!$sbindir$ac_delim
+libexecdir!$libexecdir$ac_delim
+datarootdir!$datarootdir$ac_delim
+datadir!$datadir$ac_delim
+sysconfdir!$sysconfdir$ac_delim
+sharedstatedir!$sharedstatedir$ac_delim
+localstatedir!$localstatedir$ac_delim
+includedir!$includedir$ac_delim
+oldincludedir!$oldincludedir$ac_delim
+docdir!$docdir$ac_delim
+infodir!$infodir$ac_delim
+htmldir!$htmldir$ac_delim
+dvidir!$dvidir$ac_delim
+pdfdir!$pdfdir$ac_delim
+psdir!$psdir$ac_delim
+libdir!$libdir$ac_delim
+localedir!$localedir$ac_delim
+mandir!$mandir$ac_delim
+DEFS!$DEFS$ac_delim
+ECHO_C!$ECHO_C$ac_delim
+ECHO_N!$ECHO_N$ac_delim
+ECHO_T!$ECHO_T$ac_delim
+LIBS!$LIBS$ac_delim
+build_alias!$build_alias$ac_delim
+host_alias!$host_alias$ac_delim
+target_alias!$target_alias$ac_delim
+CC!$CC$ac_delim
+CFLAGS!$CFLAGS$ac_delim
+LDFLAGS!$LDFLAGS$ac_delim
+CPPFLAGS!$CPPFLAGS$ac_delim
+ac_ct_CC!$ac_ct_CC$ac_delim
+EXEEXT!$EXEEXT$ac_delim
+OBJEXT!$OBJEXT$ac_delim
+INSTALL_PROGRAM!$INSTALL_PROGRAM$ac_delim
+INSTALL_SCRIPT!$INSTALL_SCRIPT$ac_delim
+INSTALL_DATA!$INSTALL_DATA$ac_delim
+build!$build$ac_delim
+build_cpu!$build_cpu$ac_delim
+build_vendor!$build_vendor$ac_delim
+build_os!$build_os$ac_delim
+host!$host$ac_delim
+host_cpu!$host_cpu$ac_delim
+host_vendor!$host_vendor$ac_delim
+host_os!$host_os$ac_delim
+target!$target$ac_delim
+target_cpu!$target_cpu$ac_delim
+target_vendor!$target_vendor$ac_delim
+target_os!$target_os$ac_delim
+CPP!$CPP$ac_delim
+GREP!$GREP$ac_delim
+EGREP!$EGREP$ac_delim
+LIBOBJS!$LIBOBJS$ac_delim
+ARCHOS!$ARCHOS$ac_delim
+CILHOME!$CILHOME$ac_delim
+HAS_MSVC!$HAS_MSVC$ac_delim
+DEFAULT_COMPILER!$DEFAULT_COMPILER$ac_delim
+DEFAULT_CIL_MODE!$DEFAULT_CIL_MODE$ac_delim
+CIL_VERSION_MAJOR!$CIL_VERSION_MAJOR$ac_delim
+CIL_VERSION_MINOR!$CIL_VERSION_MINOR$ac_delim
+CIL_VERSION_REV!$CIL_VERSION_REV$ac_delim
+CIL_VERSION!$CIL_VERSION$ac_delim
+CYCLES_PER_USEC!$CYCLES_PER_USEC$ac_delim
+HAS_PERFCOUNT!$HAS_PERFCOUNT$ac_delim
+HAVE_BUILTIN_VA_LIST!$HAVE_BUILTIN_VA_LIST$ac_delim
+THREAD_IS_KEYWORD!$THREAD_IS_KEYWORD$ac_delim
+UNDERSCORE_NAME!$UNDERSCORE_NAME$ac_delim
+EXTRAFEATURES!$EXTRAFEATURES$ac_delim
+EXTRASRCDIRS!$EXTRASRCDIRS$ac_delim
+LTLIBOBJS!$LTLIBOBJS$ac_delim
+_ACEOF
+
+ if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 80; then
+ break
+ elif $ac_last_try; then
+ { { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5
+echo "$as_me: error: could not make $CONFIG_STATUS" >&2;}
+ { (exit 1); exit 1; }; }
+ else
+ ac_delim="$ac_delim!$ac_delim _$ac_delim!! "
+ fi
+done
+
+ac_eof=`sed -n '/^CEOF[0-9]*$/s/CEOF/0/p' conf$$subs.sed`
+if test -n "$ac_eof"; then
+ ac_eof=`echo "$ac_eof" | sort -nru | sed 1q`
+ ac_eof=`expr $ac_eof + 1`
+fi
+
+cat >>$CONFIG_STATUS <<_ACEOF
+cat >"\$tmp/subs-1.sed" <<\CEOF$ac_eof
+/@[a-zA-Z_][a-zA-Z_0-9]*@/!b end
+_ACEOF
+sed '
+s/[,\\&]/\\&/g; s/@/@|#_!!_#|/g
+s/^/s,@/; s/!/@,|#_!!_#|/
+:n
+t n
+s/'"$ac_delim"'$/,g/; t
+s/$/\\/; p
+N; s/^.*\n//; s/[,\\&]/\\&/g; s/@/@|#_!!_#|/g; b n
+' >>$CONFIG_STATUS <conf$$subs.sed
+rm -f conf$$subs.sed
+cat >>$CONFIG_STATUS <<_ACEOF
+:end
+s/|#_!!_#|//g
+CEOF$ac_eof
+_ACEOF
+
+
+# VPATH may cause trouble with some makes, so we remove $(srcdir),
+# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and
+# trailing colons and then remove the whole line if VPATH becomes empty
+# (actually we leave an empty line to preserve line numbers).
+if test "x$srcdir" = x.; then
+ ac_vpsub='/^[ ]*VPATH[ ]*=/{
+s/:*\$(srcdir):*/:/
+s/:*\${srcdir}:*/:/
+s/:*@srcdir@:*/:/
+s/^\([^=]*=[ ]*\):*/\1/
+s/:*$//
+s/^[^=]*=[ ]*$//
+}'
+fi
+
+cat >>$CONFIG_STATUS <<\_ACEOF
+fi # test -n "$CONFIG_FILES"
+
+
+for ac_tag in :F $CONFIG_FILES :H $CONFIG_HEADERS
+do
+ case $ac_tag in
+ :[FHLC]) ac_mode=$ac_tag; continue;;
+ esac
+ case $ac_mode$ac_tag in
+ :[FHL]*:*);;
+ :L* | :C*:*) { { echo "$as_me:$LINENO: error: Invalid tag $ac_tag." >&5
+echo "$as_me: error: Invalid tag $ac_tag." >&2;}
+ { (exit 1); exit 1; }; };;
+ :[FH]-) ac_tag=-:-;;
+ :[FH]*) ac_tag=$ac_tag:$ac_tag.in;;
+ esac
+ ac_save_IFS=$IFS
+ IFS=:
+ set x $ac_tag
+ IFS=$ac_save_IFS
+ shift
+ ac_file=$1
+ shift
+
+ case $ac_mode in
+ :L) ac_source=$1;;
+ :[FH])
+ ac_file_inputs=
+ for ac_f
+ do
+ case $ac_f in
+ -) ac_f="$tmp/stdin";;
+ *) # Look for the file first in the build tree, then in the source tree
+ # (if the path is not absolute). The absolute path cannot be DOS-style,
+ # because $ac_f cannot contain `:'.
+ test -f "$ac_f" ||
+ case $ac_f in
+ [\\/$]*) false;;
+ *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";;
+ esac ||
+ { { echo "$as_me:$LINENO: error: cannot find input file: $ac_f" >&5
+echo "$as_me: error: cannot find input file: $ac_f" >&2;}
+ { (exit 1); exit 1; }; };;
+ esac
+ ac_file_inputs="$ac_file_inputs $ac_f"
+ done
+
+ # Let's still pretend it is `configure' which instantiates (i.e., don't
+ # use $as_me), people would be surprised to read:
+ # /* config.h. Generated by config.status. */
+ configure_input="Generated from "`IFS=:
+ echo $* | sed 's|^[^:]*/||;s|:[^:]*/|, |g'`" by configure."
+ if test x"$ac_file" != x-; then
+ configure_input="$ac_file. $configure_input"
+ { echo "$as_me:$LINENO: creating $ac_file" >&5
+echo "$as_me: creating $ac_file" >&6;}
+ fi
+
+ case $ac_tag in
+ *:-:* | *:-) cat >"$tmp/stdin";;
+ esac
+ ;;
+ esac
+
+ ac_dir=`$as_dirname -- "$ac_file" ||
+$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$ac_file" : 'X\(//\)[^/]' \| \
+ X"$ac_file" : 'X\(//\)$' \| \
+ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null ||
+echo X"$ac_file" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)[^/].*/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+ { as_dir="$ac_dir"
+ case $as_dir in #(
+ -*) as_dir=./$as_dir;;
+ esac
+ test -d "$as_dir" || { $as_mkdir_p && mkdir -p "$as_dir"; } || {
+ as_dirs=
+ while :; do
+ case $as_dir in #(
+ *\'*) as_qdir=`echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #(
+ *) as_qdir=$as_dir;;
+ esac
+ as_dirs="'$as_qdir' $as_dirs"
+ as_dir=`$as_dirname -- "$as_dir" ||
+$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$as_dir" : 'X\(//\)[^/]' \| \
+ X"$as_dir" : 'X\(//\)$' \| \
+ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||
+echo X"$as_dir" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)[^/].*/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+ test -d "$as_dir" && break
+ done
+ test -z "$as_dirs" || eval "mkdir $as_dirs"
+ } || test -d "$as_dir" || { { echo "$as_me:$LINENO: error: cannot create directory $as_dir" >&5
+echo "$as_me: error: cannot create directory $as_dir" >&2;}
+ { (exit 1); exit 1; }; }; }
+ ac_builddir=.
+
+case "$ac_dir" in
+.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
+*)
+ ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'`
+ # A ".." for each directory in $ac_dir_suffix.
+ ac_top_builddir_sub=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,/..,g;s,/,,'`
+ case $ac_top_builddir_sub in
+ "") ac_top_builddir_sub=. ac_top_build_prefix= ;;
+ *) ac_top_build_prefix=$ac_top_builddir_sub/ ;;
+ esac ;;
+esac
+ac_abs_top_builddir=$ac_pwd
+ac_abs_builddir=$ac_pwd$ac_dir_suffix
+# for backward compatibility:
+ac_top_builddir=$ac_top_build_prefix
+
+case $srcdir in
+ .) # We are building in place.
+ ac_srcdir=.
+ ac_top_srcdir=$ac_top_builddir_sub
+ ac_abs_top_srcdir=$ac_pwd ;;
+ [\\/]* | ?:[\\/]* ) # Absolute name.
+ ac_srcdir=$srcdir$ac_dir_suffix;
+ ac_top_srcdir=$srcdir
+ ac_abs_top_srcdir=$srcdir ;;
+ *) # Relative name.
+ ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix
+ ac_top_srcdir=$ac_top_build_prefix$srcdir
+ ac_abs_top_srcdir=$ac_pwd/$srcdir ;;
+esac
+ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix
+
+
+ case $ac_mode in
+ :F)
+ #
+ # CONFIG_FILE
+ #
+
+ case $INSTALL in
+ [\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;;
+ *) ac_INSTALL=$ac_top_build_prefix$INSTALL ;;
+ esac
+_ACEOF
+
+cat >>$CONFIG_STATUS <<\_ACEOF
+# If the template does not know about datarootdir, expand it.
+# FIXME: This hack should be removed a few years after 2.60.
+ac_datarootdir_hack=; ac_datarootdir_seen=
+
+case `sed -n '/datarootdir/ {
+ p
+ q
+}
+/@datadir@/p
+/@docdir@/p
+/@infodir@/p
+/@localedir@/p
+/@mandir@/p
+' $ac_file_inputs` in
+*datarootdir*) ac_datarootdir_seen=yes;;
+*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*)
+ { echo "$as_me:$LINENO: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5
+echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;}
+_ACEOF
+cat >>$CONFIG_STATUS <<_ACEOF
+ ac_datarootdir_hack='
+ s&@datadir@&$datadir&g
+ s&@docdir@&$docdir&g
+ s&@infodir@&$infodir&g
+ s&@localedir@&$localedir&g
+ s&@mandir@&$mandir&g
+ s&\\\${datarootdir}&$datarootdir&g' ;;
+esac
+_ACEOF
+
+# Neutralize VPATH when `$srcdir' = `.'.
+# Shell code in configure.ac might set extrasub.
+# FIXME: do we really want to maintain this feature?
+cat >>$CONFIG_STATUS <<_ACEOF
+ sed "$ac_vpsub
+$extrasub
+_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF
+:t
+/@[a-zA-Z_][a-zA-Z_0-9]*@/!b
+s&@configure_input@&$configure_input&;t t
+s&@top_builddir@&$ac_top_builddir_sub&;t t
+s&@srcdir@&$ac_srcdir&;t t
+s&@abs_srcdir@&$ac_abs_srcdir&;t t
+s&@top_srcdir@&$ac_top_srcdir&;t t
+s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t
+s&@builddir@&$ac_builddir&;t t
+s&@abs_builddir@&$ac_abs_builddir&;t t
+s&@abs_top_builddir@&$ac_abs_top_builddir&;t t
+s&@INSTALL@&$ac_INSTALL&;t t
+$ac_datarootdir_hack
+" $ac_file_inputs | sed -f "$tmp/subs-1.sed" >$tmp/out
+
+test -z "$ac_datarootdir_hack$ac_datarootdir_seen" &&
+ { ac_out=`sed -n '/\${datarootdir}/p' "$tmp/out"`; test -n "$ac_out"; } &&
+ { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' "$tmp/out"`; test -z "$ac_out"; } &&
+ { echo "$as_me:$LINENO: WARNING: $ac_file contains a reference to the variable \`datarootdir'
+which seems to be undefined. Please make sure it is defined." >&5
+echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir'
+which seems to be undefined. Please make sure it is defined." >&2;}
+
+ rm -f "$tmp/stdin"
+ case $ac_file in
+ -) cat "$tmp/out"; rm -f "$tmp/out";;
+ *) rm -f "$ac_file"; mv "$tmp/out" $ac_file;;
+ esac
+ ;;
+ :H)
+ #
+ # CONFIG_HEADER
+ #
+_ACEOF
+
+# Transform confdefs.h into a sed script `conftest.defines', that
+# substitutes the proper values into config.h.in to produce config.h.
+rm -f conftest.defines conftest.tail
+# First, append a space to every undef/define line, to ease matching.
+echo 's/$/ /' >conftest.defines
+# Then, protect against being on the right side of a sed subst, or in
+# an unquoted here document, in config.status. If some macros were
+# called several times there might be several #defines for the same
+# symbol, which is useless. But do not sort them, since the last
+# AC_DEFINE must be honored.
+ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]*
+# These sed commands are passed to sed as "A NAME B PARAMS C VALUE D", where
+# NAME is the cpp macro being defined, VALUE is the value it is being given.
+# PARAMS is the parameter list in the macro definition--in most cases, it's
+# just an empty string.
+ac_dA='s,^\\([ #]*\\)[^ ]*\\([ ]*'
+ac_dB='\\)[ (].*,\\1define\\2'
+ac_dC=' '
+ac_dD=' ,'
+
+uniq confdefs.h |
+ sed -n '
+ t rset
+ :rset
+ s/^[ ]*#[ ]*define[ ][ ]*//
+ t ok
+ d
+ :ok
+ s/[\\&,]/\\&/g
+ s/^\('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/ '"$ac_dA"'\1'"$ac_dB"'\2'"${ac_dC}"'\3'"$ac_dD"'/p
+ s/^\('"$ac_word_re"'\)[ ]*\(.*\)/'"$ac_dA"'\1'"$ac_dB$ac_dC"'\2'"$ac_dD"'/p
+ ' >>conftest.defines
+
+# Remove the space that was appended to ease matching.
+# Then replace #undef with comments. This is necessary, for
+# example, in the case of _POSIX_SOURCE, which is predefined and required
+# on some systems where configure will not decide to define it.
+# (The regexp can be short, since the line contains either #define or #undef.)
+echo 's/ $//
+s,^[ #]*u.*,/* & */,' >>conftest.defines
+
+# Break up conftest.defines:
+ac_max_sed_lines=50
+
+# First sed command is: sed -f defines.sed $ac_file_inputs >"$tmp/out1"
+# Second one is: sed -f defines.sed "$tmp/out1" >"$tmp/out2"
+# Third one will be: sed -f defines.sed "$tmp/out2" >"$tmp/out1"
+# et cetera.
+ac_in='$ac_file_inputs'
+ac_out='"$tmp/out1"'
+ac_nxt='"$tmp/out2"'
+
+while :
+do
+ # Write a here document:
+ cat >>$CONFIG_STATUS <<_ACEOF
+ # First, check the format of the line:
+ cat >"\$tmp/defines.sed" <<\\CEOF
+/^[ ]*#[ ]*undef[ ][ ]*$ac_word_re[ ]*\$/b def
+/^[ ]*#[ ]*define[ ][ ]*$ac_word_re[( ]/b def
+b
+:def
+_ACEOF
+ sed ${ac_max_sed_lines}q conftest.defines >>$CONFIG_STATUS
+ echo 'CEOF
+ sed -f "$tmp/defines.sed"' "$ac_in >$ac_out" >>$CONFIG_STATUS
+ ac_in=$ac_out; ac_out=$ac_nxt; ac_nxt=$ac_in
+ sed 1,${ac_max_sed_lines}d conftest.defines >conftest.tail
+ grep . conftest.tail >/dev/null || break
+ rm -f conftest.defines
+ mv conftest.tail conftest.defines
+done
+rm -f conftest.defines conftest.tail
+
+echo "ac_result=$ac_in" >>$CONFIG_STATUS
+cat >>$CONFIG_STATUS <<\_ACEOF
+ if test x"$ac_file" != x-; then
+ echo "/* $configure_input */" >"$tmp/config.h"
+ cat "$ac_result" >>"$tmp/config.h"
+ if diff $ac_file "$tmp/config.h" >/dev/null 2>&1; then
+ { echo "$as_me:$LINENO: $ac_file is unchanged" >&5
+echo "$as_me: $ac_file is unchanged" >&6;}
+ else
+ rm -f $ac_file
+ mv "$tmp/config.h" $ac_file
+ fi
+ else
+ echo "/* $configure_input */"
+ cat "$ac_result"
+ fi
+ rm -f "$tmp/out12"
+ ;;
+
+
+ esac
+
+
+ case $ac_file$ac_mode in
+ "Makefile":F) chmod a-w Makefile ;;
+ "cil.spec":F) chmod a-w cil.spec ;;
+ "config.mk":F) chmod a-w config.mk ;;
+ "test/Makefile":F) chmod a-w test/Makefile ;;
+ "bin/cilly.bat":F) chmod a-w,a+x bin/cilly.bat ;;
+ "bin/patcher.bat":F) chmod a-w,a+x bin/patcher.bat ;;
+ "bin/CilConfig.pm":F) chmod a-w bin/CilConfig.pm ;;
+ "doc/index.html":F) chmod a-w doc/index.html ;;
+ "doc/header.html":F) chmod a-w doc/header.html ;;
+ "ocamlutil/perfcount.c":F) chmod a-w ocamlutil/perfcount.c ;;
+
+ esac
+done # for ac_tag
+
+
+{ (exit 0); exit 0; }
+_ACEOF
+chmod +x $CONFIG_STATUS
+ac_clean_files=$ac_clean_files_save
+
+
+# configure is writing to config.log, and then calls config.status.
+# config.status does its own redirection, appending to config.log.
+# Unfortunately, on DOS this fails, as config.log is still kept open
+# by configure, so config.status won't be able to write to it; its
+# output is simply discarded. So we exec the FD to /dev/null,
+# effectively closing config.log, so it can be properly (re)opened and
+# appended to by config.status. When coming back to configure, we
+# need to make the FD available again.
+if test "$no_create" != yes; then
+ ac_cs_success=:
+ ac_config_status_args=
+ test "$silent" = yes &&
+ ac_config_status_args="$ac_config_status_args --quiet"
+ exec 5>/dev/null
+ $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false
+ exec 5>>config.log
+ # Use ||, not &&, to avoid exiting from the if with $? = 1, which
+ # would make configure fail if this is the last instruction.
+ $ac_cs_success || { (exit 1); exit 1; }
+fi
+
+
+# show the user what the variables have been set to
+cat <<EOF
+
+CIL configuration:
+ architecture/OS: ARCHOS $ARCHOS
+ source tree root: CILHOME $CILHOME
+ (optional) cl.exe found: HAS_MSVC $HAS_MSVC
+ gcc to use CC $CC
+ default compiler DEFAULT_COMPILER $DEFAULT_COMPILER
+ CIL version CIL_VERSION $CIL_VERSION
+ CIL features CIL_FEATURES $CIL_FEATURES
+ Extra source directories EXTRASRCDIRS $EXTRASRCDIRS
+ Cycles per microsecond CYCLES_PER_USEC $CYCLES_PER_USEC
+EOF
--- /dev/null
+# configure.in for CIL -*- sh -*-
+# Process this file with autoconf to produce a configure script.
+
+# Autoconf runs this through the M4 macroprocessor first; lines
+# starting with "dnl" are comments to M4. The result is a bash
+# script; any text which isn't an M4/autoconf directive gets
+# copied verbatim to that script.
+
+# also, in general, watch out: the M4 quoting charactes are
+# the square brackets: [ and ]. if you want to pass brackets
+# to something, you can quote the brackets with more brackets.
+# I don't know how to pass a single (unbalanced) bracket ..
+
+# sm: changed this file to use '#' for comments, since that's
+# just as good (since this becomes an 'sh' script)
+
+
+
+
+# -------------- usual initial stuff -------------
+# this simply names a file somewhere in the source tree to verify
+# we're in the right directory
+AC_INIT(src/cil.mli)
+AC_CONFIG_HEADERS(config.h)
+
+# sm: require a late-enough autoconf; this is the version number
+# that's on manju, so I assume it's ok
+AC_PREREQ(2.50)
+
+#
+# Assign here the CIL version numbers
+CIL_VERSION_MAJOR=1
+CIL_VERSION_MINOR=3
+CIL_VERSION_REV=6
+CIL_VERSION=$CIL_VERSION_MAJOR.$CIL_VERSION_MINOR.$CIL_VERSION_REV
+
+
+# make sure I haven't forgotten to run autoconf
+if test configure -ot configure.in; then
+ AC_MSG_ERROR(configure is older than configure.in; you forgot to run autoconf)
+fi
+
+# check for C compiler; this typically finds gcc; it sets the
+# variable CC to whatever it finds, which then gets substituted
+# 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_PROG_INSTALL
+
+# 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!)
+AC_CANONICAL_SYSTEM
+
+
+# ---------------- generic functions -----------------
+# debugging diagnostic; set to 'echo' to debug or 'true' for production
+# (technically you're not supposed to use shell functions in
+# configure scripts, because some-obscure-sh somewhere doesn't
+# support them.. but they're too convenient to not use)
+diagnostic() {
+ #echo "$@"
+ true "$@"
+}
+
+# determine if a binary is in the path
+binaryExists() {
+ # on cygwin, 'which' always returns success, so use 'type' instead
+ if type "$1" >/dev/null 2>&1; then
+ return 0
+ else
+ return 1
+ fi
+}
+
+
+# -------------- portable configuration ----------------
+# this specifies the root of the source tree; it's just the
+# directory where ./configure runs, except on cygwin, which
+# overrides this below
+CILHOME=`pwd`
+
+DEFAULT_COMPILER=_GNUCC
+DEFAULT_CIL_MODE=GNUCC
+
+# is the microsoft compiler available?
+# hmm.. I think we should check the version or something, because
+# sometimes people have Common Lisp's interpreter called 'cl' ..
+AC_MSG_CHECKING(for msvc cl.exe (optional))
+# See if CC points to the MS compiler
+if "$CC" 2>&1 | grep "Microsoft" >/dev/null; then
+ AC_MSG_RESULT([found, set as default])
+ HAS_MSVC=yes
+ DEFAULT_COMPILER=_MSVC
+ DEFAULT_CIL_MODE=MSVC
+else
+ if cl 2>&1 | grep "Microsoft" >/dev/null ;then
+ AC_MSG_RESULT(found)
+ HAS_MSVC=yes
+ else
+ AC_MSG_RESULT(not found)
+ HAS_MSVC=no
+ fi
+fi
+
+# is ocaml available?
+# needed binaries: ocamllex ocamlyacc ocamldep ocamlopt ocamlc
+ocamlDownloadInstructions="
+ OCaml can be downloaded from http://caml.inria.fr/ocaml/.
+ After downloading and unpacking the source distribution, in the ocaml
+ directory, do
+ ./configure
+ make world
+ make opt
+ make install
+ Then come back here and re-run ./configure."
+
+# required major/minor.
+# required major/minor
+reqMaj=3
+reqMin=08
+knownMaj=3
+knownMin=10
+AC_MSG_CHECKING(ocaml version is at least $reqMaj.$reqMin)
+if binaryExists ocamlc; then
+ # what version?
+ ver=`ocamlc -v | grep version | sed 's/^.*version //'`
+ diagnostic "ver is $ver"
+ # major: anything before the .
+ major=`echo $ver | sed 's/\..*$//'`
+ diagnostic "major is $major"
+ # minor: numbers after the .
+ # (the outer level of bracket-quotation protects the inner brackets)
+ [minor=`echo $ver | sed 's/^[^.]*\.\([0-9][0-9]*\).*$/\1/'`]
+ diagnostic "minor is $minor"
+
+ # I would think autoconf would already have a facility for doing
+ # these kinds of major/minor version checks, but I can't find it
+ if test $major -gt $reqMaj -o $major -ge $reqMaj -a $minor -ge $reqMin; then
+ AC_MSG_RESULT([version is $ver, ok])
+
+ # sm: added this test when we found that CCured needed to be changed
+ # a little when 3.06 came out (it had previously worked with 3.04)
+ if test "$major" -gt $knownMaj -o "$major" -ge $knownMaj -a "$minor" -gt $knownMin; then
+ AC_MSG_WARN([Your ocaml version is $ver, but the latest version this program
+ is known to work with is $knownMaj.$knownMin. If you have
+ trouble compiling, please try using an earlier version
+ or see if there is a later version of this program.])
+ fi
+ else
+ AC_MSG_ERROR([
+ I found OCaml version $ver; this program requires at least $reqMaj.$reqMin.
+ Please download a newer OCaml distribution.
+ $ocamlDownloadInstructions
+ ])
+ fi
+
+ # check for existence of other binaries
+ AC_MSG_CHECKING(existence of related ocaml tools)
+ if binaryExists ocamllex && \
+ binaryExists ocamlyacc && \
+ binaryExists ocamldep && \
+ binaryExists ocamlopt; then
+ AC_MSG_RESULT(ok)
+ else
+ AC_MSG_ERROR([
+ At least one of ocamllex, ocamlyacc, ocamldep or ocamlopt is missing.
+ In particular, ocamlopt requires you to "make opt" when building
+ OCaml from source. Please make sure all these tools are built and
+ in the path.
+ ])
+ fi
+else
+ AC_MSG_ERROR([
+ The "ocamlc" OCaml compiler was not found in the path: $PATH.
+
+ Most of this program is written in the OCaml language, so its compiler
+ is required.
+ $ocamlDownloadInstructions
+ ])
+fi
+
+#
+# ------------------- Perl ----------------
+#
+AC_MSG_CHECKING([for Perl])
+ if ! binaryExists perl; then
+ AC_MSG_ERROR([
+ perl not found.
+ You need perl version 5.6.1 or later for CIL.
+ You can get perl at http://www.cpan.org/src/index.html .
+ ])
+ fi
+
+ # sm: oh how nice it would be to just say "use English;
+ # print($PERL_VERSION)", but that appears broken on 5.6.1.. so I'm
+ # trying to say "caret right-bracket", but then that would run afoul
+ # of autoconf's quoting characters, so I use the "quadrigraph" @:>@
+ # to stand for right-bracket. what a mess.
+ perlver=`perl -e 'print($@:>@);'`
+ if perl -e "exit( $perlver >= 5.006001 );"; then
+ AC_MSG_ERROR([
+ Found perl version $perlver, but at least 5.6.1 is required.
+ You can get a newer perl at http://www.cpan.org/src/index.html .
+ ])
+ fi
+
+ perlport=`perl -e "print $^O;"`
+ case "$perlport" in
+ cygwin)
+ ;;
+ MSWin32) # ActivePerl
+ ;;
+ linux)
+ ;;
+ freebsd)
+ ;;
+ openbsd)
+ ;;
+ darwin) # Mac OS X
+ ;;
+ solaris)
+ ;;
+ *)
+ AC_MSG_ERROR([
+ Unsupported Perl port $perlport -- sorry.
+ cygwin, MSWin32 (ActivePerl), linux, freebsd, openbsd, darwin,
+ and solaris are the supported ports.
+ ])
+ esac
+AC_MSG_RESULT([found version $perlver, port $perlport])
+
+ # The cygwin port has some bugs in the File::Spec module
+if test "$perlport" = "cygwin" ;then
+ AC_MSG_CHECKING([for known cygwin Perl bug in File::Spec])
+ perlfixres=[`perl -e '
+ use File::Spec;
+ if(File::Spec->file_name_is_absolute("C:/test")) {
+ print "no bug found"; exit 0;
+ } else {
+ print "bug";
+ foreach $d (@INC) {
+ if(-f "$d/File/Spec/Unix.pm") {
+ open(IN, "<$d/File/Spec/Unix.pm");
+ open(OUT, ">$d/File/Spec/Unix.pm.fixed")
+ || die "Cannot open $d/File/Spec/Unix.pm.fixed";
+ while(<IN>) {
+ if($_ =~ m|sub file_name_is_absolute|) {
+ print OUT $_;
+ print OUT scalar(<IN>);
+ print OUT <<EOF;
+ if(\\$^O eq \"cygwin\") {
+ return scalar(\\$file =~ m{^(\\[a-z\\]:)?\\[\\\\\\\\/\\]}is);
+};
+EOF
+ next;
+ }
+ print OUT $_;
+ }
+ close(OUT);
+ close(IN);
+ system("mv -f $d/File/Spec/Unix.pm.fixed $d/File/Spec/Unix.pm");
+ }
+ }
+ }
+ '`]
+ # See if it was indeed fixed
+ if test "$perlfixres" = "bug" ;then
+ perlfixres=`perl -e '
+ use File::Spec;
+ if(File::Spec->file_name_is_absolute("C:/test")) {
+ print "bug fixed"; exit 0;
+ } else {
+ print "cannot fix bug"; exit 1;
+ }'`
+ fi
+ if test "x$perlfixres" = "x" ;then
+ AC_MSG_ERROR([
+ Cannot run perl
+ ])
+ elif test "$perlfixres" = "cannot fix bug" ;then
+ AC_MSG_ERROR([
+ Found a bug but cannot fix it.
+ ])
+ else
+ AC_MSG_RESULT([$perlfixres])
+ fi
+fi
+
+#
+# Now setup the performance counters
+#
+# At runtime, we'll try to get the cycle speed from /proc/cpuinfo
+# or FreeBSD sysctl. This means binaries can be moved to different computers.
+# CYCLES_PER_USEC is only a backup in case these aren't available.
+# (See the subversion history for the old code that read /proc/cpuinfo here.)
+AC_MSG_CHECKING(if performance counters are usable)
+# Create a C file from src/perfcount.c.in
+rm -f ./cycles.exe
+if gcc -DCONFIGURATION_ONLY \
+ -x c ocamlutil/perfcount.c.in -lm -o ./cycles.exe >/dev/null 2>&1; then
+
+ if CYCLES_PER_USEC=`./cycles.exe 2>&1` ;then
+ AC_MSG_RESULT([ok ($CYCLES_PER_USEC cycles per us)])
+ else
+ # Print what we got
+ AC_MSG_RESULT([no ($CYCLES_PER_USEC)])
+ CYCLES_PER_USEC=0
+ fi
+else
+ CYCLES_PER_USEC=0
+ AC_MSG_RESULT([no (cannot compile perfcount.c)])
+fi
+rm -f ./cycles.exe
+
+if test "$CYCLES_PER_USEC" != "0" ;then
+ HAS_PERFCOUNT=1
+else
+ HAS_PERFCOUNT=0
+fi
+
+# additional tools we might check for:
+# - gnu make
+
+#
+# -------------------- GCC --------------
+#
+
+AC_MSG_CHECKING([for gcc version])
+AC_CHECK_TYPE(__builtin_va_list,
+ HAVE_BUILTIN_VA_LIST=true,
+ HAVE_BUILTIN_VA_LIST=false)
+AC_MSG_CHECKING([if __thread is a keyword])
+AC_COMPILE_IFELSE([int main(int __thread) { return 0; }],
+ THREAD_IS_KEYWORD=false,
+ THREAD_IS_KEYWORD=true)
+AC_MSG_RESULT($THREAD_IS_KEYWORD)
+
+# Does gcc add underscores to identifiers to make assembly labels?
+# (I think MSVC always does)
+AC_MSG_CHECKING([if gcc adds underscores to assembly labels.])
+AC_LINK_IFELSE([int main() { __asm__("jmp _main"); }],
+ UNDERSCORE_NAME=true,
+ UNDERSCORE_NAME=false)
+AC_MSG_RESULT($UNDERSCORE_NAME)
+
+
+# ----------- some stuff 'autoscan' put here --------------
+# (autoscan is part of the autoconf distribution)
+
+# checks for header files
+AC_HEADER_STDC
+AC_CHECK_HEADERS(stdlib.h strings.h sys/time.h unistd.h wchar.h)
+
+# checks for typedefs, structures, and compiler characteristics
+AC_C_CONST
+AC_C_INLINE
+AC_HEADER_TIME
+
+# checks for library functions; more autoscan stuff
+AC_FUNC_MEMCMP
+AC_CHECK_FUNCS(mkdir select socket __sysv_signal)
+
+# Find out the true definitions of some integer types
+CIL_CHECK_INTEGER_TYPE(size_t, TYPE_SIZE_T)
+CIL_CHECK_INTEGER_TYPE(wchar_t, TYPE_WCHAR_T)
+
+
+# ----------- platform-specific code -------------
+# $target is typically processor-vendor-os
+case "$target" in
+
+ *86*linux*)
+ AC_MSG_RESULT(configuring for linux/x86)
+
+ ARCHOS=x86_LINUX
+ ;;
+
+ *86*openbsd*)
+ AC_MSG_RESULT(configuring for OpenBSD/x86)
+
+ ARCHOS=x86_OPENBSD
+ ;;
+
+ *i386*freebsd*|*amd64*freebsd*)
+
+ if test x"${ARCH}" = x""; then
+ ARCH=`uname -p`
+ fi
+
+ AC_MSG_RESULT(configuring for freebsd/${ARCH})
+
+ ARCHOS=${ARCH}_FREEBSD
+ ;;
+
+
+ # Mac OS X
+ *86*darwin*)
+ AC_MSG_RESULT(configuring for darwin/x86)
+
+ ARCHOS=x86_DARWIN
+ ;;
+
+ *powerpc*darwin*)
+ AC_MSG_RESULT(configuring for powerpc/darwin, which we treat like linux/x86)
+
+ ARCHOS=ppc_DARWIN
+ ;;
+
+ # cygwin
+ *86*cygwin*)
+ AC_MSG_RESULT(configuring for Cygwin on win32/x86)
+
+ ARCHOS=x86_WIN32
+
+ # override CILHOME; even on cygwin we want forward slashes
+ # sm: I folded this into what I hope will be the only
+ # case-analysis of machine type
+ #CILHOME=`cygpath -wa "$CILHOME" | sed -e "s/\\\\\/\\//g"`
+ # Try to use the Unix paths even on cygwin. The newest versions of make
+ # do not like colons in file names
+ CILHOME=`cygpath -u "$CILHOME"`
+ CC=`which $CC`
+ CC=`cygpath -wa "$CC" | sed -e "s/\\\\\/\\//g"`
+ ;;
+
+ # Solaris
+ *sparc*solaris*)
+ AC_MSG_RESULT(configuring for SPARC/Solaris)
+
+ ARCHOS=sparc_SOLARIS
+ ;;
+
+ *)
+ AC_MSG_ERROR([
+ Unsupported platform $target -- sorry.
+ ./configure supports these platforms:
+ on x86: Linux, Win32(with Cygwin), FreeBSD, OpenBSD, and Mac OS X
+ on amd64: FreeBSD
+ on PowerPC: Mac OS X
+ on SPARC: Solaris
+ ])
+ ;;
+esac
+
+# Make the object directory if not already present
+AC_CHECK_FILE(obj/$ARCHOS,, AC_MSG_RESULT(creating obj/$ARCHOS);
+ mkdir -p obj/$ARCHOS)
+
+AC_MSG_CHECKING([delete the obj/$ARCHOS/feature_config.ml and obj/$ARCHOS/machdep.ml file])
+rm -f obj/$ARCHOS/machdep.ml
+rm -f obj/.depend/machdep.d
+rm -f obj/$ARCHOS/feature_config.ml
+rm -f obj/.depend/feature_config.d
+AC_MSG_RESULT([done])
+
+
+
+#
+# CIL features
+#
+#
+
+# Set the defaults
+
+
+# Give a space-separated list of features with the defaults
+features="blockinggraph=no zrapp=no"
+
+AC_ARG_WITH(blockinggraph,
+ AC_HELP_STRING([--with-blockinggraph],
+ [enable the blocking graph feature]))
+AC_ARG_WITH(zrapp,
+ AC_HELP_STRING([--with-zrapp],
+ [enable the zrapp pretty-printer]))
+
+# Now add any features specified in the command-line
+
+features="$features $EXTRAFEATURES"
+
+rm -f Makefile.features
+echo "# -*- Mode: makefile -*-">Makefile.features
+echo "# This file was generated automatically by ./configure.in">>Makefile.features
+echo "# We will not need this once configure supports multiline variables">>Makefile.features
+
+for f_val in $features
+do
+ # If there is no =, then we default to yes
+ if ! (echo $f_val | grep "=" >/dev/null) ;then f_val="$f_val=yes"; fi
+ # echo "Testing feature $f_val"
+ f=`echo $f_val | sed -e s%=.*$%%`
+ AC_MSG_CHECKING(whether to use CIL feature $f)
+ # default value from "features"
+ defval=`echo $f_val | sed -e s%^.*=%%`
+ # current value
+ getcurval="echo \${with_$f:=$defval}"
+ curval=`eval $getcurval`
+ AC_MSG_RESULT($curval)
+ if test $curval = yes ;then
+ CIL_FEATURES="$CIL_FEATURES $f"
+ f_up=`echo $f | tr a-z A-Z`
+ echo "export USE_$f_up=yes">>Makefile.features
+ fi
+done
+echo "TYPE_SIZE_T=\"$TYPE_SIZE_T\"" >>Makefile.features
+echo "TYPE_WCHAR_T=\"$TYPE_WCHAR_T\"" >>Makefile.features
+chmod -w Makefile.features
+
+
+# ----------------- finish up -------------------
+# names of the variables that get substituted in files; for example,
+# write @ARCHOS@ somewhere in a written file to get it substituted
+AC_SUBST(ARCHOS)
+AC_SUBST(CILHOME)
+AC_SUBST(HAS_MSVC)
+AC_SUBST(DEFAULT_COMPILER)
+AC_SUBST(DEFAULT_CIL_MODE)
+AC_SUBST(CIL_VERSION_MAJOR)
+AC_SUBST(CIL_VERSION_MINOR)
+AC_SUBST(CIL_VERSION_REV)
+AC_SUBST(CIL_VERSION)
+AC_SUBST(CYCLES_PER_USEC)
+AC_SUBST(HAS_PERFCOUNT)
+AC_SUBST(HAVE_BUILTIN_VA_LIST)
+AC_SUBST(THREAD_IS_KEYWORD)
+AC_SUBST(UNDERSCORE_NAME)
+AC_SUBST(EXTRAFEATURES)
+AC_SUBST(EXTRASRCDIRS)
+
+# finish the configure script and generate various files; ./configure
+# will apply variable substitutions to <filename>.in to generate <filename>;
+
+CIL_CONFIG_FILES(Makefile)
+CIL_CONFIG_FILES(cil.spec)
+CIL_CONFIG_FILES(config.mk)
+CIL_CONFIG_FILES(test/Makefile)
+CIL_CONFIG_EXE_FILES(bin/cilly.bat)
+CIL_CONFIG_EXE_FILES(bin/patcher.bat)
+CIL_CONFIG_FILES(bin/CilConfig.pm)
+CIL_CONFIG_FILES(doc/index.html)
+CIL_CONFIG_FILES(doc/header.html)
+CIL_CONFIG_FILES(ocamlutil/perfcount.c)
+
+AC_OUTPUT()
+
+# show the user what the variables have been set to
+cat <<EOF
+
+CIL configuration:
+ architecture/OS: ARCHOS $ARCHOS
+ source tree root: CILHOME $CILHOME
+ (optional) cl.exe found: HAS_MSVC $HAS_MSVC
+ gcc to use CC $CC
+ default compiler DEFAULT_COMPILER $DEFAULT_COMPILER
+ CIL version CIL_VERSION $CIL_VERSION
+ CIL features CIL_FEATURES $CIL_FEATURES
+ Extra source directories EXTRASRCDIRS $EXTRASRCDIRS
+ Cycles per microsecond CYCLES_PER_USEC $CYCLES_PER_USEC
+EOF
--- /dev/null
+build-stamp
+cil
+cil-dev
+files
+tmp
--- /dev/null
+cil (1.3.6-1) unstable; urgency=low
+
+ * New upstream release
+
+ -- Luis Cañas DÃaz <lcanas@gsyc.es> Fri, 15 Jan 2008 14:00:52 +0200
+
+cil (1.3.5-1) unstable; urgency=low
+
+ * New upstream release
+
+ -- Luis Cañas DÃaz <lcanas@gsyc.es> Tue, 17 Apr 2007 18:30:53 +0200
+
+cil (1.3.2-1) unstable; urgency=low
+
+ * New upstream release
+
+ -- Ben Liblit <liblit@cs.wisc.edu> Sat, 5 Mar 2005 22:08:14 -0600
+
+cinterlang (1.3.1-1) unstable; urgency=low
+
+ * New upstream release
+
+ -- Jesus M. Gonzalez-Barahona <jgb@debian.org> Thu, 19 Aug 2004 15:46:39 +0000
+
+cinterlang (1.2.5-1) unstable; urgency=low
+
+ * Initial Release.
+
+ -- Jesus M. Gonzalez-Barahona <jgb@debian.org> Wed, 18 Aug 2004 00:40:43 +0200
--- /dev/null
+usr/lib
+usr/share/doc/cil-dev
--- /dev/null
+usr/share/cil
+usr/share/doc/cil
--- /dev/null
+Source: cil
+Section: devel
+Priority: optional
+Maintainer: Ben Liblit <liblit@cs.wisc.edu>
+Build-Depends: autotools-dev, debhelper (>= 4.0.0), fakeroot, hevea, libc6-i686, libncurses5-dev, locales, ocaml-base-nox (>= 3.08), ocaml-interp (>= 3.08), ocaml-nox (>= 3.08), perl-base (>= 5.6.1)
+Standards-Version: 3.6.1
+
+Package: cil
+Architecture: any
+Depends: perl (>= 5.6.1)
+Description: OCaml library for C program analysis and transformation
+ CIL (C Intermediate Language) is a high-level representation along
+ with a set of tools that permit easy analysis and source-to-source
+ transformation of C programs.
+ .
+ This package provides Perl modules which are useful for building
+ compiler wrappers. A wrapper can use CIL to transform C code before
+ passing it along to the native C compiler.
+
+Package: cil-dev
+Architecture: any
+Depends: ocaml (>= 3.08)
+Description: OCaml library for C program analysis and transformation
+ CIL (C Intermediate Language) is a high-level representation along
+ with a set of tools that permit easy analysis and source-to-source
+ transformation of C programs.
+ .
+ This package provides OCaml interfaces and an OCaml library which form
+ the CIL API.
--- /dev/null
+This package is maintained by Ben Liblit <liblit@cs.wisc.edu> based on
+initial debianizing by Jesus M. Gonzalez-Barahona <jgb@debian.org>.
+
+It was downloaded from http://manju.cs.berkeley.edu/cil/distrib
+
+Upstream Authors: George C. Necula <necula@cs.berkeley.edu>,
+ Scott McPeak <smcpeak@cs.berkeley.edu>,
+ Wes Weimer <weimer@cs.berkeley.edu>,
+ Ben Liblit <liblit@cs.wisc.edu>
+
+Copyright:
+
+Copyright (c) 2001-2005,
+ George C. Necula <necula@cs.berkeley.edu>
+ Scott McPeak <smcpeak@cs.berkeley.edu>
+ Wes Weimer <weimer@cs.berkeley.edu>
+ Ben Liblit <liblit@cs.wisc.edu>
+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.
+
+(See http://www.opensource.org/licenses/bsd-license.php)
--- /dev/null
+#!/usr/bin/make -f
+
+# These are used for cross-compiling and for saving the configure script
+# from having to guess our platform (since we know it already)
+DEB_HOST_GNU_TYPE ?= $(shell dpkg-architecture -qDEB_HOST_GNU_TYPE)
+DEB_BUILD_GNU_TYPE ?= $(shell dpkg-architecture -qDEB_BUILD_GNU_TYPE)
+
+CFLAGS = -Wall -g
+
+ifneq (,$(findstring noopt,$(DEB_BUILD_OPTIONS)))
+ CFLAGS += -O0
+else
+ CFLAGS += -O2
+endif
+ifeq (,$(findstring nostrip,$(DEB_BUILD_OPTIONS)))
+ INSTALL_PROGRAM += -s
+endif
+
+config.status: configure
+ dh_testdir
+ # Add here commands to configure the package.
+ CFLAGS="$(CFLAGS)" ./configure --host=$(DEB_HOST_GNU_TYPE) --build=$(DEB_BUILD_GNU_TYPE) --prefix=/usr --mandir=\$${prefix}/share/man --infodir=\$${prefix}/share/info
+
+build: debian/build-stamp
+
+debian/build-stamp: config.status
+ dh_testdir
+ # Add here commands to compile the package.
+ $(MAKE) setup #doc
+ touch $@
+
+check: build
+ $(MAKE) check
+
+
+clean: config.status
+ dh_testdir
+ dh_testroot
+ rm -f debian/build-stamp
+ # Add here commands to clean up after the build process.
+ -$(MAKE) distclean
+ rm -f config.status
+ifneq "$(wildcard /usr/share/misc/config.sub)" ""
+ cp -f /usr/share/misc/config.sub config.sub
+endif
+ifneq "$(wildcard /usr/share/misc/config.guess)" ""
+ cp -f /usr/share/misc/config.guess config.guess
+endif
+ dh_clean
+
+install: build
+ dh_testdir
+ dh_testroot
+ dh_clean -k
+ dh_installdirs
+ $(MAKE) install DESTDIR=$(CURDIR)/debian/tmp
+ mkdir -p $(CURDIR)/debian/tmp/usr/share/doc/cil/html
+ mkdir -p $(CURDIR)/debian/tmp/usr/share/doc/cil-dev
+ cp LICENSE $(CURDIR)/debian/tmp/usr/share/doc/cil/
+ cp LICENSE $(CURDIR)/debian/tmp/usr/share/doc/cil-dev/
+ #cp -f doc/*.html $(CURDIR)/debian/tmp/usr/share/doc/cil/html
+ #cp -f doc/*.gif $(CURDIR)/debian/tmp/usr/share/doc/cil/html
+ #cp -a doc/api $(CURDIR)/debian/tmp/usr/share/doc/cil/html
+ #cp -a doc/*.pdf $(CURDIR)/debian/tmp/usr/share/doc/cil
+ #cp -a doc/examples $(CURDIR)/debian/tmp/usr/share/doc/cil
+
+# Build architecture-independent files here.
+binary-indep: build install
+# We have nothing to do by default.
+
+# Build architecture-dependent files here.
+binary-arch: build install
+ dh_testdir
+ dh_testroot
+ dh_installchangelogs
+ dh_installdocs
+ dh_installexamples
+ dh_install --list-missing --sourcedir=$(CURDIR)/debian/tmp
+ dh_installman
+ dh_link
+ dh_strip
+ dh_compress
+ dh_fixperms
+ dh_installdeb
+ dh_gencontrol
+ dh_md5sums
+ dh_builddeb
+
+binary: binary-indep binary-arch
+.PHONY: build clean binary-indep binary-arch binary install
--- /dev/null
+# Example watch control file for uscan
+# Rename this file to "watch" and then you can run the "uscan" command
+# to check for upstream updates and more.
+# Site Directory Pattern Version Script
+version=2
+http://manju.cs.berkeley.edu/cil/distrib/cil-(.*)\.tar\.gz
--- /dev/null
+*.mfj
+*.dvi
+*.aux
+*.ps
+*.log
+*.blg
+*.bbl
+*.lof
+*.lot
+*.toc
+*.pdf
+*.png
+*.out
+*.xyc
+*.xyd
+auto
+cil-api.tex
+cil.version.tex
+cilpp.tex
+cilcode.tmp
+cil.version
+header.html
+index.html
+ocamldoc.sty
--- /dev/null
+cil.docdir/index.html
--- /dev/null
+Alpha
+Cfg
+Cil
+Cillower
+Clist
+Dataflow
+Dominators
+Errormsg
+Formatcil
+Pretty
+Stats
--- /dev/null
+\documentclass{article}
+
+\usepackage{hevea}
+
+% ww: this gibberish is ignored by hevea but makes the PDF look better
+\begin{latexonly}
+\oddsidemargin 4.5pc
+\evensidemargin 4.5pc
+\advance\oddsidemargin by -1.2in
+\advance\evensidemargin by -1.2in
+\marginparwidth 0pt
+\marginparsep 11pt
+\topmargin 4.5pc
+\advance\topmargin by -1in
+\headheight 0pt
+\headsep 0pt
+\advance\topmargin by -37pt
+\headheight 12pt
+\headsep 25pt
+\textheight 666pt
+\textwidth 44pc
+\end{latexonly}
+
+% cilversion.tex is generated automatically to define \cilversion
+\include{cil.version}
+
+\def\secref#1{Section~\ref{sec-#1}}
+\def\chref#1{Chapter~\ref{ch-#1}}
+
+\def\apiref#1#2#3{\ahref{api/#1.html\##2#3}{#1.#3}}
+\def\moduleref#1{\ahref{api/#1.html}{#1}}
+
+% Use this to refer to a Cil type/val
+\def\ciltyperef#1{\apiref{Cil}{TYPE}{#1}}
+\def\cilvalref#1{\apiref{Cil}{VAL}{#1}}
+\def\cilvisit#1{\apiref{Cil.cilVisitor}{#1}}
+\def\cilprinter#1{\apiref{Cil.cilPrinter}{#1}}
+
+% Use this to refer to a type/val in the Pretty module
+\def\ptyperef#1{\apiref{Pretty}{TYPE}{#1}}
+\def\pvalref#1{\apiref{Pretty}{VAL}{#1}}
+
+% Use this to refer to a type/val in the Errormsg module
+\def\etyperef#1{\apiref{Errormsg}{TYPE}{#1}}
+\def\evalref#1{\apiref{Errormsg}{VAL}{#1}}
+
+\def\formatcilvalref#1{\apiref{Formatcil}{VAL}{#1}}
+\def\cfgref#1{\apiref{Cfg}{VAL}{#1}}
+
+
+%----------------------------------------------------------------------
+% MACROS
+
+\newcommand{\hsp}{\hspace{0.5in}}
+\def\t#1{{\tt #1}}
+\newcommand\codecolor{\ifhevea\blue\else\fi}
+\renewcommand\c[1]{{\codecolor #1}} % Use for code fragments
+
+%%% Define an environment for code
+%% Unfortunately since hevea is not quite TeX you have to use this as follows
+%\begin{code}
+% ...
+%\end{verbatim}\end{code}
+\def\code{\begingroup\codecolor\begin{verbatim}}
+\def\endcode{\endgroup}
+
+%use this for links to external pages. It will open pages in the
+%top frame.
+\newcommand\ahreftop[2]{{\ahref{javascript:loadTop('#1')}{#2}}}
+
+%----------------------------------------------------------------------
+
+% Make sure that most documents show up in the main frame,
+% and define javascript:loadTop for those links that should fill the window.
+\makeatletter
+\let\oldmeta=\@meta
+\def\@meta{%
+\oldmeta
+\begin{rawhtml}
+<base target="main">
+<script language="JavaScript">
+<!-- Begin
+function loadTop(url) {
+ parent.location.href= url;
+}
+// -->
+</script>
+\end{rawhtml}}
+\makeatother
+
+\begin{document}
+\begin{latexonly}
+\title{CIL: Infrastructure for C Program Analysis and Transformation}
+\end{latexonly}
+\maketitle
+
+
+\section{Introduction}
+
+ New: CIL now has a Source Forge page:
+ \ahreftop{http://sourceforge.net/projects/cil}
+ {http://sourceforge.net/projects/cil}.
+
+ CIL ({\bf C} {\bf I}ntermediate {\bf L}anguage) is a high-level representation
+along with a set of tools that permit easy analysis and source-to-source
+transformation of C programs.
+
+ CIL is both lower-level than abstract-syntax trees, by clarifying ambiguous
+constructs and removing redundant ones, and also higher-level than typical
+intermediate languages designed for compilation, by maintaining types and a
+close relationship with the source program. The main advantage of CIL is that
+it compiles all valid C programs into a few core constructs with a very clean
+semantics. Also CIL has a syntax-directed type system that makes it easy to
+analyze and manipulate C programs. Furthermore, the CIL front-end is able to
+process not only ANSI-C programs but also those using Microsoft C or GNU C
+extensions. If you do not use CIL and want instead to use just a C parser and
+analyze programs expressed as abstract-syntax trees then your analysis will
+have to handle a lot of ugly corners of the language (let alone the fact that
+parsing C itself is not a trivial task). See \secref{simplec} for some
+examples of such extreme programs that CIL simplifies for you.
+
+ In essence, CIL is a highly-structured, ``clean'' subset of C. CIL features a
+reduced number of syntactic and conceptual forms. For example, all looping
+constructs are reduced to a single form, all function bodies are given
+explicit {\tt return} statements, syntactic sugar like {\tt "->"} is
+eliminated and function arguments with array types become pointers. (For an
+extensive list of how CIL simplifies C programs, see \secref{cabs2cil}.)
+This reduces the number of cases that must be considered when manipulating a C
+program. CIL also separates type declarations from code and flattens scopes
+within function bodies. This structures the program in a manner more amenable
+to rapid analysis and transformation. CIL computes the types of all program
+expressions, and makes all type promotions and casts explicit. CIL supports
+all GCC and MSVC extensions except for nested functions and complex numbers.
+Finally, CIL organizes C's imperative features into expressions, instructions
+and statements based on the presence and absence of side-effects and
+control-flow. Every statement can be annotated with successor and predecessor
+information. Thus CIL provides an integrated program representation that can
+be used with routines that require an AST (e.g. type-based analyses and
+pretty-printers), as well as with routines that require a CFG (e.g., dataflow
+analyses). CIL also supports even lower-level representations (e.g.,
+three-address code), see \secref{Extension}.
+
+ CIL comes accompanied by a number of Perl scripts that perform generally
+useful operations on code:
+\begin{itemize}
+\item A \ahrefloc{sec-driver}{driver} which behaves as either the \t{gcc} or
+Microsoft VC compiler and can invoke the preprocessor followed by the CIL
+application. The advantage of this script is that you can easily use CIL and
+the analyses written for CIL with existing make files.
+\item A \ahrefloc {sec-merger}{whole-program merger} that you can use as a
+replacement for your compiler and it learns all the files you compile when you
+make a project and merges all of the preprocessed source files into a single
+one. This makes it easy to do whole-program analysis.
+\item A \ahrefloc{sec-patcher}{patcher} makes it easy to create modified
+copies of the system include files. The CIL driver can then be told to use
+these patched copies instead of the standard ones.
+\end{itemize}
+
+ CIL has been tested very extensively. It is able to process the SPECINT95
+benchmarks, the Linux kernel, GIMP and other open-source projects. All of
+these programs are compiled to the simple CIL and then passed to \t{gcc} and
+they still run! We consider the compilation of Linux a major feat especially
+since Linux contains many of the ugly GCC extensions (see \secref{ugly-gcc}).
+This adds to about 1,000,000 lines of code that we tested it on. It is also
+able to process the few Microsoft NT device drivers that we have had access
+to. CIL was tested against GCC's c-torture testsuite and (except for the tests
+involving complex numbers and inner functions, which CIL does not currently
+implement) CIL passes most of the tests. Specifically CIL fails 23 tests out
+of the 904 c-torture tests that it should pass. GCC itself fails 19 tests. A
+total of 1400 regression test cases are run automatically on each change to
+the CIL sources.
+
+ CIL is relatively independent on the underlying machine and compiler. When
+you build it CIL will configure itself according to the underlying compiler.
+However, CIL has only been tested on Intel x86 using the gcc compiler on Linux
+and cygwin and using the MS Visual C compiler. (See below for specific
+versions of these compilers that we have used CIL for.)
+
+ The largest application we have used CIL for is
+\ahreftop{../ccured/index.html}{CCured}, a compiler that compiles C code into
+type-safe code by analyzing your pointer usage and inserting runtime checks in
+the places that cannot be guaranteed statically to be type safe.
+
+ You can also use CIL to ``compile'' code that uses GCC extensions (e.g. the
+Linux kernel) into standard C code.
+
+ CIL also comes accompanies by a growing library of extensions (see
+\secref{Extension}). You can use these for your projects or as examples of
+using CIL.
+
+\t{PDF} versions of \ahref{CIL.pdf}{this manual} and the
+\ahref{CIL-API.pdf}{CIL API} are available. However, we recommend the
+\t{HTML} versions because the postprocessed code examples are easier to
+view.
+
+ If you use CIL in your project, we would appreciate letting us know. If you
+want to cite CIL in your research writings, please refer to the paper ``CIL:
+Intermediate Language and Tools for Analysis and Transformation of C
+Programs'' by George C. Necula, Scott McPeak, S.P. Rahul and Westley Weimer,
+in ``Proceedings of Conference on Compilier Construction'', 2002.
+
+\section{Installation}
+
+ You need the following tools to build CIL:
+\begin{itemize}
+\item A Unix-like shell environment (with bash, perl, make, mv, cp,
+ etc.). On Windows, you will need cygwin with those packages.
+\item An ocaml compiler. You will need OCaml release 3.08 or higher to build
+CIL. CIL has been tested on Linux and on Windows (where it can behave as
+either Microsoft Visual C or gcc). On Windows, you can build CIL both with the
+cygwin version of ocaml (preferred) and with the Win32 version of ocaml.
+\item An underlying C compiler, which can be either gcc or Microsoft Visual C.
+\end{itemize}
+
+\begin{enumerate}
+\item Get the source code.
+\begin{itemize}
+\item {\em Official distribution} (Recommended):
+\begin{enumerate}
+\item Download the CIL \ahref{distrib}{distribution} (latest version is
+\ahrefurl{distrib/cil-\cilversion.tar.gz}). See the \secref{changes} for recent changes to the CIL distribution.
+\item Unzip and untar the source distribution. This will create a directory
+ called \t{cil} whose structure is explained below. \\
+ \t{~~~~tar xvfz cil-\cilversion.tar.gz}
+\end{enumerate}
+\item {\em Subversion Repository}: \\
+ Alternately, you can download an up to the minute version of CIL
+ from our Subversion repository at:
+\begin{verbatim}
+ svn co svn://hal.cs.berkeley.edu/home/svn/projects/trunk/cil
+\end{verbatim}
+However, the Subversion version may be less stable than the released
+version. See the Changes section of doc/cil.tex to see what's
+changed since the last release. There may be changes that aren't yet
+documented in the .tex file or this website.
+
+For those who were using the CVS server before we switched to
+Subversion, revision 8603 in Subversion corresponds to the last CVS
+version.
+
+\end{itemize}
+\item Enter the \t{cil} directory and run the \t{configure} script and then
+ GNU make to build the distribution. If you are on Windows, at least the
+ \t{configure} step must be run from within \t{bash}. \\
+ \hsp\verb!cd cil!\\
+ \hsp\verb!./configure!\\
+ \hsp\verb!make!\\
+ \hsp\verb!make quicktest!\\
+
+\item You should now find \t{cilly.asm.exe} in a subdirectory of \t{obj}. The
+name of the subdirectory is either \t{x86\_WIN32} if you are using \t{cygwin}
+on Windows or \t{x86\_LINUX} if you are using Linux (although you should be
+using instead the Perl wrapper \t{bin/cilly}). Note that we do not have an
+\t{install} make target and you should use Cil from the development directory.
+\item If you decide to use CIL, {\bf please}
+\ahref{mailto:necula@cs.berkeley.edu}{send us a note}. This will help recharge
+our batteries after a few years of development. And of course, do send us
+your bug reports as well.
+\end{enumerate}
+
+ The \t{configure} script tries to find appropriate defaults for your system.
+You can control its actions by passing the following arguments:
+\begin{itemize}
+\item \t{CC=foo} Specifies the path for the \t{gcc} executable. By default
+whichever version is in the PATH is used. If \t{CC} specifies the Microsoft
+\t{cl} compiler, then that compiler will be set as the default one. Otherwise,
+the \t{gcc} compiler will be the default.
+\end{itemize}
+
+ CIL requires an underlying C compiler and preprocessor. CIL depends on the
+underlying compiler and machine for the sizes and alignment of types. The
+installation procedure for CIL queries the underlying compiler for
+architecture and compiler dependent configuration parameters, such as the size
+of a pointer or the particular alignment rules for structure fields. (This
+means, of course, that you should re-run \t{./configure} when you move CIL to
+another machine.)
+
+We have tested CIL on the following compilers:
+
+\begin{itemize}
+\item On Windows, \t{cl} compiler version 12.00.8168 (MSVC 6),
+ 13.00.9466 (MSVC .Net), and 13.10.3077 (MSVC .Net 2003). Run \t{cl}
+ with no arguments to get the compiler version.
+\item On Windows, using \t{cygwin} and \t{gcc} version 2.95.3, 3.0,
+ 3.2, 3.3, and 3.4.
+\item On Linux, using \t{gcc} version 2.95.3, 3.0, 3.2, 3.3, 4.0, and 4.1.
+\end{itemize}
+
+Others have successfully used CIL on x86 processors with Mac OS X,
+FreeBSD and OpenBSD; on amd64 processors with FreeBSD; on SPARC
+processors with Solaris; and on PowerPC processors with Mac OS X. If
+you make any changes to the build system in order to run CIL on your
+platform, please send us a patch.
+
+ \subsection{Building CIL on Windows with Microsoft Visual C}
+
+ Some users might want to build a standalone CIL executable on Windows (an
+executable that does not require cygwin.dll to run). You will need cygwin for
+the build process only. Here is how we do it
+
+\begin{enumerate}
+\item Start with a clean CIL directory
+\item Start a command-line window setup with the environment variables for
+ Microsoft Visual Studio. You can do this by choosing Programs/Microsoft
+ Visual Studio/Tools/Command Prompt. Check that you can run \t{cl}.
+\item Ensure that \t{ocamlc} refers to a Win32 version of ocaml. Run \t{ocamlc
+ -v} and look at the path to the standard library. If you have several
+ versions of ocaml, you must set the following variables:
+ \begin{verbatim}
+ set OCAMLWIN=C:/Programs/ocaml-win
+
+ set OCAMLLIB=%OCAMLWIN%/lib
+ set PATH=%OCAMLWIN%/bin;%PATH%
+ set INCLUDE=%INCLUDE%;%OCAMLWIN%/inc
+ set LIB=%LIB%;%OCAMLWIN%/lib;obj/x86_WIN32
+ \end{verbatim}
+
+\item Run \t{bash -c "./configure CC=cl"}.
+\item Run \t{bash -c "make WIN32=1 quickbuild"}
+\item Run \t{bash -c "make WIN32=1 NATIVECAML=1 cilly}
+\item Run \t{bash -c "make WIN32=1 bindistrib-nocheck}
+\end{enumerate}
+
+ The above steps do not build the CIL library, but just the executable. The
+last step will create a subdirectory \t{TEMP\_cil-bindistrib} that contains
+everything that you need to run CIL on another machine. You will have to edit
+manually some of the files in the \t{bin} directory to replace \t{CILHOME}.
+The resulting CIL can be run with ActiveState Perl also.
+
+
+ \section{Distribution Contents}
+
+The file \ahrefurl{distrib/cil-\cilversion.tar.gz}
+contains the complete source CIL distribution,
+consisting of the following files:
+
+\begin{tabular}{ll}
+Filename & Description \\
+\t{Makefile.in} & \t{configure} source for the
+ Makefile that builds CIL \\
+\t{configure} & The configure script \\
+\t{configure.in} & The \t{autoconf} source for \t{configure} \\
+\t{config.guess}, \t{config.sub}, \t{install-sh} & stuff required by
+ \t{configure} \\
+\\
+\t{doc/} & HTML documentation of the CIL API \\
+\t{obj/} & Directory that will contain the compiled
+ CIL modules and executables\\
+\t{bin/cilly.in} & The \t{configure} source for a Perl script
+ that can be invoked with the
+ same arguments as either \t{gcc} or
+ Microsoft Visual C and will convert the
+ program to CIL, perform some simple
+ transformations, emit it and compile it as
+ usual. \\
+\t{lib/CompilerStub.pm} & A Perl class that can be used to write code
+ that impersonates a compiler. \t{cilly}
+ uses it. \\
+\t{lib/Merger.pm} & A subclass of \t{CompilerStub.pm} that can
+ be used to merge source files into a single
+ source file.\t{cilly}
+ uses it. \\
+\t{bin/patcher.in} & A Perl script that applies specified patches
+ to standard include files.\\
+\\
+\t{src/check.ml,mli} & Checks the well-formedness of a CIL file \\
+\t{src/cil.ml,mli} & Definition of CIL abstract syntax and
+ utilities for manipulating it\\
+\t{src/clist.ml,mli} & Utilities for efficiently managing lists
+ that need to be concatenated often\\
+\t{src/errormsg.ml,mli} & Utilities for error reporting \\
+\t{src/ext/heapify.ml} & A CIL transformation that moves array local
+ variables from the stack to the heap \\
+\t{src/ext/logcalls.ml,mli} & A CIL transformation that logs every
+ function call \\
+\t{src/ext/sfi.ml} & A CIL transformation that can log every
+ memory read and write \\
+\t{src/frontc/clexer.mll} & The lexer \\
+\t{src/frontc/cparser.mly} & The parser \\
+\t{src/frontc/cabs.ml} & The abstract syntax \\
+\t{src/frontc/cprint.ml} & The pretty printer for CABS \\
+\t{src/frontc/cabs2cil.ml} & The elaborator to CIL \\
+\t{src/main.ml} & The \t{cilly} application \\
+\t{src/pretty.ml,mli} & Utilities for pretty printing \\
+\t{src/rmtmps.ml,mli} & A CIL tranformation that removes unused
+ types, variables and inlined functions \\
+\t{src/stats.ml,mli} & Utilities for maintaining timing statistics
+\\
+\t{src/testcil.ml} & A random test of CIL (against the resident
+ C compiler)\\
+\t{src/trace.ml,mli} & Utilities useful for printing debugging
+ information\\
+\\
+\t{ocamlutil/} & Miscellaneous libraries that are not
+ specific to CIL. \\
+\t{ocamlutil/Makefile.ocaml} & A file that is included by \t{Makefile} \\
+\t{ocamlutil/perfcount.c} & C code that links with src/stats.ml
+ and reads Intel performance
+ counters. \\
+\\
+\t{obj/@ARCHOS@/feature\_config.ml} & File generated by the Makefile
+ describing which extra ``features''
+ to compile. See \secref{cil} \\
+\t{obj/@ARCHOS@/machdep.ml} & File generated by the Makefile containing
+ information about your architecture,
+ such as the size of a pointer \\
+\t{src/machdep.c} & C program that generates
+ \t{machdep.ml} files \\
+\end{tabular}
+
+
+\section{Compiling C to CIL}\label{sec-cabs2cil}
+
+ In this section we try to describe a few of the many transformations that are
+applied to a C program to convert it to CIL. The module that implements this
+conversion is about 5000 lines of OCaml code. In contrast a simple program
+transformation that instruments all functions to keep a shadow stack of the
+true return address (thus preventing stack smashing) is only 70 lines of code.
+This example shows that the analysis is so much simpler because it has to
+handle only a few simple C constructs and also because it can leverage on CIL
+infrastructure such as visitors and pretty-printers.
+
+ In no particular order these are a few of the most significant ways in which
+C programs are compiled into CIL:
+\begin{enumerate}
+\item CIL will eliminate all declarations for unused entities. This means that
+just because your hello world program includes \t{stdio.h} it does not mean
+that your analysis has to handle all the ugly stuff from \t{stdio.h}.
+
+\item Type specifiers are interpreted and normalized:
+\begin{cilcode}[global]
+int long signed x;
+signed long extern x;
+long static int long y;
+
+// Some code that uses these declaration, so that CIL does not remove them
+int main() { return x + y; }
+\end{cilcode}
+
+\item Anonymous structure and union declarations are given a name.
+\begin{cilcode}[global]
+ struct { int x; } s;
+\end{cilcode}
+
+\item Nested structure tag definitions are pulled apart. This means that all
+structure tag definitions can be found by a simple scan of the globals.
+
+\begin{cilcode}[global]
+struct foo {
+ struct bar {
+ union baz {
+ int x1;
+ double x2;
+ } u1;
+ int y;
+ } s1;
+ int z;
+} f;
+\end{cilcode}
+
+\item All structure, union, enumeration definitions and the type definitions
+from inners scopes are moved to global scope (with appropriate renaming). This
+facilitates moving around of the references to these entities.
+
+\begin{cilcode}[global]
+int main() {
+ struct foo {
+ int x; } foo;
+ {
+ struct foo {
+ double d;
+ };
+ return foo.x;
+ }
+}
+\end{cilcode}
+
+\item Prototypes are added for those functions that are called before being
+defined. Furthermore, if a prototype exists but does not specify the type of
+parameters that is fixed. But CIL will not be able to add prototypes for those
+functions that are neither declared nor defined (but are used!).
+\begin{cilcode}[global]
+ int f(); // Prototype without arguments
+ int f(double x) {
+ return g(x);
+ }
+ int g(double x) {
+ return x;
+ }
+\end{cilcode}
+
+\item Array lengths are computed based on the initializers or by constant
+folding.
+\begin{cilcode}[global]
+ int a1[] = {1,2,3};
+ int a2[sizeof(int) >= 4 ? 8 : 16];
+\end{cilcode}
+
+\item Enumeration tags are computed using constant folding:
+\begin{cilcode}[global]
+int main() {
+ enum {
+ FIVE = 5,
+ SIX, SEVEN,
+ FOUR = FIVE - 1,
+ EIGHT = sizeof(double)
+ } x = FIVE;
+ return x;
+}
+
+\end{cilcode}
+
+\item Initializers are normalized to include specific initialization for the
+missing elements:
+\begin{cilcode}[global]
+ int a1[5] = {1,2,3};
+ struct foo { int x, y; } s1 = { 4 };
+\end{cilcode}
+
+\item Initializer designators are interpreted and eliminated. Subobjects are
+properly marked with braces. CIL implements
+the whole ISO C99 specification for initializer (neither GCC nor MSVC do) and
+a few GCC extensions.
+\begin{cilcode}[global]
+ struct foo {
+ int x, y;
+ int a[5];
+ struct inner {
+ int z;
+ } inner;
+ } s = { 0, .inner.z = 3, .a[1 ... 2] = 5, 4, y : 8 };
+\end{cilcode}
+
+\item String initializers for arrays of characters are processed
+
+\begin{cilcode}[global]
+char foo[] = "foo plus bar";
+\end{cilcode}
+
+\item String constants are concatenated
+
+\begin{cilcode}[global]
+char *foo = "foo " " plus " " bar ";
+\end{cilcode}
+
+\item Initializers for local variables are turned into assignments. This is in
+order to separate completely the declarative part of a function body from the
+statements. This has the unfortunate effect that we have to drop the \t{const}
+qualifier from local variables !
+
+\begin{cilcode}[local]
+ int x = 5;
+ struct foo { int f1, f2; } a [] = {1, 2, 3, 4, 5 };
+\end{cilcode}
+
+\item Local variables in inner scopes are pulled to function scope (with
+appropriate renaming). Local scopes thus disappear. This makes it easy to find
+and operate on all local variables in a function.
+
+\begin{cilcode}[global]
+ int x = 5;
+ int main() {
+ int x = 6;
+ {
+ int x = 7;
+ return x;
+ }
+ return x;
+ }
+\end{cilcode}
+
+\item Global declarations in local scopes are moved to global scope:
+\begin{cilcode}[global]
+ int x = 5;
+ int main() {
+ int x = 6;
+ {
+ static int x = 7;
+ return x;
+ }
+ return x;
+ }
+\end{cilcode}
+
+\item Return statements are added for functions that are missing them. If the
+return type is not a base type then a \t{return} without a value is added.
+The guaranteed presence of return statements makes it easy to implement a
+transformation that inserts some code to be executed immediately before
+returning from a function.
+\begin{cilcode}[global]
+ int foo() {
+ int x = 5;
+ }
+\end{cilcode}
+
+\item One of the most significant transformations is that expressions that
+contain side-effects are separated into statements.
+
+\begin{cilcode}[local]
+ int x, f(int);
+ return (x ++ + f(x));
+\end{cilcode}
+
+ Internally, the \t{x ++} statement is turned into an assignment which the
+pretty-printer prints like the original. CIL has only three forms of basic
+statements: assignments, function calls and inline assembly.
+
+\item Shortcut evaluation of boolean expressions and the \t{?:} operator are
+compiled into explicit conditionals:
+\begin{cilcode}[local]
+ int x;
+ int y = x ? 2 : 4;
+ int z = x || y;
+ // Here we duplicate the return statement
+ if(x && y) { return 0; } else { return 1; }
+ // To avoid excessive duplication, CIL uses goto's for
+ // statement that have more than 5 instructions
+ if(x && y || z) { x ++; y ++; z ++; x ++; y ++; return z; }
+\end{cilcode}
+
+\item GCC's conditional expression with missing operands are also compiled
+into conditionals:
+\begin{cilcode}[local]
+ int f();;
+ return f() ? : 4;
+\end{cilcode}
+
+\item All forms of loops (\t{while}, \t{for} and \t{do}) are compiled
+internally as a single \t{while(1)} looping construct with explicit \t{break}
+statement for termination. For simple \t{while} loops the pretty printer is
+able to print back the original:
+\begin{cilcode}[local]
+ int x, y;
+ for(int i = 0; i<5; i++) {
+ if(i == 5) continue;
+ if(i == 4) break;
+ i += 2;
+ }
+ while(x < 5) {
+ if(x == 3) continue;
+ x ++;
+ }
+\end{cilcode}
+
+\item GCC's block expressions are compiled away. (That's right there is an
+infinite loop in this code.)
+
+\begin{cilcode}[local]
+ int x = 5, y = x;
+ int z = ({ x++; L: y -= x; y;});
+ return ({ goto L; 0; });
+\end{cilcode}
+
+\item CIL contains support for both MSVC and GCC inline assembly (both in one
+internal construct)
+
+\item CIL compiles away the GCC extension that allows many kinds of constructs
+to be used as lvalues:
+
+\begin{cilcode}[local]
+ int x, y, z;
+ return &(x ? y : z) - & (x ++, x);
+\end{cilcode}
+
+\item All types are computed and explicit casts are inserted for all
+promotions and conversions that a compiler must insert:
+
+\item CIL will turn old-style function definition (without prototype) into
+new-style definitions. This will make the compiler less forgiving when
+checking function calls, and will catch for example cases when a function is
+called with too few arguments. This happens in old-style code for the purpose
+of implementing variable argument functions.
+
+\item Since CIL sees the source after preprocessing the code after CIL does
+not contain the comments and the preprocessing directives.
+
+\item CIL will remove from the source file those type declarations, local
+variables and inline functions that are not used in the file. This means that
+your analysis does not have to see all the ugly stuff that comes from the
+header files:
+\begin{cilcode}[global]
+#include <stdio.h>
+
+typedef int unused_type;
+
+static char unused_static (void) { return 0; }
+
+int main() {
+ int unused_local;
+ printf("Hello world\n"); // Only printf will be kept from stdio.h
+}
+\end{cilcode}
+
+\end{enumerate}
+
+\section{How to Use CIL}\label{sec-cil}\cutname{cilly.html}
+
+There are two predominant ways to use CIL to write a program analysis or
+transformation. The first is to phrase your analysis as a module that is
+called by our existing driver. The second is to use CIL as a stand-alone
+library. We highly recommend that you use \t{cilly}, our driver.
+
+\subsection{Using \t{cilly}, the CIL driver}
+
+The most common way to use CIL is to write an Ocaml module containing your
+analysis and transformation, which you then link into our boilerplate
+driver application called \t{cilly}. \t{cilly} is a Perl script that
+processes and mimics \t{GCC} and \t{MSVC} command-line arguments and then
+calls \t{cilly.byte.exe} or \t{cilly.asm.exe} (CIL's Ocaml executable).
+
+An example of such module is \t{logwrites.ml}, a transformation that is
+distributed with CIL and whose purpose is to instrument code to print the
+addresses of memory locations being written. (We plan to release a
+C-language interface to CIL so that you can write your analyses in C
+instead of Ocaml.) See \secref{Extension} for a survey of other example
+modules.
+
+Assuming that you have written \t{/home/necula/logwrites.ml},
+here is how you use it:
+
+ \begin{enumerate}
+
+ \item Modify \t{logwrites.ml} so that it includes a CIL ``feature
+ descriptor'' like this:
+\begin{verbatim}
+let feature : featureDescr =
+ { fd_name = "logwrites";
+ fd_enabled = ref 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)
+ }
+\end{verbatim}
+ The \t{fd\_name} field names the feature and its associated
+ command-line arguments. The \t{fd\_enabled} field is a \t{bool ref}.
+ ``\t{fd\_doit}'' will be invoked if \t{!fd\_enabled} is true after
+ argument parsing, so initialize the ref cell to true if you want
+ this feature to be enabled by default.
+
+ When the user passes the \t{-{}-{}dologwrites}
+ command-line option to \t{cilly}, the variable associated with the
+ \t{fd\_enabled} flag is set and the \t{fd\_doit} function is called
+ on the \t{Cil.file} that represents the merger (see \secref{merger}) of
+ all C files listed as arguments.
+
+ \item Invoke \t{configure} with the arguments
+\begin{verbatim}
+./configure EXTRASRCDIRS=/home/necula EXTRAFEATURES=logwrites
+\end{verbatim}
+
+ This step works if each feature is packaged into its own ML file, and the
+name of the entry point in the file is \t{feature}.
+
+ An alternative way to specify the new features is to change the build files
+yourself, as explained below. You'll need to use this method if a single
+feature is split across multiple files.
+
+\begin{enumerate}
+ \item Put \t{logwrites.ml} in the \t{src} or \t{src/ext} directory. This
+ will make sure that \t{make} can find it. If you want to put it in some
+ other directory, modify \t{Makefile.in} and add to \t{SOURCEDIRS} your
+ directory. Alternately, you can create a symlink from \t{src} or
+ \t{src/ext} to your file.
+
+ \item Modify the \t{Makefile.in} and add your module to the
+ \t{CILLY\_MODULES} or
+ \t{CILLY\_LIBRARY\_MODULES} variables. The order of the modules matters. Add
+ your modules somewhere after \t{cil} and before \t{main}.
+
+ \item If you have any helper files for your module, add those to
+ the makefile in the same way. e.g.:
+
+\begin{verbatim}
+CILLY_MODULES = $(CILLY_LIBRARY_MODULES) \
+ myutilities1 myutilities2 logwrites \
+ main
+\end{verbatim}
+ % $ <- emacs hack
+
+ Again, order is important: \t{myutilities2.ml} will be able to refer
+ to Myutilities1 but not Logwrites. If you have any ocamllex or ocamlyacc
+ files, add them to both \t{CILLY\_MODULES} and either \t{MLLS} or
+ \t{MLYS}.
+
+ \item Modify \t{main.ml} so that your new feature descriptor appears in
+ the global list of CIL features.
+\begin{verbatim}
+let features : C.featureDescr list =
+ [ Logcalls.feature;
+ Oneret.feature;
+ Heapify.feature1;
+ Heapify.feature2;
+ makeCFGFeature;
+ Partial.feature;
+ Simplemem.feature;
+ Logwrites.feature; (* add this line to include the logwrites feature! *)
+ ]
+ @ Feature_config.features
+\end{verbatim}
+
+ Features are processed in the order they appear on this list. Put
+ your feature last on the list if you plan to run any of CIL's
+ built-in features (such as makeCFGfeature) before your own.
+
+\end{enumerate}
+
+ Standard code in \t{cilly} takes care of adding command-line arguments,
+ printing the description, and calling your function automatically.
+ Note: do not worry about introducing new bugs into CIL by adding a single
+ line to the feature list.
+
+ \item Now you can invoke the \t{cilly} application on a preprocessed file, or
+ instead use the \t{cilly} driver which provides a convenient compiler-like
+ interface to \t{cilly}. See \secref{driver} for details using \t{cilly}.
+ Remember to enable your analysis by passing the right argument (e.g.,
+ \t{-{}-{}dologwrites}).
+
+\end{enumerate}
+
+\subsection{Using CIL as a library}
+
+CIL can also be built as a library that is called from your stand-alone
+application. Add \t{cil/src}, \t{cil/src/frontc}, \t{cil/obj/x86\_LINUX}
+(or \t{cil/obj/x86\_WIN32}) to your Ocaml project \t{-I} include paths.
+Building CIL will also build the library \t{cil/obj/*/cil.cma} (or
+\t{cil/obj/*/cil.cmxa}). You can then link your application against that
+library.
+
+You can call the \t{Frontc.parse: string -> unit -> Cil.file} function with
+the name of a file containing the output of the C preprocessor.
+The \t{Mergecil.merge: Cil.file list -> string -> Cil.file} function merges
+multiple files. You can then invoke your analysis function on the resulting
+\t{Cil.file} data structure. You might want to call
+\t{Rmtmps.removeUnusedTemps} first to clean up the prototypes and variables
+that are not used. Then you can call the function \t{Cil.dumpFile:
+cilPrinter -> out\_channel -> Cil.file -> unit} to print the file to a
+given output channel. A good \t{cilPrinter} to use is
+\t{defaultCilPrinter}.
+
+Check out \t{src/main.ml} and \t{bin/cilly} for other good ideas
+about high-level file processing. Again, we highly recommend that you just
+our \t{cilly} driver so that you can avoid spending time re-inventing the
+wheel to provide drop-in support for standard \t{makefile}s.
+
+Here is a concrete example of compiling and linking your project against
+CIL. Imagine that your program analysis or transformation is contained in
+the single file \t{main.ml}.
+
+\begin{verbatim}
+$ ocamlopt -c -I $(CIL)/obj/x86_LINUX/ main.ml
+$ ocamlopt -ccopt -L$(CIL)/obj/x86_LINUX/ -o main unix.cmxa str.cmxa \
+ $(CIL)/obj/x86_LINUX/cil.cmxa main.cmx
+\end{verbatim} % $
+
+The first line compiles your analysis, the second line links it against CIL
+(as a library) and the Ocaml Unix library. For more information about
+compiling and linking Ocaml programs, see the Ocaml home page
+at \ahreftop{http://caml.inria.fr/ocaml/}{http://caml.inria.fr/ocaml/}.
+
+In the next section we give an overview of the API that you can use
+to write your analysis and transformation.
+
+\section{CIL API Documentation}\label{sec-api}
+
+ The CIL API is documented in the file \t{src/cil.mli}. We also have an
+\ahref{api/index.html}{online documentation} extracted from
+\t{cil.mli} and other useful modules. We
+index below the main types that are used to represent C programs in CIL:
+
+\begin{itemize}
+\item \ahref{api/index\_types.html}{An index of all types}
+\item \ahref{api/index\_values.html}{An index of all values}
+\item \ciltyperef{file} is the representation of a file.
+\item \ciltyperef{global} is the representation of a global declaration or
+definitions. Values for \ahref{api/Cil.html\#VALemptyFunction}{operating on globals}.
+\item \ciltyperef{typ} is the representation of a type.
+Values for \ahref{api/Cil.html\#VALvoidType}{operating on types}.
+\item \ciltyperef{compinfo} is the representation of a structure or a union
+type
+\item \ciltyperef{fieldinfo} is the representation of a field in a structure
+or a union
+\item \ciltyperef{enuminfo} is the representation of an enumeration type.
+\item \ciltyperef{varinfo} is the representation of a variable
+\item \ciltyperef{fundec} is the representation of a function
+\item \ciltyperef{lval} is the representation of an lvalue.
+Values for \ahref{api/Cil.html\#VALmakeVarInfo}{operating on lvalues}.
+\item \ciltyperef{exp} is the representation of an expression without
+side-effects.
+Values for \ahref{api/Cil.html\#VALzero}{operating on expressions}.
+\item \ciltyperef{instr} is the representation of an instruction (with
+side-effects but without control-flow)
+\item \ciltyperef{stmt} is the representation of a control-flow statements.
+Values for \ahref{api/Cil.html\#VALmkStmt}{operating on statements}.
+\item \ciltyperef{attribute} is the representation of attributes.
+Values for \ahref{api/Cil.html\#TYPEattributeClass}{operating on attributes}.
+\end{itemize}
+
+
+ \subsection{Using the visitor}\label{sec-visitor}
+
+ One of the most useful tools exported by the CIL API is an implementation of
+the visitor pattern for CIL programs. The visiting engine scans depth-first
+the structure of a CIL program and at each node is queries a user-provided
+visitor structure whether it should do one of the following operations:
+\begin{itemize}
+\item Ignore this node and all its descendants
+\item Descend into all of the children and when done rebuild the node if any
+of the children have changed.
+\item Replace the subtree rooted at the node with another tree.
+\item Replace the subtree with another tree, then descend into the children
+and rebuild the node if necessary and then invoke a user-specified function.
+\item In addition to all of the above actions then visitor can specify that
+some instructions should be queued to be inserted before the current
+instruction or statement being visited.
+\end{itemize}
+
+ By writing visitors you can customize the program traversal and
+transformation. One major limitation of the visiting engine is that it does
+not propagate information from one node to another. Each visitor must use its
+own private data to achieve this effect if necessary.
+
+ Each visitor is an object that is an instance of a class of type \cilvisit{}.
+The most convenient way to obtain such classes is to specialize the
+\apiref{Cil.nopCilVisitor}{} class (which just traverses the tree doing
+nothing). Any given specialization typically overrides only a few of the
+methods. Take a look for example at the visitor defined in the module
+\t{logwrites.ml}. Another, more elaborate example of a visitor is the
+[copyFunctionVisitor] defined in \t{cil.ml}.
+
+ Once you have defined a visitor you can invoke it with one of the functions:
+\begin{itemize}
+\item \cilvalref{visitCilFile} or \cilvalref{visitCilFileSameGlobals} - visit a file
+\item \cilvalref{visitCilGlobal} - visit a global
+\item \cilvalref{visitCilFunction} - visit a function definition
+\item \cilvalref{visitCilExp} - visit an expression
+\item \cilvalref{visitCilLval} - visit an lvalue
+\item \cilvalref{visitCilInstr} - visit an instruction
+\item \cilvalref{visitCilStmt} - visit a statement
+\item \cilvalref{visitCilType} - visit a type. Note that this does not visit
+the files of a composite type. use visitGlobal to visit the [GCompTag] that
+defines the fields.
+\end{itemize}
+
+Some transformations may want to use visitors to insert additional
+instructions before statements and instructions. To do so, pass a list of
+instructions to the \cilvalref{queueInstr} method of the specialized
+object. The instructions will automatically be inserted before that
+instruction in the transformed code. The \cilvalref{unqueueInstr} method
+should not normally be called by the user.
+
+ \subsection{Interpreted Constructors and Deconstructors}
+
+ Interpreted constructors and deconstructors are a facility for constructing
+and deconstructing CIL constructs using a pattern with holes that can be
+filled with a variety of kinds of elements. The pattern is a string that uses
+the C syntax to represent C language elements. For example, the following
+code:
+\begin{code}
+Formatcil.cType "void * const (*)(int x)"
+\end{verbatim}\end{code}
+
+ is an alternative way to construct the internal representation of the type of pointer to function
+with an integer argument and a {void * const} as result:
+\begin{code}
+TPtr(TFun(TVoid [Attr("const", [])],
+ [ ("x", TInt(IInt, []), []) ], false, []), [])
+\end{verbatim}\end{code}
+
+ The advantage of the interpreted constructors is that you can use familiar C
+syntax to construct CIL abstract-syntax trees.
+
+ You can construct this way types, lvalues, expressions, instructions and
+statements. The pattern string can also contain a number of placeholders that
+are replaced during construction with CIL items passed as additional argument
+to the construction function. For example, the \t{\%e:id} placeholder means
+that the argument labeled ``id'' (expected to be of form \t{Fe exp}) will
+supply the expression to replace the placeholder. For example, the following
+code constructs an increment instruction at location \t{loc}:
+\begin{code}
+Formatcil.cInstr "%v:x = %v:x + %e:something"
+ loc
+ [ ("something", Fe some_exp);
+ ("x", Fv some_varinfo) ]
+\end{verbatim}\end{code}
+
+ An alternative way to construct the same CIL instruction is:
+\begin{code}
+Set((Var some_varinfo, NoOffset),
+ BinOp(PlusA, Lval (Var some_varinfo, NoOffset),
+ some_exp, intType),
+ loc)
+\end{verbatim}\end{code}
+
+ See \ciltyperef{formatArg} for a definition of the placeholders that are
+understood.
+
+ A dual feature is the interpreted deconstructors. This can be used to test
+whether a CIL construct has a certain form:
+\begin{code}
+Formatcil.dType "void * const (*)(int x)" t
+\end{verbatim}\end{code}
+
+ will test whether the actual argument \t{t} is indeed a function pointer of
+the required type. If it is then the result is \t{Some []} otherwise it is
+\t{None}. Furthermore, for the purpose of the interpreted deconstructors
+placeholders in patterns match anything of the right type. For example,
+\begin{code}
+Formatcil.dType "void * (*)(%F:t)" t
+\end{verbatim}\end{code}
+
+ will match any function pointer type, independent of the type and number of
+the formals. If the match succeeds the result is \t{Some [ FF forms ]} where
+\t{forms} is a list of names and types of the formals. Note that each member
+in the resulting list corresponds positionally to a placeholder in the
+pattern.
+
+ The interpreted constructors and deconstructors do not support the complete C
+syntax, but only a substantial fragment chosen to simplify the parsing. The
+following is the syntax that is supported:
+\begin{verbatim}
+Expressions:
+ E ::= %e:ID | %d:ID | %g:ID | n | L | ( E ) | Unop E | E Binop E
+ | sizeof E | sizeof ( T ) | alignof E | alignof ( T )
+ | & L | ( T ) E
+
+Unary operators:
+ Unop ::= + | - | ~ | %u:ID
+
+Binary operators:
+ Binop ::= + | - | * | / | << | >> | & | ``|'' | ^
+ | == | != | < | > | <= | >= | %b:ID
+
+Lvalues:
+ L ::= %l:ID | %v:ID Offset | * E | (* E) Offset | E -> ident Offset
+
+Offsets:
+ Offset ::= empty | %o:ID | . ident Offset | [ E ] Offset
+
+Types:
+ T ::= Type_spec Attrs Decl
+
+Type specifiers:
+ Type_spec ::= void | char | unsigned char | short | unsigned short
+ | int | unsigned int | long | unsigned long | %k:ID | float
+ | double | struct %c:ID | union %c:ID
+
+
+Declarators:
+ Decl ::= * Attrs Decl | Direct_decl
+
+
+Direct declarators:
+ Direct_decl ::= empty | ident | ( Attrs Decl )
+ | Direct_decl [ Exp_opt ]
+ | ( Attrs Decl )( Parameters )
+
+Optional expressions
+ Exp_opt ::= empty | E | %eo:ID
+
+Formal parameters
+ Parameters ::= empty | ... | %va:ID | %f:ID | T | T , Parameters
+
+List of attributes
+ Attrs ::= empty | %A:ID | Attrib Attrs
+
+Attributes
+ Attrib ::= const | restrict | volatile | __attribute__ ( ( GAttr ) )
+
+GCC Attributes
+ GAttr ::= ident | ident ( AttrArg_List )
+
+Lists of GCC Attribute arguments:
+ AttrArg_List ::= AttrArg | %P:ID | AttrArg , AttrArg_List
+
+GCC Attribute arguments
+ AttrArg ::= %p:ID | ident | ident ( AttrArg_List )
+
+Instructions
+ Instr ::= %i:ID ; | L = E ; | L Binop= E | Callres L ( Args )
+
+Actual arguments
+ Args ::= empty | %E:ID | E | E , Args
+
+Call destination
+ Callres ::= empty | L = | %lo:ID
+
+Statements
+ Stmt ::= %s:ID | if ( E ) then Stmt ; | if ( E ) then Stmt else Stmt ;
+ | return Exp_opt | break ; | continue ; | { Stmt_list }
+ | while (E ) Stmt | Instr_list
+
+Lists of statements
+ Stmt_list ::= empty | %S:ID | Stmt Stmt_list
+ | Type_spec Attrs Decl ; Stmt_list
+ | Type_spec Attrs Decl = E ; Stmt_list
+ | Type_spec Attrs Decl = L (Args) ; Stmt_list
+
+List of instructions
+ Instr_list ::= Instr | %I:ID | Instr Instr_list
+\end{verbatim}
+
+Notes regarding the syntax:
+\begin{itemize}
+\item In the grammar description above non-terminals are written with
+uppercase initial
+
+\item All of the patterns consist of the \t{\%} character followed by one or
+two letters, followed by ``:'' and an indentifier. For each such
+pattern there is a corresponding constructor of the \ciltyperef{formatArg}
+type, whose name is the letter 'F' followed by the same one or two letters as
+in the pattern. That constructor is used by the user code to pass a
+\ciltyperef{formatArg} actual argument to the interpreted constructor and by
+the interpreted deconstructor to return what was matched for a pattern.
+
+\item If the pattern name is uppercase, it designates a list of the elements
+designated by the corresponding lowercase pattern. E.g. \%E designated lists
+of expressions (as in the actual arguments of a call).
+
+\item The two-letter patterns whose second letter is ``o'' designate an
+optional element. E.g. \%eo designates an optional expression (as in the
+length of an array).
+
+\item Unlike in calls to \t{printf}, the pattern \%g is used for strings.
+
+\item The usual precedence and associativity rules as in C apply
+
+\item The pattern string can contain newlines and comments, using both the
+\t{/* ... */} style as well as the \t{//} one.
+
+\item When matching a ``cast'' pattern of the form \t{( T ) E}, the
+deconstructor will match even expressions that do not have the actual cast but
+in that case the type is matched against the type of the expression. E.g. the
+patters \t{"(int)\%e"} will match any expression of type \t{int} whether it
+has an explicit cast or not.
+
+\item The \%k pattern is used to construct and deconstruct an integer type of
+any kind.
+
+\item Notice that the syntax of types and declaration are the same (in order
+to simplify the parser). This means that technically you can write a whole
+declaration instead of a type in the cast. In this case the name that you
+declare is ignored.
+
+\item In lists of formal parameters and lists of attributes, an empty list in
+the pattern matches any formal parameters or attributes.
+
+\item When matching types, uses of named types are unrolled to expose a real
+type before matching.
+
+\item The order of the attributes is ignored during matching. The the pattern
+for a list of attributes contains \%A then the resulting \t{formatArg} will be
+bound to {\bf all} attributes in the list. For example, the pattern \t{"const
+\%A"} matches any list of attributes that contains \t{const} and binds the
+corresponding placeholder to the entire list of attributes, including
+\t{const}.
+
+\item All instruction-patterns must be terminated by semicolon
+
+\item The autoincrement and autodecrement instructions are not supported. Also
+not supported are complex expressions, the \t{\&\&} and \t{||} shortcut
+operators, and a number of other more complex instructions or statements. In
+general, the patterns support only constructs that can be represented directly
+in CIL.
+
+\item The pattern argument identifiers are not used during deconstruction.
+Instead, the result contains a sequence of values in the same order as the
+appearance of pattern arguments in the pattern.
+
+\item You can mix statements with declarations. For each declaration a new
+ temporary will be constructed (using a function you provive). You can then
+ refer to that temporary by name in the rest of the pattern.
+
+\item The \t{\%v:} pattern specifier is optional.
+\end{itemize}
+
+ The following function are defined in the \t{Formatcil} module for
+constructing and deconstructing:
+\begin{itemize}
+\item \formatcilvalref{cExp} constructs \ciltyperef{exp}.
+\item \formatcilvalref{cType} constructs \ciltyperef{typ}.
+\item \formatcilvalref{cLval} constructs \ciltyperef{lval}.
+\item \formatcilvalref{cInstr} constructs \ciltyperef{instr}.
+\item \formatcilvalref{cStmt} and \formatcilvalref{cStmts} construct \ciltyperef{stmt}.
+\item \formatcilvalref{dExp} deconstructs \ciltyperef{exp}.
+\item \formatcilvalref{dType} deconstructs \ciltyperef{typ}.
+\item \formatcilvalref{dLval} deconstructs \ciltyperef{lval}.
+\item \formatcilvalref{dInstr} deconstructs \ciltyperef{lval}.
+\end{itemize}
+
+ Below is an example using interpreted constructors. This example generates
+the CIL representation of code that scans an array backwards and initializes
+every even-index element with an expression:
+\begin{code}
+Formatcil.cStmts
+ loc
+ "int idx = sizeof(array) / sizeof(array[0]) - 1;
+ while(idx >= 0) {
+ // Some statements to be run for all the elements of the array
+ %S:init
+ if(! (idx & 1))
+ array[idx] = %e:init_even;
+ /* Do not forget to decrement the index variable */
+ idx = idx - 1;
+ }"
+ (fun n t -> makeTempVar myfunc ~name:n t)
+ [ ("array", Fv myarray);
+ ("init", FS [stmt1; stmt2; stmt3]);
+ ("init_even", Fe init_expr_for_even_elements) ]
+\end{verbatim}\end{code}
+
+ To write the same CIL statement directly in CIL would take much more effort.
+Note that the pattern is parsed only once and the result (a function that
+takes the arguments and constructs the statement) is memoized.
+
+ \subsubsection{Performance considerations for interpreted constructors}
+
+ Parsing the patterns is done with a LALR parser and it takes some time. To
+improve performance the constructors and deconstructors memoize the parsed
+patterns and will only compile a pattern once. Also all construction and
+deconstruction functions can be applied partially to the pattern string to
+produce a function that can be later used directly to construct or
+deconstruct. This function appears to be about two times slower than if the
+construction is done using the CIL constructors (without memoization the
+process would be one order of magnitude slower.) However, the convenience of
+interpreted constructor might make them a viable choice in many situations
+when performance is not paramount (e.g. prototyping).
+
+
+ \subsection{Printing and Debugging support}
+
+The Modules \moduleref{Pretty} and \moduleref{Errormsg} contain respectively
+utilities for pretty printing and reporting errors and provide a convenient
+\t{printf}-like interface.
+
+ Additionally, CIL defines for each major type a pretty-printing function that
+you can use in conjunction with the \moduleref{Pretty} interface. The
+following are some of the pretty-printing functions:
+\begin{itemize}
+\item \cilvalref{d\_exp} - print an expression
+\item \cilvalref{d\_type} - print a type
+\item \cilvalref{d\_lval} - print an lvalue
+\item \cilvalref{d\_global} - print a global
+\item \cilvalref{d\_stmt} - print a statment
+\item \cilvalref{d\_instr} - print an instruction
+\item \cilvalref{d\_init} - print an initializer
+\item \cilvalref{d\_attr} - print an attribute
+\item \cilvalref{d\_attrlist} - print a set of attributes
+\item \cilvalref{d\_loc} - print a location
+\item \cilvalref{d\_ikind} - print an integer kind
+\item \cilvalref{d\_fkind} - print a floating point kind
+\item \cilvalref{d\_const} - print a constant
+\item \cilvalref{d\_storage} - print a storage specifier
+\end{itemize}
+
+ You can even customize the pretty-printer by creating instances of
+\cilprinter{}. Typically such an instance extends
+\cilvalref{defaultCilPrinter}. Once you have a customized pretty-printer you
+can use the following printing functions:
+\begin{itemize}
+\item \cilvalref{printExp} - print an expression
+\item \cilvalref{printType} - print a type
+\item \cilvalref{printLval} - print an lvalue
+\item \cilvalref{printGlobal} - print a global
+\item \cilvalref{printStmt} - print a statment
+\item \cilvalref{printInstr} - print an instruction
+\item \cilvalref{printInit} - print an initializer
+\item \cilvalref{printAttr} - print an attribute
+\item \cilvalref{printAttrs} - print a set of attributes
+\end{itemize}
+
+
+ CIL has certain internal consistency invariants. For example, all references
+to a global variable must point to the same \t{varinfo} structure. This
+ensures that one can rename the variable by changing the name in the
+\t{varinfo}. These constraints are mentioned in the API documentation. There
+is also a consistency checker in file \t{src/check.ml}. If you suspect that
+your transformation is breaking these constraints then you can pass the
+\t{-{}-check} option to cilly and this will ensure that the consistency checker
+is run after each transformation.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%5
+\subsection{Attributes}\label{sec-attrib}\cutname{attributes.html}
+
+ In CIL you can attach attributes to types and to names (variables, functions
+and fields). Attributes are represented using the type \ciltyperef{attribute}.
+An attribute consists of a name and a number of arguments (represented using
+the type \ciltyperef{attrparam}). Almost any expression can be used as an
+attribute argument. Attributes are stored in lists sorted by the name of the
+attribute. To maintain list ordering, use the functions
+\cilvalref{typeAttrs} to retrieve the attributes of a type and the functions
+\cilvalref{addAttribute} and \cilvalref{addAttributes} to add attributes.
+Alternatively you can use \cilvalref{typeAddAttributes} to add an attribute to
+a type (and return the new type).
+
+ GCC already has extensive support for attributes, and CIL extends this
+support to user-defined attributes. A GCC attribute has the syntax:
+
+\begin{verbatim}
+ gccattribute ::= __attribute__((attribute)) (Note the double parentheses)
+\end{verbatim}
+
+ Since GCC and MSVC both support various flavors of each attribute (with or
+without leading or trailing \_) we first strip ALL leading and trailing \_
+from the attribute name (but not the identified in [ACons] parameters in
+\ciltyperef{attrparam}). When we print attributes, for GCC we add two leading
+and two trailing \_; for MSVC we add just two leading \_.
+
+ There is support in CIL so that you can control the printing of attributes
+(see \cilvalref{setCustomPrintAttribute} and
+\cilvalref{setCustomPrintAttributeScope}). This custom-printing support is now
+used to print the "const" qualifier as "\t{const}" and not as
+"\t{\_\_attribute\_\_((const))}".
+
+
+ The attributes are specified in declarations. This is unfortunate since the C
+syntax for declarations is already quite complicated and after writing the
+parser and elaborator for declarations I am convinced that few C programmers
+understand it completely. Anyway, this seems to be the easiest way to support
+attributes.
+
+ Name attributes must be specified at the very end of the declaration, just
+before the \t{=} for the initializer or before the \t{,} the separates a
+declaration in a group of declarations or just before the \t{;} that
+terminates the declaration. A name attribute for a function being defined can
+be specified just before the brace that starts the function body.
+
+ For example (in the following examples \t{A1},...,\t{An} are type attributes
+and \t{N} is a name attribute (each of these uses the \t{\_\_attribute\_\_} syntax):
+
+\begin{code}
+ int x N;
+ int x N, * y N = 0, z[] N;
+ extern void exit() N;
+ int fact(int x) N { ... }
+\end{verbatim}\end{code}
+
+
+ Type attributes can be specified along with the type using the following
+ rules:
+\begin{enumerate}
+ \item The type attributes for a base type (int, float, named type, reference
+ to struct or union or enum) must be specified immediately following the
+ type (actually it is Ok to mix attributes with the specification of the
+ type, in between unsigned and int for example).
+
+ For example:
+\begin{code}
+ int A1 x N; /* A1 applies to the type int. An example is an attribute
+ "even" restricting the type int to even values. */
+ struct foo A1 A2 x; // Both A1 and A2 apply to the struct foo type
+\end{verbatim}\end{code}
+
+ \item The type attributes for a pointer type must be specified immediately
+ after the * symbol.
+\begin{code}
+ /* A pointer (A1) to an int (A2) */
+ int A2 * A1 x;
+ /* A pointer (A1) to a pointer (A2) to a float (A3) */
+ float A3 * A2 * A1 x;
+\end{verbatim}\end{code}
+
+
+ Note: The attributes for base types and for pointer types are a strict
+ extension of the ANSI C type qualifiers (const, volatile and restrict). In
+ fact CIL treats these qualifiers as attributes.
+
+ \item The attributes for a function type or for an array type can be
+ specified using parenthesized declarators.
+
+ For example:
+\begin{code}
+ /* A function (A1) from int (A2) to float (A3) */
+ float A3 (A1 f)(int A2);
+
+ /* A pointer (A1) to a function (A2) that returns an int (A3) */
+ int A3 (A2 * A1 pfun)(void);
+
+ /* An array (A1) of int (A2) */
+ int A2 (A1 x0)[]
+
+ /* Array (A1) of pointers (A2) to functions (A3) that take an int (A4) and
+ * return a pointer (A5) to int (A6) */
+ int A6 * A5 (A3 * A2 (A1 x1)[5])(int A4);
+
+
+ /* A function (A4) that takes a float (A5) and returns a pointer (A6) to an
+ * int (A7) */
+ extern int A7 * A6 (A4 x2)(float A5 x);
+
+ /* A function (A1) that takes a int (A2) and that returns a pointer (A3) to
+ * a function (A4) that takes a float (A5) and returns a pointer (A6) to an
+ * int (A7) */
+ int A7 * A6 (A4 * A3 (A1 x3)(int A2 x))(float A5) {
+ return & x2;
+ }
+\end{verbatim}\end{code}
+
+\end{enumerate}
+
+ Note: ANSI C does not allow the specification of type qualifiers for function
+and array types, although it allows for the parenthesized declarator. With
+just a bit of thought (looking at the first few examples above) I hope that
+the placement of attributes for function and array types will seem intuitive.
+
+ This extension is not without problems however. If you want to refer just to
+a type (in a cast for example) then you leave the name out. But this leads to
+strange conflicts due to the parentheses that we introduce to scope the
+attributes. Take for example the type of x0 from above. It should be written
+as:
+
+\begin{code}
+ int A2 (A1 )[]
+\end{verbatim}\end{code}
+
+ But this will lead most C parsers into deep confusion because the parentheses
+around A1 will be confused for parentheses of a function designator. To push
+this problem around (I don't know a solution) whenever we are about to print a
+parenthesized declarator with no name but with attributes, we comment out the
+attributes so you can see them (for whatever is worth) without confusing the
+compiler. For example, here is how we would print the above type:
+
+\begin{code}
+ int A2 /*(A1 )*/[]
+\end{verbatim}\end{code}
+
+ \paragraph{Handling of predefined GCC attributes}
+
+ GCC already supports attributes in a lot of places in declarations. The only
+place where we support attributes and GCC does not is right before the \{ that
+starts a function body.
+
+ GCC classifies its attributes in attributes for functions, for variables and
+for types, although the latter category is only usable in definition of struct
+or union types and is not nearly as powerful as the CIL type attributes. We
+have made an effort to reclassify GCC attributes as name and type attributes
+(they only apply for function types). Here is what we came up with:
+
+\begin{itemize}
+ \item GCC name attributes:
+
+ section, constructor, destructor, unused, weak, no\_instrument\_function,
+ noreturn, alias, no\_check\_memory\_usage, dllinport, dllexport, exception,
+ model
+
+ Note: the "noreturn" attribute would be more appropriately qualified as a
+ function type attribute. But we classify it as a name attribute to make
+ it easier to support a similarly named MSVC attribute.
+
+ \item GCC function type attributes:
+
+ fconst (printed as "const"), format, regparm, stdcall,
+ cdecl, longcall
+
+ I was not able to completely decipher the position in which these attributes
+ must go. So, the CIL elaborator knows these names and applies the following
+ rules:
+ \begin{itemize}
+ \item All of the name attributes that appear in the specifier part (i.e. at
+ the beginning) of a declaration are associated with all declared names.
+
+ \item All of the name attributes that appear at the end of a declarator are
+ associated with the particular name being declared.
+
+ \item More complicated is the handling of the function type attributes, since
+ there can be more than one function in a single declaration (a function
+ returning a pointer to a function). Lacking any real understanding of how
+ GCC handles this, I attach the function type attribute to the "nearest"
+ function. This means that if a pointer to a function is "nearby" the
+ attribute will be correctly associated with the function. In truth I pray
+ that nobody uses declarations as that of x3 above.
+ \end{itemize}
+\end{itemize}
+
+\paragraph{Handling of predefined MSVC attributes}
+
+ MSVC has two kinds of attributes, declaration modifiers to be printed before
+ the storage specifier using the notation "\t{\_\_declspec(...)}" and a few
+ function type attributes, printed almost as our CIL function type
+ attributes.
+
+ The following are the name attributes that are printed using
+ \t{\_\_declspec} right before the storage designator of the declaration:
+ thread, naked, dllimport, dllexport, noreturn
+
+
+ The following are the function type attributes supported by MSVC:
+ fastcall, cdecl, stdcall
+
+ It is not worth going into the obscure details of where MSVC accepts these
+ type attributes. The parser thinks it knows these details and it pulls
+ these attributes from wherever they might be placed. The important thing
+ is that MSVC will accept if we print them according to the rules of the CIL
+ attributes !
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\section{The CIL Driver}\label{sec-driver}
+
+ We have packaged CIL as an application \t{cilly} that contains certain
+example modules, such as \t{logwrites.ml} (a module
+that instruments code to print the addresses of memory locations being
+written). Normally, you write another module like that, add command-line
+options and an invocation of your module in \t{src/main.ml}. Once you compile
+CIL you will obtain the file \t{obj/cilly.asm.exe}.
+
+ We wrote a driver for this executable that makes it easy to invoke your
+analysis on existing C code with very little manual intervention. This driver
+is \t{bin/cilly} and is quite powerful. Note that the \t{cilly} script
+is configured during installation with the path where CIL resides. This means
+that you can move it to any place you want.
+
+ A simple use of the driver is:
+\begin{verbatim}
+bin/cilly --save-temps -D HAPPY_MOOD -I myincludes hello.c -o hello
+\end{verbatim}
+
+\c{-{}-save-temps} tells CIL to save the resulting output files in the
+current directory. Otherwise, they'll be put in \t{/tmp} and deleted
+automatically. Not that this is the only CIL-specific flag in the
+list -- the other flags use \t{gcc}'s syntax.
+
+This performs the following actions:
+\begin{itemize}
+\item preprocessing using the -D and -I arguments with the resulting
+ file left in \t{hello.i},
+\item the invocation of the \t{cilly.asm} application which parses \t{hello.i}
+ converts it to CIL and the pretty-prints it to \t{hello.cil.c}
+\item another round of preprocessing with the result placed in \t{hello.cil.i}
+\item the true compilation with the result in \t{hello.cil.o}
+\item a linking phase with the result in \t{hello}
+\end{itemize}
+
+ Note that \t{cilly} behaves like the \t{gcc} compiler. This makes it
+easy to use it with existing \t{Makefiles}:
+\begin{verbatim}
+make CC="bin/cilly" LD="bin/cilly"
+\end{verbatim}
+
+ \t{cilly} can also behave as the Microsoft Visual C compiler, if the first
+ argument is \t{-{}-mode=MSVC}:
+\begin{verbatim}
+bin/cilly --mode=MSVC /D HAPPY_MOOD /I myincludes hello.c /Fe hello.exe
+\end{verbatim}
+
+ (This in turn will pass a \t{-{}-MSVC} flag to the underlying \t{cilly.asm}
+ process which will make it understand the Microsoft Visual C extensions)
+
+ \t{cilly} can also behave as the archiver \t{ar}, if it is passed an
+argument \t{-{}-mode=AR}. Note that only the \t{cr} mode is supported (create a
+new archive and replace all files in there). Therefore the previous version of
+the archive is lost.
+
+ Furthermore, \t{cilly} allows you to pass some arguments on to the
+underlying \t{cilly.asm} process. As a general rule all arguments that start
+with \t{-{}-} and that \t{cilly} itself does not process, are passed on. For
+example,
+\begin{verbatim}
+bin/cilly --dologwrites -D HAPPY_MOOD -I myincludes hello.c -o hello.exe
+\end{verbatim}
+
+ will produce a file \t{hello.cil.c} that prints all the memory addresses
+written by the application.
+
+ The most powerful feature of \t{cilly} is that it can collect all the
+sources in your project, merge them into one file and then apply CIL. This
+makes it a breeze to do whole-program analysis and transformation. All you
+have to do is to pass the \t{-{}-merge} flag to \t{cilly}:
+\begin{verbatim}
+make CC="bin/cilly --save-temps --dologwrites --merge"
+\end{verbatim}
+
+ You can even leave some files untouched:
+\begin{verbatim}
+make CC="bin/cilly --save-temps --dologwrites --merge --leavealone=foo --leavealone=bar"
+\end{verbatim}
+
+ This will merge all the files except those with the basename \t{foo} and
+\t{bar}. Those files will be compiled as usual and then linked in at the very
+end.
+
+ The sequence of actions performed by \t{cilly} depends on whether merging
+is turned on or not:
+\begin{itemize}
+\item If merging is off
+ \begin{enumerate}
+ \item For every file \t{file.c} to compile
+ \begin{enumerate}
+ \item Preprocess the file with the given arguments to
+ produce \t{file.i}
+ \item Invoke \t{cilly.asm} to produce a \t{file.cil.c}
+ \item Preprocess to \t{file.cil.i}
+ \item Invoke the underlying compiler to produce \t{file.cil.o}
+ \end{enumerate}
+ \item Link the resulting objects
+ \end{enumerate}
+\item If merging is on
+ \begin{enumerate}
+ \item For every file \t{file.c} to compile
+ \begin{enumerate}
+ \item Preprocess the file with the given arguments to
+ produce \t{file.i}
+ \item Save the preprocessed source as \t{file.o}
+ \end{enumerate}
+ \item When linking executable \t{hello.exe}, look at every object
+ file that must be linked and see if it actually
+ contains preprocessed source. Pass all those files to a
+ special merging application (described in
+ \secref{merger}) to produce \t{hello.exe\_comb.c}
+ \item Invoke \t{cilly.asm} to produce a \t{hello.exe\_comb.cil.c}
+ \item Preprocess to \t{hello.exe\_comb.cil.i}
+ \item Invoke the underlying compiler to produce \t{hello.exe\_comb.cil.o}
+ \item Invoke the actual linker to produce \t{hello.exe}
+ \end{enumerate}
+\end{itemize}
+
+ Note that files that you specify with \t{-{}-leavealone} are not merged and
+never presented to CIL. They are compiled as usual and then are linked in at
+the end.
+
+ And a final feature of \t{cilly} is that it can substitute copies of the
+system's include files:
+
+\begin{verbatim}
+make CC="bin/cilly --includedir=myinclude"
+\end{verbatim}
+
+ This will force the preprocessor to use the file \t{myinclude/xxx/stdio.h}
+(if it exists) whenever it encounters \t{\#include <stdio.h>}. The \t{xxx} is
+a string that identifies the compiler version you are using. This modified
+include files should be produced with the patcher script (see
+\secref{patcher}).
+
+ \subsection{\t{cilly} Options}
+
+ Among the options for the \t{cilly} you can put anything that can normally
+go in the command line of the compiler that \t{cilly} is impersonating.
+\t{cilly} will do its best to pass those options along to the appropriate
+subprocess. In addition, the following options are supported (a complete and
+up-to-date list can always be obtained by running \t{cilly -{}-help}):
+
+\begin{itemize}
+\item \t{-{}-mode=mode} This must be the first argument if present. It makes
+\t{cilly} behave as a given compiled. The following modes are recognized:
+ \begin{itemize}
+ \item GNUCC - the GNU C Compiler. This is the default.
+ \item MSVC - the Microsoft Visual C compiler. Of course, you should
+ pass only MSVC valid options in this case.
+ \item AR - the archiver \t{ar}. Only the mode \t{cr} is supported and
+ the original version of the archive is lost.
+ \end{itemize}
+\item \t{-{}-help} Prints a list of the options supported.
+\item \t{-{}-verbose} Prints lots of messages about what is going on.
+\item \t{-{}-stages} Less than \t{-{}-verbose} but lets you see what \t{cilly}
+ is doing.
+\item \t{-{}-merge} This tells \t{cilly} to first attempt to collect into one
+source file all of the sources that make your application, and then to apply
+\t{cilly.asm} on the resulting source. The sequence of actions in this case is
+described above and the merger itself is described in \secref{merger}.
+
+\item \t{-{}-leavealone=xxx}. Do not merge and do not present to CIL the files
+whose basename is "xxx". These files are compiled as usual and linked in at
+the end.
+\item \t{-{}-includedir=xxx}. Override the include files with those in the given
+directory. The given directory is the same name that was given an an argument
+to the patcher (see \secref{patcher}). In particular this means that
+that directory contains subdirectories named based on the current compiler
+version. The patcher creates those directories.
+\item \t{-{}-usecabs}. Do not CIL, but instead just parse the source and print
+its AST out. This should looked like the preprocessed file. This is useful
+when you suspect that the conversion to CIL phase changes the meaning of the
+program.
+\item \t{-{}-save-temps=xxx}. Temporary files are preserved in the xxx
+ directory. For example, the output of CIL will be put in a file
+ named \t{*.cil.c}.
+\item \t{-{}-save-temps}. Temporay files are preserved in the current directory.
+\end{itemize}
+
+
+ \subsection{\t{cilly.asm} Options}
+ \label{sec-cilly-asm-options}
+
+ All of the options that start with \t{-{}-} and are not understood by
+\t{cilly} are passed on to \t{cilly.asm}. \t{cilly} also passes along to
+\t{cilly.asm} flags such as \t{-{}-MSVC} that both need to know
+about. The following options are supported. Many of these flags also
+have corresponding ``\t{-{}-no}*'' versions if you need to go back to
+the default, as in ``\t{-{}-nowarnall}''.
+
+\hspace*{2cm} {\bf General Options:}
+\begin{itemize}
+ \item \t{-{}-version} output version information and exit
+ \item \t{-{}-verbose} Print lots of random stuff. This is passed on from cilly
+ \item \t{-{}-warnall} Show all warnings.
+ \item \t{-{}-debug=xxx} turns on debugging flag xxx
+ \item \t{-{}-nodebug=xxx} turns off debugging flag xxx
+ \item \t{-{}-flush} Flush the output streams often (aids debugging).
+ \item \t{-{}-check} Run a consistency check over the CIL after every operation.
+ \item \t{-{}-strictcheck} Same as \t{-{}-check}, but it treats
+ consistency problems as errors instead of warnings.
+ \item \t{-{}-nocheck} turns off consistency checking of CIL.
+ \item \t{-{}-noPrintLn} Don't output \#line directives in the output.
+ \item \t{-{}-commPrintLn} Print \#line directives in the output, but
+ put them in comments.
+ \item \t{-{}-commPrintLnSparse} Like \t{-{}-commPrintLn} but print only new
+ line numbers.
+ \item \t{-{}-log=xxx} Set the name of the log file. By default stderr is used
+ \item \t{-{}-MSVC} Enable MSVC compatibility. Default is GNU.
+ %\item \t{-{}-testcil} test CIL using the given compiler
+ \item \t{-{}-ignore-merge-conflicts} ignore merging conflicts.
+ %\item \t{-{}-sliceGlobal} output is the slice of #pragma cilnoremove(sym) symbols
+ %\item \t{-{}-tr <sys>}: subsystem to show debug printfs for
+ %\item \t{-{}-pdepth=n}: set max print depth (default: 5)
+ \item \t{-{}-extrafiles=filename}: the name of a file that contains
+ a list of additional files to process, separated by whitespace.
+ \item \t{-{}-stats} Print statistics about the running time of the
+ parser, conversion to CIL, etc. Also prints memory-usage
+ statistics. You can time parts of your own code as well. Calling
+ (\t{Stats.time ``label'' func arg}) will evaluate \t{(func arg)}
+ and remember how long this takes. If you call \t{Stats.time}
+ repeatedly with the same label, CIL will report the aggregate
+ time.
+
+ If available, CIL uses the x86 performance counters for these
+ stats. This is very precise, but results in ``wall-clock time.''
+ To report only user-mode time, find the call to \t{Stats.reset} in
+ \t{main.ml}, and change it to \t{Stats.reset Stats.SoftwareTimer}.
+
+ {\bf Lowering Options}
+ \item \t{-{}-noLowerConstants} do not lower constant expressions.
+ \item \t{-{}-noInsertImplicitCasts} do not insert implicit casts.
+ \item \t{-{}-forceRLArgEval} Forces right to left evaluation of function arguments.
+ %\item \t{-{}-nocil=n} Do not compile to CIL the global with the given index.
+ \item \t{-{}-disallowDuplication} Prevent small chunks of code from being duplicated.
+ \item \t{-{}-keepunused} Do not remove the unused variables and types.
+ \item \t{-{}-rmUnusedInlines} Delete any unused inline functions. This is the default in MSVC mode.
+
+ {\bf Output Options:}
+ \item \t{-{}-printCilAsIs} Do not try to simplify the CIL when
+ printing. Without this flag, CIL will attempt to produce prettier
+ output by e.g. changing \t{while(1)} into more meaningful loops.
+ \item \t{-{}-noWrap} do not wrap long lines when printing
+ \item \t{-{}-out=xxx} the name of the output CIL file. \t{cilly}
+ sets this for you.
+ \item \t{-{}-mergedout=xxx} specify the name of the merged file
+ \item \t{-{}-cabsonly=xxx} CABS output file name
+%% \item \t{-{}-printComments : print cabs tree structure in comments in cabs output
+%% \item \t{-{}-patchFile <fname>: name the file containing patching transformations
+%% \item \t{-{}-printPatched : print patched CABS files after patching, to *.patched
+%% \item \t{-{}-printProtos : print prototypes to safec.proto.h after parsing
+
+ {\bf Selected features.} See \secref{Extension} for more information.
+\item \t{-{}-dologcalls}. Insert code in the processed source to print the name of
+functions as are called. Implemented in \t{src/ext/logcalls.ml}.
+\item \t{-{}-dologwrites}. Insert code in the processed source to print the
+address of all memory writes. Implemented in \t{src/ext/logwrites.ml}.
+\item \t{-{}-dooneRet}. Make each function have at most one 'return'.
+Implemented in \t{src/ext/oneret.ml}.
+\item \t{-{}-dostackGuard}. Instrument function calls and returns to
+maintain a separate stack for return addresses. Implemeted in
+\t{src/ext/heapify.ml}.
+\item \t{-{}-domakeCFG}. Make the program look more like a CFG. Implemented
+in \t{src/cil.ml}.
+\item \t{-{}-dopartial}. Do interprocedural partial evaluation and
+constant folding. Implemented in \t{src/ext/partial.ml}.
+\item \t{-{}-dosimpleMem}. Simplify all memory expressions. Implemented in
+\t{src/ext/simplemem.ml}.
+
+For an up-to-date list of available options, run \t{cilly.asm -{}-help}.
+
+\end{itemize}
+
+\subsection{Internal Options}
+\label{sec-cilly-internal-options}
+
+All of the \t{cilly.asm} options described above can be set
+programmatically -- see \t{src/ciloptions.ml} or the individual
+extensions to see how. Some options should be set before parsing to
+be effective.
+
+Additionally, a few CIL options have no command-line flag and can only
+be set programmatically. These options may be useful for certain
+analyses:
+
+\begin{itemize}
+\item \t{Cabs2cil.doCollapseCallCast}:This is false by default. Set
+to true to replicate the behavior of CIL 1.3.5 and earlier.
+
+When false, all casts in the program are made explicit using the
+\t{CastE} expression. Accordingly, the destination of a Call
+instruction will always have the same type as the function's return
+type.
+
+If true, the destination type of a Call may differ from the return type, so
+there is an implicit cast. This is useful for analyses involving
+\t{malloc}. Without this option, CIL converts ``\t{T* x = malloc(n);}''
+into ``\t{void* tmp = malloc(n); T* x = (T*)tmp;}''. If you don't
+need all casts to be made explicit, you can set
+\t{Cabs2cil.doCollapseCallCast} to true so that CIL won't insert a
+temporary and you can more easily determine the allocation type from
+calls to \t{malloc}.
+
+
+\end{itemize}
+
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\section{Library of CIL Modules} \label{sec-Extension}\cutname{ext.html}
+
+ We are developing a suite of modules that use CIL for program analyses and
+transformations that we have found useful. You can use these modules directly
+on your code, or generally as inspiration for writing similar modules. A
+particularly big and complex application written on top of CIL is CCured
+(\ahrefurl{../ccured/index.html}).
+
+\subsection{Control-Flow Graphs} \label{sec-cfg}
+
+The \ciltyperef{stmt} datatype includes fields for intraprocedural
+control-flow information: the predecessor and successor statements of
+the current statement. This information is not computed by default.
+If you want to use the control-flow graph, or any of the extensions in
+this section that require it, you have to explicitly ask CIL to
+compute the CFG using one of these two methods:
+
+\subsubsection{The CFG module (new in CIL 1.3.5)}
+
+The best way to compute the CFG is with the CFG module. Just invoke
+\cfgref{computeFileCFG} on your file. The \moduleref{Cfg} API
+describes the rest of actions you can take with this module, including
+computing the CFG for one function at a time, or printing the CFG in
+\t{dot} form.
+
+
+\subsubsection{Simplified control flow}
+
+CIL can reduce high-level C control-flow constructs like \t{switch} and
+\t{continue} to lower-level \t{goto}s. This completely eliminates some
+possible classes of statements from the program and may make the result
+easier to analyze (e.g., it simplifies data-flow analysis).
+
+You can invoke this transformation on the command line with
+\t{-{}-domakeCFG} or programatically with \cilvalref{prepareCFG}.
+After calling Cil.prepareCFG, you can use \cilvalref{computeCFGInfo}
+to compute the CFG information and find the successor and predecessor
+of each statement.
+
+For a concrete example, you can see how \t{cilly -{}-domakeCFG}
+transforms the following code (note the fall-through in case 1):
+
+\begin{cilcode}[global] --domakeCFG
+ int foo (int predicate) {
+ int x = 0;
+ switch (predicate) {
+ case 0: return 111;
+ case 1: x = x + 1;
+ case 2: return (x+3);
+ case 3: break;
+ default: return 222;
+ }
+ return 333;
+ }
+\end{cilcode}
+
+\subsection{Data flow analysis framework}
+
+ The \moduleref{Dataflow} module (click for the ocamldoc) contains a
+parameterized framework for forward and backward data flow
+analyses. You provide the transfer functions and this module does the
+analysis. You must compute control-flow information (\secref{cfg})
+before invoking the Dataflow module.
+
+
+\subsection{Inliner}
+
+ The file ext/inliner.ml contains a function inliner.
+
+\subsection{Dominators}
+
+ The module \moduleref{Dominators} contains the computation of immediate
+ dominators. It uses the \moduleref{Dataflow} module.
+
+\subsection{Points-to Analysis}
+
+The module \t{ptranal.ml} contains two interprocedural points-to
+analyses for CIL: \t{Olf} and \t{Golf}. \t{Olf} is the default.
+(Switching from \t{olf.ml} to \t{golf.ml} requires a change in
+\t{Ptranal} and a recompiling \t{cilly}.)
+
+The analyses have the following characteristics:
+\begin{itemize}
+\item Not based on C types (inferred pointer relationships are sound
+ despite most kinds of C casts)
+\item One level of subtyping
+\item One level of context sensitivity (Golf only)
+\item Monomorphic type structures
+\item Field insensitive (fields of structs are conflated)
+\item Demand-driven (points-to queries are solved on demand)
+\item Handle function pointers
+\end{itemize}
+
+The analysis itself is factored into two components: \t{Ptranal},
+which walks over the CIL file and generates constraints, and \t{Olf}
+or \t{Golf}, which solve the constraints. The analysis is invoked
+with the function \t{Ptranal.analyze\_file: Cil.file ->
+ unit}. This function builds the points-to graph for the CIL file
+and stores it internally. There is currently no facility for clearing
+internal state, so \t{Ptranal.analyze\_file} should only be called
+once.
+
+%%% Interface for querying the points-to graph...
+The constructed points-to graph supports several kinds of queries,
+including alias queries (may two expressions be aliased?) and
+points-to queries (to what set of locations may an expression point?).
+
+%%% Main Interface
+The main interface with the alias analysis is as follows:
+\begin{itemize}
+\item \t{Ptranal.may\_alias: Cil.exp -> Cil.exp -> bool}. If
+ \t{true}, the two expressions may have the same value.
+\item \t{Ptranal.resolve\_lval: Cil.lval -> (Cil.varinfo
+ list)}. Returns the list of variables to which the given
+ left-hand value may point.
+\item \t{Ptranal.resolve\_exp: Cil.exp -> (Cil.varinfo list)}.
+ Returns the list of variables to which the given expression may
+ point.
+\item \t{Ptranal.resolve\_funptr: Cil.exp -> (Cil.fundec
+ list)}. Returns the list of functions to which the given
+ expression may point.
+\end{itemize}
+
+%%% Controlling the analysis
+The precision of the analysis can be customized by changing the values
+of several flags:
+
+\begin{itemize}
+\item \t{Ptranal.no\_sub: bool ref}.
+ If \t{true}, subtyping is disabled. Associated commandline option:
+ {\bf -{}-ptr\_unify}.
+\item \t{Ptranal.analyze\_mono: bool ref}.
+ (Golf only) If \t{true}, context sensitivity is disabled and the
+ analysis is effectively monomorphic. Commandline option:
+ {\bf -{}-ptr\_mono}.
+\item \t{Ptranal.smart\_aliases: bool ref}.
+ (Golf only) If \t{true}, ``smart'' disambiguation of aliases is
+ enabled. Otherwise, aliases are computed by intersecting points-to
+ sets. This is an experimental feature.
+\item \t{Ptranal.model\_strings: bool ref}.
+ Make the alias analysis model string constants by treating them as
+ pointers to chars. Commandline option: {\bf -{}-ptr\_model\_strings}
+\item \t{Ptranal.conservative\_undefineds: bool ref}.
+ Make the most pessimistic assumptions about globals if an undefined
+ function is present. Such a function can write to every global
+ variable. Commandline option: {\bf -{}-ptr\_conservative}
+\end{itemize}
+
+In practice, the best precision/efficiency tradeoff is achieved by
+setting \t{Ptranal.no\_sub} to \t{false}, \t{Ptranal.analyze\_mono} to
+\t{true}, and \t{Ptranal.smart\_aliases} to \t{false}. These are the
+default values of the flags.
+
+%%% Debug output
+There are also a few flags that can be used to inspect or serialize
+the results of the analysis.
+\begin{itemize}
+%%\item \t{Ptranal.ptrResults}.
+%% Commandline option: {\bf -{}-ptr\_results}. A no-op!
+%%
+%%\item \t{Ptranal.ptrTypes}.
+%% Commandline option: {\bf -{}-ptr\_types}. A no-op!
+%%
+\item \t{Ptranal.debug\_may\_aliases}.
+ Print the may-alias relationship of each pair of expressions in the
+ program. Commandline option: {\bf -{}-ptr\_may\_aliases}.
+\item \t{Ptranal.print\_constraints: bool ref}.
+ If \t{true}, the analysis will print each constraint as it is
+ generated.
+\item \t{Ptranal.print\_types: bool ref}.
+ If \t{true}, the analysis will print the inferred type of each
+ variable in the program.
+
+ If \t{Ptranal.analyze\_mono} and \t{Ptranal.no\_sub} are both
+ \t{true}, this output is sufficient to reconstruct the points-to
+ graph. One nice feature is that there is a pretty printer for
+ recursive types, so the print routine does not loop.
+\item \t{Ptranal.compute\_results: bool ref}.
+ If \t{true}, the analysis will print out the points-to set of each
+ variable in the program. This will essentially serialize the
+ points-to graph.
+\end{itemize}
+
+\subsection{StackGuard}
+
+The module \t{heapify.ml} contains a transformation similar to the one
+described in ``StackGuard: Automatic Adaptive Detection and Prevention of
+Buffer-Overflow Attacks'', {\em Proceedings of the 7th USENIX Security
+Conference}. In essence it modifies the program to maintain a separate
+stack for return addresses. Even if a buffer overrun attack occurs the
+actual correct return address will be taken from the special stack.
+
+Although it does work, this CIL module is provided mainly as an example of
+how to perform a simple source-to-source program analysis and
+transformation. As an optimization only functions that contain a dangerous
+local array make use of the special return address stack.
+
+For a concrete example, you can see how \t{cilly -{}-dostackGuard}
+transforms the following dangerous code:
+
+\begin{cilcode}[global] --dostackGuard
+ int dangerous() {
+ char array[10];
+ scanf("%s",array); // possible buffer overrun!
+ }
+
+ int main () {
+ return dangerous();
+ }
+\end{cilcode}
+
+
+\subsection{Heapify}
+
+The module \t{heapify.ml} also contains a transformation that moves all
+dangerous local arrays to the heap. This also prevents a number of buffer
+overruns.
+
+For a concrete example, you can see how \t{cilly -{}-doheapify}
+transforms the following dangerous code:
+
+\begin{cilcode}[global] --doheapify
+ int dangerous() {
+ char array[10];
+ scanf("%s",array); // possible buffer overrun!
+ }
+
+ int main () {
+ return dangerous();
+ }
+\end{cilcode}
+
+\subsection{One Return}
+
+The module \t{oneret.ml} contains a transformation the ensures that all
+function bodies have at most one return statement. This simplifies a number
+of analyses by providing a canonical exit-point.
+
+For a concrete example, you can see how \t{cilly -{}-dooneRet}
+transforms the following code:
+
+\begin{cilcode}[global] --dooneRet
+ int foo (int predicate) {
+ if (predicate <= 0) {
+ return 1;
+ } else {
+ if (predicate > 5)
+ return 2;
+ return 3;
+ }
+ }
+\end{cilcode}
+
+\subsection{Partial Evaluation and Constant Folding}
+
+The \t{partial.ml} module provides a simple interprocedural partial
+evaluation and constant folding data-flow analysis and transformation.
+This transformation always requires the \t{-{}-domakeCFG} option. It
+performs:
+\begin{itemize}
+\item Constant folding even of compiler-dependent constants as, for
+ example \t{sizeof(T)}.
+\item \t{if}-statement simplification for conditional expressions that
+ evaluate to a constant. The \t{if}-statement gets replaced with the
+ taken branch.
+\item Call elimination for
+ \begin{enumerate}
+ \item\label{enum:partial-empty-proc} empty functions and
+ \item\label{enum:partial-const-func} functions that return a
+ constant.
+ \end{enumerate}
+ In case~\ref{enum:partial-empty-proc} the call disappears completely
+ and in case~\ref{enum:partial-const-func} it is replaced by the
+ constant the function returns.
+\end{itemize}
+
+Several commandline options control the behavior of the feature.
+\begin{itemize}
+\item \t{-{}-partial\_no\_global\_const}:
+ Treat global constants as unknown values. This is the default.
+\item \t{-{}-partial\_global\_const}:
+ Treat global constants as initialized. Let global constants
+ participate in the partial evaluation.
+\item \t{-{}-partial\_root\_function} \i{function-name}:
+ Name of the function where the simplification starts. Default:
+ \t{main}.
+\item \t{-{}-partial\_use\_easy\_alias}
+ Use Partial's built-in easy alias to analyze pointers. This is the
+ default.
+\item \t{-{}-partial\_use\_ptranal\_alias}
+ Use feature Ptranal to analyze pointers. Setting this option
+ requires \t{-{}-doptranal}.
+\end{itemize}
+
+For a concrete example, you can see how \t{cilly -{}-domakeCFG -{}-dopartial}
+transforms the following code (note the eliminated \t{if}-branch and the
+partial optimization of \t{foo}):
+
+\begin{cilcode}[global] --domakeCFG --dopartial
+ int foo(int x, int y) {
+ int unknown;
+ if (unknown)
+ return y + 2;
+ return x + 3;
+ }
+
+ int bar(void) {
+ return -1;
+ }
+
+ int main(void) {
+ int a, b, c;
+ a = foo(5, 7) + foo(6, 7) + bar();
+ b = 4;
+ c = b * b;
+ if (b > c)
+ return b - c;
+ else
+ return b + c;
+ }
+\end{cilcode}
+
+\subsection{Reaching Definitions}
+
+The \t{reachingdefs.ml} module uses the dataflow framework and CFG
+information to calculate the definitions that reach each
+statement. After computing the CFG (\secref{cfg}) and calling
+\t{computeRDs} on a
+function declaration, \t{ReachingDef.stmtStartData} will contain a
+mapping from statement IDs to data about which definitions reach each
+statement. In particular, it is a mapping from statement IDs to a
+triple the first two members of which are used internally. The third
+member is a mapping from variable IDs to Sets of integer options. If
+the set contains \t{Some(i)}, then the definition of that variable
+with ID \t{i} reaches that statement. If the set contains \t{None},
+then there is a path to that statement on which there is no definition
+of that variable. Also, if the variable ID is unmapped at a
+statement, then no definition of that variable reaches that statement.
+
+To summarize, reachingdefs.ml has the following interface:
+\begin{itemize}
+\item \t{computeRDs} -- Computes reaching definitions. Requires that
+CFG information has already been computed for each statement.
+\item \t{ReachingDef.stmtStartData} -- contains reaching
+definition data after \t{computeRDs} is called.
+\item \t{ReachingDef.defIdStmtHash} -- Contains a mapping
+from definition IDs to the ID of the statement in which
+the definition occurs.
+\item \t{getRDs} -- Takes a statement ID and returns
+reaching definition data for that statement.
+\item \t{instrRDs} -- Takes a list of instructions and the
+definitions that reach the first instruction, and for
+each instruction calculates the definitions that reach
+either into or out of that instruction.
+\item \t{rdVisitorClass} -- A subclass of nopCilVisitor that
+can be extended such that the current reaching definition
+data is available when expressions are visited through
+the \t{get\_cur\_iosh} method of the class.
+\end{itemize}
+
+\subsection{Available Expressions}
+
+The \t{availexps.ml} module uses the dataflow framework and CFG
+information to calculate something similar to a traditional available
+expressions analysis. After \t{computeAEs} is called following a CFG
+calculation (\secref{cfg}), \t{AvailableExps.stmtStartData} will
+contain a mapping
+from statement IDs to data about what expressions are available at
+that statement. The data for each statement is a mapping for each
+variable ID to the whole expression available at that point(in the
+traditional sense) which the variable was last defined to be. So,
+this differs from a traditional available expressions analysis in that
+only whole expressions from a variable definition are considered rather
+than all expressions.
+
+The interface is as follows:
+\begin{itemize}
+\item \t{computeAEs} -- Computes available expressions. Requires
+that CFG information has already been comptued for each statement.
+\item \t{AvailableExps.stmtStartData} -- Contains available
+expressions data for each statement after \t{computeAEs} has been
+called.
+\item \t{getAEs} -- Takes a statement ID and returns
+available expression data for that statement.
+\item \t{instrAEs} -- Takes a list of instructions and
+the availalbe expressions at the first instruction, and
+for each instruction calculates the expressions available
+on entering or exiting each instruction.
+\item \t{aeVisitorClass} -- A subclass of nopCilVisitor that
+can be extended such that the current available expressions
+data is available when expressions are visited through the
+\t{get\_cur\_eh} method of the class.
+\end{itemize}
+
+\subsection{Liveness Analysis}
+
+The \t{liveness.ml} module uses the dataflow framework and
+CFG information to calculate which variables are live at
+each program point. After \t{computeLiveness} is called
+following a CFG calculation (\secref{cfg}), \t{LiveFlow.stmtStartData} will
+contain a mapping for each statement ID to a set of \t{varinfo}s
+for varialbes live at that program point.
+
+The interface is as follows:
+\begin{itemize}
+\item \t{computeLiveness} -- Computes live variables. Requires
+that CFG information has already been computed for each statement.
+\item \t{LiveFlow.stmtStartData} -- Contains live variable data
+for each statement after \t{computeLiveness} has been called.
+\end{itemize}
+
+Also included in this module is a command line interface that
+will cause liveness data to be printed to standard out for
+a particular function or label.
+
+\begin{itemize}
+\item \t{-{}-doliveness} -- Instructs cilly to comptue liveness
+information and to print on standard out the variables live
+at the points specified by \t{-{}-live\_func} and \t{live\_label}.
+If both are ommitted, then nothing is printed.
+\item \t{-{}-live\_func} -- The name of the function whose
+liveness data is of interest. If \t{-{}-live\_label} is ommitted,
+then data for each statement is printed.
+\item \t{-{}-live\_label} -- The name of the label at which
+the liveness data will be printed.
+\end{itemize}
+
+\subsection{Dead Code Elimination}
+
+The module \t{deadcodeelim.ml} uses the reaching definitions
+analysis to eliminate assignment instructions whose results
+are not used. The interface is as follows:
+
+\begin{itemize}
+\item \t{elim\_dead\_code} -- Performs dead code elimination
+on a function. Requires that CFG information has already
+been computed (\secref{cfg}).
+\item \t{dce} -- Performs dead code elimination on an
+entire file. Requires that CFG information has already
+been computed.
+\end{itemize}
+
+\subsection{Simple Memory Operations}
+
+The \t{simplemem.ml} module allows CIL lvalues that contain memory
+accesses to be even futher simplified via the introduction of
+well-typed temporaries. After this transformation all lvalues involve
+at most one memory reference.
+
+For a concrete example, you can see how \t{cilly -{}-dosimpleMem}
+transforms the following code:
+
+\begin{cilcode}[global] --dosimpleMem
+ int main () {
+ int ***three;
+ int **two;
+ ***three = **two;
+ }
+\end{cilcode}
+
+\subsection{Simple Three-Address Code}
+
+The \t{simplify.ml} module further reduces the complexity of program
+expressions and gives you a form of three-address code. After this
+transformation all expressions will adhere to the following grammar:
+\begin{verbatim}
+ 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"
+\end{verbatim}
+In addition, all \t{sizeof} and \t{alignof} forms are turned into
+constants. Accesses to arrays and variables whose address is taken are
+turned into "Mem" accesses. All field and index computations are turned
+into address arithmetic.
+
+For a concrete example, you can see how \t{cilly -{}-dosimplify}
+transforms the following code:
+
+\begin{cilcode}[global] --dosimplify
+ int main() {
+ struct mystruct {
+ int a;
+ int b;
+ } m;
+ int local;
+ int arr[3];
+ int *ptr;
+
+ ptr = &local;
+ m.a = local + sizeof(m) + arr[2];
+ return m.a;
+ }
+\end{cilcode}
+
+\subsection{Converting C to C++}
+
+The module canonicalize.ml performs several transformations to correct
+differences between C and C++, so that the output is (hopefully) valid
+C++ code. This may be incomplete --- certain fixes which are necessary
+for some programs are not yet implemented.
+
+Using the \t{-{}-doCanonicalize} option with CIL will perform the
+following changes to your program:
+
+\begin{enumerate}
+\item Any variables that use C++ keywords as identifiers are renamed.
+\item C allows global variables to have multiple declarations and
+ multiple (equivalent) definitions. This transformation removes
+ all but one declaration and all but one definition.
+\item \t{\_\_inline} is \#defined to \t{inline}, and \t{\_\_restrict}
+ is \#defined to nothing.
+\item 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.
+\item Makes casts from int to enum types explicit. (CIL changes enum
+ constants to int constants, but doesn't use a cast.)
+\end{enumerate}
+
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\section{Controlling CIL}
+
+ In the process of converting a C file to CIL we drop the unused prototypes
+and even inline function definitions. This results in much smaller files. If
+you do not want this behavior then you must pass the \t{-{}-keepunused} argument
+to the CIL application.
+
+ Alternatively you can put the following pragma in the code (instructing CIL
+to specifically keep the declarations and definitions of the function
+\t{func1} and variable \t{var2}, the definition of type \t{foo} and of
+structure \t{bar}):
+\begin{code}
+#pragma cilnoremove("func1", "var2", "type foo", "struct bar")
+\end{verbatim}\end{code}
+
+
+
+\section{GCC Extensions}
+
+ The CIL parser handles most of the \t{gcc}
+\ahreftop{http://gcc.gnu.org/onlinedocs/gcc-3.0.2/gcc\_5.html#SEC67}{extensions}
+and compiles them to CIL. The following extensions are not handled (note that
+we are able to compile a large number of programs, including the Linux kernel,
+without encountering these):
+
+\begin{enumerate}
+\item Nested function definitions.
+\item Constructing function calls.
+\item Naming an expression's type.
+\item Complex numbers
+\item Hex floats
+\item Subscripts on non-lvalue arrays.
+\item Forward function parameter declarations
+\end{enumerate}
+
+ The following extensions are handled, typically by compiling them away:
+\begin{enumerate}
+\item Attributes for functions, variables and types. In fact, we have a clear
+specification (see \secref{attrib}) of how attributes are interpreted. The
+specification extends that of \t{gcc}.
+\item Old-style function definitions and prototypes. These are translated to
+new-style.
+\item Locally-declared labels. As part of the translation to CIL, we generate
+new labels as needed.
+\item Labels as values and computed goto. This allows a program to take the
+address of a label and to manipulate it as any value and also to perform a
+computed goto. We compile this by assigning each label whose address is taken
+a small integer that acts as its address. Every computed \t{goto} in the body
+of the function is replaced with a \t{switch} statement. If you want to invoke
+the label from another function, you are on your own (the \t{gcc}
+documentation says the same.)
+\item Generalized lvalues. You can write code like \t{(a, b) += 5} and it gets
+translated to CIL.
+\item Conditionals with omitted operands. Things like \t{x ? : y} are
+translated to CIL.
+\item Double word integers. The type \t{long long} and the \t{LL} suffix on
+constants is understood. This is currently interpreted as 64-bit integers.
+\item Local arrays of variable length. These are converted to uses of
+\t{alloca}, the array variable is replaced with a pointer to the allocated
+array and the instances of \t{sizeof(a)} are adjusted to return the size of
+the array and not the size of the pointer.
+\item Non-constant local initializers. Like all local initializers these are
+compiled into assignments.
+\item Compound literals. These are also turned into assignments.
+\item Designated initializers. The CIL parser actually supports the full ISO
+syntax for initializers, which is more than both \t{gcc} and \t{MSVC}. I
+(George) think that this is the most complicated part of the C language and
+whoever designed it should be banned from ever designing languages again.
+\item Case ranges. These are compiled into separate cases. There is no code
+duplication, just a larger number of \t{case} statements.
+\item Transparent unions. This is a strange feature that allows you to define
+a function whose formal argument has a (tranparent) union type, but the
+argument is called as if it were the first element of the union. This is
+compiled away by saying that the type of the formal argument is that of the
+first field, and the first thing in the function body we copy the formal into
+a union.
+
+\item Inline assembly-language. The full syntax is supported and it is carried
+as such in CIL.
+
+\item Function names as strings. The identifiers \t{\_\_FUNCTION\_\_} and
+\t{\_\_PRETTY\_FUNCTION\_\_} are replaced with string literals.
+
+\item Keywords \t{typeof}, \t{alignof}, \t{inline} are supported.
+\end{enumerate}
+
+\section{CIL Limitations}
+
+ There are several implementation details of CIL that might make it unusable
+ or less than ideal for certain tasks:
+
+\begin{itemize}
+\item CIL operates after preprocessing. If you need to see comments, for
+example, you cannot use CIL. But you can use attributes and pragmas instead.
+And there is some support to help you patch the include files before they are
+seen by the preprocessor. For example, this is how we turn some
+\t{\#define}s that we don't like into function calls.
+
+\item CIL does transform the code in a non-trivial way. This is done in order
+to make most analyses easier. But if you want to see the code \t{e1, e2++}
+exactly as it appears in the code, then you should not use CIL.
+
+\item CIL removes all local scopes and moves all variables to function
+scope. It also separates a declaration with an initializer into a declaration
+plus an assignment. The unfortunate effect of this transformation is that
+local variables cannot have the \t{const} qualifier.
+
+\end{itemize}
+
+\section{Known Bugs and Limitations}
+
+\subsection{Code that CIL won't compile}
+\begin{itemize}
+\item We do not support tri-graph sequences (ISO 5.2.1.1).
+
+\item CIL cannot parse arbitrary \t{\#pragma} directives. Their
+ syntax must follow gcc's attribute syntax to be understood. If you
+ need a pragma that does not follow gcc syntax, add that pragma's name
+ to \t{no\_parse\_pragma} in \t{src/frontc/clexer.mll} to indicate that
+ CIL should treat that pragma as a monolithic string rather than try
+ to parse its arguments.
+
+ CIL cannot parse a line containing an empty \t{\#pragma}.
+
+\item CIL only parses \t{\#pragma} directives at the "top level", this is,
+ outside of any enum, structure, union, or function definitions.
+
+ If your compiler uses pragmas in places other than the top-level,
+ you may have to preprocess the sources in a special way (sed, perl,
+ etc.) to remove pragmas from these locations.
+
+\item CIL cannot parse the following code (fixing this problem would require
+ extensive hacking of the LALR grammar):
+\begin{code}
+int bar(int ()); // This prototype cannot be parsed
+int bar(int x()); // If you add a name to the function, it works
+int bar(int (*)()); // This also works (and it is more appropriate)
+\end{verbatim}\end{code}
+
+\item CIL also cannot parse certain K\&R old-style prototypes with missing
+ return type:
+\begin{code}
+g(); // This cannot be parsed
+int g(); // This is Ok
+\end{verbatim}\end{code}
+
+\item CIL does not understand some obscure combinations of type
+ specifiers (``signed'' and ``unsigned'' applied to typedefs that
+ themselves contain a sign specification; you could argue that this
+ should not be allowed anyway):
+\begin{code}
+typedef signed char __s8;
+__s8 unsigned uchartest; // This is unsigned char for gcc
+\end{verbatim}\end{code}
+
+\item CIL does not support constant-folding of floating-point values,
+ because it is difficult to simulate the behavior of various
+ C floating-point implementations in Ocaml. Therefore, code such as
+ this will not compile:
+\begin{code}
+int globalArray[(1.0 < 2.0) ? 5 : 50]
+\end{verbatim}\end{code}
+
+\item CIL uses Ocaml ints to represent the size of an object.
+ Therefore, it can't compute the size of any object that is larger
+ than $2^{30}$ bits (134 MB) on 32-bit computers, or $2^{62}$ bits on
+ 64-bit computers.
+
+\end{itemize}
+
+\subsection{Code that behaves differently under CIL}
+
+\begin{itemize}
+\item GCC has a strange feature called ``extern inline''. Such a function can
+be defined twice: first with the ``extern inline'' specifier and the second
+time without it. If optimizations are turned off then the ``extern inline''
+definition is considered a prototype (its body is ignored). If optimizations
+are turned on then the extern inline function is inlined at all of its
+occurrences from the point of its definition all the way to the point where the
+(optional) second definition appears. No body is generated for an extern
+inline function. A body is generated for the real definition and that one is
+used in the rest of the file.
+
+CIL will assume optimizations are on, and rename your extern inline
+function (and its uses) with the suffix
+\t{\_\_extinline}. This means that if you have two such definition, that do
+different things and the optimizations are not on, then the CIL version might
+compute a different answer !
+
+Also, if you have multiple extern inline declarations then CIL will ignore
+but the first one. This is not so bad because GCC itself would not like it.
+
+\item The implementation of \t{bitsSizeOf} does not take into account the
+ packing pragmas. However it was tested to be accurate on cygwin/gcc-2.95.3,
+ Linux/gcc-2.95.3 and on Windows/MSVC.
+
+\item \t{-malign-double} is ignored.
+
+\item The statement \t{x = 3 + x ++} will perform the increment of \t{x}
+ before the assignment, while \t{gcc} delays the increment after the
+ assignment. It turned out that this behavior is much easier to implement
+ than gcc's one, and either way is correct (since the behavior is unspecified
+ in this case). Similarly, if you write \t{x = x ++;} then CIL will perform
+ the increment before the assignment, whereas GCC and MSVC will perform it
+ after the assignment.
+
+\item Because CIL uses 64-bit floating point numbers in its internal
+ representation of floating point numbers, \t{long double} constants
+ are parsed as if they were \t{double} constants.
+
+\end{itemize}
+
+\subsection{Effects of the CIL translation}
+\begin{itemize}
+\item CIL cleans up C code in various ways that may suppress compiler
+ warnings. For example, CIL will add casts where they are needed
+ while \t{gcc} might print a warning for the missing cast. It is
+ not a goal of CIL to emit such warnings --- we support several
+ versions of several different compilers, and mimicking the warnings
+ of each is simply not possible. If you want to see compiler
+ warnings, compile your program with your favorite compiler before
+ using CIL.
+
+\item When you use variable-length arrays, CIL turns them into calls
+ to \t{alloca}. This means that they are deallocated when the
+ function returns and not when the local scope ends.
+
+ Variable-length arrays are not supported as fields of a struct or union.
+
+\item In the new versions of \t{glibc} there is a function
+ \t{\_\_builtin\_va\_arg} that takes a type as its second argument. CIL
+ handles that through a slight trick. As it parses the function it changes a
+ call like:
+\begin{verbatim}
+ mytype x = __builtin_va_arg(marker, mytype)
+\end{verbatim}
+ into
+\begin{verbatim}
+ mytype x;
+ __builtin_va_arg(marker, sizeof(mytype), &x);
+\end{verbatim}
+
+ The latter form is used internally in CIL. However, the CIL pretty printer
+ will try to emit the original code.
+
+ Similarly, \t{\_\_builtin\_types\_compatible\_p(t1, t2)}, which takes
+ types as arguments, is represented internally as
+ \t{\_\_builtin\_types\_compatible\_p(sizeof t1, sizeof t2)}, but the
+ sizeofs are removed when printing.
+
+\end{itemize}
+
+
+
+
+
+ \section{Using the merger}\label{sec-merger}\cutname{merger.html}
+
+ There are many program analyses that are more effective when
+done on the whole program.
+
+ The merger is a tool that combines all of the C source files in a project
+into a single C file. There are two tasks that a merger must perform:
+\begin{enumerate}
+\item Detect what are all the sources that make a project and with what
+compiler arguments they are compiled.
+
+\item Merge all of the source files into a single file.
+\end{enumerate}
+
+ For the first task the merger impersonates a compiler and a linker (both a
+GCC and a Microsoft Visual C mode are supported) and it expects to be invoked
+(from a build script or a Makefile) on all sources of the project. When
+invoked to compile a source the merger just preprocesses the source and saves
+the result using the name of the requested object file. By preprocessing at
+this time the merger is able to take into account variations in the command
+line arguments that affect preprocessing of different source files.
+
+ When the merger is invoked to link a number of object files it collects the
+preprocessed sources that were stored with the names of the object files, and
+invokes the merger proper. Note that arguments that affect the compilation or
+linking must be the same for all source files.
+
+ For the second task, the merger essentially concatenates the preprocessed
+sources with care to rename conflicting file-local declarations (we call this
+process alpha-conversion of a file). The merger also attempts to remove
+duplicate global declarations and definitions. Specifically the following
+actions are taken:
+
+\begin{itemize}
+\item File-scope names (\t{static} globals, names of types defined with
+\t{typedef}, and structure/union/enumeration tags) are given new names if they
+conflict with declarations from previously processed sources. The new name is
+formed by appending the suffix \t{\_\_\_n}, where \t{n} is a unique integer
+identifier. Then the new names are applied to their occurrences in the file.
+
+\item Non-static declarations and definitions of globals are never renamed.
+But we try to remove duplicate ones. Equality of globals is detected by
+comparing the printed form of the global (ignoring the line number directives)
+after the body has been alpha-converted. This process is intended to remove
+those declarations (e.g. function prototypes) that originate from the same
+include file. Similarly, we try to eliminate duplicate definitions of
+\t{inline} functions, since these occasionally appear in include files.
+
+\item The types of all global declarations with the same name from all files
+are compared for type isomorphism. During this process, the merger detects all
+those isomorphisms between structures and type definitions that are {\bf
+required} for the merged program to be legal. Such structure tags and
+typenames are coalesced and given the same name.
+
+\item Besides the structure tags and type names that are required to be
+isomorphic, the merger also tries to coalesce definitions of structures and
+types with the same name from different file. However, in this case the merger
+will not give an error if such definitions are not isomorphic; it will just
+use different names for them.
+
+\item In rare situations, it can happen that a file-local global in
+encountered first and it is not renamed, only to discover later when
+processing another file that there is an external symbol with the same name.
+In this case, a second pass is made over the merged file to rename the
+file-local symbol.
+\end{itemize}
+
+ Here is an example of using the merger:
+
+ The contents of \t{file1.c} is:
+\begin{code}
+struct foo; // Forward declaration
+extern struct foo *global;
+\end{verbatim}\end{code}
+
+ The contents of \t{file2.c} is:
+
+\begin{code}
+struct bar {
+ int x;
+ struct bar *next;
+};
+extern struct bar *global;
+struct foo {
+ int y;
+};
+extern struct foo another;
+void main() {
+}
+\end{verbatim}\end{code}
+
+ There are several ways in which one might create an executable from these
+files:
+\begin{itemize}
+\item
+\begin{verbatim}
+gcc file1.c file2.c -o a.out
+\end{verbatim}
+
+\item
+\begin{verbatim}
+gcc -c file1.c -o file1.o
+gcc -c file2.c -o file2.o
+ld file1.o file2.o -o a.out
+\end{verbatim}
+
+\item
+\begin{verbatim}
+gcc -c file1.c -o file1.o
+gcc -c file2.c -o file2.o
+ar r libfile2.a file2.o
+gcc file1.o libfile2.a -o a.out
+\end{verbatim}
+
+\item
+\begin{verbatim}
+gcc -c file1.c -o file1.o
+gcc -c file2.c -o file2.o
+ar r libfile2.a file2.o
+gcc file1.o -lfile2 -o a.out
+\end{verbatim}
+\end{itemize}
+
+ In each of the cases above you must replace all occurrences of \t{gcc} and
+\t{ld} with \t{cilly -{}-merge}, and all occurrences of \t{ar} with \t{cilly
+-{}-merge -{}-mode=AR}. It is very important that the \t{-{}-merge} flag be used
+throughout the build process. If you want to see the merged source file you
+must also pass the \t{-{}-keepmerged} flag to the linking phase.
+
+ The result of merging file1.c and file2.c is:
+\begin{code}
+// from file1.c
+struct foo; // Forward declaration
+extern struct foo *global;
+
+// from file2.c
+struct foo {
+ int x;
+ struct foo *next;
+};
+struct foo___1 {
+ int y;
+};
+extern struct foo___1 another;
+\end{verbatim}\end{code}
+
+ \section{Using the patcher}\label{sec-patcher}\cutname{patcher.html}
+
+ Occasionally we have needed to modify slightly the standard include files.
+So, we developed a simple mechanism that allows us to create modified copies
+of the include files and use them instead of the standard ones. For this
+purpose we specify a patch file and we run a program caller Patcher which
+makes modified copies of include files and applies the patch.
+
+ The patcher is invoked as follows:
+\begin{verbatim}
+bin/patcher [options]
+
+Options:
+ --help Prints this help message
+ --verbose Prints a lot of information about what is being done
+ --mode=xxx What tool to emulate:
+ GNUCC - GNU CC
+ MSVC - MS VC cl compiler
+
+ --dest=xxx The destination directory. Will make one if it does not exist
+ --patch=xxx Patch file (can be specified multiple times)
+ --ppargs=xxx An argument to be passed to the preprocessor (can be specified
+ multiple times)
+
+ --ufile=xxx A user-include file to be patched (treated as \#include "xxx")
+ --sfile=xxx A system-include file to be patched (treated as \#include <xxx>)
+
+ --clean Remove all files in the destination directory
+ --dumpversion Print the version name used for the current compiler
+
+ All of the other arguments are passed to the preprocessor. You should pass
+ enough arguments (e.g., include directories) so that the patcher can find the
+ right include files to be patched.
+\end{verbatim}
+
+ Based on the given \t{mode} and the current version of the compiler (which
+the patcher can print when given the \t{dumpversion} argument) the patcher
+will create a subdirectory of the \t{dest} directory (say \t{/usr/home/necula/cil/include}), such as:
+\begin{verbatim}
+/usr/home/necula/cil/include/gcc_2.95.3-5
+\end{verbatim}
+
+ In that file the patcher will copy the modified versions of the include files
+specified with the \t{ufile} and \t{sfile} options. Each of these options can
+be specified multiple times.
+
+ The patch file (specified with the \t{patch} option) has a format inspired by
+the Unix \t{patch} tool. The file has the following grammar:
+
+\begin{verbatim}
+<<< flags
+patterns
+===
+replacement
+>>>
+\end{verbatim}
+
+ The flags are a comma separated, case-sensitive, sequence of keywords or
+keyword = value. The following flags are supported:
+\begin{itemize}
+\item \t{file=foo.h} - will only apply the patch on files whose name is
+ \t{foo.h}.
+\item \t{optional} - this means that it is Ok if the current patch does not
+match any of the processed files.
+\item \t{group=foo} - will add this patch to the named group. If this is not
+specified then a unique group is created to contain just the current patch.
+When all files specified in the command line have been patched, an error
+message is generated for all groups for whom no member patch was used. We use
+this mechanism to receive notice when the patch triggers are out-dated with
+respect to the new include files.
+\item \t{system=sysname} - will only consider this pattern on a given
+operating system. The ``sysname'' is reported by the ``\$\^O'' variable in
+Perl, except that Windows is always considered to have sysname
+``cygwin.'' For Linux use ``linux'' (capitalization matters).
+\item \t{ateof} - In this case the patterns are ignored and the replacement
+text is placed at the end of the patched file. Use the \t{file} flag if you
+want to restrict the files in which this replacement is performed.
+\item \t{atsof} - The patterns are ignored and the replacement text is placed
+at the start of the patched file. Uf the \t{file} flag to restrict the
+application of this patch to a certain file.
+\item \t{disabled} - Use this flag if you want to disable the pattern.
+\end{itemize}
+
+
+ The patterns can consist of several groups of lines separated by the \t{|||}
+marker. Each of these group of lines is a multi-line pattern that if found in
+the file will be replaced with the text given at the end of the block.
+
+ The matching is space-insensitive.
+
+ All of the markers \t{<<<}, \t{|||}, \t{===} and \t{>>>} must appear at the
+beginning of a line but they can be followed by arbitrary text (which is
+ignored).
+
+ The replacement text can contain the special keyword \t{@\_\_pattern\_\_@},
+which is substituted with the pattern that matched.
+
+
+\section{Debugging support}\label{sec-debugger}
+
+ Most of the time we debug our code using the Errormsg module along with the
+pretty printer. But if you want to use the Ocaml debugger here is an easy way
+to do it. Say that you want to debug the invocation of cilly that arises out
+of the following command:
+\begin{verbatim}
+cilly -c hello.c
+\end{verbatim}
+
+ You must follow the installation \ahref{../ccured/setup.html}{instructions}
+to install the Elist support files for ocaml and to extend your .emacs
+appropriately. Then from within Emacs you do
+\begin{verbatim}
+ALT-X my-camldebug
+\end{verbatim}
+
+ This will ask you for the command to use for running the Ocaml debugger
+(initially the default will be ``ocamldebug'' or the last command you
+introduced). You use the following command:
+\begin{verbatim}
+cilly --ocamldebug -c hello.c
+\end{verbatim}
+
+ This will run \t{cilly} as usual and invoke the Ocaml debugger when the cilly
+engine starts. The advantage of this way of invoking the debugger is that the
+directory search paths are set automatically and the right set or arguments is
+passed to the debugger.
+
+
+\section{Who Says C is Simple?}\label{sec-simplec}
+
+ When I (George) started to write CIL I thought it was going to take two weeks.
+Exactly a year has passed since then and I am still fixing bugs in it. This
+gross underestimate was due to the fact that I thought parsing and making
+sense of C is simple. You probably think the same. What I did not expect was
+how many dark corners this language has, especially if you want to parse
+real-world programs such as those written for GCC or if you are more ambitious
+and you want to parse the Linux or Windows NT sources (both of these were
+written without any respect for the standard and with the expectation that
+compilers will be changed to accommodate the program).
+
+ The following examples were actually encountered either in real programs or
+are taken from the ISO C99 standard or from the GCC's testcases. My first
+reaction when I saw these was: {\em Is this C?}. The second one was : {\em
+What the hell does it mean?}.
+
+ If you are contemplating doing program analysis for C on abstract-syntax
+trees then your analysis ought to be able to handle these things. Or, you can
+use CIL and let CIL translate them into clean C code.
+
+%
+% Note: the cilcode environment is bogus. You should preprocess this source
+% with cilcode.pl !!!
+%
+%
+ \subsection{Standard C}
+
+\begin{enumerate}
+
+\item Why does the following code return 0 for most values of \t{x}? (This
+should be easy.)
+
+\begin{cilcode}[local]
+ int x;
+ return x == (1 && x);
+\end{cilcode}
+
+\item Why does the following code return 0 and not -1? (Answer: because
+\t{sizeof} is unsigned, thus the result of the subtraction is unsigned, thus
+the shift is logical.)
+
+\begin{cilcode}[local]
+ return ((1 - sizeof(int)) >> 32);
+\end{cilcode}
+
+\item Scoping rules can be tricky. This function returns 5.
+
+\begin{cilcode}[global]
+int x = 5;
+int f() {
+ int x = 3;
+ {
+ extern int x;
+ return x;
+ }
+}
+\end{cilcode}
+
+\item Functions and function pointers are implicitly converted to each other.
+
+\begin{cilcode}[global]
+int (*pf)(void);
+int f(void) {
+
+ pf = &f; // This looks ok
+ pf = ***f; // Dereference a function?
+ pf(); // Invoke a function pointer?
+ (****pf)(); // Looks strange but Ok
+ (***************f)(); // Also Ok
+}
+\end{cilcode}
+
+\item Initializer with designators are one of the hardest parts about ISO C.
+Neither MSVC or GCC implement them fully. GCC comes close though. What is the
+final value of \t{i.nested.y} and \t{i.nested.z}? (Answer: 2 and respectively
+6).
+
+\begin{cilcode}[global]
+struct {
+ int x;
+ struct {
+ int y, z;
+ } nested;
+} i = { .nested.y = 5, 6, .x = 1, 2 };
+\end{cilcode}
+
+\item This is from c-torture. This function returns 1.
+
+\begin{cilcode}[global]
+typedef struct
+{
+ char *key;
+ char *value;
+} T1;
+
+typedef struct
+{
+ long type;
+ char *value;
+} T3;
+
+T1 a[] =
+{
+ {
+ "",
+ ((char *)&((T3) {1, (char *) 1}))
+ }
+};
+int main() {
+ T3 *pt3 = (T3*)a[0].value;
+ return pt3->value;
+}
+\end{cilcode}
+
+\item Another one with constructed literals. This one is legal according to
+the GCC documentation but somehow GCC chokes on (it works in CIL though). This
+code returns 2.
+
+\begin{cilcode}[local]
+ return ((int []){1,2,3,4})[1];
+\end{cilcode}
+
+\item In the example below there is one copy of ``bar'' and two copies of
+ ``pbar'' (static prototypes at block scope have file scope, while for all
+ other types they have block scope).
+
+\begin{cilcode}[global]
+ int foo() {
+ static bar();
+ static (*pbar)() = bar;
+
+ }
+
+ static bar() {
+ return 1;
+ }
+
+ static (*pbar)() = 0;
+\end{cilcode}
+
+
+\item Two years after heavy use of CIL, by us and others, I discovered a bug
+ in the parser. The return value of the following function depends on what
+ precedence you give to casts and unary minus:
+\begin{cilcode}[global]
+ unsigned long foo() {
+ return (unsigned long) - 1 / 8;
+ }
+\end{cilcode}
+
+ The correct interpretation is \t{((unsigned long) - 1) / 8}, which is a
+ relatively large number, as opposed to \t{(unsigned long) (- 1 / 8)}, which
+ is 0.
+
+\end{enumerate}
+
+ \subsection{GCC ugliness}\label{sec-ugly-gcc}
+
+\begin{enumerate}
+
+\item GCC has generalized lvalues. You can take the address of a lot of
+strange things:
+
+\begin{cilcode}[local]
+ int x, y, z;
+ return &(x ? y : z) - & (x++, x);
+\end{cilcode}
+
+\item GCC lets you omit the second component of a conditional expression.
+
+\begin{cilcode}[local]
+ extern int f();
+ return f() ? : -1; // Returns the result of f unless it is 0
+\end{cilcode}
+
+\item Computed jumps can be tricky. CIL compiles them away in a fairly clean
+way but you are on your own if you try to jump into another function this way.
+
+\begin{cilcode}[global]
+static void *jtab[2]; // A jump table
+static int doit(int x){
+
+ static int jtab_init = 0;
+ if(!jtab_init) { // Initialize the jump table
+ jtab[0] = &&lbl1;
+ jtab[1] = &&lbl2;
+ jtab_init = 1;
+ }
+ goto *jtab[x]; // Jump through the table
+lbl1:
+ return 0;
+lbl2:
+ return 1;
+}
+
+int main(void){
+ if (doit(0) != 0) exit(1);
+ if (doit(1) != 1) exit(1);
+ exit(0);
+}
+\end{cilcode}
+
+
+\item A cute little example that we made up. What is the returned value?
+(Answer: 1);
+\begin{cilcode}[local]
+ return ({goto L; 0;}) && ({L: 5;});
+\end{cilcode}
+
+\item \t{extern inline} is a strange feature of GNU C. Can you guess what the
+following code computes?
+
+\begin{cilcode}[global]
+extern inline foo(void) { return 1; }
+int firstuse(void) { return foo(); }
+
+// A second, incompatible definition of foo
+int foo(void) { return 2; }
+
+int main() {
+ return foo() + firstuse();
+}
+\end{cilcode}
+
+ The answer depends on whether the optimizations are turned on. If they are
+then the answer is 3 (the first definition is inlined at all occurrences until
+the second definition). If the optimizations are off, then the first
+definition is ignore (treated like a prototype) and the answer is 4.
+
+ CIL will misbehave on this example, if the optimizations are turned off (it
+ always returns 3).
+
+\item GCC allows you to cast an object of a type T into a union as long as the
+union has a field of that type:
+\begin{cilcode}[global]
+union u {
+ int i;
+ struct s {
+ int i1, i2;
+ } s;
+};
+
+union u x = (union u)6;
+
+int main() {
+ struct s y = {1, 2};
+ union u z = (union u)y;
+}
+\end{cilcode}
+
+\item GCC allows you to use the \t{\_\_mode\_\_} attribute to specify the size
+of the integer instead of the standard \t{char}, \t{short} and so on:
+\begin{cilcode}[global]
+int __attribute__ ((__mode__ ( __QI__ ))) i8;
+int __attribute__ ((__mode__ ( __HI__ ))) i16;
+int __attribute__ ((__mode__ ( __SI__ ))) i32;
+int __attribute__ ((__mode__ ( __DI__ ))) i64;
+\end{cilcode}
+
+\item The ``alias'' attribute on a function declaration tells the
+ linker to treat this declaration as another name for the specified
+ function. CIL will replace the declaration with a trampoline
+ function pointing to the specified target.
+\begin{cilcode}[global]
+ static int bar(int x, char y) {
+ return x + y;
+ }
+
+ //foo is considered another name for bar.
+ int foo(int x, char y) __attribute__((alias("bar")));
+\end{cilcode}
+
+\end{enumerate}
+
+ \subsection{Microsoft VC ugliness}
+
+ This compiler has few extensions, so there is not much to say here.
+
+\begin{enumerate}
+\item Why does the following code return 0 and not -1? (Answer: because of a
+bug in Microsoft Visual C. It thinks that the shift is unsigned just because
+the second operator is unsigned. CIL reproduces this bug when in MSVC mode.)
+
+\begin{code}
+ return -3 >> (8 * sizeof(int));
+\end{verbatim}\end{code}
+
+\item Unnamed fields in a structure seem really strange at first. It seems
+that Microsoft Visual C introduced this extension, then GCC picked it up (but
+in the process implemented it wrongly: in GCC the field \t{y} overlaps with
+\t{x}!).
+
+\begin{cilcode}[local]
+struct {
+ int x;
+ struct {
+ int y, z;
+ struct {
+ int u, v;
+ };
+ };
+} a;
+return a.x + a.y + a.z + a.u + a.v;
+\end{cilcode}
+
+
+\end{enumerate}
+
+\section{Authors}
+
+ The CIL parser was developed starting from Hugues Casse's \t{frontc}
+front-end for C although all the files from the \t{frontc} distribution have
+been changed very extensively. The intermediate language and the elaboration
+stage are all written from scratch. The main author is
+\ahref{mailto:necula@cs.berkeley.edu}{George Necula}, with significant
+contributions from \ahref{mailto:smcpeak@cs.berkeley.edu}{Scott McPeak},
+\ahref{mailto:weimer@cs.berkeley.edu}{Westley Weimer},
+\ahref{mailto:liblit@cs.wisc.edu}{Ben Liblit},
+\ahreftop{http://www.cs.berkeley.edu/\~{}matth/}{Matt Harren},
+Raymond To and Aman Bhargava.
+
+ This work is based upon work supported in part by the National Science
+Foundation under Grants No. 9875171, 0085949 and 0081588, and gifts from
+Microsoft Research. Any opinions, findings, and conclusions or recommendations
+expressed in this material are those of the author(s) and do not necessarily
+reflect the views of the National Science Foundation or the other sponsors.
+
+\section{License}
+
+Copyright (c) 2001-2007,
+\begin{itemize}
+\item George C. Necula <necula@cs.berkeley.edu>
+\item Scott McPeak <smcpeak@cs.berkeley.edu>
+\item Wes Weimer <weimer@cs.berkeley.edu>
+\item Ben Liblit <liblit@cs.wisc.edu>
+\item Matt Harren <matth@cs.berkeley.edu>
+\end{itemize}
+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.
+
+\section{Bug reports}
+
+ We are certain that there are still some remaining bugs in CIL. If you find
+one please file a bug report in our Source Forge space
+\ahreftop{http://sourceforge.net/projects/cil}
+ {http://sourceforge.net/projects/cil}.
+
+ You can find there the latest announcements, a source distribution,
+bug report submission instructions and a mailing list: cil-users[at
+sign]lists.sourceforge.net. Please use this list to ask questions about CIL,
+as it will ensure your message is viewed by a broad audience.
+
+\section{Changes}\label{sec-changes}\cutname{changes.html}
+\begin{itemize}
+\item {\bf February 14, 2008}: Fixed a bug in temporary file
+creation. Thanks to J. Aaron Pendergrass for the patch.
+\item {\bf November 30, 2007}: Fixed a bbug in assignment to lvalues that
+ depend on themselves.
+\item {\bf April 4, 2007}: Benjamin Monate fixed a bug in
+ \moduleref{Cfg} for empty loop bodies.
+\item {\bf March 29, 2007}: Polyvios Pratikakis fixed a bug in
+ \t{src/ext/pta/uref.ml}.
+\item {\bf March 15, 2007}: Added support for
+ \t{\_\_attribute\_\_((aligned))} and
+ \t{\_\_attribute\_\_((packed))}.
+\item {\bf March 7, 2007}: \t{typeOf(StartOf \_)} now preserves the
+ attributes of the array.
+\item {\bf February 22, 2007}: Added an inliner (ext/inliner.ml)
+\item {\bf February 21, 2007}: We now constant-fold bitfield
+ expressions. Thanks to Virgile Prevosto for the patch.
+\item {\bf February 13, 2007}: gcc preprocessor arguments passed
+ using \t{-Wp} are now used only during initial preproccessing, not
+ for the preprocessing after CIL. This fixes problems in the Linux
+ makefiles with dependency generation.
+\item {\bf February 6, 2007}: Fixed \cilvalref{parseInt} for non-32
+ bit architectures.
+\item {\bf February 5, 2007}: {\bf Released version 1.3.6} (Subversion
+ revision 9211)
+\item {\bf February 2, 2007}: Improved the way CIL gets configured for the
+ actual definitions of \t{size\_t} and \t{wchar\_t}.
+\item {\bf February 1, 2007}: Fixed the parser to support the unused
+ attribute on labels. For now, we just drop this attribute since
+ Rmtmps will remove unused labels anyways. Thanks to Peter Hawkins
+ for the patch.
+\item {\bf January 18, 2007}: Require the destination of a \t{Call} to
+ have the same type as the function's return type, even if it means
+ inserting a temporary. To get the old behavior, set
+ \t{Cabs2cil.doCollapseCallCast} to true as described in
+ \secref{cilly-internal-options}.
+\item {\bf January 17, 2007}: Fix for \t{\_\_builtin\_offsetof} when
+ the field name is also a typedef name.
+\item {\bf January 17, 2007}: Fixed \cilvalref{loadBinaryFile}
+ (Sourceforge bug \#1548894).
+ You should only use loadBinaryFile if no other code has been loaded
+ or generated in the current CIL process, since loadBinaryFile needs
+ to load some global state.
+\item {\bf December 18, 2006}: The \t{-{}-stats} flag now gets the CPU
+ speed at runtime rather than configure-time, so binary executables
+ can be moved to different computers.
+\item {\bf December 14, 2006}: Fixed various warnings and errors on
+ 64-bit architectures.
+\item {\bf November 26, 2006}: Christoph Spiel added ``\t{-{}-no}''
+ options to many of CIL's command-line flags.
+\item {\bf November 21, 2006}: Merged \t{gccBuiltins} and
+ \t{msvcBuiltins} into a single table \cilvalref{builtinFunctions}
+ that is initialized by \cilvalref{initCIL}.
+\item {\bf October 28, 2006}: Added the field \t{vdescr} to the
+ \ciltyperef{varinfo} struct to remember what value is stored in
+ certain CIL-introduced temporary variables. For example, if CIL
+ adds a temporary to store the result of \t{foo(a,b)}, then the
+ description will be ``foo(a,b)''. The new printer
+ \cilvalref{descriptiveCilPrinter} will substitute descriptions for
+ the names of temporaries. The result is not necessarily valid C,
+ but it may let you produce more helpful error messages in your
+ analysis tools: ``The value foo(a,b) may be tainted'' vs. ``The
+ value \_\_cil\_tmp29 may be tainted.''
+\item {\bf October 27, 2006}: Fixed a bug with duplicate entries in
+ the statement list of Switch nodes, and forbade duplicate
+ \t{default} cases.
+%% October 26, 2006: Moved the CIL source repository from CVS
+%% to Subversion. Subversion revision 8603 is the switchover point.
+\item {\bf October 12, 2006}: Added a new function \cilvalref{expToAttrParam}
+that attempts to convert an expression into a attribute parameter.
+\item {\bf October 12, 2006}: Added an attribute with the length of the array,
+ when array types of formal arguments are converted to pointer types.
+\item {\bf September 29, 2006}: Benjamin Monate fixed a bug in compound
+ local initializers that was causing duplicate code to be added.
+\item {\bf August 9, 2006}: Changed the patcher to print ``\t{\#line
+ nnn}'' directives instead of ``\t{\# nnn}''.
+\item {\bf August 6, 2006}: Joseph Koshy patched \t{./configure} for
+ FreeBSD on amd64.
+\item {\bf July 27, 2006}: CIL files now include the prototypes of
+ builtin functions (such as \t{\_\_builtin\_va\_arg}). This
+ preserves the invariant that every function call has a corresponding
+ function or function prototype in the file. However, the prototypes
+ of builtins are not printed in the output files.
+\item {\bf July 23, 2006}: Incorporated some fixes for the constant folding
+ for lvalues, and fixed grammatical errors. Thanks to Christian Stork.
+\item {\bf July 23, 2006}: Changed the way ./configure works. We now generate
+ the file Makefile.features to record the configuration features. This is
+ because autoconf does not work properly with multiline substitutions.
+\item {\bf July 21, 2006}: Cleaned up the printing of some Lvals. Things that
+ were printed as ``(*i)'' before are now printed simply as ``*i'' (no
+ parentheses). However, this means that when you use pLval to print lvalues
+ inside expressions, you must take care about parentheses yourself. Thanks to
+ Benjamin Monate for pointing this out.
+\item {\bf July 21, 2006}: Added new hooks to the Usedef and
+ Dataflow.BackwardsTransfer APIs. Code that uses these will need to
+ be changed slightly. Also, updated the \moduleref{Cfg} code to
+ handle noreturn functions.
+\item {\bf July 17, 2006}: Fix parsing of attributes on bitfields and
+ empty attribute lists. Thanks to Peter Hawkins.
+\item {\bf July 10, 2006}: Fix Makefile problem for FreeBSD. Thanks
+ to Joseph Koshy for the patch.
+\item {\bf June 25, 2006}: Extended the inline assembly to support named
+ arguments, as added in gcc 3.0. This changes the types of the input
+ and output lists from ``\t{(string * lval) list}'' to
+ ``\t{(string option * string * lval) list}''. Some existing code
+ will need to be modified accordingly.
+\item {\bf June 11, 2006}: Removed the function \t{Cil.foldLeftCompoundAll}.
+Use instead \cilvalref{foldLeftCompound} with \t{~implicit:true}.
+\item {\bf June 9, 2006}: Extended the definition of the cilVisitor for
+initializers to pass more information around. This might result in backward
+incompatibilities with code that uses the visitor for initializers.
+\item {\bf June 2, 2006}: Added \t{-{}-commPrintLnSparse} flag.
+\item {\bf June 1, 2006}: Christian Stork provided some fixes for the handling
+ of variable argument functions.
+\item {\bf June 1, 2006}: Added support for x86 performance counters
+ on 64-bit processors. Thanks to tbergen for the patch.
+\item {\bf May 23, 2006}: Benjamin Monate fixed a lexer bug when a
+ preprocessed file is missing a final newline.
+\item {\bf May 23, 2006}: Fix for \t{typeof($e$)} when $e$ has type
+ \t{void}.
+\item {\bf May 20, 2006}: {\bf Released version 1.3.5} (Subversion
+ revision 8093)
+\item {\bf May 19, 2006}: \t{Makefile.cil.in}/\t{Makefile.cil} have
+ been renamed \t{Makefile.in}/\t{Makefile}. And \t{maincil.ml} has
+ been renamed \t{main.ml}.
+\item {\bf May 18, 2006}: Added a new module \moduleref{Cfg} to compute the
+ control-flow graph. Unlike the older \cilvalref{computeCFGInfo},
+ the new version does not modify the code.
+\item {\bf May 18, 2006}: Added several new analyses: reaching
+ definitions, available expressions, liveness analysis, and dead code
+ elimination. See \secref{Extension}.
+\item {\bf May 2, 2006}: Added a flag \t{-{}-noInsertImplicitCasts}.
+ When this flag is used, CIL code will only include casts inserted by
+ the programmer. Implicit coercions are not changed to explicit casts.
+\item {\bf April 16, 2006}: Minor improvements to the \t{-{}-stats}
+ flag (\secref{cilly-asm-options}). We now use Pentium performance
+ counters by default, if your processor supports them.
+\item {\bf April 10, 2006}: Extended \t{machdep.c} to support
+ microcontroller compilers where the struct alignment of integer
+ types does not match the size of the type. Thanks to Nathan
+ Cooprider for the patch.
+\item {\bf April 6, 2006}: Fix for global initializers of unions when
+ the union field being initialized is not the first one, and for
+ missing initializers of unions when the first field is not the
+ largest field.
+\item {\bf April 6, 2006}: Fix for bitfields in the SFI module.
+\item {\bf April 6, 2006}: Various fixes for gcc attributes.
+ \t{packed}, \t{section}, and \t{always\_inline} attributes are now
+ parsed correctly. Also fixed printing of attributes on enum types.
+\item {\bf March 30, 2006}: Fix for \t{rmtemps.ml}, which deletes
+ unused inline functions. When in \t{gcc} mode CIL now leaves all
+ inline functions in place, since \t{gcc} treats these as externally
+ visible.
+\item {\bf March 3, 2006}: Assume inline assembly instructions can
+ fall through for the purposes of adding return statements. Thanks to
+ Nathan Cooprider for the patch.
+\item {\bf February 27, 2006}: Fix for extern inline functions when
+ the output of CIL is fed back into CIL.
+\item {\bf January 30, 2006}: Fix parsing of \t{switch} without braces.
+\item {\bf January 30, 2006}: Allow `\$' to appear in identifiers.
+\item {\bf January 13, 2006}: Added support for gcc's alias attribute
+ on functions. See \secref{ugly-gcc}, item 8.
+\item {\bf December 9, 2005}: Christoph Spiel fixed the Golf and
+ Olf modules so that Golf can be used with the points-to analysis.
+ He also added performance fixes and cleaned up the documentation.
+\item {\bf December 1, 2005}: Major rewrite of the ext/callgraph module.
+\item {\bf December 1, 2005}: Preserve enumeration constants in CIL. Default
+is the old behavior to replace them with integers.
+\item {\bf November 30, 2005}: Added support for many GCC \t{\_\_builtin}
+ functions.
+\item {\bf November 30, 2005}: Added the EXTRAFEATURES configure
+ option, making it easier to add Features to the build process.
+\item {\bf November 23, 2005}: In MSVC mode do not remove any locals whose name
+ appears as a substring in an inline assembly.
+\item {\bf November 23, 2005}: Do not add a return to functions that have the
+ noreturn attribute.
+\item {\bf November 22, 2005}: {\bf Released version 1.3.4}
+\item {\bf November 21, 2005}: Performance and correctness fixes for
+ the Points-to Analysis module. Thanks to Christoph Spiel for the
+ patches.
+\item {\bf October 5, 2005}: CIL now builds on SPARC/Solaris. Thanks
+ to Nick Petroni and Remco van Engelen for the patches.
+\item {\bf September 26, 2005}: CIL no longer uses the `\t{-I-}' flag
+ by default when preprocessing with gcc.
+\item {\bf August 24, 2005}: Added a command-line option
+ ``-{}-forceRLArgEval'' that forces function arguments to be evaluated
+ right-to-left. This is the default behavior in unoptimized gcc and
+ MSVC, but the order of evaluation is undefined when using
+ optimizations, unless you apply this CIL transformation. This flag
+ does not affect the order of evaluation of e.g. binary operators,
+ which remains undefined. Thanks to Nathan Cooprider for the patch.
+\item {\bf August 9, 2005}: Fixed merging when there are more than 20
+ input files.
+\item {\bf August 3, 2005}: When merging, it is now an error to
+ declare the same global variable twice with different initializers.
+\item {\bf July 27, 2005}: Fixed bug in transparent unions.
+\item {\bf July 27, 2005}: Fixed bug in collectInitializer. Thanks to
+ Benjamin Monate for the patch.
+\item {\bf July 26, 2005}: Better support for extended inline assembly
+ in gcc.
+\item {\bf July 26, 2005}: Added many more gcc \_\_builtin* functions
+ to CIL. Most are treated as Call instructions, but a few are
+ translated into expressions so that they can be used in global
+ initializers. For example, ``\t{\_\_builtin\_offsetof(t, field)}'' is
+ rewritten as ``\t{\&((t*)0)->field}'', the traditional way of calculating
+ an offset.
+\item {\bf July 18, 2005}: Fixed bug in the constant folding of shifts
+ when the second argument was negative or too large.
+\item {\bf July 18, 2005}: Fixed bug where casts were not always
+ inserted in function calls.
+\item {\bf June 10, 2005}: Fixed bug in the code that makes implicit
+ returns explicit. We weren't handling switch blocks correctly.
+\item {\bf June 1, 2005}: {\bf Released version 1.3.3}
+\item {\bf May 31, 2005}: Fixed handling of noreturn attribute for function
+ pointers.
+\item {\bf May 30, 2005}: Fixed bugs in the handling of constructors in gcc.
+\item {\bf May 30, 2005}: Fixed bugs in the generation of global variable IDs.
+\item {\bf May 27, 2005}: Reimplemented the translation of function calls so
+ that we can intercept some builtins. This is important for the uses of
+ \_\_builtin\_constant\_p in constants.
+\item {\bf May 27, 2005}: Export the plainCilPrinter, for debugging.
+\item {\bf May 27, 2005}: Fixed bug with printing of const attribute for
+ arrays.
+\item {\bf May 27, 2005}: Fixed bug in generation of type signatures. Now they
+ should not contain expressions anymore, so you can use structural equality.
+ This used to lead to Out\_of\_Memory exceptions.
+\item {\bf May 27, 2005}: Fixed bug in type comparisons using
+ TBuiltin\_va\_list.
+\item {\bf May 27, 2005}: Improved the constant folding in array lengths and
+ case expressions.
+\item {\bf May 27, 2005}: Added the \t{\_\_builtin\_frame\_address} to the set
+ of gcc builtins.
+\item {\bf May 27, 2005}: Added the CIL project to SourceForge.
+\item {\bf April 23, 2005}: The cattr field was not visited.
+\item {\bf March 6, 2005}: Debian packaging support
+\item {\bf February 16, 2005}: Merger fixes.
+\item {\bf February 11, 2005}: Fixed a bug in \t{-{}-dopartial}. Thanks to
+Nathan Cooprider for this fix.
+\item {\bf January 31, 2005}: Make sure the input file is closed even if a
+ parsing error is encountered.
+\item {\bf January 11, 2005}: {\bf Released version 1.3.2}
+\item {\bf January 11, 2005}: Fixed printing of integer constants whose
+ integer kind is shorter than an int.
+\item {\bf January 11, 2005}: Added checks for negative size arrays and arrays
+ too big.
+\item {\bf January 10, 2005}: Added support for GCC attribute ``volatile'' for
+ tunctions (as a synonim for noreturn).
+\item {\bf January 10, 2005}: Improved the comparison of array sizes when
+ comparing array types.
+\item {\bf January 10, 2005}: Fixed handling of shell metacharacters in the
+ cilly command lione.
+\item {\bf January 10, 2005}: Fixed dropping of cast in initialization of
+ local variable with the result of a function call.
+\item {\bf January 10, 2005}: Fixed some structural comparisons that were
+ broken in the Ocaml 3.08.
+\item {\bf January 10, 2005}: Fixed the \t{unrollType} function to not forget
+ attributes.
+\item {\bf January 10, 2005}: Better keeping track of locations of function
+ prototypes and definitions.
+\item {\bf January 10, 2005}: Fixed bug with the expansion of enumeration
+ constants in attributes.
+\item {\bf October 18, 2004}: Fixed a bug in cabsvisit.ml. CIl would wrap a
+ BLOCK around a single atom unnecessarily.
+\item {\bf August 7, 2004}: {\bf Released version 1.3.1}
+\item {\bf August 4, 2004}: Fixed a bug in splitting of structs using
+ \t{-{}-dosimplify}
+\item {\bf July 29, 2004}: Minor changes to the type typeSig (type signatures)
+ to ensure that they do not contain types, so that you can do structural
+ comparison without danger of nontermination.
+\item {\bf July 28, 2004}: Ocaml version 3.08 is required. Numerous small
+ changes while porting to Ocaml 3.08.
+\item {\bf July 7, 2004}: {\bf Released version 1.2.6}
+\item {\bf July 2, 2004}: Character constants such as \t{'c'} should
+ have type \t{int}, not \t{char}. Added a utility function
+ \t{Cil.charConstToInt} that sign-extends chars greater than 128, if needed.
+\item {\bf July 2, 2004}: Fixed a bug that was casting values to int
+ before applying the logical negation operator !. This caused
+ problems for floats, and for integer types bigger than \t{int}.
+\item {\bf June 13, 2004}: Added the field \t{sallstmts} to a function
+ description, to hold all statements in the function.
+\item {\bf June 13, 2004}: Added new extensions for data flow analyses, and
+ for computing dominators.
+\item {\bf June 10, 2004}: Force initialization of CIL at the start of
+Cabs2cil.
+\item {\bf June 9, 2004}: Added support for GCC \t{\_\_attribute\_used\_\_}
+\item {\bf April 7, 2004}: {\bf Released version 1.2.5}
+\item {\bf April 7, 2004}: Allow now to run ./configure CC=cl and set the MSVC
+compiler to be the default. The MSVC driver will now select the default name
+of the .exe file like the CL compiler.
+\item {\bf April 7, 2004}: Fixed a bug in the driver. The temporary files are
+deleted by the Perl script before the CL compiler gets to them?
+\item {\bf April 7, 2004}: Added the - form of arguments to the MSVC driver.
+\item {\bf April 7, 2004}: Added a few more GCC-specific string escapes, (, [,
+\{, \%, E.
+\item {\bf April 7, 2004}: Fixed bug with continuation lines in MSVC.
+\item {\bf April 6, 2004}: Fixed embarassing bug in the parser: the precedence
+ of casts and unary operators was switched.
+\item {\bf April 5, 2004}: Fixed a bug involving statements mixed between
+declarations containing initializers. Now we make sure that the initializers
+are run in the proper order with respect to the statements.
+\item {\bf April 5, 2004}: Fixed a bug in the merger. The merger was keeping
+separate alpha renaming talbes (namespaces) for variables and types. This
+means that it might end up with a type and a variable named the same way, if
+they come from different files, which breaks an important CIL invariant.
+\item {\bf March 11, 2004} : Fixed a bug in the Cil.copyFunction function. The
+new local variables were not getting fresh IDs.
+\item {\bf March 5, 2004}: Fixed a bug in the handling of static function
+ prototypes in a block scope. They used to be renamed. Now we just consider
+ them global.
+\item {\bf February 20, 2004}: {\bf Released version 1.2.4}
+\item {\bf February 15, 2004}: Changed the parser to allow extra semicolons
+ after field declarations.
+\item {\bf February 14, 2004}: Changed the Errormsg functions: error, unimp,
+bug to not raise an exception. Instead they just set Errormsg.hadErrors.
+\item {\bf February 13, 2004}: Change the parsing of attributes to recognize
+ enumeration constants.
+\item {\bf February 10, 2004}: In some versions of \t{gcc} the identifier
+ {\_\{thread} is an identifier and in others it is a keyword. Added code
+ during configuration to detect which is the case.
+\item {\bf January 7, 2004}: {\bf Released version 1.2.3}
+\item {\bf January 7, 2004}: Changed the alpha renamer to be less
+conservative. It will remember all versions of a name that were seen and will
+only create a new name if we have not seen one.
+\item {\bf December 30, 2003} : Extended the \t{cilly} command to understand
+ better linker command options \t{-lfoo}.
+\item {\bf December 5, 2003}: Added markup commands to the pretty-printer
+module. Also, changed the ``@<'' left-flush command into ``@\^''.
+\item {\bf December 4, 2003}: Wide string literals are now handled
+directly by Cil (rather than being exploded into arrays). This is
+apparently handy for Microsoft Device Driver APIs that use intrinsic
+functions that require literal constant wide-string arguments.
+\item {\bf December 3, 2003}: Added support for structured exception handling
+ extensions for the Microsoft compilers.
+\item {\bf December 1, 2003}: Fixed a Makefile bug in the generation of the
+Cil library (e.g., \t{cil.cma}) that was causing it to be unusable. Thanks
+to KEvin Millikin for pointing out this bug.
+\item {\bf November 26, 2003}: Added support for linkage specifications
+ (extern ``C'').
+\item {\bf November 26, 2003}: Added the ocamlutil directory to contain some
+utilities shared with other projects.
+\item {\bf November 25, 2003}: {\bf Released version 1.2.2}
+\item {\bf November 24, 2003}: Fixed a bug that allowed a static local to
+ conflict with a global with the same name that is declared later in the
+ file.
+\item {\bf November 24, 2003}: Removed the \t{-{}-keep} option of the \t{cilly}
+ driver and replaced it with \t{-{}-save-temps}.
+\item {\bf November 24, 2003}: Added printing of what CIL features are being
+ run.
+\item {\bf November 24, 2003}: Fixed a bug that resulted in attributes being
+ dropped for integer types.
+\item {\bf November 11, 2003}: Fixed a bug in the visitor for enumeration
+ definitions.
+\item {\bf October 24, 2003}: Fixed a problem in the configuration script. It
+ was not recognizing the Ocaml version number for beta versions.
+\item {\bf October 15, 2003}: Fixed a problem in version 1.2.1 that was
+ preventing compilation on OCaml 3.04.
+\item {\bf September 17, 2003: Released version 1.2.1.}
+\item {\bf September 7, 2003}: Redesigned the interface for choosing
+ \texttt{\#line} directive printing styles. Cil.printLn and
+ Cil.printLnComment have been merged into Cil.lineDirectiveStyle.
+\item {\bf August 8, 2003}: Do not silently pad out functions calls with
+arguments to match the prototype.
+\item {\bf August 1, 2003}: A variety of fixes suggested by Steve Chamberlain:
+initializers for externs, prohibit float literals in enum, initializers for
+unsized arrays were not working always, an overflow problem in Ocaml, changed
+the processing of attributes before struct specifiers
+
+\item {\bf July 14, 2003}: Add basic support for GCC's "\_\_thread" storage
+qualifier. If given, it will appear as a "thread" attribute at the top of the
+type of the declared object. Treatment is very similar to "\_\_declspec(...)"
+in MSVC
+
+\item {\bf July 8, 2003}: Fixed some of the \_\_alignof computations. Fixed
+ bug in the designated initializers for arrays (Array.get error).
+\item {\bf July 8, 2003}: Fixed infinite loop bug (Stack Overflow) in the
+ visitor for \_\_alignof.
+\item {\bf July 8, 2003}: Fixed bug in the conversion to CIL. A function or
+ array argument of
+ the GCC \_\_typeof() was being converted to pointer type. Instead, it should
+ be left alone, just like for sizeof.
+\item {\bf July 7, 2003}: New Escape module provides utility functions
+ for escaping characters and strings in accordance with C lexical
+ rules.
+
+\item {\bf July 2, 2003}: Relax CIL's rules for when two enumeration types are
+considered compatible. Previously CIL considered two enums to be compatible if
+they were the same enum. Now we follow the C99 standard.
+
+
+\item {\bf June 28, 2003}: In the Formatparse module, Eric Haugh found and
+ fixed a bug in the handling of lvalues of the form ``lv->field.more''.
+
+\item {\bf June 28, 2003}: Extended the handling of gcc command lines
+arguments in the Perl scripts.
+
+\item {\bf June 23, 2003}: In Rmtmps module, simplified the API for
+ customizing the root set. Clients may supply a predicate that
+ returns true for each root global. Modifying various
+ ``\texttt{referenced}'' fields directly is no longer supported.
+
+\item {\bf June 17, 2003}: Reimplement internal utility routine
+ \t{Cil.escape\_char}. Faster and better.
+
+\item {\bf June 14, 2003}: Implemented support for \t{\_\_attribute\_\_s}
+appearing between "struct" and the struct tag name (also for unions and
+enums), since gcc supports this as documented in section 4.30 of the gcc
+(2.95.3) manual
+
+\item {\bf May 30, 2003}: Released the regression tests.
+\item {\bf May 28, 2003}: {\bf Released version 1.1.2}
+\item {\bf May 26, 2003}: Add the \t{simplify} module that compiles CIL
+expressions into simpler expressions, similar to those that appear in a
+3-address intermediate language.
+\item {\bf May 26, 2003}: Various fixes and improvements to the pointer
+analysis modules.
+\item {\bf May 26, 2003}: Added optional consistency checking for
+transformations.
+\item {\bf May 25, 2003}: Added configuration support for big endian machines.
+Now \cilvalref{little\_endian} can be used to test whether the machine is
+little endian or not.
+\item {\bf May 22, 2003}: Fixed a bug in the handling of inline functions. The
+CIL merger used to turn these functions into ``static'', which is incorrect.
+\item {\bf May 22, 2003}: Expanded the CIL consistency checker to verify
+undesired sharing relationships between data structures.
+\item {\bf May 22, 2003}: Fixed bug in the \t{oneret} CIL module: it was
+mishandling certain labeled return statements.
+\item {\bf May 5, 2003}: {\bf Released version 1.0.11}
+\item {\bf May 5, 2003}: OS X (powerpc/darwin) support for CIL. Special
+thanks to Jeff Foster, Andy Begel and Tim Leek.
+\item {\bf April 30, 2003}: Better description of how to use CIL for your
+analysis.
+\item {\bf April 28, 2003}: Fixed a bug with \texttt{-{}-dooneRet} and
+\texttt{-{}-doheapify}. Thanks, Manos Renieris.
+\item {\bf April 16, 2003}: Reworked management of
+ temporary/intermediate output files in Perl driver scripts. Default
+ behavior is now to remove all such files. To keep intermediate
+ files, use one of the following existing flags:
+ \begin{itemize}
+ \item \texttt{-{}-keepmerged} for the single-file merge of all sources
+ \item \texttt{-{}-keep=<\textit{dir}>} for various other CIL and
+ CCured output files
+ \item \texttt{-{}-save-temps} for various gcc intermediate files; MSVC
+ has no equivalent option
+ \end{itemize}
+ As part of this change, some intermediate files have changed their
+ names slightly so that new suffixes are always preceded by a
+ period. For example, CCured output that used to appear in
+ ``\texttt{foocured.c}'' now appears in ``\texttt{foo.cured.c}''.
+\item {\bf April 7, 2003}: Changed the representation of the \cilvalref{GVar}
+global constructor. Now it is possible to update the initializer without
+reconstructing the global (which in turn it would require reconstructing the
+list of globals that make up a program). We did this because it is often
+tempting to use \cilvalref{visitCilFileSameGlobals} and the \cilvalref{GVar}
+was the only global that could not be updated in place.
+\item {\bf April 6, 2003}: Reimplemented parts of the cilly.pl script to make
+it more robust in the presence of complex compiler arguments.
+\item {\bf March 10, 2003}: {\bf Released version 1.0.9}
+\item {\bf March 10, 2003}: Unified and documented a large number of CIL
+Library Modules: oneret, simplemem, makecfg, heapify, stackguard, partial.
+Also documented the main client interface for the pointer analysis.
+\item {\bf February 18, 2003}: Fixed a bug in logwrites that was causing it
+to produce invalid C code on writes to bitfields. Thanks, David Park.
+\item {\bf February 15, 2003}: {\bf Released version 1.0.8}
+\item {\bf February 15, 2003}: PDF versions of the manual and API are
+available for those who would like to print them out.
+\item {\bf February 14, 2003}: CIL now comes bundled with alias analyses.
+\item {\bf February 11, 2003}: Added support for adding/removing options from
+ \t{./configure}.
+\item {\bf February 3, 2003}: {\bf Released version 1.0.7}
+\item {\bf February 1, 2003}: Some bug fixes in the handling of variable
+argument functions in new versions of \t{gcc} And \t{glibc}.
+\item {\bf January 29, 2003}: Added the logical AND and OR operators.
+Exapanded the translation to CIL to handle more complicated initializers
+(including those that contain logical operators).
+\item {\bf January 28, 2003}: {\bf Released version 1.0.6}
+\item {\bf January 28, 2003}: Added support for the new handling of
+variable-argument functions in new versions of \t{glibc}.
+\item {\bf January 19, 2003}: Added support for declarations in interpreted
+ constructors. Relaxed the semantics of the patterns for variables.
+\item {\bf January 17, 2003}: Added built-in prototypes for the gcc built-in
+ functions. Changed the \t{pGlobal} method in the printers to print the
+ carriage return as well.
+\item {\bf January 9, 2003}: Reworked lexer and parser's strategy for
+ tracking source file names and line numbers to more closely match
+ typical native compiler behavior. The visible CIL interface is
+ unchanged.
+\item {\bf January 9, 2003}: Changed the interface to the alpha convertor. Now
+you can pass a list where it will record undo information that you can use to
+revert the changes that it makes to the scope tables.
+\item {\bf January 6, 2003}: {\bf Released version 1.0.5}
+\item {\bf January 4, 2003}: Changed the interface for the Formatcil module.
+ Now the placeholders in the pattern have names. Also expanded the
+ documentation of the Formatcil module.
+ Now the placeholders in the pattern have names.
+\item {\bf January 3, 2003}: Extended the \t{rmtmps} module to also remove
+ unused labels that are generated in the conversion to CIL. This reduces the
+ number of warnings that you get from \t{cgcc} afterwards.
+\item {\bf December 17, 2002}: Fixed a few bugs in CIL related to the
+ representation of string literals. The standard says that a string literal
+ is an array. In CIL, a string literal has type pointer to character. This is
+ Ok, except as an argument of sizeof. To support this exception, we have
+ added to CIL the expression constructor SizeOfStr. This allowed us to fix
+ bugs with computing \t{sizeof("foo bar")} and \t{sizeof((char*)"foo bar")}
+ (the former is 8 and the latter is 4).
+
+\item {\bf December 8, 2002}: Fixed a few bugs in the lexer and parser
+ relating to hex and octal escapes in string literals. Also fixed
+ the dependencies between the lexer and parser.
+\item {\bf December 5, 2002}: Fixed visitor bugs that were causing
+ some attributes not to be visited and some queued instructions to be
+ dropped.
+\item {\bf December 3, 2002}: Added a transformation to catch stack
+ overflows. Fixed the heapify transformation.
+\item {\bf October 14, 2002}: CIL is now available under the BSD license
+(see the License section or the file LICENSE). {\bf Released version 1.0.4}
+\item {\bf October 9, 2002}: More FreeBSD configuration changes, support
+for the GCC-ims {\tt \_\_signed} and {\tt \_\_volatile}. Thanks to Axel
+Simon for pointing out these problems. {\bf Released version 1.0.3}
+\item {\bf October 8, 2002}: FreeBSD configuration and porting fixes.
+Thanks to Axel Simon for pointing out these problems.
+\item {\bf September 10, 2002}: Fixed bug in conversion to CIL. Now we drop
+all ``const'' qualifiers from the types of locals, even from the fields of
+local structures or elements of arrays.
+\item {\bf September 7, 2002}: Extended visitor interface to distinguish visitng
+ offsets inside lvalues from offsets inside initializer lists.
+\item {\bf September 7, 2002}: {\bf Released version 1.0.1}
+\item {\bf September 6, 2002}: Extended the patcher with the \t{ateof} flag.
+\item {\bf September 4, 2002}: Fixed bug in the elaboration to CIL. In some
+cases constant folding of \t{||} and \t{\&\&} was computed wrong.
+\item {\bf September 3, 2002}: Fixed the merger documentation.
+\item {\bf August 29, 2002}: {\bf Released version 1.0.0.}
+\item {\bf August 29, 2002}: Started numbering versions with a major nubmer,
+minor and revisions. Released version 1.0.0.
+\item {\bf August 25, 2002}: Fixed the implementation of the unique
+identifiers for global variables and composites. Now those identifiers are
+globally unique.
+\item {\bf August 24, 2002}: Added to the machine-dependent configuration the
+\t{sizeof{void}}. It is 1 on gcc and 0 on MSVC. Extended the implementation of
+\t{Cil.bitsSizeOf} to handle this (it was previously returning an error when
+trying to compute the size of \t{void}).
+\item {\bf August 24, 2002}: Changed the representation of structure and
+unions to distinguish between undefined structures and those that are defined
+to be empty (allowed on gcc). The sizeof operator is undefined for the former
+and returns 0 for the latter.
+\item {\bf August 22, 2002}: Apply a patch from Richard H. Y. to support
+FreeBSD installations. Thanks, Richard!
+\item {\bf August 12, 2002}: Fixed a bug in the translation of wide-character
+strings. Now this translation matches that of the underlying compiler. Changed
+the implementation of the compiler dependencies.
+\item {\bf May 25, 2002}: Added interpreted constructors and destructors.
+\item {\bf May 17, 2002}: Changed the representation of functions to move the
+``inline'' information to the varinfo. This way we can print the ``inline''
+even in declarations which is what gcc does.
+\item {\bf May 15, 2002}: Changed the visitor for initializers to make two
+tail-recursive passes (the second is a \t{List.rev} and only done if one of
+the initializers change). This prevents \t{Stack\_Overflow} for large
+initializers. Also improved the processing of initializers when converting to
+CIL.
+\item {\bf May 15, 2002}: Changed the front-end to allow the use of \t{MSVC}
+mode even on machines that do not have MSVC. The machine-dependent parameters
+for GCC will be used in that case.
+\item {\bf May 11, 2002}: Changed the representation of formals in function
+types. Now the function type is purely functional.
+\item {\bf May 4, 2002}: Added the function
+\cilvalref{visitCilFileSameGlobals} and changed \cilvalref{visitCilFile} to be
+tail recursive. This prevents stack overflow on huge files.
+\item {\bf February 28, 2002}: Changed the significance of the
+\t{CompoundInit} in \ciltyperef{init} to allow for missing initializers at the
+end of an array initializer. Added the API function
+\cilvalref{foldLeftCompoundAll}.
+\end{itemize}
+
+\end{document}
+
+
+
+% LocalWords: CIL intraprocedural datatype CIL's html Dataflow ocamldoc cilly
+% LocalWords: Dominators tbergen bitfield
--- /dev/null
+#
+# Preprocesses a text and it changes
+# \begin{cilcode}
+# ...
+# \end{cilcode}
+#
+# into the verbatim environment and add the option to see the CIL output for
+# it.
+
+use strict;
+use Data::Dumper;
+
+my $testnr = 1;
+my $tmpdir = "cilcode.tmp";
+my $htmloutdir = "examples";
+my $outdir = "html/cil/$htmloutdir";
+
+my $cilly = "perl ../bin/cilly --verbose";
+
+my $doexamples = ! defined($ENV{'NO_EXAMPLES'});
+
+my $preambleLocal = <<EOF;
+int main(void) {
+\# 1
+EOF
+
+my $preambleGlobal = <<EOF;
+EOF
+
+my $postambleGlobal = "";
+my $postambleLocal = <<EOF;
+}
+EOF
+
+if(! -d $tmpdir) {
+ mkdir $tmpdir || die "Canmake not make $tmpdir\n";
+
+}
+my $incode = 0;
+my $opt;
+my $cil_options;
+
+binmode STDOUT;
+
+my $lineno = 0;
+while(<>) {
+ $lineno ++;
+ 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")
+ || die "Cannot create source $testnr";
+ if($opt eq 'local') {
+ print TSTSRC $preambleLocal;
+ } else {
+ print TSTSRC $preambleGlobal;
+ }
+ print "\\begin{code}\n";
+ next;
+ }
+ if($incode && $_ =~ m|^\\end{cilcode}$|) {
+ $incode = 0;
+ if($opt eq 'local') {
+ print TSTSRC $postambleLocal;
+ } else {
+ print TSTSRC $postambleGlobal;
+ }
+ close(TSTSRC);
+ print "\\end{verbatim}\\end{code}\n";
+ if($doexamples) {
+ print "See the \\ahref{$htmloutdir/ex$testnr.txt}{CIL output} for this
+code fragment\n";
+ # Now run cilly
+ my $cmd = "$cilly $cil_options -c $tmpdir/ex$testnr.c -o $tmpdir/ex$testnr.o --save-temps=$tmpdir";
+ # print "$cmd\n";
+ if(system($cmd)) {
+ die "Error running CIL for $tmpdir/ex$testnr.c";
+ }
+ # Now repackage the CIL file
+ my $cilfile = "$tmpdir/ex$testnr.cil.c";
+ open(CIL, "<$cilfile") || die "Cannot find CIL file \"$cilfile\" for $testnr";
+ my $exfile = "$outdir/ex$testnr.txt";
+ open(OUT, ">$exfile") || die "Cannot write OUT file \"$exfile\" for $testnr";
+ while(<CIL>) {
+ print OUT $_;
+ }
+ close(OUT);
+ close(CIL);
+ } else {
+ print "(Code generation was turned off for this document)";
+ }
+ $testnr ++;
+ next;
+ }
+ if($incode) {
+ print TSTSRC $_;
+ }
+ print $_;
+}
+
--- /dev/null
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Comment.sty version 3.6, October 1999
+%
+% Purpose:
+% selectively in/exclude pieces of text: the user can define new
+% comment versions, and each is controlled separately.
+% Special comments can be defined where the user specifies the
+% action that is to be taken with each comment line.
+%
+% Author
+% Victor Eijkhout
+% Department of Computer Science
+% University of Tennessee
+% 107 Ayres Hall
+% Knoxville TN 37996
+% USA
+%
+% victor@eijkhout.net
+%
+% This program is free software; you can redistribute it and/or
+% modify it under the terms of the GNU General Public License
+% as published by the Free Software Foundation; either version 2
+% of the License, or (at your option) any later version.
+%
+% This program is distributed in the hope that it will be useful,
+% but WITHOUT ANY WARRANTY; without even the implied warranty of
+% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+% GNU General Public License for more details.
+%
+% For a copy of the GNU General Public License, write to the
+% Free Software Foundation, Inc.,
+% 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA,
+% or find it on the net, for instance at
+% http://www.gnu.org/copyleft/gpl.html
+%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% This style can be used with plain TeX or LaTeX, and probably
+% most other packages too.
+%
+% Usage: all text included between
+% \comment ... \endcomment
+% or \begin{comment} ... \end{comment}
+% is discarded.
+%
+% The opening and closing commands should appear on a line
+% of their own. No starting spaces, nothing after it.
+% This environment should work with arbitrary amounts
+% of comment, and the comment can be arbitrary text.
+%
+% Other `comment' environments are defined by
+% and are selected/deselected with
+% \includecomment{versiona}
+% \excludecoment{versionb}
+%
+% These environments are used as
+% \versiona ... \endversiona
+% or \begin{versiona} ... \end{versiona}
+% with the opening and closing commands again on a line of
+% their own.
+%
+% LaTeX users note: for an included comment, the
+% \begin and \end lines act as if they don't exist.
+% In particular, they don't imply grouping, so assignments
+% &c are not local.
+%
+% Special comments are defined as
+% \specialcomment{name}{before commands}{after commands}
+% where the second and third arguments are executed before
+% and after each comment block. You can use this for global
+% formatting commands.
+% To keep definitions &c local, you can include \begingroup
+% in the `before commands' and \endgroup in the `after commands'.
+% ex:
+% \specialcomment{smalltt}
+% {\begingroup\ttfamily\footnotesize}{\endgroup}
+% You do *not* have to do an additional
+% \includecomment{smalltt}
+% To remove 'smalltt' blocks, give \excludecomment{smalltt}
+% after the definition.
+%
+% Processing comments can apply processing to each line.
+% \processcomment{name}{each-line commands}%
+% {before commands}{after commands}
+% By defining a control sequence
+% \def\Thiscomment##1{...} in the before commands the user can
+% specify what is to be done with each comment line.
+% BUG this does not work quite yet BUG
+%
+% Trick for short in/exclude macros (such as \maybe{this snippet}):
+%\includecomment{cond}
+%\newcommand{\maybe}[1]{}
+%\begin{cond}
+%\renewcommand{\maybe}[1]{#1}
+%\end{cond}
+%
+% Basic approach of the implementation:
+% to comment something out, scoop up every line in verbatim mode
+% as macro argument, then throw it away.
+% For inclusions, in LaTeX the block is written out to
+% a file \CommentCutFile (default "comment.cut"), which is
+% then included.
+% In plain TeX (and other formats) both the opening and
+% closing comands are defined as noop.
+%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Changes in version 3.1
+% - updated author's address
+% - cleaned up some code
+% - trailing contents on \begin{env} line is always discarded
+% even if you've done \includecomment{env}
+% - comments no longer define grouping!! you can even
+% \includecomment{env}
+% \begin{env}
+% \begin{itemize}
+% \end{env}
+% Isn't that something ...
+% - included comments are written to file and input again.
+% Changes in 3.2
+% - \specialcomment brought up to date (thanks to Ivo Welch).
+% Changes in 3.3
+% - updated author's address again
+% - parametrised \CommentCutFile
+% Changes in 3.4
+% - added GNU public license
+% - added \processcomment, because Ivo's fix (above) brought an
+% inconsistency to light.
+% Changes in 3.5
+% - corrected typo in header.
+% - changed author email
+% - corrected \specialcomment yet again.
+% - fixed excludecomment of an earlier defined environment.
+% Changes in 3.6
+% - The 'cut' file is now written more verbatim, using \meaning;
+% some people reported having trouble with ISO latin 1, or umlaute.sty.
+% - removed some \newif statements.
+% Has this suddenly become \outer again?
+%
+% Known bugs:
+% - excludecomment leads to one superfluous space
+% - processcomment leads to a superfluous line break
+%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\def\makeinnocent#1{\catcode`#1=12 }
+\def\csarg#1#2{\expandafter#1\csname#2\endcsname}
+\def\latexname{lplain}\def\latexename{LaTeX2e}
+\newwrite\CommentStream
+\def\CommentCutFile{comment.cut}
+
+\def\ProcessComment#1% start it all of
+ {\begingroup
+ \def\CurrentComment{#1}%
+ \let\do\makeinnocent \dospecials
+ \makeinnocent\^^L% and whatever other special cases
+ \endlinechar`\^^M \catcode`\^^M=12 \xComment}
+%\def\ProcessCommentWithArg#1#2% to be used in \leveledcomment
+% {\begingroup
+% \def\CurrentComment{#1}%
+% \let\do\makeinnocent \dospecials
+% \makeinnocent\^^L% and whatever other special cases
+% \endlinechar`\^^M \catcode`\^^M=12 \xComment}
+{\catcode`\^^M=12 \endlinechar=-1 %
+ \gdef\xComment#1^^M{%
+ \expandafter\ProcessCommentLine}
+ \gdef\ProcessCommentLine#1^^M{\def\test{#1}
+ \csarg\ifx{End\CurrentComment Test}\test
+ \edef\next{\noexpand\EndOfComment{\CurrentComment}}%
+ \else \ThisComment{#1}\let\next\ProcessCommentLine
+ \fi \next}
+}
+
+\def\CSstringmeaning#1{\expandafter\CSgobblearrow\meaning#1}
+\def\CSstringcsnoescape#1{\expandafter\CSgobbleescape\string#1}
+{\escapechar-1
+\expandafter\expandafter\expandafter\gdef
+ \expandafter\expandafter\expandafter\CSgobblearrow
+ \expandafter\string\csname macro:->\endcsname{}
+}
+\def\CSgobbleescape#1{\ifnum`\\=`#1 \else #1\fi}
+\def\WriteCommentLine#1{\def\CStmp{#1}%
+ \immediate\write\CommentStream{\CSstringmeaning\CStmp}}
+
+% 3.1 change: in LaTeX and LaTeX2e prevent grouping
+\if 0%
+\ifx\fmtname\latexename
+ 0%
+\else \ifx\fmtname\latexname
+ 0%
+ \else
+ 1%
+\fi \fi
+%%%%
+%%%% definitions for LaTeX
+%%%%
+\def\AfterIncludedComment
+ {\immediate\closeout\CommentStream
+ \input{\CommentCutFile}\relax
+ }%
+\def\TossComment{\immediate\closeout\CommentStream}
+\def\BeforeIncludedComment
+ {\immediate\openout\CommentStream=\CommentCutFile
+ \let\ThisComment\WriteCommentLine}
+\def\includecomment
+ #1{\message{Include comment '#1'}%
+ \csarg\let{After#1Comment}\AfterIncludedComment
+ \csarg\def{#1}{\BeforeIncludedComment
+ \ProcessComment{#1}}%
+ \CommentEndDef{#1}}
+\long\def\specialcomment
+ #1#2#3{\message{Special comment '#1'}%
+ % note: \AfterIncludedComment does \input, so #2 goes here!
+ \csarg\def{After#1Comment}{#2\AfterIncludedComment#3}%
+ \csarg\def{#1}{\BeforeIncludedComment\relax
+ \ProcessComment{#1}}%
+ \CommentEndDef{#1}}
+\long\def\processcomment
+ #1#2#3#4{\message{Lines-Processing comment '#1'}%
+ \csarg\def{After#1Comment}{#3\AfterIncludedComment#4}%
+ \csarg\def{#1}{\BeforeIncludedComment#2\relax
+ \ProcessComment{#1}}%
+ \CommentEndDef{#1}}
+\def\leveledcomment
+ #1#2{\message{Include comment '#1' up to level '#2'}%
+ %\csname #1IsLeveledCommenttrue\endcsname
+ \csarg\let{After#1Comment}\AfterIncludedComment
+ \csarg\def{#1}{\BeforeIncludedComment
+ \ProcessCommentWithArg{#1}}%
+ \CommentEndDef{#1}}
+\else
+%%%%
+%%%%plain TeX and other formats
+%%%%
+\def\includecomment
+ #1{\message{Including comment '#1'}%
+ \csarg\def{#1}{}%
+ \csarg\def{end#1}{}}
+\long\def\specialcomment
+ #1#2#3{\message{Special comment '#1'}%
+ \csarg\def{#1}{\def\ThisComment{}\def\AfterComment{#3}#2%
+ \ProcessComment{#1}}%
+ \CommentEndDef{#1}}
+\fi
+
+%%%%
+%%%% general definition of skipped comment
+%%%%
+\def\excludecomment
+ #1{\message{Excluding comment '#1'}%
+ \csarg\def{#1}{\let\AfterComment\relax
+ \def\ThisComment####1{}\ProcessComment{#1}}%
+ \csarg\let{After#1Comment}\TossComment
+ \CommentEndDef{#1}}
+
+\if 0%
+\ifx\fmtname\latexename
+ 0%
+\else \ifx\fmtname\latexname
+ 0%
+ \else
+ 1%
+\fi \fi
+% latex & latex2e:
+\def\EndOfComment#1{\endgroup\end{#1}%
+ \csname After#1Comment\endcsname}
+\def\CommentEndDef#1{{\escapechar=-1\relax
+ \csarg\xdef{End#1Test}{\string\\end\string\{#1\string\}}%
+ }}
+\else
+% plain & other
+\def\EndOfComment#1{\endgroup\AfterComment}
+\def\CommentEndDef#1{{\escapechar=-1\relax
+ \csarg\xdef{End#1Test}{\string\\end#1}%
+ }}
+\fi
+
+\excludecomment{comment}
+
+\endinput
--- /dev/null
+\documentclass{article}
+\usepackage{hevea}
+
+\def\t#1{{\tt #1}}
+\def\DYNAMIC{\t{DYNAMIC}}
+\title{Setting Up CVS and SSH}
+\author{Scott McPeak \and George Necula}
+
+\def\cvshost{manju}
+
+\begin{document}
+\maketitle
+
+ This document is intended to get you started with the tools that are
+necessary for checking out stuff out of the \cvshost{} CVS repository. These
+instructions work on Linux and Windows (NT4.0, 2000, XP and also less reliably
+on 95/98/Me).
+
+\section{If you want to use Windows}
+
+ \subsection{Get \t{cygwin}}
+
+ You must have a bunch of Unix tools installed on your machine. (In the future
+we might be able to avoid these but for now you are better off with them.).
+Here is what I (George) do to install Cygwin. You need a good network
+connection for this.
+\begin{itemize}
+\item Create a directory \t{C:\backslash Download\backslash cygwin}
+\item Go to \ahrefurl{http://sources.redhat.com/cygwin} and click \t{Install
+cygwin} icon. Download \t{setup.exe} to the directory you just created.
+\item Run \t{setup.exe} and select ``Download to local directory''. Select all
+the packages. It is especially important to select all packages under
+``Devel'' category. If you want to use OCaml for other projects as well, I
+also suggest that you select the XFree86-bin, XFree86-lib and XFree86-prog as
+well. This will take a while (~ 30 minutes)
+\item Run \t{setup.exe} again and now select to ``Install from local
+directory''. It is best to {\bf deselect} the \t{tetex} package since I found
+it to interfere with other installations of Latex.
+\item I choose \t{C:\backslash Programs\backslash cygwin}
+as the home for \t{cygwin}, I use \t{DOS} as the default text file and I
+choose ``Install for All''.
+\item Add \t{C:\backslash Programs\backslash cygwin\backslash bin} to your
+PATH. You must put it in the ``System Variables'' PATH (In Control Panel/System/Advanced/Environment
+Variables'' and {\bf put it first} so that it comes before the default
+c:/WinNT/system32. You can verify that you got it right if you get
+\t{/usr/bin/find} when you run \t{which find}.
+\end{itemize}
+
+
+ If you get a compilation error in file ``cltkImg.c'' while you compile Ocaml
+v 3.06, then you should patch the Ocaml sources as explained at
+\ahrefurl{http://groups.google.com/groups?selm=fa.i2v96ov.1p7cmbc\%40ifi.uio.no}
+(It is easy).
+
+ \subsection{Customize \t{ssh}}\label{sec-win-ssh}
+
+ Set the environment variable \t{HOME} to point to your home directory. I use
+ \t{C:\backslash Necula}.
+
+ For some strange reason \t{ssh} does not see this \t{HOME} variable and
+insists on looking at \t{/home/necula} instead. So I create a link as follows:
+\begin{verbatim}
+bash
+cd /
+mkdir home
+ln -s /cygdrive/c/Necula /home/necula
+\end{verbatim}
+
+\section{Configure CVS}
+
+ \subsection{\t{.cvsrc}}
+
+ Create a \home{/.cvsrc} file with two lines in it:
+\begin{verbatim}
+cvs -q
+update -d
+\end{verbatim}
+
+ \subsection{\t{.ssh/config}}
+
+ Create a \home{/.ssh/config} file with this line in it:
+\begin{verbatim}
+ForwardX11 yes
+\end{verbatim}
+
+ If the \t{DISPLAY} environment variable is set when you invoke \t{ssh} (e.g.
+to \t{localhost:0.0} then \t{ssh} will do automatic X11 forwarding for you.
+This is not useful for the use of \t{ssh} with \t{cvs} but when you want to do
+remote login.
+
+ \subsection{Using CVS with \t{ssh}}
+
+ Note: these instructions appear to work even on Windows with the \t{ssh} and
+\t{cvs} that ships with \t{cygwin} (provided that you have installed
+\t{cygwin} and \t{ssh} as discussed in Section~\ref{sec-win-ssh}).
+
+ Set the environment variable \t{CVS\_RSH} to \t{ssh}.
+
+ Now you can use cvs with ssh but you will have to type the remote password
+ everytime you run cvs.
+
+ If you want to be able to use \t{ssh} without typing a password everytime
+here is what you can do. These instructions are for the case when you use one
+of the newer versions of SSH that support the protocol 2.
+
+\begin{enumerate}
+ \item If you have a DSA private key that is already authorized on
+ the server, copy it to \t{\home{}/.ssh/id\_dsa} and you
+ should be done.
+ \item Otherwise
+ \begin{enumerate}
+ \item Run \t{ssh-keygen -t dsa} to create a private key.
+ Choose a passphrase and remember it.
+ If you do not have a passphrase then anybody who gets
+ access to your machine will also be able to log in to the server. This
+ step should create the files \t{id\_dsa.pub} and \t{id\_dsa} in your
+ \t{\home{}/.ssh} directory.
+ \item Copy the public key to the server (say \cvshost.cs.berkeley.edu).
+ Make sure you append the key to {\bf authorized\_keys2}, not to {\bf
+ authorized\_keys}.
+ \begin{verbatim}
+ cd ~
+ scp .ssh/id_dsa.pub manju:~/.ssh/newpublicid
+ ssh manju
+ cd .ssh
+ cat newpublicid >> authorized_keys2
+ rm newpublicid
+ \end{verbatim}
+ \end{enumerate}
+\end{enumerate}
+
+
+ If you want you can even start an agent to do the authentication for
+you. The steps are different for Linux or Windows:
+ \begin{itemize}
+ \item On Linux or on Windows if you work from within \t{bash} you can run
+ \begin{verbatim}
+ eval `ssh-agent`
+ ssh-add
+ \end{verbatim}
+
+ The first step starts the agent and the second on loads your identity
+ in the agent. In this latter step you will be asked to enter your
+ passphrase.
+ \item At the Windows command prompt (\t{cmd.exe}) you cannot just run
+ those commands. Instead you have to download
+ \ahref{http://raw.cs.berkeley.edu/winssh-agent.cmd}{this batch file
+ ({\bf do not execute it})},
+ put it somewhere in your path and then run it instead of the above
+ sequence of commands.
+ \end{itemize}
+
+\section{Using CVS}
+
+ You should read the rest only if you have not used CVS before.
+
+ CVS is used to synchronize changes to the project across multiple
+developers. See the CVS website for detailed information
+
+ \ahrefurl{http://www.cvshome.org/}
+
+There are a few common commands you'll need. Each of these is to be run
+in the base 'cil' directory (the one with 'regrtest'):
+
+\begin{itemize}
+\item \t{cvs [-n] update -d [filename]}
+
+ This retrieves any changes recently committed by others. This is
+ usually necessary before you can commit your own changes. It is a
+ good idea to run the fast regression test ('regrtest') before and
+ after doing "cvs update" so you can know whether it was you or the
+ update which broke something.
+
+ The optional -n flag tells CVS to not actually change any of your
+ files. This is useful for querying the status of the repository.
+
+ The -d argument tells cvs to create on your machine any new directories
+ that somebody might have checked in. By default cvs does not create new
+ directories. This flag is so useful that many people find it useful to
+ create a \home{/.cvsrc} file with one line containing "update -d" in it.
+ This way you don't have to specify the flag all the time.
+
+ If you specify a filename (after cd'ing to the directory containing it),
+ only that file will be updated, otherwise everything in the current
+ directory and below is updated. Run this in the top-level project
+ directory to update the entire project. A useful idiom for undoing all of
+ your changes is "cd dir; rm file; cvs update file".
+
+
+\item \t{cvs commit [filename]}
+
+ This pushes your changes into the repository, so that the next time
+ someone does "cvs update" they will get your changes. Please try to
+ only commit when the regression test script passes.
+
+ If you specify a filename, only that file will be committed, otherwise
+ everything in the current directory and below is checked in. Run this in
+ the top-level project directory to check all of your changes in.
+
+\item \t{cvs add filename}
+
+ This adds a new file to the repository. It isn't visible in the
+ repository until you do a commit.
+\end{itemize}
+
+
+\section{Useful Links}
+\begin{itemize}
+ \item Tutorial on ML:
+ \item Documentation and sources for CVS:
+ \ahrefurl{http://www.cvshome.org/}
+
+ \end{itemize}
+
+\end{document}
+
--- /dev/null
+% This is FULLPAGE.STY by H.Partl, Version 2 as of 15 Dec 1988.
+% Document Style Option to fill the paper just like Plain TeX.
+
+\typeout{Style Option FULLPAGE Version 2 as of 15 Dec 1988}
+
+\topmargin 0pt
+\advance \topmargin by -\headheight
+\advance \topmargin by -\headsep
+
+\textheight 8.9in
+
+\oddsidemargin 0pt
+\evensidemargin \oddsidemargin
+\marginparwidth 0.5in
+
+\textwidth 6.5in
+
+
+% For users of A4 paper: The above values are suited for american 8.5x11in
+% paper. If your output driver performs a conversion for A4 paper, keep
+% those values. If your output driver conforms to the TeX standard (1in/1in),
+% then you should add the following commands to center the text on A4 paper:
+
+% \advance\hoffset by -3mm % A4 is narrower.
+% \advance\voffset by 8mm % A4 is taller.
+
+\endinput
+
+
--- /dev/null
+<html>
+
+<head>
+<meta http-equiv="Content-Language" content="en-us">
+<meta name="GENERATOR" content="Microsoft FrontPage 5.0">
+<meta name="ProgId" content="FrontPage.Editor.Document">
+<meta http-equiv="Content-Type" content="text/html; charset=windows-1252">
+<title>CIL Documentation (v. @CIL_VERSION@)</title>
+<base target="contents">
+</head>
+
+<body>
+
+<h1 align="center">CIL - Infrastructure for C Program Analysis and Transformation (v. @CIL_VERSION@)</h1>
+
+</body>
+
+</html>
--- /dev/null
+% hevea : hevea.sty
+% This is a very basic style file for latex document to be processed
+% with hevea. It contains definitions of LaTeX environment which are
+% processed in a special way by the translator.
+% Mostly :
+% - latexonly, not processed by hevea, processed by latex.
+% - htmlonly , the reverse.
+% - rawhtml, to include raw HTML in hevea output.
+% - toimage, to send text to the image file.
+% The package also provides hevea logos, html related commands (ahref
+% etc.), void cutting and image commands.
+\NeedsTeXFormat{LaTeX2e}
+\ProvidesPackage{hevea}[1999/08/11]
+\RequirePackage{comment}
+\newif\ifhevea\heveafalse
+\makeatletter%
+\newcommand{\heveasmup}[2]{%
+\raise #1\hbox{$\m@th$%
+ \csname S@\f@size\endcsname
+ \fontsize\sf@size 0%
+ \math@fontsfalse\selectfont
+#2%
+}}%
+\DeclareRobustCommand{\hevea}{H\kern-.15em\heveasmup{.2ex}{E}\kern-.15emV\kern-.15em\heveasmup{.2ex}{E}\kern-.15emA}%
+\DeclareRobustCommand{\hacha}{H\kern-.15em\heveasmup{.2ex}{A}\kern-.15emC\kern-.1em\heveasmup{.2ex}{H}\kern-.15emA}%
+\DeclareRobustCommand{\html}{\protect\heveasmup{0.ex}{HTML}}
+%%%%%%%%% Hyperlinks hevea style
+\newcommand{\ahref}[2]{{#2}}
+\newcommand{\ahrefloc}[2]{{#2}}
+\newcommand{\aname}[2]{{#2}}
+\newcommand{\ahrefurl}[1]{\texttt{#1}}
+\newcommand{\footahref}[2]{#2\footnote{\texttt{#1}}}
+\newcommand{\mailto}[1]{\texttt{#1}}
+\newcommand{\imgsrc}[2][]{}
+\newcommand{\home}[1]{\protect\raisebox{-.75ex}{\char126}#1}
+\AtBeginDocument
+{\@ifundefined{url}
+{%url package is not loaded
+\let\url\ahref\let\oneurl\ahrefurl\let\footurl\footahref}
+{}}
+%% Void cutting instructions
+\newcounter{cuttingdepth}
+\newcommand{\cuttingunit}{}
+\newcommand{\cutdef}[2][]{}
+\newcommand{\cuthere}[2]{}
+\newcommand{\cutend}{}
+\newcommand{\htmlhead}[1]{}
+\newcommand{\htmlfoot}[1]{}
+\newenvironment{cutflow}[1]{}{}
+\newcommand{\cutname}[1]{}
+%% TeX \let and \def inside HeVeA
+\let\texlet\let
+\let\texdef\def
+%%%% Html only
+\excludecomment{rawhtml}
+\excludecomment{htmlonly}
+%%%% Latex only
+\newenvironment{latexonly}{}{}
+\newenvironment{verblatex}{}{}
+%%%% Image file stuff
+\def\toimage{\endgroup}
+\def\endtoimage{\begingroup\def\@currenvir{toimage}}
+\def\verbimage{\endgroup}
+\def\endverbimage{\begingroup\def\@currenvir{verbimage}}
+\newcommand{\imageflush}[1][]{}
+\makeatother
--- /dev/null
+<html>
+
+<head>
+<meta name="GENERATOR" content="Microsoft FrontPage 5.0">
+<meta name="ProgId" content="FrontPage.Editor.Document">
+<base target="main">
+<title>CIL Documentation (v. @CIL_VERSION@)</title>
+</head>
+
+<frameset rows="64,*">
+ <frame name="banner" scrolling="auto" noresize target="contents"
+ src="header.html">
+ <frameset cols="267,*">
+ <frame name="contents" target="main" src="ciltoc.html" scrolling="auto">
+ <frame name="main" src="cil001.html" scrolling="auto">
+ </frameset>
+ <noframes>
+ <body>
+
+ <p>This page uses frames, but your browser doesn't support them.</p>
+
+ </body>
+ </noframes>
+</frameset>
+
+</html>
\ No newline at end of file
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<html>
+ <head>
+ <title></title>
+ <meta name="GENERATOR" content="Microsoft Visual Studio .NET 7.1">
+ <meta name="vs_targetSchema" content="http://schemas.microsoft.com/intellisense/ie5">
+ </head>
+ <body>
+ <H2 align="center">CIL (C Intermediate Language)
+ </H2>
+ <P><FONT face="Arial">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. For example, in CIL all
+ looping constructs are given a single form and expressions have no
+ side-effects. This reduces the number of cases that must be considered when
+ manipulating a C program. CIL has been used for a variety of projects,
+ including CCured, a tool that makes C programs memory safe.</FONT></P>
+ <P><FONT face="Arial">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. More information can be found <A href="http://manju.cs.berkeley.edu/cil">
+ here</A>.</FONT></P>
+ <P><FONT face="Arial"></FONT> </P>
+ <P><FONT face="Arial">About CIL:</FONT></P>
+ <UL>
+ <LI>
+ <FONT face="Arial"><A href="https://sourceforge.net/projects/cil/">SourceForge page</A></FONT></LI>
+ <UL>
+ <LI>
+ <FONT face="Arial"><A href="http://lists.sourceforge.net/lists/listinfo/cil-users">Mailing list</A></FONT></LI>
+ <LI>
+ <FONT face="Arial"><A href="https://sourceforge.net/tracker/?group_id=138953&atid=742140">
+ Bug database / feature requests</A>.</FONT></LI></UL>
+ <LI>
+ <FONT face="Arial"><A href="http://manju.cs.berkeley.edu/cil">Documentation</A></FONT></LI>
+ <LI>
+ <FONT face="Arial"><A href="http://manju.cs.berkeley.edu/cil/distrib/cil-latest.tar.gz">
+ Download</A></FONT></LI></UL>
+ <P> </P>
+ </body>
+</html>
--- /dev/null
+Cil Makefile Structure
+----------------------
+
+(Originally written by Scott, updated 11/19/01.)
+
+The build rules are spread out among several Makefiles:
+
+ Makefile - toplevel driver Makefile, interprets a variety
+ of command-line arguments (e.g. INFERBOX=infer),
+ and has rules for all the tests/benchmarks
+
+ Makefile.gcc - definitions of make variables that specify the syntax
+ of invoking gcc; for example, it has "INC := -I",
+ meaning -I is the option to name include directories
+
+ Makefile.msvc - similar to above, but for MS's "cl.exe" command-line
+ compiler (e.g. "INC := /I")
+
+ Makefile.ccured - rules for building the 'ccured' program and runtime
+ library
+
+ Makefile.ocaml - generic Makefile for OCaml projects; includes targets
+ to compile and link ML sources into bytecode or
+ native code
+
+ Makefile.combiner - rules for making the 'combiner' program
+
+ Makefile.cil - rules for making the 'cilly' program
+
+
+------------- Makefile -----------
+Typical usage is to run only the toplevel Makefile, but specify options
+on the command line saying what to do. For example:
+
+ make - build the bytecode 'ccured' and debug library
+
+Some of the more important command-line options:
+
+ NATIVECAML=1 - build native code 'ccured'
+ RELEASELIB=1 - build non-debug library
+ OPTIM=1 - enable ccured's built-in optimizer module
+ RELEASE=1 - native code, non-debug, optimizer enabled, etc.
+ NOGC=1 - disable the garbage collector (use malloc/free)
+ NOLINES=1 - disable #line directives in output
+ COMMLINES=1 - print #line, but only as comments
+ TRACE=flag1,.. - enable various debug output flags
+ LOGCALLS=1 - transform code to print at every function entry
+ LOGSTYLE=n - style for LOGCALLS; see Makefile for n's meaning
+ INFERBOX=infer - turn on full ccured transformation; without this,
+ it just transforms to Cil and outputs uninstrumented
+
+so for example "make RELEASE=1" will build release versions of things.
+Some other targets of interest:
+
+ make clean - remove compilation byproducts, including executables
+ make odoc - make OCamlDoc documentation .html files
+ make setup - build *both* bytecode/native, debug/non-debug
+
+For convenience, we've put targets into the Makefile for various test
+programs and benchmarks we use. For example:
+
+ make go INFERBOX=infer - build spec95 "go" benchmark in ccured mode
+ make power - build Olden "power" benchmark in cil-only mode
+
+The line "below here are rules for building benchmarks" separates the
+benchmark targets.
+
+
+------------- Makefile.ccured -----------
+This file does three jobs:
+ - supplies parameters to Makefile.ocaml that let it build the
+ 'ccured' executable, which transforms C code to add runtime checks
+ - says how to build the CCured runtime library
+ - produce patched versions of some system #include files
+
+Among the info to build 'ccured', the most important is the "MODULES"
+line, which says what are the ML modules which comprise this program.
+
+Note that order is *very* important: the OCaml linker wants to see
+*no* forward references, so the modules admit a total order on
+dependencies. (If modules A and B call each other, you can list A
+first, and let B have an exported function reference which module A then
+sets to point at one of A's functions. Ugly, I know.)
+
+Some of the configuration rules from Makefile are repeated in
+Makefile.ocaml. This is unfortunate..
+
+The runtime library contains wrappers for C library calls, and the
+Boehm-Weiser conservative garbage collector.
+
+The library's name is dependent on (1) which compiler you're using,
+(2) whether it's being build in debug mode or not, and (3) what the
+extension for libraries is on the current platform. For
+gcc/debug/linux, it's obj/ccured_GNUCC_debug.a.
+
+The garbage collector is built essentially independently, yielding
+its "gc.a" library. The CCured modules are then added to this.
+
+
+-------------- Makefile.ocaml ------------
+This makefile is a generic OCaml build system. You tell it the names
+of the modules to build, and it compiles and links them. A major
+choice is whether to build bytecode or native code, determined by
+whether NATIVECAML is defined.
+
+The rules themselves are complicated because this makefile works
+hard to allow the source files (.ml, etc.) to live in a different
+directory than the compiled object files (.cmo, etc.).
+
+If you want to see the details of the build process, set the variable
+ECHOSTYLE_SCOTT (in your .ccuredrc, for example). This will print
+every command executed which has a side effect. Without this you'll
+just see English descriptions of what's happening.
+
+
+------------- stylistic conventions ----------
+For the most part, we try to use ":=" instead of "=". Basically, ":="
+evaluates its right-hand-side the moment it's parsed, whereas the
+RHS of "=" is evaluated every time the variable is referenced. We
+find it's easier to predict how ":=" will behave, so unless the delayed
+evaluation of "=" is really desired, use ":=".
+
+Please indent the bodies of "ifdef..endif". This works fine, and
+makes the files much easier to read. (I'm not going to explore here
+the theology behind how *much* to indent...)
+
+
+-------------- references --------------
+Main Cil docs:
+ http://raw.cs.berkeley.edu/ccured/cil/index.html
+
+GNU Make manual:
+ http://www.gnu.org/manual/make/html_chapter/make_toc.html
+
+"Recursive Make Considered Harmful", an interesting and informative
+article about how to use and misuse make:
+ http://www.tip.net.au/~millerp/rmch/recu-make-cons-harm.html
+
--- /dev/null
+<html>
+<head>
+ <title>How to build the ocamldoc tool</title>
+</head>
+
+<body>
+<h2>How to build the ocamldoc tool</h2>
+
+<p><a href="http://pauillac.inria.fr/~guesdon/tools.html">ocamldoc</a>
+is a tool for extracting documentation from specially-formatted
+comments in the source code. It works similarly to
+<a href="http://java.sun.com/j2se/javadoc/index.html">javadoc</a>.
+The following instructions explain how to get, build, and use this tool,
+especially in the context of the CCured project.</p>
+
+<p>For the purposes of these instructions, pick some directories:</p>
+<ul><li><tt>$DIST</tt>: directory where you'll download the tarballs
+ (e.g. <tt>/home/scott/dist</tt>)
+ <li><tt>$BLD</tt>: directory where you'll compile the software
+ (e.g. <tt>/home/scott/bld</tt>)
+ <li><tt>$PREFIX</tt>: directory into which the compiled files will be installed
+ (e.g. <tt>/home/scott/lib/ocaml-current</tt> or <tt>/usr/local</tt>)
+ <li><tt>$CIL</tt>: toplevel directory of ccured ("cil") repository
+ (e.g. <tt>/home/scott/wrk/safec/cil</tt>)
+</ul>
+
+<p>First, download and build the latest <a href="http://www.cvshome.org/docs/manual/cvs.html">
+CVS</a> snapshot of the <a href="http://caml.inria.fr/ocaml/">OCaml</a> compiler:
+<pre>
+ % cd $BLD
+ % cvs -d :pserver:anoncvs@camlcvs.inria.fr:/caml checkout ocaml
+ % cd ocaml
+ % ./configure --prefix $PREFIX
+ % make world
+ % make opt
+ % make ocamlc.opt # ocamldoc wants this?
+ % make install
+</pre></p>
+
+<p>Next, download the <a href="http://pauillac.inria.fr/~guesdon/Tars/ocamldoc_08_10_2001.tar.gz">
+ocamldoc distribution tarball</a>, and build it:
+<pre>
+ % cd $BLD
+ % tar xvfz $DIST/ocamldoc_08_10_2001.tar.gz
+ % cd ocamldoc
+ % ln -s $BLD/ocaml ocaml
+ % patch -p1 < $CIL/doc/ocamldoc.patch # fix configure.in
+ % PATH=$PREFIX/bin:$PATH # for sh/bash
+ or
+ % set path = ($PREFIX/bin $path) # for csh/tcsh
+ % autoconf
+ % ./configure # inherits --prefix from above
+ % make depend
+ % make all
+ (fails with complaint about either missing .cmx (if ocamlc.opt not built)
+ or "inconsistent assumptions over implementation Odoc_misc", but this
+ doesn't matter since it makes 'odoc' successfully)
+ % make install
+ (succeeds in copying 'odoc' to $PREFIX/bin, but fails to copy odoc_info.cma; ignoring)
+</pre>
+The resulting <tt>odoc</tt> binary can be copied anywhere and used. However,
+it contains within it the path to the 'ocamlrun' binary in $PREFIX/bin, so
+that has to stay put. Building <tt>odoc.opt</tt> unfortunately fails.</p>
+
+<p>(optional) Staying in <tt>$BLD/ocamldoc</tt>, we can have it
+generate a few sample documentation files:
+<pre>
+ % make doctest # build docs of ocamldoc sources -> doctest/
+ % make stdlib # build docs of ocaml library sources -> stdlib/
+ (appears to fail with "Unbound module Support", but actually succeeds)
+</pre></p>
+
+
+<p>Finally, we can use this to generate documentation for the CCured sources:
+<pre>
+ % cd $CIL
+ % make # need the .cmi files built
+ % make odoc
+</pre>
+This will dump a bunch of .html files into the odoc/ directory. It also may spew
+some messages about errors parsing text inside comments; those messages are
+nonfatal but should be addressed.</p>
+
+<hr>
+<p>Originally written by <a href="mailto:smcpeak@cs.berkeley.edu">Scott</a>.
+
+</body>
+</html>
--- /dev/null
+diff -cb ocamldoc-orig/configure.in ocamldoc/configure.in
+*** ocamldoc-orig/configure.in Fri Oct 5 13:15:45 2001
+--- ocamldoc/configure.in Sat Oct 20 13:04:20 2001
+***************
+*** 44,50 ****
+ else
+ AC_MSG_CHECKING(ocamlopt version)
+ TMPVERSION=`$OCAMLOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+! if test "$TMPVERSION" != $OCAMLVERSION ; then
+ AC_MSG_RESULT(differs from ocamlc; ocamlopt discarded.)
+ OCAMLOPT=no
+ else
+--- 44,50 ----
+ else
+ AC_MSG_CHECKING(ocamlopt version)
+ TMPVERSION=`$OCAMLOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+! if test "$TMPVERSION" != "$OCAMLVERSION" ; then
+ AC_MSG_RESULT(differs from ocamlc; ocamlopt discarded.)
+ OCAMLOPT=no
+ else
+***************
+*** 58,64 ****
+ if test "$OCAMLCDOTOPT" != no ; then
+ AC_MSG_CHECKING(ocamlc.opt version)
+ TMPVERSION=`$OCAMLCDOTOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+! if test "$TMPVERSION" != $OCAMLVERSION ; then
+ AC_MSG_RESULT(differs from ocamlc; ocamlc.opt discarded.)
+ else
+ AC_MSG_RESULT(ok)
+--- 58,64 ----
+ if test "$OCAMLCDOTOPT" != no ; then
+ AC_MSG_CHECKING(ocamlc.opt version)
+ TMPVERSION=`$OCAMLCDOTOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+! if test "$TMPVERSION" != "$OCAMLVERSION" ; then
+ AC_MSG_RESULT(differs from ocamlc; ocamlc.opt discarded.)
+ else
+ AC_MSG_RESULT(ok)
+***************
+*** 72,78 ****
+ if test "$OCAMLOPTDOTOPT" != no ; then
+ AC_MSG_CHECKING(ocamlc.opt version)
+ TMPVER=`$OCAMLOPTDOTOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+! if test "$TMPVER" != $OCAMLVERSION ; then
+ AC_MSG_RESULT(differs from ocamlc; ocamlopt.opt discarded.)
+ else
+ AC_MSG_RESULT(ok)
+--- 72,78 ----
+ if test "$OCAMLOPTDOTOPT" != no ; then
+ AC_MSG_CHECKING(ocamlc.opt version)
+ TMPVER=`$OCAMLOPTDOTOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+! if test "$TMPVER" != "$OCAMLVERSION" ; then
+ AC_MSG_RESULT(differs from ocamlc; ocamlopt.opt discarded.)
+ else
+ AC_MSG_RESULT(ok)
+diff -cb ocamldoc-orig/odoc_html.ml ocamldoc/odoc_html.ml
+*** ocamldoc-orig/odoc_html.ml Mon Oct 8 08:32:51 2001
+--- ocamldoc/odoc_html.ml Sun Oct 21 01:11:24 2001
+***************
+*** 218,223 ****
+--- 218,237 ----
+ val mutable constructor_color = "SlateBlue"
+
+
++ (* sm: utility to get toplevel title string *)
++ method topTitle () : string = (
++ match !Odoc_args.title with
++ None -> ""
++ | Some t -> Text.escape t
++ )
++
++ (* sm: title of something below the toplevel *)
++ method innerTitle (s:string) : string = (
++ match !Odoc_args.title with
++ None -> s
++ | Some t -> (Text.escape t) ^ ": " ^ s
++ )
++
+ (** Return html code with the given string in the keyword color.*)
+ method keyword s = "<FONT COLOR=\""^keyword_color^"\">"^s^"</FONT>"
+
+***************
+*** 967,972 ****
+--- 981,987 ----
+ style^
+ "<HEAD>\n"^
+ "<TITLE>\n"^
++ (self#innerTitle cl.cl_name)^
+ "</TITLE>\n"^
+ "</HEAD>\n"^
+ "<BODY BGCOLOR=\"white\">\n"^
+***************
+*** 1010,1015 ****
+--- 1025,1031 ----
+ style^
+ "<HEAD>\n"^
+ "<TITLE>\n"^
++ (self#innerTitle clt.clt_name)^
+ "</TITLE>\n"^
+ "</HEAD>\n"^
+ "<BODY BGCOLOR=\"white\">\n"^
+***************
+*** 1053,1058 ****
+--- 1069,1075 ----
+ style^
+ "<HEAD>\n"^
+ "<TITLE>\n"^
++ (self#innerTitle mt.mt_name)^
+ "</TITLE>\n"^
+ "</HEAD>\n"^
+ "<BODY BGCOLOR=\"white\">\n"^
+***************
+*** 1132,1137 ****
+--- 1149,1155 ----
+ style^
+ "<HEAD>\n"^
+ "<TITLE>\n"^
++ (self#innerTitle modu.m_name)^
+ "</TITLE>\n"^
+ "</HEAD>\n"^
+ "<BODY BGCOLOR=\"white\">\n"^
+***************
+*** 1204,1214 ****
+ method generate_index module_list =
+ try
+ let chanout = open_out (Filename.concat !Odoc_args.target_dir "index.html") in
+! let t =
+! match !Odoc_args.title with
+! None -> ""
+! | Some t -> Text.escape t
+! in
+ output_string chanout
+ (
+ "<HTML>\n"^
+--- 1222,1228 ----
+ method generate_index module_list =
+ try
+ let chanout = open_out (Filename.concat !Odoc_args.target_dir "index.html") in
+! let t = (self#topTitle ()) in
+ output_string chanout
+ (
+ "<HTML>\n"^
--- /dev/null
+%%
+\NeedsTeXFormat{LaTeX2e}
+\ProvidesPackage{program}
+ [1998/07/30 1.0 Source program environment for LaTeX]
+\RequirePackage{keyval}
+
+%
+% Style for writing programs
+%
+%\begin{program}[number,stretch=1.1]
+% even if you do not have options better put [] (but in Latex's \newcommand)
+% Options:
+% number[=true] - numbers all the lines with \prognumstyle
+% firstline=xxx - sets the first line number
+% numberevery[=1]- put a number every n lines (first is always numbered)
+% box[=true] - puts the whole program in a minipage
+% valign[=t] - the valign to be passed to minipage
+% width=xxx - the width to be passed to minipage
+% style=xxx - the default style of text in env. Can be "math" or "tt"
+% Or, redefine \Programstyle{#1}{#2} so that #1 is the
+% style start and #2 is the style end
+% stretch=xxx - factor to stretch the distance between lines
+%
+% line breaks are verbatim. Put % to prevent a newline
+% !foo! writes foo with \formatname{foo}. Default \tt
+% |bar| writes bar with \formatvariable{bar}. Default \mathit
+% @foo@ writes foo with \formattext. Default \mbox
+% \tab idents future lines here
+% \stab{dim} puts a \tab forward of this location and backs up
+% \qtab = \quad\tab
+% \untab undoes the last undone \tab
+% \rjust{txt} puts txt right justified
+% \rcomment{txt} like \rjust but with \formatcomment{txt}. Default \mbox
+% \lab{txt} puts a label leftjustified with \formatlabel{txt}
+% \labspace{txt} use on first line to create indentation that clears labels
+% \nonumber omits the line number in this line. The line number is not
+% incremented
+% \donumber makes sure a line number is emitted
+% \bumpnumber{5} increments the line number by 5. Visible on current line
+%
+% This environment is built on top of Latex tabbing environment. As such the
+% tabbing commands work here as well. However, some tabbing commands will
+% interfere with the program environment. The command that you can use are:
+% \> advance to the next tab
+%\end{program}
+%
+% Define the options
+%
+% Define a boolean key with a default value if used without =
+\def\Prog@defboolkey#1[#2]{%
+ \expandafter\newif\csname ifProg@#1\endcsname % Define the if
+ \define@key{Prog}{#1}[#2]{\csname Prog@#1##1\endcsname}}
+\def\Prog@defvalkey#1[#2]{%
+ \define@key{Prog}{#1}[#2]{\expandafter\def\csname Prog@#1\endcsname{##1}}}
+\def\Prog@defvalkeynodef#1{%
+ \define@key{Prog}{#1}{\expandafter\def\csname Prog@#1\endcsname{##1}}}
+
+
+\Prog@defboolkey{number}[true] % numbers lines
+\Prog@defboolkey{box}[true] % it puts the program in a parbox
+\Prog@defboolkey{style}[math] % Can be math or tt
+\Prog@defvalkey{valign}[t] % how to align the minipage (if in box)
+\Prog@defvalkey{stretch}[1.0] % Factor to stretch the distance betwee lines
+\Prog@defvalkeynodef{width}
+\Prog@defvalkeynodef{firstline}
+\Prog@defvalkey{numberevery}[1]% Put a line number every n lines.
+
+% Set the defaults
+\setkeys{Prog}{box=true,number=false,firstline=1,numberevery=1,
+ valign=t,style=math,stretch=1.0,width=\z@}
+
+% Set the global defaults
+%
+% User parameters
+%
+\def\ProgramStyle#1#2{\def\ProgramStyleStart{#1}%
+ \def\ProgramStyleEnd{#1}}
+\def\Prog@stylett{\ProgramStyle{\tt}{}}
+\def\Prog@stylemath{\ProgramStyle{$}{$}}
+\Prog@stylemath
+
+% How to print line numbers
+\def\prognumstyle{\scriptsize\em} % The style for printing line nos
+\def\formatkeyword#1{\keepspaceafter{\underbar{\bfseries #1}}}
+\def\formatvariable#1{\keepspaceafter{\mbox{$\mathit{#1}$}}}
+\def\formatcomment#1{\mbox{#1}}
+\def\formattext#1{\keepspaceafter{\mbox{#1}}}
+\def\proglabelskip{1mm}
+\def\formatlabel#1{#1:\hskip\proglabelskip}
+
+\def\formatname#1{\keepspaceafter{\mbox{\ttfamily #1}}}
+
+
+\def\tab{{}\=\+{}}%
+\def\stab#1{\hskip #1\tab\hskip -#1}
+\def\qtab{\quad\tab}%
+\def\untab{{}\-{}}%
+\def\rjust#1{\`#1}
+\def\rcomment#1{\`\formatcomment{#1}}%
+\def\lab#1{\gdef\prog@label{\formatlabel{#1}}}%
+\def\labref#1{\mbox{#1}}
+\def\labspace#1{\phantom{\formatlabel{#1}}}
+
+\def\proglabelwidth{1em}
+
+%%%%%%%%%%%%%%
+\newcounter{programline}
+\newcounter{programlineskip}
+\newcounter{programid}\setcounter{programid}{0}
+ %This is for hyperref to make the line numbers
+ %unique in a document
+\def\theHprogramline{\arabic{programid}.\arabic{programline}}
+
+\let\exclmark=!
+{% Set |...| to print the ... as a variable
+ \catcode`\|=\active\relax
+ \let\prog@bar=|%
+ \gdef|#1|{\formatvariable{#1}}
+% % Set ; to print a thick space after it in math mode
+% \let\prog@semicolon=;
+% \catcode`\;=\active\relax
+% \gdef;{\ifmmode\prog@semicolon\;\else\prog@semicolon\fi}
+ % Set !...! to print the ... as a name
+ \catcode`\!=\active\relax
+ \gdef!#1!{\formatname{#1}}
+ % Set @...@ to print the ... as text
+ \catcode`\@=\active\relax
+ \gdef@#1@{\formattext{#1}}
+}
+ % Define prog@space
+\def\@tmp.{\futurelet\prog@space\relax}\@tmp. \relax
+ % Keep a space after something
+\def\keepspaceafter#1{\def\@tmp{#1}%
+ \futurelet\@next\@keepspaceafteri}
+\def\@keepspaceafteri{\ifx\@next\prog@space
+ \def\@tmpi{\@tmp\ }%
+ \else
+ \def\@tmpi{\@tmp}\fi
+ \@tmpi}
+
+
+
+%
+% The next few macros override macros from the Latex tabbing environment
+%
+\def\prog@numberthisline{1}% Default is line numbering
+\def\prog@nonumber{\gdef\prog@numberthisline{0}}
+\def\prog@donumber{\gdef\prog@numberthisline{1}}
+\def\prog@bumpnumber#1{\addtocounter{programline}{#1}}
+
+\def\prog@startline{%
+ \ifProg@number
+ \refstepcounter{programline}% Increment the program line before each line
+ \fi
+ \prog@origstartline}
+
+\def\prog@printlineno{\ifProg@number
+ \hskip\proglabelwidth
+ \ifnum\prog@numberthisline=1\relax
+ \ifnum\theprogramlineskip=0\relax
+ \llap{\prognumstyle\theprogramline}%
+ \setcounter{programlineskip}{\Prog@numberevery}%
+ \fi
+ \addtocounter{programlineskip}{-1}%
+ \else
+ \addtocounter{programline}{-1}%
+ \prog@donumber
+ \fi
+ \fi
+ \hskip\labelsep
+ % Now put the current label
+ \ifx\prog@label\empty \else
+ \setbox\z@\hbox{\prog@label}%
+ \copy\z@ \hskip -\wd\z@
+ \global\let\prog@label=\empty
+ \fi
+ }
+
+\def\prog@startfield{%
+ \prog@origstartfield
+ \ProgramStyleStart}
+
+\def\prog@stopfield{%
+ \ProgramStyleEnd
+ \prog@origstopfield}
+
+% A new version of @stopline which ignores blank lines (lines with
+% width 0pt) and prints line numbers. To print a blank line, put "\ \\" on it!
+%
+\def\prog@stopline{%
+ \unskip\@stopfield
+ \if@rjfield
+ \global\@rjfieldfalse
+ \@tempdima\@totalleftmargin \advance\@tempdima\linewidth
+ \hbox to\@tempdima{\@itemfudge\prog@printlineno\hskip\dimen\@curtabmar
+ \box\@curline\hfil\box\@curfield}%
+ \else
+ \@addfield
+ \ifdim\wd\@curline=0pt%
+ \ifProg@number \addtocounter{programline}{-1}\fi
+ \else
+ \hbox{\@itemfudge\prog@printlineno\hskip\dimen\@curtabmar\box\@curline}%
+ \fi
+\fi
+}
+
+
+\newcommand\program[1][]{%
+ \stepcounter{programid}%
+ \bgroup % Start a group so that we can undo easily most assignments
+ % Process the optional arguments
+ \def\Prog@width{\z@}%
+ \setkeys{Prog}{#1}%
+ \ifdim\Prog@width=\z@
+ \edef\Prog@width{\the\linewidth}%
+ \fi
+ % Line numbering
+ \ifProg@number
+ \prog@donumber
+ \else
+ \prog@nonumber
+ \fi
+ % Whether in a box
+ \ifProg@box
+ \begin{minipage}[\Prog@valign]{\Prog@width}%
+ \fi
+ % The distance between lines
+ \setbox\strutbox\hbox{%
+ \vrule\@height\Prog@stretch\ht\strutbox
+ \@depth\Prog@stretch\dp\strutbox
+ \@width\z@}%
+ \setcounter{programline}{\Prog@firstline}%
+ \addtocounter{programline}{-1}% Adjust for preincrement
+ \let\prog@label=\empty
+ \let\prog@origbar=|%
+ \catcode`\|=\active\relax
+ \catcode`\!=\active\relax
+ \catcode`\@=\active\relax
+ % Start a tabbing environment with obey lines
+ \let\prog@origstartline=\@startline
+ \let\@startline=\prog@startline
+ \let\@stopline=\prog@stopline
+ \let\prog@origstartfield=\@startfield
+ \let\@startfield=\prog@startfield
+ \let\prog@origstopfield=\@stopfield
+ \let\@stopfield=\prog@stopfield
+ \let\nonumber=\prog@nonumber
+ \let\donumber=\prog@donumber
+ \let\bumpnumber=\prog@bumpnumber
+ \obeycr% All lines after this must end with a comment
+ \tabbing% Everything after this is local to a field
+% \@gobblecr
+}
+
+\def\endprogram{%
+ \endtabbing%
+ \restorecr%
+ \ifProg@box
+ \end{minipage}%
+ \fi
+ \egroup
+}
+
+
+
--- /dev/null
+% proof.sty (Proof Figure Macros)
+%
+% version 3.0 (for both LaTeX 2.09 and LaTeX 2e)
+% Mar 6, 1997
+% Copyright (C) 1990 -- 1997, Makoto Tatsuta (tatsuta@kusm.kyoto-u.ac.jp)
+%
+% This program is free software; you can redistribute it or modify
+% it under the terms of the GNU General Public License as published by
+% the Free Software Foundation; either versions 1, or (at your option)
+% any later version.
+%
+% This program is distributed in the hope that it will be useful
+% but WITHOUT ANY WARRANTY; without even the implied warranty of
+% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+% GNU General Public License for more details.
+%
+% Usage:
+% In \documentstyle, specify an optional style `proof', say,
+% \documentstyle[proof]{article}.
+%
+% The following macros are available:
+%
+% In all the following macros, all the arguments such as
+% <Lowers> and <Uppers> are processed in math mode.
+%
+% \infer<Lower><Uppers>
+% draws an inference.
+%
+% Use & in <Uppers> to delimit upper formulae.
+% <Uppers> consists more than 0 formulae.
+%
+% \infer returns \hbox{ ... } or \vbox{ ... } and
+% sets \@LeftOffset and \@RightOffset globally.
+%
+% \infer[<Label>]<Lower><Uppers>
+% draws an inference labeled with <Label>.
+%
+% \infer*<Lower><Uppers>
+% draws a many step deduction.
+%
+% \infer*[<Label>]<Lower><Uppers>
+% draws a many step deduction labeled with <Label>.
+%
+% \infer=<Lower><Uppers>
+% draws a double-ruled deduction.
+%
+% \infer=[<Label>]<Lower><Uppers>
+% draws a double-ruled deduction labeled with <Label>.
+%
+% \deduce<Lower><Uppers>
+% draws an inference without a rule.
+%
+% \deduce[<Proof>]<Lower><Uppers>
+% draws a many step deduction with a proof name.
+%
+% Example:
+% If you want to write
+% B C
+% -----
+% A D
+% ----------
+% E
+% use
+% \infer{E}{
+% A
+% &
+% \infer{D}{B & C}
+% }
+%
+
+% Add a ``[c]'' after the label and right before the <Lower> to center
+% around the rule
+%
+
+% Style Parameters
+
+\newdimen\inferLineSkip \inferLineSkip=3pt
+\newdimen\inferLabelSkip \inferLabelSkip=5pt
+\def\inferTabSkip{\quad}
+
+% Variables
+
+\newdimen\@LeftOffset % global
+\newdimen\@RightOffset % global
+\newdimen\@SavedLeftOffset % safe from users
+
+\newdimen\UpperWidth
+\newdimen\LowerWidth
+\newdimen\LowerHeight
+\newdimen\UpperLeftOffset
+\newdimen\UpperRightOffset
+\newdimen\UpperCenter
+\newdimen\LowerCenter
+\newdimen\UpperAdjust
+\newdimen\RuleAdjust
+\newdimen\LowerAdjust
+\newdimen\RuleWidth
+\newdimen\HLabelAdjust
+\newdimen\VLabelAdjust
+\newdimen\WidthAdjust
+
+\newbox\@UpperPart
+\newbox\@LowerPart
+\newbox\@LabelPart
+\newbox\ResultBox
+
+% Flags
+
+\newif\if@inferRule % whether \@infer draws a rule.
+\newif\if@DoubleRule % whether \@infer draws doulbe rules.
+\newif\if@ReturnLeftOffset % whether \@infer returns \@LeftOffset.
+\newif\if@MathSaved % whether inner math mode where \infer or
+ % \deduce appears.
+\newif\if@inferCenter % whether to center the rule
+
+% Special Fonts
+
+\def\DeduceSym{\vtop{\baselineskip4\p@ \lineskiplimit\z@
+ \vbox{\hbox{.}\hbox{.}\hbox{.}}\hbox{.}}}
+
+% Math Save Macros
+%
+% \@SaveMath is called in the very begining of toplevel macros
+% which are \infer and \deduce.
+% \@RestoreMath is called in the very last before toplevel macros end.
+% Remark \infer and \deduce ends calling \@infer.
+
+\def\@SaveMath{\@MathSavedfalse \ifmmode \ifinner
+ \relax $\relax \@MathSavedtrue \fi\fi }
+
+\def\@RestoreMath{\if@MathSaved \relax $\relax\fi }
+
+% Macros
+
+% Renaming @ifnextchar and @ifnch of LaTeX2e to @IFnextchar and @IFnch.
+
+\def\@IFnextchar#1#2#3{%
+ \let\reserved@e=#1\def\reserved@a{#2}\def\reserved@b{#3}\futurelet
+ \reserved@c\@IFnch}
+\def\@IFnch{\ifx \reserved@c \@sptoken \let\reserved@d\@xifnch
+ \else \ifx \reserved@c \reserved@e\let\reserved@d\reserved@a\else
+ \let\reserved@d\reserved@b\fi
+ \fi \reserved@d}
+
+\def\@ifEmpty#1#2#3{\def\@tempa{\@empty}\def\@tempb{#1}\relax
+ \ifx \@tempa \@tempb #2\else #3\fi }
+
+\def\infer{\@SaveMath \@IFnextchar *{\@inferSteps}{\relax
+ \@IFnextchar ={\@inferDoubleRule}{\@inferOneStep}}}
+
+\def\@inferOneStep{\@inferRuletrue \@DoubleRulefalse
+ \@IFnextchar [{\@infer}{\@infer[\@empty]}}
+
+\def\@inferDoubleRule={\@inferRuletrue \@DoubleRuletrue
+ \@IFnextchar [{\@infer}{\@infer[\@empty]}}
+
+\def\@inferSteps*{\@IFnextchar [{\@@inferSteps}{\@@inferSteps[\@empty]}}
+
+\def\@@inferSteps[#1]{\@deduce{#1}[\DeduceSym]}
+
+\def\deduce{\@SaveMath \@IFnextchar [{\@deduce{\@empty}}
+ {\@inferRulefalse \@infer[\@empty]}}
+
+% \@deduce<Proof Label>[<Proof>]<Lower><Uppers>
+
+\def\@deduce#1[#2]#3#4{\@inferRulefalse
+ \@infer[\@empty]{#3}{\@SaveMath \@infer[{#1}]{#2}{#4}}}
+
+% Now deal with the optional vertical centering. Grab the label first
+\def\@infer[#1]{\@IFnextchar [{\@inferCentertrue \@inferv@[#1]}%
+ {\@inferCenterfalse \@inferv[#1]}}
+
+\def\@inferv@[#1][c]{\@inferv[#1]}
+
+% \@inferv[<Label>]<Lower><Uppers>
+% If \@inferRuletrue, it draws a rule and <Label> is right to
+% a rule. In this case, if \@DoubleRuletrue, it draws
+% double rules.
+%
+% Otherwise, draws no rule and <Label> is right to <Lower>.
+%
+% If \@inferCenter, centers the result around the rule
+%
+\def\@inferv[#1]#2#3{\relax
+% Get parameters
+ \if@ReturnLeftOffset \else \@SavedLeftOffset=\@LeftOffset \fi
+ \setbox\@LabelPart=\hbox{$#1$}\relax
+ \setbox\@LowerPart=\hbox{$#2$}\relax
+%
+ \global\@LeftOffset=0pt
+ \setbox\@UpperPart=\vbox{\tabskip=0pt \halign{\relax
+ \global\@RightOffset=0pt \@ReturnLeftOffsettrue $##$&&
+ \inferTabSkip
+ \global\@RightOffset=0pt \@ReturnLeftOffsetfalse $##$\cr
+ #3\cr}}\relax
+% Here is a little trick.
+% \@ReturnLeftOffsettrue(false) influences on \infer or
+% \deduce placed in ## locally
+% because of \@SaveMath and \@RestoreMath.
+ \UpperLeftOffset=\@LeftOffset
+ \UpperRightOffset=\@RightOffset
+% Calculate Adjustments
+ \LowerWidth=\wd\@LowerPart
+ \LowerHeight=\ht\@LowerPart
+ \LowerCenter=0.5\LowerWidth
+%
+ \UpperWidth=\wd\@UpperPart \advance\UpperWidth by -\UpperLeftOffset
+ \advance\UpperWidth by -\UpperRightOffset
+ \UpperCenter=\UpperLeftOffset
+ \advance\UpperCenter by 0.5\UpperWidth
+%
+ \ifdim \UpperWidth > \LowerWidth
+ % \UpperCenter > \LowerCenter
+ \UpperAdjust=0pt
+ \RuleAdjust=\UpperLeftOffset
+ \LowerAdjust=\UpperCenter \advance\LowerAdjust by -\LowerCenter
+ \RuleWidth=\UpperWidth
+ \global\@LeftOffset=\LowerAdjust
+%
+ \else % \UpperWidth <= \LowerWidth
+ \ifdim \UpperCenter > \LowerCenter
+%
+ \UpperAdjust=0pt
+ \RuleAdjust=\UpperCenter \advance\RuleAdjust by -\LowerCenter
+ \LowerAdjust=\RuleAdjust
+ \RuleWidth=\LowerWidth
+ \global\@LeftOffset=\LowerAdjust
+%
+ \else % \UpperWidth <= \LowerWidth
+ % \UpperCenter <= \LowerCenter
+%
+ \UpperAdjust=\LowerCenter \advance\UpperAdjust by -\UpperCenter
+ \RuleAdjust=0pt
+ \LowerAdjust=0pt
+ \RuleWidth=\LowerWidth
+ \global\@LeftOffset=0pt
+%
+ \fi\fi
+% Make a box
+ \if@inferRule
+%
+ \setbox\ResultBox=\vbox{
+ \moveright \UpperAdjust \box\@UpperPart
+ \nointerlineskip \kern\inferLineSkip
+ \if@DoubleRule
+ \moveright \RuleAdjust \vbox{\hrule width\RuleWidth
+ \kern 1pt\hrule width\RuleWidth}\relax
+ \else
+ \moveright \RuleAdjust \vbox{\hrule width\RuleWidth}\relax
+ \fi
+ \nointerlineskip \kern\inferLineSkip
+ \moveright \LowerAdjust \box\@LowerPart }\relax
+%
+ \@ifEmpty{#1}{}{\relax
+%
+ \HLabelAdjust=\wd\ResultBox \advance\HLabelAdjust by -\RuleAdjust
+ \advance\HLabelAdjust by -\RuleWidth
+ \WidthAdjust=\HLabelAdjust
+ \advance\WidthAdjust by -\inferLabelSkip
+ \advance\WidthAdjust by -\wd\@LabelPart
+ \ifdim \WidthAdjust < 0pt \WidthAdjust=0pt \fi
+%
+% \VLabelAdjust=\dp\@LabelPart
+% \advance\VLabelAdjust by -\ht\@LabelPart
+ \VLabelAdjust=-.5ex%
+ \advance\VLabelAdjust by \LowerHeight
+ \advance\VLabelAdjust by \inferLineSkip
+%
+ \setbox\ResultBox=\hbox{\box\ResultBox
+ \kern -\HLabelAdjust \kern\inferLabelSkip
+ \raise\VLabelAdjust \box\@LabelPart \kern\WidthAdjust}\relax
+%
+ }\relax % end @ifEmpty
+%
+ \else % \@inferRulefalse
+%
+ \setbox\ResultBox=\vbox{
+ \moveright \UpperAdjust \box\@UpperPart
+ \nointerlineskip \kern\inferLineSkip
+ \moveright \LowerAdjust \hbox{\unhbox\@LowerPart
+ \@ifEmpty{#1}{}{\relax
+ \kern\inferLabelSkip \unhbox\@LabelPart}}}\relax
+ \fi
+%
+ \global\@RightOffset=\wd\ResultBox
+ \global\advance\@RightOffset by -\@LeftOffset
+ \global\advance\@RightOffset by -\LowerWidth
+ \if@ReturnLeftOffset \else \global\@LeftOffset=\@SavedLeftOffset \fi
+%
+ \if@inferCenter
+ \lower\VLabelAdjust \box\ResultBox
+ \else
+ \box\ResultBox
+ \fi
+ \@RestoreMath
+}
--- /dev/null
+Here is a little bit on sendmail...
+
+Contents:
+
+I. Notes
+ a. General Notes
+ b. Running it through cil
+II. Making a .cf file (shuddder...)
+ a. Instructions on making a .cf file
+ b. Necessary modifications (if you're not root)
+III. Running the guy
+ a. step by step on how to use this thing
+IV. How to check if it worked
+
+
+I. Notes
+
+a. General Notes
+Documentation:
+
+sendmail/cf/README - information about making a cf file
+sendmail/doc/op/op.txt or op.ps - users manual for sendmail
+sendmail/README - release notes
+
+There is also a lot of information about sendmail at www.sendmail.org.
+When you first download and uncompress sendmail, you must type in "sh Build"
+in the directory you extracted to in order to compile. It does not use "make"
+or anything yet on the first compilation. Once you type in "sh Build," it will
+do its magic and under the "sendmail-XXX/obj-OSTYPE/sendmail/" directory you
+will find the source files and the Makefile. It is from here that you can run
+"make" and recompile sendmail. (Note: XXX is whatever version of sendmail you
+downloaded, and OSTYPE is the operating system you are using, it is
+obj.Linux.2.4.5.i686 on manju).
+
+b. Running it through cil
+
+This should be simple. In the cil directory, type in "make sendmail" on manju.
+If you have installed sendmail to a different directory, you must change the
+SENDMAILSRC definition in the Makefile.
+
+
+II. Making a .cf file
+
+a. Instructions on making a .cf file
+Go to your sendmail/cf directory. From here, there are two subdirectories of
+note: cf and m4. Both of these contain files necessary to make your config
+file. Here is the command to make a configuration file (run this from your
+/sendmail/cf directory):
+
+m4 ${CFDIR}/m4/cf.m4 config.mc > config.cf
+
+CFDIR is the cf directory (/usr/local/src/sendmail-8.12.1/cf on manju)
+
+config.mc is a generic name. You should replace it with the OS that you
+are running. Typically, I used generic-linux.mc.
+
+config.cf is the name of the .cf file you want to make. config.cf or
+sendmail.cf are perfectly fine names.
+
+Now, simply stick this file in the sendmail source code directory
+(/usr/local/src/sendmail-8.12.1/obj.Linux.2.4.5.i686/sendmail on manju).
+
+b. Necessary modifications
+If you are not root, you will not be able to access the default mailbox
+directory /etc/mail/ which is defined in the cfhead.m4 file, found in
+the m4 subdirectory. It is not recommended that you modify the .m4 files.
+Instead, you can make modifications to a .mc file of your creation. I have
+one named winston.mc found in the cf subdirectory. At the top, this line was
+added:
+
+define(`MAIL_SETTINGS_DIR', `/home/winston/mailbox/')dnl
+
+Note the difference between ` and ' used to quote the variable and definition.
+This means that all mail will instead be deposited in subdirectories of
+/home/winston/mailbox. For instance, mail will now be deposited in
+/home/winston/var/spool/mqueue.
+
+Another thing you need to do is create a file called "local-host-names" in the
+mailbox directory. So, just create a file called "local-host-names" and put
+the name of the machine you are on. I put "manju@cs.berkeley.edu."
+
+Lastly, you must make sure that port 9999 is available on the machine you are
+working on (typically manju). You can check this by running the "netstat -anp"
+command in Unix scrolling up to check what ports are in use. If it is not
+available, you are going to have to modify the source code. Here's how to do it:
+
+In daemon.c, change all occurrences of 9999 to some other port above 1024 that
+is not in use.
+In config.cf change all occurrences of 9999 to that same port above. Lastly,
+change the TrustedUser to your manju login. (i.e. TrustedUser=winston, or
+whatever your login is.)
+
+III. Running the guy
+
+Ok, now to the fun part. After running it through cil, you want to see if it
+works. Here's the command to type in the $(SENDMAILDIR)/obj.Linux.xxx/sendmail
+directory:
+
+./sendmail -C config.cf -bD -v -d1
+
+Of course, if you named your config.cf file differently, change that here.
+
+The -bD flag tells it to run as a daemon in the foreground.
+The -v flag tells it to go to verbose mode (it's not really necessary)
+the -d1 flag tells it to go to debugging mode (not really necessary either)
+
+Now you are running sendmail! Now, open another console. Type in
+"telnet localhost 9999" or whatever port you decided to use. If you are on
+another machine, change the localhost to whatever machine you are running
+sendmail on. You will get some sort of message telling you what you've
+connected.
+
+Now, type in:
+HELO blah
+It's really not important what goes after HELO.
+
+Now, type in the sender of this message. To do that, type in:
+MAIL from: winston@manju.cs.berkeley.edu (or whatever address you are
+sending from)
+
+Next, designate the recipient. To do that, type in:
+RCPT to: winston@madrone.cs.berkeley.edu (or whatever address you are
+sending to)
+
+Next, write the body. To do that, type in:
+DATA (hit enter)
+blah blah blah blah blah
+Follow the instructions, end with a . on a line by itself.
+
+Now, that's it. You've sent something! (hopefully). To exit, type in:
+quit
+
+
+IV. Checking that it worked
+
+Now for the moment of truth. Go to one level above your mailbox directory (in
+the examples above, my mailbox directory was /home/winston/mailbox, so I would
+go to /home/winston now) and go to the var/spool/mqueue directory. Inside there
+should be file with gibberish names on them. "cat" the ones starting with "dff."
+One of those should be the body of your email. Wow, it worked! Sendmail just
+places the files here so the MTA can pick them up for delivery. That's it!
+
--- /dev/null
+\documentclass{article}
+\usepackage{hevea}
+
+\def\t#1{{\tt #1}}
+\def\DYNAMIC{\t{DYNAMIC}}
+\title{Setting Up cygwin and OCaml}
+\author{Scott McPeak \and George Necula}
+
+\begin{document}
+\maketitle
+
+ This document is intended to get you started with OCAML and the other tools
+that are necessary for CCured and other projects of ours. These tools work on
+Linux and Windows (NT4.0, 2000, XP and also less reliably on 95/98/Me).
+
+ If you use Linux then you can go directly to Section~\ref{sec-ocaml}.
+
+\section{If you want to use Windows}
+
+ \subsection{Get \t{cygwin}}
+
+ You must have a bunch of Unix tools installed on your machine. (In the future
+we might be able to avoid these but for now you are better off with them.).
+Here is what I (George) do to install Cygwin. You need a good network
+connection for this.
+\begin{itemize}
+\item Create a directory \t{C:\backslash Download\backslash cygwin}
+\item Go to \ahrefurl{http://sources.redhat.com/cygwin} and click \t{Install
+cygwin} icon. Download \t{setup.exe} to the directory you just created.
+\item Run \t{setup.exe} and select ``Download to local directory''. Select all
+the packages. This will take a while (~ 30 minutes)
+\item Run \t{setup.exe} again and not select to ``Install from local
+directory''. It is best to {\bf deselect} the \t{tetex} package since I found
+it to interfere with other installations of Latex.
+\item I choose \t{C:\backslash Programs\backslash cygwin}
+as the home for \t{cygwin}, I use \t{DOS} as the default text file and I
+choose ``Install for All''.
+\item Add \t{C:\backslash Programs\backslash cygwin\backslash bin} to your
+PATH. You must put it first in the ``System Variables'' PATH (In Control Panel/System/Advanced/Environment
+Variables'' and {\bf put it first} so that it comes before the default
+c:/WinNT/system32. You can verify that you got it right if you get
+\t{/usr/bin/find} when you run \t{which find}.
+\item Verify that you can run \t{/usr/bin/perl} from the command line within
+\t{bash}.
+\end{itemize}
+
+
+\section{Get OCaml}\label{sec-ocaml}
+
+The next step for most people is to download and install the Ocaml
+compiler system. This is available at:
+
+ \ahrefurl{http://caml.inria.fr/ocaml/}
+
+At the time of writing, the current version is 3.07. The following
+instructions assume that you will build from sources even on Windows (instead
+of using the Native compiler provided). Here the rough sequence of steps:
+\begin{itemize}
+\item Download and unpack the sources
+\item Go in that directory, start \t{bash} if on Windows, and run
+\begin{verbatim}
+% ./configure
+% make world
+% make opt
+% make install
+\end{verbatim}
+
+ The first command might fail to configure some libraries but that's Ok.
+\end{itemize}
+
+To test your ocaml distribution, try:
+
+\begin{verbatim}
+ % which ocaml
+ /usr/local/bin/ocaml
+
+ % ocaml
+ Objective Caml version 3.07
+
+ # exit 0;; <-- you type "exit 0;;", and press enter
+\end{verbatim}
+
+ If you intend to program in Ocaml then you should also install the emacs
+support files for ocaml. This will give you nice fontification and
+indentation. If you check in code that is not indented nicely some members of
+the project will not be pleased!
+
+ \subsection{Debugging Support Ocaml}
+
+ If you expect to need to run the debugger our projects are set up in such a
+way that they will invoke the debugger for you. How to do that is described in
+each project's documentation. But for that support to work you must add the
+following code to your .emacs file. Also, if you are using GNU-emacs then you
+must set the Coding style for your files to ``unix'' (CTRL-X RET F).
+
+\begin{verbatim}
+(defvar ocamldebug-history nil)
+(defun my-camldebug (command-line)
+ "Run camldebug on program FILE in buffer *camldebug-FILE*.
+The directory containing FILE becomes the initial working directory
+and source-file directory for camldebug. If you wish to change this, use
+the camldebug commands `cd DIR' and `directory'."
+ (interactive
+ (list (read-from-minibuffer "Run ocamldebug (like this): "
+ (if (consp ocamldebug-history)
+ (car ocamldebug-history)
+ "ocamldebug")
+ nil
+ nil
+ '(ocamldebug-history . 1))))
+ ; call something from camldebug.el to make sure it is loaded
+ (camldebug-numeric-arg 1)
+
+ ; We must override the camldebug-display-line
+ (if (not (fboundp 'original-camldebug-display-line))
+ (fset 'original-camldebug-display-line
+ (symbol-function 'camldebug-display-line)))
+ (defun camldebug-display-line (true-file character kind)
+ ; See if true-file exists
+ (if (not (file-exists-p true-file))
+ ; Try to run cygpath to convert the file name
+ (with-temp-buffer
+ (if (equal 0
+ (call-process "cygpath" nil t t "-m" true-file))
+ (progn
+ ; Drop the end of line
+ (when (bolp)
+ (backward-delete-char 1))
+ (setq true-file (buffer-string))))))
+ (original-camldebug-display-line true-file character kind))
+
+
+ (pop-to-buffer (concat "*camldebug*"))
+ (setq words (split-string command-line))
+ (message "Current directory is %s" default-directory)
+ (apply 'make-comint (cons "camldebug"
+ (cons (car words)
+ (cons nil (cdr words)))))
+ (set-process-filter (get-buffer-process (current-buffer))
+ 'camldebug-filter)
+ (set-process-sentinel (get-buffer-process (current-buffer))
+ 'camldebug-sentinel)
+ (camldebug-mode)
+ (camldebug-set-buffer))
+\end{verbatim}
+
+
+\section{Set the environment variables}
+
+ Make sure that /usr/local/lib in in your path. If you are on Windows this
+ means ``C:/Programs/cygwin/usr/local/lib''.
+
+
+\section{If you need CVS access}
+
+ See the \ahref{cvssetup.html}{separate instructions}.
+
+
+\section{Useful Links}
+\begin{itemize}
+ \item Tutorial on ML:
+ \ahrefurl{http://www.dcs.napier.ac.uk/course-notes/sml/manual.html}
+ \item Documentation and sources for Ocaml:
+ \ahrefurl{http://caml.inria.fr/ocaml/}
+ \item Manual for GNU make:
+ \ahrefurl{http://www.gnu.org/manual/make/html\_chapter/make\_toc.html}
+
+
+ \end{itemize}
+
+
+\end{document}
--- /dev/null
+This file is meant to collect the various "here's how to do X" advice
+we like to send around in emails and then promptly forget.
+
+
+----------------------- slicer for globals ----------------------
+
+I (Scott) just implemented a simple extension to cilly.asm.exe
+(really, just a small modification to 'rmtmps') which lets you slice a
+given C file so that it only contains things which contribute to a
+given global's type (actually, you can name as many root globals as
+you want). I think this will be useful for tracking down merger
+problems in big programs.
+
+To use this, just add
+
+ #pragma cilnoremove("my_symbol")
+
+to the file in question, and then run
+
+ $cil/obj/x86_LINUX/cilly.asm.exe \
+ --sliceGlobal --out file.cil.c file.i
+
+(where file.i is preprocessed file.c). This will slice file.i so it only
+contains things which are needed for 'my_symbol' to compile successfully,
+and write the output to file.cil.c.
+
+The symbol in question can be a function, enum tag, struct tag, typedef
+name, or global variable. Add more #pragma cilnoremove's to add more
+things to the root set.
+
+Update: It doesn't work very well for types. Instead, if you want to
+slice on a type, add at the end of the file
+
+ #pragma cilnoremove("myGlobalVar")
+ struct typeOfInterest myGlobalVar;
+
+then the slicer will retain 'typeOfInterest'.
+
+
+------------------- trusted expressions ------------------
+
+> Here's another idea: can we mark certain expressions as "trusted"?
+
+Yes. Enclose the expression (say, "x=a;") as follows:
+
+ { __NOBOXBLOCK x=a; }
+
+This causes markptr to ignore the expression (so no edges/flags are
+generated and thus the solver won't become upset by anything that happens
+there) and boxing to ... do the best it can, with everything in there lean.
+
+
+--------------------- invoking the Ocaml debugger ----------------------
+
+I have just written some Elisp code that allows you to enter the
+debugger very easily:
+
+First the usage:
+ Say you want to debug the ccured invocation for the command
+
+ make test/array1 INFERBOX=infer
+
+ You start emacs, go to directory cil/test (in which the above command
+makes sense) and then do
+
+ M-x my-camldebug
+ This will ask you how to run the debugger. You write the following
+
+ make test/array1 INFERBOX=infer OCAMLDEBUG=1
+
+ This will call ocamldebug when appropriately with the right arguments
+and with proper setting of source directories.
+
+ After that it feels like gdb (see the manual though). The time travel
+(i.e. backwards stepping) is great.
+
+ Now the Lisp magic. Put this in your .emacs:
+
+(defvar ocamldebug-history nil)
+(defun my-camldebug (command-line)
+ "Run camldebug on program FILE in buffer *camldebug-FILE*. The directory containing FILE becomes the initial working directory and source-file directory for camldebug. If you wish to change this, use the camldebug commands `cd DIR' and `directory'."
+ (interactive
+ (list (read-from-minibuffer "Run ocamldebug (like this): "
+ (if (consp ocamldebug-history)
+ (car ocamldebug-history)
+ "ocamldebug")
+ nil
+ nil
+ '(ocamldebug-history . 1))))
+ ; call something from camldebug.el to make sure it is loaded
+ (camldebug-numeric-arg 1)
+ (pop-to-buffer (concat "*camldebug*"))
+ (setq words (gud-chop-words command-line))
+ (message "Current directory is %s" default-directory)
+ (apply 'make-comint (cons "camldebug"
+ (cons (car words)
+ (cons nil (cdr words)))))
+ (set-process-filter (get-buffer-process (current-buffer))
+ 'camldebug-filter)
+ (set-process-sentinel (get-buffer-process (current-buffer))
+ 'camldebug-sentinel)
+ (camldebug-mode)
+ (camldebug-set-buffer))
+
+
+--------------------- mapping backwards through #line -------------------
+by Scott 6/18/02 02:41
+
+The typical CCured build involves many source translation steps.
+Usually, we use the --commPrintLn flag to emit #line directives, but
+commented-out, so we see the final translation product in gdb.
+
+However, it's often useful to see the original source also, or the
+intermediate stages, when debugging. I've written an elisp macro
+to look backwards in the current file for the #line directives which
+tell the file/line from which the current one came, and then open that
+file and position the cursor at the right line. It's called
+"map-hashline-back", and is among those defined below.
+
+; search backwards in a file for the nearest #line directive that
+; mentions the filename
+(defun find-enclosing-hashline ()
+ "Search backwards for #line directive with filename"
+ (interactive)
+ (re-search-backward "^/?/?#\\(line\\)? [0-9]+ ")
+)
+
+(defun find-enclosing-hashline-any ()
+ "Search backwards for any #line directive"
+ (interactive)
+ (re-search-backward "^/?/?#\\(line\\)? [0-9]+")
+)
+
+(defun match-string (n)
+ "Return string matched by most recent search; 'n' is parethesis
+ grouping number, where 0 means entire search string."
+ (buffer-substring (match-beginning n) (match-end n))
+)
+
+(defun current-hashline-line ()
+ "Extract and return line number of #line directive at cursor."
+ (re-search-forward "#\\(line\\)? \\([0-9]+\\)")
+ (string-to-number (match-string 2))
+)
+
+(defun current-hashline-file ()
+ "Extract and return file name of #line directive at cursor."
+ (re-search-forward "#\\(line\\)? [0-9]+ \"\\(.*\\)\"")
+ (match-string 2)
+)
+
+(defun map-hashline-back ()
+ "Given a #line directive at cursor, open file it refers to, at
+ the line position given."
+ (interactive)
+ (let ((curPosn (point))) ; save current cursor position
+ (find-enclosing-hashline-any)
+ (let ((lineNumber (current-hashline-line)))
+ (goto-char curPosn) ; restore original buffer's position
+ (find-enclosing-hashline)
+ (let ((fileName (current-hashline-file)))
+ (goto-char curPosn) ; restore original buffer's position
+
+ (if (file-exists-p fileName)
+ (find-file fileName) ; open the named file
+ ; try one level up, which is needed for our current
+ ; C++/CCured build process where we move files around
+ ; after translation
+ (if (file-exists-p (concat "../" fileName))
+ (find-file (concat "../" fileName))
+ (error "File does not exist: %s" fileName)
+ ))
+ (goto-line lineNumber) ; go to right line
+
+ ; print where we went
+ (princ fileName)
+ (princ ":")
+ (princ lineNumber)
+ )
+ )
+ )
+)
+
+; this doesn't work as advertised, but it's close enough
+(defun run-previous-M-x-command ()
+ "Run the last command interactively entered with M-x."
+ (interactive)
+ (let ((prevCmd (car command-history)))
+ (princ prevCmd)
+ (eval prevCmd)
+ )
+)
+
+; after doing M-x map-hashline-back once, now ctl+alt+p will
+; go back through successive layers
+(global-set-key [(control meta p)] 'run-previous-M-x-command )
+
+
+--------------------- navigating .infer files ------------------
+by Scott 6/18/02 02:42
+
+(George had a different way of doing this; how does his work?)
+
+When I use .infer files, it's always to do one thing: given a
+WILD node, trace backwards to the cast which caused it. The
+macro goto-prev-wild will do one step of the mapping. Then, use
+ctl+alt+p (above) to go more steps.
+
+(defun get-wild-source ()
+ "Search forward to the next WILD/<reason>(<id>) string, and
+ extract and return that node id."
+ (re-search-forward "WILD/[A-Za-z_]+(\\([0-9]+\\))")
+ (string-to-number (match-string 1))
+)
+
+(defun goto-infer-node (n)
+ "Find the information section for node 'n'."
+ (goto-char 0)
+ (re-search-forward (format "^%d :" n))
+)
+
+(defun goto-prev-wild ()
+ "Go to the node which caused this one to be WILD."
+ (interactive)
+ (let ((source (get-wild-source)))
+ (princ (format "Node %d" source))
+ (goto-infer-node source)
+ )
+)
--- /dev/null
+#!/bin/sh
+#
+# install - install a program, script, or datafile
+# This comes from X11R5 (mit/util/scripts/install.sh).
+#
+# Copyright 1991 by the Massachusetts Institute of Technology
+#
+# Permission to use, copy, modify, distribute, and sell this software and its
+# documentation for any purpose is hereby granted without fee, provided that
+# the above copyright notice appear in all copies and that both that
+# copyright notice and this permission notice appear in supporting
+# documentation, and that the name of M.I.T. not be used in advertising or
+# publicity pertaining to distribution of the software without specific,
+# written prior permission. M.I.T. makes no representations about the
+# suitability of this software for any purpose. It is provided "as is"
+# without express or implied warranty.
+#
+# Calling this script install-sh is preferred over install.sh, to prevent
+# `make' implicit rules from creating a file called install from it
+# when there is no Makefile.
+#
+# This script is compatible with the BSD install script, but was written
+# from scratch. It can only install one file at a time, a restriction
+# shared with many OS's install programs.
+
+
+# set DOITPROG to echo to test this script
+
+# Don't use :- since 4.3BSD and earlier shells don't like it.
+doit="${DOITPROG-}"
+
+
+# put in absolute paths if you don't have them in your path; or use env. vars.
+
+mvprog="${MVPROG-mv}"
+cpprog="${CPPROG-cp}"
+chmodprog="${CHMODPROG-chmod}"
+chownprog="${CHOWNPROG-chown}"
+chgrpprog="${CHGRPPROG-chgrp}"
+stripprog="${STRIPPROG-strip}"
+rmprog="${RMPROG-rm}"
+mkdirprog="${MKDIRPROG-mkdir}"
+
+transformbasename=""
+transform_arg=""
+instcmd="$mvprog"
+chmodcmd="$chmodprog 0755"
+chowncmd=""
+chgrpcmd=""
+stripcmd=""
+rmcmd="$rmprog -f"
+mvcmd="$mvprog"
+src=""
+dst=""
+dir_arg=""
+
+while [ x"$1" != x ]; do
+ case $1 in
+ -c) instcmd="$cpprog"
+ shift
+ continue;;
+
+ -d) dir_arg=true
+ shift
+ continue;;
+
+ -m) chmodcmd="$chmodprog $2"
+ shift
+ shift
+ continue;;
+
+ -o) chowncmd="$chownprog $2"
+ shift
+ shift
+ continue;;
+
+ -g) chgrpcmd="$chgrpprog $2"
+ shift
+ shift
+ continue;;
+
+ -s) stripcmd="$stripprog"
+ shift
+ continue;;
+
+ -t=*) transformarg=`echo $1 | sed 's/-t=//'`
+ shift
+ continue;;
+
+ -b=*) transformbasename=`echo $1 | sed 's/-b=//'`
+ shift
+ continue;;
+
+ *) if [ x"$src" = x ]
+ then
+ src=$1
+ else
+ # this colon is to work around a 386BSD /bin/sh bug
+ :
+ dst=$1
+ fi
+ shift
+ continue;;
+ esac
+done
+
+if [ x"$src" = x ]
+then
+ echo "install: no input file specified"
+ exit 1
+else
+ true
+fi
+
+if [ x"$dir_arg" != x ]; then
+ dst=$src
+ src=""
+
+ if [ -d $dst ]; then
+ instcmd=:
+ chmodcmd=""
+ else
+ instcmd=mkdir
+ fi
+else
+
+# Waiting for this to be detected by the "$instcmd $src $dsttmp" command
+# might cause directories to be created, which would be especially bad
+# if $src (and thus $dsttmp) contains '*'.
+
+ if [ -f $src -o -d $src ]
+ then
+ true
+ else
+ echo "install: $src does not exist"
+ exit 1
+ fi
+
+ if [ x"$dst" = x ]
+ then
+ echo "install: no destination specified"
+ exit 1
+ else
+ true
+ fi
+
+# If destination is a directory, append the input filename; if your system
+# does not like double slashes in filenames, you may need to add some logic
+
+ if [ -d $dst ]
+ then
+ dst="$dst"/`basename $src`
+ else
+ true
+ fi
+fi
+
+## this sed command emulates the dirname command
+dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'`
+
+# Make sure that the destination directory exists.
+# this part is taken from Noah Friedman's mkinstalldirs script
+
+# Skip lots of stat calls in the usual case.
+if [ ! -d "$dstdir" ]; then
+defaultIFS='
+'
+IFS="${IFS-${defaultIFS}}"
+
+oIFS="${IFS}"
+# Some sh's can't handle IFS=/ for some reason.
+IFS='%'
+set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'`
+IFS="${oIFS}"
+
+pathcomp=''
+
+while [ $# -ne 0 ] ; do
+ pathcomp="${pathcomp}${1}"
+ shift
+
+ if [ ! -d "${pathcomp}" ] ;
+ then
+ $mkdirprog "${pathcomp}"
+ else
+ true
+ fi
+
+ pathcomp="${pathcomp}/"
+done
+fi
+
+if [ x"$dir_arg" != x ]
+then
+ $doit $instcmd $dst &&
+
+ if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi &&
+ if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi &&
+ if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi &&
+ if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi
+else
+
+# If we're going to rename the final executable, determine the name now.
+
+ if [ x"$transformarg" = x ]
+ then
+ dstfile=`basename $dst`
+ else
+ dstfile=`basename $dst $transformbasename |
+ sed $transformarg`$transformbasename
+ fi
+
+# don't allow the sed command to completely eliminate the filename
+
+ if [ x"$dstfile" = x ]
+ then
+ dstfile=`basename $dst`
+ else
+ true
+ fi
+
+# Make a temp file name in the proper directory.
+
+ dsttmp=$dstdir/#inst.$$#
+
+# Move or copy the file name to the temp name
+
+ $doit $instcmd $src $dsttmp &&
+
+ trap "rm -f ${dsttmp}" 0 &&
+
+# and set any options; do chmod last to preserve setuid bits
+
+# If any of these fail, we abort the whole thing. If we want to
+# ignore errors from any of these, just make sure not to ignore
+# errors from the above "$doit $instcmd $src $dsttmp" command.
+
+ if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi &&
+ if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi &&
+ if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi &&
+ if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi &&
+
+# Now rename the file to the real destination.
+
+ $doit $rmcmd -f $dstdir/$dstfile &&
+ $doit $mvcmd $dsttmp $dstdir/$dstfile
+
+fi &&
+
+
+exit 0
--- /dev/null
+splay
+*.patch2.i*
+topformflat
+topformflat.c
+getrusage
--- /dev/null
+# .gdbinit
+
+file splay
+break main
+break initErrorHandlers
+run
--- /dev/null
+#
+#
+# Copyright (c) 2001-2002,
+# George C. Necula <necula@cs.berkeley.edu>
+# Scott McPeak <smcpeak@cs.berkeley.edu>
+# Wes Weimer <weimer@cs.berkeley.edu>
+# 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 implements a compiler stub that parses the command line
+# arguments of gcc and Microsoft Visual C (along with some arguments for the
+# script itself) and gives hooks into preprocessing, compilation and linking.
+
+
+$::cilbin = 'bin';
+
+package Cilly;
+@ISA = ();
+
+use strict;
+use File::Basename;
+use File::Copy;
+use File::Spec;
+use Data::Dumper;
+use Carp;
+use Text::ParseWords;
+
+use KeptFile;
+use OutputFile;
+use TempFile;
+
+$Cilly::savedSourceExt = "_saved.c";
+
+# Pass to new a list of command arguments
+sub new {
+ my ($proto, @args) = @_;
+ my $class = ref($proto) || $proto;
+
+ my $ref =
+ { ARGV => \@args, # Arguments
+ CFILES => [], # C input files
+ SFILES => [], # Assembly language files
+ OFILES => [], # Other input files
+ IFILES => [], # Already preprocessed files
+ EARLY_PPARGS => [], # Preprocessor args, first (pre-CIL) pass only
+ PPARGS => [], # Preprocessor args
+ CCARGS => [], # Compiler args
+ LINKARGS => [], # Linker args
+ NATIVECAML => 1, # this causes the native code boxer to be used
+ RELEASELIB => 0, # if true, use the release runtime library (if any)
+ IDASHDOT => 1, # if true, pass "-I." to gcc's preprocessor
+ VERBOSE => 0, # when true, print extra detail
+ TRACE_COMMANDS => 1, # when true, echo commands being run
+ SEPARATE => ! $::default_is_merge,
+ LIBDIR => [],
+ OPERATION => 'TOEXE', # This is the default for all compilers
+ };
+
+ my $self = bless $ref, $class;
+
+ if(! @args) {
+ print "No arguments passed\n";
+ $self->printHelp();
+ exit 0;
+ }
+ # Look for the --mode argument first. If not found it is GCC
+ # Also parse the --gcc option which overrides the C compiler name
+ # (currently only used in the gcc case)
+ my $mode = $::default_mode;
+ {
+ my @args1 = ();
+ foreach my $arg (@args) {
+ if($arg =~ m|--mode=(.+)$|) {
+ $mode = $1;
+ }
+ elsif($arg =~ m|--gcc=(.+)$|) {
+ $::cc = $1;
+ } else {
+ push @args1, $arg;
+ }
+ }
+ @args = @args1; # These are the argument after we extracted the --mode
+
+ }
+ if(defined $self->{MODENAME} && $self->{MODENAME} ne $mode) {
+ die "Cannot re-specify the compiler";
+ }
+
+ my $compiler;
+ if($mode eq "MSVC") {
+ unshift @Cilly::ISA, qw(MSVC);
+ $compiler = MSVC->new($self);
+ } elsif($mode eq "GNUCC") {
+ unshift @Cilly::ISA, qw(GNUCC);
+ $compiler = GNUCC->new($self);
+ } elsif($mode eq "MSLINK") {
+ unshift @Cilly::ISA, qw(MSLINK);
+ $compiler = MSLINK->new($self);
+ } elsif($mode eq "MSLIB") {
+ unshift @Cilly::ISA, qw(MSLIB);
+ $compiler = MSLIB->new($self);
+ } elsif($mode eq "AR") {
+ unshift @Cilly::ISA, qw(AR);
+ $compiler = AR->new($self);
+ } else {
+ die "Don't know about compiler $mode\n";
+ }
+ # Now grab the fields from the compiler and put them inside self
+ my $key;
+ foreach $key (keys %{$compiler}) {
+ $self->{$key} = $compiler->{$key};
+ }
+
+ # 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} = '.';
+ }
+
+ return $self;
+}
+
+sub processArguments {
+ my ($self) = @_;
+ my @args = @{$self->{ARGV}};
+
+ # Scan and process the arguments
+ $self->setDefaultArguments;
+ collectArgumentList($self, @args);
+
+ # sm: if an environment variable is set, then do not merge; this
+ # is intended for use in ./configure scripts, where merging delays
+ # the reporting of errors that the script is expecting
+ if (defined($ENV{"CILLY_NOMERGE"})) {
+ $self->{SEPARATE} = 1;
+ if($self->{VERBOSE}) { print STDERR "Merging disabled by CILLY_NOMERGE\n"; }
+ }
+
+# print Dumper($self);
+
+ return $self;
+}
+
+# Hook to let subclasses set/override default arguments
+sub setDefaultArguments {
+}
+
+# work through an array of arguments, processing each one
+sub collectArgumentList {
+ my ($self, @args) = @_;
+
+ # Scan and process the arguments
+ while($#args >= 0) {
+ my $arg = $self->fetchNextArg(\@args);
+
+ if(! defined($arg)) {
+ last;
+ }
+ if($arg eq "") { next; }
+
+ #print("arg: $arg\n");
+#
+# my $arg = shift @args; # Grab the next one
+ if(! $self->collectOneArgument($arg, \@args)) {
+ print "Warning: Unknown argument $arg\n";
+ push @{$self->{CCARGS}}, $arg;
+ }
+ }
+}
+
+# Grab the next argument
+sub fetchNextArg {
+ my ($self, $pargs) = @_;
+ return shift @{$pargs};
+}
+
+# Collecting arguments. Take a look at one argument. If we understand it then
+# we return 1. Otherwise we return 0. Might pop some more arguments from pargs.
+sub collectOneArgument {
+ my($self, $arg, $pargs) = @_;
+ my $res;
+ # Maybe it is a compiler option or a source file
+ if($self->compilerArgument($self->{OPTIONS}, $arg, $pargs)) { return 1; }
+
+ if($arg eq "--help" || $arg eq "-help") {
+ $self->printVersion();
+ $self->printHelp();
+ exit 1;
+ }
+ if($arg eq "--version" || $arg eq "-version") {
+ $self->printVersion(); exit 0;
+ }
+ if($arg eq "--verbose") {
+ $self->{VERBOSE} = 1; return 1;
+ }
+ if($arg eq "--flatten_linker_scripts") {
+ $self->{FLATTEN_LINKER_SCRIPTS} = 1; return 1;
+ }
+ if($arg eq '--nomerge') {
+ $self->{SEPARATE} = 1;
+ return 1;
+ }
+ if($arg eq '--merge') {
+ $self->{SEPARATE} = 0;
+ return 1;
+ }
+ if($arg =~ "--ccargs=(.+)\$") {
+ push @{$self->{CCARGS}}, $1;
+ return 1;
+ }
+ if($arg eq '--trueobj') {
+ $self->{TRUEOBJ} = 1;
+ return 1;
+ }
+ # zf: force curing when linking to a lib
+ if ($arg eq '--truelib') {
+ $self->{TRUELIB} = 1;
+ return 1;
+ }
+ if($arg eq '--keepmerged') {
+ $self->{KEEPMERGED} = 1;
+ return 1;
+ }
+ if($arg eq '--stdoutpp') {
+ $self->{STDOUTPP} = 1;
+ return 1;
+ }
+ if($arg =~ m|--save-temps=(.+)$|) {
+ if(! -d $1) {
+ die "Cannot find directory $1";
+ }
+ $self->{SAVE_TEMPS} = $1;
+ return 1;
+ }
+ if($arg eq '--save-temps') {
+ $self->{SAVE_TEMPS} = '.';
+ return 1;
+ }
+ if($arg =~ m|--leavealone=(.+)$|) {
+ push @{$self->{LEAVEALONE}}, $1;
+ return 1;
+ }
+ if($arg =~ m|--includedir=(.+)$|) {
+ push @{$self->{INCLUDEDIR}}, $1; return 1;
+ }
+ if($arg =~ m|--stages|) {
+ $self->{SHOWSTAGES} = 1;
+ push @{$self->{CILARGS}}, $arg;
+ return 1;
+ }
+ if($arg eq "--bytecode") {
+ $self->{NATIVECAML} = 0; return 1;
+ }
+ if($arg eq "--no-idashdot") {
+ $self->{IDASHDOT} = 0; return 1;
+ }
+
+ # sm: response file
+ if($arg =~ m|-@(.+)$| ||
+ (($self->{MODENAME} eq "MSVC" ||
+ $self->{MODENAME} eq "MSLINK" ||
+ $self->{MODENAME} eq "MSLIB") && $arg =~ m|@(.+)$|)) {
+ my $fname = $1; # name of response file
+ &classifyArgDebug("processing response file: $fname\n");
+
+ # read the lines into an array
+ if (!open(RF, "<$fname")) {
+ die("cannot open response file $fname: $!\n");
+ }
+ my @respArgs = ();
+ while(<RF>) {
+ # Drop spaces and empty lines
+ my ($middle) = ($_ =~ m|\s*(\S.*\S)\s*|);
+ if($middle ne "") {
+ # Sometimes we have multiple arguments in one line :-()
+ if($middle =~ m|\s| &&
+ $middle !~ m|[\"]|) {
+ # Contains spaces and no quotes
+ my @middles = split(/\s+/, $middle);
+ push @respArgs, @middles;
+ } else {
+ push @respArgs, $middle;
+ }
+# print "Arg:$middle\n";
+ }
+ }
+ close(RF) or die;
+
+
+ # Scan and process the arguments
+ collectArgumentList($self, @respArgs);
+
+ #print("done with response file: $fname\n");
+ return 1; # argument undestood
+ }
+ if($arg eq "-@" || ($self->{MODENAME} eq "MSVC" && $arg eq "@")) {
+ # sm: I didn't implement the case where it takes the next argument
+ # because I wasn't sure how to grab add'l args (none of the
+ # cases above do..)
+ die("For ccured/cilly, please don't separate the -@ from the\n",
+ "response file name. e.g., use -@", "respfile.\n");
+ }
+
+ # Intercept the --out argument
+ if($arg =~ m|^--out=(\S+)$|) {
+ $self->{CILLY_OUT} = $1;
+ push @{$self->{CILARGS}}, "--out", $1;
+ return 1;
+ }
+ # All other arguments starting with -- are passed to CIL
+ if($arg =~ m|^--|) {
+ # Split the ==
+ if($arg =~ m|^(--\S+)=(.+)$|) {
+ push @{$self->{CILARGS}}, $1, $2; return 1;
+ } else {
+ push @{$self->{CILARGS}}, $arg; return 1;
+ }
+ }
+ return 0;
+}
+
+
+sub printVersion {
+ system ($CilCompiler::compiler, '--version');
+}
+
+sub printHelp {
+ my($self) = @_;
+ $self->usage();
+ my $nomergeisDefault = "";
+ my $mergeisDefault = "";
+ if ($::default_is_merge) {
+ $mergeisDefault = "\n This is the default.";
+ } else {
+ $nomergeisDefault = "\n This is the default.";
+ }
+ print <<EOF;
+
+Options:
+ --mode=xxx What tool to emulate:
+ GNUCC - GNU gcc
+ AR - GNU ar
+ MSVC - MS VC cl compiler
+ MSLINK - MS VC link linker
+ MSLIB - MS VC lib linker
+ This option must be the first one! If it is not found there
+ then GNUCC mode is assumed.
+ --help (or -help) Prints this help message.
+ --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.
+ --trueobj Do not write preprocessed sources in .obj/.o files but
+ create some other files (e.g. foo.o_saved.c).
+ --truelib When linking to a library (with -r or -i), output real
+ object files instead of preprocessed sources. This only
+ works for GCC right now.
+ --leavealone=xxx Leave alone files whose base name is xxx. This means
+ 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
+ well the /P file
+
+EOF
+ $self->helpMessage();
+}
+
+# For printing the first line of the help message
+sub usage {
+ my ($self) = @_;
+ print "<No usage is defined>";
+}
+
+# The rest of the help message
+sub helpMessage {
+ my ($self) = @_;
+ print <<EOF;
+Send bugs to necula\@cs.berkeley.edu.
+EOF
+}
+
+
+#
+# Normalize a file name to always use slashes
+#
+sub normalizeFileName {
+ my($f) = @_;
+ $f =~ s|\\|/|g;
+ return $f;
+}
+
+#
+# The basic routines: for ech source file preprocess, compile, then link
+# everything
+#
+#
+
+
+# LINKING into a library (with COMPILATION and PREPROCESSING)
+sub straight_linktolib {
+ my ($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_;
+ my @sources = ref($psrcs) ? @{$psrcs} : ($psrcs);
+ my @dest = $dest eq "" ? () : ($self->{OUTLIB} . $dest);
+ # Pass the linkargs last because some libraries must be passed after
+ # the sources
+ my @cmd = (@{$self->{LDLIB}}, @dest, @{$ppargs}, @{$ccargs}, @sources, @{$ldargs});
+ return $self->runShell(@cmd);
+}
+
+# Customize the linking into libraries
+sub linktolib {
+ my($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_;
+ if($self->{VERBOSE}) { print STDERR "Linking into library $dest\n"; }
+
+ # Now collect the files to be merged
+ my ($tomerge, $trueobjs, $ccargs) =
+ $self->separateTrueObjects($psrcs, $ccargs);
+
+ if($self->{SEPARATE} || @{$tomerge} == 0) {
+ # Not merging. Regular linking.
+
+ 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";
+ if($self->{VERBOSE}) {
+ print STDERR
+ "Saving additional true object files in $trueobjs_file\n";
+ }
+ open(TRUEOBJS, ">$trueobjs_file") || die "Cannot write $trueobjs_file";
+ foreach my $true (@{$trueobjs}) {
+ my $abs = File::Spec->rel2abs($true);
+ print TRUEOBJS "$abs\n";
+ }
+ close(TRUEOBJS);
+ }
+ if(@{$tomerge} == 1) { # Just copy the file over
+ (!system('cp', '-f', ${$tomerge}[0], $dest))
+ || die "Cannot copy ${$tomerge}[0] to $dest\n";
+ return ;
+ }
+ #
+ # We must do real merging
+ #
+ # 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];
+
+ if($self->{MODENAME} eq "MSVC") {
+ push @cmd, "--MSVC";
+ }
+ if($self->{VERBOSE}) {
+ push @cmd, "--verbose";
+ }
+ if(defined $self->{CILARGS}) {
+ 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)
+ # instead of actual filename
+ my @normalized = @{$tomerge} ;
+ $_ = (ref $_ ? $_->filename : $_) foreach @normalized;
+ foreach my $fl (@normalized) {
+ print TOMERGE "$fl\n";
+ }
+ close(TOMERGE);
+ push @cmd, '--extrafiles', $extraFile;
+ } else {
+ push @cmd, @{$tomerge};
+ }
+ push @cmd, "--mergedout", $dest;
+ # Now run cilly
+ return $self->runShell(@cmd);
+}
+
+############
+############ PREPROCESSING
+############
+#
+# All flavors of preprocessing return the destination file
+#
+
+# THIS IS THE ENTRY POINT FOR COMPILING SOURCE FILES
+sub preprocess_compile {
+ my ($self, $src, $dest, $early_ppargs, $ppargs, $ccargs) = @_;
+ &mydebug("preprocess_compile(src=$src, dest=$dest)\n");
+ Carp::confess "bad dest: $dest" unless $dest->isa('OutputFile');
+
+ my ($base, $dir, $ext) = fileparse($src, "\\.[^.]+");
+ if($ext eq ".c" || $ext eq ".cpp" || $ext eq ".cc") {
+ if($self->leaveAlone($src)) {
+ print "Leaving alone $src\n";
+ # We leave this alone. So just compile as usual
+ return $self->straight_compile($src, $dest, [@{$early_ppargs}, @{$ppargs}], $ccargs);
+ }
+ my $out = $self->preprocessOutputFile($src);
+ $out = $self->preprocess($src, $out,
+ [@{$early_ppargs}, @{$ppargs},
+ "$self->{DEFARG}CIL=1"]);
+ return $self->compile($out, $dest, $ppargs, $ccargs);
+ }
+ if($ext eq ".i") {
+ return $self->compile($src, $dest, $ppargs, $ccargs);
+ }
+ if($ext eq ".$::cilbin") {
+ return $self->compile($src, $dest, $ppargs, $ccargs);
+ }
+}
+
+# THIS IS THE ENTRY POINT FOR JUST PREPROCESSING A FILE
+sub preprocess {
+ my($self, $src, $dest, $ppargs) = @_;
+ Carp::confess "bad dest: $dest" unless $dest->isa('OutputFile');
+ return $self->preprocess_before_cil($src, $dest, $ppargs);
+}
+
+# Find the name of the preprocessed file before CIL processing
+sub preprocessOutputFile {
+ my($self, $src) = @_;
+ return $self->outputFile($src, 'i');
+}
+
+# Find the name of the preprocessed file after CIL processing
+sub preprocessAfterOutputFile {
+ my($self, $src) = @_;
+ return $self->outputFile($src, 'cil.i');
+}
+
+# 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('OutputFile');
+ my @args = @{$ppargs};
+
+ # See if we must force some includes
+ if(defined $self->{INCLUDEDIR} && !defined($ENV{"CILLY_NOCURE"})) {
+ # And force the other includes. Put them at the begining
+ if(($self->{MODENAME} eq 'GNUCC') &&
+ # sm: m88k doesn't work if I pass -I.
+ $self->{IDASHDOT}) {
+ unshift @args, "-I.";
+ }
+ if(! defined($self->{VERSION})) {
+ $self->setVersion();
+ }
+ unshift @args,
+ map { my $dir = $_;
+ $self->{INCARG} . $dir . "/" . $self->{VERSION} }
+ @{$self->{INCLUDEDIR}};
+ #matth: include the main include dir as well as the compiler-specific directory
+ unshift @args,
+ map { my $dir = $_;
+ $self->{INCARG} . $dir }
+ @{$self->{INCLUDEDIR}};
+ if($self->{MODENAME} eq 'GNUCC') {
+ # sm: this is incompatible with wu-ftpd, but is apparently needed
+ # for apache.. more investigation is needed
+ # update: now when I try it, apache works without -I- also.. but
+ # I'll make this into a switchable flag anyway
+ # matth: this breaks other tests. Let's try without.
+# if ($self->{IDASHI}) {
+# unshift @args, "-I-";
+# }
+ }
+ }
+
+ return $self->straight_preprocess($src, $dest, \@args);
+}
+
+# Preprocessing after CIL
+sub preprocess_after_cil {
+ my ($self, $src, $dest, $ppargs) = @_;
+ Carp::confess "bad dest: $dest" unless $dest->isa('OutputFile');
+ return $self->straight_preprocess($src, $dest, $ppargs);
+}
+
+#
+# This is intended to be the true invocation of the underlying preprocessor
+# You should not override this method
+sub straight_preprocess {
+ my ($self, $src, $dest, $ppargs) = @_;
+ Carp::confess "bad dest: $dest" unless $dest->isa('OutputFile');
+ if($self->{VERBOSE}) {
+ my $srcname = ref $src ? $src->filename : $src;
+ print STDERR "Preprocessing $srcname\n";
+ }
+ if($self->{MODENAME} eq "MSVC" ||
+ $self->{MODENAME} eq "MSLINK" ||
+ $self->{MODENAME} eq "MSLIB") {
+ $self->MSVC::msvc_preprocess($src, $dest, $ppargs);
+ } else {
+# print Dumper($self);
+ my @cmd = (@{$self->{CPP}}, @{$ppargs},
+ $src, $self->makeOutArguments($self->{OUTCPP}, $dest));
+ $self->runShell(@cmd);
+
+ }
+ return $dest;
+}
+
+
+#
+#
+#
+# COMPILATION
+#
+#
+
+sub compile {
+ my($self, $src, $dest, $ppargs, $ccargs) = @_;
+ &mydebug("Cilly.compile(src=$src, dest=$dest->{filename})\n");
+ Carp::confess "bad dest: $dest->{filename}"
+ unless $dest->isa('OutputFile');
+
+ if($self->{SEPARATE}) {
+ # Now invoke CIL and compile afterwards
+ return $self->applyCilAndCompile([$src], $dest, $ppargs, $ccargs);
+ }
+ # We are merging
+ # If we are merging then we just save the preprocessed source
+ my ($mtime, $res, $outfile);
+ if(! $self->{TRUEOBJ}) {
+ $outfile = $dest->{filename}; $mtime = 0; $res = $dest;
+ } else {
+ # Do the real compilation
+ $res = $self->straight_compile($src, $dest, $ppargs, $ccargs);
+ # 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)) {
+ die "Cannot stat the result of compilation $dest->{filename}";
+ }
+ $mtime = $mtime_1;
+ $outfile = $dest->{filename} . $Cilly::savedSourceExt;
+ }
+ 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;
+ $toprintsrc =~ s|\\|/|g;
+ print OUT "#pragma merger($mtime,\"$toprintsrc\",\"" .
+ join(',', @{$ccargs}), "\")\n";
+ open(IN, '<', $srcname) || die "Cannot read $srcname";
+ while(<IN>) {
+ print OUT $_;
+ }
+ close(OUT);
+ close(IN);
+ return $res;
+}
+
+sub makeOutArguments {
+ my ($self, $which, $dest) = @_;
+ $dest = $dest->{filename} if ref $dest;
+ if($self->{MODENAME} eq "MSVC" ||
+ $self->{MODENAME} eq "MSLINK" ||
+ $self->{MODENAME} eq "MSLIB") {
+ # A single argument
+ return ("$which$dest");
+ } else {
+ return ($which, $dest);
+ }
+}
+# This is the actual invocation of the underlying compiler. You should not
+# 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";
+ }
+ my @dest =
+ $dest eq "" ? () : $self->makeOutArguments($self->{OUTOBJ}, $dest);
+ my @forcec = @{$self->{FORCECSOURCE}};
+ my @cmd = (@{$self->{CC}}, @{$ppargs}, @{$ccargs},
+ @dest, @forcec, $src);
+ return $self->runShell(@cmd);
+}
+
+# This is compilation after CIL
+sub compile_cil {
+ my ($self, $src, $dest, $ppargs, $ccargs) = @_;
+ return $self->straight_compile($src, $dest, $ppargs, $ccargs);
+}
+
+
+
+# THIS IS THE ENTRY POINT FOR JUST ASSEMBLING FILES
+sub assemble {
+ my ($self, $src, $dest, $ppargs, $ccargs) = @_;
+ if($self->{VERBOSE}) { print STDERR "Assembling $src\n"; }
+ my @dest =
+ $dest eq "" ? () : $self->makeOutArguments($self->{OUTOBJ}, $dest);
+ my @cmd = (@{$self->{CC}}, @{$ppargs}, @{$ccargs},
+ @dest, $src);
+ return $self->runShell(@cmd);
+}
+
+
+
+#
+# This is intended to be the true invocation of the underlying linker
+# You should not override this method
+sub straight_link {
+ my ($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_;
+ my @sources = ref($psrcs) ? @{$psrcs} : ($psrcs);
+ my @dest =
+ $dest eq "" ? () : $self->makeOutArguments($self->{OUTEXE}, $dest);
+ # Pass the linkargs last because some libraries must be passed after
+ # the sources
+ my @cmd = (@{$self->{LD}}, @dest,
+ @{$ppargs}, @{$ccargs}, @sources, @{$ldargs});
+ return $self->runShell(@cmd);
+}
+
+#
+# See if some libraries are actually lists of files
+sub expandLibraries {
+ my ($self) = @_;
+
+ my @tolink = @{$self->{OFILES}};
+
+ # Go through the sources and replace all libraries with the files that
+ # they contain
+ my @tolink1 = ();
+ 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
+ # list of files
+ if($src =~ m|\.$self->{LIBEXT}$| && -f "$src.files") {
+ open(FILES, "<$src.files") || die "Cannot read $src.files";
+ while(<FILES>) {
+ # Put them back in the "tolink" to process them recursively
+ while($_ =~ m|[\r\n]$|) {
+ chop;
+ }
+ unshift @tolink, $_;
+ }
+ close(FILES);
+ next;
+ }
+ # This is not for us
+ push @tolink1, $src;
+ next;
+ }
+ $self->{OFILES} = \@tolink1;
+}
+
+# Go over a list of object files and separate them into those that are
+# actually sources to be merged, and the true object files
+#
+sub separateTrueObjects {
+ my ($self, $psrcs, $ccargs) = @_;
+
+ my @sources = @{$psrcs};
+# print "Sources are @sources\n";
+ my @tomerge = ();
+ my @othersources = ();
+
+ my @ccmerged = @{$ccargs};
+ foreach my $src (@sources) {
+ my ($combsrc, $combsrcname, $mtime);
+ my $srcname = ref $src ? $src->filename : $src;
+ if(! $self->{TRUEOBJ}) {
+ # We are using the object file itself to save the sources
+ $combsrcname = $srcname;
+ $combsrc = $src;
+ $mtime = 0;
+ } else {
+ $combsrcname = $srcname . $Cilly::savedSourceExt;
+ $combsrc = $combsrcname;
+ if(-f $combsrcname) {
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime_1,$ctime,$blksize,$blocks) = stat($srcname);
+ $mtime = $mtime_1;
+ } else {
+ $mtime = 0;
+ }
+ }
+ # Look inside and see if it is one of the files created by us
+ open(IN, "<$combsrcname") || die "Cannot read $combsrcname";
+ my $fstline = <IN>;
+ close(IN);
+ if($fstline =~ m|CIL|) {
+ goto ToMerge;
+ }
+ if($fstline =~ m|^\#pragma merger\((\d+),\".*\",\"(.*)\"\)$|) {
+ my $mymtime = $1;
+ # Get the CC flags
+ my @thisccargs = split(/,/, $2);
+ foreach my $arg (@thisccargs) {
+ # print "Looking at $arg\n ccmerged=@ccmerged\n";
+ if(! grep(/$arg/, @ccmerged)) {
+ # print " adding it\n";
+ push @ccmerged, $arg
+ }
+ }
+ ToMerge:
+ if($mymtime == $mtime) { # It is ours
+ # See if we have this already
+ if(! grep { $_ eq $srcname } @tomerge) { # It is ours
+ push @tomerge, $combsrc;
+ # See if there is a a trueobjs file also
+ my $trueobjs = $combsrcname . "_trueobjs";
+ if(-f $trueobjs) {
+ open(TRUEOBJS, "<$trueobjs")
+ || die "Cannot read $trueobjs";
+ while(<TRUEOBJS>) {
+ chop;
+ push @othersources, $_;
+ }
+ close(TRUEOBJS);
+ }
+ }
+ next;
+ }
+ }
+ push @othersources, $combsrc;
+ }
+ # If we are merging, turn off "warnings are errors" flag
+ if(grep(/$self->{WARNISERROR}/, @ccmerged)) {
+ @ccmerged = grep(!/$self->{WARNISERROR}/, @ccmerged);
+ print STDERR "Turning off warn-is-error flag $self->{WARNISERROR}\n";
+ }
+
+ return (\@tomerge, \@othersources, \@ccmerged);
+}
+
+
+# Customize the linking
+sub link {
+ my($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_;
+ my $destname = ref $dest ? $dest->filename : $dest;
+ if($self->{SEPARATE}) {
+ 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,
+ $ppargs, $ccargs, $ldargs);
+ }
+ else {
+ return 0; # sm: is this value used??
+ }
+ }
+ my $outname = ($self->{OPERATION} eq "TOASM") ? $destname
+ : "${destname}_comb.$self->{OBJEXT}";
+ my $mergedobj = new OutputFile($destname, $outname);
+
+ # We must merge
+ 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) =
+ $self->separateTrueObjects($psrcs, $ccargs);
+
+ if($self->{VERBOSE}) {
+ print STDERR "Will merge the following: ",
+ join(' ', @{$tomerge}), "\n";
+ print STDERR "Will just link the genuine object files: ",
+ join(' ', @{$trueobjs}), "\n";
+ print STDERR "After merge compile flags: @{$ccargs}\n";
+ }
+ # Check the modification times and see if we can just use the combined
+ # file instead of merging all over again
+ if(@{$tomerge} > 1 && $self->{KEEPMERGED}) {
+ my $canReuse = 1;
+ my $combFile = new OutputFile($destname,
+ "${destname}_comb.c");
+ my @tmp = stat($combFile);
+ my $combFileMtime = $tmp[9] || 0;
+ foreach my $mrg (@{$tomerge}) {
+ my @tmp = stat($mrg); my $mtime = $tmp[9];
+ if($mtime >= $combFileMtime) { goto DoMerge; }
+ }
+ if($self->{VERBOSE}) {
+ print STDERR "Reusing merged file $combFile\n";
+ }
+ $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".
+ " for the output."
+ }
+ # Don't use ld on assembly files. The -S in CCARGS has already
+ # generated the right format of output.
+ return;
+ }
+
+ # Put the merged OBJ at the beginning because maybe some of the trueobjs
+ # are libraries which like to be at the end
+ unshift @{$trueobjs}, $mergedobj;
+
+ # And finally link
+ # zf: hack for linking linux stuff
+ if ($self->{TRUELIB}) {
+ my @cmd = (@{$self->{LDLIB}}, ($dest),
+ @{$ppargs}, @{$ccargs}, @{$trueobjs}, @{$ldargs});
+ return $self->runShell(@cmd);
+ }
+
+ # sm: hack: made this conditional for dsw
+ if (!defined($ENV{CILLY_DONT_LINK_AFTER_MERGE})) {
+ $self->link_after_cil($trueobjs, $dest, $ppargs, $ccargs, $ldargs);
+ }
+
+}
+
+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"
+ unless $aftercil->isa('OutputFile');
+
+ if($self->{MODENAME} eq "MSVC" ||
+ $self->{MODENAME} eq "MSLINK" ||
+ $self->{MODENAME} eq "MSLIB") {
+ push @cmd, '--MSVC';
+ }
+ if($self->{VERBOSE}) {
+ push @cmd, '--verbose';
+ }
+ if(defined $self->{CILARGS}) {
+ push @cmd, @{$self->{CILARGS}};
+ }
+
+ # Add the arguments
+ if(@srcs > 20) {
+ my $extraFile = "___extra_files";
+ open(TOMERGE, ">$extraFile") || die $!;
+ foreach my $fl (@srcs) {
+ my $fname = ref $fl ? $fl->filename : $fl;
+ print TOMERGE "$fname\n";
+ }
+ close(TOMERGE);
+ push @cmd, '--extrafiles', $extraFile;
+ } else {
+ push @cmd, @srcs;
+ }
+ if(@srcs > 1 && $self->{KEEPMERGED}) {
+ my ($base, $dir, undef) = fileparse($dest->filename, qr{\.[^.]+});
+ push @cmd, '--mergedout', "$dir$base" . '.c';
+ }
+ # Now run cilly
+ $self->runShell(@cmd);
+
+ # Tell the caller where we put the output
+ return $aftercil;
+}
+
+
+sub applyCilAndCompile {
+ my ($self, $ppsrc, $dest, $ppargs, $ccargs) = @_;
+ Carp::confess "$self produced bad destination file: $dest"
+ unless $dest->isa('OutputFile');
+
+ # The input files
+ my @srcs = @{$ppsrc};
+ &mydebug("Cilly.PM.applyCilAndCompile(srcs=[",join(',',@{$ppsrc}),"])\n");
+
+ # Now run cilly
+ my $aftercil = $self->applyCil($ppsrc, $dest);
+ Carp::confess "$self produced bad output file: $aftercil"
+ unless $aftercil->isa('OutputFile');
+
+ # Now preprocess
+ my $aftercilpp = $self->preprocessAfterOutputFile($aftercil);
+ $self->preprocess_after_cil($aftercil, $aftercilpp, $ppargs);
+
+ if (!defined($ENV{CILLY_DONT_COMPILE_AFTER_MERGE})) {
+ # Now compile
+ return $self->compile_cil($aftercilpp, $dest, $ppargs, $ccargs);
+ }
+}
+
+# Linking after CIL
+sub link_after_cil {
+ my ($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_;
+ if (!defined($ENV{CILLY_DONT_COMPILE_AFTER_MERGE})) {
+ return $self->straight_link($psrcs, $dest, $ppargs, $ccargs, $ldargs);
+ }
+}
+
+# See if we must merge this one
+sub leaveAlone {
+ my($self, $filename) = @_;
+ my ($base, $dir, $ext) = fileparse($filename, "(\\.[^.]+)");
+ if(grep { $_ eq $base } @{$self->{LEAVEALONE}}) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+
+# DO EVERYTHING
+sub doit {
+ my ($self) = @_;
+ my $file;
+ my $out;
+
+ $self->processArguments();
+
+# print Dumper($self);
+
+ # Maybe we must preprocess only
+ if($self->{OPERATION} eq "TOI" || $self->{OPERATION} eq 'SPECIAL') {
+ # Then we do not do anything
+ my @cmd = (@{$self->{CPP}},
+ @{$self->{EARLY_PPARGS}},
+ @{$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
+ # 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
+ # 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
+ # object file is a disguised source
+ my $turnOffMerging = 0;
+ if(@{$self->{OFILES}}) {
+ my ($tomerge, $trueobjs, $mergedccargs) =
+ $self->separateTrueObjects($self->{OFILES}, $self->{CCARGS});
+ $self->{CCARGS} = $mergedccargs;
+ $turnOffMerging = (@{$tomerge} == 0);
+ } else {
+ $turnOffMerging = 1;
+ }
+ if($turnOffMerging) {
+ if($self->{VERBOSE}) {
+ print STDERR
+ "Turn off merging because the program contains one file\n";
+ }
+ $self->{SEPARATE} = 1;
+ }
+ }
+
+ # Turn everything into OBJ files
+ my @tolink = ();
+
+ foreach $file (@{$self->{IFILES}}, @{$self->{CFILES}}) {
+ $out = $self->compileOutputFile($file);
+ $self->preprocess_compile($file, $out,
+ $self->{EARLY_PPARGS},
+ $self->{PPARGS}, $self->{CCARGS});
+ push @tolink, $out;
+ }
+ # Now do the assembly language file
+ foreach $file (@{$self->{SFILES}}) {
+ $out = $self->assembleOutputFile($file);
+ $self->assemble($file, $out,
+ $self->{EARLY_PPARGS},
+ $self->{PPARGS}, $self->{CCARGS});
+ push @tolink, $out;
+ }
+ # Now add the original object files. Put them last because libraries like
+ # to be last.
+ push @tolink, @{$self->{OFILES}};
+
+ # See if we must stop after compilation
+ if($self->{OPERATION} eq "TOOBJ") {
+ return;
+ }
+ if(($self->{OPERATION} eq "TOASM") && $self->{SEPARATE}) {
+ return;
+ }
+
+ # See if we must create a library only
+ if($self->{OPERATION} eq "TOLIB") {
+ if (!$self->{TRUELIB}) {
+ # zf: Creating a library containing merged source
+ $out = $self->linkOutputFile(@tolink);
+ $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
+ # 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->{PPARGS}, $self->{CCARGS}, $self->{LINKARGS});
+ return;
+ }
+
+ }
+
+ # 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->{PPARGS}, $self->{CCARGS}, $self->{LINKARGS});
+ return;
+ }
+
+ die "I don't understand OPERATION:$self->{OPERATION}\n";
+}
+
+sub classifyArgDebug {
+ if(0) { print @_; }
+}
+
+sub mydebug {
+ if(0) { print @_; }
+}
+
+sub compilerArgument {
+ my($self, $options, $arg, $pargs) = @_;
+ &classifyArgDebug("Classifying arg: $arg\n");
+ my $idx = 0;
+ for($idx=0; $idx < $#$options; $idx += 2) {
+ my $key = ${$options}[$idx];
+ my $action = ${$options}[$idx + 1];
+ &classifyArgDebug("Try match with $key\n");
+ if($arg =~ m|^$key|) {
+ &classifyArgDebug(" match with $key\n");
+ my @fullarg = ($arg);
+ my $onemore;
+ if(defined $action->{'ONEMORE'}) {
+ &classifyArgDebug(" expecting one more\n");
+ # Maybe the next arg is attached
+ my $realarg;
+ ($realarg, $onemore) = ($arg =~ m|^($key)(.+)$|);
+ if(! defined $onemore) {
+ # Grab the next argument
+ $onemore = $self->fetchNextArg($pargs);
+ $onemore = "eIfNecessary($onemore);
+ push @fullarg, $onemore;
+ } else {
+ $onemore = "eIfNecessary($onemore);
+ }
+ &classifyArgDebug(" onemore=$onemore\n");
+ }
+ # Now see what action we must perform
+ my $argument_done = 1;
+ if(defined $action->{'RUN'}) {
+ &{$action->{'RUN'}}($self, @fullarg, $onemore, $pargs);
+ $argument_done = 1;
+ }
+ # Quote special SHELL caracters
+ @fullarg = map { $_ =~ s%([<>;&|])%'$1'%g; $_ } @fullarg;
+ # print "fullarg = ", @fullarg, "\n";
+ if(defined $action->{'TYPE'}) {
+ &classifyArgDebug(" type=$action->{TYPE}\n");
+ if($action->{TYPE} eq 'EARLY_PREPROC') {
+ push @{$self->{EARLY_PPARGS}}, @fullarg; return 1;
+ }
+ elsif($action->{TYPE} eq "PREPROC") {
+ push @{$self->{PPARGS}}, @fullarg; return 1;
+ }
+ elsif($action->{TYPE} eq 'SPECIAL') {
+ push @{$self->{PPARGS}}, @fullarg;
+ $self->{OPERATION} = 'SPECIAL';
+ return 1;
+ }
+ elsif($action->{TYPE} eq "CC") {
+ push @{$self->{CCARGS}}, @fullarg; return 1;
+ }
+ elsif($action->{TYPE} eq "LINKCC") {
+ 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->{LINKARGS}}, @fullarg; return 1;
+ }
+ elsif($action->{TYPE} eq "LINK") {
+ push @{$self->{LINKARGS}}, @fullarg; return 1;
+ }
+ elsif($action->{TYPE} eq "CSOURCE") {
+ OutputFile->protect(@fullarg);
+ $fullarg[0] = &normalizeFileName($fullarg[0]);
+ push @{$self->{CFILES}}, @fullarg; return 1;
+ }
+ elsif($action->{TYPE} eq "ASMSOURCE") {
+ OutputFile->protect(@fullarg);
+ $fullarg[0] = &normalizeFileName($fullarg[0]);
+ push @{$self->{SFILES}}, @fullarg; return 1;
+ }
+ elsif($action->{TYPE} eq "OSOURCE") {
+ OutputFile->protect(@fullarg);
+ $fullarg[0] = &normalizeFileName($fullarg[0]);
+ push @{$self->{OFILES}}, @fullarg; return 1;
+ }
+ elsif($action->{TYPE} eq "ISOURCE") {
+ OutputFile->protect(@fullarg);
+ $fullarg[0] = &normalizeFileName($fullarg[0]);
+ push @{$self->{IFILES}}, @fullarg; return 1;
+ }
+ elsif($action->{TYPE} eq 'OUT') {
+ if(defined($self->{OUTARG})) {
+ print "Warning: output file is multiply defined: @{$self->{OUTARG}} and @fullarg\n";
+ }
+ $fullarg[0] = &normalizeFileName($fullarg[0]);
+ $self->{OUTARG} = [@fullarg]; return 1;
+ }
+ print " Do not understand TYPE\n"; return 1;
+ }
+ if($argument_done) { return 1; }
+ print "Don't know what to do with option $arg\n";
+ return 0;
+ }
+ }
+ return 0;
+}
+
+
+sub runShell {
+ my ($self, @cmd) = @_;
+
+ my $msvcFriends =
+ ($self->{MODENAME} eq "MSVC" ||
+ $self->{MODENAME} eq "MSLINK" ||
+ $self->{MODENAME} eq "MSLIB");
+
+ foreach (@cmd) {
+ $_ = $_->filename if ref;
+ # If we are in MSVC mode then we might have to convert the files
+ # from cygwin names to the actual Windows names
+ if($msvcFriends && $^O eq "cygwin") {
+ my $arg = $_;
+ if ($arg =~ m|^/| && -f $arg) {
+ my $mname = `cygpath -m $arg`;
+ chop $mname;
+ if($mname ne "") { $_ = $mname; }
+ }
+ }
+ }
+
+ # sm: I want this printed to stderr instead of stdout
+ # because the rest of 'make' output goes there and this
+ # way I can capture to a coherent file
+ # sm: removed conditional on verbose since there's already
+ # so much noise in the output, and this is the *one* piece
+ # of information I *always* end up digging around for..
+ if($self->{TRACE_COMMANDS}) { print STDERR "@cmd\n"; }
+
+ # weimer: let's have a sanity check
+ my $code = system { $cmd[0] } @cmd;
+ if ($code != 0) {
+ # sm: now that we always print, don't echo the command again,
+ # since that makes the output more confusing
+ #die "Possible error with @cmd!\n";
+ $code >>= 8; # extract exit code portion
+
+ exit $code;
+ }
+ return $code;
+}
+
+sub quoteIfNecessary {
+ my($arg) = @_;
+ # If it contains spaces or "" then it must be quoted
+ if($arg =~ m|\s| || $arg =~ m|\"|) {
+ return "\'$arg\'";
+ } else {
+ return $arg;
+ }
+}
+
+
+sub cilOutputFile {
+ Carp::croak 'bad argument count' unless @_ == 3;
+ my ($self, $basis, $suffix) = @_;
+
+ if (defined $self->{SAVE_TEMPS}) {
+ return new KeptFile($basis, $suffix, $self->{SAVE_TEMPS});
+ } else {
+ return $self->outputFile($basis, $suffix);
+ }
+}
+
+
+sub outputFile {
+ Carp::confess 'bad argument count' unless @_ == 3;
+ my ($self, $basis, $suffix) = @_;
+
+ if (defined $self->{SAVE_TEMPS}) {
+ return new KeptFile($basis, $suffix, $self->{SAVE_TEMPS});
+ } else {
+ return new TempFile($basis, $suffix);
+ }
+}
+
+
+###########################################################################
+####
+#### MS CL specific code
+####
+package MSVC;
+
+use strict;
+use File::Basename;
+use Data::Dumper;
+
+# 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})) {
+ $self->{FIRST_SOURCE} = $src;
+ }
+}
+
+sub new {
+ my ($proto, $stub) = @_;
+ my $class = ref($proto) || $proto;
+ # Create $self
+
+ my $self =
+ { NAME => 'Microsoft cl compiler',
+ MODENAME => 'MSVC',
+ CC => ['cl', '/nologo', '/D_MSVC', '/c'],
+ CPP => ['cl', '/nologo', '/D_MSVC', '/P'],
+ LD => ['cl', '/nologo', '/D_MSVC'],
+ DEFARG => "/D",
+ INCARG => "/I",
+ DEBUGARG => ['/Zi', '/MLd', '/DEBUG'],
+ OPTIMARG => ['/Ox', '/G6'],
+ OBJEXT => "obj",
+ LIBEXT => "lib", # Library extension (without the .)
+ EXEEXT => ".exe", # Executable extension (with the .)
+ OUTOBJ => "/Fo",
+ OUTEXE => "/Fe",
+ WARNISERROR => "/WX",
+ FORCECSOURCE => ['/Tc'],
+ LINEPATTERN => "^#line\\s+(\\d+)\\s+\"(.+)\"",
+
+ 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.
+#
+# If the action contains TYPE => "..." then the argument is put into
+# one of several lists, as follows: "PREPROC" in ppargs; "CC" in
+# ccargs; "LINK" in linkargs; "LINKCC" both in ccargs and linkargs;
+# "ALLARGS" in ppargs, ccargs, and linkargs; "CSOURCE" in cfiles;
+# "ASMSOURCE" in sfiles; "OSOURCE" in ofiles; "ISOURCE" in ifiles;
+# "OUT" in outarg. "SPECIAL" flags indicate that the compiler should
+# be run directly so that it can perform some special action other
+# than generating code (e.g. printing out version or configuration
+# information).
+#
+# If the TYPE is not defined but the RUN => sub { ... } is defined then the
+# 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)\$" =>
+ { TYPE => 'CSOURCE',
+ RUN => sub { &MSVC::setFirstSource(@_); } },
+ "[^/].*\\.(asm)\$" => { TYPE => 'ASMSOURCE' },
+ "[^/].*\\.i\$" => { TYPE => 'ISOURCE' },
+ "[^/\\-@]" => { TYPE => "OSOURCE" },
+ "[/\\-]O" => { TYPE => "CC" },
+ "[/\\-][DI]" => { TYPE => "PREPROC"},
+ "[/\\-]EH" => { TYPE => "CC" },
+ "[/\\-]G" => { TYPE => "CC" },
+ "[/\\-]F[aA]" => { TYPE => 'CC' },
+ "[/\\-]Fo" => { TYPE => 'OUT' },
+ "/Fe" => { TYPE => 'OUT',
+ RUN => sub { $stub->{OPERATION} = "TOEXE" }},
+ "[/\\-]F[dprR]" => { TYPE => "CC" },
+ "[/\\-]FI" => { TYPE => "PREPROC" },
+ "[/\\-][CXu]" => { TYPE => "PREPROC" },
+ "[/\\-]U" => { ONEMORE => 1, TYPE => "PREPROC" },
+ "[/\\-](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 {
+ my $arg = $_[1];
+ my ($fname) = ($arg =~ m|[/\\-]Tc(.+)$|);
+ $fname = &normalizeFileName($fname);
+ push @{$stub->{CFILES}}, $fname;
+ }},
+ "[/\\-]v(d|m)" => { TYPE => "CC" },
+ "[/\\-]F" => { TYPE => "CC" },
+ "[/\\-]M" => { TYPE => 'LINKCC' },
+ "/link" => { RUN => sub { push @{$stub->{LINKARGS}}, "/link",
+ @{$_[3]};
+ @{$_[3]} = (); } },
+ "-cbstring" => { TYPE => "CC" },
+ "/" => { RUN =>
+ sub { print "Unimplemented MSVC argument $_[1]\n";}},
+ ],
+ };
+ bless $self, $class;
+ return $self;
+}
+
+
+sub msvc_preprocess {
+ my($self, $src, $dest, $ppargs) = @_;
+ my $res;
+ my $srcname = ref $src ? $src->filename : $src;
+ 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
+ # cl to force this file to be interpreted as a C one
+ my @cmd = @{$ppargs};
+
+ if($sext eq ".cpp") {
+ push @cmd, "/Tc";
+ }
+ # MSVC cannot be told where to put the output. But we know that it
+ # puts it in the current directory
+ my $msvcout = "./$sbase.i";
+ if($self->{STDOUTPP}) {
+ @cmd = ('cmd', '/c', 'cl', '/nologo', '/E', ">$msvcout", '/D_MSVC',
+ @cmd);
+
+ } else {
+ @cmd = ('cl', '/nologo', '/P', '/D_MSVC', @cmd);
+ }
+ $res = $self->runShell(@cmd, $srcname);
+ # Check file equivalence by making sure that all elements of the stat
+ # structure are the same, except for the access time.
+ my @st1 = stat $msvcout; $st1[8] = 0;
+ my @st2 = stat $dest->{filename}; $st2[8] = 0;
+ # print Dumper(\@st1, \@st2);
+ if($msvcout ne $dest->{filename}) {
+ while($#st1 >= 0) {
+ if(shift @st1 != shift @st2) {
+# print "$msvcout is NOT the same as $afterpp\n";
+ if($self->{VERBOSE}) {
+ print STDERR "Copying $msvcout to $dest->{filename} (MSVC_preprocess)\n";
+ }
+ unlink $dest;
+ File::Copy::copy($msvcout, $dest->filename);
+ unlink $msvcout;
+ return $res;
+ }
+ }
+ }
+ return $res;
+}
+
+sub forceIncludeArg {
+ my($self, $what) = @_;
+ return "/FI$what";
+}
+
+
+ # MSVC does not understand the extension .i, so we tell it it is a C file
+sub fixupCsources {
+ my (@csources) = @_;
+ my @mod_csources = ();
+ my $src;
+ foreach $src (@csources) {
+ my ($sbase, $sdir, $sext) = fileparse($src,
+ "\\.[^.]+");
+ if($sext eq ".i") {
+ push @mod_csources, "/Tc";
+ }
+ push @mod_csources, $src;
+ }
+ return @mod_csources;
+}
+
+
+# Emit a line # directive
+sub lineDirective {
+ my ($self, $fileName, $lineno) = @_;
+ return "#line $lineno \"$fileName\"\n";
+}
+
+# The name of the output file
+sub compileOutputFile {
+ my($self, $src) = @_;
+
+ die "compileOutputFile: not a C source file: $src\n"
+ unless $src =~ /\.($::cilbin|c|cc|cpp|i|asm)$/;
+
+ Carp::carp ("compileOutputFile: $self->{OPERATION}, $src",
+ Dumper($self->{OUTARG})) if 0;
+ if ($self->{OPERATION} eq 'TOOBJ') {
+ if(defined $self->{OUTARG}
+ && "@{$self->{OUTARG}}" =~ m|[/\\-]Fo(.+)|) {
+ my $dest = $1;
+ # Perhaps $dest is a directory
+ if(-d $dest) {
+ return new KeptFile($src, $self->{OBJEXT}, $dest);
+ } else {
+ return new OutputFile($src, $1);
+ }
+ } else {
+ return new KeptFile($src, $self->{OBJEXT}, '.');
+ }
+ } else {
+# die "compileOutputfile: operation is not TOOBJ";
+ return $self->outputFile($src, $self->{OBJEXT});
+ }
+}
+
+sub assembleOutputFile {
+ my($self, $src) = @_;
+ return $self->compileOutputFile($src);
+}
+
+sub linkOutputFile {
+ my($self, $src) = @_;
+ $src = $src->filename if ref $src;
+ if(defined $self->{OUTARG} && "@{$self->{OUTARG}}" =~ m|/Fe(.+)|) {
+ return $1;
+ }
+ # Use the name of the first source file, in the current directory
+ my ($base, $dir, $ext) = fileparse ($src, "\\.[^.]+");
+ return "./$base.exe";
+}
+
+sub setVersion {
+ my($self) = @_;
+ my $cversion = "";
+ open(VER, "cl 2>&1|") || die "Cannot start Microsoft CL\n";
+ while(<VER>) {
+ if($_ =~ m|Compiler Version (\S+) |) {
+ $cversion = "cl_$1";
+ close(VER);
+ $self->{VERSION} = $cversion;
+ return;
+ }
+ }
+ die "Cannot find Microsoft CL version\n";
+}
+
+########################################################################
+##
+## MS LINK specific code
+##
+###
+package MSLINK;
+
+use strict;
+
+use File::Basename;
+use Data::Dumper;
+
+sub new {
+ my ($proto, $stub) = @_;
+ my $class = ref($proto) || $proto;
+
+ # Create a MSVC compiler object
+ my $msvc = MSVC->new($stub);
+
+ # Create $self
+
+ my $self =
+ { NAME => 'Microsoft linker',
+ MODENAME => 'MSLINK',
+ CC => $msvc->{CC},
+ CPP => $msvc->{CPP},
+ LD => ['link'],
+ DEFARG => $msvc->{DEFARG},
+ INCARG => $msvc->{INCARG},
+ DEBUGARG => ['/DEBUG'],
+ OPTIMARG => [],
+ LDLIB => ['lib'],
+ OBJEXT => "obj",
+ LIBEXT => "lib", # Library extension (without the .)
+ EXEEXT => ".exe", # Executable extension (with the .)
+ OUTOBJ => $msvc->{OUTOBJ},
+ OUTEXE => "-out:", # Keep this form because build.exe looks for it
+ WARNISERROR => "/WX",
+ LINEPATTERN => "",
+ FORCECSOURCE => $msvc->{FORCECSOURCE},
+
+ MSVC => $msvc,
+
+ OPTIONS =>
+ ["[^/\\-@]" => { TYPE => 'OSOURCE' },
+ "[/\\-](OUT|out):" => { TYPE => 'OUT' },
+ "^((/)|(\\-[^\\-]))" => { TYPE => 'LINK' },
+ ],
+ };
+ bless $self, $class;
+ return $self;
+}
+
+
+sub forceIncludeArg { # Same as for CL
+ my($self, $what) = @_;
+ return "/FI$what";
+}
+
+
+
+sub linkOutputFile {
+ my($self, $src) = @_;
+# print Dumper($self);
+ Carp::confess "Cannot compute the linker output file"
+ if ! defined $self->{OUTARG};
+
+ if("@{$self->{OUTARG}}" =~ m|.+:(.+)|) {
+ return $1;
+ }
+ die "I do not know what is the link output file\n";
+}
+
+sub setVersion {
+ my($self) = @_;
+ my $cversion = "";
+ open(VER, "link 2>&1|") || die "Cannot start Microsoft LINK\n";
+ while(<VER>) {
+ if($_ =~ m|Linker Version (\S+)|) {
+ $cversion = "link_$1";
+ close(VER);
+ $self->{VERSION} = $cversion;
+ return;
+ }
+ }
+ die "Cannot find Microsoft LINK version\n";
+}
+
+########################################################################
+##
+## MS LIB specific code
+##
+###
+package MSLIB;
+
+our @ISA = qw(MSLINK);
+
+use strict;
+
+use File::Basename;
+use Data::Dumper;
+
+sub new {
+ my ($proto, $stub) = @_;
+ my $class = ref($proto) || $proto;
+
+ # Create a MSVC linker object
+ my $self = MSLINK->new($stub);
+
+ $self->{NAME} = 'Microsoft librarian';
+ $self->{MODENAME} = 'MSLIB';
+ $self->{OPERATION} = "TOLIB";
+ $self->{LDLIB} = ['lib'];
+ bless $self, $class;
+ return $self;
+}
+
+sub setVersion {
+ my($self) = @_;
+ my $cversion = "";
+ open(VER, "lib 2>&1|") || die "Cannot start Microsoft LIB\n";
+ while(<VER>) {
+ if($_ =~ m|Library Manager Version (\S+)|) {
+ $cversion = "lib_$1";
+ close(VER);
+ $self->{VERSION} = $cversion;
+ return;
+ }
+ }
+ die "Cannot find Microsoft LINK version\n";
+}
+
+########################################################################
+##
+## GNU ar specific code
+##
+###
+package AR;
+
+use strict;
+
+use File::Basename;
+use Data::Dumper;
+
+sub new {
+ my ($proto, $stub) = @_;
+ my $class = ref($proto) || $proto;
+ # Create $self
+
+ my $self =
+ { NAME => 'Archiver',
+ MODENAME => 'ar',
+ CC => ['no_compiler_in_ar_mode'],
+ CPP => ['no_compiler_in_ar_mode'],
+ LDLIB => ['ar', 'crv'],
+ DEFARG => "??DEFARG",
+ INCARG => '??INCARG',
+ DEBUGARG => ['??DEBUGARG'],
+ OPTIMARG => [],
+ OBJEXT => "o",
+ LIBEXT => "a", # Library extension (without the .)
+ EXEEXT => "", # Executable extension (with the .)
+ OUTOBJ => "??OUTOBJ",
+ OUTLIB => "", # But better be first
+ LINEPATTERN => "",
+
+ OPTIONS =>
+ ["^[^-]" => { RUN => \&arArguments } ]
+
+ };
+ bless $self, $class;
+ return $self;
+}
+
+# We handle arguments in a special way for AR
+sub arArguments {
+ my ($self, $arg, $onemore, $pargs) = @_;
+ # If the first argument starts with -- pass it on
+ if($arg =~ m|^--|) {
+ return 0;
+ }
+ # We got here for the first non -- argument.
+ # Will handle all arguments at once
+ if($self->{VERBOSE}) {
+ print "AR called with $arg @{$pargs}\n";
+ }
+
+ #The r flag is required:
+ if($arg !~ m|r| || $#{$pargs} < 0) {
+ die "Error: CCured's AR mode implements only the r and cr operations.";
+ }
+ if($arg =~ /[^crvus]/) {
+ die "Error: CCured's AR mode supports only the c, r, u, s, and v flags.";
+ }
+ if($arg =~ /v/) {
+ $self->{VERBOSE} = 1;
+ }
+
+ if($arg =~ /c/)
+ {
+ # Command is "cr":
+ # Get the name of the library
+ my $out = shift @{$pargs};
+ $self->{OUTARG} = [$out];
+ unlink $out;
+ }
+ else
+ {
+ # 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.
+ if(-f $out) {
+
+ my $temp_name = $out . "_old.a";
+ if($self->{VERBOSE}) {
+ print "Copying $out to $temp_name so we can add "
+ . "to it.\n";
+ }
+ if(-f $temp_name) {
+ unlink $temp_name;
+ }
+ rename $out, $temp_name;
+
+ #now use $temp_name as the input. $self->{OUTARG} will,
+ # as usual, be the output.
+ push @{$self->{OFILES}}, $temp_name;
+ } else {
+ warn "Library $out not found; creating.";
+ }
+
+ }
+
+ # The rest of the arguments must be object files
+ push @{$self->{OFILES}}, @{$pargs};
+ $self->{OPERATION} = 'TOLIB';
+ @{$pargs} = ();
+# print Dumper($self);
+ return 1;
+}
+
+sub linkOutputFile {
+ my($self, $src) = @_;
+ if(defined $self->{OUTARG}) {
+ return "@{$self->{OUTARG}}";
+ }
+ die "I do not know what is the link output file\n";
+}
+
+sub setVersion {
+ # sm: bin/cilly wants this for all "compilers"
+}
+
+
+#########################################################################
+##
+## GNUCC specific code
+##
+package GNUCC;
+
+use strict;
+
+use File::Basename;
+
+# The variable $::cc is inherited from the main script!!
+
+sub new {
+ my ($proto, $stub) = @_;
+ my $class = ref($proto) || $proto;
+ # Create $self
+
+ my @native_cc = Text::ParseWords::shellwords($ENV{CILLY_NATIVE_CC} || $::cc);
+
+ 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
+ # sm: removed -O to ease debugging; will address "inline extern" elsewhere
+ CC => [@native_cc, '-D_GNUCC', '-c'],
+ LD => [@native_cc, '-D_GNUCC'],
+ LDLIB => ['ld', '-r', '-o'],
+ CPP => [@native_cc, '-D_GNUCC', '-E'],
+ DEFARG => "-D",
+ INCARG => "-I",
+ DEBUGARG => ['-g', '-ggdb'],
+ OPTIMARG => ['-O4'],
+ CPROFILEARG => '-pg',
+ LPROFILEARG => '-pg',
+ OBJEXT => "o",
+ LIBEXT => "a",
+ EXEEXT => "",
+ OUTOBJ => '-o',
+ OUTEXE => '-o',
+ OUTCPP => '-o',
+ WARNISERROR => "-Werror",
+ FORCECSOURCE => [],
+ LINEPATTERN => "^#\\s+(\\d+)\\s+\"(.+)\"",
+
+ OPTIONS =>
+ [ # Files
+ "[^-].*\\.($::cilbin|c|cpp|cc)\$" => { TYPE => 'CSOURCE' },
+ "[^-].*\\.(s|S)\$" => { TYPE => 'ASMSOURCE' },
+ "[^-].*\\.i\$" => { TYPE => 'ISOURCE' },
+ # .o files can be linker scripts
+ "[^-]" => { RUN => sub { &GNUCC::parseLinkerScript(@_); }},
+
+ # Overall Options
+ "-c" => { RUN => sub { $stub->{OPERATION} = "TOOBJ"; }},
+ "-S" => { RUN => sub { $stub->{OPERATION} = "TOASM";
+ push @{$stub->{CCARGS}}, $_[1]; }},
+ "-E" => { RUN => sub { $stub->{OPERATION} = "TOI"; }},
+ "-o" => { ONEMORE => 1, TYPE => 'OUT' },
+ "-combine\$" => { TYPE => 'ALLARGS' },
+ "-pipe\$" => { TYPE => 'ALLARGS' },
+ "-x" => { ONEMORE => 1, TYPE => "CC" },
+ "-v" => { TYPE => 'ALLARGS',
+ RUN => sub { $stub->{TRACE_COMMANDS} = 1; } },
+ # skipping -###, --help, --target-help, --version
+
+ # C Language Options
+ "-ansi" => { TYPE => 'ALLARGS' },
+ '-std=' => { TYPE => 'ALLARGS' },
+ "-aux-info\$" => { TYPE => 'CC', ONEMORE => 1 },
+ "-f" => { TYPE => 'CC' },
+
+ # -Wx,blah options (placed before general -W warning options)
+ #matth: the handling of -Wp may be wrong. We may need to
+ # break up the argument list and invoke the map on each argument,
+ # so that some are classified as PREPROC and others as
+ # EARLY_PREPROC
+ '-Wp,' => { TYPE => 'EARLY_PREPROC' },
+ '-Wl,--(no-)?whole-archive$' => { TYPE => 'OSOURCE' },
+ '-Wl,' =>
+ { RUN => sub {
+ my ($linkargs) = ($_[1] =~ m|-Wl,(.*)$|);
+ #Split up the args
+ push @{$stub->{LINKARGS}}, split(/,/, $linkargs);
+ }},
+
+ # Warning Options
+ "-pedantic\$" => { TYPE => 'ALLARGS' },
+ "-pedantic-errors\$" => { TYPE => 'ALLARGS' },
+ "-Wall" => { TYPE => 'CC',
+ RUN => sub { push @{$stub->{CILARGS}},"--warnall";}},
+ "-W[-a-z0-9]*\$" => { TYPE => 'CC' },
+ "-w\$" => { TYPE => 'ALLARGS' },
+
+ # Debugging Options
+ '-g' => { TYPE => 'ALLARGS' },
+ "-save-temps" => { TYPE => 'ALLARGS',
+ RUN => sub { if(! defined $stub->{SAVE_TEMPS}) {
+ $stub->{SAVE_TEMPS} = '.'; } }},
+ '--?print-' => { TYPE => 'SPECIAL' },
+ '-dump' => { TYPE => 'SPECIAL' },
+ "-p\$" => { TYPE => 'LINKCC' },
+ "-pg" => { TYPE => 'LINKCC' },
+
+ # Optimization Options
+ # GCC defines some more macros if the optimization is On so pass
+ # the -O to the preprocessor and the compiler
+ '-O' => { TYPE => 'ALLARGS' },
+ '--param$' => { TYPE => 'CC', ONEMORE => 1 },
+
+ # Preprocessor Options
+ "-A" => { ONEMORE => 1, TYPE => "PREPROC" },
+ '-C$' => { TYPE => 'EARLY_PREPROC'}, # zra
+ '-CC$' => { TYPE => 'EARLY_PREPROC'},
+ '-d[DIMN]$' => { TYPE => 'EARLY_PREPROC' },
+ "-[DIU]" => { ONEMORE => 1, TYPE => "PREPROC" },
+ '-H$' => { TYPE => 'EARLY_PREPROC'},
+ '-idirafter$' => { ONEMORE => 1, TYPE => "PREPROC" },
+ '-include$' => { ONEMORE => 1, TYPE => "PREPROC" },
+ '-imacros$' => { ONEMORE => 1, TYPE => "PREPROC" },
+ '-iprefix$' => { ONEMORE => 1, TYPE => "PREPROC" },
+ '-iquote$' => { ONEMORE => 1, TYPE => "PREPROC" },
+ '-iwithprefix$' => { ONEMORE => 1, TYPE => "PREPROC" },
+ '-iwithprefixbefore$' => { ONEMORE => 1, TYPE => "PREPROC" },
+ '-isystem$' => { ONEMORE => 1, TYPE => "PREPROC" },
+ '-M$' => { TYPE => 'SPECIAL' },
+ '-MM$' => { TYPE => 'SPECIAL' },
+ '-MF$' => { TYPE => 'EARLY_PREPROC', ONEMORE => 1 },
+ '-MG$' => { TYPE => 'EARLY_PREPROC' },
+ '-MP$' => { TYPE => 'EARLY_PREPROC' },
+ '-MT$' => { TYPE => 'EARLY_PREPROC', ONEMORE => 1 },
+ '-MQ$' => { TYPE => 'EARLY_PREPROC', ONEMORE => 1 },
+ '-MD$' => { TYPE => 'EARLY_PREPROC' },
+ '-MMD$' => { TYPE => 'EARLY_PREPROC' },
+ '-P$' => { TYPE => 'EARLY_PREPROC'},
+ '-nostdinc$' => { TYPE => 'PREPROC' },
+ '-remap$' => { TYPE => 'PREPROC' },
+ '-traditional$' => { TYPE => 'PREPROC' },
+ '-tradtional-cpp$' => { TYPE => 'PREPROC' },
+ '-trigraphs$' => { TYPE => 'PREPROC' },
+ '-undef$' => { TYPE => 'PREPROC' },
+ '-Xpreprocessor$' => { ONEMORE => 1, TYPE => "PREPROC" },
+
+ # Linker Options
+ "-l" =>
+ { RUN => sub {
+ my ($libname) = ($_[1] =~ m|-l(.+)$|);
+ # See if we can find this library in the LIBDIR
+ my @libdirs = @{$stub->{LIBDIR}};
+ if($#libdirs == -1) {
+ push @libdirs, '.';
+ }
+ foreach my $d (@libdirs) {
+ if(-f "$d/lib$libname.a") {
+ # Pretend that we had a straight argument
+ push @{$stub->{OFILES}}, "$d/lib$libname.a";
+ return;
+ }
+ }
+ # We get here when we cannot find the library in the LIBDIR
+ push @{$stub->{LINKARGS}}, $_[1];
+ }},
+ '-nostartfiles$' => { TYPE => 'LINK' },
+ '-nodefaultlibs$' => { TYPE => 'LINK' },
+ '-nostdlib$' => { TYPE => 'LINK' },
+ '-pie$' => { TYPE => 'LINK' },
+ '-s$' => { TYPE => 'LINKCC' },
+ '-rdynamic$' => { TYPE => 'LINK' },
+ '-static$' => { TYPE => 'LINK' },
+ '-static-libgcc$' => { TYPE => 'LINK' },
+ '-shared$' => { TYPE => 'LINK' },
+ '-shared-libgcc$' => { TYPE => 'LINK' },
+ '-symbolic$' => { TYPE => 'LINK' },
+ '-u' => { TYPE => 'LINK', ONEMORE => 1 },
+ "-Xlinker\$" => { ONEMORE => 1, TYPE => 'LINK' },
+
+ # Directory Options
+ "-B" => { ONEMORE => 1, TYPE => 'ALLARGS' },
+ "-specs=" => { TYPE => 'ALLARGS' },
+ "-L" =>
+ { RUN => sub {
+ # Remember these directories in LIBDIR
+ my ($dir) = ($_[1] =~ m|-L(.+)$|);
+ push @{$stub->{LIBDIR}}, $dir;
+ push @{$stub->{LINKARGS}}, $_[1];
+ }},
+
+ # Target Options
+ "-V" => { ONEMORE => 1, TYPE => 'ALLARGS' },
+ "-b" => { ONEMORE => 1, TYPE => 'ALLARGS' },
+
+ # Machine Dependent Options
+ "-m" => { TYPE => 'ALLARGS', ONEMORE => 1 },
+ "-pthread\$" => { TYPE => 'ALLARGS' },
+
+ # mysterious options
+ "^-e\$" => { ONEMORE => 1, TYPE => 'LINK' },
+ "^-T\$" => { ONEMORE => 1, TYPE => 'LINK' },
+ "^-T(bss|data|text)\$" => { ONEMORE => 1, TYPE => 'LINK' },
+ "^-N\$" => { TYPE => 'LINK' },
+ "-a" => { TYPE => 'LINKCC' },
+ "-r\$" => { RUN => sub { $stub->{OPERATION} = "TOLIB"; }},
+ "-i\$" => { RUN => sub { $stub->{OPERATION} = "TOLIB"; }},
+
+ "--start-group" => { RUN => sub { } },
+ "--end-group" => { RUN => sub { }},
+ ],
+
+ };
+ bless $self, $class;
+ return $self;
+}
+# '
+
+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;
+ return 1;
+ }
+ warn "parsing OBJECT FILE:$filename ****************\n" if
+ $linker_script_debug;
+ open OBJFILE, $filename or die $!;
+ my $line = <OBJFILE>;
+ if ($line !~ /^INPUT/) {
+ close OBJFILE or die $!;
+ goto NotAScript;
+ }
+ warn "\tYES an INPUT file.\n" if $linker_script_debug;
+ my @lines = <OBJFILE>; # Read it all and close it
+ unshift @lines, $line;
+ close OBJFILE or die $!;
+ # Process recursively each line from the file
+ my @tokens = ();
+ my $incomment = 0; # Whether we are in a comment
+ foreach my $line (@lines) {
+ chomp $line;
+ if($incomment) {
+ # See where the comment ends
+ my $endcomment = index($line, "*/");
+ if($endcomment < 0) { # No end on this line
+ next; # next line
+ } else {
+ $line = substr($line, $endcomment + 2);
+ $incomment = 0;
+ }
+ }
+ # Drop the comments that are on a single line
+ $line =~ s|/\*.*\*/| |g;
+ # Here if outside comment. See if a comment starts
+ my $startcomment = index($line, "/*");
+ if($startcomment >= 0) {
+ $incomment = 1;
+ $line = substr($line, 0, $startcomment);
+ }
+ # Split the line into tokens. Sicne we use parentheses in the pattern
+ # the separators will be tokens as well
+ push @tokens, split(/([(),\s])/, $line);
+ }
+ 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; }
+ else { die "Error in script: expecting INPUT"; }
+ }
+ if($state == 1) {
+ if($token eq "(") { $state = 2; next; }
+ else { die "Error in script: expecting ( after INPUT"; }
+ }
+ if($state == 2) {
+ if($token eq ")") { $state = 0; next; }
+ if($token eq ",") { next; } # Comma could be a separator
+ # Now we better see a filename
+ if(! -f $token) {
+ warn "Linker script mentions inexistent file:$token.Ignoring\n";
+ next;
+ }
+ # Process it recursively because it could be a script itself
+ warn "LISTED FILE:$token.\n" if $linker_script_debug;
+ $self->parseLinkerScript($token, $onemore, $pargs);
+ next;
+ }
+ die "Invalid linker script parser state\n";
+
+ }
+}
+
+sub forceIncludeArg {
+ my($self, $what) = @_;
+ return ('-include', $what);
+}
+
+
+# Emit a line # directive
+sub lineDirective {
+ my ($self, $fileName, $lineno) = @_;
+ return "# $lineno \"$fileName\"\n";
+}
+
+# The name of the output file
+sub compileOutputFile {
+ my($self, $src) = @_;
+
+ 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}
+ && "@{$self->{OUTARG}}" =~ m|^-o\s*(\S.+)$|) {
+ return new OutputFile($src, $1);
+ } else {
+ return new KeptFile($src, $self->{OBJEXT}, '.');
+ }
+ } else {
+ return $self->outputFile($src, $self->{OBJEXT});
+ }
+}
+
+sub assembleOutputFile {
+ my($self, $src) = @_;
+ return $self->compileOutputFile($src);
+}
+
+sub linkOutputFile {
+ my($self, $src) = @_;
+ if(defined $self->{OUTARG} && "@{$self->{OUTARG}}" =~ m|-o\s*(\S.+)|) {
+ return $1;
+ }
+ return "a.out";
+}
+
+sub setVersion {
+ my($self) = @_;
+ my $cversion = "";
+ open(VER, "@{$self->{CC}} -dumpversion "
+ . join(' ', @{$self->{PPARGS}}) ." |")
+ || die "Cannot start GNUCC";
+ while(<VER>) {
+ if($_ =~ m|^(\d+\S+)| || $_ =~ m|^(egcs-\d+\S+)|) {
+ $cversion = "gcc_$1";
+ close(VER) || die "Cannot start GNUCC\n";
+ $self->{VERSION} = $cversion;
+ return;
+ }
+ }
+ die "Cannot find GNUCC version\n";
+}
+
+1;
+
+
+__END__
+
+
+
--- /dev/null
+package KeptFile;
+use OutputFile;
+@ISA = (OutputFile);
+
+use strict;
+use Carp;
+use File::Basename;
+use File::Spec;
+
+
+########################################################################
+
+
+sub new {
+ croak 'bad argument count' unless @_ == 4;
+ my ($proto, $basis, $suffix, $dir) = @_;
+ my $class = ref($proto) || $proto;
+
+ $basis = $basis->basis if ref $basis;
+ my ($basename, undef, $basefix) = fileparse($basis, qr{\.[^.]+});
+ my $filename = File::Spec->catfile($dir, "$basename.$suffix");
+
+ my $self = $class->SUPER::new($basis, $filename);
+ return $self;
+}
+
+
+########################################################################
+
+
+1;
+
+__END__
+
+
+=head1 Name
+
+KeptFile - persistent compiler output files
+
+=head1 Synopsis
+
+ use KeptFile;
+
+ my $cppOut = new KeptFile ('code.c', 'i', '/output/directory');
+ system 'cpp', 'code.c', '-o', $cppOut->filename;
+
+=head2 Description
+
+C<KeptFile> represents an intermediate output file generated by some
+stage of a C<Cilly>-based compiler that should be retained after
+compilation. It is a concrete subclass of L<OutputFile|OutputFile>.
+Use C<KeptFile> when the user has asked for intermediate files to be
+retained, such as via gcc's C<-save-temps> flag.
+
+=head2 Public Methods
+
+=over
+
+=item new
+
+C<new KeptFile ($basis, $suffix, $dir)> constructs a new C<KeptFile>
+instance. The new file name is constructed using the base file name
+of C<$basis> with its suffix replaced by C<$suffix> and its path given
+by C<$dir>. For example,
+
+ new KeptFile ('/foo/code.c', 'i', '/bar')
+
+yields a C<KeptFile> with file name F</bar/code.i>.
+
+C<$basis> may be either absolute or relative; only the trailing file
+name is used. C<$basis> can also be an C<OutputFile> instance, in
+which case C<< $basis->basis >> is used as the actual basis. See
+L<OutputFile/"basis"> for more information on basis flattening.
+
+C<$suffix> should not include a leading dot; this will be added
+automatically.
+
+C<$dir> may be either absolute or relative. It is common to use F<.>
+as the directory, which puts the C<KeptFile> in the current working
+directory.
+
+=back
+
+=head1 See Also
+
+L<OutputFile>, L<TempFile>.
+
+=cut
--- /dev/null
+# Makefile for lib; this Makefile is just for building the test
+# programs for experimenting with gc
+
+# tweak
+
+CFLAGS = -g -Wall -Igc/include
+CC = gcc $(CFLAGS)
+
+all: getrusage
+
+splay: splay.c
+ $(CC) -o splay -DTEST_SPLAY splay.c
+
+check-splay: splay
+ ./splay
+
+# I compile with several levels of optimization because this
+# greatly purturbs the results
+mymark: mymark.c
+ $(CC) -o mymark -DTEST_MYMARK mymark.c gc/gc.a
+ $(CC) -o mymark-O2 -O2 -DTEST_MYMARK mymark.c gc/gc.a
+ $(CC) -o mymark-O3 -O3 -DTEST_MYMARK mymark.c gc/gc.a
+
+mymark.i: mymark.c
+ cpp $(CFLAGS) mymark.c | grep -v '^#' > mymark.i
+
+mymarki: mymark.i
+ $(CC) -o mymarki mymark.i gc/gc.a
+
+getrusage: getrusage.c
+ $(CC) -o $@ getrusage.c
--- /dev/null
+package OutputFile;
+@ISA = ();
+
+use strict;
+use Carp;
+use File::Basename;
+use File::Spec;
+
+
+########################################################################
+
+
+my $debug = 0;
+
+
+sub new {
+ croak 'bad argument count' unless @_ == 3;
+ my ($proto, $basis, $filename) = @_;
+ my $class = ref($proto) || $proto;
+
+ $basis = $basis->basis if ref $basis;
+ my $ref = { filename => $filename,
+ basis => $basis };
+ my $self = bless $ref, $class;
+
+ $self->checkRef($filename);
+ $self->checkRef($basis);
+ $self->checkProtected();
+ $self->checkTemporary();
+
+ Carp::cluck "OutputFile: filename == $filename, basis == $basis" if $debug;
+ return $self;
+}
+
+
+sub filename {
+ my ($self) = @_;
+ return $self->{filename};
+}
+
+
+sub basis {
+ my ($self) = @_;
+ return $self->{basis};
+}
+
+
+########################################################################
+
+
+sub checkRef {
+ my ($self, $filename) = @_;
+ confess "ref found where string expected: $filename" if ref $filename;
+ confess "stringified ref found where string expected: $filename" if $filename =~ /\w+=HASH\(0x[0-9a-f]+\)/;
+}
+
+
+sub checkTemporary {
+ my ($self) = @_;
+ my ($basename, $path) = fileparse $self->filename;
+ return if $path eq File::Spec->tmpdir . '/';
+ confess "found temporary file in wrong directory: ", $self->filename
+ if $basename =~ /^cil-[a-zA-Z0-9]{8}\./;
+}
+
+
+########################################################################
+
+
+my @protected = ();
+
+
+sub checkProtected {
+ my ($self) = @_;
+ my $abs = File::Spec->rel2abs($self->filename);
+
+ foreach (@protected) {
+ confess "caught attempt to overwrite protected file: ", $self->filename
+ if $_ eq $abs;
+ }
+}
+
+
+sub protect {
+ my ($self, @precious) = @_;
+ push @protected, File::Spec->rel2abs($_)
+ foreach @precious;
+}
+
+
+########################################################################
+
+
+1;
+
+__END__
+
+
+=head1 Name
+
+OutputFile - base class for intermediate compiler output files
+
+=head1 Description
+
+C<OutputFile> represents an intermediate output file generated by some
+stage of a C<Cilly>-based compiler. This is an abstract base class
+and should never be instantiated directly. It provides common
+behaviors used by concrete subclasses L<KeptFile|KeptFile> and
+L<TempFile|TempFile>.
+
+=head2 Public Methods
+
+=over
+
+=item filename
+
+An C<OutputFile> instance is a smart wrapper around a file name. C<<
+$out->filename >> returns the name of the file represented by
+C<OutputFile> instance C<$out>. When building a command line, this is
+the string to use for the file. For example:
+
+ my $out = ... ; # some OutputFile subclass
+ my @argv = ('gcc', '-E', '-o', $out->filename, 'input.c');
+ system @argv;
+
+C<Cilly> often creates command vectors with a mix of strings and
+C<OutputFile> objects. This is fine, but before using a mixed vector
+as a command line, you must replace all C<OutputFile> objects with
+their corresponding file names:
+
+ my @mixed = (...); # mix of strings and objects
+ my @normalized = @mixed;
+ $_ = (ref $_ ? $_->filename : $_) foreach @normalized;
+ system @normalized;
+
+Common utility methods like C<Cilly::runShell> already do exactly this
+normalization, but you may need to do it yourself if you are running
+external commands on your own.
+
+=item protect
+
+C<OutputFile> contains safety interlocks that help it avoid stomping
+on user input files. C<< OutputFile->protect($precious) >> marks
+C<$precious> as a protected input file which should not be
+overwritten. If any C<OutputFile> tries to claim this same file name,
+an error will be raised. In theory, this never happens. In practice,
+scripts can have bugs, and it's better to be safe than sorry.
+
+C<Cilly> uses this method to register input files that it discovers
+during command line processing. If you add special command line
+processing of your own, or if you identify input files through other
+means, we highly recommend using this method as well. Otherwise,
+there is some risk that a buggy client script could mistakenly create
+an output file that destroys the user's source code.
+
+Note that C<protect> is a class method: call it on the C<OutputFile>
+module, rather than on a specific instance.
+
+=back
+
+=head2 Internal Methods
+
+The following methods are used within C<OutputFile> or by
+C<OutputFile> subclasses. They are not intended for use by outside
+scripts.
+
+=over
+
+=item basis
+
+In addition to L<its own file name|/"filename">, each C<OutputFile>
+instance records a second file name: its I<basis>. The basis file
+name is initialized and used differently by different subclasses, but
+typically represents the input file from which this output file is
+derived. C<< $out->basis >> returns the basis file name for instance
+C<$out>.
+
+When instantiating an C<OutputFile>, the caller can provide either a
+file name string as the basis or another C<OutputFile> instance.
+However, basis file names are not chained: if C<< $a->basis >> is
+F<foo.c>, and C<$b> is constructed with C<$a> as its basis, C<<
+$b->basis >> will return F<foo.c>, not C<$a> or C<< $a->filename >>.
+This flattening is done at construction time.
+
+See L<KeptFile/"new"> and L<TempFile/"new"> for more details on how
+basis file names are used.
+
+=item checkRef
+
+C<< OutputFile->checkRef($filename) >> raises an error if C<$filename>
+is an object reference, or looks like the string representation of an
+object reference. Used to sanity check arguments to various methods.
+
+=item checkTemporary
+
+C<< $out->checkTemporary >> raises an error if C<< $out->filename >>
+looks like a temporary file name but is not in the system temporary
+directory. Used to sanity check arguments in various methods.
+
+=item checkProtected
+
+C<< $out->checkProtected >> raises an error if C<< $out->filename >>
+is listed as a protected file. This check, performed at construction
+time, implements a safety interlock to prevent overwriting of user
+input files. Protected files are registered using L<"protect">.
+
+=back
+
+=head1 See Also
+
+L<KeptFile>, L<TempFile>.
+
+=cut
--- /dev/null
+package TempFile;
+use OutputFile;
+@ISA = (OutputFile);
+
+use strict;
+use Carp;
+use File::Temp qw(tempfile);
+
+
+########################################################################
+
+
+sub new {
+ croak 'bad argument count' unless @_ == 3;
+ my ($proto, $basis, $suffix) = @_;
+ my $class = ref($proto) || $proto;
+
+ my ($fh, $filename) = tempfile('cil-XXXXXXXX',
+ DIR => File::Spec->tmpdir,
+ SUFFIX => ".$suffix",
+ UNLINK => 1);
+ close($fh);
+ my $self = $class->SUPER::new($basis, $filename);
+ return $self;
+}
+
+
+########################################################################
+
+
+1;
+
+__END__
+
+
+=head1 Name
+
+TempFile - transitory compiler output files
+
+=head1 Synopsis
+
+ use TempFile;
+
+ my $cppOut = new TempFile ('code.c', 'i');
+ system 'cpp', 'code.c', '-o', $cppOut->filename;
+
+=head2 Description
+
+C<TempFile> represents an intermediate output file generated by some
+stage of a C<Cilly>-based compiler that should be removed after
+compilation. It is a concrete subclass of L<OutputFile|OutputFile>.
+Use C<TempFile> when the user has asked not for intermediate files to
+be retained.
+
+All C<TempFile> files are removed when the script terminates. This
+cleanup happens for both normal exits as well as fatal errors.
+However, the standard L<Perl exec function|perlfun/exec> does not
+perform cleanups, and therefore should be avoided in scripts that use
+C<TempFile>.
+
+=head2 Public Methods
+
+=over
+
+=item new
+
+C<new TempFile ($basis, $suffix)> constructs a new C<TempFile>
+instance. The new file name is constructed in some system-specific
+temporary directory with a randomly generated file name that ends with
+C<$suffix>. For example,
+
+ new TempFile ('/foo/code.c', 'i')
+
+might yield a C<TempFile> with file name F</var/tmp/cil-x9GyA93R.i>.
+
+C<$basis> gives the basis file name for this instance. The file name
+is not used directly, but is retained in case this instance is later
+passed as the basis for some other C<OutputFile>. See
+L<OutputFile/"basis"> for more information on basis flattening.
+
+C<$suffix> should not include a leading dot; this will be added
+automatically.
+
+=back
+
+=head1 See Also
+
+L<OutputFile>, L<TempFile>.
+
+=cut
--- /dev/null
+open Ocamlbuild_plugin
+open Command
+
+
+;;
+
+
+dispatch begin
+ function
+ | After_rules ->
+ (* the main CIL library *)
+ ocaml_lib "src/cil";
+
+ (* performance counter external functions *)
+ let perfcount = "ocamlutil/perfcount.o" in
+ flag ["use_perfcount"] (S [P perfcount]);
+ dep ["use_perfcount"] [perfcount];
+ flag ["optimize"] (S [A "-ccopt"; A "-O3"]);
+
+ (* residual reliance on make to build some OCaml source files *)
+ let make target =
+ let basename = Pathname.basename target in
+ rule ("make " ^ target)
+ ~dep: "Makefile"
+ ~prod: basename
+ begin
+ fun env _ ->
+ Cmd (S [A "make";
+ A "-s";
+ A "-C"; P "..";
+ A "MODULES=";
+ A "OBJDIR=_build";
+ P ("_build" / target)])
+ end
+ in
+ make "cilversion.ml";
+ make "feature_config.ml";
+ make "machdep.ml";
+
+ | _ ->
+ ()
+end
--- /dev/null
+perfcount.c
+profile.c
+Makefile
--- /dev/null
+# -*- Mode: makefile -*-
+# Copyright (c) 2001-2002,
+# George C. Necula <necula@cs.berkeley.edu>
+# Scott McPeak <smcpeak@cs.berkeley.edu>
+# Wes Weimer <weimer@cs.berkeley.edu>
+# 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.
+
+ # Generic Makefile for Ocaml projects
+ # Written by necula@cs.berkeley.edu
+ #
+ # Features:
+ # - keeps byproducts of building in a separate directory
+ # - handles dependencies automatically
+ # - user specifies just what modules go into a project and
+ # everything else is done automatically
+ # - you can use one Makefile for several Ocaml projects
+ #
+ # You must include this file in your Makefile. Before the include point
+ # you must defined the following variables (which are glob al for all Ocaml
+ # projects specified in one Makefile):
+ #
+ # CAMLDIR - the directory where to get the ocaml executables from.
+ # Must be empty (defaul) or end with a /
+ # OBJDIR - the directory where to put all object files. This directory
+ # must exist (default obj)
+ # DEPENDDIR - the directory where to put dependency files. This directory
+ # must exist. (default obj/.depend)
+ # NATIVECAML - if set then will use the native compiler
+ # UNSAFE - if set then will turn off safety checks (only with NATIVECAML)
+ # CAML_NOOPT - if set then it will not optimizer (default is to optimize when
+ # NATIVECAML is used, and not optimize in bytecode mode)
+ # PROFILE - if set then it will compile and link with "gprof" profiling
+ # support (NATIVECAML mode only)
+ # ASSEMBLY - if set then it will keep assembly files
+ # STATIC - if set then it will compile and link statically
+ # (NATIVECAML mode only)
+ # PREPROC - the preprocessor command
+
+ # WIN32 - means that we are using the Windows native tools
+
+ # MODULES - a list of all modules for all projects defined in the
+ # Makefile. Give only the basenames (no directory,
+ # no extension). This is used to create the dependencies.
+ # SOURCEDIRS - a list of all directories containing sources for all
+ # projects defined in a Makefile. This is used to set vpath.
+ # MLLS - a list of all .mll (ocamllex input) files for all
+ # projects defined in the Makefile.
+ # MLYS - a list of all .mly (ocamlyacc input) files for all
+ # projects defined in the Makefile.
+ # CP4S - a list of all .p4 (ocamlp4 input) files for all
+ # projects defined in the Makefile.
+ # ECHO - if specifically set to nothing then it will print
+ # all of the commands issued. Set this in the command line
+ # if you want to see what is going on.
+ #
+ # COMPILEFLAGS - if defined, then it is passed as argument to ocamlc
+ # and ocamlopt
+ # LINKFLAGS - if defined, then it is passed as argument to
+ # ocamlc and ocamlopt, when linking (at start of
+ # command line)
+ #
+ # CAML_CFLAGS - flags used only for the compilation of C files.
+ # e.g. '-ccopt <gcc flag>'
+ #
+ # BEFOREDEPS - must list the ML files that must be created before computing
+ # dependencies. If you do not do this, then ocamldep will not
+ # record a dependency on the missing ML files.
+ # The files obtained from MLYS and MLLS are
+ # handled automatically. This must be set before including this
+ # Makefile.ocaml
+ #
+ # After you set all of the above you must do the following for EACH separate
+ # executable that you want to build.
+ #
+ # Define the following:
+ # PROJECT_EXECUTABLE - the name of the executable you want to build. To take
+ # advantage of the naming scheme that separates the
+ # bytecode version and the native version, use the
+ # $(EXE) variable which is defined to either .byte.exe
+ # or .asm.exe. I typically put the executable in
+ # $(OBJDIR) as well.
+ # PROJECT_MODULES - the base names of the modules that make this
+ # executable in the order in which they must be
+ # passed to the linker. Make sure that all of
+ # the names mentioned here are also mentioned in
+ # MODULES.
+ # PROJECT_CMODULES - same as modules but for the C modules. These
+ # do not need to be mentioned in MODULES. There must be
+ # no name clashes with MODULES
+ # PROJECT_LIBS - the base names of the libraries that you
+ # want to link in the executable.
+ #
+ #
+ # After defining these variables, put the following code in your
+ # Makefile to generate a customized rule for making your executable:
+ #
+ # $(PROJECT_EXECUTABLE) : $(PROJECT_MODULES:%=$(OBJDIR)/%.$(CMO)) \
+ # $(PROJECT_CMODULES:%=$(OBJDIR)/%.$(CMC))
+ # @$(NARRATIVE) "Linking $(COMPILETOWHAT) $@ $(LINKMSG)"
+ # $(AT)$(CAMLLINK) -verbose -o $@ \
+ # $(PROJECT_LIBS:%=%.$(CMXA)) \
+ # $(PROJECT_LIBS:%=-cclib -l%) \
+ # $^
+ #
+ #
+ # Example:
+ #
+ # OBJDIR = obj
+ # DEPENDDIR = obj/.depend
+ # SOURCEDIRS = src src/special
+ # MLLS = mylex
+ # MLYS = myparse
+ #
+ # MODULES = mod11 mod12 mod21 modcommon
+ #
+ # # Rules for project 1
+ # PROJECT_EXECUTABLE = $(OBJDIR)/proj1$(EXE)
+ # PROJECT_MODULES = mod11 mod12 modcommon
+ # PROJECT_CMODULES =
+ # PROJEC_LIBS = unix
+ # #Standard boilerplate for the executable
+ # $(PROJECT_EXECUTABLE) : $(PROJECT_MODULES:%=$(OBJDIR)/%.$(CMO)) \
+ # $(PROJECT_CMODULES:%=$(OBJDIR)/%.$(CMC))
+ # @$(NARRATIVE) "Linking $(COMPILETOWHAT) $@ $(LINKMSG)"
+ # $(AT)$(CAMLLINK) -verbose -o $@ \
+ # $(PROJECT_LIBS:%=%.$(CMXA)) \
+ # $(PROJECT_LIBS:%=-cclib -l%) \
+ # $^
+ #
+ #
+ # # Rules for project 2
+ # PROJECT_EXECUTABLE = $(OBJDIR)/proj2$(EXE)
+ # PROJECT_MODULES = mod21 modcommon
+ # PROJECT_CMODULES =
+ # PROJEC_LIBS = unix str
+ # #Standard boilerplate for the executable
+ # $(PROJECT_EXECUTABLE) : $(PROJECT_MODULES:%=$(OBJDIR)/%.$(CMO)) \
+ # $(PROJECT_CMODULES:%=$(OBJDIR)/%.$(CMC))
+ # @$(NARRATIVE) "Linking $(COMPILETOWHAT) $@ $(LINKMSG)"
+ # $(AT)$(CAMLLINK) -verbose -o $@ \
+ # $(PROJECT_LIBS:%=%.$(CMXA)) \
+ # $(PROJECT_LIBS:%=-cclib -l%) \
+ # $^
+ #
+
+
+CAMLLEX = ocamllex
+CAMLYACC= ocamlyacc -v
+CAMLDEP = ocamldep
+CAMLP4 = camlp4 pa_o.cmo pa_op.cmo pr_o.cmo
+
+# Internal versions of COMPILEFLAGS and LINKFLAGS. We'll add additional flags
+# to these.
+COMPILE_FLAGS := $(COMPILEFLAGS)
+LINK_FLAGS := $(LINKFLAGS)
+
+COMPILE_FLAGS += -I $(OBJDIR)
+
+# sm: two styles for echoing compilation progress:
+# style 1, by George:
+# - print English descriptions of what's happening
+# - set ECHO to "" to see *everything*
+# style 2, by Scott:
+# - do not print English descriptions
+# - print every shell command that is executed which has a side effect,
+# so that they could be pasted into a shell to reproduce manually
+# - omit some of the details of dependency generation
+#
+# to be able to choose which style, several variables are used:
+# @$(NARRATIVE) - put this before English descriptions for style 1
+# @$(COMMAND) - put this before shell commands which are to be
+# printed for style 2; the command is *not* executed
+# $(AT) - put this before shell commands which are to be executed,
+# and also printed in style 2
+# $(ECHO) - use in place of '@' for things not printed in either style
+ifdef ECHOSTYLE_SCOTT
+ # 'true' silently consumes its arguments, whereas 'echo' prints them
+ NARRATIVE := true
+ COMMAND := echo
+ AT :=
+ ECHO := @
+else
+ NARRATIVE := echo
+ COMMAND := true
+ # change these next two definitions to <empty> to echo everything,
+ # or leave as @ to suppress echoing
+ AT := @
+ ECHO := @
+endif
+
+ifdef PREPROC
+ COMPILE_FLAGS += -pp "$(PREPROC)"
+ DEPFLAGS += -pp "$(PREPROC)"
+endif
+
+COMPILEMSG=
+LINKMSG=
+
+ifdef WIN32
+OBJ = obj
+else
+OBJ = o
+endif
+EXE = $(EXEEXT).exe
+
+
+export EXE
+
+
+
+ifdef NATIVECAML
+ ifdef PROFILE
+ COMPILE_FLAGS += -p
+ LINK_FLAGS += -p
+ COMPILEMSG += (profile)
+ LINKMSG += (profile)
+ endif
+ ifdef ASSEMBLY
+ COMPILE_FLAGS += -S
+ endif
+ ifdef STATIC
+ COMPILE_FLAGS += -ccopt -static
+ LINK_FLAGS += -ccopt -static
+ endif
+ #foo := $(shell echo "I am in NATIVECAML mode" >&2; echo whatever)
+ CAMLC = $(CAMLDIR)ocamlopt $(COMPILE_FLAGS)
+ CAMLLINK = $(CAMLDIR)ocamlopt $(LINK_FLAGS)
+ CMO = cmx
+ CMC = opt.$(OBJ) # compiled (and optimized) C
+ CMXA = cmxa
+ EXEEXT = .asm
+ MOVEAFTERCAMLC = cmi cmx $(OBJ)
+ COMPILETOWHAT = native code
+ # sm: by adding -native in native mode, we prevent spurious
+ # dependencies on .cmo files which were causing lots of
+ # extra recompilation
+ CAMLDEP = $(CAMLDIR)ocamldep -native
+ # CAML_NOOPT maintains its value on entry (default, missing)
+else
+ # Bytecode mode
+ CMO = cmo
+ CMXA = cma
+ CMC = $(OBJ)
+ EXEEXT = .byte
+ MOVEAFTERCAMLC = cmi cmo
+ COMPILETOWHAT = bytecode
+ CAMLC = $(CAMLDIR)ocamlc $(COMPILE_FLAGS)
+ CAMLLINK = $(CAMLDIR)ocamlc -custom $(LINK_FLAGS)
+ CAML_NOOPT = 1
+endif
+
+
+ifdef UNSAFE
+ CAMLC := $(CAMLC) -unsafe -noassert
+endif
+
+ifdef CAML_NOOPT
+ ifdef WIN32
+ COMPILE_FLAGS += -ccopt /Zi -ccopt /Od
+ LINK_FLAGS += -ccopt /Zi -ccopt /Od
+ else
+ COMPILE_FLAGS += -g -ccopt -g
+ LINK_FLAGS += -g -ccopt -g
+ endif
+else
+ ifdef WIN32
+ COMPILE_FLAGS += -ccopt /Ox
+ else
+ COMPILE_FLAGS += -ccopt -O3
+ endif
+endif
+
+
+
+ # Allow searching for .ml and .mli
+vpath %.mll $(SOURCEDIRS)
+vpath %.mly $(SOURCEDIRS)
+vpath %.ml $(SOURCEDIRS) $(OBJDIR)
+vpath %.mli $(SOURCEDIRS) $(OBJDIR)
+vpath %.c $(SOURCEDIRS)
+vpath %.p4 $(SOURCEDIRS)
+
+
+
+# Secondaries are intermediates that we don't want make to delete
+# By giving the right names to secondary files we tell make where to make
+# them if they are not already made. VERY USEFUL!!
+
+MLL_LYS:= $(MLLS:%.mll=$(OBJDIR)/%.ml) \
+ $(MLYS:%.mly=$(OBJDIR)/%.ml) $(MLYS:%.mly=$(OBJDIR)/%.mli) \
+ $(CP4S:%.p4=$(OBJDIR)/%.ml)
+
+.SECONDARY : $(MLL_LYS)
+
+ # Run the lexer generator
+ # Move the result to the OBJDIR directory
+ # If there is a .mli file in the same directory with .mll then
+ # copy it to OBJDIR (where the .ml) file will live.
+$(OBJDIR)/%.ml: %.mll
+ $(CAMLLEX) $<
+ $(AT)mv -f $(basename $<).ml $(OBJDIR)/
+ $(ECHO)if test -f $(basename $<).mli ;then \
+ $(COMMAND) cp -f $(basename $<).mli $(OBJDIR)/; \
+ cp -f $(basename $<).mli $(OBJDIR)/ \
+ ;fi
+
+ # Run the parser generator
+ # Move the result to the $(OBJDIR) directory.
+$(OBJDIR)/%.ml $(OBJDIR)/%.mli: %.mly
+ $(CAMLYACC) $(CAMLYACCFLAGS) $<
+ $(AT)mv -f $(basename $<).ml $(basename $<).mli $(OBJDIR)/
+
+$(OBJDIR)/%.ml: %.p4
+ $(CAMLP4) -impl $< > $@
+ $(ECHO)if test -f $(basename $<).mli ;then \
+ $(COMMAND) cp -f $(basename $<).mli $(OBJDIR); \
+ cp -f $(basename $<).mli $(OBJDIR) \
+ ;fi
+
+ # Compile an MLI file. After compilation move the result to OBJDIR
+$(OBJDIR)/%.cmi: %.mli
+ @$(NARRATIVE) Compiling interface $<
+ $(AT)$(CAMLC) -c $<
+ $(ECHO)if test $(OBJDIR) != $(<D) ;then \
+ $(COMMAND) mv -f $(basename $<).cmi $(OBJDIR)/; \
+ mv -f $(basename $<).cmi $(OBJDIR)/ \
+ ;fi
+
+ # Compile an ML file. After compilation we
+ # copy to $(OBJDIR) the .cmi and the result of compilation.
+$(OBJDIR)/%.$(CMO): %.ml
+ @$(NARRATIVE) "Compiling $< to $(COMPILETOWHAT) $(COMPILEMSG)"
+# $(ECHO)#if test $(OBJDIR) != $(<D) -a -f $(OBJDIR)/$(basename $(<F)).cmi ;then \
+# $(COMMAND) mv -f $(OBJDIR)/$(basename $(<F)).cmi $(<D); \
+# mv -f $(OBJDIR)/$(basename $(<F)).cmi $(<D); \
+# fi
+ @$(COMMAND) $(CAMLC) -c $<
+ $(ECHO)$(CAMLC) -c $< ; res=$$?; \
+ if test $(OBJDIR) != $(<D) ;then \
+ for ext in $(MOVEAFTERCAMLC); do \
+ if test -f $(basename $<).$$ext ;then \
+ $(COMMAND) mv -f $(basename $<).$$ext $(OBJDIR)/; \
+ mv -f $(basename $<).$$ext $(OBJDIR)/; \
+ fi; \
+ done; \
+ fi; exit $$res
+
+ # Compile C files
+ # They appear to be left in the current directory as .o files
+$(OBJDIR)/%.$(CMC): %.c
+ @$(NARRATIVE) "Compiling C file $< $(COMPILEMSG)"
+ $(AT)$(CAMLC) $(CAML_CFLAGS) -c $< -o $@
+ $(AT)mv -f $(basename $(notdir $<)).$(OBJ) $@
+
+ # Special rule for profile.c
+CAMLC_NOPROF=$(subst -p,,$(CAMLC))
+$(OBJDIR)/profile.$(CMC): profile.c
+ @$(NARRATIVE) "Compiling C file $<"
+ $(AT)$(CAMLC_NOPROF) $(CAML_CFLAGS) -c $< -o $@
+ $(AT)mv -f $(basename $(notdir $<)).$(OBJ) $@
+
+
+# Phonies should be "remade" even if someone mistakenly creates them
+.PHONY: cleancaml
+cleancaml:
+ -rm -f $(OBJDIR)/*.cmi
+ -rm -f $(OBJDIR)/*.cmo
+ -rm -f $(OBJDIR)/*.cmx
+ -rm -f $(OBJDIR)/*.cma
+ -rm -f $(OBJDIR)/*.cmxa
+ -rm -f $(OBJDIR)/*.exe
+ -rm -f $(OBJDIR)/*.obj
+ -rm -f $(OBJDIR)/*.o
+ -rm -f $(OBJDIR)/*.obj
+ -rm -f $(OBJDIR)/*.o
+ -rm -f $(OBJDIR)/*.lib
+ -rm -f $(OBJDIR)/*.a
+ -rm -f $(OBJDIR)/*.mli
+ -rm -f $(OBJDIR)/*.ml
+ -rm -f $(DEPENDDIR)/*.d $(DEPENDDIR)/*.di
+ -rm -f $(MLLS:%.mll=$(OBJDIR)/%.ml) \
+ $(MLLS:%.mll=$(OBJDIR)/%.mli) \
+ $(MLYS:%.mly=$(OBJDIR)/%.ml) \
+ $(MLYS:%.mly=$(OBJDIR)/%.mli) \
+ $(CP4S:%.p4=$(OBJDIR)/%.ml)
+
+
+
+# Before we generate the dependencies, we must make sure to create all the
+# ML files that we need. Otherwise, the ocamldep will not point out a
+# dependency to a missing file
+BEFOREDEPS += $(MLLS:%.mll=$(OBJDIR)/%.ml) $(MLYS:%.mly=$(OBJDIR)/%.ml)
+
+# Automatic dependency generation (see GNU info for details)
+#
+# Each .ml file has a .d (dependency file) which is automatically
+# generated and included by the rules below. The perl script replaces
+# directory paths with $(OBJDIR)/
+#
+# Dependencies for .mli files reside in corresponding .di files.
+#
+
+# Replace the directories in the dependency rules with $(OBJDIR)/, since
+# we'll move .cmo/.cmx files there.
+# 1. Strip any text followed by / or \. The / case even strips slashes that
+# are preceded by whitespace, to account for unix absolute paths.
+# The \ case does not strip slashes that come immediately after whitespace,
+# to preserve the trailing \ at the end of Makefile rules.
+# 2. Replace these directory names by '$(OBJDIR)/'
+FIXDEPEND:=perl -e 'while(<>) { s%[^/\\ :]*/% %g; s%[^/\\ :]+\\% %g; s%([-a-zA-Z0-9+-.:/\/_]+)%\$$(OBJDIR)/$$1%g; print $$_;}'
+# FIXDEPEND:=cat
+
+DEPINCLUDES= -I $(OBJDIR) $(SOURCEDIRS:%=-I %)
+$(DEPENDDIR)/%.d: %.ml $(BEFOREDEPS)
+ @$(NARRATIVE) "Generating dependency information for $<"
+ $(ECHO)if ! [ -d $(DEPENDDIR) ]; then mkdir -p $(DEPENDDIR) ; fi
+ @$(COMMAND) $(CAMLDEP) $(DEPFLAGS) $(DEPINCLUDES) $<
+ $(ECHO)$(CAMLDEP) $(DEPFLAGS) $(DEPINCLUDES) $< | $(FIXDEPEND) > $@
+
+$(DEPENDDIR)/%.di: %.mli $(BEFOREDEPS)
+ @$(NARRATIVE) "Generating dependency information for $<"
+ $(ECHO)if ! [ -d $(DEPENDDIR) ]; then mkdir -p $(DEPENDDIR) ; fi
+ @$(COMMAND) $(CAMLDEP) $(DEPFLAGS) $(DEPINCLUDES) $<
+ $(ECHO)$(CAMLDEP) $(DEPFLAGS) $(DEPINCLUDES) $< | $(FIXDEPEND) > $@
+
+# sm: it turns out there's a variable which lists all the goals
+# specified on the command line; I'll use this to set CLEANING
+# (which is not set anywhere else, currently)
+ifeq ($(MAKECMDGOALS),clean)
+ #$(warning "Skipping dependency rules because we're cleaning")
+ CLEANING := 1
+endif
+
+ifndef CLEANING
+-include $(MODULES:%=$(DEPENDDIR)/%.d)
+-include $(MODULES:%=$(DEPENDDIR)/%.di)
+endif
+
+listmodules:
+ @echo $(MODULES)
--- /dev/null
+# -*- Mode: makefile -*-
+# Copyright (c) 2001-2002,
+# George C. Necula <necula@cs.berkeley.edu>
+# Scott McPeak <smcpeak@cs.berkeley.edu>
+# Wes Weimer <weimer@cs.berkeley.edu>
+# 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.
+
+ # Auxiliary Makefile for building Ocaml project. See the documentation in
+ # the associated Makefile.ocaml for how to use this file.
+ # Written by necula@cs.berkeley.edu
+ #
+
+$(error "Makefile.ocaml.build is deprecated. Just inline the code for the execuable target.")
+#
+# Do not use this file anymore because it leads to more trouble than it is worth it.
+# Just inline the code in the host file
+#
+#$(PROJECT_EXECUTABLE) : $(PROJECT_MODULES:%=$(OBJDIR)/%.$(CMO)) \
+# $(PROJECT_CMODULES:%=$(OBJDIR)/%.$(CMC))
+# @$(NARRATIVE) "Linking $(COMPILETOWHAT) $@ $(LINKMSG)"
+# $(AT)$(CAMLLINK) -verbose -o $@ \
+# $(PROJECT_LIBS:%=%.$(CMXA)) \
+# $(PROJECT_LIBS:%=-cclib -l%) \
+# $^
+
+
+
+
+
--- /dev/null
+
+#
+# Regression testing module
+# George Necula (necula@cs.berkeley.edu)
+#
+package RegTest;
+
+require 5.00;
+require File::Basename;
+require File::Copy;
+require Getopt::Long;
+require Cwd;
+use Data::Dumper;
+use strict;
+
+# Authors: George Necula (necula@cs.berkeley.edu)
+
+
+# Set filename parsing according to current operating system.
+File::Basename::fileparse_set_fstype($^O);
+
+if($^O eq 'MSWin32') {
+ require Win32;
+}
+
+# unbuffer stdout, if it happens to be a file handle
+{ my $ofh = select STDOUT;
+ $| = 1;
+ select $ofh;
+}
+
+# &Getopt::Long::Configure('pass_through'); # Does not work on Linux
+
+# Set a signal handler
+my $interrupt = 0; # Will set this and we'll poll it between tests
+my $timeout = 0;
+sub intHandler {
+ my $signame = shift;
+ print "I got a SIG$signame\n";
+ $interrupt = 1;
+}
+
+# another one, for the hack involving --showoutput
+my $gotSigUsr1 = 0;
+sub usr1Handler {
+ $gotSigUsr1 = 1;
+}
+sub setUsr1Handler {
+ $gotSigUsr1 = 0;
+ $SIG{'USR1'} = \&usr1Handler;
+}
+
+
+ # Create an exception handler
+sub setInterruptHandler {
+ $SIG{'INT'} = \&intHandler;
+
+ # sm: 'CLD' is the child-death signal, which we always
+ # get when a child exits
+# $SIG{'CLD'} = \&intHandler;
+}
+
+&setInterruptHandler();
+
+sub processInterrupt {
+ my($self) = @_;
+ if($interrupt) {
+ $interrupt = 0;
+ print "\n";
+ my $answer =
+ &promptYN("You pressed CTRL-C. Want to continue? (y/n): ",
+ 'N');
+ if($answer eq "Y") {
+ &setInterruptHandler();
+ return;
+ }
+
+ $answer =
+ &promptYN("Will exit now. Do you want to keep the log file? (y/n):"
+ , 'Y');
+ if($answer eq "N") {
+ print "I am deleting $self->{LogFile}\n";
+ unlink $self->{LogFile};
+ }
+ die "I'm outta here\n";
+ }
+}
+
+
+use Config;
+# sm: added 'if (0)' -- we don't want to install handlers
+# for *all* signals!
+if (0) {
+ my $sg;
+ foreach $sg (split(' ', $Config{sig_name})) {
+ #print("Setting handler for $sg\n");
+ $SIG{$sg} = \&intHandler;
+ }
+}
+# print "signame = $Config{sig_name}\n";
+
+# Printing for the --verbose and --gory options.
+ # sm: aren't these named backwards, i.e. shouldn't vprint be for --verbose
+ # and gprint be for --gory?
+sub vprint {
+ my $self = shift;
+ if($self->{gory}) { print STDERR "@_"; }
+}
+
+sub gprint {
+ my $self = shift;
+ if($self->{verbose} or $self->{gory}) { print STDERR "@_"; }
+}
+
+sub mypwd {
+ my $ret = `pwd`;
+ chomp($ret);
+ return $ret;
+}
+
+###############################
+#
+# The Constructor
+#
+###############################
+# A constructor. Creates a RegTest object
+#
+sub new {
+ my ($proto, %args) = @_;
+ my $class = ref($proto) || $proto;
+ # Create $self
+
+ my $self = {};
+ # Pass on everything from args into $self
+ my $k;
+ foreach $k (keys %args) {
+ $self->{$k} = $args{$k};
+ }
+ bless $self, $class;
+
+ #
+ # Process the command line options
+ #
+ $Getopt::Long::bundling = 1;
+ my @extraopt = $self->extraOptions();
+
+ my (%option);
+ &Getopt::Long::GetOptions
+ (\%option,
+ "--help", # Display help information
+ "--verbose|v", # Display information about programs invoked
+ "--gory", # Display lots of information about programs
+ "--debug!", # Run the debug version of spj
+ "--run|r", # Run the tests
+ "--dryrun|n", # Pretend to run the tests
+ "--all", # Enable all tests, even if disabled by default
+ "--group=s@", # Run a group of tests
+ "--nogroup=s@", # Omit a group of tests
+ "--one=s", # Run a single test
+ "--param|p=s", # Report on a parameter
+ "--sort|s=s", # Sort by the given parameters
+ "--log=s", # The log file
+ "--logversions=i", # How many versions of the log file to keep
+ "--listtests", # Show the tests and their group memberships
+ "--stoponerror", # Stop at the first error
+ "--showoutput", # Show the output on the console
+ "--regrtest", # enable a variety of regrtest-like behaviors
+ "--timeout=i", # timeout (seconds)
+ "--skip=i", # skip a certain number of tests on startup
+ "--stopAfter=i", # stop after the given test number
+ "--extraArgs=s", # additional argument to pass to each test command
+ @extraopt
+ );
+
+ if($option{help}) {
+ $self->printHelp();
+ exit 0;
+ }
+ $self->{option} = \%option;
+ $self->{gory} = $option{gory};
+ $self->{verbose} = $option{verbose};
+ $self->{regrtest} = $option{regrtest};
+ $self->{timeout} = (defined($option{timeout}) ? $option{timeout}
+ : (defined($self->{DefaultTimeout})
+ ? $self->{DefaultTimeout} : 60));
+
+ # Initialize the list of tests
+ my %tests = ();
+ $self->{tests} = \%tests;
+
+ if(defined($option{log})) {
+ $self->{LogFile} = $option{log};
+ } else {
+ if(! defined($self->{LogFile})) {
+ $self->{LogFile} = "tests.log";
+ }
+ }
+
+ if(! defined($option{logversions})) {
+ $option{logversions} = 5;
+ }
+
+
+ # counter for tests, which gives a sometimes more convenient
+ # naming scheme for tests
+ $self->{testCounter} = -1;
+
+ # sm: I want to maintain counters of what happened this run, rather
+ # than doing log analysis
+ $self->{numExSuccess} = 0;
+ $self->{numUnexSuccess} = 0;
+ $self->{numExFailure} = 0;
+ $self->{numUnexFailure} = 0;
+
+ # but, I want a log of the unexpected events.. perhaps I could get
+ # this information by analyzing the existing logfiles, but what I
+ # want is so simple..
+ $self->{smLogfile} = mypwd() . "/testsafec.smlog";
+ system("rm $self->{smLogfile} 2>/dev/null");
+
+
+ return $self;
+}
+
+# print "ARGV after GetOptions = ", join(' ', @ARGV), "\n";
+
+# Help message printing routine.
+sub printHelp {
+ my ($self, $scriptname) = @_;
+ my ($scriptname, $extra) = $self->extraHelpMessage();
+ my $availparams = $self->{AvailParams};
+ my $params = "";
+ my $p;
+ foreach $p (keys %{$availparams}) {
+ $params .= " $p\n";
+ }
+ print << "EOF";
+Usage: $self->{CommandName} [options]
+Options:
+ --help Display this information
+ --verbose (or -v) Display information about invoked sub-processes
+ --gory Display lots of information about sub-processes
+ --run|-r Recreate the database by running all the tests
+ --dryrun|-n Show the commands that would be executed
+ --group <name> Run a group of tests. This option can be
+ specified multiple times. Only the specified
+ groups are considered, if this option is
+ present. If the option is missing run all
+ enabled tests.
+ --nogroup <name> Do not run a group of tests. This option
+ can be specified multiple times. Exclude from
+ the executed tests the mentioned ones. This
+ option is processed after all group options are
+ processed.
+ --listtests List the tests and their group memberships
+ --all Enable all tests, even those disabled by
+ default. Useful in --listtests -all
+ --one <name> Run a single test
+ --param|-p=<pnames> Create a report with values of the named
+ parameters (separated by :). Use "ALL" for all
+ parameters. The available parameters are:
+$params
+ --sort=<pnames> Sort the report by the given parameters.
+ --log=<name> The name of a log file to operate on.
+ --logversions=<nr> How many old versions of the log file to keep
+ --stoponerror Stop at the first error
+ --showoutput Show the output on the console
+ --timeout=ss Stop the command after ss seconds. Use 0 to disable.
+$extra
+
+Report bugs to necula\@cs.berkeley.edu.
+EOF
+}
+sub extraHelpMessage {
+ my($self) = @_;
+ return ("RegTest", "");
+}
+
+
+sub initialize {
+}
+
+
+sub extraOptions {
+ my($self) = @_;
+ return ();
+}
+
+#
+# Return a hash mapping parameter names either to 1 if the parameter is
+# numeric or to 0
+sub availableParameters {
+ my($self) = @_;
+ return ('SUCCESS' => 1);
+}
+
+#
+# Run a shell command
+# In a given directory
+# with given destinations for stdout, stderr ("" for no redirection)
+sub runCommand {
+ my($self, $tst, $dir, $cmd, $stdoutFile, $stderrFile) = @_;
+
+ my $dryrun = $self->{option}->{dryrun};
+
+ my $newcmd = $cmd;
+ if($^O eq "MSWin32") {
+ # Split the command arguments and the arguments
+ my ($command, @args) = split(/ /, $cmd);
+ my $arg = join(' ', @args);
+ # use slashes
+ $command =~ s|\\|/|g;
+ # escape some "sh" special characters in the arguments
+ $arg =~ s|\\|\\\\|g;
+ $arg =~ s|;|\\;|g;
+ $arg =~ s|\$|\\\$|g;
+
+ if ($stdoutFile) {
+ # sm: I think this does what it used to, but of course
+ # I can't easily test it..
+ $arg .= " 2>$stderrFile >$stdoutFile";
+ }
+
+ # Pass everything through sh.exe
+ $newcmd = "sh -c \"$command $arg\"";
+ }
+ else {
+ # The Unix branch.
+
+ # sm: why do we split commands and escape metacharacters? it seems
+ # to me the command itself might want to contain metacharacters
+ # for their meta-effect, and could easily escape those for which
+ # it wants no meta-effect ..
+
+ # Split the command arguments and the arguments
+ my ($command, @args) = split(/ /, $cmd);
+ my $arg = join(' ', @args);
+ # escape some "sh" special characters in the arguments
+ $arg =~ s|\\|\\\\|g;
+ $arg =~ s|;|\\;|g;
+ $arg =~ s|\$|\\\$|g;
+
+ # The comment in PCC/bin/PCC.pm is pertinent here.
+ $newcmd = "$command $arg";
+
+ if ($stdoutFile) {
+ if ($self->{option}->{showoutput}) {
+ # wrap up the command in some tees and subshells so the
+ # output will go to the specified files in addition to
+ # the terminal (or more generally, this process' stdout/err);
+ # we also have to play games with signals to detect errors..
+ # (personal reminder: my test script is ~/scripts/teetwo)
+ setUsr1Handler();
+ $newcmd = "exec 3>&1; exec 4>&2; ".
+ "(($newcmd || kill -USR1 $$) | ".
+ "tee $stdoutFile >&3) 2>&1 | ".
+ "tee $stderrFile >&4";
+ }
+ else {
+ $newcmd = "$newcmd 2>$stderrFile >$stdoutFile";
+ }
+ }
+ }
+
+ if($dryrun) {
+ if (!$self->{regrtest}) {
+ print " $newcmd\n";
+ }
+ return 0;
+ } else {
+ $self->gprint("\n [Running $newcmd]");
+
+ my $olddir = Cwd::cwd();
+ if(chdir $dir) {
+ my $res;
+ eval {
+ local $SIG{ALRM} = sub { die "got timeout"; };
+ my $timeout = $self->{timeout};
+ if(defined $tst->{Timeout}) {
+ $timeout = $tst->{Timeout};
+ }
+ alarm $timeout;
+ $res = system($newcmd);
+ alarm 0; # clear the alarm
+ };
+ if($@ =~ m/got timeout/) {
+# print STDERR "Got timeout. Kill children\n";
+ print STDERR " TIMEOUT ";
+ open(ERR, ">>$stderrFile");
+ print ERR "Error: TIMEOUT ($self->{timeout}s)";
+ close(ERR);
+ # Kill the children
+ local $SIG{HUP} = 'IGNORE';
+ kill HUP => -$$;
+ &setInterruptHandler();
+ $res = (1 << 7) + 1
+ }
+
+ if ($gotSigUsr1) {
+ $self->gprint("[exited: usr1]");
+ $res = 2 << 8; # no signal, exit code 2
+ }
+ else {
+ $self->gprint("[exited: $res]");
+ }
+
+ # check the result code for termination by Ctrl-C,
+ # which is the 'INT' signal (signal 2)
+ my $signal_num = $res & 127;
+ if ($signal_num == 2) {
+ #print("Ctrl-C pressed\n");
+ $interrupt = 1;
+ }
+
+ chdir $olddir;
+ return $res;
+ } else {
+ print "\nCannot change to directory $dir to run $newcmd\n";
+ return 1;
+ }
+ }
+}
+
+# All the %args are the placed into the new test
+#
+# The following arguments are useful:
+# Name => "...", Must be present
+# Dir => "...", default to cwd
+# Cmd => "...", no default. Use if you want to use the default
+# "run" method. Do not redirect outputs !
+# Enabled => 1/0, defaults to 1
+# Group => [ "...", "..."] defaults to empty
+# Comm => "..." a comment to be printed
+# Timeout => 40, seconds of timeout
+# ErrorMsg => "..." an error message to be printed if there is an error
+#
+sub newTest {
+ my ($self, %args) = @_;
+
+ # make a new test
+ my $new = { };
+
+ # Move the %args into $new
+ my $k;
+ foreach $k (keys %args) {
+ $new->{$k} = $args{$k};
+ }
+
+ if(! defined($new->{Name})) {
+ die "Test does not have a name\n";
+ }
+
+ if(! defined($new->{Enabled})) {
+ $new->{Enabled} = 1;
+ }
+ if(! defined($new->{Dir})) {
+ $new->{Dir} = Cwd::cwd();
+ }
+
+
+ # Add itself to the regression test
+ my $tests = $self->{tests};
+ $tests->{$new->{Name}} = $new;
+
+ $new->{ErrorCode} = -1; # not yet seen
+
+ return $new;
+}
+
+sub getTest {
+ my($self, $name) = @_;
+ return $self->{tests}->{$name};
+}
+
+
+sub cloneTest {
+ my($self, $name, $newname) = @_;
+ my $t = $self->getTest($name);
+ if(! defined $t) {
+ die "Cannot clone test $name";
+ }
+ my %args = %{$t}; # Make a copy
+ if(defined $self->getTest($newname)) {
+ die "The name $newname for the cloned test alredy used";
+ }
+ $args{Name} = $newname;
+ $self->newTest(%args);
+}
+
+
+# Run the tests and collect the output in a specified logFile
+sub runTests {
+ my ($self, $logfile) = @_;
+ my $dryrun = $self->{option}->{dryrun};
+
+ # Place a description in the log file
+ my ($hostname, $aliases, $type, $len, $thataddr) =
+ gethostbyname("localhost");
+ # Create the log file
+ if(! $dryrun) {
+ open(GLOBLOG, ">$logfile") || die "Cannot create log file $logfile";
+ print GLOBLOG "Testsuite ran on " .
+ localtime(time) . " on $hostname\n";
+ close(GLOBLOG) || die "Cannot close $logfile";
+ }
+ my %tests = %{$self->{tests}};
+
+ my @tstnames = keys %tests;
+ my $tstname;
+ my $nrtests = 0; # Count the enabled tests
+ foreach $tstname (@tstnames) {
+ my $tst = $tests{$tstname};
+ if(! $tst->{Enabled}) {
+ next;
+ }
+ $nrtests ++;
+ }
+ if ($self->{regrtest}) {
+ print ("There are $nrtests tests enabled\n");
+ }
+
+ my $theOne = $self->{option}->{one};
+
+ my $count = 0;
+ # Sort the test names in alphabetical order
+ @tstnames = sort @tstnames;
+ foreach $tstname (@tstnames) {
+ my $tst = $tests{$tstname};
+ if(! $tst->{Enabled}) {
+ next;
+ }
+
+ if (defined($theOne) &&
+ $tstname ne $theOne) {
+ next;
+ }
+
+ if (defined($self->{option}->{stopAfter}) &&
+ ($self->{option}->{stopAfter} <= $self->{testCounter})) {
+ last;
+ }
+
+ $self->processInterrupt();
+ $count ++;
+ if(! $dryrun) {
+ open(GLOBLOG, ">>$logfile")
+ || die "Cannot create log file $logfile";
+ }
+ my $msg = "Starting test $count/$nrtests on " . localtime(time) .
+ ": $tstname";
+ if (!$self->{regrtest}) { # sm: don't want this..
+ print $msg;
+ }
+ my $lfile = Cwd::cwd() . "/__log";
+ my $lfilestdout = Cwd::cwd() . "/__log.stdout";
+ # Try to delete the file. If we cannot then somebody is hanging to
+ # them and we will not see any output
+ if((-f $lfile && ! unlink $lfile) ||
+ (-f $lfilestdout && ! unlink $lfilestdout)) {
+ die "\nCannot delete $lfile or $lfilestdout. Some process is hanging on to them";
+ }
+
+ if(! $dryrun) {
+ print GLOBLOG "\n===================================\n$msg\n";
+ close(GLOBLOG) || die "Cannot close $logfile";
+ } elsif (!$self->{regrtest}) {
+ print "\n";
+ }
+
+ my $extracmd = "";
+ #if(defined ($self->{option}->{showoutput})) {
+ # $extracmd = " | tee $lfilestdout 2>$lfile ";
+ #} else {
+ # $extracmd = " 2>$lfile >$lfilestdout ";
+ #}
+ my $res = $self->run($tst, $extracmd, $dryrun,
+ $lfilestdout, $lfile);
+ if(! $dryrun) {
+ # Now copy over logs
+ open(GLOBLOG, ">>$logfile")
+ || die "Cannot create log file $logfile";
+ if(open(ERRLOG, "<$lfile")) {
+ while(<ERRLOG>) {
+ print GLOBLOG $_;
+ }
+ close(ERRLOG) || die "Cannot close $lfile";
+ unlink $lfile;
+ }
+ if(open(STDLOG, "<$lfilestdout")) {
+ print GLOBLOG "\n === STDOUT ===\n";
+ while(<STDLOG>) { print GLOBLOG $_; }
+ close(STDLOG) || die "Cannot close $lfilestdout";
+ unlink $lfilestdout;
+ }
+ close(GLOBLOG) || die "Cannot close $logfile";
+ unlink "$logfile.stdout";
+
+ # analyze success/failure
+ if($self->expectedToFail($tstname) ? !$res : $res) {
+ # test resolved the opposite way from what was expected
+ if (! $self->{regrtest}) {
+ print "\t--FAILED\n";
+ }
+ if(defined $self->{option}->{stoponerror}) {
+ #die "You told me to stop on error";
+ exit 2; # sm: don't need the explanation
+ }
+ }
+
+ else {
+ # test resolved the way it was expected to
+ if (!$self->{regrtest}) {
+ print "\n";
+ }
+ }
+ }
+ }
+}
+
+
+# return true if the test is expected to fail
+sub expectedToFail {
+ my ($self, $tname) = @_;
+ my $tst = $self->{tests}->{$tname};
+ if (defined($tst) && # what the hey..
+ (defined($tst->{MustFail}) || defined($tst->{Comm}))) {
+ return 1;
+ }
+ else {
+ return 0;
+ }
+}
+
+
+# Open an existing logfile and parse it.
+sub parseLogFile {
+ my($self, $logfile) = @_;
+
+ print "Parsing logfile $logfile\n";
+ my $currentTestName = "";
+ my $currentTest;
+ my $tests = $self->{tests};
+ open(LOG, "<$logfile") || die "Cannot open the log file $logfile (cwd=" . Cwd::cwd() .")";
+ my $date = <LOG>;
+ $date =~ s/^Testsuite ran at (.+) on (.+)$/$1/;
+ while(<LOG>) {
+ if($_ =~ m|^Starting test \d+/\d+ on .+:\d\d:\d\d \d\d\d\d: (\S+)|) {
+ # print "Found start of $1 (defined = ", defined($currentTest), ")\n";
+ # Finish the previous test case
+ if(defined $currentTest) {
+ $self->finishParsingLog($currentTest);
+ }
+ # Find the test with this name
+ $currentTest = $self->getTest($1);
+ if(defined $currentTest) {
+ # print "Start parsing log for $currentTest->{Name}\n";
+ # Start the parsing
+ $self->startParsingLog($currentTest);
+ }
+ }
+ if(defined($currentTest)) {
+ # Recognize the TIMEOUT error
+ if($_ =~ m|^Error: TIMEOUT|) {
+ $currentTest->{ErrorCode} = 100;
+ $currentTest->{ErrorMsg} = $_;
+ }
+ # Do the specialized parsing
+ $self->parseLogLine($currentTest, $_);
+ }
+ }
+ # Finish parsing the last test
+ if(defined($currentTest)) {
+ $self->finishParsingLog($currentTest);
+ }
+ close(LOG);
+ return ($date);
+}
+
+
+#
+# Show a list of test cases
+# Arguments:
+# - heading of the set of test cases
+# - a list of test cases
+sub showList {
+ my($self, @lst) = @_;
+ my $tst;
+ # Sort the list by name
+ @lst = sort {$a->{Name} cmp $b->{Name}} @lst;
+ foreach $tst (@lst) {
+ my $comm = defined($tst->{Comm}) ? "\n\t-$tst->{Comm}" : "";
+ my $errmsg =
+ defined($tst->{ErrorMsg}) ? "\n\t$tst->{ErrorMsg}" : "";
+ print " $tst->{Name}$comm$errmsg\n";
+ }
+}
+
+sub showListHeader {
+ my($self, $title, $code, $totalenabled, @lst) = @_;
+ my $tests = $self->{tests};
+ my $count = $#lst + 1;
+ my $ratio = $totalenabled == 0 ? 0 : 100 * $count / $totalenabled;
+ printf "%s(%d) %02d%% (%d / %d) [%d tests disabled]\n", $title,
+ $code,
+ $ratio, $count, $totalenabled,
+ (scalar keys %$tests) - $totalenabled;
+}
+
+sub processGroup {
+ my($self, $group, $toAdd) = @_;
+ my $tstname;
+ my $count = 0;
+ my %tests = %{$self->{tests}};
+ ITER:
+ foreach $tstname (keys %tests) {
+ if((defined $tests{$tstname}->{Group})) {
+ my $i;
+ my @arr = @{$tests{$tstname}->{Group}};
+ my $size = $#arr;
+ for($i=0; $i <= $size; $i++) {
+ if($arr[$i] eq $group) {
+ if(($toAdd ? 1 : 0) !=
+ ($tests{$tstname}{Enabled} ? 1 : 0)) {
+ $count++;
+ }
+ $tests{$tstname}{Enabled} = $toAdd;
+ next ITER;
+ }
+ }
+ }
+ }
+ if($count == 0) {
+ warn "Cannot find any tests in group $group\n";
+ }
+ my $str = ($toAdd ? "Enabled" : "Disabled");
+ print STDOUT "$str $count tests in group $group\n";
+}
+
+
+# A subroutine that deletes or renames a version of the log file
+# The first version is called <base>.1, ... where <base> is the current log
+# file
+sub deleteOrRenameLog {
+ my($self, $logbase, $version) = @_;
+ my $verlogname = $version == 0 ? $logbase : "$logbase.$version";
+ if(! -f $verlogname) {
+ return;
+ }
+ if($version >= $self->{option}->{logversions}) {
+ # delete it
+ unlink $verlogname;
+ return;
+ }
+ # See if we can rename it to a higher version
+ my $newversion = $version + 1;
+ $self->deleteOrRenameLog($logbase, $newversion);
+ rename $verlogname, "$logbase.$newversion";
+}
+
+# The main entry point
+sub doit {
+
+ my ($self) = @_;
+ my %option = %{$self->{option}};
+ my %tests = %{$self->{tests}};
+ # Get the logfile name
+ my $logFile = $self->{LogFile};
+
+ # Go through the directory in which $logFile is and find all files with
+ # similar names
+ my @existingLogFiles = ();
+
+ my $logDir = ".";
+ my $logBase;
+ {
+ my ($base, $dir, $ext) =
+ File::Basename::fileparse($logFile, "");
+ if(defined($dir)) {
+ $logDir = $dir; $logBase = "$base$ext";
+ }
+ my $file;
+ opendir(LOGDIR, $logDir) || die "can't open directore $logDir";
+ foreach $file (readdir LOGDIR) {
+ if($file =~ m|$logBase(\.\d+)?$|) {
+ push @existingLogFiles, $file
+ }
+ }
+ closedir(LOGDIR);
+ }
+ @existingLogFiles = sort { $a cmp $b } @existingLogFiles;
+
+ my $results;
+
+
+ # Enable all tests if specified
+ if(defined $option{all}) {
+ # Enable all tests
+ my $tst;
+ foreach $tst (keys %tests) {
+ $tests{$tst}->{Enabled} = 1;
+ }
+ }
+ # Prune to a group if specified
+ if(defined $option{group}) {
+ # First go and disable all tests
+ my $tst;
+ foreach $tst (keys %tests) {
+ $tests{$tst}->{Enabled} = 0;
+ }
+ # Enable the ALWAYS group
+ $self->processGroup("ALWAYS", 1);
+ # No go and enable all given groups
+ my $grp;
+ foreach $grp (@{$option{group}}) {
+ print "Enabling group $grp\n";
+ $self->processGroup($grp, 1);
+ }
+ }
+ # Prune a group if specified
+ if(defined $option{nogroup}) {
+ # No go and disable all given groups
+ my $grp;
+ foreach $grp (@{$option{nogroup}}) {
+ $self->processGroup($grp, 0);
+ }
+ }
+
+ # Show the groups if it was requested
+ if($option{listtests}) {
+ my $tstname;
+ print "The enabled test cases are:\n";
+ my @tstnames = keys %tests;
+ my @sorted = sort @tstnames;
+ foreach $tstname (@sorted) {
+ my $tst = $tests{$tstname};
+ if(! $tst->{Enabled}) { next; }
+ printf " %-40s (%s)\n",
+ $tstname,
+ defined $tst->{Group} ? join(',', @{$tst->{Group}}) : "";
+ }
+ exit 0;
+ }
+
+ # Or maybe we need to run a group
+ my $hascreatedlog = 0;
+ if(defined $option{run} || defined $option{dryrun}) {
+ # Now rename some old log files to make room for the new one
+ if(! $option{dryrun}) {
+ $self->deleteOrRenameLog($logFile, 0);
+ $hascreatedlog = 1;
+ } else {
+ print "DRY RUN: ";
+ }
+ if (!$self->{regrtest}) {
+ print "Writing test results in logfile $logFile\n";
+ }
+ # Now run the tests
+ $self->runTests($logFile);
+ }
+
+ if ($self->{regrtest}) {
+ # sm: finish up the way I like
+ print("\n");
+ print("Successful tests: $self->{numExSuccess}\n");
+ print("Failed as expected: $self->{numExFailure}\n");
+ if (!defined($self->{option}->{stoponerror})) {
+ print("Unexpected success: $self->{numUnexSuccess}\n");
+ print("Unexpected failure: $self->{numUnexFailure}\n");
+
+ # report the unexpected events
+ if ( -f $self->{smLogfile} ) {
+ print("\n");
+ system("cat $self->{smLogfile}");
+ system("rm $self->{smLogfile}");
+ }
+ }
+
+ exit 0;
+ }
+
+ # Now select which log file to look at
+ if(! $hascreatedlog) {
+ if(defined $option{log}) {
+ $logFile = $option{log};
+ } else {
+ if($#existingLogFiles >= 0) {
+ my $file;
+ my $id = 1;
+ if($#existingLogFiles > 0) {
+ print "The following test logs are available:\n";
+ foreach $file (@existingLogFiles) {
+ my $comment;
+ my @thestat = stat("$logDir/$file");
+ my $nrbytes = $thestat[7];
+ open(LOG, "<$logDir/$file");
+ if(<LOG> =~ m|^Testsuite ran on (.+) on (.+)$|) {
+ $comment .= "$nrbytes bytes. Ran on $1 on $2";
+ }
+ close(LOG);
+ print " $id: $file ($comment)\n";
+ $id ++;
+ }
+ $id --;
+ SelectAnother:
+ print "Select a log (1-$id, q to quit): ";
+ my $cmd = <STDIN>; chop $cmd;
+ if($cmd eq "q") {
+ exit(0);
+ }
+ if($cmd < 1 || $cmd > $id) {
+ goto SelectAnother;
+ }
+ $id = $cmd;
+ }
+ $logFile = @existingLogFiles[$id - 1];
+ }
+ }
+ }
+ if(! -f $logFile) {
+ print "\n*** No log file exists. Use the --run command first to create one\n\n\n";
+ $self->printHelp ();
+ exit 1;
+ }
+ # Parse the log file and set ErrorCode
+ my ($results, $date) = $self->parseLogFile($logFile);
+
+ # Collect all the ErrorCode's
+ my %errcodelst = ();
+
+ my $tst;
+ my $nrenabled = 0;
+ foreach $tst (values %tests) {
+ if(! $tst->{Enabled}) { next; }
+ $nrenabled ++;
+ my $errcode = $tst->{ErrorCode};
+ # Add it to the list for the error code
+ my $errlst = $errcodelst{$errcode};
+ if(! defined($errlst)) {
+ $errlst = [];
+ $errcodelst{$errcode} = $errlst;
+ }
+ push @{$errlst}, $tst;
+ }
+
+ # Now show a report sorted by error code (viewed as a number)
+ my @errorcodes = sort { $a <=> $b } (keys %errcodelst);
+
+ print "Reporting results in $logFile\n";
+ # Now show those test cases that succeeded but have bad comments
+ # associated with them
+ my @succs = grep { defined ($_->{Comm}) } @{$errcodelst{0}};
+ $self->showListHeader("Successes thought to fail", 0, $nrenabled, @succs);
+ $self->showList(@succs);
+ foreach my $errcode (@errorcodes) {
+ $self->showListHeader($self->errorHeading(int($errcode)),
+ int($errcode),
+ $nrenabled,
+ @{$errcodelst{$errcode}});
+ if($errcode > 0) {
+ $self->showList(@{$errcodelst{$errcode}});
+ }
+ }
+ if(defined $option{param}) {
+ $self->printReport();
+ }
+}
+
+
+
+
+sub sortReport {
+ my ($self) = @_;
+ my $sp;
+ my @sortpars = @{$self->{sortpars}};
+
+ foreach $sp (@sortpars) {
+ my $res;
+ if($self->{AvailParams}->{$sp}) { # Is numeric
+ $res = int($a->{$sp}) <=> int($b->{$sp});
+ } else {
+ $res = $a->{$sp} cmp $b->{$sp};
+ }
+ if($res != 0) {
+ return $res;
+ }
+ }
+ return 0;
+}
+
+
+
+sub printReport {
+ my ($self) = @_;
+ my %option = %{$self->{option}};
+ my @sortpars;
+
+ print "Printing report\n";
+ if(defined($option{param})) {
+ my @params = split(/:/, $option{param});
+ if(grep(/^ALL$/, @params)) {
+ @params = keys %{$self->{AvailParams}};
+ }
+ unshift @params, "Name"; # Name is always the first parameter
+
+ # Now sort the report
+ @sortpars = ();
+ if(defined($option{sort})) {
+ @sortpars = split(/:/, $option{sort});
+ }
+ push @sortpars, "Name"; # Add the name as the last sorting parameter
+ $self->{sortpars} = \@sortpars;
+
+ # Create a list with all successes and with the requested parameters
+ my @report = ();
+ my $tstname;
+ foreach $tstname (keys %{$self->{tests}}) {
+ my $tst = $self->{tests}->{$tstname};
+ if(! $tst->{Enabled}) { next; }
+ push @report, $tst;
+ }
+ # print "Sorting on ", join('+', @sortpars), "\n";
+ my @sortedreport = sort sortReport @report;
+
+ # Now print the report
+ my $par;
+ print "\n";
+ foreach $par (@params) {
+ if($par eq "Name") {
+ printf "%-20s ", $par;
+ } else {
+ printf "%-8s ", $par;
+ }
+ }
+ print "\n------------------------------------------------------\n";
+ my $tst;
+ foreach $tst (@sortedreport) {
+ # print Dumper(\$tst);
+ foreach $par (@params) {
+ my $pval = $tst->{$par};
+ if(! defined($pval)) { $pval = '-'; }
+ if($par eq "Name") {
+ printf "%-20s ", $pval;
+ } else {
+ printf "%-8s ", $pval;
+ }
+ }
+ print "\n";
+ }
+ }
+}
+
+#
+# A function to translate the error code into a report heading
+sub errorHeading {
+ my($self, $errcode) = @_;
+ if($errcode == 0) {
+ return "Success";
+ }
+ if($errcode == 10000) {
+ return "Test should have failed";
+ }
+ if($errcode == 10001) {
+ return "Could not find pattern in output";
+ }
+ return "Error $errcode";
+}
+
+
+# send something to stdout and to my little log file
+sub smLog {
+ my ($self, $msg) = @_;
+ print($msg . "\n");
+ system("echo \"$msg\" >> $self->{smLogfile}");
+}
+
+
+#
+# Run a test. Return 0 if success
+sub run {
+ my($self, $tst, $extraArgs, $dryrun, $stdoutFile, $stderrFile) = @_;
+
+ # sm: this test always fails because the caller tests it too ..
+ if(! $tst->{Enabled}) { return 0 ; }
+
+ my $expectFail = $self->expectedToFail($tst->{Name})? "(fail) " : "";
+
+ # the summary line is supposed to be a command that can be copy+pasted
+ # into an xterm to reproduce the failure
+ my $summary = $tst->{Cmd} . $extraArgs;
+ $summary =~ s/ *_GNUCC=1//; # strip options I don't care about
+ $summary =~ s/ *STATS=1//;
+ $summary =~ s/ *PRINTSTAGES=1//;
+ $summary =~ s/ +/ /g; # collapse consecutive spaces
+ $summary =~ s/ *$//; # strip trailing spaces
+ $self->{testCounter}++;
+
+ my $skip = defined($self->{option}->{skip}) &&
+ ($self->{option}->{skip} > $self->{testCounter})? "(skip) " : "";
+
+ if ($self->{regrtest}) {
+ # sm: regrtest-like output
+ if ($skip) {
+ print("skipping: [$self->{testCounter}] $expectFail$summary\n");
+ }
+ else {
+ print("------------ [$self->{testCounter}] " .
+ "$expectFail$summary ------------\n");
+ }
+ }
+
+ if ($skip) {
+ return $expectFail? 1 : 0;
+ }
+
+ # add additional arguments passed at command line to entire tester
+ if (defined($self->{option}->{extraArgs})) {
+ $extraArgs .= $self->{option}->{extraArgs};
+ }
+
+
+ if (defined($tst->{ExtraArgs})) {
+ $extraArgs .= " " . $tst->{ExtraArgs};
+ }
+
+ my $res =
+ $self->runCommand($tst,
+ $tst->{Dir},
+ $tst->{Cmd} . $extraArgs,
+ $stdoutFile, $stderrFile);
+
+ # sm: I want ctl-c to bail immediately, no questions asked.
+ # I originally put this in processInterrupt, but that doesn't
+ # get called very soon after runCommand, and other stuff
+ # happens in between that I didn't want.
+ if ($interrupt && $self->{regrtest}) {
+ print("interupted\n");
+ exit 2;
+ }
+
+ # analyze success/failure (some additional analysis is done
+ # in the caller, runTests)
+ if ($res == 0) { # test succeeded
+ if (!$expectFail) {
+ $self->{numExSuccess}++;
+
+ if ($self->{regrtest} &&
+ defined($tst->{AfterSuccessScript})) {
+ if (system($tst->{AfterSuccessScript}) != 0) {
+ exit 2; # bail if after-script fails
+ }
+ }
+ }
+ else {
+ $self->{numUnexSuccess}++;
+
+ if ($self->{regrtest}) {
+ my $reason = $tst->{Comm};
+ print("\n");
+ $self->smLog("[$self->{testCounter}] GOOD NEWS: " .
+ "A test that used to fail ($reason) now succeeds:");
+ $self->smLog(" $summary");
+ }
+ }
+ }
+
+ else { # test failed
+ if ($expectFail) {
+ $self->{numExFailure}++;
+ }
+ else {
+ $self->{numUnexFailure}++;
+
+ if ($self->{regrtest}) {
+ print("\n");
+ $self->smLog("[$self->{testCounter}] " .
+ "A regression test command failed:");
+ $self->smLog(" $summary");
+
+ if (defined($tst->{FailDiagnosis})) {
+ print ("\n" . $tst->{FailDiagnosis} . "\n");
+ }
+ }
+ }
+ }
+
+ return $res;
+}
+
+# Called when the parsing of the log for this test begins
+sub startParsingLog {
+ my($self, $tst) = @_;
+ $tst->{ErrorCode} = 0;
+ return;
+}
+
+# Called when the parsing of the log for this test ends
+sub finishParsingLog {
+ my($self, $tst) = @_;
+ if(defined $tst->{MustFail}) {
+ if($tst->{ErrorCode} == 0) {
+ $tst->{ErrorCode} = 10000;
+ } else {
+ $tst->{ErrorCode} = 0; # No failure then
+ }
+ }
+ if($tst->{ErrorCode} == 0 && # Looks like success so far
+ defined $tst->{ExpectPattern} &&
+ ! $tst->{FoundExpectedPattern}) {
+
+ $tst->{ErrorCode} = 10001;
+ }
+ if($tst->{ErrorCode} == 0) {
+ $tst->{SUCCESS} = 1;
+ }
+ # print "finishParsingLog for $tst->{Name}\n";
+# if ($tst->{Name} eq "testrun/demo1-inferbox") {
+# print Dumper($tst);
+# }
+ return;
+}
+
+my $debugpat = 0;
+# Called on each line of the log for this test
+# Should set fields in the object
+# The ErrorCode field, if set to <> 0 will signal an error
+sub parseLogLine {
+ my($self, $tst, $line) = @_;
+ if(defined $tst->{Patterns}) {
+ my $pat;
+ my %patterns = %{$tst->{Patterns}};
+ foreach $pat (keys %patterns) {
+ my @results;
+ if($line =~ m/$pat/) {
+ if($debugpat) {
+ print "Matched $pat for $tst->{Name}\: $1, $2, $3, $4, $5,
+$6, $7, $8, $9\n";
+ }
+ my $handler = $patterns{$pat};
+ &{$handler}($self, $tst, $1, $2, $3, $4, $5, $6, $7, $8, $9);
+ }
+ }
+ }
+ # See if any pattern is expected
+ if(defined $tst->{ExpectPattern}) {
+ my $pat = $tst->{ExpectPattern};
+ if ($line =~ m|$pat|) {
+ $tst->{FoundExpectedPattern} = 1;
+ }
+ }
+ return;
+}
+
+
+sub testExists {
+ my ($self, $tname) = @_;
+ return defined($self->{tests}->{$tname});
+}
+
+sub setField {
+ my($self, $tname, $field, $value) = @_;
+ my $tst = $self->{tests}->{$tname};
+ if(! defined($tst)) {
+ die "Cannot set field of nonexistent test $tname\n";
+ }
+ $tst->{$field} = $value;
+}
+sub getField {
+ my($self, $tname, $field) = @_;
+ my $tst = $self->{tests}->{$tname};
+ if(! defined($tst)) {
+ die "Cannot set field of nonexistent test $tname\n";
+ }
+ return $tst->{$field};
+}
+
+sub addComment {
+ my($self, $tname, $comm) = @_;
+ my $tst = $self->{tests}->{$tname};
+ if(! defined($tst)) {
+ die "Cannot add comment to nonexistent test $tname\n";
+ }
+ $tst->{Comm} .= $comm;
+}
+
+sub addGroups {
+ my($self, $tname, @groups) = @_;
+ my $tst = $self->{tests}->{$tname};
+ if(! defined($tst)) {
+ die "Cannot add groups to nonexistent test $tname\n";
+ }
+ push @groups, @{$tst->{Group}};
+ $tst->{Group} = \@groups;
+}
+
+sub enable {
+ my($self, $tname, $value) = @_;
+ my $tst = $self->{tests}->{$tname};
+ if(! defined($tst)) {
+ die "Cannot enable to nonexistent test $tname\n";
+ }
+ $tst->{Enabled} = $value;
+}
+
+sub prompt {
+ my($msg) = @_;
+ print $msg;
+ my $answer = <STDIN>;
+ if($answer =~ m|^([^\r\n]*)[\r\n]+|) {
+ $answer = $1;
+ }
+ return $answer;
+}
+
+sub promptYN {
+ my($msg, $default) = @_;
+ my $counter = 5;
+ while(1) {
+ my $answer = &prompt($msg);
+ if($answer eq "") {
+ # Perhaps we have no input
+ if(eof(STDIN)) {
+ return $default;
+ }
+ next;
+ }
+ if($answer eq 'y' || $answer eq 'Y') { return 'Y'; }
+ if($answer eq 'n' || $answer eq 'N') { return 'N'; }
+ }
+}
+
+
+1;
+
+
+
--- /dev/null
+# compiling
+"perfcount.c": optimize
--- /dev/null
+module H = Hashtbl
+module E = Errormsg
+open Pretty
+
+let debugAlpha (prefix: string) = false
+(*** Alpha conversion ***)
+let alphaSeparator = "___"
+let alphaSeparatorLen = String.length alphaSeparator
+
+(** For each prefix we remember the next integer suffix to use and the list
+ * of suffixes, each with some data assciated with the newAlphaName that
+ * created the suffix. *)
+type 'a alphaTableData = int * (string * 'a) list
+
+type 'a undoAlphaElement =
+ AlphaChangedSuffix of 'a alphaTableData ref * 'a alphaTableData (* The
+ * reference that was changed and
+ * the old suffix *)
+ | AlphaAddedSuffix of string (* We added this new entry to the
+ * table *)
+
+(* The number of decimal digits that can fit in a 31-bit signed int *)
+let maxSuffixLength = 9
+let maxSuffix = (* "999999999" *)
+ try
+ let maxSuffixStr = String.make maxSuffixLength '9' in
+ int_of_string maxSuffixStr
+ with Failure _ ->
+ E.s (E.bug "You appear to be using the Alpha module on a computer where int is represented with fewer than 31 bits. Go to alpha.ml and change maxSuffixLength to a smaller number.")
+
+
+(* Create a new name based on a given name. The new name is formed
+ * from a prefix (obtained from the given name by stripping a suffix
+ * consisting of the alphaSeparator followed by up to maxSuffixLength
+ * digits), followed by alphaSeparator and then by a positive integer
+ * suffix. The first argument is a table mapping name prefixes to the
+ * largest suffix used so far for that prefix. The largest suffix is
+ * one when only the version without suffix has been used. *)
+let rec newAlphaName ~(alphaTable: (string, 'a alphaTableData ref) H.t)
+ ~(undolist: 'a undoAlphaElement list ref option)
+ ~(lookupname: string)
+ ~(data: 'a) : string * 'a =
+ alphaWorker ~alphaTable:alphaTable ~undolist:undolist
+ ~lookupname:lookupname ~data:data true
+
+
+(** Just register the name so that we will not use in the future *)
+and registerAlphaName ~(alphaTable: (string, 'a alphaTableData ref) H.t)
+ ~(undolist: 'a undoAlphaElement list ref option)
+ ~(lookupname: string)
+ ~(data: 'a) : unit =
+ ignore (alphaWorker ~alphaTable:alphaTable ~undolist:undolist
+ ~lookupname:lookupname ~data:data false)
+
+
+and alphaWorker ~(alphaTable: (string, 'a alphaTableData ref) H.t)
+ ~(undolist: 'a undoAlphaElement list ref option)
+ ~(lookupname: string) ~(data:'a)
+ (make_new: bool) : string * 'a =
+ let prefix, suffix, (numsuffix: int) = splitNameForAlpha ~lookupname in
+ if debugAlpha prefix then
+ ignore (E.log "Alpha worker: prefix=%s suffix=%s (%d) create=%b. "
+ prefix suffix numsuffix make_new);
+ let newname, (olddata: 'a) =
+ try
+ let rc = H.find alphaTable prefix in
+ let max, suffixes = !rc in
+ (* We have seen this prefix *)
+ if debugAlpha prefix then
+ ignore (E.log " Old max %d. Old suffixes: @[%a@]" max
+ (docList
+ (fun (s, l) -> dprintf "%s" (* d_loc l *) s)) suffixes);
+ (* Save the undo info *)
+ (match undolist with
+ Some l -> l := AlphaChangedSuffix (rc, !rc) :: !l
+ | _ -> ());
+
+ let newmax, newsuffix, (olddata: 'a), newsuffixes =
+ if numsuffix > max then begin
+ (* Clearly we have not seen it *)
+ numsuffix, suffix, data,
+ (suffix, data) :: suffixes
+ end else begin
+ match List.filter (fun (n, _) -> n = suffix) suffixes with
+ [] -> (* Not found *)
+ max, suffix, data, (suffix, data) :: suffixes
+ | [(_, l) ] ->
+ (* We have seen this exact suffix before *)
+ if make_new then begin
+ if max >= maxSuffix then
+ E.s (E.unimp ("Encountered a variable name containing ___ "
+ ^^"and many digits. This could cause overflow "
+ ^^"in the Alpha renaming module."));
+ let newsuffix = alphaSeparator ^ (string_of_int (max + 1)) in
+ max + 1, newsuffix, l, (newsuffix, data) :: suffixes
+ end else
+ max, suffix, data, suffixes
+ | _ -> E.s (E.bug "Alpha.alphaWorker")
+ end
+ in
+ rc := (newmax, newsuffixes);
+ prefix ^ newsuffix, olddata
+ with Not_found -> begin (* First variable with this prefix *)
+ (match undolist with
+ Some l -> l := AlphaAddedSuffix prefix :: !l
+ | _ -> ());
+ H.add alphaTable prefix (ref (numsuffix, [ (suffix, data) ]));
+ if debugAlpha prefix then ignore (E.log " First seen. ");
+ lookupname, data (* Return the original name *)
+ end
+ in
+ if debugAlpha prefix then
+ ignore (E.log " Res=: %s \n" newname (* d_loc oldloc *));
+ newname, olddata
+
+(* Strip the suffix. Return the prefix, the suffix (including the separator
+ * and the numeric value, possibly empty), and the
+ * numeric value of the suffix (possibly -1 if missing) *)
+and splitNameForAlpha ~(lookupname: string) : (string * string * int) =
+ let len = String.length lookupname in
+ (* Search backward for the numeric suffix. Return the first digit of the
+ * suffix. Returns len if no numeric suffix *)
+ let rec skipSuffix (i: int) =
+ if i = -1 then -1 else
+ let c = Char.code (String.get lookupname i) - Char.code '0' in
+ if c >= 0 && c <= 9 then
+ skipSuffix (i - 1)
+ else (i + 1)
+ in
+ let startSuffix = skipSuffix (len - 1) in
+
+ if startSuffix >= len (* No digits at all at the end *) ||
+ (* If the suffix has length >= maxSuffixLength, treat it as no suffix
+ at all. This ensures we only call int_of_string with values that
+ will fit in an int. *)
+ (len - startSuffix > maxSuffixLength) ||
+ startSuffix <= alphaSeparatorLen (* Not enough room for a prefix and
+ * the separator before suffix *) ||
+ (* Suffix starts with a 0 and has more characters after that *)
+ (startSuffix < len - 1 && String.get lookupname startSuffix = '0') ||
+ alphaSeparator <> String.sub lookupname
+ (startSuffix - alphaSeparatorLen)
+ alphaSeparatorLen
+ then
+ (lookupname, "", -1) (* No valid suffix in the name *)
+ else
+ (String.sub lookupname 0 (startSuffix - alphaSeparatorLen),
+ String.sub lookupname (startSuffix - alphaSeparatorLen)
+ (len - startSuffix + alphaSeparatorLen),
+ int_of_string (String.sub lookupname startSuffix (len - startSuffix)))
+
+
+let getAlphaPrefix ~(lookupname:string) : string =
+ let p, _, _ = splitNameForAlpha ~lookupname:lookupname in
+ p
+
+(* Undoes the changes as specified by the undolist *)
+let undoAlphaChanges ~(alphaTable: (string, 'a alphaTableData ref) H.t)
+ ~(undolist: 'a undoAlphaElement list) =
+ List.iter
+ (function
+ AlphaChangedSuffix (where, old) ->
+ where := old
+ | AlphaAddedSuffix name ->
+ if debugAlpha name then
+ ignore (E.log "Removing %s from alpha table\n" name);
+ H.remove alphaTable name)
+ undolist
+
+let docAlphaTable () (alphaTable: (string, 'a alphaTableData ref) H.t) =
+ let acc : (string * (int * (string * 'a) list)) list ref = ref [] in
+ H.iter (fun k d -> acc := (k, !d) :: !acc) alphaTable;
+ docList ~sep:line (fun (k, (d, _)) -> dprintf " %s -> %d" k d) () !acc
+
--- /dev/null
+(** ALPHA conversion *)
+
+(** This is the type of the elements that are recorded by the alpha
+ * conversion functions in order to be able to undo changes to the tables
+ * they modify. Useful for implementing
+ * scoping *)
+type 'a undoAlphaElement
+
+(** This is the type of the elements of the alpha renaming table. These
+ * elements can carry some data associated with each occurrence of the name. *)
+type 'a alphaTableData
+
+
+(** Create a new name based on a given name. The new name is formed from a
+ * prefix (obtained from the given name by stripping a suffix consisting of ___
+ * followed by up to 9 digits), followed by a special separator and then by a
+ * positive integer suffix. The first argument is a table mapping name
+ * prefixes to some data that specifies what suffixes have been used and how
+ * to create the new one. This function updates the table with the new
+ * largest suffix generated. The "undolist" argument, when present, will be
+ * used by the function to record information that can be used by
+ * {!Alpha.undoAlphaChanges} to undo those changes. Note that the undo
+ * information will be in reverse order in which the action occurred. Returns
+ * the new name and, if different from the lookupname, the location of the
+ * previous occurrence. This function knows about the location implicitly
+ * from the {!Cil.currentLoc}. *)
+val newAlphaName: alphaTable:(string, 'a alphaTableData ref) Hashtbl.t ->
+ undolist: 'a undoAlphaElement list ref option ->
+ lookupname:string -> data:'a -> string * 'a
+
+
+(** Register a name with an alpha conversion table to ensure that when later
+ * we call newAlphaName we do not end up generating this one *)
+val registerAlphaName: alphaTable:(string, 'a alphaTableData ref) Hashtbl.t ->
+ undolist: 'a undoAlphaElement list ref option ->
+ lookupname:string -> data:'a -> unit
+
+(** Split the name in preparation for newAlphaName. The prefix returned is
+ used to index into the hashtable. The next result value is a separator
+ (either empty or the separator chosen to separate the original name from
+ the index) *)
+val docAlphaTable: unit ->
+ (string, 'a alphaTableData ref) Hashtbl.t -> Pretty.doc
+
+
+val getAlphaPrefix: lookupname:string -> string
+
+(** Undo the changes to a table *)
+val undoAlphaChanges: alphaTable:(string, 'a alphaTableData ref) Hashtbl.t ->
+ undolist:'a undoAlphaElement list -> unit
--- /dev/null
+
+ (* Imperative bitmaps *)
+type t = { mutable nrWords : int;
+ mutable nrBits : int; (* This is 32 * nrWords *)
+ mutable bitmap : int32 array }
+
+
+ (* Enlarge a bitmap to contain at
+ * least newWords *)
+let enlarge b newWords =
+ let newbitmap =
+ if newWords > b.nrWords then
+ let a = Array.create newWords Int32.zero in
+ Array.blit b.bitmap 0 a 0 b.nrWords;
+ a
+ else
+ b.bitmap in
+ b.nrWords <- newWords;
+ b.nrBits <- newWords lsl 5;
+ b.bitmap <- newbitmap
+
+
+ (* Create a new empty bitmap *)
+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
+ (* Make an initialized array *)
+let init size how =
+ let wrd = (size + 31) lsr 5 in
+ 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
+ else
+ let acc' = Int32.shift_left acc 1 in
+ if how i then loop (i + 1) (Int32.logor acc' Int32.one)
+ else loop (i + 1) acc'
+ in
+ loop first Int32.zero
+ in
+ { nrWords = wrd;
+ nrBits = wrd lsl 5;
+ bitmap = Array.init wrd how'
+ }
+
+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 =
+ 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
+ let changed = ref false in
+ for i=0 to n - 1 do
+ begin
+ let t = a1.(i) in
+ let upd = Int32.logor t a2.(i) in
+ let _ = if upd <> t then changed := true else () in
+ Array.unsafe_set a1 i upd
+ end
+ done;
+ ! changed
+ end
+ (* 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 ();
+ (* Need to enlarge lin to lout *)
+ if lin.nrWords < n then enlarge lin n else ();
+ let changed = ref false in
+ let alin = lin.bitmap in
+ let alout = lout.bitmap in
+ let adef = def.bitmap in
+ for i=0 to n - 1 do
+ begin
+ let old = alin.(i) in
+ let nw = Int32.logor old (Int32.logand alout.(i)
+ (Int32.lognot adef.(i))) in
+ alin.(i) <- nw;
+ changed := (old <> nw) || (!changed)
+ end
+ done;
+ !changed
+ end
+
+ (* b1 *= b2 *)
+let inters b1 b2 =
+ begin
+ let n = min b1.nrWords b2.nrWords in
+ let a1 = b1.bitmap in
+ let a2 = b2.bitmap in
+ for i=0 to n - 1 do
+ begin
+ a1.(i) <- Int32.logand a1.(i) a2.(i)
+ end
+ done;
+ if n < b1.nrWords then
+ Array.fill a1 n (b1.nrWords - n) Int32.zero
+ else
+ ()
+ end
+
+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))
+ in
+ loop start
+
+let empty b = emptyInt b 0
+
+ (* b1 =? b2 *)
+let equal b1 b2 =
+ begin
+ let n = min b1.nrWords b2.nrWords in
+ let a1 = b1.bitmap in
+ let a2 = b2.bitmap in
+ let res = ref true in
+ for i=0 to n - 1 do
+ begin
+ if a1.(i) <> a2.(i) then res := false else ()
+ end
+ done;
+ if !res then
+ if b1.nrWords > n then
+ emptyInt b1 n
+ else if b2.nrWords > n then
+ emptyInt b2 n
+ else
+ true
+ else
+ false
+ end
+
+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
+ end
+
+ (* b1 -= b2 *)
+let diff b1 b2 =
+ begin
+ let n = min b1.nrWords b2.nrWords in
+ let a1 = b1.bitmap in
+ let a2 = b2.bitmap in
+ for i=0 to n - 1 do
+ a1.(i) <- Int32.logand a1.(i) (Int32.lognot a2.(i))
+ done;
+ if n < b1.nrWords then
+ Array.fill a1 n (b1.nrWords - n) Int32.zero
+ else
+ ()
+ end
+
+
+
+
+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
+ let msk = Int32.shift_left Int32.one (i - (wrd lsl 5)) in
+ (Int32.logand bmp.bitmap.(wrd) msk) <> Int32.zero
+
+
+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
+ 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
+ * bitmap *)
+let fold f bmp arg =
+ let a = bmp.bitmap in
+ let n = bmp.nrWords in
+ let rec allWords wrd bit arg =
+ if wrd >= n then arg else
+ 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
+ else arg)
+ in
+ allBits a.(wrd) bit 32 arg
+ in
+ allWords 0 0 arg
+
+
+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
--- /dev/null
+ (* Imperative bitmaps *)
+
+type t
+ (* Create a bitmap given the number
+ * of bits *)
+val make : int -> t
+val init : int -> (int -> bool) -> t (* Also initialize it *)
+
+val size : t -> int (* How much space it is reserved *)
+
+ (* The cardinality of a set *)
+val card : t -> int
+
+ (* Make a copy of a bitmap *)
+val clone : t -> t
+
+val cloneEmpty : t -> t (* An empty set with the same
+ * dimensions *)
+
+ (* Set the bit *)
+val setTo : t -> int -> bool -> unit
+val test : t -> int -> bool
+
+val testAndSetTo: t -> int -> bool -> bool (** Set the value and return the old
+ * value *)
+
+ (** destructive union. The first
+ * element is updated. Returns true
+ * if any change was actually
+ * necessary *)
+val union : t -> t -> bool
+
+ (* union_except livein liveout def.
+ * Does liveIn += (liveout - def).
+ * Return true if the first set was
+ * changed. *)
+val union_except : t -> t -> t -> bool
+
+ (* Copy the second argument onto the
+ * first *)
+val assign : t -> t -> unit
+
+
+val inters : t -> t -> unit
+val diff : t -> t -> unit
+
+
+val empty : t -> bool
+
+val equal : t -> t -> bool
+
+val toList : t -> int list
+
+val iter : (int -> unit) -> t -> unit
+val fold : ('a -> int -> 'a) -> t -> 'a -> 'a
+
--- /dev/null
+(* bitvector.ml *)
+(* Unit tests and ML implementation for some of bitvector.mli. *)
+
+open Pretty (* pretty printing *)
+
+
+type bitvector (* details are opaque to Ocaml *)
+
+type t = bitvector
+
+(* externals implemented in bitvectori.c *)
+external make: int (*n*) -> bitvector = "bitvector_create"
+external size: bitvector (*v*) -> int = "bitvector_length"
+external copyBits: bitvector (*dest*) -> bitvector (*src*) -> unit = "bitvector_copyBits"
+external clearAll: bitvector (*v*) -> unit = "bitvector_clearAll"
+external test: bitvector (*v*) -> int (*n*) -> bool = "bitvector_test"
+external setTo: bitvector (*v*) -> int (*n*) -> bool (*bit*) -> unit = "bitvector_setTo"
+external testAndSetTo: bitvector (*v*) -> int (*n*) -> bool (*bit*) -> bool = "bitvector_testAndSetTo"
+external set: bitvector (*v*) -> int (*n*) -> unit = "bitvector_set"
+external clear: bitvector (*v*) -> int (*n*) -> unit = "bitvector_clear"
+external unioneq: bitvector (*a*) -> bitvector (*b*) -> unit = "bitvector_unioneq"
+external intersecteq: bitvector (*a*) -> bitvector (*b*) -> unit = "bitvector_intersecteq"
+external complementeq: bitvector (*a*) -> unit = "bitvector_complementeq"
+external count: bitvector (*v*) -> int = "bitvector_count"
+external fold_left: ('a -> int -> 'a) (*f*) -> bitvector (*v*) -> 'a (*init*) -> 'a = "bitvector_fold_left"
+external union_except: bitvector (*a*) -> bitvector (*b*) -> bitvector (*c*) -> bool = "bitvector_inplace_union_except"
+
+
+(* ----------------- utilities ---------------- *)
+let copy (src: bitvector) : bitvector =
+begin
+ let ret:bitvector = (make (size src)) in
+ (copyBits ret src);
+ ret
+end
+
+
+let union (a: bitvector) (b: bitvector) : bitvector =
+begin
+ let ret:bitvector = (copy a) in
+ (unioneq ret b);
+ ret
+end
+
+let intersect (a: bitvector) (b: bitvector) : bitvector =
+begin
+ let ret:bitvector = (copy a) in
+ (intersecteq ret b);
+ ret
+end
+
+let complement (a: bitvector) : bitvector =
+begin
+ let ret:bitvector = (copy a) in
+ (complementeq ret);
+ ret
+end
+
+
+let iter (f: int -> unit) (vec: bitvector): unit =
+begin
+ let wrapper () (i: int) : unit =
+ (f i)
+ in
+ (fold_left wrapper vec ())
+end
+
+
+let rec d_bitvector () (vec: bitvector) : doc =
+begin
+ let len:int = (size vec) in
+ let b:Buffer.t = (Buffer.create (len+2)) in
+
+ (* build up the string using a Buffer *)
+ (Buffer.add_char b '"');
+ let rec loop (i: int) : unit =
+ begin
+ if (i < len) then (
+ (Buffer.add_char b
+ (if (test vec i) then '1' else '0'));
+ (if (i mod 8 == 7) then
+ (Buffer.add_char b '_'));
+ (loop (i+1))
+ )
+ else
+ ()
+ end in
+ (loop 0);
+ (Buffer.add_char b '"');
+
+ (* extract the built string and make a doc *)
+ (text (Buffer.contents b))
+end
+
+
+let d_bitvector_as_set () (vec: bitvector) : doc =
+begin
+ if ((count vec) == 0) then
+ (text "{}")
+ else (
+ let init:doc = (text "{") in
+ let f (acc: doc) (i: int) : doc =
+ if (acc == init) then
+ acc ++ (num i)
+ else
+ acc ++ (text ",") ++ (num i)
+ in
+ (fold_left f vec init) ++ (text "}")
+ )
+end
+
+
+(* ------------------ unit tests -------------------- *)
+let printVec (name: string) (vec: bitvector) : unit =
+begin
+ ignore (printf "%s: %a %a (%d)\n"
+ name
+ d_bitvector vec
+ d_bitvector_as_set vec
+ (count vec));
+end
+
+
+let testBitvector () : unit =
+begin
+ let v1:bitvector = (make 10) in
+ (printVec "v1 initial " v1);
+
+ (set v1 4);
+ (printVec "v1 with bit 4 set" v1);
+
+ (set v1 2);
+ (clear v1 4);
+ (set v1 3);
+ (printVec "v1 with 2,3 set " v1);
+
+ (try
+ (set v1 (0-2));
+ (failwith "should have failed")
+ with Invalid_argument(s) ->
+ ignore (printf "caught expected error: %s\n" s));
+
+ (try
+ (set v1 100);
+ (failwith "should have failed")
+ with Invalid_argument(s) ->
+ ignore (printf "caught expected error: %s\n" s));
+
+ (set v1 5);
+ (set v1 7);
+ (printVec "v1 with primes " v1);
+
+
+ let v2:bitvector = (make 30) in
+ (printVec "v2 initial " v2);
+
+ (set v2 2);
+ (set v2 3);
+ (set v2 5);
+ (set v2 7);
+ (set v2 11);
+ (set v2 13);
+ (set v2 17);
+ (set v2 19);
+ (set v2 23);
+ (set v2 29);
+ (set v2 1);
+ (printVec "v2 with primes+1 " v2);
+
+ (clear v2 5);
+ (clear v2 6);
+ (clear v2 7);
+ (clear v2 8);
+ (clear v2 9);
+ (printVec "v2, primes\\{5-9} " v2);
+
+
+ (printVec "v1 | v2 " (union v1 v2));
+ (printVec "v1 & v2 " (intersect v1 v2));
+ (printVec "~v1 " (complement v1));
+ (printVec "~v2 " (complement v2));
+
+
+ let v3:bitvector = (make 64) in
+ (unioneq v3 v2);
+ (printVec "v3 = v2 " v3);
+ (printVec "v1 | ~v3 " (union v1 (complement v3)));
+ (printVec "v1 & ~v3 " (intersect v1 (complement v3)));
+ (printVec "v3 | ~v1 " (union v3 (complement v1)));
+ (printVec "v3 & ~v1 " (intersect v3 (complement v1)));
+
+
+ (exit 0);
+end
+
+
+(* EOF *)
--- /dev/null
+(* bitvector.mli *)
+(* This module provides efficient bitvectors. The size of the
+ * vector must be specified in advance. The implementation
+ * is in bitvectori.c and bitvector.ml. *)
+
+type bitvector (* details are opaque to Ocaml *)
+
+type t = bitvector (* a synonim *)
+
+(* Create a new bitvector with 'n' bits, all initialized to 0. *)
+external make: int (*n*) -> bitvector = "bitvector_create"
+
+(* Make a copy of 'src'. *)
+val copy: bitvector (*src*) -> bitvector
+
+
+(* Query how many bits are available in 'v'; this might be more
+ * than was originally requested. *)
+external size: bitvector (*v*) -> int = "bitvector_length"
+
+(* Copy the bits of 'src' into 'dest'. If they have different
+ * sizes, copy the smaller number of bits. *)
+external copyBits: bitvector (*dest*) -> bitvector (*src*) -> unit = "bitvector_copyBits"
+
+(* Set all the bits to 0. *)
+external clearAll: bitvector (*v*) -> unit = "bitvector_clearAll"
+
+
+(* Test bit 'n' of vector 'v'. *)
+external test: bitvector (*v*) -> int (*n*) -> bool = "bitvector_test"
+
+(* Set bit 'n' of vector 'v' to value 'bit'. *)
+external setTo: bitvector (*v*) -> int (*n*) -> bool (*bit*) -> unit = "bitvector_setTo"
+
+external testAndSetTo: bitvector (*v*) -> int (*n*) -> bool (*newval*)-> bool = "bitvector_testAndSetTo"
+
+(* Specialized versions for setting to 0 or 1. *)
+external set: bitvector (*v*) -> int (*n*) -> unit = "bitvector_set"
+external clear: bitvector (*v*) -> int (*n*) -> unit = "bitvector_clear"
+
+
+(* Set-like operations on set of '1' bits. *)
+
+(* These mutate the value of 'a'. *)
+external unioneq: bitvector (*a*) -> bitvector (*b*) -> unit = "bitvector_unioneq"
+external intersecteq: bitvector (*a*) -> bitvector (*b*) -> unit = "bitvector_intersecteq"
+external complementeq: bitvector (*a*) -> unit = "bitvector_complementeq"
+
+(* Non-mutating versions. *)
+val union: bitvector (*a*) -> bitvector (*b*) -> bitvector
+val intersect: bitvector (*a*) -> bitvector (*b*) -> bitvector
+val complement: bitvector (*a*) -> bitvector
+
+(* Count the number of '1' bits. *)
+external count: bitvector (*v*) -> int = "bitvector_count"
+
+(* Apply a function to each index where a '1' appears. *)
+external fold_left: ('a -> int -> 'a) (*f*) -> bitvector (*v*) -> 'a (*init*) -> 'a = "bitvector_fold_left"
+val iter: (int -> unit) (*f*) -> bitvector (*v*) -> unit
+
+
+(* Add to 'a' (modifying it) all the bits in 'b', except do not add
+ * bits if they are also in 'c'. Return true if something was added to a. *)
+external union_except: bitvector (*a*) -> bitvector (*b*) -> bitvector (*c*) -> bool = "bitvector_inplace_union_except"
+
+
+(* Print a bitvector. *)
+val d_bitvector: unit -> bitvector -> Pretty.doc
+val d_bitvector_as_set: unit -> bitvector -> Pretty.doc
+
+
+(* Run unit tests, then exit. *)
+val testBitvector: unit -> unit
+
+
+(* EOF *)
--- /dev/null
+v1 initial : "00000000_00000000_00000000_00000000_" {} (0)
+v1 with bit 4 set: "00001000_00000000_00000000_00000000_" {4} (1)
+v1 with 2,3 set : "00110000_00000000_00000000_00000000_" {2,3} (2)
+caught expected error: index out of bounds
+caught expected error: index out of bounds
+v1 with primes : "00110101_00000000_00000000_00000000_" {2,3,5,7} (4)
+v2 initial : "00000000_00000000_00000000_00000000_" {} (0)
+v2 with primes+1 : "01110101_00010100_01010001_00000100_" {1,2,3,5,7,11,13,17,19,23,29} (11)
+v2, primes\{5-9} : "01110000_00010100_01010001_00000100_" {1,2,3,11,13,17,19,23,29} (9)
+v1 | v2 : "01110101_00010100_01010001_00000100_" {1,2,3,5,7,11,13,17,19,23,29} (11)
+v1 & v2 : "00110000_00000000_00000000_00000000_" {2,3} (2)
+~v1 : "11001010_11111111_11111111_11111111_" {0,1,4,6,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31} (28)
+~v2 : "10001111_11101011_10101110_11111011_" {0,4,5,6,7,8,9,10,12,14,15,16,18,20,21,22,24,25,26,27,28,30,31} (23)
+v3 = v2 : "01110000_00010100_01010001_00000100_00000000_00000000_00000000_00000000_" {1,2,3,11,13,17,19,23,29} (9)
+v1 | ~v3 : "10111111_11101011_10101110_11111011_" {0,2,3,4,5,6,7,8,9,10,12,14,15,16,18,20,21,22,24,25,26,27,28,30,31} (25)
+v1 & ~v3 : "00000101_00000000_00000000_00000000_" {5,7} (2)
+v3 | ~v1 : "11111010_11111111_11111111_11111111_00000000_00000000_00000000_00000000_" {0,1,2,3,4,6,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31} (30)
+v3 & ~v1 : "01000000_00010100_01010001_00000100_00000000_00000000_00000000_00000000_" {1,11,13,17,19,23,29} (7)
--- /dev/null
+/* bitvectori.c */
+/* C implementation of some of bitvector.mli */
+
+/* Note: I have not added all the CAMLparam and CAMLreturn statements
+ * the manual says I need, since I think they are only needed if I
+ * call back into the ocaml code. */
+
+#include <caml/alloc.h> /* caml_alloc */
+#include <caml/mlvalues.h> /* value */
+#include <caml/fail.h> /* caml_invalid_argument */
+#include <caml/memory.h> /* CAMLparam, etc. */
+#include <caml/callback.h> /* caml_callback2 */
+
+#include <string.h> /* memset, memcpy */
+#include <assert.h> /* assert */
+#include <stdio.h> /* printf (for debugging) */
+
+
+#if 0
+ #define debugf(x) printf x
+#else
+ #define debugf(x) ((void)0)
+#endif
+
+enum { BITS_PER_WORD = sizeof(unsigned long) * 8 };
+
+
+/* map a bitvector 'value' to a pointer to its bits */
+inline unsigned long *getBits(value vec)
+{
+ return (unsigned long*)Op_val(vec);
+}
+
+/* map a bitvector 'value' to the # of words of bits it has */
+inline long getNumWords(value vec)
+{
+ return Wosize_val(vec);
+}
+
+
+value bitvector_create(value n_)
+{
+ CAMLparam1(n_);
+ CAMLlocal1(ret);
+
+ int bits = Int_val(n_);
+ int words;
+
+ if (bits < 0) {
+ debugf(("bits=%d\n", bits));
+ caml_invalid_argument("Negative bitvector size.");
+ }
+
+ /* divide, rounding up */
+ words = (bits + BITS_PER_WORD-1) / BITS_PER_WORD;
+
+ debugf(("bitvector_create: bits=%d, words=%d\n", bits, words));
+
+ /* allocate */
+ ret = caml_alloc(words, No_scan_tag);
+ assert(getNumWords(ret) >= words);
+
+ /* zero */
+ memset(getBits(ret), 0, words * sizeof(unsigned long));
+
+ CAMLreturn(ret);
+}
+
+
+value bitvector_length(value vec)
+{
+ long words = getNumWords(vec);
+ return Val_long(words * BITS_PER_WORD);
+}
+
+
+void bitvector_copyBits(value dest, value src)
+{
+ long srcWords = getNumWords(src);
+ long destWords = getNumWords(dest);
+ long words = (srcWords<destWords? srcWords : destWords);
+
+ unsigned long const *srcBits = getBits(src);
+ unsigned long *destBits = getBits(dest);
+
+ memcpy(destBits, srcBits, words * sizeof(unsigned long));
+}
+
+
+void bitvector_clearAll(value vec)
+{
+ long words = getNumWords(vec);
+ unsigned long *bits = getBits(vec);
+
+ memset(bits, 0, words * sizeof(unsigned long));
+}
+
+
+/* given vector 'vec' and bit 'n', set 'bits' to point at the
+ * word containing the bit, and 'n' to the bit number */
+#define OFFSET_CALCULATION \
+ unsigned long *bits = getBits(vec); \
+ long words = getNumWords(vec); \
+ if (n < 0 || n >= words * BITS_PER_WORD) { \
+ debugf(("n=%d words=%ld\n", n, words)); \
+ caml_array_bound_error(); \
+ } \
+ bits += n / BITS_PER_WORD; \
+ n = n % BITS_PER_WORD /* user ; */
+
+
+value bitvector_test(value vec, value n_)
+{
+ int n = Int_val(n_);
+ int bit;
+
+ unsigned long *bits = getBits(vec);
+ long words = getNumWords(vec);
+
+ if (n < 0) {
+ debugf(("n=%d words=%ld\n", n, words));
+ caml_array_bound_error();
+ }
+ else if (n >= words * BITS_PER_WORD) {
+ /* not an error; this bit is simply regarded as not set */
+ return Val_int(0);
+ }
+
+ bits += n / BITS_PER_WORD;
+ n = n % BITS_PER_WORD;
+
+ bit = (*bits >> n) & 1;
+ return Val_int(bit);
+}
+
+
+void bitvector_set(value vec, value n_)
+{
+ int n = Int_val(n_);
+
+ OFFSET_CALCULATION;
+
+ *bits |= (1L << n);
+}
+
+
+void bitvector_clear(value vec, value n_)
+{
+ int n = Int_val(n_);
+
+ OFFSET_CALCULATION;
+
+ *bits &= ~(1L << n);
+}
+
+
+void bitvector_setTo(value vec, value n_, value bit_)
+{
+ int n = Int_val(n_);
+
+ OFFSET_CALCULATION;
+
+ if (Int_val(bit_)) {
+ *bits |= (1L << n);
+ }
+ else {
+ *bits &= ~(1L << n);
+ }
+}
+
+value bitvector_testAndSetTo(value vec, value n_, value bit_)
+{
+ int n = Int_val(n_);
+ value res;
+
+ OFFSET_CALCULATION;
+
+ res = Val_int((*bits >> n) & 1);
+
+ if (Int_val(bit_)) {
+ *bits |= (1L << n);
+ }
+ else {
+ *bits &= ~(1L << n);
+ }
+ return res;
+}
+
+
+void bitvector_unioneq(value a, value b)
+{
+ long aWords = getNumWords(a);
+ long bWords = getNumWords(b);
+
+ unsigned long *aBits = getBits(a);
+ unsigned long const *bBits = getBits(b);
+
+ while (aWords && bWords) {
+ *aBits |= *bBits;
+ aBits++;
+ bBits++;
+ aWords--;
+ bWords--;
+ }
+
+ /* any excess bits in 'a' are left as-is */
+}
+
+
+void bitvector_intersecteq(value a, value b)
+{
+ long aWords = getNumWords(a);
+ long bWords = getNumWords(b);
+
+ unsigned long *aBits = getBits(a);
+ unsigned long const *bBits = getBits(b);
+
+ while (aWords && bWords) {
+ *aBits &= *bBits;
+ aBits++;
+ bBits++;
+ aWords--;
+ bWords--;
+ }
+
+ /* any excess bits in 'a' are zeroed, under the premise that
+ * the missing bits of 'b' should be treated as zero and this
+ * is an intersection operation */
+ while (aWords) {
+ *aBits = 0;
+ aBits++;
+ aWords--;
+ }
+}
+
+
+
+void bitvector_complementeq(value a)
+{
+ long aWords = getNumWords(a);
+ unsigned long *aBits = getBits(a);
+
+ while (aWords) {
+ *aBits = ~*aBits;
+ aBits++;
+ aWords--;
+ }
+}
+
+
+value bitvector_count(value vec)
+{
+ long words = getNumWords(vec);
+ unsigned long *bits = getBits(vec);
+
+ int ct = 0;
+
+ while (words) {
+ unsigned long w = *bits;
+ while (w) {
+ ct++;
+
+ /* set the least significant 1 bit of 'w' to 0 */
+ w ^= (w & (~w + 1));
+ }
+
+ words--;
+ bits++;
+ }
+
+ return Val_int(ct);
+}
+
+
+value bitvector_fold_left(value f, value vec, value result)
+{
+ CAMLparam3(f, vec, result);
+
+ /* This is so I can detect when the GC moves the vector's storage. */
+ value orig_vec = vec;
+
+ long words = getNumWords(vec);
+ unsigned long *bits = getBits(vec);
+
+ int bit = 0;
+
+ long word;
+ for (word=0; word<words; word++) {
+ unsigned long w = bits[word];
+
+ int i;
+ for (i=0; i < BITS_PER_WORD; i++) {
+ if (w & 1) {
+ result = caml_callback2(f, result, Val_int(bit));
+ if (vec != orig_vec) {
+ /* the GC moved my storage, so get my pointer again */
+ bits = getBits(vec);
+
+ /* should not have changed the size */
+ assert(words == getNumWords(vec));
+
+ /* 2005-06-14: The above code *has* been tested, by
+ * verifier$ ./runvml -kettle -dry ex/doublylinked.c
+ * though of course that command's ability to exercise
+ * this code will not last. */
+ }
+ }
+ w >>= 1;
+ bit++;
+ }
+ }
+
+ CAMLreturn(result);
+}
+
+
+/* a |= (b & ~c) */
+/* This is implemented as a primitive function because it is the
+ * behavior I need and building it on top of the other primitives
+ * would require an extra allocation. */
+value bitvector_inplace_union_except(value a, value b, value c)
+{
+ long aWords = getNumWords(a);
+ long bWords = getNumWords(b);
+ long cWords = getNumWords(c);
+
+ unsigned long *aBits = getBits(a);
+ unsigned long const *bBits = getBits(b);
+ unsigned long const *cBits = getBits(c);
+
+ int changes = 0;
+
+ while (aWords && bWords) {
+ /* mask of bits to consider */
+ unsigned long mask;
+ if (cWords) {
+ mask = *cBits;
+ cBits++;
+ cWords--;
+ }
+ else {
+ /* it is ok for 'c' to end early; we just treat it as having
+ * as many extra 0s as we need */
+ mask = 0;
+ }
+ mask = ~mask;
+
+ /* add everything in both 'b' and 'mask' to 'a' */
+ {
+ unsigned long oldaBits = *aBits;
+ *aBits |= (*bBits & mask);
+ if(*aBits != oldaBits) { changes = 1; }
+ }
+
+ aBits++;
+ bBits++;
+ aWords--;
+ bWords--;
+ }
+
+ /* If we exhausted 'b', then fine. But if we exhausted 'a' without
+ * exhausting 'b', see if there are some bits in 'b' that are supposed
+ * to go into 'a' but cannot because 'a' is not large enough. */
+
+ while (bWords) {
+ /* like above */
+ unsigned long mask;
+ if (cWords) {
+ mask = *cBits;
+ cBits++;
+ cWords--;
+ }
+ else {
+ mask = 0;
+ }
+ mask = ~mask;
+
+ if (*bBits & mask) {
+ caml_invalid_argument(
+ "inplace_union_except: there are bits from 'b' not masked by 'c' "
+ "that exceed the capacity of 'a' to store");
+ }
+
+ bBits++;
+ bWords--;
+ }
+
+ return Val_bool(changes);
+}
+
+
+#undef OFFSET_CALCULATION
+
+
+/* EOF */
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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
+
+
+(* We often need to concatenate sequences and using lists for this purpose is
+ * expensive. So we define a kind of "concatenable lists" that are easier to
+ * concatenate *)
+type 'a clist =
+ | CList of 'a list (* This is the only representation for empty
+ * *)
+ | CConsL of 'a * 'a clist
+ | CConsR of 'a clist * 'a
+ | CSeq of 'a clist * 'a clist (* We concatenate only two of them at this
+ * time. Neither is CEmpty. To be sure
+ * always use append to make these *)
+
+let rec listifyOnto (tail: 'a list) = function
+ CList l -> l @ tail
+ | CConsL (x, l) -> x :: listifyOnto tail l
+ | CConsR (l, x) -> listifyOnto (x :: tail) l
+ | CSeq (l1, l2) -> listifyOnto (listifyOnto tail l2) l1
+
+let toList l = listifyOnto [] l
+let fromList l = CList l
+
+
+let single x = CList [x]
+let empty = CList []
+
+let checkBeforeAppend (l1: 'a clist) (l2: 'a clist) : bool =
+ l1 != l2 || l1 = (CList [])
+
+let append l1 l2 =
+ if l1 = CList [] then l2 else
+ if l2 = CList [] then l1 else
+ begin
+ if l1 == l2 then
+ raise (Failure "You should not use Clist.append to double a list");
+ CSeq (l1, l2)
+ end
+
+let rec length (acc: int) = function
+ CList l -> acc + (List.length l)
+ | CConsL (x, l) -> length (acc + 1) l
+ | CConsR (l, _) -> length (acc + 1) l
+ | CSeq (l1, l2) -> length (length acc l1) l2
+let length l = length 0 l (* The external version *)
+
+let map (f: 'a -> 'b) (l: 'a clist) : 'b clist =
+ let rec loop = function
+ CList l -> CList (List.map f l)
+ | CConsL (x, l) -> let x' = f x in CConsL (x', loop l)
+ | CConsR (l, x) -> let l' = loop l in CConsR (l', f x)
+ | CSeq (l1, l2) -> let l1' = loop l1 in CSeq (l1', loop l2)
+ in
+ loop l
+
+
+let fold_left (f: 'acc -> 'a -> 'acc) (start: 'acc) (l: 'a clist) =
+ let rec loop (start: 'acc) = function
+ CList l -> List.fold_left f start l
+ | CConsL (x, l) -> loop (f start x) l
+ | CConsR (l, x) -> let res = loop start l in f res x
+ | CSeq (l1, l2) ->
+ let res1 = loop start l1 in
+ loop res1 l2
+ in
+ loop start l
+
+let iter (f: 'a -> unit) (l: 'a clist) : unit =
+ let rec loop = function
+ CList l -> List.iter f l
+ | CConsL (x, l) -> f x; loop l
+ | CConsR (l, x) -> loop l; f x
+ | CSeq (l1, l2) -> loop l1; loop l2
+ in
+ loop l
+
+
+let rec rev (revelem: 'a -> 'a) = function
+ CList l ->
+ let rec revonto (tail: 'a list) = function
+ [] -> tail
+ | x :: rest -> revonto (revelem x :: tail) rest
+ in
+ CList (revonto [] l)
+
+ | CConsL (x, l) -> CConsR (rev revelem l, x)
+ | CConsR (l, x) -> CConsL (x, rev revelem l)
+ | CSeq (l1, l2) -> CSeq (rev revelem l2, rev revelem l1)
+
+
+let docCList (sep: doc) (doone: 'a -> doc) () (dl: 'a clist) =
+ fold_left
+ (fun (acc: doc) (elem: 'a) ->
+ let elemd = doone elem in
+ if acc == nil then elemd else acc ++ sep ++ elemd)
+ nil
+ dl
+
+
+(* let debugCheck (lst: 'a clist) : unit =*)
+(* (* use a hashtable to store values encountered *)*)
+(* let tbl : 'a bool H.t = (H.create 13) in*)
+
+(* letrec recurse (node: 'a clist) =*)
+(* (* have we seen*)*)
+
+(* match node with*)
+(* | CList*)
+
+
+(* --------------- testing ----------------- *)
+type boxedInt =
+ | BI of int
+ | SomethingElse
+
+let d_boxedInt () b =
+ match b with
+ | BI(i) -> (dprintf "%d" i)
+ | SomethingElse -> (text "somethingElse")
+
+
+(* sm: some simple tests of CLists
+let testCList () : unit =
+begin
+ (trace "sm" (dprintf "in testCList\n"));
+
+ let clist1 = (fromList [BI(1); BI(2); BI(3)]) in
+ (trace "sm" (dprintf "length of clist1 is %d\n"
+ (length clist1) ));
+
+ let flattened = (toList clist1) in
+ (trace "sm" (dprintf "flattened: %a\n"
+ (docList ~sep:(chr ',' ++ break) (d_boxedInt ()))
+ flattened));
+
+
+end
+1) in
+ (trace "sm" (dprintf "flattened: %a\n"
+ (docList ~sep:(chr ',' ++ break) (d_boxedInt ()))
+ flattened));
+
+
+end
+*)
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(** Utilities for managing "concatenable lists" (clists). We often need to
+ concatenate sequences, and using lists for this purpose is expensive. This
+ module provides routines to manage such lists more efficiently. In this
+ model, we never do cons or append explicitly. Instead we maintain
+ the elements of the list in a special data structure. Routines are provided
+ to convert to/from ordinary lists, and carry out common list operations.*)
+
+(** The clist datatype. A clist can be an ordinary list, or a clist preceded
+ or followed by an element, or two clists implicitly appended together*)
+type 'a clist =
+ | CList of 'a list (** The only representation for the empty
+ list. Try to use sparingly. *)
+ | CConsL of 'a * 'a clist (** Do not use this a lot because scanning
+ * it is not tail recursive *)
+ | CConsR of 'a clist * 'a
+ | CSeq of 'a clist * 'a clist (** We concatenate only two of them at this
+ time. Neither is the empty clist. To be
+ sure always use append to make these *)
+
+
+(** Convert a clist to an ordinary list *)
+val toList: 'a clist -> 'a list
+
+(** Convert an ordinary list to a clist *)
+val fromList: 'a list -> 'a clist
+
+(** Create a clist containing one element *)
+val single: 'a -> 'a clist
+
+(** The empty clist *)
+val empty: 'a clist
+
+
+(** Append two clists *)
+val append: 'a clist -> 'a clist -> 'a clist
+
+(** A useful check to assert before an append. It checks that the two lists
+ * are not identically the same (Except if they are both empty) *)
+val checkBeforeAppend: 'a clist -> 'a clist -> bool
+
+(** Find the length of a clist *)
+val length: 'a clist -> int
+
+(** Map a function over a clist. Returns another clist *)
+val map: ('a -> 'b) -> 'a clist -> 'b clist
+
+
+(** A version of fold_left that works on clists *)
+val fold_left: ('acc -> 'a -> 'acc) -> 'acc -> 'a clist -> 'acc
+
+(** A version of iter that works on clists *)
+val iter: ('a -> unit) -> 'a clist -> unit
+
+(** Reverse a clist. The first function reverses an element. *)
+val rev: ('a -> 'a) -> 'a clist -> 'a clist
+
+(** A document for printing a clist (similar to [docList]) *)
+val docCList:
+ Pretty.doc -> ('a -> Pretty.doc) -> unit -> 'a clist -> Pretty.doc
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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
+
+
+
+let debugFlag = ref false (* If set then print debugging info *)
+let verboseFlag = ref false
+
+(**** Error reporting ****)
+exception Error
+let s (d : 'a) = raise Error
+
+let hadErrors = ref false
+
+let errorContext = ref []
+let pushContext f = errorContext := f :: (!errorContext)
+let popContext () =
+ match !errorContext with
+ _ :: t -> errorContext := t
+ | [] -> s (eprintf "Bug: cannot pop error context")
+
+
+let withContext ctx f x =
+ pushContext ctx;
+ try
+ let res = f x in
+ popContext ();
+ res
+ with e -> begin
+ popContext ();
+ raise e
+ end
+
+ (* Make sure that showContext calls
+ * each f with its appropriate
+ * errorContext as it was when it was
+ * pushed *)
+let showContext () =
+ let rec loop = function
+ [] -> ()
+ | f :: rest -> (errorContext := rest; (* Just in case f raises an error *)
+ ignore (eprintf " Context : %t@!" f);
+ loop rest)
+ in
+ let old = !errorContext in
+ try
+ loop old;
+ errorContext := old
+ with e -> begin
+ errorContext := old;
+ raise e
+ end
+
+let contextMessage (name: string) (d: doc) =
+ ignore (eprintf "@!%s: %a@!" name insert d);
+ showContext ()
+
+let warnFlag = ref false
+
+let logChannel : out_channel ref = ref stderr
+
+
+let bug (fmt : ('a,unit,doc,unit) format4) : 'a =
+ let f d =
+ hadErrors := true; contextMessage "Bug" d;
+ flush !logChannel
+ in
+ Pretty.gprintf f fmt
+
+let error (fmt : ('a,unit,doc,unit) format4) : 'a =
+ let f d = hadErrors := true; contextMessage "Error" d;
+ flush !logChannel
+ in
+ Pretty.gprintf f fmt
+
+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 f d = contextMessage "Warning" d; flush !logChannel in
+ Pretty.gprintf f fmt
+
+let warnOpt (fmt : ('a,unit,doc,unit) format4) : 'a =
+ let f d =
+ if !warnFlag then contextMessage "Warning" d;
+ flush !logChannel in
+ Pretty.gprintf f fmt
+
+
+let log (fmt : ('a,unit,doc,unit) format4) : 'a =
+ let f d = fprint !logChannel 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
+ Pretty.gprintf f fmt
+
+let null (fmt : ('a,unit,doc,unit) format4) : 'a =
+ let f d = () in
+ Pretty.gprintf f fmt
+
+
+let theLexbuf = ref (Lexing.from_string "")
+
+let fail format = Pretty.gprintf (fun x -> Pretty.fprint stderr 80 x;
+ raise (Failure "")) format
+
+
+
+(***** Handling parsing errors ********)
+type parseinfo =
+ { mutable linenum: int ; (* Current line *)
+ mutable linestart: int ; (* The position in the buffer where the
+ * current line starts *)
+ mutable fileName : string ; (* Current file *)
+ mutable hfile : string ; (* High-level file *)
+ mutable hline : int; (* High-level line *)
+ lexbuf : Lexing.lexbuf;
+ inchan : in_channel option; (* None, if from a string *)
+ mutable num_errors : int; (* Errors so far *)
+ }
+
+let dummyinfo =
+ { linenum = 1;
+ linestart = 0;
+ fileName = "" ;
+ lexbuf = Lexing.from_string "";
+ inchan = None;
+ hfile = "";
+ hline = 0;
+ num_errors = 0;
+ }
+
+let current = ref dummyinfo
+
+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 = '"' (* '"' ( *)
+ 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
+ if c <> '\\' then begin
+ String.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
+ loop (copyto + 1) (i + 2)
+ else
+ loop (copyto + 1) (i + 1)
+ end
+ in
+ loop 0 0
+
+let readingFromStdin = ref false
+
+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
+ readingFromStdin := true;
+ stdin
+ end else begin
+ readingFromStdin := false;
+ open_in fname
+ end
+ 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 =
+ cleanFileName (if useBasename then Filename.basename fname else fname);
+ lexbuf = lexbuf; inchan = Some inchan;
+ hfile = ""; hline = 0;
+ num_errors = 0 } in
+
+ current := i;
+ lexbuf
+
+let startParsingFromString ?(file="<string>") ?(line=1) (str: string) =
+ let lexbuf = Lexing.from_string str in
+ let i =
+ { linenum = line; linestart = line - 1;
+ fileName = file;
+ hfile = ""; hline = 0;
+ lexbuf = lexbuf;
+ inchan = None;
+ num_errors = 0 }
+ in
+ current := i;
+ lexbuf
+
+let finishParsing () =
+ let i = !current in
+ (match i.inchan with Some c -> close_in c | _ -> ());
+ current := dummyinfo
+
+
+(* Call this function to announce a new line *)
+let newline () =
+ let i = !current in
+ i.linenum <- 1 + i.linenum;
+ i.linestart <- Lexing.lexeme_start i.lexbuf
+
+let newHline () =
+ let i = !current in
+ i.hline <- 1 + i.hline
+
+let setCurrentLine (i: int) =
+ !current.linenum <- i
+
+let setCurrentFile (n: string) =
+ !current.fileName <- cleanFileName n
+
+
+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 =
+ try Parsing.symbol_start (), Parsing.symbol_end ()
+ with e -> begin
+ ignore (warn "Parsing raised %s\n" (Printexc.to_string e));
+ 0, 0
+ end
+ in
+ let i = !current in
+ let adjStart =
+ if token_start < i.linestart then 0 else token_start - i.linestart in
+ let adjEnd =
+ if token_end < i.linestart then 0 else token_end - i.linestart in
+ output_string
+ stderr
+ (i.fileName ^ "[" ^ (string_of_int i.linenum) ^ ":"
+ ^ (string_of_int adjStart) ^ "-"
+ ^ (string_of_int adjEnd)
+ ^ "]"
+ ^ " : " ^ msg);
+ output_string stderr "\n";
+ flush stderr ;
+ 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
+ end;
+ hadErrors := true;
+ raise Parsing.Parse_error
+
+
+
+
+(* More parsing support functions: line, file, char count *)
+let getPosition () : int * string * int =
+ let i = !current in
+ i.linenum, i.fileName, Lexing.lexeme_start i.lexbuf
+
+
+let getHPosition () =
+ !current.hline, !current.hfile
+
+(** Type for source-file locations *)
+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 =
+ text (l.file ^ ":" ^ string_of_int l.line)
+
+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 hl, hf = getHPosition () in
+ let l, f, c = getPosition () in
+ { hfile = hf; hline = hl;
+ file = f; line = l }
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+(** Utility functions for error-reporting *)
+
+(** A channel for printing log messages *)
+val logChannel : out_channel ref
+
+(** If set then print debugging info *)
+val debugFlag : bool ref
+
+val verboseFlag : bool ref
+
+
+(** Set to true if you want to see all warnings. *)
+val warnFlag: bool ref
+
+(** Error reporting functions raise this exception *)
+exception Error
+
+
+ (* Error reporting. All of these functions take same arguments as a
+ * Pretty.eprintf. They set the hadErrors flag, but do not raise an
+ * exception. Their return type is unit.
+ *)
+
+(** Prints an error message of the form [Error: ...].
+ Use in conjunction with s, for example: [E.s (E.error ... )]. *)
+val error: ('a,unit,Pretty.doc,unit) format4 -> 'a
+
+(** Similar to [error] except that its output has the form [Bug: ...] *)
+val bug: ('a,unit,Pretty.doc,unit) format4 -> 'a
+
+(** Similar to [error] except that its output has the form [Unimplemented: ...] *)
+val unimp: ('a,unit,Pretty.doc,unit) format4 -> 'a
+
+(** Stop the execution by raising an Error. *)
+val s: 'a -> 'b
+
+(** This is set whenever one of the above error functions are called. It must
+ be cleared manually *)
+val hadErrors: bool ref
+
+(** Like {!Errormsg.error} but does not raise the {!Errormsg.Error}
+ * exception. Return type is unit. *)
+val warn: ('a,unit,Pretty.doc,unit) format4 -> 'a
+
+(** Like {!Errormsg.warn} but optional. Printed only if the
+ * {!Errormsg.warnFlag} is set *)
+val warnOpt: ('a,unit,Pretty.doc,unit) format4 -> 'a
+
+(** Print something to [logChannel] *)
+val log: ('a,unit,Pretty.doc,unit) format4 -> 'a
+
+(** same as {!Errormsg.log} but do not wrap lines *)
+val logg: ('a,unit,Pretty.doc,unit) format4 -> 'a
+
+ (* All of the error and warning reporting functions can also print a
+ * context. To register a context printing function use "pushContext". To
+ * remove the last registered one use "popContext". If one of the error
+ * reporting functions is called it will invoke all currently registered
+ * context reporting functions in the reverse order they were registered. *)
+
+(** Do not actually print (i.e. print to /dev/null) *)
+val null : ('a,unit,Pretty.doc,unit) format4 -> 'a
+
+(** Registers a context printing function *)
+val pushContext : (unit -> Pretty.doc) -> unit
+
+(** Removes the last registered context printing function *)
+val popContext : unit -> unit
+
+(** Show the context stack to stderr *)
+val showContext : unit -> unit
+
+(** To ensure that the context is registered and removed properly, use the
+ function below *)
+val withContext : (unit -> Pretty.doc) -> ('a -> 'b) -> 'a -> 'b
+
+
+
+val newline: unit -> unit (* Call this function to announce a new line *)
+val newHline: unit -> unit
+
+val getPosition: unit -> int * string * int (* Line number, file name,
+ current byte count in file *)
+val getHPosition: unit -> int * string (** high-level position *)
+
+val setHLine: int -> unit
+val setHFile: string -> unit
+
+val setCurrentLine: int -> unit
+val setCurrentFile: string -> unit
+
+(** Type for source-file locations *)
+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 *)
+ }
+
+val d_loc: unit -> location -> Pretty.doc
+val d_hloc: unit -> location -> Pretty.doc
+
+val getLocation: unit -> location
+
+val parse_error: string -> (* A message *)
+ 'a
+
+(** An unknown location for use when you need one but you don't have one *)
+val locUnknown: location
+
+
+(** Records whether the stdin is open for reading the goal **)
+val readingFromStdin: bool ref
+
+
+(* Call this function to start parsing. useBasename is by default "true",
+ * meaning that the error information maintains only the basename. If the
+ * file name is - then it reads from stdin. *)
+val startParsing: ?useBasename:bool -> string ->
+ Lexing.lexbuf
+
+val startParsingFromString: ?file:string -> ?line:int -> string
+ -> Lexing.lexbuf
+
+val finishParsing: unit -> unit (* Call this function to finish parsing and
+ * close the input channel *)
+
+
--- /dev/null
+(** Growable Arrays *)
+
+module LA = Longarray
+
+type 'a fill =
+ Elem of 'a
+ | Susp of (int -> 'a)
+
+type 'a t = {
+ gaFill: 'a fill;
+ (** Stuff to use to fill in the array as it grows *)
+
+ mutable gaMaxInitIndex: int;
+ (** Maximum index that was written to. -1 if no writes have
+ * been made. *)
+
+ mutable gaData: 'a LA.t;
+ }
+
+let growTheArray (ga: 'a t) (len: int)
+ (toidx: int) (why: string) : unit =
+ if toidx >= len then begin
+ (* Grow the array by 50% *)
+ let newlen = toidx + 1 + len / 2 in
+(*
+ ignore (E.log "growing an array to idx=%d (%s)\n" toidx why);
+*)
+ let data' = begin match ga.gaFill with
+ Elem x ->
+ let data'' = LA.create newlen x in
+ LA.blit ga.gaData 0 data'' 0 len;
+ data''
+ | Susp f -> LA.init newlen
+ (fun i -> if i < len then LA.get ga.gaData i else f i)
+ end
+ in
+ ga.gaData <- data'
+ end
+
+let max_init_index (ga: 'a t) : int =
+ ga.gaMaxInitIndex
+
+let num_alloc_index (ga: 'a t) : int =
+ LA.length ga.gaData
+
+let reset_max_init_index (ga: 'a t) : unit =
+ ga.gaMaxInitIndex <- -1
+
+let getg (ga: 'a t) (r: int) : 'a =
+ let len = LA.length ga.gaData in
+ if r >= len then
+ growTheArray ga len r "getg";
+
+ LA.get ga.gaData r
+
+let setg (ga: 'a t) (r: int) (what: 'a) : unit =
+ let len = LA.length ga.gaData in
+ if r >= len then
+ growTheArray ga len r "setg";
+ if r > max_init_index ga then ga.gaMaxInitIndex <- r;
+ LA.set ga.gaData r what
+
+let get (ga: 'a t) (r: int) : 'a = LA.get ga.gaData r
+
+let set (ga: 'a t) (r: int) (what: 'a) : unit =
+ if r > max_init_index ga then ga.gaMaxInitIndex <- r;
+ LA.set ga.gaData r what
+
+let make (initsz: int) (fill: 'a fill) : 'a t =
+ { gaFill = fill;
+ gaMaxInitIndex = -1;
+ gaData = begin match fill with
+ Elem x -> LA.create initsz x
+ | Susp f -> LA.init initsz f
+ end; }
+
+let clear (ga: 'a t) : unit =
+ (* This assumes the user hasn't used the raw "set" on any value past
+ max_init_index. Maybe we shouldn't trust max_init_index here?? *)
+ if ga.gaMaxInitIndex >= 0 then begin
+ begin match ga.gaFill with
+ Elem x -> LA.fill ga.gaData 0 (ga.gaMaxInitIndex+1) x
+ | Susp f ->
+ for i = 0 to ga.gaMaxInitIndex do
+ LA.set ga.gaData i (f i)
+ done
+ end;
+ ga.gaMaxInitIndex <- -1
+ end
+
+let copy (ga: 'a t) : 'a t =
+ { ga with gaData = LA.copy ga.gaData }
+
+let deep_copy (ga: 'a t) (copy: 'a -> 'a): 'a t =
+ { ga with gaData = LA.map copy ga.gaData }
+
+(* An accumulating for loop. Used internally. *)
+let fold_for ~(init: 'a) ~(lo: int) ~(hi: int) (f: int -> 'a -> 'a) =
+ let rec forloop i acc =
+ if i > hi then acc
+ else forloop (i+1) (f i acc)
+ in
+ forloop lo init
+
+(** Iterate over the initialized elements of the array *)
+let iter (f: 'a -> unit) (ga: 'a t) =
+ for i = 0 to max_init_index ga do
+ f (LA.get ga.gaData i)
+ done
+
+(** Iterate over the initialized elements of the array *)
+let iteri (f: int -> 'a -> unit) (ga: 'a t) =
+ for i = 0 to max_init_index ga do
+ f i (LA.get ga.gaData i)
+ done
+
+(** Iterate over the elements of 2 arrays *)
+let iter2 (f: int -> 'a -> 'b -> unit) (ga1: 'a t) (ga2: 'b t) =
+ let len1 = max_init_index ga1 in
+ let len2 = max_init_index ga2 in
+ if len1 > -1 || len2 > -1 then begin
+ let max = if len1 > len2 then begin
+ ignore(getg ga2 len1); (*grow ga2 to match ga1*)
+ len1
+ end else begin
+ ignore(getg ga1 len2); (*grow ga1 to match ga2*)
+ len2
+ end in
+ for i = 0 to max do
+ f i (LA.get ga1.gaData i) (LA.get ga2.gaData i)
+ done
+ end
+
+(** Fold left over the initialized elements of the array *)
+let fold_left (f: 'acc -> 'a -> 'acc) (acc: 'acc) (ga: 'a t) : 'acc =
+ let rec loop (acc: 'acc) (idx: int) : 'acc =
+ if idx > max_init_index ga then
+ acc
+ else
+ loop (f acc (LA.get ga.gaData idx)) (idx + 1)
+ in
+ loop acc 0
+
+
+(** Fold left over the initialized elements of the array *)
+let fold_lefti (f: 'acc -> int -> 'a -> 'acc) (acc: 'acc) (ga: 'a t) : 'acc =
+ let rec loop (acc: 'acc) (idx: int) : 'acc =
+ if idx > max_init_index ga then
+ acc
+ else
+ loop (f acc idx (LA.get ga.gaData idx)) (idx + 1)
+ in
+ loop acc 0
+
+(** Fold right over the initialized elements of the array *)
+let fold_right (f: 'a -> 'acc -> 'acc) (ga: 'a t) (acc: 'acc) : 'acc =
+ let rec loop (acc: 'acc) (idx: int) : 'acc =
+ if idx < 0 then
+ acc
+ else
+ loop (f (LA.get ga.gaData idx) acc) (idx - 1)
+ in
+ loop acc (max_init_index ga)
+
+(** Document generator *)
+let d_growarray (sep: Pretty.doc)
+ (doit:int -> 'a -> Pretty.doc)
+ ()
+ (elements: 'a t) =
+ LA.docArray ~sep:sep doit () elements.gaData
+
+let restoreGA ?deepCopy (ga: 'a t) : (unit -> unit) =
+ let old =
+ (match deepCopy with
+ None -> copy ga
+ | Some f -> deep_copy ga f)
+ in
+ (fun () ->
+ if ga.gaFill != old.gaFill then
+ Errormsg.s
+ (Errormsg.bug "restoreGA to an array with a different fill.");
+ ga.gaMaxInitIndex <- old.gaMaxInitIndex;
+ for i = 0 to max_init_index ga do
+ set ga i (getg old i)
+ done)
+
+let find (ga: 'a t) (fn: 'a -> bool) : int option =
+ let rec loop (i:int) : int option =
+ if i > ga.gaMaxInitIndex then None
+ else if fn (get ga i) then Some i
+ else loop (i + 1)
+ in
+ loop 0
--- /dev/null
+(***********************************************************************)
+(* Growable Arrays *)
+(* *)
+(* This a wrapper around the standard OCaml array, but will grow *)
+(* automatically on get or set outside the current size of the *)
+(* array. *)
+(* *)
+(* The interface is the same as the standard OCaml array where *)
+(* applicable (and implemented). *)
+(***********************************************************************)
+
+(* $Id: growArray.mli 6537 2005-01-06 15:37:37Z necula $ *)
+
+(** Array operations. *)
+
+(** The type of growable arrays *)
+type 'a t
+
+(** The default value to a new element of the growable array *)
+type 'a fill =
+ Elem of 'a
+ (* A default value *)
+ | Susp of (int -> 'a)
+ (* A function given an index to generate a default value *)
+
+val make : int -> 'a fill -> 'a t
+(** [GrowArray.make n x] returns a fresh growable array of size
+ at least [n] with default value specified by [x].
+
+ Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. *)
+
+val num_alloc_index: 'a t -> int
+(** [GrowArray.num_alloc_index a] returns the number of allocated entries in
+ * the array **)
+
+val max_init_index : 'a t -> int
+(** [GrowArray.max_init_index a] returns the maximum index to
+ which has been written.
+
+ Returns -1 if no writes have been made. *)
+
+val reset_max_init_index : 'a t -> unit
+(** [GrowArray.reset_init a] resets the max_init_index. You should probably
+ use [GrowArray.clear a] instead if you also want to delete the contents. *)
+
+val getg : 'a t -> int -> 'a
+(** [GrowArray.getg a n] returns the element number [n] of array [a].
+ The first element has number 0.
+ The last element has number [GrowArray.length a - 1].
+
+ If [n] is outside the range 0 to [(GrowArray.max_init_index a)],
+ then the array grows to at least [n] and yields the default value. *)
+
+val setg : 'a t -> int -> 'a -> unit
+(** [GrowArray.setg a n x] modifies array [a] in place, replacing
+ element number [n] with [x].
+
+ If [n] is outside the range 0 to [(GrowArray.max_init_index a)],
+ then the array grows to at least [n] and yields the default value. *)
+
+val get : 'a t -> int -> 'a
+(** [GrowArray.get a n] returns the element number [n] of grow array [a].
+
+ Raise [Invalid_argument "Array.get"] if [n] is outside the range
+ of the underlying array. *)
+
+val set : 'a t -> int -> 'a -> unit
+(** [GrowArray.set a n x] modifies grow array [a] in place, replacing
+ element number [n] with [x].
+
+ Raise [Invalid_argument "Array.set"] if [n] is outside the range
+ of the underlying array. *)
+
+val clear: 'a t -> unit
+(** [GrowArray.clear a] clears the contents of the array and sets
+ max_init_index to -1. Suspension thunks will be rerun to regenerate the
+ initial values of the array. *)
+
+val copy : 'a t -> 'a t
+(** [GrowArray.copy a] returns a copy of [a], that is, a fresh array
+ containing the same elements as [a]. *)
+
+val deep_copy : 'a t -> ('a -> 'a) -> 'a t
+(** [GrowArray.copy a f] returns a deep copy of [a] using f to
+ copy elements of [a]. *)
+
+val iter : ('a -> unit) -> 'a t -> unit
+(** [GrowArray.iter f a] applies function [f] in turn to all
+ the elements of [a]. It is equivalent to
+ [f a.(0); f a.(1); ...; f a.(GrowArray.length a - 1); ()]. *)
+
+val iteri : (int -> 'a -> unit) -> 'a t -> unit
+(** Same as {!GrowArray.iter}, but the
+ function is applied to the index of the element as first argument,
+ and the element itself as second argument. *)
+
+val iter2 : (int -> 'a -> 'b -> unit) -> 'a t -> 'b t -> unit
+(** Same as {!GrowArray.iteri}, but the function is applied to two arrays.
+ [iter2 f a b] is equivalent to
+ [f 0 a.(0) b.(0); f 1 a.(1) b.(1); ...; f n a.(n) b.(n); ()]
+ where n is the larger of (max_init_index a) or (max_init_index b).
+ The shorter array will grow to match the longer.*)
+
+val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a
+(** [GrowArray.fold_left f x a] computes
+ [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)],
+ where [n] is the length of the array [a]. *)
+
+val fold_lefti : ('a -> int -> 'b -> 'a) -> 'a -> 'b t -> 'a
+(** [GrowArray.fold_lefti f x a] computes
+ [f (... (f (f x 0 a.(0)) 1 a.(1)) ...) (n-1) a.(n-1)],
+ where [n] is the length of the array [a]. *)
+
+val fold_right : ('b -> 'a -> 'a) -> 'b t -> 'a -> 'a
+(** [GrowArray.fold_right f a x] computes
+ [f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))],
+ where [n] is the length of the array [a]. *)
+
+val d_growarray : Pretty.doc -> (int -> 'a -> Pretty.doc) -> unit -> 'a t
+ -> Pretty.doc
+(** [GrowArray.d_growarray sep f () a] creates a {!Pretty.doc} for growable
+ array a using separator sep and element printer f. *)
+
+
+val restoreGA: ?deepCopy:('a -> 'a) -> 'a t -> unit -> unit
+(** Given a growable array, produce a thunk that later restores it to its
+ current value *)
+
+val find: 'a t -> ('a -> bool) -> int option
+(** Returns the index of the first element in the array that satisfies the
+ predicate, or None if there is no such element *)
--- /dev/null
+(** A hash table specialized on integer keys *)
+type 'a t =
+ { mutable size: int; (* number of elements *)
+ mutable data: 'a bucketlist array } (* the buckets *)
+
+and 'a bucketlist =
+ Empty
+ | Cons of int * 'a * 'a bucketlist
+
+let hash key = key land 0x3fffffff
+
+let create initial_size =
+ let s = min (max 1 initial_size) Sys.max_array_length in
+ { size = 0; data = Array.make s Empty }
+
+let clear h =
+ for i = 0 to Array.length h.data - 1 do
+ h.data.(i) <- Empty
+ done;
+ h.size <- 0
+
+let copy h =
+ { size = h.size;
+ data = Array.copy h.data }
+
+let copy_into src dest =
+ dest.size <- src.size;
+ dest.data <- Array.copy src.data
+
+let length h = h.size
+
+let resize tbl =
+ let odata = tbl.data in
+ 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 rec insert_bucket = function
+ Empty -> ()
+ | Cons(key, data, rest) ->
+ insert_bucket rest; (* preserve original order of elements *)
+ let nidx = (hash key) mod nsize in
+ ndata.(nidx) <- Cons(key, data, ndata.(nidx)) in
+ for i = 0 to osize - 1 do
+ insert_bucket odata.(i)
+ done;
+ tbl.data <- ndata;
+ end
+
+let add h key info =
+ let i = (hash key) mod (Array.length h.data) in
+ let bucket = Cons(key, info, h.data.(i)) in
+ h.data.(i) <- bucket;
+ h.size <- succ h.size;
+ if h.size > Array.length h.data lsl 1 then resize h
+
+let remove h key =
+ let rec remove_bucket = function
+ Empty ->
+ Empty
+ | Cons(k, i, next) ->
+ if k = key
+ then begin h.size <- pred h.size; next end
+ else Cons(k, i, remove_bucket next) in
+ let i = (hash key) mod (Array.length h.data) in
+ h.data.(i) <- remove_bucket h.data.(i)
+
+let remove_all h key =
+ let rec remove_bucket = function
+ Empty ->
+ Empty
+ | Cons(k, i, next) ->
+ if k = key
+ 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
+ h.data.(i) <- remove_bucket h.data.(i)
+
+let rec find_rec key = function
+ Empty ->
+ raise Not_found
+ | Cons(k, d, rest) ->
+ if key = k then d else find_rec key rest
+
+let find h key =
+ match h.data.((hash key) mod (Array.length h.data)) with
+ Empty -> raise Not_found
+ | Cons(k1, d1, rest1) ->
+ if key = k1 then d1 else
+ match rest1 with
+ Empty -> raise Not_found
+ | Cons(k2, d2, rest2) ->
+ if key = k2 then d2 else
+ match rest2 with
+ Empty -> raise Not_found
+ | Cons(k3, d3, rest3) ->
+ if key = k3 then d3 else find_rec key rest3
+
+let find_all h key =
+ let rec find_in_bucket = function
+ Empty ->
+ []
+ | Cons(k, d, rest) ->
+ if k = key then d :: find_in_bucket rest else find_in_bucket rest in
+ find_in_bucket h.data.((hash key) mod (Array.length h.data))
+
+let tryfind h key =
+ try Some(find h key)
+ with Not_found -> None
+
+let replace h key info =
+ let rec replace_bucket = function
+ Empty ->
+ raise Not_found
+ | Cons(k, i, next) ->
+ if k = key
+ then Cons(k, info, next)
+ else Cons(k, i, replace_bucket next) in
+ let i = (hash key) mod (Array.length h.data) in
+ let l = h.data.(i) in
+ try
+ h.data.(i) <- replace_bucket l
+ with Not_found ->
+ h.data.(i) <- Cons(key, info, l);
+ h.size <- succ h.size;
+ if h.size > Array.length h.data lsl 1 then resize h
+
+let mem h key =
+ let rec mem_in_bucket = function
+ | Empty ->
+ false
+ | Cons(k, d, rest) ->
+ k = key || mem_in_bucket rest in
+ mem_in_bucket h.data.((hash key) mod (Array.length h.data))
+
+let iter (f: int -> 'a -> unit) (h: 'a t) : unit =
+ let rec do_bucket = function
+ Empty ->
+ ()
+ | Cons(k, d, rest) ->
+ f k d; do_bucket rest in
+ let d = h.data in
+ for i = 0 to Array.length d - 1 do
+ do_bucket d.(i)
+ done
+
+let fold (f: int -> 'a -> 'b -> 'b) (h: 'a t) (init: 'b) =
+ let rec do_bucket b accu =
+ match b with
+ Empty ->
+ accu
+ | Cons(k, d, rest) ->
+ do_bucket rest (f k d accu) in
+ let d = h.data in
+ let accu = ref init in
+ for i = 0 to Array.length d - 1 do
+ accu := do_bucket d.(i) !accu
+ done;
+ !accu
+
+
+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 ()
+ | Cons(k, d, rest) ->
+ if key = k then d else find_rec key rest
+ and find_in_bucket key = function
+ Empty -> addit ()
+ | Cons(k1, d1, rest1) ->
+ if key = k1 then d1 else
+ match rest1 with
+ Empty -> addit ()
+ | Cons(k2, d2, rest2) ->
+ if key = k2 then d2 else
+ match rest2 with
+ Empty -> addit ()
+ | Cons(k3, d3, rest3) ->
+ if key = k3 then d3 else find_rec key rest3
+ and addit () =
+ let it = f key in
+ h.data.(i) <- Cons(key, it, h.data.(i));
+ h.size <- succ h.size;
+ if h.size > Array.length h.data lsl 1 then resize h;
+ it
+ in
+ find_in_bucket key h.data.(i)
+
+
+let tolist (h: 'a t) : (int * 'a) list =
+ fold (fun k d acc -> (k, d) :: acc) h []
--- /dev/null
+type 'a t
+
+(* These functions behave the same as Hashtbl, but the key type is
+ always int. (Specializing on int improves the performance) *)
+
+val create: int -> 'a t
+val clear: 'a t -> unit
+val length : 'a t -> int
+
+val copy: 'a t -> 'a t
+val copy_into: 'a t -> 'a t -> unit
+
+val add: 'a t -> int -> 'a -> unit
+val replace: 'a t -> int -> 'a -> unit
+val remove: 'a t -> int -> unit
+val remove_all: 'a t -> int -> unit
+
+val mem: 'a t -> int -> bool
+val find: 'a t -> int -> 'a
+val find_all: 'a t -> int -> 'a list
+val tryfind: 'a t -> int -> 'a option
+
+val iter: (int -> 'a -> unit) -> 'a t -> unit
+val fold: (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+
+val memoize: 'a t -> int -> (int -> 'a) -> 'a
+
+val tolist: 'a t -> (int * 'a) list
--- /dev/null
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU Library General Public License, with *)
+(* the special exception on linking described in file ../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+(* $Id: intmap.ml 9877 2007-11-22 19:20:27Z liblit $ *)
+
+(* specialized to integer keys by George Necula *)
+
+type 'a t =
+ Empty
+ | Node of 'a t * int * 'a * 'a t * int
+
+let height = function
+ Empty -> 0
+ | Node(_,_,_,_,h) -> h
+
+let create l x d r =
+ let hl = height l and hr = height r in
+ Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+let bal l x d r =
+ let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
+ let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
+ if hl > hr + 2 then begin
+ match l with
+ Empty -> invalid_arg "Map.bal"
+ | Node(ll, lv, ld, lr, _) ->
+ if height ll >= height lr then
+ create ll lv ld (create lr x d r)
+ else begin
+ match lr with
+ Empty -> invalid_arg "Map.bal"
+ | Node(lrl, lrv, lrd, lrr, _)->
+ create (create ll lv ld lrl) lrv lrd (create lrr x d r)
+ end
+ end else if hr > hl + 2 then begin
+ match r with
+ Empty -> invalid_arg "Map.bal"
+ | Node(rl, rv, rd, rr, _) ->
+ if height rr >= height rl then
+ create (create l x d rl) rv rd rr
+ else begin
+ match rl with
+ Empty -> invalid_arg "Map.bal"
+ | Node(rll, rlv, rld, rlr, _) ->
+ create (create l x d rll) rlv rld (create rlr rv rd rr)
+ end
+ end else
+ Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+let empty = Empty
+
+let is_empty = function Empty -> true | _ -> false
+
+let rec add x data = function
+ Empty ->
+ Node(Empty, x, data, Empty, 1)
+ | Node(l, v, d, r, h) ->
+ if x = v then
+ Node(l, x, data, r, h)
+ else if x < v then
+ bal (add x data l) v d r
+ else
+ bal l v d (add x data r)
+
+let rec find x = function
+ Empty ->
+ raise Not_found
+ | Node(l, v, d, r, _) ->
+ if x = v then d
+ else find x (if x < v then l else r)
+
+let rec mem x = function
+ Empty ->
+ false
+ | Node(l, v, d, r, _) ->
+ x = v || mem x (if x < v then l else r)
+
+let rec min_binding = function
+ Empty -> raise Not_found
+ | Node(Empty, x, d, r, _) -> (x, d)
+ | Node(l, x, d, r, _) -> min_binding l
+
+let rec remove_min_binding = function
+ Empty -> invalid_arg "Map.remove_min_elt"
+ | Node(Empty, x, d, r, _) -> r
+ | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
+
+let merge t1 t2 =
+ match (t1, t2) with
+ (Empty, t) -> t
+ | (t, Empty) -> t
+ | (_, _) ->
+ let (x, d) = min_binding t2 in
+ bal t1 x d (remove_min_binding t2)
+
+let rec remove x = function
+ Empty ->
+ Empty
+ | Node(l, v, d, r, h) ->
+ if x = v then
+ merge l r
+ else if x < v then
+ bal (remove x l) v d r
+ else
+ bal l v d (remove x r)
+
+let rec iter f = function
+ Empty -> ()
+ | Node(l, v, d, r, _) ->
+ iter f l; f v d; iter f r
+
+let rec map f = function
+ Empty -> Empty
+ | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h)
+
+let rec mapi f = function
+ Empty -> Empty
+ | Node(l, v, d, r, h) -> Node(mapi f l, v, f v d, mapi f r, h)
+
+let rec fold f m accu =
+ match m with
+ Empty -> accu
+ | Node(l, v, d, r, _) ->
+ fold f l (f v d (fold f r accu))
+
+type 'a enumeration = End | More of int * 'a * 'a t * 'a enumeration
+
+let rec cons_enum m e =
+ match m with
+ Empty -> e
+ | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e))
+
+let compare cmp m1 m2 =
+ let rec compare_aux e1 e2 =
+ match (e1, e2) with
+ (End, End) -> 0
+ | (End, _) -> -1
+ | (_, End) -> 1
+ | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
+ if v1 <> v2 then if v1 < v2 then -1 else 1 else
+ let c = cmp d1 d2 in
+ if c <> 0 then c else
+ compare_aux (cons_enum r1 e1) (cons_enum r2 e2)
+in compare_aux (cons_enum m1 End) (cons_enum m2 End)
+
+let equal cmp m1 m2 =
+ let rec equal_aux e1 e2 =
+ match (e1, e2) with
+ (End, End) -> true
+ | (End, _) -> false
+ | (_, End) -> false
+ | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
+ v1 = v2 && cmp d1 d2 &&
+ equal_aux (cons_enum r1 e1) (cons_enum r2 e2)
+in equal_aux (cons_enum m1 End) (cons_enum m2 End)
+
+(** Some definitions for ML2Coq *)
+let _ = ignore "coq:
+(* Some definitions for ML2Coq *)
+
+"
--- /dev/null
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU Library General Public License, with *)
+(* the special exception on linking described in file ../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+(* $Id: intmap.mli 9877 2007-11-22 19:20:27Z liblit $ *)
+
+(** Specialized to integer keys by George Necula *)
+
+(** Association tables over ordered types.
+
+ This module implements applicative association tables, also known as
+ finite maps or dictionaries, given a total ordering function
+ over the keys.
+ All operations over maps are purely applicative (no side-effects).
+ The implementation uses balanced binary trees, and therefore searching
+ and insertion take time logarithmic in the size of the map.
+*)
+
+type (+'a) t
+ (** The type of maps from type [key] to type ['a]. *)
+
+val empty: 'a t
+ (** The empty map. *)
+
+val is_empty: 'a t -> bool
+ (** Test whether a map is empty or not. *)
+
+val add: int -> 'a -> 'a t -> 'a t
+ (** [add x y m] returns a map containing the same bindings as
+ [m], plus a binding of [x] to [y]. If [x] was already bound
+ in [m], its previous binding disappears. *)
+
+val find: int -> 'a t -> 'a
+ (** [find x m] returns the current binding of [x] in [m],
+ or raises [Not_found] if no such binding exists. *)
+
+val remove: int -> 'a t -> 'a t
+ (** [remove x m] returns a map containing the same bindings as
+ [m], except for [x] which is unbound in the returned map. *)
+
+val mem: int -> 'a t -> bool
+ (** [mem x m] returns [true] if [m] contains a binding for [x],
+ and [false] otherwise. *)
+
+val iter: (int -> 'a -> unit) -> 'a t -> unit
+ (** [iter f m] applies [f] to all bindings in map [m].
+ [f] receives the key as first argument, and the associated value
+ as second argument. The bindings are passed to [f] in increasing
+ order with respect to the ordering over the type of the keys.
+ Only current bindings are presented to [f]:
+ bindings hidden by more recent bindings are not passed to [f]. *)
+
+val map: ('a -> 'b) -> 'a t -> 'b t
+ (** [map f m] returns a map with same domain as [m], where the
+ associated value [a] of all bindings of [m] has been
+ replaced by the result of the application of [f] to [a].
+ The bindings are passed to [f] in increasing order
+ with respect to the ordering over the type of the keys. *)
+
+val mapi: (int -> 'a -> 'b) -> 'a t -> 'b t
+ (** Same as {!Map.S.map}, but the function receives as arguments both the
+ key and the associated value for each binding of the map. *)
+
+val fold: (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)],
+ where [k1 ... kN] are the keys of all bindings in [m]
+ (in increasing order), and [d1 ... dN] are the associated data. *)
+
+val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
+ (** Total ordering between maps. The first argument is a total ordering
+ used to compare data associated with equal keys in the two maps. *)
+
+val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+ (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are
+ equal, that is, contain equal keys and associate them with
+ equal data. [cmp] is the equality predicate used to compare
+ the data associated with the keys. *)
+
--- /dev/null
+(* The Longarray module is designed to work around the maximum array size
+ * imposed by OCaml's built-in Array module. Longarray provides the
+ * same interface as Array (well, a portion of it) and is implemented as
+ * a list of arrays. For arrays shorter than the maximum length, the
+ * only cost is an additional level of indirection. *)
+
+open Pretty
+
+module E = Errormsg
+
+type 'a t = 'a array list
+
+let split_len (len: int) : int * int =
+ if len <= Sys.max_array_length then
+ len, 0
+ else
+ Sys.max_array_length, len - Sys.max_array_length
+
+let split_idx (idx: int) : int option =
+ if idx < Sys.max_array_length then
+ None
+ else
+ Some (idx - Sys.max_array_length)
+
+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 [])
+
+let rec init (len: int) (fn: int -> 'a) : 'a t =
+ let len1, len2 = split_len len in
+ let fn2 i = fn (i + len1) in
+ (Array.init len1 fn) :: (if len2 > 0 then init len2 fn2 else [])
+
+let rec blit (src: 'a t) (srcidx: int)
+ (dst: 'a t) (dstidx: int) (len: int) : unit =
+ if srcidx != 0 || dstidx != 0 then
+ E.s (E.unimp "Longarray.blit with nonzero src/dst indices");
+ try
+ let len1, len2 = split_len len in
+ 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") ->
+ raise (Invalid_argument "Longarray.blit")
+
+let rec fill (a: 'a t) (idx: int) (len: int) (elt: 'a) : unit =
+ try
+ match split_idx idx with
+ | None ->
+ let end1, end2 = split_len (idx + len) in
+ Array.fill (List.hd a) idx (end1 - idx) elt;
+ if end2 > 0 then
+ fill (List.tl a) 0 end2 elt
+ | Some idx' ->
+ fill (List.tl a) idx' len elt
+ with Failure ("hd" | "tl") ->
+ raise (Invalid_argument "Longarray.fill")
+
+let rec length (a: 'a t) : int =
+ match a with
+ | hd :: tl -> Array.length hd + length tl
+ | [] -> 0
+
+let rec get (a: 'a t) (i: int) : 'a =
+ try
+ match split_idx i with
+ | None -> Array.get (List.hd a) i
+ | Some i' -> get (List.tl a) i'
+ with Failure ("hd" | "tl") ->
+ raise (Invalid_argument "(get) index out of bounds")
+
+let rec set (a: 'a t) (i: int) (elt: 'a) : unit =
+ try
+ 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") ->
+ raise (Invalid_argument "(set) index out of bounds")
+
+let rec copy (a: 'a t) : 'a t =
+ match a with
+ | hd :: tl -> Array.copy hd :: copy tl
+ | [] -> []
+
+let rec map (fn: 'a -> 'b) (a: 'a t) : 'b t =
+ match a with
+ | hd :: tl -> Array.map fn hd :: map fn tl
+ | [] -> []
+
+let docArray ?(sep = chr ',') (doit: int -> 'a -> doc)
+ () (elements: 'a t) =
+ let len = length elements in
+ if len = 0 then
+ nil
+ else
+ let rec loop (acc: doc) i =
+ if i >= len then acc else
+ let fi = doit i (get elements i) in (* Make sure this is done first *)
+ loop (acc ++ sep ++ fi) (i + 1)
+ in
+ let f0 = doit 0 (get elements 0) in
+ loop f0 1
--- /dev/null
+(* The Longarray module is designed to work around the maximum array size
+ * imposed by OCaml's built-in Array module. Longarray provides the
+ * same interface as Array (well, a portion of it) and is implemented as
+ * a list of arrays. For arrays shorter than the maximum length, the
+ * only cost is an additional level of indirection. *)
+
+type 'a t
+
+val create : int -> 'a -> 'a t
+val init : int -> (int -> 'a) -> 'a t
+val blit : 'a t -> int -> 'a t -> int -> int -> unit
+val fill : 'a t -> int -> int -> 'a -> unit
+val length : 'a t -> int
+val get : 'a t -> int -> 'a
+val set : 'a t -> int -> 'a -> unit
+val copy : 'a t -> 'a t
+val map : ('a -> 'b) -> 'a t -> 'b t
+
+val docArray : ?sep: Pretty.doc -> (int -> 'a -> Pretty.doc) ->
+ unit -> 'a t -> Pretty.doc
--- /dev/null
+(** We define a type for option descriptors. Such options can be set from the
+ * command line or from the UI *)
+type optionDescr = {
+ optInUI: string;
+ (** The way the option should appear in the UI. Use & before a letter to
+ * indicate the shortcut letter *)
+
+ optRestart: bool;
+ (** Whether setting this option requires restarting the Engine *)
+
+ optKind: optionKind;
+ (** The option kind. *)
+
+ optExtra: unit -> unit;
+ (** An extra thing to do after setting the ref.
+ This can be used, for instance, to set several refs
+ with one option. *)
+
+ optCommandLine: string;
+ (** How the option should appear in the command line *)
+
+ optHelp: string;
+ (** A help string that is printed when the --help argument is given or as
+ * a tooltip in the GUI *)
+ }
+
+and optionKind =
+ | OUnit
+ | OBool of bool ref (** A boolean option *)
+ | OInt of int ref (** An integer option *)
+ | OString of string ref (** A string option *)
+ | OStringList of char * string list ref
+ (** A list of strings, with a separator. This means that the option can
+ * also appear multiple times *)
+ | OOutChannel of (out_channel * string) option ref
+ (** Takes a filename from the command line, opens a channel to that file,
+ * and updates the ref with the channel and the filename.
+ * The file is opened in text mode.
+ * Uses stdout if the argument is "-" or "stdout". *)
+
+let splitStringList (sep: char) (str: string) : string list =
+ let len = String.length str in
+ let rec loop (start: int) : string list =
+ if start >= len then
+ []
+ else begin
+ try
+ let next_sep = String.index_from str start sep in
+ String.sub str start (next_sep - start) :: loop (next_sep + 1)
+ with Not_found -> (* The entire thing is a string *)
+ [ String.sub str start (len - start) ]
+ end
+ in
+ loop 0
+
+(* open an output channel *)
+let outChannel (what:string) (fname: string) : out_channel * string=
+ match fname with
+ "-" | "stdout" -> stdout, "(stdout)"
+ | _ ->
+ try
+ open_out fname, fname
+ with e ->
+ raise (Arg.Bad ("Cannot open " ^ what ^ " file " ^ fname))
+
+let optionToArgs (od : optionDescr) : (string * Arg.spec * string) list =
+ if od.optCommandLine <> "" then begin
+ match od.optKind with
+ | OUnit -> [ (od.optCommandLine,
+ Arg.Unit (fun _ -> od.optExtra ()),
+ od.optHelp) ]
+
+ | OBool oref ->
+ [ (od.optCommandLine,
+ Arg.Unit (fun _ -> oref := true; od.optExtra ()),
+ od.optHelp ^ (if !oref then " (default)" else ""));
+ ("-no" ^ od.optCommandLine,
+ Arg.Unit (fun _ -> oref := false; od.optExtra ()),
+ "turn this option off" ^ (if !oref then "" else " (default)")) ]
+
+ | OInt iref ->
+ [ (od.optCommandLine,
+ Arg.Int (fun i -> iref := i; od.optExtra ()),
+ od.optHelp ^ " (default " ^ string_of_int !iref ^ ")") ]
+ | OString sref ->
+ [ (od.optCommandLine,
+ Arg.String (fun s -> sref := s; od.optExtra ()),
+ od.optHelp ^ " (default " ^ !sref ^ ")") ]
+
+ | OStringList (sep, lref) ->
+ [ (od.optCommandLine,
+ Arg.String (fun s -> lref := !lref @ splitStringList sep s;
+ od.optExtra ()),
+ od.optHelp ^
+ " (initially " ^
+ (String.concat (String.make 1 sep) !lref) ^ ")") ]
+
+ | OOutChannel (chref) ->
+ [ (od.optCommandLine,
+ Arg.String (fun s -> chref := Some (outChannel od.optCommandLine s);
+ od.optExtra ()),
+ od.optHelp) ]
+
+ end else
+ []
--- /dev/null
+
+(** {b Options} *)
+(** We define a type for option descriptors. Such options can be set from the
+ * command line or from the UI *)
+type optionDescr = {
+ optInUI: string;
+ (** The way the option should appear in the UI. Use & before a letter to
+ * indicate the shortcut letter *)
+
+ optRestart: bool;
+ (** Whether setting this option requires restarting the Engine *)
+
+ optKind: optionKind;
+ (** The option kind. *)
+
+ optExtra: unit -> unit;
+ (** An extra thing to do after setting the ref.
+ This can be used, for instance, to set several refs
+ with one option. *)
+
+ optCommandLine: string;
+ (** How the option should appear in the command line. The empty string
+ * means that this option does not appear among the command line options.*)
+
+ optHelp: string;
+ (** A help string that is printed when the --help argument is given or as
+ * a tooltip in the GUI *)
+ }
+
+and optionKind =
+ | OUnit
+ | OBool of bool ref (** A boolean option *)
+ | OInt of int ref (** An integer option *)
+ | OString of string ref (** A string option *)
+ | OStringList of char * string list ref
+ (** A list of strings, with a separator. This means that the option can
+ * also appear multiple times *)
+ | OOutChannel of (out_channel * string) option ref
+ (** Takes a filename from the command line, opens a channel to that file,
+ * and updates the ref with the channel and the filename.
+ * The file is opened in text mode.
+ * Uses stdout if the argument is "-" or "stdout". *)
+
+val optionToArgs: optionDescr -> (string * Arg.spec * string) list
+
+val splitStringList: char -> string -> string list
+
+
--- /dev/null
+(** camlp4 code for generating pretty printers for types, based on the Pretty
+ * module. *)
+
+(*** USAGE ***)
+(* To use this module in your code you must add the following line
+ * before the type declarations for which you want to auto generate printing
+ functions.
+
+ let _ = Pretty.auto_printer "ALL"
+
+ If the Pretty module is open, then you can leave the [Pretty.] part out.
+ But you should not do something like P.auto_printer.
+
+ The scope of the above invocation extends to the end of the module.
+
+ Assume that "foo" and "bar" were declared in the same mutually recursive
+ declaration (occurring after the above auto_printer invocation).
+ Then the following functions are generated:
+
+ let rec d_foo_rec (d_foo: foo -> doc) (d_bar: bar -> doc) : foo -> doc = ...
+ and d_bar_rec (d_foo: foo -> doc) (d_bar: bar -> doc) : bar -> doc = ...
+
+ let rec d_foo x = d_foo_rec d_foo d_bar x
+ and d_bar x = d_bar_rec d_foo d_bar x
+
+ let f_foo () = d_foo
+ let f_bar () = d_bar
+
+ The first set of functions you can use later to override partially the
+ printing function:
+
+ let rec new_foo = function
+ | A 0 -> text "my special foo"
+ | x -> d_foo_rec new_foo new_bar x
+ and new_bar = function
+ | B 1 -> text "my special bar"
+ | x -> d_bar_rec new_foo new_bar x
+
+ The second set of functions you can use right away to print, and the f_
+ functions you can use in conjunction with format strings.
+
+ An alternative usage mode is to add the following line AFTER each
+ type declaration for which you want printing functions to be
+ generated.
+
+ let _ = Pretty.auto_printer "foo"
+
+ The above line must occur after the declaration of the type name "foo".
+ Note that you must only mention one of the mutually recursive types when
+ you invoke Pretty.auto_printer, and you get the printing functions for
+ all the types.
+
+
+ LIMITATIONS:
+ The auto-generated printing functions work for most types. For
+ unrecognized types they will print something of the form <unimplemented>.
+
+ Note that for printing a value of named type "baz", the printer will assume
+ that the function d_baz is defined and of the right type. You will get
+ strange messages if this is not the case.
+*)
+
+(**** INSTALATION *******)
+(* To use this module you must first compile it and then you must use it
+ as a preprocessor
+
+ To compile this module add something like this to your Makefile
+
+$(OBJDIR)/pa_prtype.cmo: pa_prtype.ml
+ ocamlc -c -pp "camlp4o pa_extend.cmo q_MLast.cmo" \
+ -I +camlp4 -I $(OBJDIR) -c $< && \
+ mv -f $(<D)/pa_prtype.cmo $@
+
+pa_prtype: $(OBJDIR)/pretty.cmi $(OBJDIR)/pa_prtype.cmo
+
+ And add "pa_prtype" as a first dependency to your target.
+
+ Note that the dependency generation should work even before you compile
+ the preprocessor.
+
+ To use this module as a preprocessor you add the following flags to the
+ ocamlc command line:
+
+ -pp "camlp4o -I $(OBJDIR) pa_prtype.cmo"
+
+
+*******************************************************)
+
+
+open MLast
+
+open Pretty
+module H = Hashtbl
+
+let dogen = ref false
+
+(* The printing function name *)
+let p_fun_name (n: string) : string = "d_" ^ n
+
+let p_rec_fun_name (n: string) : string = "d_" ^ n ^ "_rec"
+
+let f_fun_name (n: string) : string = "f_" ^ n
+
+(** We remember the type declarations, in case we see a call to
+ * "auto_printer". *)
+let knownTypes: (string, type_decl list) H.t = H.create 13
+
+
+ (* Make a concatenation *)
+let rec concatenate (loc: loc) (el: expr list) : expr =
+ match el with
+ [ e ] -> e
+ | e1 :: reste ->
+ let restee: expr = concatenate loc reste in
+ <:expr< (Pretty.concat $e1$ $restee$) >>
+ | [ ] -> <:expr< Pretty.nil >>
+in
+
+(* Make a list with a given separator *)
+let rec gen_print_list (loc: loc) (sep: string) (el: expr list) : expr =
+ match el with
+ [ e ] -> e
+ | e1 :: reste ->
+ let restee: expr = gen_print_list loc sep reste in
+ <:expr< (Pretty.concat
+ (Pretty.concat
+ (Pretty.concat $e1$ (Pretty.text $str:sep$))
+ Pretty.break)
+ $restee$) >>
+ | [] -> <:expr< Pretty.nil >>
+in
+
+let param_name cnt = "x" ^ string_of_int cnt in
+
+let list_mapi f l =
+ let rec loop cnt =
+ function
+ x :: l -> f cnt x :: loop (cnt + 1) l
+ | [] -> []
+ in
+ loop 1 l
+in
+
+let gen_print_cons_patt loc (cons:string) (params: ctyp list) =
+ let pl =
+ list_mapi (fun n _ -> <:patt< $lid:param_name n$ >>)
+ params
+ in
+ List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>)
+ <:patt< $uid:cons$ >> pl
+in
+
+let gen_call loc n f = <:expr< $f$ $lid:param_name n$ >> in
+
+
+let unimp loc (s: string) = <:expr< Pretty.text $str:s$ >> in
+let unimpF loc (s: string) = <:expr< fun _ -> Pretty.text $str:s$ >> in
+
+
+(* Generate the body of a function that prints a type *)
+let rec gen_print_type loc : ctyp -> expr =
+ function
+ | TyLid (_, s) -> (* named type *)
+ if s = "int" then
+ <:expr< Pretty.num >>
+ else if s = "string" then
+ <:expr< Pretty.text >>
+ else if s = "bool" then
+ <:expr< fun b -> if b then Pretty.text "true" else Pretty.text "false" >>
+ else if s = "int32" then
+ <:expr< Pretty.d_int32 >>
+ else if s = "int64" then
+ <:expr< Pretty.d_int64 >>
+ else
+ <:expr< $lid:p_fun_name s$ >>
+
+ | TyAcc (loc, t1, t2) -> (* Qualified types *) begin
+ match t2 with
+ TyLid (_, t2n) -> begin (* Get the module names *)
+ let rec getModules = function
+ TyUid(loc, m) -> ExUid(loc, m)
+ | TyAcc (loc, base, TyUid(locm, m)) ->
+ ExAcc (loc, getModules base, ExUid (locm, m))
+ | _ -> raise Not_found
+ in
+ try
+ (* Look for some special cases *)
+ match getModules t1, t2n with
+ ExUid (_, "Pretty"), "doc" ->
+ <:expr< Pretty.insert () >>
+ | _ ->
+ ExAcc(loc, getModules t1, ExLid (loc, p_fun_name t2n))
+ with Not_found ->
+ unimpF loc "TyAcc: path is not TUid"
+ end
+ | _ -> unimpF loc "TyAcc: t2 is not Lid"
+ end
+
+ | TyApp (loc, tcons, tpar) -> begin
+ (* Type constructors *)
+ match tcons with
+ TyLid (_, "list") ->
+ <:expr< Pretty.docList $gen_print_type loc tpar$ () >>
+ | TyLid (_, "option") ->
+ <:expr< Pretty.docOpt $gen_print_type loc tpar$ () >>
+
+ | _ -> unimpF loc "TyApp"
+ end
+
+
+ | TyTup (loc, typs) -> (* A tuple *)
+ (* Make a pattern to match the tuple *)
+ let pats: patt list =
+ list_mapi (fun n _ -> <:patt< $lid:param_name n$ >>)
+ typs
+ in
+ let pat: patt = PaTup (loc, pats) in
+ (* The parameters *)
+ let pr_params: expr list =
+ let type_funs = List.map (gen_print_type loc) typs in
+ list_mapi (gen_call loc) type_funs
+ in
+ (* Put the separators *)
+ let sep_params: expr = gen_print_list loc "," pr_params in
+ let e: expr = concatenate loc
+ [ <:expr< Pretty.text "(" >> ;
+ <:expr< Pretty.align >>;
+ <:expr< $sep_params$ >> ;
+ <:expr< Pretty.text ")" >> ;
+ <:expr< Pretty.unalign >> ]
+ in
+ <:expr< fun [ $pat$ -> $e$ ] >>
+
+ | TyRec (loc, _, fields) -> (* A record *)
+ (* Make a pattern *)
+ let pats: (patt * patt) list =
+ list_mapi (fun n (_, fn, _, _) ->
+ <:patt< $lid:fn$ >>, <:patt< $lid:param_name n$ >>)
+ fields
+ in
+ let pat: patt = PaRec (loc, pats) in
+ (* Now print each component *)
+ let pr_params: expr list =
+ let type_funs =
+ List.map (fun (_, _, _, ft) -> gen_print_type loc ft) fields in
+ list_mapi (gen_call loc) type_funs
+ in
+ (* Put the separators *)
+ let sep_params: expr = gen_print_list loc "," pr_params in
+ let e: expr = concatenate loc
+ [ <:expr< Pretty.text "{" >> ;
+ <:expr< Pretty.align >>;
+ <:expr< $sep_params$ >> ;
+ <:expr< Pretty.text "}" >> ;
+ <:expr< Pretty.unalign >> ]
+ in
+ <:expr< fun [ $pat$ -> $e$ ] >>
+
+ | TySum (loc, _, cdl) ->
+ let gen_print_cons_expr loc (c: string) (tl: ctyp list) : expr =
+ let pr_con = <:expr< Pretty.text $str:c$ >> in
+ match tl with
+ [] -> pr_con
+ | _ ->
+ (* The parameters *)
+ let pr_params: expr list =
+ let type_funs = List.map (gen_print_type loc) tl in
+ list_mapi (gen_call loc) type_funs
+ in
+ (* Put the separators *)
+ let sep_params: expr = gen_print_list loc "," pr_params in
+ (* Put the alignment two characters into the name of the
+ * constructor *)
+ let print_c: expr list =
+ if String.length c > 2 then
+ let fst = String.sub c 0 2 in
+ let last = String.sub c 2 (String.length c - 2) in
+ [ <:expr< Pretty.text $str:fst$ >> ;
+ <:expr< Pretty.align >> ;
+ <:expr< Pretty.text $str:last$ >> ]
+ else
+ [ <:expr< Pretty.text $str:c$ >>;
+ <:expr< Pretty.align >> ]
+ in
+ let e: expr = concatenate loc
+ (print_c @ [ <:expr< Pretty.text "(" >> ;
+ <:expr< $sep_params$ >> ;
+ <:expr< Pretty.text ")" >> ;
+ <:expr< Pretty.unalign >> ])
+ in
+ e
+ in
+
+ (* Print one constructor *)
+ let gen_print_cons (loc, c, tl) =
+ let p = gen_print_cons_patt loc c tl in
+ let e = gen_print_cons_expr loc c tl in
+ p, None, e
+ in
+ let gen_print_sum loc cdl =
+ let pwel = List.map gen_print_cons cdl in
+ <:expr< fun [ $list:pwel$ ] >>
+ in
+ gen_print_sum loc cdl
+
+ | TyArr (_, _, _) -> (* An arrow *)
+ <:expr< fun _ -> Pretty.text "<func>" >>
+
+ | _ -> <:expr< fun _ -> Pretty.text "<type unimplemented>" >>
+in
+
+
+(* For each type declaration of type t1, t2, we generate the following
+ * functions
+ let rec d_t1_rec (d_t1: t1 -> doc) (d_t2: t2 -> doc) : t1 -> doc = ...
+ and d_t2_rec (d_t1: t1 -> doc) (d_t2: t2 -> doc) : t2 -> doc = ...
+
+ - in the above functions the arguments are used for the recursive
+ invocations. These functions are used for override.
+
+ let rec d_t1 = d_t1_rec d_t1 d_t2
+ and d_t2 = d_t2_rec d_t1 d_t2
+
+ - These functions can be used more easily
+
+ let f_t1 () x = d_t1 x
+ let f_t2 () x = d_t2 x
+
+ - These functions can be used with format strings
+*)
+let gen_print_funs (loc: loc) (tdl: type_decl list) : str_item list =
+
+ let gen_one_print_fun (loc: loc) (((locn,n), tpl, (tk: ctyp),
+ constraints): type_decl)
+ : patt * expr =
+ (* Generate the body of the printing function *)
+ let body: expr =
+ if tpl <> [] then
+ <:expr< text "parameterized types not yet implemented" >>
+ else if constraints <> [] then
+ <:expr< text "typ constraints not yet implemented" >>
+ else
+ gen_print_type loc tk
+
+ in
+ (* Generate the pattern including all the recursive functions *)
+ let body': expr =
+ List.fold_right
+ (fun ((_, n), _, _, _) acc ->
+ <:expr< fun $lid:p_fun_name n$ -> $acc$ >>)
+ tdl
+ body
+ in
+ <:patt< $lid:p_rec_fun_name n$ >>, body'
+ in
+ let prec_el: (patt * expr) list = List.map (gen_one_print_fun loc) tdl in
+ let rec_printers: str_item =
+ <:str_item< value rec $list:prec_el$ >>
+ in
+ (* Now generate the actual printers *)
+ let p_el: (patt * expr) list =
+ List.map (fun ((loc, n), _, _, _) ->
+ let body =
+ List.fold_left
+ (fun acc ((loc, n'), _, _, _) ->
+ <:expr< $acc$ $lid:p_fun_name n'$ >>)
+ <:expr< $lid:p_rec_fun_name n$ >>
+ tdl
+ in
+ <:patt< $lid:p_fun_name n$ >>, <:expr< fun x -> $body$ x >>)
+ tdl
+ in
+ let printers: str_item =
+ <:str_item< value rec $list:p_el$ >>
+ in
+ (* Now generate the format printers *)
+ let f_printers: str_item list =
+ List.map
+ (fun ((loc,n), _, _, _) ->
+ <:str_item< value $lid:f_fun_name n$ () = $lid:p_fun_name n$ >>)
+ tdl
+ in
+ rec_printers :: printers :: f_printers
+in
+
+
+(* Delete the old rule for parsing types *)
+DELETE_RULE
+ Pcaml.str_item: "type"; LIST1 Pcaml.type_declaration SEP "and"
+END;
+
+
+DELETE_RULE
+ Pcaml.str_item: "let"; OPT "rec"; LIST1 Pcaml.let_binding SEP "and"
+END;
+
+
+
+DELETE_RULE
+ Pcaml.module_expr: "struct"; LIST0 [ Pcaml.str_item; OPT ";;" ] ; "end"
+END;
+
+
+(** Add our type parsing *)
+EXTEND
+ Pcaml.str_item:
+ [ [ "type"; tdl = LIST1 Pcaml.type_declaration SEP "and" ->
+ (* The actual type declarations. Remember them *)
+ List.iter (fun ((_, n), _, _, _) -> H.add knownTypes n tdl) tdl;
+ if H.mem knownTypes "ALL" then begin
+ (* We must generate the printer for all types *)
+ StDcl (loc, StTyp (loc, tdl) ::
+ gen_print_funs loc tdl)
+ end else begin
+ StTyp (loc, tdl)
+ end
+
+ | "let"; r = OPT "rec"; l = LIST1 Pcaml.let_binding SEP "and" ->
+ (* See if this is ours *)
+ let isrec = if r = None then false else true in
+ try
+ match l with
+ [ (PaAny _, e) ] when not isrec -> begin
+ match e with
+ <:expr< Pretty.auto_printer $e$ >>
+ | <:expr< auto_printer $e$ >> -> begin
+ (* see if we know about such a type *)
+ let n: string =
+ match e with
+ ExStr (_, n) -> n
+ | _ ->
+ Stdpp.raise_with_loc loc
+ (Failure "auto_printer must have a string literal representing a type name")
+ in
+ if n = "ALL" then begin
+ H.add knownTypes "ALL";
+ StDcl (loc, [])
+ end else begin
+ try
+ let tdl = H.find knownTypes n in
+ StDcl (loc, gen_print_funs loc tdl)
+ with Not_found ->
+ Stdpp.raise_with_loc loc
+ (Failure ("auto_printer invoked for unknown type " ^ n))
+ end
+ end
+ | _ -> raise Not_found
+ end
+ | _ -> raise Not_found
+ with Not_found ->
+ StVal (loc, isrec, l)
+ ]
+ ]
+ ;
+
+ Pcaml.module_expr:
+ [ [ "struct"; st = LIST0 [ s = Pcaml.str_item; OPT ";" -> s ] ; "end" ->
+ (* Found a complete module expr. Now forget the types that are in st *)
+ List.iter (fun s ->
+ match s with
+ StTyp (_, td) ->
+ List.iter (fun ((_, n), _, _, _) ->
+ assert (H.mem knownTypes n);
+ H.remove knownTypes n)
+ td
+ | _ -> ())
+ st;
+ MeStr (loc, st )
+ ] ];
+
+END;
+
+(*
+let _ = Grammar.Entry.print Pcaml.str_item in
+()
+
+*)
+
+
--- /dev/null
+// -*- Mode: c -*-
+//
+/*
+ * A module that allows the reading of performance counters on Pentium.
+ *
+ * This file contains both code that uses the performance counters to
+ * compute the number of cycles per second (to be used during ./configure)
+ * and also code to read the performance counters from Ocaml.
+ *
+ * Author: George Necula (necula@cs.berkeley.edu)
+ */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#if defined(__GNUC__)
+ #define longlong long long
+ // RDTSC puts the result in EAX and EDX. We tell gcc to use those registers
+ // for "low" and "high"
+ #if defined(__i386__) || defined(__x86_64__)
+ #define GETCOUNTER(low,high) \
+ __asm__ volatile ("rdtsc" : "=a" (low), "=d" (high));
+ #else
+ #define GETCOUNTER(low,high) \
+ printf ("Reading of performance counters is supported only on Intel x86\n"); \
+ exit(1);
+ #endif
+#else
+ // Microsoft Visual Studio
+ #define longlong __int64
+ #define inline __inline
+ #define GETCOUNTER(low,high) __asm { \
+ __asm rdtsc \
+ __asm mov low, eax \
+ __asm mov high, edx };
+#endif
+
+/* Store here the first value read from the performance counter */
+unsigned static longlong first_value;
+
+
+/* This is the function that actually reads the performance counter. */
+inline unsigned longlong read_ppc(void) {
+ unsigned long pclow, pchigh;
+ unsigned longlong lowhigh;
+
+ GETCOUNTER(pclow, pchigh);
+
+ // printf ("Read low=0x%08lx high=0x%08lx\n", low, high);
+
+ // Put the 64-bit value together
+ lowhigh = ((unsigned longlong)pclow) | ((unsigned longlong)pchigh << 32);
+
+ if(first_value == 0) {
+ first_value = lowhigh;
+ }
+ return lowhigh - first_value;
+}
+
+
+/* sm: I want a version that is as fast as possible, dropping
+ * bits that aren't very important to achieve it. *
+ *
+ * This version drops the low 20 bits and the high 14 bits so the
+ * result is 30 bits (always a positive Ocaml int); this yields
+ * megacycles, which for GHz machines will be something like
+ * milliseconds. */
+static unsigned long sample_ppc_20(void)
+{
+ unsigned long pclow, pchigh;
+
+ GETCOUNTER(pclow, pchigh);
+
+ return ((pclow >> 20) | (pchigh << 12)) & 0x3FFFFFFF;
+}
+
+/* This version drops the low 10 bits, yielding something like
+ * microseconds. */
+inline static unsigned long sample_ppc_10()
+{
+ unsigned long pclow, pchigh;
+
+ GETCOUNTER(pclow,pchigh);
+
+ return ((pclow >> 10) | (pchigh << 22)) & 0x3FFFFFFF;
+}
+
+
+
+#ifndef CONFIGURATION_ONLY
+/*** This is the OCAML stub for the read_ppc ***/
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+
+// At configuration time, we estimated the cycles per microsecond as
+// @CYCLES_PER_USEC@. But if we can get the cycle counts directly from the OS,
+// do that instead, since it's more reliable and it lets us move programs
+// to different machines without recompiling.
+double cycles_per_usec = @CYCLES_PER_USEC@;
+
+#if defined(__FreeBSD__)
+#define CAN_GET_SPEED_FROM_OS
+
+ // Get the CPU speed from the sysctl machdep.tsc_freq
+ // This only works on FreeBSD
+
+ #include <sys/types.h>
+ #include <sys/param.h>
+ #include <sys/sysctl.h>
+
+ double getSpeedFromOS() {
+ unsigned long tscfreq;
+ size_t tflen = sizeof(tscfreq);
+
+ if (sysctlbyname("machdep.tsc_freq", (void *) &tscfreq,
+ &tflen, NULL, 0) < 0) {
+ perror("sysctl failed");
+ return @CYCLES_PER_USEC@;
+ }
+ return (double)tscfreq / 1000000; // We care about cycles per microsecond
+ }
+#elif defined(__CYGWIN__) || defined(__linux__)
+#define CAN_GET_SPEED_FROM_OS
+
+ // Get the CPU speed from /proc/cpuinfo
+
+ #define CPUINFO_KEY "cpu MHz"
+ #include <errno.h>
+
+ double getSpeedFromOS(){
+ char buffer[100];
+ FILE* cpuinfo = fopen("/proc/cpuinfo", "r");
+ if (!cpuinfo) {
+ printf("Error: could not open /proc/cpuinfo: %s", strerror(errno));
+ exit(1);
+ }
+ while(fgets(buffer, 100, cpuinfo)) {
+ if (0 == strncasecmp(buffer, CPUINFO_KEY, sizeof(CPUINFO_KEY)-1)) {
+ char* speed = buffer + sizeof(CPUINFO_KEY)-1;
+ double result;
+ while (*speed == ' ' || *speed == '\t' || *speed == ':') {
+ speed++;
+ }
+ result = atof(speed);
+ if (result != 0.0) {
+ return result;
+ }
+ }
+ }
+ // Reading /proc/cpuinfo failed to find "cpu MHz"
+ return @CYCLES_PER_USEC@;
+ }
+#endif
+
+
+/* Returns false if hardware counters are not availible. */
+value has_performance_counters() {
+
+ // HAS_PERFCOUNT is set by the configuration code at the end of
+ // this file, during ./configure
+ if ((@HAS_PERFCOUNT@) && (cycles_per_usec > 0.0)) {
+ return Val_true;
+ } else {
+ return Val_false;
+ }
+}
+
+/* The Ocaml system can use this function to set cycles_per_usec.
+ Returns false if hardware counters are not availible. */
+value reset_performance_counters() {
+
+#ifdef CAN_GET_SPEED_FROM_OS
+ cycles_per_usec = getSpeedFromOS();
+#endif
+
+ return has_performance_counters();
+}
+
+value read_pentium_perfcount()
+{
+ double counter = (double)read_ppc() / (1000000.0 * cycles_per_usec);
+ return copy_double(counter);
+}
+
+/* sm: interface to above from Ocaml */
+value sample_pentium_perfcount_20()
+{
+ return Val_long(sample_ppc_20());
+}
+
+value sample_pentium_perfcount_10()
+{
+ return Val_long(sample_ppc_10());
+}
+
+#endif
+
+
+/* Now we have a function that tries to compute the number of cycles per
+ * second (to be used during ./configure) */
+#ifdef CONFIGURATION_ONLY
+#include <sys/times.h>
+#include <unistd.h>
+#include <math.h>
+
+int main() {
+ struct tms t;
+ clock_t start, finish, diff;
+ unsigned longlong start_pc, finish_pc, diff_pc;
+ long clk_per_sec = sysconf(_SC_CLK_TCK);
+ double cycles_per_usec;
+
+ if(clk_per_sec <= 0) {
+ printf("Cannot find clk_per_sec (got %ld)\n", clk_per_sec);
+ exit(1);
+ }
+
+ times(&t); start = t.tms_utime;
+ start_pc = read_ppc();
+ // Do something for a while
+ {
+ int i;
+ double a = 5.678;
+ for(i=0;i<10000000;i++) {
+ a = (i & 1) ? (a * a) : (sqrt(a));
+ }
+ }
+ times(&t); finish = t.tms_utime;
+ finish_pc = read_ppc();
+ diff = finish - start;
+ diff_pc = finish_pc - start_pc;
+ if(diff == 0) {
+ printf("Cannot use Unix.times\n");
+ exit(1);
+ }
+ if(diff_pc == 0) {
+ printf("Invalid result from the peformance counters\n");
+ exit(1);
+ }
+ diff_pc /= 1000000; // We care about cycles per microsecond
+// printf("diff = %ld, diff_pc = %ld, clk = %ld\n",
+// (long)diff,
+// (long)diff_pc, (long)clk_per_sec);
+
+ cycles_per_usec = (((double)diff_pc / (double)diff)
+ * (double)clk_per_sec);
+
+ /* Whatever value we print here will be used as the CYCLES_PER_USEC
+ * below */
+ printf("%.3lf\n", cycles_per_usec);
+ exit(0);
+}
+#endif //defined CONFIGURATION_ONLY
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(******************************************************************************)
+(* Pretty printer
+ This module contains several fast, but sub-optimal heuristics to pretty-print
+ structured text.
+*)
+
+let debug = false
+
+(* Choose an algorithm *)
+type algo = George | Aman | Gap
+let algo = George
+let fastMode = ref false
+
+
+(** Whether to print identation or not (for faster printing and smaller
+ * output) *)
+let printIndent = ref true
+
+(******************************************************************************)
+(* The doc type and constructors *)
+
+type doc =
+ Nil
+ | Text of string
+ | Concat of doc * doc
+ | CText of doc * string
+ | Break
+ | Line
+ | LeftFlush
+ | Align
+ | Unalign
+ | Mark
+ | Unmark
+
+(* Break a string at \n *)
+let rec breakString (acc: doc) (str: string) : doc =
+ try
+ (* Printf.printf "breaking string %s\n" str; *)
+ let r = String.index str '\n' in
+ (* Printf.printf "r=%d\n" r; *)
+ let len = String.length str in
+ if r > 0 then begin
+ (* Printf.printf "Taking %s\n" (String.sub str 0 r); *)
+ let acc' = Concat(CText (acc, String.sub str 0 r), Line) in
+ if r = len - 1 then (* The last one *)
+ acc'
+ else begin
+ (* Printf.printf "Continuing with %s\n" (String.sub str (r + 1) (len - r - 1)); *)
+ breakString acc'
+ (String.sub str (r + 1) (len - r - 1))
+ end
+ end else (* The first is a newline *)
+ breakString (Concat(acc, Line))
+ (String.sub str (r + 1) (len - r - 1))
+ with Not_found ->
+ if acc = Nil then Text str else CText (acc, str)
+
+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 align = Align
+let unalign = Unalign
+let line = Line
+let leftflush = LeftFlush
+let break = Break
+let mark = Mark
+let unmark = Unmark
+
+let d_int32 (i: int32) = text (Int32.to_string i)
+let f_int32 () i = d_int32 i
+
+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
+ * left side of a Concat is the non-tail recursive case. *)
+
+let (++) d1 d2 = Concat (d1, d2)
+let concat d1 d2 = Concat (d1, d2)
+
+(* Ben Liblit fix *)
+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 rec loop (acc: doc) = function
+ [] -> acc
+ | 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 ->
+ let fh = doit h in loop fh t)
+
+
+let docArray ?(sep=chr ',') (doit:int -> 'a -> doc) () (elements:'a array) =
+ let len = Array.length elements in
+ if len = 0 then
+ nil
+ else
+ let rec loop (acc: doc) i =
+ if i >= len then acc else
+ let fi = doit i elements.(i) in (* Make sure this is done first *)
+ loop (acc ++ sep ++ fi) (i + 1)
+ in
+ let f0 = doit 0 elements.(0) in
+ loop f0 1
+
+let docOpt delem () = function
+ None -> text "None"
+ | Some e -> text "Some(" ++ (delem e) ++ chr ')'
+
+
+
+let docList ?(sep=chr ',') (doit:'a -> doc) () (elements:'a list) =
+ seq sep doit elements
+
+let insert () d = d
+
+
+let d_list (sep:string) (doit:unit -> 'a -> doc) () (elts:'a list) : doc =
+ (* thunk 'doit' to match docList's interface *)
+ let internalDoit (elt:'a) =
+ (doit () elt) in
+ (docList ~sep:(text sep) internalDoit () elts)
+
+(** Format maps *)
+module MakeMapPrinter =
+ functor (Map: sig
+ type key
+ type 'a t
+ val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ end) ->
+struct
+ let docMap ?(sep=chr ',')
+ (doit: Map.key -> 'a -> doc) () (maplets: 'a Map.t) : doc =
+ Map.fold
+ (fun k d acc ->
+ (if acc==nil then acc else acc ++ sep)
+ ++ (doit k d))
+ maplets
+ nil
+
+ let dmaplet d0 d1 = d0 ++ (text " |-> ") ++ d1
+
+ let d_map ?(dmaplet=dmaplet) (sep:string) dkey dval =
+ let doit = fun k d -> dmaplet (dkey () k) (dval () d) in
+ docMap ~sep:(text sep) doit
+end
+
+(** Format sets *)
+module MakeSetPrinter =
+ functor (Set: sig
+ type elt
+ type t
+ val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+ end) ->
+struct
+ let docSet ?(sep=chr ',') (doit: Set.elt -> doc) () (set: Set.t) : doc =
+ Set.fold
+ (fun elt acc ->
+ (if acc==nil then acc else acc ++ sep)
+ ++ (doit elt))
+ set
+ nil
+
+ let d_set (sep:string) delt =
+ docSet ~sep:(text sep) (delt ())
+end
+
+
+(******************************************************************************)
+(* Some debugging stuff *)
+
+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 ";
+ dbgPrintDoc d2; dbgprintf ""
+ | CText (d,s) -> dbgPrintDoc d; dbgprintf " ++ \"%s\"" s;
+ | Break -> dbgprintf "(Break)"
+ | Line -> dbgprintf "(Line)"
+ | LeftFlush -> dbgprintf "(LeftFlush)"
+ | Align -> dbgprintf "(Align)"
+ | Unalign -> dbgprintf "(Unalign)"
+ | 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
+ * consuming a lot of stack when we traverse the document *)
+let rec flatten (acc: doc) = function
+ | Concat (d1, d2) -> flatten (flatten acc d2) d1
+ | CText (d, s) -> flatten (Concat(Text s, acc)) d
+ | Nil -> acc (* Get rid of Nil *)
+ | 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
+ * 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
+ * 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
+ * previous active align *)
+ 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,
+ * with the top at the head. Never empty. *)
+ 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 topalign = List.hd !aligns in
+ 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 () =
+ match !aligns with
+ 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 are in *)
+let activeMarkups: int list ref = ref []
+
+
+(* 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 []
+
+(* The maximum column that we should use *)
+let maxCol = ref 0
+
+(* Sometimes we take all the optional breaks *)
+let breakAllMode = ref false
+
+(* We are taking a newline and moving left *)
+let newline () =
+ let topalign = List.hd !aligns in (* aligns is never empty *)
+ 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
+ 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
+ * align is the top align) *)
+let chooseBestGain () : align option =
+ let bestGain = ref 0 in
+ let rec loop (breakingAlign: align option) = function
+ [] -> breakingAlign
+ | a :: resta ->
+ if debug then dbgprintf "Looking at align with gain %d\n" a.gainBreak;
+ if a.gainBreak > !bestGain then begin
+ bestGain := a.gainBreak;
+ loop (Some a) resta
+ end else
+ loop breakingAlign resta
+ in
+ loop None !aligns
+
+
+(* Another one that chooses the break associated with the current align only *)
+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
+ * more are left *)
+ 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
+ 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
+ | Some breakingAlign -> begin
+ let topalign = List.hd !aligns in
+ let theGain = breakingAlign.gainBreak in
+ assert (theGain > 0);
+ if debug then dbgprintf "Taking break at %d. gain=%d\n" abscol theGain;
+ breakingAlign.isTaken := true;
+ breakingAlign.gainBreak <- 0;
+ if breakingAlign != topalign then begin
+ breakingAlign.deltaToNext :=
+ !(breakingAlign.deltaToNext) - theGain;
+ topAlignAbsCol := !topAlignAbsCol - theGain
+ end;
+ tryAgain (abscol - theGain)
+ end
+ end
+ in
+ 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
+ * !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 () =
+ incr alignDepth;
+ useAlignDepth && !alignDepth = !printDepth + 1
+
+(** Exit an align *)
+let exitAlign () =
+ decr alignDepth
+
+(** See if we are at a low-enough align level (and we should be printing
+ * normally) *)
+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
+ Nil -> abscol
+ | Concat (d1, d2) -> scan (scan abscol d1) d2
+ | 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) ->
+ let abscol' = scan abscol d in
+ if shallowAlign () then begin
+ 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
+ movingRight (abscol + 3) (* "..." *)
+ else
+ abscol
+
+ | Unalign -> exitAlign (); popAlign (); abscol
+
+ | 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
+ * followed by an optional line break *)
+ if !activeMarkups != [] then
+ failwith "Line breaks inside markup sections";
+ let takenref = ref false in
+ breaks := takenref :: !breaks;
+ let topalign = List.hd !aligns in (* aligns is never empty *)
+ if !breakAllMode then begin
+ takenref := true;
+ newline ()
+ end else begin
+ (* 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"
+ (1 + abscol) topalign.gainBreak;
+ movingRight (1 + abscol)
+ end
+
+ | Mark -> activeMarkups := abscol :: !activeMarkups;
+ abscol
+
+ | Unmark -> begin
+ 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
+ * 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
+ * string *)
+ (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
+ if leftflush is not encountered *)
+ let newline () =
+ match !aligns with
+ [] -> failwith "Ran out of aligns"
+ | x :: _ ->
+ emitString "\n" 1;
+ incr countNewLines;
+ wantIndent := true;
+ x
+ in
+ (* Print indentation if wantIndent was previously flagged ; reset this flag *)
+ let indentIfNeeded () =
+ if !printIndent && !wantIndent then ignore (
+ match !aligns with
+ [] -> failwith "Ran out of aligns"
+ | x :: _ ->
+ if x > 0 then emitString " " x;
+ x);
+ wantIndent := false
+ in
+ (* A continuation passing style loop *)
+ let rec loopCont (abscol: int) (d: doc) (cont: int -> unit) : unit
+ (* the new column *) =
+ match d with
+ Nil -> cont abscol
+ | Concat (d1, d2) ->
+ loopCont abscol d1 (fun abscol' -> loopCont abscol' d2 cont)
+
+ | 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
+ let sl = String.length s in
+ indentIfNeeded ();
+ emitString s 1;
+ cont (abscol' + sl)
+ else
+ cont abscol')
+
+ | Align ->
+ aligns := abscol :: !aligns;
+ if enterAlign () then begin
+ indentIfNeeded ();
+ emitString "..." 1;
+ cont (abscol + 3)
+ end else
+ cont abscol
+
+ | Unalign -> begin
+ match !aligns with
+ [] -> failwith "Unmatched unalign"
+ | _ :: rest ->
+ exitAlign ();
+ aligns := rest; cont abscol
+ end
+ | Line when shallowAlign () -> cont (newline ())
+ | LeftFlush when shallowAlign () -> wantIndent := false; cont (0)
+ | Break when shallowAlign () -> begin
+ match !breaks with
+ [] -> failwith "Break without a takenref"
+ | istaken :: rest ->
+ breaks := rest; (* Consume the break *)
+ if !istaken then cont (newline ())
+ else begin
+ indentIfNeeded ();
+ emitString " " 1;
+ cont (abscol + 1)
+ end
+ end
+
+ | Mark ->
+ activeMarkups := abscol :: !activeMarkups;
+ cont abscol
+
+ | Unmark -> begin
+ match !activeMarkups with
+ old :: rest -> activeMarkups := rest;
+ cont old
+ | [] -> failwith "Unmark without a mark"
+ end
+
+ | _ -> (* Align is too deep *)
+ cont abscol
+ in
+
+ loopCont 0 d (fun x -> ())
+
+
+(* Print a document on a channel *)
+let fprint (chn: out_channel) ~(width: int) doc =
+ (* Save some parameters, to allow for nested calls of these routines. *)
+ maxCol := width;
+ let old_breaks = !breaks in
+ breaks := [];
+ let old_alignDepth = !alignDepth in
+ alignDepth := 0;
+ 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
+ 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
+ * memory *)
+
+(* Print the document to a string *)
+let sprint ~(width : int) doc : string =
+ maxCol := width;
+ let old_breaks = !breaks in
+ breaks := [];
+ let old_activeMarkups = !activeMarkups in
+ activeMarkups := [];
+ let old_alignDepth = !alignDepth in
+ alignDepth := 0;
+ ignore (scan 0 doc);
+ breaks := List.rev !breaks;
+ let buf = Buffer.create 1024 in
+ let rec add_n_strings str num =
+ if num <= 0 then ()
+ else begin Buffer.add_string buf str; add_n_strings str (num - 1) end
+ in
+ emitDoc add_n_strings doc;
+ breaks := old_breaks;
+ activeMarkups := old_activeMarkups;
+ alignDepth := old_alignDepth;
+ Buffer.contents buf
+
+
+ (* The rest is based on printf.ml *)
+external format_int: string -> int -> string = "caml_format_int"
+external format_float: string -> float -> string = "caml_format_float"
+
+
+
+let gprintf (finish : doc -> 'b)
+ (format : ('a, unit, doc, 'b) format4) : 'a =
+ let format = (Obj.magic format : string) in
+
+ (* Record the starting align depth *)
+ let startAlignDepth = !alignDepth in
+ (* Special concatenation functions *)
+ 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
+ CText(acc, str)
+ in
+ (* Special finish function *)
+ let dfinish (dc: doc) : 'b =
+ if !alignDepth <> startAlignDepth then
+ prerr_string ("Unmatched align/unalign in " ^ format ^ "\n");
+ finish dc
+ in
+ 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
+ | '\n' -> true
+ | _ -> false) then
+ collect (dctext1 acc (String.sub format i (j-i))) j
+ else
+ skipChars (succ j)
+ in
+ skipChars (succ i)
+ (* the main collection function *)
+ and collect (acc: doc) (i: int) =
+ if i >= flen then begin
+ 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
+ | 's' ->
+ Obj.magic(fun s ->
+ let str =
+ if j <= i+1 then
+ s
+ else
+ let sl = String.length s in
+ let p =
+ try
+ int_of_string (String.sub format (i+1) (j-i-1))
+ with _ ->
+ invalid_arg "fprintf: bad %s format" in
+ if p > 0 && sl < p then
+ (String.make (p - sl) ' ') ^ s
+ else if p < 0 && sl < -p then
+ s ^ (String.make (-p - sl) ' ')
+ else
+ s
+ in
+ collect (breakString acc str) (succ j))
+ | 'c' ->
+ Obj.magic(fun c ->
+ collect (dctext1 acc (String.make 1 c)) (succ j))
+ | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
+ Obj.magic(fun n ->
+ collect (dctext1 acc
+ (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
+ formats d,i,o,x,X,u. For example, %Lo means print an Int64 in octal.*)
+ | '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 "
+ ^ (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. *)
+ Obj.magic(fun n ->
+ collect (dctext1 acc
+ (Int64.format format_spec n))
+ (succ j'))
+ | 'l' ->
+ 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. *)
+ Obj.magic(fun n ->
+ collect (dctext1 acc
+ (Int32.format format_spec n))
+ (succ j'))
+ | 'n' ->
+ 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. *)
+ Obj.magic(fun n ->
+ collect (dctext1 acc
+ (Nativeint.format format_spec n))
+ (succ j'))
+ | 'f' | 'e' | 'E' | 'g' | 'G' ->
+ Obj.magic(fun f ->
+ collect (dctext1 acc
+ (format_float (String.sub format i (j-i+1)) f))
+ (succ j))
+ | 'b' | 'B' ->
+ Obj.magic(fun b ->
+ collect (dctext1 acc (string_of_bool b)) (succ j))
+ | 'a' ->
+ Obj.magic(fun pprinter arg ->
+ collect (dconcat acc (pprinter () arg)) (succ j))
+ | 't' ->
+ Obj.magic(fun pprinter ->
+ collect (dconcat acc (pprinter ())) (succ j))
+ | c ->
+ invalid_arg ("dprintf: unknown format %s" ^ String.make 1 c)
+
+ end else if c = '@' then begin
+ if i + 1 < flen then begin
+ match fget (succ i) with
+
+ (* Now the special format characters *)
+ '[' -> (* align *)
+ let newacc =
+ if !alignDepth > !printDepth then
+ acc
+ else if !alignDepth = !printDepth then
+ CText(acc, "...")
+ else
+ acc ++ align
+ in
+ incr alignDepth;
+ collect newacc (i + 2)
+
+ | ']' -> (* unalign *)
+ decr alignDepth;
+ let newacc =
+ if !alignDepth >= !printDepth then
+ acc
+ else
+ acc ++ unalign
+ in
+ collect newacc (i + 2)
+ | '!' -> (* hard-line break *)
+ 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)
+ end else
+ invalid_arg "dprintf: incomplete format @"
+ end else if c = '\n' then begin
+ collect (dconcat acc line) (i + 1)
+ end else
+ literal acc i
+ end
+
+ and skip_args j =
+ match String.unsafe_get format j with
+ '0' .. '9' | ' ' | '.' | '-' -> skip_args (succ j)
+ | c -> j
+
+ in
+ collect Nil 0
+
+let withPrintDepth dp thunk =
+ let opd = !printDepth in
+ printDepth := dp;
+ thunk ();
+ printDepth := opd
+
+
+
+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
+ (* 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
+ * *)
+ if !flushOften then flush chn;
+ res
+ (* weimeric hack ends *)
+
+let printf format = fprintf stdout format
+let eprintf format = fprintf stderr format
+
+
+
+(******************************************************************************)
+let getAlgoName = function
+ George -> "George"
+ | Aman -> "Aman"
+ | Gap -> "Gap"
+
+let getAboutString () : string =
+ "(Pretty: ALGO=" ^ (getAlgoName algo) ^ ")"
+
+
+(************************************************)
+let auto_printer (typ: string) =
+ failwith ("Pretty.auto_printer \"" ^ typ ^ "\" only works with you use -pp \"camlp4o pa_prtype.cmo\" when you compile")
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001 by
+ * George C. Necula necula@cs.berkeley.edu
+ * Scott McPeak smcpeak@cs.berkeley.edu
+ * Wes Weimer weimer@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.
+ *
+ *)
+
+(** Utility functions for pretty-printing. The major features provided by
+ this module are
+- An [fprintf]-style interface with support for user-defined printers
+- The printout is fit to a width by selecting some of the optional newlines
+- Constructs for alignment and indentation
+- Print ellipsis starting at a certain nesting depth
+- Constructs for printing lists and arrays
+
+ Pretty-printing occurs in two stages:
+- Construct a {!Pretty.doc} object that encodes all of the elements to be
+ printed
+ along with alignment specifiers and optional and mandatory newlines
+- Format the {!Pretty.doc} to a certain width and emit it as a string, to an
+ output stream or pass it to a user-defined function
+
+ The formatting algorithm is not optimal but it does a pretty good job while
+ still operating in linear time. The original version was based on a pretty
+ printer by Philip Wadler which turned out to not scale to large jobs.
+*)
+
+(** API *)
+
+(** The type of unformated documents. Elements of this type can be
+ * constructed in two ways. Either with a number of constructor shown below,
+ * or using the {!Pretty.dprintf} function with a [printf]-like interface.
+ * The {!Pretty.dprintf} method is slightly slower so we do not use it for
+ * large jobs such as the output routines for a compiler. But we use it for
+ * small jobs such as logging and error messages. *)
+type doc
+
+
+
+(** Constructors for the doc type. *)
+
+
+
+
+(** Constructs an empty document *)
+val nil : doc
+
+
+(** Concatenates two documents. This is an infix operator that associates to
+ the left. *)
+val (++) : doc -> doc -> doc
+val concat : doc -> doc -> doc
+
+(** A document that prints the given string *)
+val text : string -> doc
+
+
+(** A document that prints an integer in decimal form *)
+val num : int -> doc
+
+(** A document that prints a 64-bit int in decimal form *)
+val num64 : int64 -> doc
+
+(** A document that prints a real number *)
+val real : float -> doc
+
+(** A document that prints a character. This is just like {!Pretty.text}
+ with a one-character string. *)
+val chr : char -> doc
+
+
+(** A document that consists of a mandatory newline. This is just like [(text
+ "\n")]. The new line will be indented to the current indentation level,
+ unless you use {!Pretty.leftflush} right after this. *)
+val line : doc
+
+(** Use after a {!Pretty.line} to prevent the indentation. Whatever follows
+ * next will be flushed left. Indentation resumes on the next line. *)
+val leftflush : doc
+
+
+(** A document that consists of either a space or a line break. Also called
+ an optional line break. Such a break will be
+ taken only if necessary to fit the document in a given width. If the break
+ is not taken a space is printed instead. *)
+val break: doc
+
+(** Mark the current column as the current indentation level. Does not print
+ anything. All taken line breaks will align to this column. The previous
+ alignment level is saved on a stack. *)
+val align: doc
+
+(** Reverts to the last saved indentation level. *)
+val unalign: doc
+
+
+(** Mark the beginning of a markup section. The width of a markup section is
+ * considered 0 for the purpose of computing identation *)
+val mark: doc
+
+(** The end of a markup section *)
+val unmark: doc
+
+(************* Now some syntactic sugar *****************)
+(** Syntactic sugar *)
+
+(** Indents the document. Same as [((text " ") ++ align ++ doc ++ unalign)],
+ with the specified number of spaces. *)
+val indent: int -> doc -> doc
+
+(** Prints a document as markup. The marked document cannot contain line
+ * breaks or alignment constructs. *)
+val markup: doc -> doc
+
+(** Formats a sequence. [sep] is a separator, [doit] is a function that
+ * converts an element to a document. *)
+val seq: sep:doc -> doit:('a ->doc) -> elements:'a list -> doc
+
+
+(** An alternative function for printing a list. The [unit] argument is there
+ * to make this function more easily usable with the {!Pretty.dprintf}
+ * interface. The first argument is a separator, by default a comma. *)
+val docList: ?sep:doc -> ('a -> doc) -> unit -> 'a list -> doc
+
+(** sm: Yet another list printer. This one accepts the same kind of
+ * printing function that {!Pretty.dprintf} does, and itself works
+ * in the dprintf context. Also accepts
+ * a string as the separator since that's by far the most common. *)
+val d_list: string -> (unit -> 'a -> doc) -> unit -> 'a list -> doc
+
+(** Formats an array. A separator and a function that prints an array
+ element. The default separator is a comma. *)
+val docArray: ?sep:doc -> (int -> 'a -> doc) -> unit -> 'a array -> doc
+
+(** Prints an ['a option] with [None] or [Some] *)
+val docOpt: ('a -> doc) -> unit -> 'a option -> doc
+
+
+(** Print an int32 *)
+val d_int32: int32 -> doc
+val f_int32: unit -> int32 -> doc
+
+val d_int64: int64 -> doc
+val f_int64: unit -> int64 -> doc
+
+(** Format maps. *)
+module MakeMapPrinter :
+ functor (Map: sig
+ type key
+ type 'a t
+ val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ end) ->
+sig
+ (** Format a map, analogous to docList. *)
+ val docMap: ?sep:doc -> (Map.key -> 'a -> doc) -> unit -> 'a Map.t -> doc
+
+ (** Format a map, analogous to d_list. *)
+ val d_map: ?dmaplet:(doc -> doc -> doc)
+ -> string
+ -> (unit -> Map.key -> doc)
+ -> (unit -> 'a -> doc)
+ -> unit
+ -> 'a Map.t
+ -> doc
+ end
+
+(** Format sets. *)
+module MakeSetPrinter :
+ functor (Set: sig
+ type elt
+ type t
+ val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+ end) ->
+sig
+ (** Format a set, analogous to docList. *)
+ val docSet: ?sep:doc -> (Set.elt -> doc) -> unit -> Set.t -> doc
+
+ (** Format a set, analogous to d_list. *)
+ val d_set: string
+ -> (unit -> Set.elt -> doc)
+ -> unit
+ -> Set.t
+ -> doc
+end
+
+(** A function that is useful with the [printf]-like interface *)
+val insert: unit -> doc -> doc
+
+val dprintf: ('a, unit, doc, doc) format4 -> 'a
+(** This function provides an alternative method for constructing
+ [doc] objects. The first argument for this function is a format string
+ argument (of type [('a, unit, doc) format]; if you insist on
+ understanding what that means see the module [Printf]). The format string
+ is like that for the [printf] function in C, except that it understands a
+ few more formatting controls, all starting with the @ character.
+
+ See the gprintf function if you want to pipe the result of dprintf into
+ some other functions.
+
+ The following special formatting characters are understood (these do not
+ correspond to arguments of the function):
+- @\[ Inserts an {!Pretty.align}. Every format string must have matching
+ {!Pretty.align} and {!Pretty.unalign}.
+- @\] Inserts an {!Pretty.unalign}.
+- @! Inserts a {!Pretty.line}. Just like "\n"
+- @? Inserts a {!Pretty.break}.
+- @< Inserts a {!Pretty.mark}.
+- @> Inserts a {!Pretty.unmark}.
+- @^ Inserts a {!Pretty.leftflush}
+ Should be used immediately after @! or "\n".
+- @@ : inserts a @ character
+
+ In addition to the usual [printf] % formatting characters the following two
+ new characters are supported:
+- %t Corresponds to an argument of type [unit -> doc]. This argument is
+ invoked to produce a document
+- %a Corresponds to {b two} arguments. The first of type [unit -> 'a -> doc]
+ and the second of type ['a]. (The extra [unit] is do to the
+ peculiarities of the built-in support for format strings in Ocaml. It
+ turns out that it is not a major problem.) Here is an example of how
+ you use this:
+
+{v dprintf "Name=%s, SSN=%7d, Children=\@\[%a\@\]\n"
+ pers.name pers.ssn (docList (chr ',' ++ break) text)
+ pers.children v}
+
+ The result of [dprintf] is a {!Pretty.doc}. You can format the document and
+ emit it using the functions {!Pretty.fprint} and {!Pretty.sprint}.
+
+*)
+
+(** Like {!Pretty.dprintf} but more general. It also takes a function that is
+ * invoked on the constructed document but before any formatting is done. The
+ * type of the format argument means that 'a is the type of the parameters of
+ * this function, unit is the type of the first argument to %a and %t
+ * formats, doc is the type of the intermediate result, and 'b is the type of
+ * the result of gprintf. *)
+val gprintf: (doc -> 'b) -> ('a, unit, doc, 'b) format4 -> 'a
+
+(** Format the document to the given width and emit it to the given channel *)
+val fprint: out_channel -> width:int -> doc -> unit
+
+(** Format the document to the given width and emit it as a string *)
+val sprint: width:int -> doc -> string
+
+(** Like {!Pretty.dprintf} followed by {!Pretty.fprint} *)
+val fprintf: out_channel -> ('a, unit, doc) format -> 'a
+
+(** Like {!Pretty.fprintf} applied to [stdout] *)
+val printf: ('a, unit, doc) format -> 'a
+
+(** Like {!Pretty.fprintf} applied to [stderr] *)
+val eprintf: ('a, unit, doc) format -> 'a
+
+
+(* sm: arg! why can't I write this function?! *)
+(* * Like {!Pretty.dprintf} but yielding a string with no newlines *)
+(*val sprintf: (doc, unit, doc) format -> string*)
+
+(* sm: different tack.. *)
+(* doesn't work either. well f it anyway *)
+(*val failwithf: ('a, unit, doc) format -> 'a*)
+
+
+(** Invokes a thunk, with printDepth temporarily set to the specified value *)
+val withPrintDepth : int -> (unit -> unit) -> unit
+
+(** The following variables can be used to control the operation of the printer *)
+
+(** Specifies the nesting depth of the [align]/[unalign] pairs at which
+ everything is replaced with ellipsis *)
+val printDepth : int ref
+
+val printIndent : bool ref (** If false then does not indent *)
+
+
+(** If set to [true] then optional breaks are taken only when the document
+ has exceeded the given width. This means that the printout will looked
+ more ragged but it will be faster *)
+val fastMode : bool ref
+
+val flushOften : bool ref (** If true the it flushes after every print *)
+
+
+(** Keep a running count of the taken newlines. You can read and write this
+ * from the client code if you want *)
+val countNewLines : int ref
+
+
+(** A function that when used at top-level in a module will direct
+ * the pa_prtype module generate automatically the printing functions for a
+ * type *)
+val auto_printer: string -> 'b
--- /dev/null
+// -*- Mode: c -*-
+//
+
+/* This is a replacement for the standard library profiling functions. I
+ * have copied most of this code from the cygwin distribution. The "mcount"
+ * function is new, and so is the startup/exit mechanism. */
+
+#include <stdio.h>
+#include <string.h>
+#include <assert.h>
+
+// We must tell GCC not to instrument this function for profiling
+// Put here the profiling code
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#include <fcntl.h>
+#include <unistd.h>
+
+// If DEBUG == 1 we print some start-up and exit info
+// If DEBUG == 2 we print also information on some mcount invocations
+// when something interesting happens
+// If DEBUG >= 3 we print information on all mcount invocations
+#define DEBUG 1
+
+#ifndef O_BINARY
+#define O_BINARY 0
+#endif
+
+#ifndef PROF_HZ
+#define PROF_HZ 100
+#endif
+
+
+/* On Linux if we re-define the __monstartup and the _mcleanup symbols then
+ * these take over the ones defined in the library. On other architectures,
+ * we hook these functions in ourselves in initProfiler */
+
+#if defined(x86_LINUX)
+ #define MONSTARTUP __monstartup
+ #define MONCLEANUP _mcleanup
+ #define GMONOUT "gmon.out"
+#elif defined(x86_WIN32)
+ #define MONSTARTUP my_monstartup
+ #define MONCLEANUP my_mcleanup
+ #define MUST_INIT_PROFILER 1
+ #define GMONOUT "gmon.out0"
+ void MONSTARTUP(u_long low, u_long high);
+ void MONCLEANUP(void);
+ extern u_char etext asm ("etext");
+ extern u_char mainCRTStartup;
+ extern void _monstartup(void);
+#else
+ #error Unknown architecture
+#endif
+
+extern void aftermcount(void);
+extern void mcount(void);
+
+static int profilerInitialized = 0; // Whether we have loaded the table
+// The table contains the ranges we must skip
+#define MAX_RANGE 128
+struct range {
+ unsigned long low, high;
+} rangetable[MAX_RANGE];
+int nextIdx = 0; // The index of the next free element
+
+extern u_char start_this_file;
+asm(".text");
+asm("start_this_file:");
+
+static struct range* findInTable(unsigned long pc) {
+ int l = 0, h = nextIdx; // If the element exists its index is >= l and < h
+ while(l < h) {
+ int m = (l + h) >> 1;
+ // l <= m < h
+ if(pc < rangetable[m].low) {
+ h = m; // make progress because m < h
+ } else
+ if(pc >= rangetable[m].high) {
+ l = m + 1; // make progress because m + 1 > l
+ } else {
+ // m is the one we need
+ return & rangetable[m];
+ }
+ }
+ return 0;
+}
+
+void my_mcleanup(void);
+
+void initProfiler() {
+ // See if we have defined the magic environment variable
+ char *f = getenv("PROFILE_SKIP_RANGE_FILE");
+ assert(! profilerInitialized);
+
+ profilerInitialized = 1;
+#if DEBUG >= 1
+ fprintf(stderr, "Initializing the profiler\n");
+#endif
+ nextIdx = 0;
+ if(f) {
+ FILE *ff = fopen(f, "r");
+ if(ff) {
+ while(! feof(ff)) {
+ unsigned long low, high;
+ int i;
+ if(nextIdx >= MAX_RANGE) {
+ fprintf(stderr, "Too many profile ranges");
+ break;
+ }
+ if(2 != fscanf(ff, "%ld-%ld ", &low, &high)) {
+ fprintf(stderr, "Invalid line in profile ranges file %s\n", f);
+ break;
+ }
+#if DEBUG >= 3
+ fprintf(stderr,
+ "Loaded profile skip range %ld-%ld\n", low, high);
+#endif
+ // Insert it sorted in the table
+ for(i=0;i<nextIdx;i++) {
+ if(rangetable[i].low < low) continue;
+
+ if(rangetable[i].low == low) // Already inserted
+ goto DoneInserting;
+
+ break;
+ }
+ // We get here if we must insert at i
+ // Make room by moving the tail
+ memmove(& rangetable[i + 1], &rangetable[i],
+ sizeof(rangetable[0]) * (nextIdx - i));
+ rangetable[i].low = low;
+ rangetable[i].high = high;
+ nextIdx ++;
+ DoneInserting:
+ }
+ fclose(ff);
+ // Coalesce adjacent entries in the table
+ {
+ int current = 0;
+ int next = 1;
+ while(next < nextIdx) {
+ if(rangetable[current].high + 8 >= rangetable[next].low) {
+ // Coalesce
+ rangetable[current].high = rangetable[next].high;
+ next ++;
+ } else {
+ // Do not coalesce
+ current ++;
+ if(current != next) {
+ rangetable[current] = rangetable[next];
+ }
+ next ++;
+ }
+ }
+ nextIdx = current + 1;
+ }
+ }
+ }
+
+ /* Now we must call the initialization functions, if we are not on Linux */
+#ifdef MUST_INIT_PROFILER
+#if DEBUG >= 1
+ fprintf(stderr, " calling the standard profiler startup function\n");
+#endif
+ MONSTARTUP((u_long) & mainCRTStartup, (u_long)&etext);
+ atexit(& MONCLEANUP);
+#endif
+
+#if DEBUG >= 2
+ {
+ int i;
+ fprintf(stderr, "Profiler skip table is:\n");
+ for(i=0;i<nextIdx;i++) {
+ fprintf(stderr, " 0x%lx-0x%lx\n",
+ rangetable[i].low, rangetable[i].high);
+ }
+ }
+#endif
+
+}
+
+// Start code copied from elsewhere
+//
+/*
+ * Structure prepended to gmon.out profiling data file.
+ */
+struct gmonhdr {
+ u_long lpc; /* base pc address of sample buffer */
+ u_long hpc; /* max pc address of sampled buffer */
+ int ncnt; /* size of sample buffer (plus this header) */
+ int version; /* version number */
+ int profrate; /* profiling clock rate */
+ int spare[3]; /* reserved */
+};
+#define GMONVERSION 0x00051879
+
+/*
+ * histogram counters are unsigned shorts (according to the kernel).
+ */
+#define HISTCOUNTER unsigned short
+
+/*
+ * fraction of text space to allocate for histogram counters here, 1/2
+ */
+#define HISTFRACTION 2
+
+/*
+ * Fraction of text space to allocate for from hash buckets.
+ * The value of HASHFRACTION is based on the minimum number of bytes
+ * of separation between two subroutine call points in the object code.
+ * Given MIN_SUBR_SEPARATION bytes of separation the value of
+ * HASHFRACTION is calculated as:
+ *
+ * HASHFRACTION = MIN_SUBR_SEPARATION / (2 * sizeof(short) - 1);
+ *
+ * For example, on the VAX, the shortest two call sequence is:
+ *
+ * calls $0,(r0)
+ * calls $0,(r0)
+ *
+ * which is separated by only three bytes, thus HASHFRACTION is
+ * calculated as:
+ *
+ * HASHFRACTION = 3 / (2 * 2 - 1) = 1
+ *
+ * Note that the division above rounds down, thus if MIN_SUBR_FRACTION
+ * is less than three, this algorithm will not work!
+ *
+ * In practice, however, call instructions are rarely at a minimal
+ * distance. Hence, we will define HASHFRACTION to be 2 across all
+ * architectures. This saves a reasonable amount of space for
+ * profiling data structures without (in practice) sacrificing
+ * any granularity.
+ */
+#define HASHFRACTION 2
+
+/*
+ * percent of text space to allocate for tostructs with a minimum.
+ */
+#define ARCDENSITY 2
+#define MINARCS 50
+#define MAXARCS ((1 << (8 * sizeof(HISTCOUNTER))) - 2)
+
+struct tostruct {
+ u_long selfpc;
+ long count;
+ u_short link;
+ u_short pad;
+};
+
+/*
+ * a raw arc, with pointers to the calling site and
+ * the called site and a count.
+ */
+struct rawarc {
+ u_long raw_frompc;
+ u_long raw_selfpc;
+ long raw_count;
+};
+
+/*
+ * general rounding functions.
+ */
+#define ROUNDDOWN(x,y) (((x)/(y))*(y))
+#define ROUNDUP(x,y) ((((x)+(y)-1)/(y))*(y))
+
+/*
+ * The profiling data structures are housed in this structure.
+ */
+struct gmonparam {
+ int state;
+ u_short *kcount;
+ u_long kcountsize;
+ u_short *froms;
+ u_long fromssize;
+ struct tostruct *tos;
+ u_long tossize;
+ long tolimit;
+ u_long lowpc;
+ u_long highpc;
+ u_long textsize;
+ u_long hashfraction;
+};
+extern struct gmonparam _my_gmonparam;
+
+/*
+ * Possible states of profiling.
+ */
+#define GMON_PROF_ON 0
+#define GMON_PROF_BUSY 1
+#define GMON_PROF_ERROR 2
+#define GMON_PROF_OFF 3
+
+/*
+ * Sysctl definitions for extracting profiling information from the kernel.
+ */
+#define GPROF_STATE 0 /* int: profiling enabling variable */
+#define GPROF_COUNT 1 /* struct: profile tick count buffer */
+#define GPROF_FROMS 2 /* struct: from location hash bucket */
+#define GPROF_TOS 3 /* struct: destination/count structure */
+#define GPROF_GMONPARAM 4 /* struct: profiling parameters (see above) */
+
+
+
+
+struct gmonparam _my_gmonparam = { GMON_PROF_OFF };
+
+static int s_scale;
+/* see profil(2) where this is described (incorrectly) */
+#define SCALE_1_TO_1 0x10000L
+
+#define PCTOIDX(pc,base) \
+ ((unsigned int) \
+ (((unsigned long long)((u_long)(pc) - (u_long)(base)) / 2) \
+ * (unsigned long long)s_scale / 65536))
+#define IDXTOPC(idx,base) \
+ ((u_long)((unsigned long long)(idx) * 65536LL / s_scale * 2) + \
+ (u_long)(base))
+
+#define ERR(s) write(2, s, sizeof(s))
+
+void my_moncontrol(int);
+
+static void *
+fake_sbrk(int size)
+{
+ void *rv = malloc(size);
+ if (rv)
+ return rv;
+ else
+ return (void *) -1;
+}
+
+void MONCLEANUP()
+{
+ int fd;
+ int hz;
+ int fromindex;
+ int endfrom;
+ u_long frompc;
+ int toindex;
+ struct rawarc rawarc;
+ struct gmonparam *p = &_my_gmonparam;
+ struct gmonhdr gmonhdr, *hdr;
+ char *proffile;
+#if DEBUG >= 1
+ int log, len;
+ char dbuf[200];
+#endif
+
+#if DEBUG >= 1
+ fprintf(stderr, "Saving profile output in %s\n", GMONOUT);
+#endif
+
+ if (p->state == GMON_PROF_ERROR)
+ ERR("_mcleanup: tos overflow\n");
+
+ hz = PROF_HZ;
+ my_moncontrol(0);
+
+ profilerInitialized = 0;
+
+#ifdef nope
+ if ((profdir = getenv("PROFDIR")) != NULL) {
+ extern char *__progname;
+ char *s, *t, *limit;
+ pid_t pid;
+ long divisor;
+
+ /* If PROFDIR contains a null value, no profiling
+ output is produced */
+ if (*profdir == '\0') {
+ return;
+ }
+
+ limit = buf + sizeof buf - 1 - 10 - 1 -
+ strlen(__progname) - 1;
+ t = buf;
+ s = profdir;
+ while((*t = *s) != '\0' && t < limit) {
+ t++;
+ s++;
+ }
+ *t++ = '/';
+
+ /*
+ * Copy and convert pid from a pid_t to a string. For
+ * best performance, divisor should be initialized to
+ * the largest power of 10 less than PID_MAX.
+ */
+ pid = getpid();
+ divisor=10000;
+ while (divisor > pid) divisor /= 10; /* skip leading zeros */
+ do {
+ *t++ = (pid/divisor) + '0';
+ pid %= divisor;
+ } while (divisor /= 10);
+ *t++ = '.';
+
+ s = __progname;
+ while ((*t++ = *s++) != '\0')
+ ;
+
+ proffile = buf;
+ } else {
+ proffile = GMONOUT;
+ }
+#else
+ {
+ char gmon_out[] = GMONOUT;
+ proffile = gmon_out;
+ }
+#endif
+
+ fd = open(proffile , O_CREAT|O_TRUNC|O_WRONLY|O_BINARY, 0666);
+ if (fd < 0) {
+ perror( proffile );
+ return;
+ }
+#if DEBUG >= 1
+ log = open("gmon.log", O_CREAT|O_TRUNC|O_WRONLY, 0664);
+ if (log < 0) {
+ perror("mcount: gmon.log");
+ return;
+ }
+ len = sprintf(dbuf, "[mcleanup1] kcount 0x%lx ssiz %ld\n",
+ (u_long)p->kcount, p->kcountsize);
+ write(log, dbuf, len);
+#endif
+ hdr = (struct gmonhdr *)&gmonhdr;
+ hdr->lpc = p->lowpc;
+ hdr->hpc = p->highpc;
+ hdr->ncnt = p->kcountsize + sizeof(gmonhdr);
+ hdr->version = GMONVERSION;
+ hdr->profrate = hz;
+ write(fd, (char *)hdr, sizeof *hdr);
+
+ /* Clear out the counts associated with PCs in this file */
+ {
+ unsigned int first_idx = PCTOIDX(&mcount, p->lowpc);
+ unsigned int last_idx = PCTOIDX(&aftermcount, p->lowpc);
+
+ /*fprintf(stderr, "s_scale = %d, base = 0x%lx\n",
+ s_scale, p->lowpc);
+ fprintf(stderr, "findInTable at 0x%lx, mcount at 0x%lx, after 0x%lx\n",
+ (u_long)&start_this_file, (u_long)&mcount,
+ (u_long)&aftermcount);*/
+ if(first_idx >= p->kcountsize / sizeof(p->kcount[0]) ||
+ last_idx >= p->kcountsize / sizeof(p->kcount[0])) {
+ fprintf(stderr, "Invalid indices into the profile table\n");
+ } else {
+#if DEBUG >= 2
+ fprintf(stderr, "Will clear from %d-%d\n", first_idx, last_idx);
+#endif
+ for(;first_idx<=last_idx;first_idx++) {
+#if DEBUG >= 2
+ fprintf(stderr, "Clear index %d in count table: 0x%lx-0x%lx.\n",
+ first_idx,
+ IDXTOPC(first_idx,p->lowpc),
+ IDXTOPC(first_idx+1,p->lowpc));
+#endif
+ p->kcount[first_idx] = 0;
+ }
+ }
+ }
+
+ write(fd, p->kcount, p->kcountsize);
+ endfrom = p->fromssize / sizeof(*p->froms);
+ for (fromindex = 0; fromindex < endfrom; fromindex++) {
+ if (p->froms[fromindex] == 0)
+ continue;
+
+ frompc = p->lowpc;
+ frompc += fromindex * p->hashfraction * sizeof(*p->froms);
+ for (toindex = p->froms[fromindex]; toindex != 0;
+ toindex = p->tos[toindex].link) {
+#if DEBUG >= 1
+ len = sprintf(dbuf,
+ "[mcleanup2] frompc 0x%lx selfpc 0x%lx count %ld\n" ,
+ frompc, p->tos[toindex].selfpc,
+ p->tos[toindex].count);
+ write(log, dbuf, len);
+#endif
+ rawarc.raw_frompc = frompc;
+ rawarc.raw_selfpc = p->tos[toindex].selfpc;
+ rawarc.raw_count = p->tos[toindex].count;
+ write(fd, &rawarc, sizeof rawarc);
+ }
+ }
+ close(fd);
+}
+
+// This will be called from the main library
+void MONSTARTUP(lowpc, highpc)
+ u_long lowpc;
+ u_long highpc;
+{
+ register int o;
+ char *cp;
+ struct gmonparam *p = &_my_gmonparam;
+
+#if DEBUG >= 1
+ fprintf(stderr, "You called monstartup(LOW=0x%lx, HIGH=0x%lx)\n",
+ lowpc, highpc);
+#endif
+ /*
+ * round lowpc and highpc to multiples of the density we're using
+ * so the rest of the scaling (here and in gprof) stays in ints.
+ */
+ p->lowpc = ROUNDDOWN(lowpc, HISTFRACTION * sizeof(HISTCOUNTER));
+ p->highpc = ROUNDUP(highpc, HISTFRACTION * sizeof(HISTCOUNTER));
+ p->textsize = p->highpc - p->lowpc;
+ p->kcountsize = p->textsize / HISTFRACTION;
+ p->hashfraction = HASHFRACTION;
+ p->fromssize = p->textsize / p->hashfraction;
+ p->tolimit = p->textsize * ARCDENSITY / 100;
+ if (p->tolimit < MINARCS)
+ p->tolimit = MINARCS;
+ else if (p->tolimit > MAXARCS)
+ p->tolimit = MAXARCS;
+ p->tossize = p->tolimit * sizeof(struct tostruct);
+
+ cp = fake_sbrk(p->kcountsize + p->fromssize + p->tossize);
+ if (cp == (char *)-1) {
+ ERR("monstartup: out of memory\n");
+ return;
+ }
+#ifdef notdef
+ bzero(cp, p->kcountsize + p->fromssize + p->tossize);
+#endif
+ p->tos = (struct tostruct *)cp;
+ cp += p->tossize;
+ p->kcount = (u_short *)cp;
+ cp += p->kcountsize;
+ p->froms = (u_short *)cp;
+
+ /* XXX minbrk needed? */
+ //minbrk = fake_sbrk(0);
+ p->tos[0].link = 0;
+
+ o = p->highpc - p->lowpc;
+ if (p->kcountsize < o) {
+#ifndef notdef
+ s_scale = ((float)p->kcountsize / o ) * SCALE_1_TO_1;
+#else /* avoid floating point */
+ int quot = o / p->kcountsize;
+
+ if (quot >= 0x10000)
+ s_scale = 1;
+ else if (quot >= 0x100)
+ s_scale = 0x10000 / quot;
+ else if (o >= 0x800000)
+ s_scale = 0x1000000 / (o / (p->kcountsize >> 8));
+ else
+ s_scale = 0x1000000 / ((o << 8) / p->kcountsize);
+#endif
+ } else
+ s_scale = SCALE_1_TO_1;
+
+ my_moncontrol(1);
+}
+
+
+/*
+ * Control profiling
+ * profiling is what mcount checks to see if
+ * all the data structures are ready.
+ */
+
+void
+my_moncontrol(mode)
+ int mode;
+{
+ struct gmonparam *p = &_my_gmonparam;
+
+ if (mode) {
+ /* start */
+ profil((u_short *)p->kcount, p->kcountsize, p->lowpc,
+ s_scale);
+ p->state = GMON_PROF_ON;
+ } else {
+ /* stop */
+ profil((u_short *)0, 0, 0, 0);
+ p->state = GMON_PROF_OFF;
+ }
+}
+
+
+
+
+inline static void
+_mcount(p, frompc, selfpc) /* _mcount; may be static, inline, etc */
+ register struct gmonparam *p;
+ register u_long frompc, selfpc;
+{
+ register u_short *frompcindex;
+ register struct tostruct *top, *prevtop;
+ register long toindex;
+
+ frompc -= p->lowpc;
+#if (HASHFRACTION & (HASHFRACTION - 1)) == 0
+ if (p->hashfraction == HASHFRACTION)
+ frompcindex =
+ &p->froms[frompc / (HASHFRACTION * sizeof(*p->froms))];
+ else
+#endif
+ frompcindex =
+ &p->froms[frompc / (p->hashfraction * sizeof(*p->froms))];
+ toindex = *frompcindex;
+ if (toindex == 0) {
+ /*
+ * first time traversing this arc
+ */
+ toindex = ++p->tos[0].link;
+ if (toindex >= p->tolimit)
+ /* halt further profiling */
+ goto overflow;
+
+ *frompcindex = toindex;
+ top = &p->tos[toindex];
+ top->selfpc = selfpc;
+ top->count = 1;
+ top->link = 0;
+ goto done;
+ }
+ top = &p->tos[toindex];
+ if (top->selfpc == selfpc) {
+ /*
+ * arc at front of chain; usual case.
+ */
+ top->count++;
+ goto done;
+ }
+ /*
+ * have to go looking down chain for it.
+ * top points to what we are looking at,
+ * prevtop points to previous top.
+ * we know it is not at the head of the chain.
+ */
+ for (; /* goto done */; ) {
+ if (top->link == 0) {
+ /*
+ * top is end of the chain and none of the chain
+ * had top->selfpc == selfpc.
+ * so we allocate a new tostruct
+ * and link it to the head of the chain.
+ */
+ toindex = ++p->tos[0].link;
+ if (toindex >= p->tolimit)
+ goto overflow;
+
+ top = &p->tos[toindex];
+ top->selfpc = selfpc;
+ top->count = 1;
+ top->link = *frompcindex;
+ *frompcindex = toindex;
+ goto done;
+ }
+ /*
+ * otherwise, check the next arc on the chain.
+ */
+ prevtop = top;
+ top = &p->tos[top->link];
+ if (top->selfpc == selfpc) {
+ /*
+ * there it is.
+ * increment its count
+ * move it to the head of the chain.
+ */
+ top->count++;
+ toindex = prevtop->link;
+ prevtop->link = top->link;
+ top->link = *frompcindex;
+ *frompcindex = toindex;
+ goto done;
+ }
+ }
+done:
+ p->state = GMON_PROF_ON;
+ return;
+overflow:
+ p->state = GMON_PROF_ERROR;
+ return;
+}
+
+/* I have no idea how to find the backtrace in the Ocaml native code
+ * compilation. So, we maintain a stack outselves. We put on the stack only
+ * the functions we must skip. */
+static struct stackentry {
+ struct range range; // Range of the PC for the function
+ u_long frompc; // The address it was called from
+ u_long frame_address; // The frame address for this function
+} stack[128];
+static struct stackentry *stackTop = &stack[0];
+ /* The top of the stack. There is always an
+ * element with 0 */
+
+
+void mcount() {
+ register struct gmonparam *p;
+ register u_long frompc, selfpc;
+ register u_long frame_address;
+ struct range *selfrange;
+
+ if(! profilerInitialized) initProfiler ();
+
+ // This code was copied from _mcount. We moved it here because we want
+ // to avoid expensive table lookups if not necessary
+ p = &_my_gmonparam;
+ /*
+ * check that we are profiling
+ * and that we aren't recursively invoked.
+ */
+ if (p->state != GMON_PROF_ON) {
+#if DEBUG >= 2
+ fprintf(stderr, "already profiling\n");
+#endif
+ return;
+ }
+ p->state = GMON_PROF_BUSY;
+
+ selfpc = (unsigned long)__builtin_return_address(0);
+ frompc = (unsigned long)__builtin_return_address(1);
+
+
+#if DEBUG >= 3
+ fprintf(stderr, "mcount 0x%lx -> 0x%lx.\n",
+ frompc, selfpc);
+#endif
+
+ // See if we need to pop some things off the stack
+ frame_address = (u_long)__builtin_frame_address(0);
+ while(stackTop > stack && frame_address >= stackTop->frame_address) {
+#if DEBUG >= 2
+ fprintf(stderr, "Poping profiling stack entry 0x%lx\n",
+ stackTop->frame_address);
+#endif
+ stackTop --;
+ }
+
+ /* See if we need to change the frompc to pretend we are coming from
+ * somewhere else */
+ if(frompc >= stackTop->range.low
+ && frompc < stackTop->range.high) {
+ // This means we are calling from a function that we have to skip
+#if DEBUG >= 2
+ fprintf(stderr, "Changing FROM=0x%lx (0x%lx->0x%lx).\n",
+ stackTop->frompc, frompc, selfpc);
+#endif
+ // Pretend we are coming directly from grandparent
+ frompc = stackTop->frompc;
+ }
+
+ /* See if we must push a new entry on the stack, for a SELFPC that we must
+ * skip */
+ selfrange = findInTable(selfpc);
+ if(selfrange) {
+ if(stackTop->frompc != frompc
+ || stackTop->range.low != selfrange->low
+ || stackTop->range.high != selfrange->high) {
+#if DEBUG >= 2
+ fprintf(stderr, "Pushing profiling entry (0x%lx-0x%lx) frame 0x%lx, from 0x%lx\n",
+ selfrange->low, selfrange->high, frame_address, frompc);
+#endif
+ stackTop ++;
+ if(stackTop - stack >= sizeof(stack) / sizeof(stack[0])) {
+ fprintf(stderr, "Profiling stack overflow\n");
+ stackTop = stack;
+ }
+ stackTop->range = *selfrange;
+ stackTop->frompc = frompc;
+ stackTop->frame_address = frame_address;
+ }
+ }
+
+
+ /* Finally, ignore those cases when the FROMPC is not in the range that we
+ * care about */
+ if (frompc - p->lowpc > p->textsize) {
+#if DEBUG >= 2
+ fprintf(stderr, "ignoring FROMPC 0x%lx out of range (SELF=0x%lx)\n",
+ frompc, selfpc);
+#endif
+ p->state = GMON_PROF_ON;
+ return;
+ }
+
+ _mcount(p, frompc, selfpc); // Will reset p->state
+}
+
+void aftermcount(void) {
+ // Define this function only to be able to get a PC that is after mcount
+ return;
+}
+
--- /dev/null
+#!/bin/perl
+
+use strict;
+use File::Basename;
+
+# usage runall.pl filename
+# See below for the environment variables that control the execution
+#
+#
+# The file is expected to contain the code for the tests.
+#
+# The test file is scanned for lines that contain some keywords. In
+# all cases the rest of the line following the keywords must be a test
+# specification, of the form:
+#
+# TestSpec ::= [testname] [: (error|success)[(=|~) "message"]]
+#
+# "testname" is the (optional) name of the test. If it is missing
+# then a fresh new numeric name is made up.
+#
+# If this specification is not the first for the given test name then the rest
+# of the line may be empty. Otherwise there must be at least [: error] or [:
+# success], to say whether this test should fail or should succeed.
+#
+# Both for success and for failure you can define some text that must appear
+# in the output of the test (with the = specifier), or a Perl regexp that must
+# appear in the output (with the ~ specifier).
+
+#
+# In a first pass, the file is scanned to collect a list of tests.
+# If there are no tests defined in the file, then we assume a default line
+# TESTDEF default : success
+# This actually means that
+#
+# Then for each test we process the file and we comment out some lines based
+# on the keywords that appear in the file:
+#
+# TESTDEF TestSpec - defines a test, must appear alone on a line
+# DROP TestSpec - this line is dropped ONLY during that test
+# KEEP TestSpec - this line is kept ONLY during that test
+# IFTEST TestSpec - keeps a whole bunch of lines ONLY for this test.
+# IFTEST, ELSE and ENDIF must appear alone on a line
+# ...
+# [ ELSE
+# ...
+# ENDIF ]
+#
+# IFNTEST ... - same syntax as IFTEST.
+#
+# The lines containing TESTDEF, IFTEST, ELSE, ENDIF will always
+# be commented. The DROP and the KEEP keywords must appear after a comment
+# character.
+#
+#
+# EXAMPLES
+#
+# ======== foo1.c ======
+# int main() { return 0; }
+#
+# ==
+# Only one test, called "default" will be executed and expected to
+# succeed
+#
+# ======= foo2.c ======
+# int main() {
+# return 1; // KEEP : error
+# return 0; // KEEP : success
+# }
+#
+# ==
+# Two tests are executed, one with each version of the return. The test
+# that contains "return 1" is expected to fail, while the other is
+# expected to succeed
+#
+
+#
+# The result of processing the file for each test is obtained from the
+# directory and base names of the file along with "-tmp" followed by the
+# original extension. Thus, for "foo/test.s" we get "foo/test-tmp.s".
+#
+# If the environment variable RUNONLY is set to tst, then only the test named
+# tst is run.
+#
+# If the environment variable KEEPGOING is set, then we continue after
+# errors.
+#
+# If the environment variable COMMENT is set, then this string is used to
+# comment out a line. Otherwise, the lines that must be dropped are not
+# printed.
+#
+# If the environment variable KEEP is set, then we do not delete the
+# files that are generated.
+#
+# The COMMAND variable must contain the command to run for each test. The
+# following substitutions are done:
+# __FILE__ with the name of the transformed file
+# __BASENAME__ with the basename (no directory, no extension)
+# __EXT__ with the extension
+# __DIR__ with the directory
+#
+# If none of the above substitutions can be performed, then the
+# name of the file is appended to the command.
+#
+#
+
+my %testnames;
+
+my ($base, $dir, $ext) = fileparse($ARGV[0], qr{\.[^.]+});
+
+my $outbasename = "$base-tmp";
+my $outext = $ext;
+my $outdir = $dir;
+my $outfile = "$dir$base-tmp$ext";
+
+my $action = 'COLLECT';
+
+my $countFreshName;
+
+my $hadErrors = 0;
+
+my $debug = 1;
+
+# Collect the test cases
+&scanTestFile("");
+
+$action = 'PROCESS';
+
+my $countTests = 0;
+
+if(defined $ENV{'RUNONLY'}) {
+ if(! defined $testnames{$ENV{'RUNONLY'}}) {
+ die "Test $ENV{'RUNONLY'} does not exist";
+ }
+ &runOneTest($ENV{'RUNONLY'});
+} else {
+ # Now run over all tests
+ foreach my $t (sort (keys %testnames)) {
+ &runOneTest($t);
+ }
+}
+if(not defined $ENV{'KEEP'}) {
+ unlink $outfile;
+}
+if($hadErrors) {
+ print "There were errors!\n";
+ exit 1;
+} else {
+ print "All $countTests tests were successful!\n";
+ exit 0;
+}
+1;
+
+
+##############################
+
+sub parseTestDef {
+ my ($text, $line) = @_;
+ my ($name, $success, $msg, $msgpattern);
+
+ # All the way to : is the name of the test
+ if($text !~ m|^([^:]+):(.*)$|) {
+ # There is no :. All of it is the name of the test. Trim spaces
+ ($name) = ($text =~ m|^\s*(\S.*)$|);
+ ($name) = ($name =~ m|^(.*\S)\s*$|);
+ if($name eq "") {
+ die "Test definition with no name and no : error or : success";
+ }
+ if(! defined $testnames{$name}) {
+ die "Unknown test";
+ }
+ return $name;
+ } else {
+ # We have a : This is a test definition
+ my $rest = $2;
+ ($name) = ($1 =~ m|^\s*(\S.*)$|);
+ ($name) = ($name =~ m|^(.*\S)\s*$|);
+ if($name eq "") {
+ $name = $countFreshName ++;
+ }
+ # See if this is success
+ if($rest !~ m|^\s*(error\|success)(.*)$|) {
+ die "After success or error there must be =\n";
+ }
+ $success = ($1 eq "success") ? 1 : 0;
+ $rest = $2;
+
+ # See if there is a message. Must be at least two chars long
+ if($rest =~ m|^\s*(=\|~)\s*(\S.*\S)\s*$|) {
+ $msg = $2;
+ $msgpattern = ($1 eq "~");
+ } else {
+ if($rest =~ m|^\s*$|) {
+ $msg = "";
+ $msgpattern = 0;
+ } else {
+ die ("After " . ($success ? "\"success\"" : "\"error\"") .
+ " there must be nothing of = ...");
+ }
+ }
+
+
+ # We have found a test
+ if($action eq 'COLLECT') {
+ if(defined $testnames{$name} &&
+ $testnames{$name}->{SUCCESS} != $success) {
+ die "Test $name is defined both success and error";
+ }
+ if(defined $testnames{$name} &&
+ $testnames{$name}->{'MSG'} ne "" &&
+ $msg ne "") {
+ warn "Ignoring duplicate message for $name: $msg";
+ } else {
+ print "Found test $name with msg:$msg\n";
+ $testnames{$name} = { SUCCESS => $success,
+ LINE => $line,
+ MSG => $msg,
+ MSGPATTERN => $msgpattern };
+ }
+ }
+ return $name;
+ }
+}
+
+# Populate the test data
+sub scanTestFile {
+ my($current) = @_;
+
+ $countFreshName = 0;
+ open(IN, "<$ARGV[0]") || die "Cannot open file $ARGV[0]";
+
+ # We keep track of the IF scopes we are in. We keep a stack of scopes,
+ # starting with the global scope. For each scope on the stack we keep a
+ # boolean, saying whether the scope is positive or negative.
+ my @ifenv = (1); # We enclose everything in a positive global scope
+
+ # This variable is the && of all entries in ifenv
+ my $keep = 1;
+
+ my $COMMENT = "//";
+ if (defined $ENV{'COMMENT'}) {
+ $COMMENT = $ENV{'COMMENT'};
+ }
+ my $line = 0;
+ while(<IN>) {
+ $line ++;
+ my $name;
+
+ my $comment = 0;
+
+ my $linename = "";
+
+ # Look first at the test descriptions
+ # Set $comment if we want to comment this line
+ if($_ =~ m|^\s*TESTDEF(.*)$|) {
+ $name = &parseTestDef($1, $line);
+ $comment = 1;
+
+ } elsif($_ =~ m|$COMMENT\s*DROP(.*)$|) {
+ $name = &parseTestDef($1, $line);
+ if($name eq $current) { $comment = 1; }
+ $linename = "DROP($name)";
+
+ } elsif($_ =~ m|$COMMENT\s*KEEP(.*)$|) {
+ $name = &parseTestDef($1, $line);
+ if($name ne $current) { $comment = 1; }
+ $linename = "KEEP($name)";
+
+ } elsif($_ =~ m|^\s*IFTEST(.*)$|) {
+ $name = &parseTestDef($1, $line);
+ $linename = "IFTEST($name)";
+ # Push on the stack
+ unshift @ifenv, ($name eq $current ? 1 : 0);
+ $keep = &allTrue(@ifenv);
+ $comment = 1;
+
+ } elsif($_ =~ m|^\s*IFNTEST(.*)$|) {
+ $name = &parseTestDef($1, $line);
+ $linename = "IFNTEST($name)";
+ unshift @ifenv, ($name ne $current ? 1 : 0);
+ $keep = &allTrue(@ifenv);
+ $comment = 1;
+
+ } elsif($_ =~ m|^\s*ELSE\s*$|) {
+ # Stack must have at least 2 elements
+ if($#ifenv < 1) { die "Found ELSE without IF"; }
+ $linename = "ELSE";
+ $ifenv[0] = ($ifenv[0] ? 0 : 1);
+ $keep = &allTrue(@ifenv);
+ $comment = 1;
+
+ } elsif($_ =~ m|^\s*ENDIF\s*$|) {
+ # Stack must have at least 2 elements
+ if($#ifenv < 1) { die "Found ENDIF without IF"; }
+ $linename = "ENDIF";
+ shift @ifenv;
+ $keep = &allTrue(@ifenv);
+ $comment = 1;
+ }
+
+ # We are done if collecting
+ if($action ne 'PROCESS') { next; }
+
+ my $keep_this_line = $comment ? 0 : $keep;
+ if($debug && $linename ne "") {
+ if($linename =~ m|^KEEP| ||
+ $linename =~ m|^DROP|) {
+ print "$line: $linename: keep=", ($comment ? 0 : 1), "\n";
+ } else {
+ print "$line: $linename: keep=$keep, env = ", join(',', @ifenv), "\n";
+ }
+ }
+ if($comment || ! $keep) {
+ if(defined $ENV{'COMMENT'}) {
+ print OUT $ENV{'COMMENT'};
+ print OUT " ";
+ print OUT $_;
+ } else {
+ print OUT "\n";
+ }
+ } else {
+ print OUT $_;
+ }
+ }
+
+ if(0 == keys %testnames) {
+ print "There are no tests defined in the file. Assume a success test\n";
+ &parseTestDef("default : success", -1);
+
+ }
+}
+
+sub allTrue {
+ my $res = 1;
+ while(@_) {
+ if(! (shift @_)) {
+ $res = 0;
+ }
+ }
+ return $res;
+}
+
+
+sub runOneTest {
+ my($t) = @_;
+ my $ti = $testnames{$t};
+
+ $countTests ++;
+
+ print "\n********* $base: Running test $t from line $ti->{LINE}\n";
+ if($debug) {
+ print "Test $t:\n\tSUCCESS => $ti->{SUCCESS}\n\tLINE => $ti->{LINE}\n\tMSG => $ti->{MSG},\n\tMSGPATTERN => $ti->{MSGPATTERN}\n";
+ }
+ open(OUT, ">$outfile\n")
+ || die "Cannot write $outfile";
+ &scanTestFile($t);
+ close(OUT) || die "Cannot close file $outfile";
+ # Now we run the command
+ if(! defined $ENV{COMMAND}) {
+ die "You forgot to set the COMMAND";
+ }
+ my $command = $ENV{COMMAND};
+ # Substitute __FILE__ with the current file
+ if($command =~ m|__FILE__|) {
+ $command =~ s|__FILE__|$outfile|g;
+ }
+ if($command =~ m|__DIR__|) {
+ $command =~ s|__DIR__|$outdir|g;
+ }
+ if($command =~ m|__BASENAME__|) {
+ $command =~ s|__BASENAME__|$outbasename|g;
+ }
+ if($command =~ m|__EXT__|) {
+ $command =~ s|__EXT__|$outext|g;
+ }
+ if($command eq $ENV{COMMAND}) {
+ $command .= " $outfile";
+ }
+ print "$command\n";
+ my $msgfile = "runall_out";
+ my $code = system("($command) >$msgfile 2>&1");
+ open(MSG, "<$msgfile") || die "Cannot read $msgfile";
+ my @msgs = <MSG>;
+ close(MSG) || die "Cannot close $msgfile";
+ print @msgs;
+ unlink $msgfile;
+ if($debug) {
+ print "Test $t returned with code $code. Expected ",
+ ($ti->{SUCCESS} ? "success" : "failure", "\n");
+ }
+
+ if(($code == 0) != $ti->{SUCCESS}) {
+ if($code == 0) {
+ warn "Test case $t (line $ti->{LINE}) succeeds and it is supposed to fail";
+ } else {
+ warn "Test case $t (line $ti->{LINE}) fails and it is supposed to succeed";
+ }
+ $hadErrors = 1;
+ if(! defined($ENV{KEEPGOING})) {
+ die "";
+ }
+ } else {
+ # Now we check the output for the message
+ if($ti->{MSG} ne "") {
+ # See if the message occurs
+ my $found = 0;
+ foreach my $l (@msgs) {
+ # print "Checking: $l";
+ if($ti->{MSGPATTERN}) {
+ $found = ($l =~ m%$ti->{MSG}%);
+ } else {
+ $found = (0 <= index($l, $ti->{MSG}));
+ }
+ if($found) { last; }
+ }
+ if(! $found) {
+ warn "Cannot " . ($ti->{MSGPATTERN} ? 'match' : 'find') .
+ " \"$ti->{MSG}\" in output of test $t";
+ if(! defined($ENV{KEEPGOING})) {
+ die "";
+ }
+ }
+ } else {
+ print "Test $t (line $ti->{LINE}) was successful\n";
+ unlink $msgfile;
+ }
+ }
+}
+
+1;
+
+
--- /dev/null
+(* The following functions are implemented in perfcount.c *)
+
+(* Returns true if we have the performance counters *)
+external has_performance_counters: unit -> bool = "has_performance_counters"
+
+(* Initializes the CPU speed and returns true if we have
+ the performance counters *)
+external reset_performance_counters: unit -> bool = "reset_performance_counters"
+
+(* Returns number of seconds since the first read *)
+external read_pentium_perfcount : unit -> float = "read_pentium_perfcount"
+
+(* Returns current cycle counter, divided by 1^20, and truncated to 30 bits *)
+external sample_pentium_perfcount_20 : unit -> int = "sample_pentium_perfcount_20"
+
+(* Returns current cycle counter, divided by 1^10, and truncated to 30 bits *)
+external sample_pentium_perfcount_10 : unit -> int = "sample_pentium_perfcount_10"
+
+
+(** Whether to use the performance counters (on Pentium only) *)
+type timerModeEnum =
+ | Disabled (** Do not collect timing information *)
+ | SoftwareTimer (** Use OCaml's [Unix.time] for timing information *)
+ | HardwareTimer (** Use the Pentium's cycle counter to time code *)
+ | HardwareIfAvail (** Use the hardware cycle counter if availible;
+ otherwise use SoftwareTimer *)
+
+(* The performance counters are disabled by default.
+ This will always be one of Disabled | SoftwareTimer | HardwareTimer.
+ HardwareIfAvail is handled in reset. *)
+let timerMode = ref Disabled
+
+(* Flag for counting number of calls *)
+let countCalls = ref false
+
+ (* A hierarchy of timings *)
+
+type t = { name : string;
+ mutable time : float; (* In seconds *)
+ mutable ncalls : int;
+ mutable sub : t list}
+
+ (* Create the top level *)
+let top = { name = "TOTAL";
+ time = 0.0;
+ ncalls = 0;
+ sub = []; }
+
+ (* 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 =
+ top.sub <- [];
+ match mode with
+ Disabled
+ | SoftwareTimer -> timerMode := mode
+ | HardwareTimer ->
+ if not (reset_performance_counters ()) then begin
+ timerMode := SoftwareTimer;
+ raise NoPerfCount
+ end;
+ timerMode := mode
+ | HardwareIfAvail ->
+ if (reset_performance_counters ()) then
+ timerMode := HardwareTimer
+ else
+ timerMode := SoftwareTimer
+
+
+
+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 =
+ begin
+ if !timerMode = HardwareTimer then
+ (Printf.fprintf chn "%s%-25s %8.5f s"
+ (String.make ind ' ') node.name node.time)
+ else
+ (Printf.fprintf chn "%s%-25s %6.3f s"
+ (String.make ind ' ') node.name node.time)
+ end;
+ begin
+ if node.ncalls <= 0 then
+ output_string chn "\n"
+ else if node.ncalls = 1 then
+ output_string chn " (1 call)\n"
+ else
+ (Printf.fprintf chn " (%d calls)\n" node.ncalls)
+ end;
+ List.iter (prTree (ind + 2)) (List.rev node.sub)
+ in
+ Printf.fprintf chn "%s" msg;
+ List.iter (prTree 0) [ top ];
+ Printf.fprintf chn "Timing used %s\n"
+ (if !timerMode = HardwareTimer then "Pentium performance counters"
+ else "Unix.time");
+ let gc = Gc.quick_stat () in
+ let printM (w: float) : string =
+ Printf.sprintf "%.2fMb" (w *. 4.0 /. 1000000.0)
+ in
+ 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
+ -. gc.Gc.promoted_words))
+ (printM (float_of_int gc.Gc.top_heap_words))
+ (printM gc.Gc.minor_words)
+ (printM gc.Gc.major_words)
+ (printM gc.Gc.promoted_words)
+ gc.Gc.minor_collections
+ gc.Gc.major_collections
+ gc.Gc.compactions;
+
+ ()
+
+
+
+(* Get the current time, in seconds *)
+let get_current_time () : float =
+ if !timerMode = HardwareTimer then
+ read_pentium_perfcount ()
+ else
+ (Unix.times ()).Unix.tms_utime
+
+let repeattime limit str f arg =
+ (* Find the right stat *)
+ 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
+ in
+ loop curr.sub
+ in
+ let oldcurrent = !current in
+ current := stat :: oldcurrent;
+ let start = get_current_time () in
+ let rec repeatf count =
+ let finish diff =
+ (* count each call to repeattime once *)
+ if !countCalls then stat.ncalls <- stat.ncalls + 1;
+ stat.time <- stat.time +. (diff /. float(count));
+ current := oldcurrent; (* Pop the current stat *)
+ ()
+ in
+ let res =
+ try f arg
+ with e ->
+ let diff = get_current_time () -. start in
+ finish diff;
+ raise e
+ in
+ let diff = get_current_time () -. start in
+ if diff < limit then
+ repeatf (count + 1)
+ else begin
+ finish diff;
+ res (* Return the function result *)
+ end
+ in
+ repeatf 1
+
+
+let time str f arg =
+ if !timerMode = Disabled then
+ f arg
+ else
+ repeattime 0.0 str f arg
+
+
+let lastTime = ref 0.0
+let timethis (f: 'a -> 'b) (arg: 'a) : 'b =
+ let start = get_current_time () in
+ 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
+ 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 =
+ if x.name = label then time := !time +. x.time;
+ List.iter search x.sub
+ in
+ search top;
+ !time
+
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001 by
+ * George C. Necula necula@cs.berkeley.edu
+ * Scott McPeak smcpeak@cs.berkeley.edu
+ * Wes Weimer weimer@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.
+ *
+ *)
+
+(** Utilities for maintaining timing statistics *)
+
+(** Whether to use the performance counters (on Pentium only) *)
+type timerModeEnum =
+ | Disabled (** Do not collect timing information *)
+ | SoftwareTimer (** Use OCaml's [Unix.time] for timing information *)
+ | HardwareTimer (** Use the Pentium's cycle counter to time code *)
+ | HardwareIfAvail (** Use the hardware cycle counter if availible;
+ otherwise use SoftwareTimer *)
+
+(** Resets all the timings and specifies the method to use for future timings.
+ * Call this before doing any timing.
+
+ * You will get an exception if you pass HardwareTimer to reset and the
+ * hardware counters are not available *)
+val reset: timerModeEnum -> unit
+exception NoPerfCount
+
+(** Flag to indicate whether or not to count the number of calls of
+ to {!Stats.repeattime} or {!Stats.time} for each label.
+ (default: false) *)
+val countCalls: bool ref
+
+(** Check if we have performance counters *)
+val has_performance_counters: unit -> bool
+
+(** Sample the current cycle count, in megacycles. *)
+val sample_pentium_perfcount_20: unit -> int
+
+(** Sample the current cycle count, in kilocycles. *)
+val sample_pentium_perfcount_10: unit -> int
+
+(** Time a function and associate the time with the given string. If some
+ timing information is already associated with that string, then accumulate
+ the times. If this function is invoked within another timed function then
+ you can have a hierarchy of timings *)
+val time : string -> ('a -> 'b) -> 'a -> 'b
+
+(** repeattime is like time but runs the function several times until the total
+ running time is greater or equal to the first argument. The total time is
+ then divided by the number of times the function was run. *)
+val repeattime : float -> string -> ('a -> 'b) -> 'a -> 'b
+
+(** Print the current stats preceeded by a message *)
+val print : out_channel -> string -> unit
+
+(** Return the cumulative time of all calls to {!Stats.time} and
+ {!Stats.repeattime} with the given label. *)
+val lookupTime: string -> float
+
+
+(** Time a function and set lastTime to the time it took *)
+val timethis: ('a -> 'b) -> 'a -> 'b
+val lastTime: float ref
+
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+
+use Getopt::Long 2.17;
+
+my $debug = 0;
+my $file = "";
+
+sub pdebug {
+ if($debug) { print STDERR @_; }
+}
+
+sub objdump {
+ my ($cmd) = @_;
+ my $base = "objdump $file --section=.text";
+ &pdebug("Running: $base $cmd\n");
+ open(IN, "$base $cmd |")
+ || die "Cannot run $base $cmd";
+ my @lines = <IN>;
+ close(IN);
+ return @lines;
+}
+
+sub hextodec {
+ my($h) = @_;
+ my $v = 0;
+ my $l = length($h);
+ for(my $i=0;$i<$l;$i++) {
+ my $c = substr($h, $i, 1);
+ my $cval;
+ if(ord($c) >= ord('0') && ord($c) <= ord('9')) {
+ $cval = $c - '0';
+ } elsif(ord($c) >= ord('a') && ord($c) <= ord('f')) {
+ $cval = 10 + (ord($c) - ord('a'));
+ } elsif($c >= 'A' && $c <= 'F') {
+ $cval = 10 + ($c - 'A');
+ } else {
+ die "Invalid character $c in hex string $h";
+ }
+ $v = $v * 16 + $cval;
+ }
+ return $v;
+}
+
+sub dectohex {
+ my($d) = @_;
+ my $r = "";
+ if($d == 0) { return "0x0"; }
+ while($d > 0) {
+ my $q = int($d / 16);
+ my $rem = $d - 16 * $q;
+ if($rem <= 9) {
+ $r = $rem . $r;
+ } else {
+ $r = chr(ord('a') + $rem - 10) . $r;
+ }
+ $d = $q;
+ }
+ return "0x$r";
+}
+
+my $textvma;
+my $text_section_idx;
+my $fileformat;
+
+sub parseTextSymbol {
+ my ($l) = @_;
+ my $name;
+ my $vma;
+ if($fileformat eq "pei-i386" && $l =~ m|.*\s+0x(\S+)\s+(\S+)$|) {
+ $name = $2;
+ $vma = $textvma + &hextodec($1);
+ } elsif($fileformat eq "elf32-i386" &&
+ $l =~ m|^\s*(\S*)\s.*\s\.text\s+\S+\s+(\S+)$|) {
+ $name = $2;
+ $vma = &hextodec($1);
+ }
+ &pdebug("parseTextSymbol:$l name=$name, vma=".&dectohex($vma)."\n");
+ return ($name, $vma);
+}
+
+my %options =
+ ("debug!" => \$debug,
+ "file=s" => \$file,
+ );
+
+
+&GetOptions(%options);
+
+# Get the file type
+foreach my $l (&objdump("-f | grep 'file format'")) {
+ if($l =~ m|.*\s(\S+)\s*$|) {
+ $fileformat = $1;
+ }
+}
+if(! defined($fileformat)) {
+ die "Cannot find the file format";
+}
+&pdebug("File format is $fileformat\n");
+
+# Get the parameters of the .text section
+my $textoffset;
+foreach my $l (&objdump("-h | grep .text")) {
+ my @line = split(/\s+/, $l);
+ while($line[0] eq '') {
+ shift @line;
+ }
+ &pdebug("Parsing .text info: line=", join(':', @line), "\n");
+ if($fileformat eq "pei-i386" && $line[1] eq ".text") {
+ $text_section_idx = 1 + $line[0];
+ $textoffset = &hextodec($line[5]);
+ $textvma = &hextodec($line[3]);
+ last;
+ } elsif($fileformat eq "elf32-i386" && $line[1] eq ".text") {
+ $text_section_idx = 0;
+ $textoffset = &hextodec($line[5]);
+ $textvma = &hextodec($line[3]);
+ last;
+ } else {
+ die "Found unexpected output for -h: $l";
+ }
+}
+
+&pdebug(".text section is at index $text_section_idx, offset $textoffset (" . &dectohex($textoffset) .
+ ") and VMA=$textvma (" . &dectohex($textvma) . ")\n");
+
+# Now load all the symbols
+my %symbols = (); # Indexed by their name
+
+# Construct here the grep expression for the diffent architectures
+my $grep;
+if($fileformat eq "pei-i386") {
+ $grep = "sec $text_section_idx";
+} elsif($fileformat eq "elf32-i386") {
+ $grep = '\.text';
+} else {
+ die "";
+}
+my @lines = &objdump("--syms | grep \"$grep\"");
+# Get the one we care about
+foreach my $l (@lines) {
+ my ($name, $vma) = &parseTextSymbol($l);
+ if(defined $name) {
+ # Insert it into the array of symbols
+ $symbols{$name} = $vma;
+ }
+}
+
+# Now sort the symbols by the VMA
+my @symbolnames = sort { $symbols{$a} <=> $symbols{$b} } (keys %symbols);
+
+# For each function that we got as argument produce its range of VMA
+my %functions = ();
+foreach my $f (@ARGV) { $functions{$f} = ""; }
+
+for(my $i=0;$i<@symbolnames;$i++) {
+ &pdebug("Found symbol $symbolnames[$i] at ".
+ &dectohex($symbols{$symbolnames[$i]})."\n");
+ # See if the symbolname matches the start of a function that we must print
+ foreach my $f (@ARGV) {
+ if($symbolnames[$i]=~ m|^$f|) {
+ $functions{$f} = $symbolnames[$i] . "," . $functions{$f};
+ print STDERR "Found symbol $symbolnames[$i]\n";
+
+ # A function we care about
+ my $start = $symbols{$symbolnames[$i]};
+ my $end;
+ if($i + 1 < @symbolnames) {
+ $end = $symbols{$symbolnames[$i + 1]}
+ } else {
+ die "Not implemented: the last function";
+ }
+ $functions{$symbolnames[$i]} = 1;
+ print $start, "-", $end, " ";
+ }
+ }
+}
+
+foreach my $f (keys %functions) {
+ if($functions{$f} eq '') {
+ warn "Warning: Could not find the range for function $f\n";
+ }
+}
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(* Trace module implementation
+ * see trace.mli
+ *)
+
+open Pretty;;
+
+
+(* --------- traceSubsystems --------- *)
+(* this is the list of tags (usually subsystem names) for which
+ * trace output will appear *)
+let traceSubsystems : string list ref = ref [];;
+
+
+let traceAddSys (subsys : string) : unit =
+ (* (ignore (printf "traceAddSys %s\n" subsys)); *)
+ traceSubsystems := subsys :: !traceSubsystems
+;;
+
+
+let traceActive (subsys : string) : bool =
+ (* (List.mem elt list) returns true if something in list equals ('=') elt *)
+ (List.mem subsys !traceSubsystems)
+;;
+
+
+let rec parseString (str : string) (delim : char) : string list =
+begin
+ if (not (String.contains str delim)) then
+ if ((String.length str) = 0) then
+ []
+ else
+ [str]
+
+ else
+ let d = ((String.index str delim) + 1) in
+ if (d = 1) then
+ (* leading delims are eaten *)
+ (parseString (String.sub str d ((String.length str) - d)) delim)
+ else
+ (String.sub str 0 (d-1)) ::
+ (parseString (String.sub str d ((String.length str) - d)) delim)
+end;;
+
+let traceAddMulti (systems : string) : unit =
+begin
+ let syslist = (parseString systems ',') in
+ (List.iter traceAddSys syslist)
+end;;
+
+
+
+(* --------- traceIndent --------- *)
+let traceIndentLevel : int ref = ref 0;;
+
+
+let traceIndent (sys : string) : unit =
+ if (traceActive sys) then
+ traceIndentLevel := !traceIndentLevel + 2
+;;
+
+let traceOutdent (sys : string) : unit =
+ if ((traceActive sys) &&
+ (!traceIndentLevel >= 2)) then
+ traceIndentLevel := !traceIndentLevel - 2
+;;
+
+
+(* --------- trace --------- *)
+(* return a tag to prepend to a trace output
+ * e.g. " %%% mysys: "
+ *)
+let traceTag (sys : string) : Pretty.doc =
+ (* return string of 'i' spaces *)
+ let rec ind (i : int) : string =
+ if (i <= 0) then
+ ""
+ else
+ " " ^ (ind (i-1))
+
+ in
+ (text ((ind !traceIndentLevel) ^ "%%% " ^ sys ^ ": "))
+;;
+
+
+(* this is the trace function; its first argument is a string
+ * tag, and subsequent arguments are like printf formatting
+ * strings ("%a" and whatnot) *)
+let trace
+ (subsys : string) (* subsystem identifier for enabling tracing *)
+ (d : Pretty.doc) (* something made by 'dprintf' *)
+ : unit = (* no return value *)
+ (* (ignore (printf "trace %s\n" subsys)); *)
+
+ (* see if the subsystem's tracing is turned on *)
+ if (traceActive subsys) then
+ begin
+ (fprint stderr 80 (* print it *)
+ ((traceTag subsys) ++ d)); (* with prepended subsys tag *)
+ (* mb: flush after every message; useful if the program hangs in an
+ infinite loop... *)
+ (flush stderr)
+ end
+ else
+ () (* eat it *)
+;;
+
+
+let tracei (sys : string) (d : Pretty.doc) : unit =
+ (* trace before indent *)
+ (trace sys d);
+ (traceIndent sys)
+;;
+
+let traceu (sys : string) (d : Pretty.doc) : unit =
+ (* trace after outdent *)
+ (* no -- I changed my mind -- I want trace *then* outdent *)
+ (trace sys d);
+ (traceOutdent sys)
+;;
+
+
+
+
+(* -------------------------- trash --------------------- *)
+(* TRASH START
+
+(* sm: more experimenting *)
+(trace "no" (dprintf "no %d\n" 5));
+(trace "yes" (dprintf "yes %d\n" 6));
+(trace "maybe" (dprintf "maybe %d\n" 7));
+
+TRASH END *)
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(* Trace module
+ * Scott McPeak, 5/4/00
+ *
+ * The idea is to pepper the source with debugging printfs,
+ * and be able to select which ones to actually display at
+ * runtime.
+ *
+ * It is built on top of the Pretty module for printing data
+ * structures.
+ *
+ * To a first approximation, this is needed to compensate for
+ * the lack of a debugger that does what I want...
+ *)
+
+
+(* this is the list of tags (usually subsystem names) for which
+ * trace output will appear *)
+val traceSubsystems : string list ref
+
+(* interface to add a new subsystem to trace (slightly more
+ * convenient than direclty changing 'tracingSubsystems') *)
+val traceAddSys : string -> unit
+
+(* query whether a particular subsystem is being traced *)
+val traceActive : string -> bool
+
+(* add several systems, separated by commas *)
+val traceAddMulti : string -> unit
+
+
+(* current indentation level for tracing *)
+val traceIndentLevel : int ref
+
+(* bump up or down the indentation level, if the given subsys
+ * is being traced *)
+val traceIndent : string -> unit
+val traceOutdent : string -> unit
+
+
+(* this is the trace function; its first argument is a string
+ * tag, and second argument is a 'doc' (which is what 'dprintf'
+ * returns).
+ *
+ * so a sample usage might be
+ * (trace "mysubsys" (dprintf "something neat happened %d times\n" counter))
+ *)
+val trace : string -> Pretty.doc -> unit
+
+
+(* special flavors that indent/outdent as well. the indent version
+ * indents *after* printing, while the outdent version outdents
+ * *before* printing. thus, a sequence like
+ *
+ * (tracei "foo" (dprintf "beginning razzle-dazzle\n"))
+ * ..razzle..
+ * ..dazzle..
+ * (traceu "foo" (dprintf "done with razzle-dazzle\n"))
+ *
+ * will do the right thing
+ *
+ * update -- I changed my mind! I decided I prefer it like this
+ * %%% sys: (myfunc args)
+ * %%% ...inner stuff...
+ * %%% sys: myfunc returning 56
+ *
+ * so now they both print before in/outdenting
+ *)
+val tracei : string -> Pretty.doc -> unit
+val traceu : string -> Pretty.doc -> unit
--- /dev/null
+(** Utility functions for Coolaid *)
+module E = Errormsg
+module H = Hashtbl
+module IH = Inthash
+
+open Pretty
+
+exception GotSignal of int
+
+let withTimeout (secs: float) (* Seconds for timeout *)
+ (handler: int -> 'b) (* What to do if we have a timeout. The
+ * argument passed is the signal number
+ * received. *)
+ (f: 'a -> 'b) (* The function to run *)
+ (arg: 'a) (* And its argument *)
+ : 'b =
+ let oldHandler =
+ Sys.signal Sys.sigalrm
+ (Sys.Signal_handle
+ (fun i ->
+ ignore (E.log "Got signal %d\n" i);
+ raise (GotSignal i)))
+ in
+ let reset_sigalrm () =
+ ignore (Unix.setitimer Unix.ITIMER_REAL { Unix.it_value = 0.0;
+ Unix.it_interval = 0.0;});
+ Sys.set_signal Sys.sigalrm oldHandler;
+ in
+ ignore (Unix.setitimer Unix.ITIMER_REAL
+ { Unix.it_value = secs;
+ Unix.it_interval = 0.0;});
+ (* ignore (Unix.alarm 2); *)
+ try
+ let res = f arg in
+ reset_sigalrm ();
+ res
+ with exc -> begin
+ reset_sigalrm ();
+ ignore (E.log "Got an exception\n");
+ match exc with
+ GotSignal i ->
+ handler i
+ | _ -> raise exc
+ end
+
+(** Print a hash table *)
+let docHash ?(sep=chr ',') (one: 'a -> 'b -> doc) () (h: ('a, 'b) H.t) =
+ (H.fold
+ (fun key data acc ->
+ if acc == align then acc ++ one key data
+ else acc ++ sep ++ one key data)
+ h
+ align) ++ unalign
+
+
+
+let hash_to_list (h: ('a, 'b) H.t) : ('a * 'b) list =
+ H.fold
+ (fun key data acc -> (key, data) :: acc)
+ h
+ []
+
+let keys (h: ('a, 'b) H.t) : 'a list =
+ H.fold
+ (fun key data acc -> key :: acc)
+ h
+ []
+
+let hash_copy_into (hfrom: ('a, 'b) H.t) (hto: ('a, 'b) H.t) : unit =
+ H.clear hto;
+ H.iter (H.add hto) hfrom
+
+let anticompare a b = compare b a
+;;
+
+
+let rec list_drop (n : int) (xs : 'a list) : 'a list =
+ if n < 0 then invalid_arg "Util.list_drop";
+ if n = 0 then
+ xs
+ else begin
+ match xs with
+ | [] -> invalid_arg "Util.list_drop"
+ | y::ys -> list_drop (n-1) ys
+ end
+
+let list_droptail (n : int) (xs : 'a list) : 'a list =
+ if n < 0 then invalid_arg "Util.list_droptail";
+ let (ndrop,r) =
+ List.fold_right
+ (fun x (ndrop,acc) ->
+ if ndrop = 0 then (ndrop, x :: acc)
+ else (ndrop-1, acc))
+ xs
+ (n,[])
+ in
+ if ndrop > 0 then invalid_arg "Util.listdroptail"
+ else r
+
+let rec list_span (p : 'a -> bool) (xs : 'a list) : 'a list * 'a list =
+ begin match xs with
+ | [] -> ([],[])
+ | x::xs' ->
+ if p x then
+ let (ys,zs) = list_span p xs' in (x::ys,zs)
+ else ([],xs)
+ end
+;;
+
+let rec list_rev_append revxs ys =
+ begin match revxs with
+ | [] -> ys
+ | x::xs -> list_rev_append xs (x::ys)
+ end
+;;
+let list_insert_by (cmp : 'a -> 'a -> int)
+ (x : 'a) (xs : 'a list) : 'a list =
+ let rec helper revhs ts =
+ begin match ts with
+ | [] -> List.rev (x::revhs)
+ | t::ts' ->
+ if cmp x t >= 0 then helper (t::revhs) ts'
+ else list_rev_append (x::revhs) ts
+ end
+ in
+ helper [] xs
+;;
+
+let list_head_default (d : 'a) (xs : 'a list) : 'a =
+ begin match xs with
+ | [] -> d
+ | x::_ -> x
+ end
+;;
+
+let rec list_iter3 f xs ys zs =
+ begin match xs, ys, zs with
+ | [], [], [] -> ()
+ | x::xs, y::ys, z::zs -> f x y z; list_iter3 f xs ys zs
+ | _ -> invalid_arg "Util.list_iter3"
+ end
+;;
+
+let rec get_some_option_list (xs : 'a option list) : 'a list =
+ begin match xs with
+ | [] -> []
+ | None::xs -> get_some_option_list xs
+ | Some x::xs -> x :: get_some_option_list xs
+ end
+;;
+
+(* tail-recursive append: reverses xs twice *)
+let list_append (xs: 'a list) (ys: 'a list): 'a list =
+ match xs with (* optimize some common cases *)
+ [] -> ys
+ | [x] -> x::ys
+ | _ -> list_rev_append (List.rev xs) ys
+
+let list_iteri (f: int -> 'a -> unit) (l: 'a list) : unit =
+ let rec loop (i: int) (l: 'a list) : unit =
+ match l with
+ [] -> ()
+ | h :: t -> f i h; loop (i + 1) t
+ in
+ loop 0 l
+
+let list_mapi (f: int -> 'a -> 'b) (l: 'a list) : 'b list =
+ let rec loop (i: int) (l: 'a list) : 'b list =
+ match l with
+ [] -> []
+ | h :: t ->
+ let headres = f i h in
+ headres :: loop (i + 1) t
+ in
+ loop 0 l
+
+let list_fold_lefti (f: 'acc -> int -> 'a -> 'acc) (start: 'acc)
+ (l: 'a list) : 'acc =
+ let rec loop (i, acc) l =
+ match l with
+ [] -> acc
+ | h :: t -> loop (i + 1, f acc i h) t
+ in
+ loop (0, start) l
+
+
+let list_init (len : int) (init_fun : int -> 'a) : 'a list =
+ let rec loop n acc =
+ if n < 0 then acc
+ else loop (n-1) ((init_fun n)::acc)
+ in
+ loop (len - 1) []
+;;
+
+
+let rec list_find_first (l: 'a list) (f: 'a -> 'b option) : 'b option =
+ match l with
+ [] -> None
+ | h :: t -> begin
+ match f h with
+ None -> list_find_first t f
+ | r -> r
+ end
+
+(** Generates the range of integers starting with a and ending with b *)
+let int_range_list (a: int) (b: int) =
+ list_init (b - a + 1) (fun i -> a + i)
+
+
+(** Some handling of registers *)
+type 'a growArrayFill =
+ Elem of 'a
+ | Susp of (int -> 'a)
+
+type 'a growArray = {
+ gaFill: 'a growArrayFill;
+ (** Stuff to use to fill in the array as it grows *)
+
+ mutable gaMaxInitIndex: int;
+ (** Maximum index that was written to. -1 if no writes have
+ * been made. *)
+
+ mutable gaData: 'a array;
+ }
+
+let growTheArray (ga: 'a growArray) (len: int)
+ (toidx: int) (why: string) : unit =
+ if toidx >= len then begin
+ (* Grow the array by 50% *)
+ let newlen = toidx + 1 + len / 2 in
+(*
+ ignore (E.log "growing an array to idx=%d (%s)\n" toidx why);
+*)
+ let data' = begin match ga.gaFill with
+ Elem x ->
+
+ let data'' = Array.create newlen x in
+ Array.blit ga.gaData 0 data'' 0 len;
+ data''
+ | Susp f -> Array.init newlen
+ (fun i -> if i < len then ga.gaData.(i) else f i)
+ end
+ in
+ ga.gaData <- data'
+ end
+
+let getReg (ga: 'a growArray) (r: int) : 'a =
+ let len = Array.length ga.gaData in
+ if r >= len then
+ growTheArray ga len r "get";
+
+ ga.gaData.(r)
+
+let setReg (ga: 'a growArray) (r: int) (what: 'a) : unit =
+ let len = Array.length ga.gaData in
+ if r >= len then
+ growTheArray ga len r "set";
+ if r > ga.gaMaxInitIndex then ga.gaMaxInitIndex <- r;
+ ga.gaData.(r) <- what
+
+let newGrowArray (initsz: int) (fill: 'a growArrayFill) : 'a growArray =
+ { gaFill = fill;
+ gaMaxInitIndex = -1;
+ gaData = begin match fill with
+ Elem x -> Array.create initsz x
+ | Susp f -> Array.init initsz f
+ end; }
+
+let copyGrowArray (ga: 'a growArray) : 'a growArray =
+ { ga with gaData = Array.copy ga.gaData }
+
+let deepCopyGrowArray (ga: 'a growArray) (copy: 'a -> 'a): 'a growArray =
+ { ga with gaData = Array.map copy ga.gaData }
+
+
+
+(** Iterate over the initialized elements of the array *)
+let growArray_iteri (f: int -> 'a -> unit) (ga: 'a growArray) =
+ for i = 0 to ga.gaMaxInitIndex do
+ f i ga.gaData.(i)
+ done
+
+
+(** Fold left over the initialized elements of the array *)
+let growArray_foldl (f: 'acc -> 'a -> 'acc)
+ (acc: 'acc) (ga: 'a growArray) : 'acc =
+ let rec loop (acc: 'acc) (idx: int) : 'acc =
+ if idx > ga.gaMaxInitIndex then
+ acc
+ else
+ loop (f acc ga.gaData.(idx)) (idx + 1)
+ in
+ loop acc 0
+
+
+
+
+let hasPrefix (prefix: string) (what: string) : bool =
+ let pl = String.length prefix in
+ try String.sub what 0 pl = prefix
+ with Invalid_argument _ -> false
+
+
+
+let restoreRef ?(deepCopy=(fun x -> x)) (r: 'a ref) : (unit -> unit) =
+ let old = deepCopy !r in
+ (fun () -> r := old)
+
+let restoreHash ?deepCopy (h: ('a, 'b) H.t) : (unit -> unit) =
+ let old =
+ match deepCopy with
+ None -> H.copy h
+ | Some f ->
+ let old = H.create (H.length h) in
+ H.iter (fun k d -> H.add old k (f d)) h;
+ old
+ in
+ (fun () -> hash_copy_into old h)
+
+let restoreIntHash ?deepCopy (h: 'a IH.t) : (unit -> unit) =
+ let old =
+ match deepCopy with
+ None -> IH.copy h
+ | Some f ->
+ let old = IH.create (IH.length h) in
+ IH.iter (fun k d -> IH.add old k (f d)) h;
+ old
+ in
+ (fun () ->
+ IH.clear h;
+ IH.iter (fun i k -> IH.add h i k) old)
+
+let restoreArray ?deepCopy (a: 'a array) : (unit -> unit) =
+ let old = Array.copy a in
+ (match deepCopy with
+ None -> ()
+ | Some f -> Array.iteri (fun i v -> old.(i) <- f v) old);
+ (fun () -> Array.blit old 0 a 0 (Array.length a))
+
+let runThunks (l: (unit -> unit) list) : (unit -> unit) =
+ fun () -> List.iter (fun f -> f ()) l
+
+
+
+(* Memoize *)
+let memoize (h: ('a, 'b) Hashtbl.t)
+ (arg: 'a)
+ (f: 'a -> 'b) : 'b =
+ try
+ Hashtbl.find h arg
+ with Not_found -> begin
+ let res = f arg in
+ Hashtbl.add h arg res;
+ res
+ end
+
+(* Just another name for memoize *)
+let findOrAdd h arg f = memoize h arg f
+
+(* A tryFinally function *)
+let tryFinally
+ (main: 'a -> 'b) (* The function to run *)
+ (final: 'b option -> unit) (* Something to run at the end *)
+ (arg: 'a) : 'b =
+ try
+ let res: 'b = main arg in
+ final (Some res);
+ res
+ with e -> begin
+ final None;
+ raise e
+ end
+
+
+
+
+let valOf : 'a option -> 'a = function
+ None -> raise (Failure "Util.valOf")
+ | Some x -> x
+
+(**
+ * An accumulating for loop.
+ *
+ * Initialize the accumulator with init. The current index and accumulator
+ * from the previous iteration is passed to f.
+ *)
+let fold_for ~(init: 'a) ~(lo: int) ~(hi: int) (f: int -> 'a -> 'a) =
+ let rec forloop i acc =
+ if i > hi then acc
+ else forloop (i+1) (f i acc)
+ in
+ forloop lo init
+
+(************************************************************************)
+
+module type STACK = sig
+ type 'a t
+ (** The type of stacks containing elements of type ['a]. *)
+
+ exception Empty
+ (** Raised when {!Stack.pop} or {!Stack.top} is applied to an empty stack. *)
+
+ val create : unit -> 'a t
+ (** Return a new stack, initially empty. *)
+
+ val push : 'a -> 'a t -> unit
+ (** [push x s] adds the element [x] at the top of stack [s]. *)
+
+ val pop : 'a t -> 'a
+ (** [pop s] removes and returns the topmost element in stack [s],
+ or raises [Empty] if the stack is empty. *)
+
+ val top : 'a t -> 'a
+ (** [top s] returns the topmost element in stack [s],
+ or raises [Empty] if the stack is empty. *)
+
+ val clear : 'a t -> unit
+ (** Discard all elements from a stack. *)
+
+ val copy : 'a t -> 'a t
+ (** Return a copy of the given stack. *)
+
+ val is_empty : 'a t -> bool
+ (** Return [true] if the given stack is empty, [false] otherwise. *)
+
+ val length : 'a t -> int
+ (** Return the number of elements in a stack. *)
+
+ val iter : ('a -> unit) -> 'a t -> unit
+ (** [iter f s] applies [f] in turn to all elements of [s],
+ from the element at the top of the stack to the element at the
+ bottom of the stack. The stack itself is unchanged. *)
+end
+
+module Stack = struct
+
+ type 'a t = { mutable length : int;
+ stack : 'a Stack.t; }
+
+ exception Empty
+
+ let create () = { length = 0;
+ stack = Stack.create(); }
+
+ let push x s =
+ s.length <- s.length + 1;
+ Stack.push x s.stack
+
+ let pop s =
+ s.length <- s.length - 1;
+ Stack.pop s.stack
+
+ let top s =
+ Stack.top s.stack
+
+ let clear s =
+ s.length <- 0;
+ Stack.clear s.stack
+
+ let copy s = { length = s.length;
+ stack = Stack.copy s.stack; }
+
+ let is_empty s =
+ Stack.is_empty s.stack
+
+ let length s = s.length
+
+ let iter f s =
+ Stack.iter f s.stack
+
+end
+
+(************************************************************************)
+
+let absoluteFilename (fname: string) =
+ if Filename.is_relative fname then
+ Filename.concat (Sys.getcwd ()) fname
+ else
+ fname
+
+
+(* mapNoCopy is like map but avoid copying the list if the function does not
+ * change the elements. *)
+let rec mapNoCopy (f: 'a -> 'a) = function
+ [] -> []
+ | (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
+
+let rec mapNoCopyList (f: 'a -> 'a list) = function
+ [] -> []
+ | (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'
+
+
+(* Use a filter function that does not rewrite the list unless necessary *)
+let rec filterNoCopy (f: 'a -> bool) (l: 'a list) : 'a list =
+ match l with
+ [] -> []
+ | h :: rest when not (f h) -> filterNoCopy f rest
+ | h :: rest ->
+ let rest' = filterNoCopy f rest in
+ if rest == rest' then l else h :: rest'
+
+(** Join a list of strings *)
+let rec joinStrings (sep: string) (sl: string list) =
+ match sl with
+ [] -> ""
+ | [s1] -> s1
+ | s1 :: ((_ :: _) as rest) -> s1 ^ sep ^ joinStrings sep rest
+
+
+(************************************************************************
+
+ Configuration
+
+ ************************************************************************)
+(** The configuration data can be of several types **)
+type configData =
+ ConfInt of int
+ | ConfBool of bool
+ | ConfFloat of float
+ | ConfString of string
+ | ConfList of configData list
+
+
+(* Store here window configuration file *)
+let configurationData: (string, configData) H.t = H.create 13
+
+let clearConfiguration () = H.clear configurationData
+
+let setConfiguration (key: string) (c: configData) =
+ H.replace configurationData key c
+
+let findConfiguration (key: string) : configData =
+ H.find configurationData key
+
+let findConfigurationInt (key: string) : int =
+ match findConfiguration key with
+ ConfInt i -> i
+ | _ ->
+ ignore (E.warn "Configuration %s is not an integer" key);
+ raise Not_found
+
+let useConfigurationInt (key: string) (f: int -> unit) =
+ try f (findConfigurationInt key)
+ with Not_found -> ()
+
+let findConfigurationString (key: string) : string =
+ match findConfiguration key with
+ ConfString s -> s
+ | _ ->
+ ignore (E.warn "Configuration %s is not a string" key);
+ raise Not_found
+
+let useConfigurationString (key: string) (f: string -> unit) =
+ try f (findConfigurationString key)
+ with Not_found -> ()
+
+
+let findConfigurationBool (key: string) : bool =
+ match findConfiguration key with
+ ConfBool b -> b
+ | _ ->
+ ignore (E.warn "Configuration %s is not a boolean" key);
+ raise Not_found
+
+let useConfigurationBool (key: string) (f: bool -> unit) =
+ try f (findConfigurationBool key)
+ with Not_found -> ()
+
+let findConfigurationList (key: string) : configData list =
+ match findConfiguration key with
+ ConfList l -> l
+ | _ ->
+ ignore (E.warn "Configuration %s is not a list" key);
+ raise Not_found
+
+let useConfigurationList (key: string) (f: configData list -> unit) =
+ try f (findConfigurationList key)
+ with Not_found -> ()
+
+
+let saveConfiguration (fname: string) =
+ (** Convert configuration data to a string, for saving externally *)
+ let configToString (c: configData) : string =
+ let buff = Buffer.create 80 in
+ let rec loop (c: configData) : unit =
+ match c with
+ ConfInt i ->
+ Buffer.add_char buff 'i';
+ Buffer.add_string buff (string_of_int i);
+ Buffer.add_char buff ';'
+
+ | ConfBool b ->
+ Buffer.add_char buff 'b';
+ Buffer.add_string buff (string_of_bool b);
+ Buffer.add_char buff ';'
+
+ | ConfFloat f ->
+ Buffer.add_char buff 'f';
+ Buffer.add_string buff (string_of_float f);
+ Buffer.add_char buff ';'
+
+ | ConfString s ->
+ if String.contains s '"' then
+ E.s (E.unimp "Guilib: configuration string contains quotes");
+ Buffer.add_char buff '"';
+ Buffer.add_string buff s;
+ Buffer.add_char buff '"'; (* '"' *)
+
+ | ConfList l ->
+ Buffer.add_char buff '[';
+ List.iter loop l;
+ Buffer.add_char buff ']'
+ in
+ loop c;
+ Buffer.contents buff
+ in
+ try
+ let oc = open_out fname in
+ ignore (E.log "Saving configuration to %s\n" (absoluteFilename fname));
+ H.iter (fun k c ->
+ output_string oc (k ^ "\n");
+ output_string oc ((configToString c) ^ "\n"))
+ configurationData;
+ close_out oc
+ with _ ->
+ ignore (E.warn "Cannot open configuration file %s\n" fname)
+
+
+(** Make some regular expressions early *)
+let intRegexp = Str.regexp "i\\([0-9]+\\);"
+let floatRegexp = Str.regexp "f\\([0-9]+\\.[0-9]+\\);"
+let boolRegexp = Str.regexp "b\\(\\(true\\)\\|\\(false\\)\\);"
+let stringRegexp = Str.regexp "\"\\([^\"]*\\)\""
+
+let loadConfiguration (fname: string) : unit =
+ H.clear configurationData;
+
+ let stringToConfig (s: string) : configData =
+ let idx = ref 0 in (** the current index *)
+ let l = String.length s in
+
+ let rec getOne () : configData =
+ if !idx >= l then raise Not_found;
+
+ if Str.string_match intRegexp s !idx then begin
+ idx := Str.match_end ();
+ ConfInt (int_of_string (Str.matched_group 1 s))
+ end else if Str.string_match floatRegexp s !idx then begin
+ idx := Str.match_end ();
+ ConfFloat (float_of_string (Str.matched_group 1 s))
+ end else if Str.string_match boolRegexp s !idx then begin
+ idx := Str.match_end ();
+ ConfBool (bool_of_string (Str.matched_group 1 s))
+ end else if Str.string_match stringRegexp s !idx then begin
+ idx := Str.match_end ();
+ ConfString (Str.matched_group 1 s)
+ end else if String.get s !idx = '[' then begin
+ (* We are starting a list *)
+ incr idx;
+ let rec loop (acc: configData list) : configData list =
+ if !idx >= l then begin
+ ignore (E.warn "Non-terminated list in configuration %s" s);
+ raise Not_found
+ end;
+ if String.get s !idx = ']' then begin
+ incr idx;
+ List.rev acc
+ end else
+ loop (getOne () :: acc)
+ in
+ ConfList (loop [])
+ end else begin
+ ignore (E.warn "Bad configuration element in a list: %s\n"
+ (String.sub s !idx (l - !idx)));
+ raise Not_found
+ end
+ in
+ getOne ()
+ in
+ (try
+ let ic = open_in fname in
+ ignore (E.log "Loading configuration from %s\n" (absoluteFilename fname));
+ (try
+ while true do
+ let k = input_line ic in
+ let s = input_line ic in
+ try
+ let c = stringToConfig s in
+ setConfiguration k c
+ with Not_found -> ()
+ done
+ with End_of_file -> ());
+ close_in ic;
+ with _ -> () (* no file, ignore *));
+
+ ()
+
+
+
+(*********************************************************************)
+type symbol = int
+
+(**{ Registering symbol names} *)
+let registeredSymbolNames: (string, symbol) H.t = H.create 113
+let symbolNames: string IH.t = IH.create 113
+let nextSymbolId = ref 0
+
+(* When we register symbol ranges, we store a naming function for use later
+ * when we print the symbol *)
+let symbolRangeNaming: (int * int * (int -> string)) list ref = ref []
+
+(* Reset the symbols. We want to allow the registration of symbols at the
+ * top-level. This means that we cannot simply clear the hash tables. The
+ * first time we call "reset" we actually remember the state. *)
+let resetThunk: (unit -> unit) option ref = ref None
+
+let snapshotSymbols () : unit -> unit =
+ runThunks [ restoreIntHash symbolNames;
+ restoreRef nextSymbolId;
+ restoreHash registeredSymbolNames;
+ restoreRef symbolRangeNaming ]
+
+let resetSymbols () =
+ match !resetThunk with
+ None -> resetThunk := Some (snapshotSymbols ())
+ | Some t -> t ()
+
+
+let dumpSymbols () =
+ ignore (E.log "Current symbols\n");
+ IH.iter (fun i k -> ignore (E.log " %s -> %d\n" k i)) symbolNames;
+ ()
+
+let newSymbol (n: string) : symbol =
+ assert(not (H.mem registeredSymbolNames n));
+ let id = !nextSymbolId in
+ incr nextSymbolId;
+ H.add registeredSymbolNames n id;
+ IH.add symbolNames id n;
+ id
+
+let registerSymbolName (n: string) : symbol =
+ try H.find registeredSymbolNames n
+ with Not_found -> begin
+ newSymbol n
+ end
+
+(** Register a range of symbols. The mkname function will be invoked for
+ * indices starting at 0 *)
+let registerSymbolRange (count: int) (mkname: int -> string) : symbol =
+ if count < 0 then E.s (E.bug "registerSymbolRange: invalid counter");
+ let first = !nextSymbolId in
+ nextSymbolId := !nextSymbolId + count;
+ symbolRangeNaming :=
+ (first, !nextSymbolId - 1, mkname) :: !symbolRangeNaming;
+ first
+
+let symbolName (id: symbol) : string =
+ try IH.find symbolNames id
+ with Not_found ->
+ (* Perhaps it is one of the lazily named symbols *)
+ try
+ let (fst, _, mkname) =
+ List.find
+ (fun (fst,lst,_) -> fst <= id && id <= lst)
+ !symbolRangeNaming in
+ let n = mkname (id - fst) in
+ IH.add symbolNames id n;
+ n
+ with Not_found ->
+ ignore (E.warn "Cannot find the name of symbol %d" id);
+ "symbol" ^ string_of_int id
+
+(************************************************************************)
+
+(** {1 Int32 Operators} *)
+
+module Int32Op = struct
+ exception IntegerTooLarge
+ let to_int (i: int32) =
+ let i' = Int32.to_int i in (* Silently drop the 32nd bit *)
+ if i = Int32.of_int i' then i'
+ else raise IntegerTooLarge
+
+ let (<%) = (fun x y -> (Int32.compare x y) < 0)
+ let (<=%) = (fun x y -> (Int32.compare x y) <= 0)
+ let (>%) = (fun x y -> (Int32.compare x y) > 0)
+ let (>=%) = (fun x y -> (Int32.compare x y) >= 0)
+ let (<>%) = (fun x y -> (Int32.compare x y) <> 0)
+
+ let (+%) = Int32.add
+ let (-%) = Int32.sub
+ let ( *% ) = Int32.mul
+ let (/%) = Int32.div
+ let (~-%) = Int32.neg
+
+ (* We cannot use the <<% because it trips camlp4 *)
+ let sll = fun i j -> Int32.shift_left i (to_int j)
+ let (>>%) = fun i j -> Int32.shift_right i (to_int j)
+ let (>>>%) = fun i j -> Int32.shift_right_logical i (to_int j)
+end
+
+
+(*********************************************************************)
+
+let equals x1 x2 : bool =
+ (compare x1 x2) = 0
--- /dev/null
+(** A bunch of generally useful functions *)
+
+exception GotSignal of int
+
+val withTimeout : float -> (* Seconds for timeout *)
+ (int -> 'b) -> (* What to do if we have a timeout. The
+ * argument passed is the signal number
+ * received. *)
+ ('a -> 'b) -> (* The function to run *)
+ 'a -> (* And its argument *)
+ 'b
+
+val docHash : ?sep:Pretty.doc -> ('a -> 'b -> Pretty.doc) -> unit ->
+ (('a, 'b) Hashtbl.t) -> Pretty.doc
+
+
+val hash_to_list: ('a, 'b) Hashtbl.t -> ('a * 'b) list
+
+val keys: ('a, 'b) Hashtbl.t -> 'a list
+
+
+(** Copy a hash table into another *)
+val hash_copy_into: ('a, 'b) Hashtbl.t -> ('a, 'b) Hashtbl.t -> unit
+
+(** First, a few utility functions I wish were in the standard prelude *)
+
+val anticompare: 'a -> 'a -> int
+
+val list_drop : int -> 'a list -> 'a list
+val list_droptail : int -> 'a list -> 'a list
+val list_span: ('a -> bool) -> ('a list) -> 'a list * 'a list
+val list_insert_by: ('a -> 'a -> int) -> 'a -> 'a list -> 'a list
+val list_head_default: 'a -> 'a list -> 'a
+val list_iter3 : ('a -> 'b -> 'c -> unit) ->
+ 'a list -> 'b list -> 'c list -> unit
+val get_some_option_list : 'a option list -> 'a list
+val list_append: ('a list) -> ('a list) -> ('a list) (* tail-recursive append*)
+
+(** Iterate over a list passing the index as you go *)
+val list_iteri: (int -> 'a -> unit) -> 'a list -> unit
+val list_mapi: (int -> 'a -> 'b) -> 'a list -> 'b list
+
+(** Like fold_left but pass the index into the list as well *)
+val list_fold_lefti: ('acc -> int -> 'a -> 'acc) -> 'acc -> 'a list -> 'acc
+
+(** Generates the range of integers starting with a and ending with b *)
+val int_range_list : int -> int -> int list
+
+(* Create a list of length l *)
+val list_init : int -> (int -> 'a) -> 'a list
+
+(** Find the first element in a list that returns Some *)
+val list_find_first: 'a list -> ('a -> 'b option) -> 'b option
+
+(** mapNoCopy is like map but avoid copying the list if the function does not
+ * change the elements *)
+
+val mapNoCopy: ('a -> 'a) -> 'a list -> 'a list
+
+val mapNoCopyList: ('a -> 'a list) -> 'a list -> 'a list
+
+val filterNoCopy: ('a -> bool) -> 'a list -> 'a list
+
+
+(** Join a list of strings *)
+val joinStrings: string -> string list -> string
+
+
+(**** Now in growArray.mli
+
+(** Growable arrays *)
+type 'a growArrayFill =
+ Elem of 'a
+ | Susp of (int -> 'a)
+
+type 'a growArray = {
+ gaFill: 'a growArrayFill;
+ (** Stuff to use to fill in the array as it grows *)
+
+ mutable gaMaxInitIndex: int;
+ (** Maximum index that was written to. -1 if no writes have
+ * been made. *)
+
+ mutable gaData: 'a array;
+ }
+
+val newGrowArray: int -> 'a growArrayFill -> 'a growArray
+(** [newGrowArray initsz fillhow] *)
+
+val getReg: 'a growArray -> int -> 'a
+val setReg: 'a growArray -> int -> 'a -> unit
+val copyGrowArray: 'a growArray -> 'a growArray
+val deepCopyGrowArray: 'a growArray -> ('a -> 'a) -> 'a growArray
+
+
+val growArray_iteri: (int -> 'a -> unit) -> 'a growArray -> unit
+(** Iterate over the initialized elements of the array *)
+
+val growArray_foldl: ('acc -> 'a -> 'acc) -> 'acc ->'a growArray -> 'acc
+(** Fold left over the initialized elements of the array *)
+
+****)
+
+(** hasPrefix prefix str returns true with str starts with prefix *)
+val hasPrefix: string -> string -> bool
+
+
+(** Given a ref cell, produce a thunk that later restores it to its current value *)
+val restoreRef: ?deepCopy:('a -> 'a) -> 'a ref -> unit -> unit
+
+(** Given a hash table, produce a thunk that later restores it to its current value *)
+val restoreHash: ?deepCopy:('b -> 'b) -> ('a, 'b) Hashtbl.t -> unit -> unit
+
+(** Given an integer hash table, produce a thunk that later restores it to
+ * its current value *)
+val restoreIntHash: ?deepCopy:('b -> 'b) -> 'b Inthash.t -> unit -> unit
+
+(** Given an array, produce a thunk that later restores it to its current value *)
+val restoreArray: ?deepCopy:('a -> 'a) -> 'a array -> unit -> unit
+
+
+(** Given a list of thunks, produce a thunk that runs them all *)
+val runThunks: (unit -> unit) list -> unit -> unit
+
+
+val memoize: ('a, 'b) Hashtbl.t ->
+ 'a ->
+ ('a -> 'b) -> 'b
+
+(** Just another name for memoize *)
+val findOrAdd: ('a, 'b) Hashtbl.t ->
+ 'a ->
+ ('a -> 'b) -> 'b
+
+val tryFinally:
+ ('a -> 'b) -> (* The function to run *)
+ ('b option -> unit) -> (* Something to run at the end. The None case is
+ * used when an exception is thrown *)
+ 'a -> 'b
+
+
+
+
+(** Get the value of an option. Raises Failure if None *)
+val valOf : 'a option -> 'a
+
+(**
+ * An accumulating for loop.
+ *
+ * Initialize the accumulator with init. The current index and accumulator
+ * from the previous iteration is passed to f.
+ *)
+val fold_for : init:'a -> lo:int -> hi:int -> (int -> 'a -> 'a) -> 'a
+
+(************************************************************************)
+
+module type STACK = sig
+ type 'a t
+ (** The type of stacks containing elements of type ['a]. *)
+
+ exception Empty
+ (** Raised when {!Util.Stack.pop} or {!Util.Stack.top} is applied to an
+ * empty stack. *)
+
+ val create : unit -> 'a t
+
+
+ val push : 'a -> 'a t -> unit
+ (** [push x s] adds the element [x] at the top of stack [s]. *)
+
+ val pop : 'a t -> 'a
+ (** [pop s] removes and returns the topmost element in stack [s],
+ or raises [Empty] if the stack is empty. *)
+
+ val top : 'a t -> 'a
+ (** [top s] returns the topmost element in stack [s],
+ or raises [Empty] if the stack is empty. *)
+
+ val clear : 'a t -> unit
+ (** Discard all elements from a stack. *)
+
+ val copy : 'a t -> 'a t
+ (** Return a copy of the given stack. *)
+
+ val is_empty : 'a t -> bool
+ (** Return [true] if the given stack is empty, [false] otherwise. *)
+
+ val length : 'a t -> int
+ (** Return the number of elements in a stack. *)
+
+ val iter : ('a -> unit) -> 'a t -> unit
+ (** [iter f s] applies [f] in turn to all elements of [s],
+ from the element at the top of the stack to the element at the
+ bottom of the stack. The stack itself is unchanged. *)
+end
+
+module Stack : STACK
+
+(************************************************************************
+ Configuration
+************************************************************************)
+(** The configuration data can be of several types **)
+type configData =
+ ConfInt of int
+ | ConfBool of bool
+ | ConfFloat of float
+ | ConfString of string
+ | ConfList of configData list
+
+
+(** Load the configuration from a file *)
+val loadConfiguration: string -> unit
+
+(** Save the configuration in a file. Overwrites the previous values *)
+val saveConfiguration: string -> unit
+
+
+(** Clear all configuration data *)
+val clearConfiguration: unit -> unit
+
+(** Set a configuration element, with a key. Overwrites the previous values *)
+val setConfiguration: string -> configData -> unit
+
+(** Find a configuration elements, given a key. Raises Not_found if it canont
+ * find it *)
+val findConfiguration: string -> configData
+
+(** Like findConfiguration but extracts the integer *)
+val findConfigurationInt: string -> int
+
+(** Looks for an integer configuration element, and if it is found, it uses
+ * the given function. Otherwise, does nothing *)
+val useConfigurationInt: string -> (int -> unit) -> unit
+
+
+val findConfigurationBool: string -> bool
+val useConfigurationBool: string -> (bool -> unit) -> unit
+
+val findConfigurationString: string -> string
+val useConfigurationString: string -> (string -> unit) -> unit
+
+val findConfigurationList: string -> configData list
+val useConfigurationList: string -> (configData list -> unit) -> unit
+
+
+(************************************************************************)
+
+(** Symbols are integers that are uniquely associated with names *)
+type symbol = int
+
+(** Get the name of a symbol *)
+val symbolName: symbol -> string
+
+(** Register a symbol name and get the symbol for it *)
+val registerSymbolName: string -> symbol
+
+(** Register a number of consecutive symbol ids. The naming function will be
+ * invoked with indices from 0 to the counter - 1. Returns the id of the
+ * first symbol created. The naming function is invoked lazily, only when the
+ * name of the symbol is required. *)
+val registerSymbolRange: int -> (int -> string) -> symbol
+
+
+(** Make a fresh symbol. Give the name also, which ought to be distinct from
+ * existing symbols. This is different from registerSymbolName in that it
+ * always creates a new symbol. *)
+val newSymbol: string -> symbol
+
+(** Reset the state of the symbols to the program startup state *)
+val resetSymbols: unit -> unit
+
+(** Take a snapshot of the symbol state. Returns a thunk that restores the
+ * state. *)
+val snapshotSymbols: unit -> unit -> unit
+
+
+(** Dump the list of registered symbols *)
+val dumpSymbols: unit -> unit
+
+(************************************************************************)
+
+(** {1 Int32 Operators} *)
+
+module Int32Op : sig
+ val (<%) : int32 -> int32 -> bool
+ val (<=%) : int32 -> int32 -> bool
+ val (>%) : int32 -> int32 -> bool
+ val (>=%) : int32 -> int32 -> bool
+ val (<>%) : int32 -> int32 -> bool
+
+ val (+%) : int32 -> int32 -> int32
+ val (-%) : int32 -> int32 -> int32
+ val ( *% ) : int32 -> int32 -> int32
+ val (/%) : int32 -> int32 -> int32
+ val (~-%) : int32 -> int32
+
+ val sll : int32 -> int32 -> int32
+ val (>>%) : int32 -> int32 -> int32
+ val (>>>%) : int32 -> int32 -> int32
+
+ exception IntegerTooLarge
+ val to_int : int32 -> int
+end
+
+(************************************************************************)
+
+(** This has the semantics of (=) on OCaml 3.07 and earlier. It can
+ handle cyclic values as long as a structure in the cycle has a unique
+ name or id in some field that occurs before any fields that have cyclic
+ pointers. *)
+val equals: 'a -> 'a -> bool
--- /dev/null
+*.output
+ChangeLog
+
--- /dev/null
+# subdirectories containing source code
+"ext": include
+"frontc": include
+"src": include
+
+# linking
+<cil.{cma,cmxa}>: use_perfcount, is_cil
+<main.{byte,native}>: custom, use_str, use_unix, use_cil
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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 consistency checker for CIL *)
+open Cil
+module E = Errormsg
+module H = Hashtbl
+open Pretty
+
+
+(* A few parameters to customize the checking *)
+type checkFlags =
+ NoCheckGlobalIds (* Do not check that the global ids have the proper
+ * hash value *)
+ | IgnoreInstructions of (instr -> bool) (* Ignore the specified instructions *)
+
+let checkGlobalIds = ref true
+let ignoreInstr = ref (fun i -> false)
+
+ (* Attributes must be sorted *)
+type ctxAttr =
+ CALocal (* Attribute of a local variable *)
+ | CAGlobal (* Attribute of a global variable *)
+ | CAType (* Attribute of a type *)
+
+let valid = ref true
+
+let warn fmt =
+ valid := false;
+ Cil.warn ("CIL invariant broken: "^^fmt)
+
+let warnContext fmt =
+ valid := false;
+ Cil.warnContext fmt
+
+let checkAttributes (attrs: attribute list) : unit =
+ let rec loop lastname = function
+ [] -> ()
+ | Attr(an, _) :: resta ->
+ if an < lastname then
+ ignore (warn "Attributes not sorted");
+ loop an resta
+ in
+ loop "" attrs
+
+
+ (* Keep track of defined types *)
+let typeDefs : (string, typ) H.t = H.create 117
+
+
+ (* Keep track of all variables names, enum tags and type names *)
+let varNamesEnv : (string, unit) H.t = H.create 117
+
+ (* We also keep a map of variables indexed by id, to ensure that only one
+ * varinfo has a given id *)
+let varIdsEnv: (int, varinfo) H.t = H.create 117
+
+ (* And keep track of all varinfo's to check the uniqueness of the
+ * identifiers *)
+let allVarIds: (int, varinfo) H.t = H.create 117
+
+ (* Also keep a list of environments. We place an empty string in the list to
+ * mark the start of a local environment (i.e. a function) *)
+let varNamesList : (string * int) list ref = ref []
+let defineName s =
+ if s = "" then
+ E.s (bug "Empty name\n");
+ if H.mem varNamesEnv s then
+ ignore (warn "Multiple definitions for %s\n" s);
+ H.add varNamesEnv s ()
+
+let defineVariable vi =
+ (* E.log "saw %s: %d\n" vi.vname vi.vid; *)
+ defineName vi.vname;
+ varNamesList := (vi.vname, vi.vid) :: !varNamesList;
+ (* Check the id *)
+ if H.mem allVarIds vi.vid then
+ ignore (warn "Id %d is already defined (%s)\n" vi.vid vi.vname);
+ H.add allVarIds vi.vid vi;
+ (* And register it in the current scope also *)
+ H.add varIdsEnv vi.vid vi
+
+(* Check that a varinfo has already been registered *)
+let checkVariable vi =
+ try
+ (* Check in the current scope only *)
+ let old = H.find varIdsEnv vi.vid in
+ if vi != old then begin
+ if vi.vname = old.vname then
+ ignore (warnContext "varinfos for %s not shared\n" vi.vname)
+ else
+ ignore (warnContext "variables %s and %s share id %d\n"
+ vi.vname old.vname vi.vid )
+ end
+ with Not_found ->
+ ignore (warn "Unknown id (%d) for %s\n" vi.vid vi.vname)
+
+
+let startEnv () =
+ varNamesList := ("", -1) :: !varNamesList
+
+let endEnv () =
+ let rec loop = function
+ [] -> E.s (bug "Cannot find start of env")
+ | ("", _) :: rest -> varNamesList := rest
+ | (s, id) :: rest -> begin
+ H.remove varNamesEnv s;
+ H.remove varIdsEnv id;
+ loop rest
+ end
+ in
+ loop !varNamesList
+
+
+
+(* The current function being checked *)
+let currentReturnType : typ ref = ref voidType
+
+(* A map of labels in the current function *)
+let labels: (string, unit) H.t = H.create 17
+
+(* A list of statements seen in the current function *)
+let statements: stmt list ref = ref []
+
+(* A list of the targets of Gotos *)
+let gotoTargets: (string * stmt) list ref = ref []
+
+(*** TYPES ***)
+(* Cetain types can only occur in some contexts, so keep a list of context *)
+type ctxType =
+ CTStruct (* In a composite type *)
+ | CTUnion
+ | CTFArg (* In a function argument type *)
+ | CTFRes (* In a function result type *)
+ | CTArray (* In an array type *)
+ | CTPtr (* In a pointer type *)
+ | CTExp (* In an expression, as the type of
+ * the result of binary operators, or
+ * in a cast *)
+ | CTSizeof (* In a sizeof *)
+ | CTDecl (* In a typedef, or a declaration *)
+
+let d_context () = function
+ CTStruct -> text "CTStruct"
+ | CTUnion -> text "CTUnion"
+ | CTFArg -> text "CTFArg"
+ | CTFRes -> text "CTFRes"
+ | CTArray -> text "CTArray"
+ | CTPtr -> text "CTPtr"
+ | CTExp -> text "CTExp"
+ | CTSizeof -> text "CTSizeof"
+ | CTDecl -> text "CTDecl"
+
+
+(* Keep track of all tags that we use. For each tag remember also the info
+ * structure and a flag whether it was actually defined or just used. A
+ * forward declaration acts as a definition. *)
+type defuse =
+ Defined (* We actually have seen a definition of this tag *)
+ | Forward (* We have seen a forward declaration for it. This is done using
+ * a GType with an empty type name *)
+ | Used (* Only uses *)
+let compUsed : (int, compinfo * defuse ref) H.t = H.create 117
+let enumUsed : (string, enuminfo * defuse ref) H.t = H.create 117
+let typUsed : (string, typeinfo * defuse ref) H.t = H.create 117
+
+(* For composite types we also check that the names are unique *)
+let compNames : (string, unit) H.t = H.create 17
+
+
+let typeSigIgnoreConst (t : typ) : typsig =
+ let attrFilter (attr : attribute) : bool =
+ match attr with
+ | Attr ("const", []) -> false
+ | _ -> true
+ in
+ typeSigWithAttrs (List.filter attrFilter) t
+
+
+ (* Check a type *)
+let rec checkType (t: typ) (ctx: ctxType) =
+ (* Check that it appears in the right context *)
+ let rec checkContext = function
+ TVoid _ -> ctx = CTPtr || ctx = CTFRes || ctx = CTDecl || ctx = CTSizeof
+ | TNamed (ti, a) -> checkContext ti.ttype
+ | TArray _ ->
+ (ctx = CTStruct || ctx = CTUnion
+ || ctx = CTSizeof || ctx = CTDecl || ctx = CTArray || ctx = CTPtr)
+ | TFun _ ->
+ if ctx = CTSizeof && !msvcMode then
+ (ignore(warn "sizeof(function) is not defined in MSVC."); false)
+ else
+ ctx = CTPtr || ctx = CTDecl || ctx = CTSizeof
+ | _ -> true
+ in
+ if not (checkContext t) then
+ ignore (warn "Type (%a) used in wrong context. Expected context: %a"
+ d_plaintype t d_context ctx);
+ match t with
+ (TVoid a | TBuiltin_va_list a) -> checkAttributes a
+ | TInt (ik, a) -> checkAttributes a
+ | TFloat (_, a) -> checkAttributes a
+ | TPtr (t, a) -> checkAttributes a; checkType t CTPtr
+
+ | TNamed (ti, a) ->
+ checkAttributes a;
+ if ti.tname = "" then
+ ignore (warnContext "Using a typeinfo for an empty-named type\n");
+ checkTypeInfo Used ti
+
+ | TComp (comp, a) ->
+ checkAttributes a;
+ (* Mark it as a forward. We'll check it later. If we try to check it
+ * now we might encounter undefined types *)
+ checkCompInfo Used comp
+
+
+ | TEnum (enum, a) -> begin
+ checkAttributes a;
+ checkEnumInfo Used enum
+ end
+
+ | TArray(bt, len, a) ->
+ checkAttributes a;
+ checkType bt CTArray;
+ (match len with
+ None -> ()
+ | Some l -> begin
+ let t = checkExp true l in
+ if not (isIntegralType t) then
+ E.s (bug "Type of array length is not integer")
+ end)
+
+ | TFun (rt, targs, isva, a) ->
+ checkAttributes a;
+ checkType rt CTFRes;
+ List.iter
+ (fun (an, at, aa) ->
+ checkType at CTFArg;
+ checkAttributes aa) (argsToList targs)
+
+(* Check that a type is a promoted integral type *)
+and checkIntegralType (t: typ) =
+ checkType t CTExp;
+ if not (isIntegralType t) then
+ ignore (warn "Non-integral type")
+
+(* Check that a type is a promoted arithmetic type *)
+and checkArithmeticType (t: typ) =
+ checkType t CTExp;
+ if not (isArithmeticType t) then
+ ignore (warn "Non-arithmetic type")
+
+(* Check that a type is a promoted boolean type *)
+and checkBooleanType (t: typ) =
+ checkType t CTExp;
+ match unrollType t with
+ TInt _ | TEnum _ | TFloat _ | TPtr _ -> ()
+ | _ -> ignore (warn "Non-boolean type")
+
+
+(* Check that a type is a pointer type *)
+and checkPointerType (t: typ) =
+ checkType t CTExp;
+ if not (isPointerType t) then
+ ignore (warn "Non-pointer type")
+
+
+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 *)
+ if typeSigIgnoreConst t1 <> typeSigIgnoreConst t2 then
+ match unrollType t1, unrollType t2 with
+ (* Allow free interchange of TInt and TEnum *)
+ TInt (IInt, _), TEnum _ -> ()
+ | TEnum _, TInt (IInt, _) -> ()
+
+ | _, _ -> ignore (warn "Type mismatch:@! %a@!and %a@!"
+ d_type t1 d_type t2)
+ end else begin
+ (* Many casts are missing. For now, just skip this check. *)
+ end
+
+and checkCompInfo (isadef: defuse) comp =
+ let fullname = compFullName comp in
+ try
+ let oldci, olddef = H.find compUsed comp.ckey in
+ (* Check that it is the same *)
+ if oldci != comp then
+ ignore (warnContext "compinfo for %s not shared\n" fullname);
+ (match !olddef, isadef with
+ | Defined, Defined ->
+ ignore (warnContext "Multiple definition of %s\n" fullname)
+ | _, Defined -> olddef := Defined
+ | Defined, _ -> ()
+ | _, Forward -> olddef := Forward
+ | _, _ -> ())
+ with Not_found -> begin (* This is the first time we see it *)
+ (* Check that the name is not empty *)
+ if comp.cname = "" then
+ E.s (bug "Compinfo with empty name");
+ (* Check that the name is unique *)
+ if H.mem compNames fullname then
+ ignore (warn "Duplicate name %s" fullname);
+ (* Add it to the map before we go on *)
+ H.add compUsed comp.ckey (comp, ref isadef);
+ H.add compNames fullname ();
+ (* Do not check the compinfo unless this is a definition. Otherwise you
+ * might run into undefined types. *)
+ if isadef = Defined then begin
+ checkAttributes comp.cattr;
+ let fctx = if comp.cstruct then CTStruct else CTUnion in
+ let rec checkField f =
+ if not
+ (f.fcomp == comp && (* Each field must share the self cell of
+ * the host *)
+ f.fname <> "") then
+ ignore (warn "Self pointer not set in field %s of %s"
+ f.fname fullname);
+ checkType f.ftype fctx;
+ (* Check the bitfields *)
+ (match unrollType f.ftype, f.fbitfield with
+ | TInt (ik, a), Some w ->
+ checkAttributes a;
+ if w < 0 || w > bitsSizeOf (TInt(ik, a)) then
+ ignore (warn "Wrong width (%d) in bitfield" w)
+ | _, Some w ->
+ ignore (E.error "Bitfield on a non integer type\n")
+ | _ -> ());
+ checkAttributes f.fattr
+ in
+ List.iter checkField comp.cfields
+ end
+ end
+
+
+and checkEnumInfo (isadef: defuse) enum =
+ if enum.ename = "" then
+ E.s (bug "Enuminfo with empty name");
+ try
+ let oldei, olddef = H.find enumUsed enum.ename in
+ (* Check that it is the same *)
+ if oldei != enum then
+ ignore (warnContext "enuminfo for %s not shared\n" enum.ename);
+ (match !olddef, isadef with
+ Defined, Defined ->
+ ignore (warnContext "Multiple definition of enum %s\n" enum.ename)
+ | _, Defined -> olddef := Defined
+ | Defined, _ -> ()
+ | _, Forward -> olddef := Forward
+ | _, _ -> ())
+ with Not_found -> begin (* This is the first time we see it *)
+ (* Add it to the map before we go on *)
+ H.add enumUsed enum.ename (enum, ref isadef);
+ checkAttributes enum.eattr;
+ List.iter (fun (tn, _, _) -> defineName tn) enum.eitems;
+ end
+
+and checkTypeInfo (isadef: defuse) ti =
+ try
+ let oldti, olddef = H.find typUsed ti.tname in
+ (* Check that it is the same *)
+ if oldti != ti then
+ ignore (warnContext "typeinfo for %s not shared\n" ti.tname);
+ (match !olddef, isadef with
+ Defined, Defined ->
+ ignore (warnContext "Multiple definition of type %s\n" ti.tname)
+ | Defined, Used -> ()
+ | Used, Defined ->
+ ignore (warnContext "Use of type %s before its definition\n" ti.tname)
+ | _, _ ->
+ ignore (warnContext "Bug in checkTypeInfo for %s\n" ti.tname))
+ with Not_found -> begin (* This is the first time we see it *)
+ if ti.tname = "" then
+ ignore (warnContext "typeinfo with empty name");
+ checkType ti.ttype CTDecl;
+ (* Add it to the map before we go on *)
+ H.add typUsed ti.tname (ti, ref isadef);
+ end
+
+(* Check an lvalue. If isconst then the lvalue appears in a context where
+ * only a compile-time constant can appear. Return the type of the lvalue.
+ * See the typing rule from cil.mli *)
+and checkLval (isconst: bool) (forAddrof: bool) (lv: lval) : typ =
+ match lv with
+ Var vi, off ->
+ checkVariable vi;
+ checkOffset vi.vtype off
+
+ | Mem addr, off -> begin
+ if isconst && not forAddrof then
+ ignore (warn "Memory operation in constant");
+ let ta = checkExp false addr in
+ match unrollType ta with
+ TPtr (t, _) -> checkOffset t off
+ | _ -> E.s (bug "Mem on a non-pointer")
+ end
+
+(* Check an offset. The basetype is the type of the object referenced by the
+ * base. Return the type of the lvalue constructed from a base value of right
+ * type and the offset. See the typing rules from cil.mli *)
+and checkOffset basetyp : offset -> typ = function
+ NoOffset -> basetyp
+ | Index (ei, o) ->
+ checkIntegralType (checkExp false ei);
+ begin
+ match unrollType basetyp with
+ TArray (t, _, _) -> checkOffset t o
+ | t -> E.s (bug "typeOffset: Index on a non-array: %a" d_plaintype t)
+ end
+
+ | Field (fi, o) ->
+ (* Now check that the host is shared propertly *)
+ checkCompInfo Used fi.fcomp;
+ (* Check that this exact field is part of the host *)
+ if not (List.exists (fun f -> f == fi) fi.fcomp.cfields) then
+ ignore (warn "Field %s not part of %s"
+ fi.fname (compFullName fi.fcomp));
+ checkOffset fi.ftype o
+
+and checkExpType (isconst: bool) (e: exp) (t: typ) =
+ let t' = checkExp isconst e in (* compute the type *)
+ (* 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
+ * type of the expression *)
+and checkExp (isconst: bool) (e: exp) : typ =
+ E.withContext
+ (fun _ -> dprintf "check%s: %a"
+ (if isconst then "Const" else "Exp") d_exp e)
+ (fun _ ->
+ match e with
+ | Const(_) -> typeOf e
+ | Lval(lv) ->
+ if isconst then
+ ignore (warn "Lval in constant");
+ checkLval isconst false lv
+
+ | SizeOf(t) -> begin
+ (* Sizeof cannot be applied to certain types *)
+ checkType t CTSizeof;
+ (match unrollType t with
+ (TFun _ ) ->
+ ignore (warn "Invalid operand for sizeof")
+ | _ ->());
+ typeOf e
+ end
+ | SizeOfE(e') ->
+ (* The expression in a sizeof can be anything *)
+ let te = checkExp false e' in
+ checkType te CTSizeof;
+ typeOf e
+
+ | SizeOfStr s -> typeOf e
+
+ | AlignOf(t) -> begin
+ (* Sizeof cannot be applied to certain types *)
+ checkType t CTSizeof;
+ typeOf e
+ end
+ | AlignOfE(e') ->
+ (* The expression in an AlignOfE can be anything *)
+ let te = checkExp false e' in
+ checkType te CTSizeof;
+ typeOf e
+
+ | UnOp (Neg, e, tres) ->
+ checkArithmeticType tres; checkExpType isconst e tres; tres
+
+ | UnOp (BNot, e, tres) ->
+ checkIntegralType tres; checkExpType isconst e tres; tres
+
+ | UnOp (LNot, e, tres) ->
+ let te = checkExp isconst e in
+ checkBooleanType te;
+ checkIntegralType tres; (* Must check that t is well-formed *)
+ typeMatch tres intType;
+ tres
+
+ | BinOp (bop, e1, e2, tres) -> begin
+ let t1 = checkExp isconst e1 in
+ let t2 = checkExp isconst e2 in
+ match bop with
+ (Mult | Div) ->
+ typeMatch t1 t2; checkArithmeticType tres;
+ typeMatch t1 tres; tres
+ | (Eq|Ne|Lt|Le|Ge|Gt) ->
+ typeMatch t1 t2; checkArithmeticType t1;
+ typeMatch tres intType; tres
+ | Mod|BAnd|BOr|BXor ->
+ typeMatch t1 t2; checkIntegralType tres;
+ typeMatch t1 tres; tres
+ | LAnd | LOr ->
+ typeMatch t1 t2; checkBooleanType tres;
+ typeMatch t1 tres; tres
+ | Shiftlt | Shiftrt ->
+ typeMatch t1 tres; checkIntegralType t1;
+ checkIntegralType t2; tres
+ | (PlusA | MinusA) ->
+ typeMatch t1 t2; typeMatch t1 tres;
+ checkArithmeticType tres; tres
+ | (PlusPI | MinusPI | IndexPI) ->
+ checkPointerType tres;
+ typeMatch t1 tres;
+ checkIntegralType t2;
+ tres
+ | MinusPP ->
+ checkPointerType t1; checkPointerType t2;
+ typeMatch t1 t2;
+ typeMatch tres intType;
+ tres
+ end
+ | AddrOf (lv) -> begin
+ let tlv = checkLval isconst true lv in
+ (* Only certain types can be in AddrOf *)
+ match unrollType tlv with
+ | TVoid _ ->
+ E.s (bug "AddrOf on improper type");
+
+ | (TInt _ | TFloat _ | TPtr _ | TComp _ | TFun _ | TArray _ ) ->
+ TPtr(tlv, [])
+
+ | TEnum _ -> intPtrType
+ | _ -> E.s (bug "AddrOf on unknown type")
+ end
+
+ | StartOf lv -> begin
+ let tlv = checkLval isconst true lv in
+ match unrollType tlv with
+ TArray (t,_, _) -> TPtr(t, [])
+ | _ -> E.s (bug "StartOf on a non-array")
+ end
+
+ | CastE (tres, e) -> begin
+ let et = checkExp isconst e in
+ checkType tres CTExp;
+ (* Not all types can be cast *)
+ match unrollType et with
+ TArray _ -> E.s (bug "Cast of an array type")
+ | TFun _ -> E.s (bug "Cast of a function type")
+ (* A TComp cast that changes the attributes is okay. *)
+ (* | TComp _ -> E.s (bug "Cast of a composite type") *)
+ | TVoid _ -> E.s (bug "Cast of a void type")
+ | _ -> tres
+ end)
+ () (* The argument of withContext *)
+
+and checkInit (i: init) : typ =
+ E.withContext
+ (fun _ -> dprintf "checkInit: %a" d_init i)
+ (fun _ ->
+ match i with
+ SingleInit e -> checkExp true e
+(*
+ | ArrayInit (bt, len, initl) -> begin
+ checkType bt CTSizeof;
+ if List.length initl > len then
+ ignore (warn "Too many initializers in array");
+ List.iter (fun i -> checkInitType i bt) initl;
+ TArray(bt, Some (integer len), [])
+ end
+*)
+ | CompoundInit (ct, initl) -> begin
+ checkType ct CTSizeof;
+ (match unrollType ct with
+ TArray(bt, Some elen, _) ->
+ ignore (checkExp true elen);
+ let len =
+ match isInteger (constFold true elen) with
+ Some len -> len
+ | None ->
+ ignore (warn "Array length is not a constant");
+ 0L
+ in
+ let rec loopIndex i = function
+ [] ->
+ if i > len then
+ ignore (warn "Wrong number of initializers in array")
+
+ | (Index(Const(CInt64(i', _, _)), NoOffset), ei) :: rest ->
+ if i' <> i then
+ ignore (warn "Initializer for index %s when %s was expected\n"
+ (Int64.format "%d" i') (Int64.format "%d" i));
+ checkInitType ei bt;
+ loopIndex (Int64.succ i) rest
+ | _ :: rest ->
+ ignore (warn "Malformed initializer for array element")
+ in
+ loopIndex Int64.zero initl
+ | TArray(_, None, _) ->
+ ignore (warn "Malformed initializer for array")
+ | TComp (comp, _) ->
+ if comp.cstruct then
+ let rec loopFields
+ (nextflds: fieldinfo list)
+ (initl: (offset * init) list) : unit =
+ match nextflds, initl with
+ [], [] -> () (* We are done *)
+ | f :: restf, (Field(f', NoOffset), i) :: resti ->
+ if f.fname <> f'.fname then
+ ignore (warn "Expected initializer for field %s and found one for %s\n" f.fname f'.fname);
+ checkInitType i f.ftype;
+ loopFields restf resti
+ | [], _ :: _ ->
+ ignore (warn "Too many initializers for struct")
+ | _ :: _, [] ->
+ ignore (warn "Too few initializers for struct")
+ | _, _ ->
+ ignore (warn "Malformed initializer for struct")
+ in
+ loopFields
+ (List.filter (fun f -> f.fname <> missingFieldName)
+ comp.cfields)
+ initl
+
+ else (* UNION *)
+ if comp.cfields == [] then begin
+ if initl != [] then
+ ignore (warn "Initializer for empty union not empty");
+ end else begin
+ match initl with
+ [(Field(f, NoOffset), ei)] ->
+ if f.fcomp != comp then
+ ignore (bug "Wrong designator for union initializer");
+ if !msvcMode && f != List.hd comp.cfields then
+ ignore (warn "On MSVC you can only initialize the first field of a union");
+ checkInitType ei f.ftype
+
+ | _ ->
+ ignore (warn "Malformed initializer for union")
+ end
+ | _ ->
+ E.s (warn "Type of Compound is not array or struct or union"));
+ ct
+ end)
+ () (* The arguments of withContext *)
+
+
+and checkInitType (i: init) (t: typ) : unit =
+ let it = checkInit i in
+ typeMatch it t
+
+and checkStmt (s: stmt) =
+ E.withContext
+ (fun _ ->
+ (* Print context only for certain small statements *)
+ match s.skind with
+ Loop _ | If _ | Switch _ -> nil
+ | _ -> dprintf "checkStmt: %a" d_stmt s)
+ (fun _ ->
+ (* Check the labels *)
+ let checkLabel = function
+ Label (ln, l, _) ->
+ if H.mem labels ln then
+ ignore (warn "Multiply defined label %s" ln);
+ H.add labels ln ()
+ | Case (e, _) ->
+ checkExpType true e intType
+ | _ -> () (* Not yet implemented *)
+ in
+ List.iter checkLabel s.labels;
+ (* See if we have seen this statement before *)
+ if List.memq s !statements then
+ ignore (warn "Statement is shared");
+ (* Remember that we have seen this one *)
+ statements := s :: !statements;
+ match s.skind with
+ Break _ | Continue _ -> ()
+ | Goto (gref, l) ->
+ currentLoc := l;
+ (* Find a label *)
+ let lab =
+ match List.filter (function Label _ -> true | _ -> false)
+ !gref.labels with
+ Label (lab, _, _) :: _ -> lab
+ | _ ->
+ ignore (warn "Goto to block without a label\n");
+ "<missing label>"
+ in
+ (* Remember it as a target *)
+ gotoTargets := (lab, !gref) :: !gotoTargets
+
+
+ | Return (re,l) -> begin
+ currentLoc := l;
+ match re, !currentReturnType with
+ None, TVoid _ -> ()
+ | _, TVoid _ -> ignore (warn "Invalid return value")
+ | None, _ -> ignore (warn "Invalid return value")
+ | Some re', rt' -> checkExpType false re' rt'
+ end
+ | Loop (b, l, _, _) -> checkBlock b
+ | Block b -> checkBlock b
+ | If (e, bt, bf, l) ->
+ currentLoc := l;
+ let te = checkExp false e in
+ checkBooleanType te;
+ checkBlock bt;
+ checkBlock bf
+ | Switch (e, b, cases, l) ->
+ currentLoc := l;
+ checkExpType false e intType;
+ (* Remember the statements so far *)
+ let prevStatements = !statements in
+ checkBlock b;
+ (* Now make sure that all the cases do occur in that block,
+ and that no case is listed twice. *)
+ let casesVisited : stmt list ref = ref [] in
+ List.iter
+ (fun c ->
+ (if List.memq c !casesVisited then
+ 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
+ "Cannot find target of switch statement")
+ | [] -> E.s (E.bug "Check: findCase")
+ | c' :: rest when c == c' -> () (* Found *)
+ | _ :: rest -> findCase rest
+ in
+ findCase !statements)
+ cases;
+ | TryFinally (b, h, l) ->
+ currentLoc := l;
+ checkBlock b;
+ checkBlock h
+
+ | TryExcept (b, (il, e), h, l) ->
+ currentLoc := l;
+ checkBlock b;
+ List.iter checkInstr il;
+ checkExpType false e intType;
+ checkBlock h
+
+ | Instr il -> List.iter checkInstr il)
+ () (* argument of withContext *)
+
+and checkBlock (b: block) : unit =
+ List.iter checkStmt b.bstmts
+
+
+and checkInstr (i: instr) =
+ if !ignoreInstr i then ()
+ else
+ match i with
+ | Set (dest, e, l) ->
+ currentLoc := l;
+ let t = checkLval false false dest in
+ (* Not all types can be assigned to *)
+ (match unrollType t with
+ TFun _ -> ignore (warn "Assignment to a function type")
+ | TArray _ -> ignore (warn "Assignment to an array type")
+ | TVoid _ -> ignore (warn "Assignment to a void type")
+ | _ -> ());
+ checkExpType false e t
+
+ | Call(dest, what, args, l) ->
+ currentLoc := l;
+ let (rt, formals, isva, fnAttrs) =
+ match unrollType (checkExp false what) with
+ TFun(rt, formals, isva, fnAttrs) -> rt, formals, isva, fnAttrs
+ | _ -> E.s (bug "Call to a non-function")
+ in
+ (* Now check the return value*)
+ (match dest, unrollType rt with
+ None, TVoid _ -> ()
+ | Some _, TVoid _ -> ignore (warn "void value is assigned")
+ | None, _ -> () (* "Call of function is not assigned" *)
+ | Some destlv, rt' ->
+ let desttyp = checkLval false false destlv in
+ if typeSig desttyp <> typeSig rt then begin
+ if not !Cabs2cil.doCollapseCallCast then
+ ignore (warn
+ "Destination of Call does not match the return type.");
+ (* Not all types can be assigned to *)
+ (match unrollType desttyp with
+ TFun _ -> ignore (warn "Assignment to a function type")
+ | TArray _ -> ignore (warn "Assignment to an array type")
+ | TVoid _ -> ignore (warn "Assignment to a void type")
+ | _ -> ());
+ (* Not all types can be cast *)
+ (match unrollType rt' with
+ TArray _ -> ignore (warn "Cast of an array type")
+ | TFun _ -> ignore (warn "Cast of a function type")
+ | TComp _ -> ignore (warn "Cast of a composite type")
+ | TVoid _ -> ignore (warn "Cast of a void type")
+
+ | _ -> ())
+ end);
+ (* Now check the arguments *)
+ let rec loopArgs formals args =
+ match formals, args with
+ [], _ when (isva || args = []) -> ()
+ | (fn,ft,_) :: formals, a :: args ->
+ checkExpType false a ft;
+ loopArgs formals args
+ | _, _ -> ignore (warn "Not enough arguments")
+ in
+ if formals <> None then
+ loopArgs (argsToList formals) args
+
+ | Asm _ -> () (* Not yet implemented *)
+
+let rec checkGlobal = function
+ GAsm _ -> ()
+ | GPragma _ -> ()
+ | GText _ -> ()
+ | GType (ti, l) ->
+ currentLoc := l;
+ E.withContext (fun _ -> dprintf "GType(%s)" ti.tname)
+ (fun _ ->
+ checkTypeInfo Defined ti;
+ if ti.tname <> "" then defineName ti.tname)
+ ()
+
+ | GCompTag (comp, l) ->
+ currentLoc := l;
+ checkCompInfo Defined comp;
+
+ | GCompTagDecl (comp, l) ->
+ currentLoc := l;
+ checkCompInfo Forward comp;
+
+ | GEnumTag (enum, l) ->
+ currentLoc := l;
+ checkEnumInfo Defined enum
+
+ | GEnumTagDecl (enum, l) ->
+ currentLoc := l;
+ checkEnumInfo Forward enum
+
+ | GVarDecl (vi, l) ->
+ currentLoc := l;
+ (* We might have seen it already *)
+ E.withContext (fun _ -> dprintf "GVarDecl(%s)" vi.vname)
+ (fun _ ->
+ (* If we have seen this vid already then it must be for the exact
+ * same varinfo *)
+ if H.mem varIdsEnv vi.vid then
+ checkVariable vi
+ else begin
+ defineVariable vi;
+ checkAttributes vi.vattr;
+ checkType vi.vtype CTDecl;
+ if not (vi.vglob &&
+ vi.vstorage <> Register) then
+ E.s (bug "Invalid declaration of %s" vi.vname)
+ end)
+ ()
+
+ | GVar (vi, init, l) ->
+ currentLoc := l;
+ (* Maybe this is the first occurrence *)
+ E.withContext (fun _ -> dprintf "GVar(%s)" vi.vname)
+ (fun _ ->
+ checkGlobal (GVarDecl (vi, l));
+ (* Check the initializer *)
+ begin match init.init with
+ None -> ()
+ | Some i -> ignore (checkInitType i vi.vtype)
+ end;
+ (* Cannot be a function *)
+ if isFunctionType vi.vtype then
+ E.s (bug "GVar for a function (%s)\n" vi.vname);
+ )
+ ()
+
+
+ | GFun (fd, l) -> begin
+ currentLoc := l;
+ (* Check if this is the first occurrence *)
+ let vi = fd.svar in
+ let fname = vi.vname in
+ E.withContext (fun _ -> dprintf "GFun(%s)" fname)
+ (fun _ ->
+ checkGlobal (GVarDecl (vi, l));
+ (* Check that the argument types in the type are identical to the
+ * formals *)
+ let rec loopArgs targs formals =
+ match targs, formals with
+ [], [] -> ()
+ | (fn, ft, fa) :: targs, fo :: formals ->
+ if fn <> fo.vname 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"
+ fo.vname fname);
+ loopArgs targs formals
+
+ | _ ->
+ E.s (bug "Type has different number of formals for %s"
+ fname)
+ in
+ begin match unrollType vi.vtype with
+ TFun (rt, args, isva, a) -> begin
+ currentReturnType := rt;
+ loopArgs (argsToList args) fd.sformals
+ end
+ | _ -> E.s (bug "Function %s does not have a function type"
+ fname)
+ end;
+ ignore (fd.smaxid >= 0 || E.s (bug "smaxid < 0 for %s" fname));
+ (* Now start a new environment, in a finally clause *)
+ begin try
+ startEnv ();
+ (* Do the locals *)
+ let doLocal tctx v =
+ if v.vglob then
+ ignore (warnContext
+ "Local %s has the vglob flag set" v.vname);
+ if v.vstorage <> NoStorage && v.vstorage <> Register then
+ ignore (warnContext
+ "Local %s has storage %a\n" v.vname
+ d_storage v.vstorage);
+ checkType v.vtype tctx;
+ checkAttributes v.vattr;
+ defineVariable v
+ in
+ List.iter (doLocal CTFArg) fd.sformals;
+ List.iter (doLocal CTDecl) fd.slocals;
+ statements := [];
+ gotoTargets := [];
+ checkBlock fd.sbody;
+ H.clear labels;
+ (* Now verify that we have scanned all targets *)
+ List.iter
+ (fun (lab, t) -> if not (List.memq t !statements) then
+ ignore (warnContext
+ "Target of \"goto %s\" statement does not appear in function body" lab))
+ !gotoTargets;
+ statements := [];
+ gotoTargets := [];
+ (* Done *)
+ endEnv ()
+ with e ->
+ endEnv ();
+ raise e
+ end;
+ ())
+ () (* final argument of withContext *)
+ end
+
+
+let checkFile flags fl =
+ if !E.verboseFlag then ignore (E.log "Checking file %s\n" fl.fileName);
+ valid := true;
+ List.iter
+ (function
+ NoCheckGlobalIds -> checkGlobalIds := false
+ | IgnoreInstructions f -> ignoreInstr := f
+ )
+ flags;
+ iterGlobals fl (fun g -> try checkGlobal g with _ -> ());
+ (* Check that for all struct/union tags there is a definition *)
+ H.iter
+ (fun k (comp, isadef) ->
+ if !isadef = Used then
+ begin
+ valid := false;
+ ignore (E.warn "Compinfo %s is referenced but not defined"
+ (compFullName comp))
+ end)
+ compUsed;
+ (* Check that for all enum tags there is a definition *)
+ H.iter
+ (fun k (enum, isadef) ->
+ if !isadef = Used then
+ begin
+ valid := false;
+ ignore (E.warn "Enuminfo %s is referenced but not defined"
+ enum.ename)
+ end)
+ enumUsed;
+ (* Clean the hashes to let the GC do its job *)
+ H.clear typeDefs;
+ H.clear varNamesEnv;
+ H.clear varIdsEnv;
+ H.clear allVarIds;
+ H.clear compNames;
+ H.clear compUsed;
+ H.clear enumUsed;
+ H.clear typUsed;
+ varNamesList := [];
+ if !E.verboseFlag then
+ ignore (E.log "Finished checking file %s\n" fl.fileName);
+ !valid
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * 3. The names of the contributors may not be used to endorse or promote
+ * products derived from this software without specific prior written
+ * permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+ * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+ * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+ * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+ * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+ * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+ * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+ * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+ * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+ * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+ * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ *
+ *)
+
+ (* Checks the well-formedness of the file. Prints warnings and
+ * returns false if errors are found *)
+
+type checkFlags =
+ NoCheckGlobalIds (* Do not check that the global ids have the proper
+ * hash value *)
+ | IgnoreInstructions of (Cil.instr -> bool)
+ (** Ignore the specified instructions *)
+
+val checkFile: checkFlags list -> Cil.file -> bool
--- /dev/null
+cil.cma
+cil.cmxa
+main.byte
+main.native
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2003,
+ * 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.
+ *
+ * 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 Escape
+open Pretty
+(* open Trace (\* sm: 'trace' function *\) *)
+module E = Errormsg
+module H = Hashtbl
+module IH = Inthash
+
+(*
+ * CIL: An intermediate language for analyzing C progams.
+ *
+ * Scott McPeak, George Necula, Wes Weimer
+ *
+ *)
+
+(* The module Cilversion is generated automatically by Makefile from
+ * information in configure.in *)
+let cilVersion = Cilversion.cilVersion
+let cilVersionMajor = Cilversion.cilVersionMajor
+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
+ * compiler. Default is GCC *)
+
+let useLogicalOperators = ref false
+
+
+module M = Machdep
+(* Cil.initCil will set this to the current machine description.
+ Makefile.cil generates the file obj/@ARCHOS@/machdep.ml,
+ which contains the descriptions of gcc and msvc. *)
+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) *)
+
+
+let little_endian = ref true
+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
+ * visual inspection *)
+ | LineCommentSparse (** Like LineComment but only print a line
+ * directive for a new source line *)
+ | LinePreprocessorInput (** Use #line directives *)
+ | LinePreprocessorOutput (** Use # nnn directives (in gcc mode) *)
+
+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
+ * to do lossless transformations when CIL is the consumer *)
+let forgcc (s: string) : string =
+ if (!print_CIL_Input) then "" else s
+
+
+let debugConstFold = false
+
+(** The Abstract Syntax of CIL *)
+
+
+(** The top-level representation of a CIL source file. Its main contents is
+ the list of global declarations and definitions. *)
+type file =
+ { mutable fileName: string; (** The complete file name *)
+ mutable globals: global list; (** List of globals as they will appear
+ in the printed file *)
+ mutable globinit: fundec option;
+ (** An optional global initializer function. This is a function where
+ * you can put stuff that must be executed before the program is
+ * started. This function, is conceptually at the end of the file,
+ * although it is not part of the globals list. Use {!Cil.getGlobInit}
+ * to create/get one. *)
+ mutable globinitcalled: bool;
+ (** Whether the global initialization function is called in main. This
+ should always be false if there is no global initializer. When
+ you create a global initialization CIL will try to insert code in
+ main to call it. *)
+ }
+
+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
+ 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
+ is the defined name and always not-empty. *)
+
+ | GCompTag of compinfo * location
+ (** Defines a struct/union tag with some fields. There must be one of
+ these for each struct/union tag that you use (through the [TComp]
+ constructor) since this is the only context in which the fields are
+ printed. Consequently nested structure tag definitions must be
+ broken into individual definitions with the innermost structure
+ defined first. *)
+
+ | GCompTagDecl of compinfo * location
+ (** Declares a struct/union tag. Use as a forward declaration. This is
+ * printed without the fields. *)
+
+ | GEnumTag of enuminfo * location
+ (** Declares an enumeration tag with some fields. There must be one of
+ these for each enumeration tag that you use (through the [TEnum]
+ constructor) since this is the only context in which the items are
+ printed. *)
+
+ | GEnumTagDecl of enuminfo * location
+ (** Declares an enumeration tag. Use as a forward declaration. This is
+ * printed without the items. *)
+
+ | GVarDecl of varinfo * location
+ (** A variable declaration (not a definition). If the variable has a
+ function type then this is a prototype. There can be several
+ declarations and at most one definition for a given variable. If both
+ forms appear then they must share the same varinfo structure. A
+ prototype shares the varinfo with the fundec of the definition. Either
+ has storage Extern or there must be a definition in this file *)
+
+ | GVar of varinfo * initinfo * location
+ (** A variable definition. Can have an initializer. The initializer is
+ * updateable so that you can change it without requiring to recreate
+ * the list of globals. There can be at most one definition for a
+ * variable in an entire program. Cannot have storage Extern or function
+ * type. *)
+
+
+ | GFun of fundec * location
+ (** A function definition. *)
+
+ | GAsm of string * location (** Global asm statement. These ones
+ can contain only a template *)
+ | GPragma of attribute * location (** Pragmas at top level. Use the same
+ syntax as attributes *)
+ | GText of string (** Some text (printed verbatim) at
+ top level. E.g., this way you can
+ put comments in the output. *)
+
+
+(** 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
+ the sign and width. *)
+ | TFloat of fkind * attributes (** A floating-point type. The kind
+ specifies the precision. *)
+
+ | 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'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
+ * 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
+ the type and which are stored in the compinfo. *)
+
+ | TEnum of enuminfo * attributes
+ (** A reference to an enumeration type. All such references must
+ share the enuminfo among them and with a [GEnumTag] global that
+ preceeds all uses. The attributes refer to this use of the
+ enumeration and are in addition to the attributes of the
+ enumeration itself, which are stored inside the enuminfo *)
+
+
+
+ | TBuiltin_va_list of attributes
+ (** This is the same as the gcc's type with the same name *)
+
+(** Various kinds of integers *)
+and ikind =
+ IChar (** [char] *)
+ | ISChar (** [signed char] *)
+ | IUChar (** [unsigned char] *)
+ | IInt (** [int] *)
+ | IUInt (** [unsigned int] *)
+ | IShort (** [short] *)
+ | IUShort (** [unsigned short] *)
+ | ILong (** [long] *)
+ | IULong (** [unsigned long] *)
+ | ILongLong (** [long long] (or [_int64] on Microsoft Visual C) *)
+ | IULongLong (** [unsigned long long] (or [unsigned _int64] on Microsoft
+ Visual C) *)
+
+(** Various kinds of floating-point numbers*)
+and fkind =
+ FFloat (** [float] *)
+ | FDouble (** [double] *)
+ | FLongDouble (** [long double] *)
+
+(** An attribute has a name and some optional parameters *)
+and attribute = Attr of string * attrparam list
+
+(** Attributes are lists sorted by the attribute name *)
+and attributes = attribute list
+
+(** The type of parameters in attributes *)
+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
+ parentheses are not printed. *)
+ | ASizeOf of typ (** A way to talk about types *)
+ | ASizeOfE of attrparam
+ | ASizeOfS of typsig (** Replacement for ASizeOf in type
+ signatures. Only used for
+ attributes inside typsigs.*)
+ | AAlignOf of typ
+ | AAlignOfE of attrparam
+ | AAlignOfS of typsig
+ | AUnOp of unop * attrparam
+ | ABinOp of binop * attrparam * attrparam
+ | ADot of attrparam * string (** a.foo **)
+ | AStar of attrparam (** * a *)
+ | AAddrOf of attrparam (** & a **)
+ | AIndex of attrparam * attrparam (** a1[a2] *)
+ | AQuestion of attrparam * attrparam * attrparam (** a1 ? a2 : a3 **)
+
+
+(** 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
+ * 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
+ * for a given key are shared. *)
+ 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
+ * compinfo. *)
+ 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
+ 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
+ * participate in initialization *)
+ mutable ftype: typ; (** The type *)
+ mutable fbitfield: int option; (** If a bitfield then ftype should be
+ an integer type *)
+ mutable fattr: attributes; (** The attributes for this field
+ * (not for its type) *)
+ mutable floc: location; (** The location where this field
+ * is defined *)
+}
+
+
+
+(** Information about an enumeration. This is shared by all references to an
+ enumeration. Make sure you have a [GEnumTag] for each of of these. *)
+and enuminfo = {
+ 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
+ values must be
+ compile-time
+ constants. *)
+ mutable eattr: attributes; (** Attributes *)
+ mutable ereferenced: bool; (** True if used. Initially set to false*)
+}
+
+(** 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 ttype: typ;
+ (** The actual type. *)
+ 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
+ * {!Cil.makeGlobalVar} to create instances of this data structure. *)
+and varinfo = {
+ mutable vname: string; (** The name of the variable. Cannot
+ * be empty. *)
+ mutable vtype: typ; (** The declared type of the
+ * variable. *)
+ mutable vattr: attributes; (** A list of attributes associated
+ * with the variable. *)
+ mutable vstorage: storage; (** The storage-class *)
+ (* 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 vdecl: location; (** Location of variable declaration *)
+
+ 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
+ * create [AddrOf] expression. *)
+
+ mutable vreferenced: bool; (** True if this variable is ever
+ referenced. This is computed by
+ [removeUnusedVars]. It is safe to
+ just initialize this to False *)
+
+ mutable vdescr: doc; (** For most temporary variables, a
+ description of what the var holds.
+ (e.g. for temporaries used for
+ function call results, this string
+ is a representation of the function
+ call.) *)
+
+ mutable vdescrpure: bool; (** Indicates whether the vdescr above
+ is a pure expression or call.
+ True for all CIL expressions and
+ Lvals, but false for e.g. function
+ calls.
+ Printing a non-pure vdescr more
+ than once may yield incorrect
+ results. *)
+}
+
+(** Storage-class information *)
+and storage =
+ NoStorage | (** The default storage. Nothing is
+ * printed *)
+ Static |
+ Register |
+ Extern
+
+
+(** Expressions (Side-effect free)*)
+and exp =
+ Const of constant (** Constant *)
+ | Lval of lval (** Lvalue *)
+ | SizeOf of typ (** sizeof(<type>). Has [unsigned
+ * int] type (ISO 6.5.3.4). This is
+ * not turned into a constant because
+ * some transformations might want to
+ * change types *)
+
+ | SizeOfE of exp (** sizeof(<expression>) *)
+ | SizeOfStr of string
+ (** sizeof(string_literal). We separate this case out because this is the
+ * only instance in which a string literal should not be treated as
+ * having type pointer to character. *)
+
+ | AlignOf of typ (** Has [unsigned int] type *)
+ | AlignOfE of exp
+
+
+ | UnOp of unop * exp * typ (** Unary operation. Includes
+ the type of the result *)
+
+ | BinOp of binop * exp * exp * typ
+ (** Binary operation. Includes the
+ type of the result. The arithemtic
+ conversions are made explicit
+ for the arguments *)
+ | CastE of typ * exp (** Use {!Cil.mkCast} to make casts *)
+
+ | AddrOf of lval (** Always use {!Cil.mkAddrOf} to
+ * construct one of these. Apply to an
+ * lvalue of type [T] yields an
+ * expression of type [TPtr(T)] *)
+
+ | StartOf of lval (** 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.
+ * 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 *") *)
+ | CChr of char (** Character constant. This has type int, so use
+ * charConstToInt to read the value in case
+ * sign-extension is needed. *)
+ | CReal of float * fkind * string option (** Floating point constant. Give
+ the fkind (see ISO 6.4.4.2) and
+ also the textual representation,
+ if available *)
+ | CEnum of 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
+ * constants. *)
+
+(** Unary operators *)
+and unop =
+ Neg (** Unary minus *)
+ | BNot (** Bitwise complement (~) *)
+ | LNot (** Logical Not (!) *)
+
+(** Binary operations *)
+and binop =
+ PlusA (** arithmetic + *)
+ | PlusPI (** pointer + integer *)
+ | IndexPI (** pointer + integer but only when
+ * it arises from an expression
+ * [e\[i\]] when [e] is a pointer and
+ * not an array. This is semantically
+ * the same as PlusPI but CCured uses
+ * this as a hint that the integer is
+ * probably positive. *)
+ | MinusA (** arithmetic - *)
+ | MinusPI (** pointer - integer *)
+ | MinusPP (** pointer - pointer *)
+ | Mult (** * *)
+ | Div (** / *)
+ | Mod (** % *)
+ | Shiftlt (** shift left *)
+ | Shiftrt (** shift right *)
+
+ | Lt (** < (arithmetic comparison) *)
+ | Gt (** > (arithmetic comparison) *)
+ | Le (** <= (arithmetic comparison) *)
+ | Ge (** > (arithmetic comparison) *)
+ | Eq (** == (arithmetic comparison) *)
+ | Ne (** != (arithmetic comparison) *)
+ | BAnd (** bitwise and *)
+ | BXor (** exclusive-or *)
+ | BOr (** inclusive-or *)
+
+ | LAnd (** logical and *)
+ | LOr (** logical or *)
+
+
+
+
+(** 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
+ (** The host is a variable. *)
+
+ | Mem of exp
+ (** The host is an object of type [T] when the expression has pointer
+ * [TPtr(T)]. *)
+
+
+(** The offset part of an {!Cil.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
+ * offsets. *)
+
+ | Field of fieldinfo * offset
+ (** A field offset. Can be applied only to an lvalue
+ * that denotes a structure or a union that contains
+ * the mentioned field. This advances the offset to the
+ * beginning of the mentioned field and changes the
+ * type to the type of the mentioned field. *)
+
+ | Index of exp * offset
+ (** An array index offset. Can be applied only to an
+ * lvalue that denotes an array. This advances the
+ * starting address of the lval to the beginning of the
+ * mentioned array element and changes the denoted type
+ * to be the type of the array element *)
+
+
+
+(* The following equivalences hold *)
+(* 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 *)
+
+(** Initializers for global variables. You can create an initializer with
+ * {!Cil.makeZeroInit}. *)
+and init =
+ | SingleInit of exp (** A single initializer *)
+ | CompoundInit of typ * (offset * init) list
+ (** Used only for initializers of structures, unions and arrays.
+ * The offsets are all of the form [Field(f, NoOffset)] or
+ * [Index(i, NoOffset)] and specify the field or the index being
+ * initialized. For structures all fields
+ * must have an initializer (except the unnamed bitfields), in
+ * the proper order. This is necessary since the offsets are not
+ * printed. For arrays the list must contain a prefix of the
+ * initializers; the rest are 0-initialized.
+ * For unions there must be exactly one initializer. If
+ * the initializer is not for the first field then a field
+ * designator is printed, so you better be on GCC since MSVC does
+ * not understand this. You can scan an initializer list with
+ * {!Cil.foldLeftCompound}. *)
+
+(** We want to be able to update an initializer in a global variable, so we
+ * define it as a mutable field *)
+and initinfo = {
+ mutable init : init option;
+ }
+
+
+(** Function definitions. *)
+and fundec =
+ { mutable svar: varinfo;
+ (** Holds the name and type as a variable, so we can refer to it
+ * easily from the program. All references to this function either
+ * in a function call or in a prototype must point to the same
+ * varinfo. *)
+ mutable sformals: varinfo list;
+ (** Formals. These must be 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
+ * 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
+ * {!Cil.computeCFGInfo}. *)
+ 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
+ one element to the next *)
+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
+ 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
+ default statement *)
+ mutable skind: stmtkind; (** The kind of statement *)
+
+ (* Now some additional control flow information. Initially this is not
+ * filled in. *)
+ 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
+ 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
+ * created by CIL or some other transformation *)
+ | Case of exp * location (** A case statement *)
+ | Default of location (** A default statement *)
+
+
+
+(* The various kinds of statements *)
+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
+ leaf in the CFG. *)
+
+ | Goto of stmt ref * location (** A goto statement. Appears from
+ actual goto's in the code. *)
+ | Break of location (** A break to the end of the nearest
+ enclosing Loop or Switch *)
+ | Continue of location (** A continue to the start of the
+ nearest enclosing [Loop] *)
+ | If of exp * block * block * location (** A conditional.
+ Two successors, the "then" and
+ the "else" branches. Both
+ branches fall-through to the
+ successor of the If statement *)
+ | Switch of exp * block * (stmt list) * location
+ (** A switch statement. 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
+ * label for this loop. *)
+
+ | 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 }
+ __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
+
+
+(** Instructions. They may cause effects directly but may not have control
+ flow.*)
+and instr =
+ Set of lval * exp * location (** An assignment. A cast is present
+ if the exp has different type
+ from lval *)
+ | Call of lval option * exp * exp list * location
+ (** optional: result is an lval. A cast might be
+ necessary if the declared result type of the
+ function is not the same as that of the
+ destination. 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
+ * are used *)
+ (* sm: I've added a notes.txt file which contains more
+ * information on interpreting Asm instructions *)
+ | Asm of attributes * (* Really only const and volatile can appear
+ * here *)
+ string list * (* templates (CR-separated) *)
+ (string option * string * lval) list *
+ (* outputs must be lvals with
+ * optional names and constraints.
+ * I would like these
+ * to be actually variables, but I
+ * run into some trouble with ASMs
+ * in the Linux sources *)
+ (string option * string * exp) list *
+ (* inputs with optional names and constraints *)
+ string list * (* register clobbers *)
+ location
+ (** An inline assembly instruction. The arguments are (1) a list of
+ attributes (only const and volatile can appear here and only for
+ GCC), (2) templates (CR-separated), (3) a list of
+ outputs, each of which is an lvalue with 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 = {
+ 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 *)
+and typsig =
+ TSArray of typsig * int64 option * attribute list
+ | TSPtr of typsig * attribute list
+ | TSComp of bool * string * attribute list
+ | TSFun of typsig * typsig list * bool * attribute list
+ | TSEnum of string * attribute list
+ | TSBase of typ
+
+
+
+(** To be able to add/remove features easily, each feature should be packaged
+ * as an interface with the following interface. These features should be *)
+type featureDescr = {
+ fd_enabled: bool ref;
+ (** The enable flag. Set to default value *)
+
+ fd_name: string;
+ (** This is used to construct an option "--doxxx" and "--dontxxx" that
+ * enable and disable the feature *)
+
+ fd_description: string;
+ (* A longer name that can be used to document the new options *)
+
+ fd_extraopt: (string * Arg.spec * string) list;
+ (** Additional command line options. The description strings should
+ usually start with a space for Arg.align to print the --help nicely. *)
+
+ fd_doit: (file -> unit);
+ (** This performs the transformation *)
+
+ fd_post_check: bool;
+ (* Whether to perform a CIL consistency checking after this stage, if
+ * checking is enabled (--check is passed to cilly) *)
+}
+
+let locUnknown = { line = -1;
+ file = "";
+ byte = -1;}
+
+(* A reference to the current location *)
+let currentLoc : location ref = ref locUnknown
+
+(* A reference to the current global being visited *)
+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
+ then namecmp
+ else
+ let linecmp = a.line - b.line in
+ if linecmp != 0
+ then linecmp
+ else a.byte - b.byte
+
+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 =
+ ref (fun _ -> E.s (E.bug "pd_exp not initialized"))
+let pd_type : (unit -> typ -> doc) ref =
+ ref (fun _ -> E.s (E.bug "pd_type not initialized"))
+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
+ the node as it is. *)
+ | DoChildren (** Continue with the children of this
+ node. Rebuild the node on return
+ if any of the children changes
+ (use == test) *)
+ | 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
+ 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
+ * one of Change... actions if you want to copy the node *)
+
+(** A visitor interface for traversing CIL trees. Create instantiations of
+ * this type by specializing the class {!Cil.nopCilVisitor}. *)
+class type cilVisitor = object
+
+ method vvdec: varinfo -> varinfo visitAction
+ (** Invoked for each variable declaration. The subtrees to be traversed
+ * are those corresponding to the type and attributes of the variable.
+ * Note that variable declarations are all the [GVar], [GVarDecl], [GFun],
+ * all the [varinfo] in formals of function types, and the formals and
+ * locals for function definitions. This means that the list of formals
+ * in a function definition will be traversed twice, once as part of the
+ * function type and second as part of the formals in a function
+ * definition. *)
+
+ method vvrbl: varinfo -> varinfo visitAction
+ (** Invoked on each variable use. Here only the [SkipChildren] and
+ * [ChangeTo] actions make sense since there are no subtrees. Note that
+ * the type and attributes of the variable are not traversed for a
+ * variable use *)
+
+ method vexpr: exp -> exp visitAction
+ (** Invoked on each expression occurence. The subtrees are the
+ * subexpressions, the types (for a [Cast] or [SizeOf] expression) or the
+ * variable use. *)
+
+ method vlval: lval -> lval visitAction
+ (** Invoked on each lvalue occurence *)
+
+ method voffs: offset -> offset visitAction
+ (** Invoked on each offset occurrence that is *not* as part
+ * of an initializer list specification, i.e. in an lval or
+ * recursively inside an offset. *)
+
+ method vinitoffs: offset -> offset visitAction
+ (** Invoked on each offset appearing in the list of a
+ * CompoundInit initializer. *)
+
+ method vinst: instr -> instr list visitAction
+ (** Invoked on each instruction occurrence. The [ChangeTo] action can
+ * replace this instruction with a list of instructions *)
+
+ method vstmt: stmt -> stmt visitAction
+ (** Control-flow statement. *)
+
+ method vblock: block -> block visitAction (** Block. Replaced in
+ place. *)
+ method vfunc: fundec -> fundec visitAction (** Function definition.
+ Replaced in place. *)
+ method vglob: global -> global list visitAction (** Global (vars, types,
+ etc.) *)
+ method vinit: varinfo -> offset -> init -> init visitAction
+ (** Initializers for globals,
+ * pass the global where this
+ * occurs, and the offset *)
+ method vtype: typ -> typ visitAction (** Use of some type. Note
+ * that for structure/union
+ * and enumeration types the
+ * definition of the
+ * composite type is not
+ * visited. Use [vglob] to
+ * visit it. *)
+ method vattr: attribute -> attribute list visitAction
+ (** Attribute. Each attribute can be replaced by a list *)
+ method vattrparam: attrparam -> attrparam visitAction
+ (** Attribute parameters. *)
+
+ (** Add here instructions while visiting to queue them to
+ * preceede the current statement or instruction being processed *)
+ method queueInstr: instr list -> unit
+
+ (** Gets the queue of instructions and resets the queue *)
+ method unqueueInstr: unit -> instr list
+
+end
+
+(* the default visitor does nothing at each node, but does *)
+(* not stop; hence they return true *)
+class nopCilVisitor : cilVisitor = object
+ method vvrbl (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
+ * 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 vblock (b: block) = DoChildren
+ method vfunc (f:fundec) = DoChildren (* function definition *)
+ method vglob (g:global) = DoChildren (* global (vars, types, etc.) *)
+ method vinit (forg: varinfo) (off: offset) (i:init) = DoChildren (* global initializers *)
+ method vtype (t:typ) = DoChildren (* use of some type *)
+ method vattr (a: attribute) = DoChildren
+ method vattrparam (a: attrparam) = DoChildren
+
+ val mutable instrQueue = []
+
+ method queueInstr (il: instr list) =
+ List.iter (fun i -> instrQueue <- i :: instrQueue) il
+
+ method unqueueInstr () =
+ let res = List.rev instrQueue in
+ instrQueue <- [];
+ res
+
+end
+
+let assertEmptyQueue vis =
+ if vis#unqueueInstr () <> [] then
+ (* Either a visitor inserted an instruction somewhere that it shouldn't
+ have (i.e. at the top level rather than inside of a statement), or
+ there's a bug in the visitor engine. *)
+ E.s (E.bug "Visitor's instruction queue is not empty.\n You should only use queueInstr inside a function body!");
+ ()
+
+
+let lu = locUnknown
+
+(* sm: utility *)
+let startsWith (prefix: string) (s: string) : bool =
+(
+ let prefixLen = (String.length prefix) in
+ (String.length s) >= prefixLen &&
+ (String.sub s 0 prefixLen) = prefix
+)
+
+let endsWith (suffix: string) (s: string) : bool =
+ let suffixLen = String.length suffix in
+ let sLen = String.length s in
+ sLen >= suffixLen &&
+ (String.sub s (sLen - suffixLen) suffixLen) = suffix
+
+let stripUnderscores (s: string) : string =
+ if (startsWith "__" s) && (endsWith "__" s) then
+ String.sub s 2 ((String.length s) - 4)
+ else
+ s
+
+let get_instrLoc (inst : instr) =
+ match inst with
+ Set(_, _, loc) -> loc
+ | Call(_, _, _, loc) -> loc
+ | Asm(_, _, _, _, _, 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)
+ | GVar(_,_,l) -> (l)
+ | GAsm(_,l) -> (l)
+ | GPragma(_,l) -> (l)
+ | GText(_) -> locUnknown
+
+let rec get_stmtLoc (statement : stmtkind) =
+ match statement with
+ Instr([]) -> lu
+ | Instr(hd::tl) -> get_instrLoc(hd)
+ | Return(_, loc) -> loc
+ | Goto(_, loc) -> loc
+ | Break(loc) -> loc
+ | Continue(loc) -> loc
+ | If(_, _, _, loc) -> loc
+ | Switch (_, _, _, loc) -> loc
+ | Loop (_, loc, _, _) -> loc
+ | Block b -> if b.bstmts == [] then lu
+ else get_stmtLoc ((List.hd b.bstmts).skind)
+ | TryFinally (_, _, l) -> l
+ | TryExcept (_, _, _, l) -> l
+
+
+(* The next variable identifier to use. Counts up *)
+let nextGlobalVID = ref 1
+
+(* The next compindo identifier to use. Counts up. *)
+let nextCompinfoKey = ref 1
+
+(* Some error reporting functions *)
+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@!"
+ 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@!"
+ 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@!"
+ 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@!"
+ d_loc loc insert d);
+ E.showContext ();
+ nil
+ in
+ Pretty.gprintf f fmt
+
+let warn (fmt : ('a,unit,doc) format) : 'a =
+ let f d =
+ ignore (eprintf "@!%t: Warning: %a@!"
+ d_thisloc insert d);
+ nil
+ in
+ Pretty.gprintf f fmt
+
+
+let warnOpt (fmt : ('a,unit,doc) format) : 'a =
+ let f d =
+ 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 f d =
+ 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 f d =
+ 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 f d =
+ ignore (eprintf "@!%a: Warning: %a@!"
+ d_loc loc insert d);
+ E.showContext ();
+ nil
+ in
+ Pretty.gprintf f fmt
+
+
+
+(* Construct an integer. Use only for values that fit on 31 bits.
+ For larger values, use kinteger *)
+let integer (i: int) = Const (CInt64(Int64.of_int i, IInt, None))
+
+let zero = integer 0
+let one = integer 1
+let mone = integer (-1)
+
+(** Given the character c in a (CChr c), sign-extend it to 32 bits.
+ (This is the official way of interpreting character constants, according to
+ ISO C 6.4.4.4.10, which says that character constants are chars cast to ints)
+ Returns CInt64(sign-extened c, IInt, None) *)
+let charConstToInt (c: char) : constant =
+ let c' = Char.code c in
+ let value =
+ if c' < 128
+ then Int64.of_int c'
+ else Int64.of_int (c' - 256)
+ in
+ CInt64(value, IInt, None)
+
+
+let rec isInteger : exp -> int64 option = function
+ | Const(CInt64 (n,_,_)) -> Some n
+ | Const(CChr c) -> isInteger (Const (charConstToInt c)) (* sign-extend *)
+ | Const(CEnum(v, s, ei)) -> isInteger v
+ | CastE(_, e) -> isInteger e
+ | _ -> None
+
+
+(** Convert a 64-bit int to an OCaml int, or raise an exception if that
+ can't be done. *)
+let i64_to_int (i: int64) : int =
+ let i': int = Int64.to_int i in (* i.e. i' = i mod 2^31 *)
+ if i = Int64.of_int i' then i'
+ else E.s (E.unimp "%a: Int constant too large: %Ld\n" d_loc !currentLoc i)
+
+
+let rec isZero (e: exp) : bool = isInteger e = Some Int64.zero
+
+let voidType = TVoid([])
+let intType = TInt(IInt,[])
+let uintType = TInt(IUInt,[])
+let longType = TInt(ILong,[])
+let ulongType = TInt(IULong,[])
+let charType = TInt(IChar, [])
+
+let charPtrType = TPtr(charType,[])
+let charConstPtrType = TPtr(TInt(IChar, [Attr("const", [])]),[])
+let stringLiteralType = ref charPtrType
+
+let voidPtrType = TPtr(voidType, [])
+let intPtrType = TPtr(intType, [])
+let uintPtrType = TPtr(uintType, [])
+
+let doubleType = TFloat(FDouble, [])
+
+
+(* An integer type that fits pointers. Initialized by initCIL *)
+let upointType = ref voidType
+
+(* An integer type that fits wchar_t. Initialized by initCIL *)
+let wcharKind = ref IChar
+let wcharType = ref voidType
+
+
+(* An integer type that is the type of sizeof. Initialized by initCIL *)
+let typeOfSizeOf = ref voidType
+let kindOfSizeOf = ref IUInt
+
+let initCIL_called = ref false
+
+(** Returns true if and only if the given integer type is signed. *)
+let isSigned = function
+ | IUChar
+ | IUShort
+ | IUInt
+ | IULong
+ | IULongLong ->
+ false
+ | ISChar
+ | IShort
+ | IInt
+ | ILong
+ | ILongLong ->
+ true
+ | IChar ->
+ not !M.theMachine.M.char_is_unsigned
+
+let mkStmt (sk: stmtkind) : stmt =
+ { skind = sk;
+ labels = [];
+ sid = -1; succs = []; preds = [] }
+
+let mkBlock (slst: stmt list) : block =
+ { battrs = []; bstmts = slst; }
+
+let mkEmptyStmt () = mkStmt (Instr [])
+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
+ * instructions in it. *)
+ let rec compress (lastinstrstmt: stmt) (* Might be dummStmt *)
+ (lastinstrs: instr Clist.clist)
+ (body: 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
+ [] -> finishLast []
+ | ({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)
+
+ | s :: rest ->
+ let res = s :: compress dummyStmt Clist.empty rest in
+ finishLast res
+ in
+ compress dummyStmt Clist.empty b
+
+
+(** Construct sorted lists of attributes ***)
+let rec addAttribute (Attr(an, _) as a: attribute) (al: attributes) =
+ let rec insertSorted = function
+ [] -> [a]
+ | ((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
+ * this name *)
+ in
+ insertSorted al
+
+(** The second attribute list is sorted *)
+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) =
+ List.filter (fun (Attr(an', _)) -> an <> an') al
+
+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 =
+ List.filter (fun (Attr(an, _)) -> an = s) al
+
+(* sm: *)
+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
+ * specifier *)
+ | AttrFunType of bool
+ (* Attribute of a function type. If argument is true and we are on
+ * MSVC then the attribute is printed just before the function name *)
+
+ | AttrType (* Attribute of a type *)
+
+(* This table contains the mapping of predefined attributes to classes.
+ * Extend this table with more attributes as you need. This table is used to
+ * determine how to associate attributes with names or type during cabs2cil
+ * conversion *)
+let attributeHash: (string, attributeClass) H.t =
+ let table = H.create 13 in
+ List.iter (fun a -> H.add table a (AttrName false))
+ [ "section"; "constructor"; "destructor"; "unused"; "used"; "weak";
+ "no_instrument_function"; "alias"; "no_check_memory_usage";
+ "exception"; "model"; (* "restrict"; *)
+ "aconst"; "__asm__" (* Gcc uses this to specifiy the name to be used in
+ * assembly for a global *)];
+
+ (* Now come the MSVC declspec attributes *)
+ List.iter (fun a -> H.add table a (AttrName true))
+ [ "thread"; "naked"; "dllimport"; "dllexport";
+ "selectany"; "allocate"; "nothrow"; "novtable"; "property"; "noreturn";
+ "uuid"; "align" ];
+
+ List.iter (fun a -> H.add table a (AttrFunType false))
+ [ "format"; "regparm"; "longcall";
+ "noinline"; "always_inline"; ];
+
+ List.iter (fun a -> H.add table a (AttrFunType true))
+ [ "stdcall";"cdecl"; "fastcall" ];
+
+ List.iter (fun a -> H.add table a AttrType)
+ [ "const"; "volatile"; "restrict"; "mode" ];
+ table
+
+
+(* Partition the attributes into classes *)
+let partitionAttributes
+ ~(default:attributeClass)
+ (attrs: attribute list) :
+ attribute list * attribute list * attribute list =
+ let rec loop (n,f,t) = function
+ [] -> n, f, t
+ | (Attr(an, _) as a) :: rest ->
+ match (try H.find attributeHash an with Not_found -> default) with
+ AttrName _ -> loop (addAttribute a n, f, t) rest
+ | AttrFunType _ ->
+ loop (n, addAttribute a f, t) rest
+ | AttrType -> loop (n, f, addAttribute a t) rest
+ in
+ loop ([], [], []) attrs
+
+
+(* Get the full name of a comp *)
+let compFullName comp =
+ (if comp.cstruct then "struct " else "union ") ^ comp.cname
+
+
+let missingFieldName = "___missing_field_name"
+
+(** Creates a 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
+ * constructing a recursive type. *)
+ (mkfspec: compinfo -> (string * typ * int option * attribute list *
+ location) list)
+ (a: attribute list) : compinfo =
+
+ (* make a new name for anonymous structs *)
+ if n = "" then
+ E.s (E.bug "mkCompInfo: missing structure name\n");
+ (* Make a new self cell and a forward reference *)
+ let comp =
+ { cstruct = isstruct; cname = ""; ckey = 0; cfields = [];
+ cattr = a; creferenced = false;
+ (* Make this compinfo undefined by default *)
+ cdefined = false; }
+ in
+ comp.cname <- n;
+ comp.ckey <- !nextCompinfoKey;
+ incr nextCompinfoKey;
+ let flds =
+ List.map (fun (fn, ft, fb, fa, fl) ->
+ { fcomp = comp;
+ ftype = ft;
+ fname = fn;
+ fbitfield = fb;
+ fattr = fa;
+ floc = fl}) (mkfspec comp) in
+ comp.cfields <- flds;
+ if flds <> [] then comp.cdefined <- true;
+ comp
+
+(** Make a copy of a compinfo, changing the name and the key *)
+let copyCompInfo (ci: compinfo) (n: string) : compinfo =
+ let ci' = {ci with cname = n;
+ ckey = !nextCompinfoKey; } in
+ incr nextCompinfoKey;
+ (* Copy the fields and set the new pointers to parents *)
+ ci'.cfields <- List.map (fun f -> {f with fcomp = ci'}) ci'.cfields;
+ ci'
+
+(**** Utility functions ******)
+
+let rec typeAttrs = function
+ TVoid a -> a
+ | TInt (_, a) -> a
+ | TFloat (_, a) -> a
+ | TNamed (t, a) -> addAttributes a (typeAttrs t.ttype)
+ | TPtr (_, a) -> a
+ | TArray (_, _, a) -> a
+ | TComp (comp, a) -> addAttributes comp.cattr a
+ | TEnum (enum, a) -> addAttributes enum.eattr a
+ | TFun (_, _, _, a) -> a
+ | TBuiltin_va_list a -> a
+
+
+let setTypeAttrs t a =
+ match t with
+ TVoid _ -> TVoid a
+ | TInt (i, _) -> TInt (i, a)
+ | TFloat (f, _) -> TFloat (f, a)
+ | TNamed (t, _) -> TNamed(t, a)
+ | TPtr (t', _) -> TPtr(t', a)
+ | TArray (t', l, _) -> TArray(t', l, a)
+ | TComp (comp, _) -> TComp (comp, a)
+ | TEnum (enum, _) -> TEnum (enum, a)
+ | TFun (r, args, v, _) -> TFun(r,args,v,a)
+ | TBuiltin_va_list _ -> TBuiltin_va_list a
+
+
+let typeAddAttributes a0 t =
+begin
+ match a0 with
+ | [] ->
+ (* no attributes, keep same type *)
+ t
+ | _ ->
+ (* anything else: add a0 to existing attributes *)
+ let add (a: attributes) = addAttributes a0 a in
+ match t with
+ TVoid a -> TVoid (add a)
+ | TInt (ik, a) -> TInt (ik, add a)
+ | TFloat (fk, a) -> TFloat (fk, add a)
+ | TEnum (enum, a) -> TEnum (enum, add a)
+ | TPtr (t, a) -> TPtr (t, add a)
+ | TArray (t, l, 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)
+end
+
+let typeRemoveAttributes (anl: string list) t =
+ let drop (al: attributes) = dropAttributes anl al in
+ match t with
+ TVoid a -> TVoid (drop a)
+ | TInt (ik, a) -> TInt (ik, drop a)
+ | TFloat (fk, a) -> TFloat (fk, drop a)
+ | TEnum (enum, a) -> TEnum (enum, drop a)
+ | TPtr (t, a) -> TPtr (t, drop a)
+ | TArray (t, l, a) -> TArray (t, l, drop a)
+ | TFun (t, args, isva, a) -> TFun(t, args, isva, drop a)
+ | TComp (comp, a) -> TComp (comp, drop a)
+ | 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
+ 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
+ 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
+ None -> None
+ | Some argl ->
+ Some (List.map (fun (an,at,aa) ->
+ (an, unrollTypeDeep at, aa)) argl)),
+ isva,
+ addAttributes al a')
+ | x -> typeAddAttributes al x
+ in
+ withAttrs [] t
+
+let isVoidType t =
+ match unrollType t with
+ TVoid _ -> true
+ | _ -> false
+let isVoidPtrType t =
+ match unrollType t with
+ TPtr(tau,_) when isVoidType tau -> true
+ | _ -> false
+
+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 =
+ (* Do it like this so that the pretty printer recognizes it *)
+ [ 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 mkForIncr ~(iter : varinfo) ~(first: exp) ~stopat:(past: exp) ~(incr: exp)
+ ~(body: stmt list) : stmt list =
+ (* See what kind of operator we need *)
+ let compop, nextop =
+ match 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,
+ (BinOp(nextop, Lval(var iter), incr, iter.vtype)),
+ lu))])]
+ body
+
+
+let rec stripCasts (e: exp) =
+ match e with CastE(_, e') -> stripCasts e' | _ -> e
+
+
+
+(* the name of the C function we call to get ccgr ASTs
+external parse : string -> file = "cil_main"
+*)
+(*
+ Pretty Printing
+ *)
+
+let d_ikind () = function
+ IChar -> text "char"
+ | ISChar -> text "signed char"
+ | IUChar -> text "unsigned char"
+ | IInt -> text "int"
+ | IUInt -> text "unsigned int"
+ | IShort -> text "short"
+ | IUShort -> text "unsigned short"
+ | ILong -> text "long"
+ | IULong -> text "unsigned long"
+ | ILongLong ->
+ if !msvcMode then text "__int64" else text "long long"
+ | 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"
+
+let d_storage () = function
+ NoStorage -> nil
+ | Static -> text "static "
+ | Extern -> text "extern "
+ | Register -> text "register "
+
+(* sm: need this value below *)
+let mostNeg32BitInt : int64 = (Int64.of_string "-0x80000000")
+let mostNeg64BitInt : int64 = (Int64.of_string "-0x8000000000000000")
+
+(* constant *)
+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
+ * constants this is done with a suffix, for others with a cast prefix.*)
+ let suffix : string =
+ match ik with
+ IUInt -> "U"
+ | ILong -> "L"
+ | IULong -> "UL"
+ | ILongLong -> if !msvcMode then "L" else "LL"
+ | IULongLong -> if !msvcMode then "UL" else "ULL"
+ | _ -> ""
+ in
+ let prefix : string =
+ if suffix <> "" then ""
+ else if ik = IInt then ""
+ else "(" ^ (sprint !lineLength (d_ikind () ik)) ^ ")"
+ in
+ (* Watch out here for negative integers that we should be printing as
+ * large positive ones *)
+ if i < Int64.zero
+ && (match ik with
+ IUInt | IULong | IULongLong | IUChar | IUShort -> true | _ -> false) then
+ let high = Int64.shift_right i 32 in
+ if ik <> IULongLong && ik <> ILongLong && high = Int64.of_int (-1) then
+ (* Print only the low order 32 bits *)
+ text (prefix ^ "0x" ^
+ (Int64.format "%x"
+ (Int64.logand i (Int64.shift_right_logical high 32))
+ ^ suffix))
+ else
+ text (prefix ^ "0x" ^ Int64.format "%x" i ^ suffix)
+ else (
+ if (i = mostNeg32BitInt) then
+ (* sm: quirk here: if you print -2147483648 then this is two tokens *)
+ (* in C, and the second one is too large to represent in a signed *)
+ (* int.. so we do what's done in limits.h, and print (-2147483467-1); *)
+ (* in gcc this avoids a warning, but it might avoid a real problem *)
+ (* on another compiler or a 64-bit architecture *)
+ text (prefix ^ "(-0x7FFFFFFF-1)")
+ else if (i = mostNeg64BitInt) then
+ (* The same is true of the largest 64-bit negative. *)
+ text (prefix ^ "(-0x7FFFFFFFFFFFFFFF-1)")
+ else
+ text (prefix ^ (Int64.to_string i ^ suffix))
+ )
+
+ | CStr(s) -> text ("\"" ^ escape_string s ^ "\"")
+ | CWStr(s) ->
+ (* text ("L\"" ^ escape_string s ^ "\"") *)
+ (List.fold_left (fun acc elt ->
+ acc ++
+ if (elt >= Int64.zero &&
+ elt <= (Int64.of_int 255)) then
+ text (escape_char (Char.chr (Int64.to_int elt)))
+ else
+ ( text (Printf.sprintf "\\x%LX\"" elt) ++ break ++
+ (text "\""))
+ ) (text "L\"") s ) ++ text "\""
+ (* we cannot print L"\xabcd" "feedme" as L"\xabcdfeedme" --
+ * the former has 7 wide characters and the later has 3. *)
+
+ | CChr(c) -> text ("'" ^ escape_char c ^ "'")
+ | CReal(_, _, Some s) -> text s
+ | CReal(f, fsize, None) ->
+ text (string_of_float f) ++
+ (match fsize with
+ FFloat -> chr 'f'
+ | FDouble -> nil
+ | FLongDouble -> chr 'L')
+ | 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
+ * MUST correspond to a stronger precedence! *)
+let derefStarLevel = 20
+let indexLevel = 20
+let arrowLevel = 20
+let addrOfLevel = 30
+let additiveLevel = 60
+let comparativeLevel = 70
+let bitwiseLevel = 75
+let questionLevel = 100
+let getParenthLevel (e: exp) =
+ match e with
+ | BinOp((LAnd | LOr), _,_,_) -> 80
+ (* Bit operations. *)
+ | BinOp((BOr|BXor|BAnd),_,_,_) -> bitwiseLevel (* 75 *)
+
+ (* Comparisons *)
+ | BinOp((Eq|Ne|Gt|Lt|Ge|Le),_,_,_) ->
+ comparativeLevel (* 70 *)
+ (* Additive. Shifts can have higher
+ * level than + or - but I want
+ * parentheses around them *)
+ | BinOp((MinusA|MinusPP|MinusPI|PlusA|
+ PlusPI|IndexPI|Shiftlt|Shiftrt),_,_,_)
+ -> additiveLevel (* 60 *)
+
+ (* Multiplicative *)
+ | BinOp((Div|Mod|Mult),_,_,_) -> 40
+
+ (* Unary *)
+ | CastE(_,_) -> 30
+ | AddrOf(_) -> 30
+ | StartOf(_) -> 30
+ | UnOp((Neg|BNot|LNot),_,_) -> 30
+
+ (* Lvals *)
+ | Lval(Mem _ , _) -> derefStarLevel (* 20 *)
+ | Lval(Var _, (Field _|Index _)) -> indexLevel (* 20 *)
+ | SizeOf _ | SizeOfE _ | SizeOfStr _ -> 20
+ | AlignOf _ | AlignOfE _ -> 20
+
+ | Lval(Var _, NoOffset) -> 0 (* Plain variables *)
+ | Const _ -> 0 (* Constants *)
+
+
+let getParenthLevelAttrParam (a: attrparam) =
+ (* Create an expression of the same shape, and use {!getParenthLevel} *)
+ match a with
+ AInt _ | AStr _ | ACons _ -> 0
+ | ASizeOf _ | ASizeOfE _ | ASizeOfS _ -> 20
+ | AAlignOf _ | AAlignOfE _ | AAlignOfS _ -> 20
+ | AUnOp (uo, _) -> getParenthLevel (UnOp(uo, zero, intType))
+ | ABinOp (bo, _, _) -> getParenthLevel (BinOp(bo, zero, zero, intType))
+ | AAddrOf _ -> 30
+ | ADot _ | AIndex _ | AStar _ -> 20
+ | AQuestion _ -> questionLevel
+
+
+(* Separate out the storage-modifier name attributes *)
+let separateStorageModifiers (al: attribute list) =
+ let isstoragemod (Attr(an, _): attribute) : bool =
+ try
+ match H.find attributeHash an with
+ AttrName issm -> issm
+ | _ -> false
+ with Not_found -> false
+ in
+ let stom, rest = List.partition isstoragemod al in
+ if not !msvcMode then
+ stom, rest
+ else
+ (* Put back the declspec. Put it without the leading __ since these will
+ * be added later *)
+ let stom' =
+ List.map (fun (Attr(an, args)) ->
+ Attr("declspec", [ACons(an, args)])) stom in
+ stom', rest
+
+
+let isIntegralType t =
+ match unrollType t with
+ (TInt _ | TEnum _) -> true
+ | _ -> false
+
+let isArithmeticType t =
+ match unrollType t with
+ (TInt _ | TEnum _ | TFloat _) -> true
+ | _ -> false
+
+
+let isPointerType t =
+ match unrollType t with
+ TPtr _ -> true
+ | _ -> false
+
+let isFunctionType t =
+ match unrollType t with
+ TFun _ -> true
+ | _ -> false
+
+(**** Compute the type of an expression ****)
+let rec typeOf (e: exp) : typ =
+ match e with
+ | Const(CInt64 (_, ik, _)) -> TInt(ik, [])
+
+ (* Character constants have type int. ISO/IEC 9899:1999 (E),
+ * section 6.4.4.4 [Character constants], paragraph 10, if you
+ * don't believe me. *)
+ | Const(CChr _) -> intType
+
+ (* The type of a string is a pointer to characters ! The only case when
+ * you would want it to be an array is as an argument to sizeof, but we
+ * have SizeOfStr for that *)
+ | Const(CStr s) -> !stringLiteralType
+
+ | Const(CWStr s) -> TPtr(!wcharType,[])
+
+ | Const(CReal (_, fk, _)) -> TFloat(fk, [])
+
+ | Const(CEnum(_, _, ei)) -> TEnum(ei, [])
+
+ | Lval(lv) -> typeOfLval lv
+ | SizeOf _ | SizeOfE _ | SizeOfStr _ -> !typeOfSizeOf
+ | AlignOf _ | AlignOfE _ -> !typeOfSizeOf
+ | UnOp (_, _, t) -> t
+ | BinOp (_, _, _, t) -> t
+ | CastE (t, _) -> t
+ | AddrOf (lv) -> TPtr(typeOfLval lv, [])
+ | StartOf (lv) -> begin
+ match unrollType (typeOfLval lv) with
+ TArray (t,_, a) -> TPtr(t, a)
+ | _ -> E.s (E.bug "typeOf: StartOf on a non-array")
+ end
+
+and typeOfInit (i: init) : typ =
+ match i with
+ SingleInit e -> typeOf e
+ | CompoundInit (t, _) -> t
+
+and typeOfLval = function
+ Var vi, off -> typeOffset vi.vtype off
+ | Mem addr, off -> begin
+ match unrollType (typeOf addr) with
+ TPtr (t, _) -> typeOffset t off
+ | _ -> E.s (bug "typeOfLval: Mem on a non-pointer (%a)" !pd_exp addr)
+ end
+
+and typeOffset basetyp =
+ let blendAttributes baseAttrs =
+ let (_, _, contageous) =
+ partitionAttributes ~default:(AttrName false) baseAttrs in
+ typeAddAttributes contageous
+ in
+ function
+ NoOffset -> basetyp
+ | Index (_, o) -> begin
+ match unrollType basetyp with
+ TArray (t, _, baseAttrs) ->
+ let elementType = typeOffset t o in
+ blendAttributes baseAttrs elementType
+ | t -> E.s (E.bug "typeOffset: Index on a non-array")
+ end
+ | Field (fi, o) ->
+ match unrollType basetyp with
+ TComp (_, baseAttrs) ->
+ let fieldType = typeOffset fi.ftype o in
+ blendAttributes baseAttrs fieldType
+ | _ -> E.s (bug "typeOffset: Field on a non-compound")
+
+
+(**
+ **
+ ** MACHINE DEPENDENT PART
+ **
+ **)
+exception SizeOfError of string * typ
+
+
+let bytesSizeOfInt (ik: ikind): int =
+ match ik with
+ | IChar | ISChar | IUChar -> 1
+ | IInt | IUInt -> !M.theMachine.M.sizeof_int
+ | IShort | IUShort -> !M.theMachine.M.sizeof_short
+ | ILong | IULong -> !M.theMachine.M.sizeof_long
+ | ILongLong | IULongLong -> !M.theMachine.M.sizeof_longlong
+
+let unsignedVersionOf (ik:ikind): ikind =
+ match ik with
+ | ISChar | IChar -> IUChar
+ | IShort -> IUShort
+ | IInt -> IUInt
+ | ILong -> IULong
+ | ILongLong -> IULongLong
+ | _ -> ik
+
+let intKindForSize (s:int) =
+ (* Test the most common sizes first *)
+ if s = 1 then ISChar
+ else if s = !M.theMachine.M.sizeof_int then IInt
+ else if s = !M.theMachine.M.sizeof_long then ILong
+ else if s = !M.theMachine.M.sizeof_short then IShort
+ else if s = !M.theMachine.M.sizeof_longlong then ILongLong
+ else raise Not_found
+
+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
+ else raise Not_found
+
+(* 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 nrBits = 8 * (bytesSizeOfInt k) in
+ let signed = isSigned k in
+ 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)
+ else Int64.shift_right_logical i1 (64 - nrBits)
+ in
+ let truncated =
+ if i2 = i then false
+ else
+ (* Examine the bits that we chopped off. If they are all zero, then
+ * any difference between i2 and i is due to a simple sign-extension.
+ * e.g. casting the constant 0x80000000 to int makes it
+ * 0xffffffff80000000.
+ * Suppress the truncation warning in this case. *)
+ let chopped = Int64.shift_right i (64 - 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
+ unsigned value. While potentially a bug, this is almost
+ always what the programmer intended. *)
+ && chopped <> Int64.minus_one
+ in
+ i2, truncated
+ end
+
+(* Construct an integer constant with possible truncation *)
+let kinteger64 (k: ikind) (i: int64) : exp =
+ let i', truncated = truncateInteger64 k i in
+ if truncated && !warnTruncate then
+ ignore (warnOpt "Truncating integer %s to %s\n"
+ (Int64.format "0x%x" i) (Int64.format "0x%x" i'));
+ Const (CInt64(i', k, None))
+
+(* Construct an integer of a given kind. *)
+let kinteger (k: ikind) (i: int) = kinteger64 k (Int64.of_int i)
+
+(* Convert 2 integer constants to integers with the same type, in preparation
+ for a binary operation. See ISO C 6.3.1.8p1 *)
+let convertInts (i1:int64) (ik1:ikind) (i2:int64) (ik2:ikind)
+ : int64 * int64 * ikind =
+ if ik1 = ik2 then (* nothing to do *)
+ i1, i2, ik1
+ else begin
+ let rank : ikind -> int = function
+ (* these are just unique numbers representing the integer
+ conversion rank. *)
+ | IChar | ISChar | IUChar -> 1
+ | IShort | IUShort -> 2
+ | IInt | IUInt -> 3
+ | ILong | IULong -> 4
+ | ILongLong | IULongLong -> 5
+ in
+ let r1 = rank ik1 in
+ let r2 = rank ik2 in
+ let ik' =
+ if (isSigned ik1) = (isSigned ik2) then begin
+ (* Both signed or both unsigned. *)
+ if r1 > r2 then ik1 else ik2
+ end
+ else begin
+ let signedKind, unsignedKind, signedRank, unsignedRank =
+ if isSigned ik1 then ik1, ik2, r1, r2 else ik2, ik1, r2, r1
+ in
+ (* The rules for signed + unsigned get hairy.
+ (unsigned short + long) is converted to signed long,
+ but (unsigned int + long) is converted to unsigned long.*)
+ if unsignedRank >= signedRank then unsignedKind
+ else if (bytesSizeOfInt signedKind) > (bytesSizeOfInt unsignedKind) then
+ signedKind
+ else
+ unsignedVersionOf signedKind
+ end
+ in
+ let i1',_ = truncateInteger64 ik' i1 in
+ let i2',_ = truncateInteger64 ik' i2 in
+ i1', i2', ik'
+ end
+
+
+type offsetAcc =
+ { oaFirstFree: int; (* The first free bit *)
+ oaLastFieldStart: int; (* Where the previous field started *)
+ oaLastFieldWidth: int; (* The width of the previous field. Might not
+ * be same as FirstFree - FieldStart because
+ * of internal padding *)
+ oaPrevBitPack: (int * ikind * int) option; (* If the previous fields
+ * were packed bitfields,
+ * the bit where packing
+ * has started, the ikind
+ * of the bitfield and the
+ * width of the ikind *)
+ }
+
+(* Hack to prevent infinite recursion in alignments *)
+let ignoreAlignmentAttrs = ref false
+
+(* Get the minimum aligment in bytes for a given type *)
+let rec alignOf_int t =
+ let alignOfType () =
+ match t with
+ | TInt((IChar|ISChar|IUChar), _) -> 1
+ | TInt((IShort|IUShort), _) -> !M.theMachine.M.alignof_short
+ | TInt((IInt|IUInt), _) -> !M.theMachine.M.alignof_int
+ | TInt((ILong|IULong), _) -> !M.theMachine.M.alignof_long
+ | TInt((ILongLong|IULongLong), _) -> !M.theMachine.M.alignof_longlong
+ | TEnum _ -> !M.theMachine.M.alignof_enum
+ | TFloat(FFloat, _) -> !M.theMachine.M.alignof_float
+ | TFloat(FDouble, _) -> !M.theMachine.M.alignof_double
+ | TFloat(FLongDouble, _) -> !M.theMachine.M.alignof_longdouble
+ | 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 *)
+ let rec dropZeros (afterbitfield: bool) = function
+ | f :: rest when f.fbitfield = Some 0 && not afterbitfield ->
+ dropZeros afterbitfield rest
+ | f :: rest -> f :: dropZeros (f.fbitfield <> None) rest
+ | [] -> []
+ in
+ let fields = dropZeros false c.cfields in
+ List.fold_left
+ (fun sofar f ->
+ (* Bitfields with zero width do not contribute to the alignment in
+ * GCC *)
+ if not !msvcMode && f.fbitfield = Some 0 then sofar else
+ max sofar (alignOfField f)) 1 fields
+ (* These are some error cases *)
+ | TFun _ when not !msvcMode -> !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\n"
+ (!pd_type) t);
+ alignOfType ()
+ | (Attr(_, [a]) as at)::rest -> begin
+ if rest <> [] then
+ ignore (warn "ignoring duplicate align attributes on %a\n"
+ (!pd_type) t);
+ match intOfAttrparam a with
+ Some n -> n
+ | None ->
+ ignore (warn "alignment attribute \"%a\" not understood on %a"
+ (!pd_attr) at (!pd_type) t);
+ alignOfType ()
+ end
+ | Attr(_, [])::rest ->
+ (* aligned with no arg means a power of two at least as large as
+ any alignment on the system.*)
+ if rest <> [] then
+ ignore(warn "ignoring duplicate align attributes on %a\n"
+ (!pd_type) t);
+ !M.theMachine.M.alignof_aligned
+ | at::_ ->
+ 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
+ || hasAttribute "packed" fi.fcomp.cattr in
+ if fieldIsPacked then 1
+ else alignOf_int fi.ftype
+
+and intOfAttrparam (a:attrparam) : int option =
+ let rec doit a : int =
+ match a with
+ AInt(n) -> n
+ | ABinOp(Shiftlt, a1, a2) -> (doit a1) lsl (doit a2)
+ | ABinOp(Div, a1, a2) -> (doit a1) / (doit a2)
+ | ASizeOf(t) ->
+ let bs = bitsSizeOf t in
+ bs / 8
+ | AAlignOf(t) ->
+ alignOf_int t
+ | _ -> raise (SizeOfError ("", voidType))
+ in
+ (* Use ignoreAlignmentAttrs here to prevent stack overflow if a buggy
+ program does something like
+ struct s {...} __attribute__((aligned(sizeof(struct s))))
+ This is too conservative, but it's often enough.
+ *)
+ assert (not !ignoreAlignmentAttrs);
+ ignoreAlignmentAttrs := true;
+ try
+ let n = doit a in
+ ignoreAlignmentAttrs := false;
+ Some n
+ with SizeOfError _ -> (* Can't compile *)
+ ignoreAlignmentAttrs := false;
+ None
+
+
+(* GCC version *)
+(* Does not use the sofar.oaPrevBitPack *)
+and offsetOfFieldAcc_GCC
+ (fi: fieldinfo)
+ (sofar: offsetAcc) : offsetAcc =
+ (* field type *)
+ let ftype = unrollType fi.ftype in
+ let ftypeAlign = 8 * alignOfField fi in
+ let ftypeBits = bitsSizeOf ftype in
+ match ftype, fi.fbitfield with
+ (* A width of 0 means that we must end the current packing. It seems that
+ * GCC pads only up to the alignment boundary for the type of this field.
+ * *)
+ | _, Some 0 ->
+ let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in
+ { oaFirstFree = firstFree;
+ oaLastFieldStart = firstFree;
+ oaLastFieldWidth = 0;
+ oaPrevBitPack = None }
+
+ (* A bitfield cannot span more alignment boundaries of its type than the
+ * type itself *)
+ | _, Some wdthis
+ when (sofar.oaFirstFree + wdthis + ftypeAlign - 1) / ftypeAlign
+ - sofar.oaFirstFree / ftypeAlign > ftypeBits / ftypeAlign ->
+ let start = addTrailing sofar.oaFirstFree ftypeAlign in
+ { oaFirstFree = start + wdthis;
+ oaLastFieldStart = start;
+ oaLastFieldWidth = wdthis;
+ oaPrevBitPack = None }
+
+ (* Try a simple method. Just put the field down *)
+ | _, Some wdthis ->
+ { oaFirstFree = sofar.oaFirstFree + wdthis;
+ oaLastFieldStart = sofar.oaFirstFree;
+ oaLastFieldWidth = wdthis;
+ oaPrevBitPack = None
+ }
+
+ (* Non-bitfield *)
+ | _, None ->
+ (* Align this field *)
+ let newStart = addTrailing sofar.oaFirstFree ftypeAlign in
+ { oaFirstFree = newStart + ftypeBits;
+ oaLastFieldStart = newStart;
+ oaLastFieldWidth = ftypeBits;
+ oaPrevBitPack = None;
+ }
+
+(* MSVC version *)
+and offsetOfFieldAcc_MSVC (fi: fieldinfo)
+ (sofar: offsetAcc) : offsetAcc =
+ (* field type *)
+ let ftype = unrollType fi.ftype in
+ let ftypeAlign = 8 * 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
+ d_type ftype
+ insert
+ (match fi.fbitfield with
+ None -> nil
+ | Some wdthis -> dprintf ":%d" wdthis)
+ sofar.oaFirstFree
+ insert
+ (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 ->
+ let firstFree = sofar.oaFirstFree in
+ { oaFirstFree = firstFree;
+ oaLastFieldStart = firstFree;
+ oaLastFieldWidth = 0;
+ oaPrevBitPack = None }
+
+ (* If we are in a bitpack and we see a bitfield for a type with the
+ * different width than the pack, then we finish the pack and retry *)
+ | _, Some _, Some (packstart, _, wdpack) when wdpack != ftypeBits ->
+ let firstFree =
+ if sofar.oaFirstFree = packstart then packstart else
+ packstart + wdpack
+ in
+ offsetOfFieldAcc_MSVC fi
+ { oaFirstFree = addTrailing firstFree ftypeAlign;
+ oaLastFieldStart = sofar.oaLastFieldStart;
+ oaLastFieldWidth = sofar.oaLastFieldWidth;
+ oaPrevBitPack = None }
+
+ (* A width of 0 means that we must end the current packing. *)
+ | TInt (ikthis, _), Some 0, Some (packstart, _, wdpack) ->
+ let firstFree =
+ if sofar.oaFirstFree = packstart then packstart else
+ packstart + wdpack
+ in
+ let firstFree = addTrailing firstFree ftypeAlign in
+ { oaFirstFree = firstFree;
+ oaLastFieldStart = firstFree;
+ oaLastFieldWidth = 0;
+ oaPrevBitPack = Some (firstFree, ikthis, ftypeBits) }
+
+ (* Check for a bitfield that fits in the current pack after some other
+ * bitfields *)
+ | TInt(ikthis, _), Some wdthis, Some (packstart, ikprev, wdpack)
+ when packstart + wdpack >= sofar.oaFirstFree + wdthis ->
+ { oaFirstFree = sofar.oaFirstFree + wdthis;
+ oaLastFieldStart = sofar.oaFirstFree;
+ oaLastFieldWidth = wdthis;
+ oaPrevBitPack = sofar.oaPrevBitPack
+ }
+
+
+ | _, _, Some (packstart, _, wdpack) -> (* Finish up the bitfield pack and
+ * restart. *)
+ let firstFree =
+ if sofar.oaFirstFree = packstart then packstart else
+ packstart + wdpack
+ in
+ offsetOfFieldAcc_MSVC fi
+ { oaFirstFree = addTrailing firstFree ftypeAlign;
+ oaLastFieldStart = sofar.oaLastFieldStart;
+ oaLastFieldWidth = sofar.oaLastFieldWidth;
+ oaPrevBitPack = None }
+
+ (* No active bitfield pack. But we are seeing a bitfield. *)
+ | TInt(ikthis, _), Some wdthis, None ->
+ let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in
+ { oaFirstFree = firstFree + wdthis;
+ oaLastFieldStart = firstFree;
+ oaLastFieldWidth = wdthis;
+ oaPrevBitPack = Some (firstFree, ikthis, ftypeBits); }
+
+ (* No active bitfield pack. Non-bitfield *)
+ | _, None, None ->
+ (* Align this field *)
+ let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in
+ { oaFirstFree = firstFree + ftypeBits;
+ oaLastFieldStart = firstFree;
+ oaLastFieldWidth = ftypeBits;
+ oaPrevBitPack = None;
+ }
+
+ | _, Some _, None -> E.s (E.bug "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
+ * added *)
+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
+ | 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
+ | TEnum _ -> 8 * !M.theMachine.M.sizeof_enum
+ | TPtr _ -> 8 * !M.theMachine.M.sizeof_ptr
+ | TBuiltin_va_list _ -> 8 * !M.theMachine.M.sizeof_ptr
+ | TNamed (t, _) -> bitsSizeOf t.ttype
+ | TComp (comp, _) when comp.cfields == [] -> begin
+ (* Empty structs are allowed in msvc mode *)
+ if not comp.cdefined && not !msvcMode then
+ raise (SizeOfError ("abstract type", t)) (*abstract type*)
+ else
+ 0
+ end
+
+ | TComp (comp, _) when comp.cstruct -> (* Struct *)
+ (* Go and get the last offset *)
+ let startAcc =
+ { oaFirstFree = 0;
+ oaLastFieldStart = 0;
+ oaLastFieldWidth = 0;
+ oaPrevBitPack = None;
+ } in
+ let lastoff =
+ List.fold_left (fun acc fi -> offsetOfFieldAcc ~fi ~sofar:acc)
+ startAcc comp.cfields
+ in
+ if !msvcMode && lastoff.oaFirstFree = 0 && comp.cfields <> [] then
+ (* On MSVC if we have just a zero-width bitfields then the length
+ * is 32 and is not padded *)
+ 32
+ else begin
+ (* Drop e.g. the align attribute from t. For this purpose,
+ consider only the attributes on comp itself.*)
+ 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 =
+ { oaFirstFree = 0;
+ oaLastFieldStart = 0;
+ oaLastFieldWidth = 0;
+ oaPrevBitPack = None;
+ } in
+ let max =
+ List.fold_left (fun acc fi ->
+ let lastoff = offsetOfFieldAcc ~fi ~sofar:startAcc in
+ if lastoff.oaFirstFree > acc then
+ lastoff.oaFirstFree else acc) 0 comp.cfields in
+ (* Add trailing by simulating adding an extra field *)
+ addTrailing max (8 * alignOf_int t)
+
+ | TArray(bt, Some len, _) -> begin
+ match constFold true len with
+ Const(CInt64(l,_,_)) ->
+ let sz = Int64.mul (Int64.of_int (bitsSizeOf bt)) l in
+ let sz' = i64_to_int sz in
+ (* Check for overflow.
+ There are other places in these cil.ml that overflow can occur,
+ but this multiplication is the most likely to be a problem. *)
+ if (Int64.of_int sz') <> sz then
+ raise (SizeOfError ("Array is so long that its size can't be "
+ ^"represented with an OCaml int.", t))
+ else
+ addTrailing sz' (8 * alignOf_int t)
+ | _ -> raise (SizeOfError ("array non-constant length", t))
+ end
+
+
+ | TVoid _ -> 8 * !M.theMachine.M.sizeof_void
+ | 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 *)
+ 0
+
+ | TFun _ -> raise (SizeOfError ("function", t))
+
+
+and addTrailing nrbits roundto =
+ (nrbits + roundto - 1) land (lnot (roundto - 1))
+
+and sizeOf t =
+ try
+ integer ((bitsSizeOf t) lsr 3)
+ with SizeOfError _ -> SizeOf(t)
+
+
+and bitsOffset (baset: typ) (off: offset) : int * int =
+ let rec loopOff (baset: typ) (width: int) (start: int) = function
+ NoOffset -> start, width
+ | Index(e, off) -> begin
+ let ei =
+ match isInteger e with
+ Some i64 -> i64_to_int i64
+ | None -> raise (SizeOfError ("index not constant", baset))
+ in
+ let bt =
+ match unrollType baset with
+ TArray(bt, _, _) -> bt
+ | _ -> E.s (E.bug "bitsOffset: Index on a non-array")
+ in
+ let bitsbt = bitsSizeOf bt in
+ loopOff bt bitsbt (start + ei * bitsbt) off
+ end
+ | 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 =
+ let rec loop = function
+ [] -> 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
+ in
+ loop f.fcomp.cfields
+ in
+ let lastoff =
+ List.fold_left (fun acc fi' -> offsetOfFieldAcc ~fi:fi' ~sofar:acc)
+ { oaFirstFree = 0; (* Start at 0 because each struct is done
+ * separately *)
+ oaLastFieldStart = 0;
+ oaLastFieldWidth = 0;
+ oaPrevBitPack = None } prevflds
+ in
+ (* ignore (E.log "Field %s of %s: start=%d, lastFieldStart=%d\n"
+ f.fname f.fcomp.cname start lastoff.oaLastFieldStart); *)
+ loopOff f.ftype lastoff.oaLastFieldWidth
+ (start + lastoff.oaLastFieldStart) off
+ in
+ loopOff baset (bitsSizeOf baset) 0 off
+
+
+
+
+(** 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 =
+ match e with
+ BinOp(bop, e1, e2, tres) -> constFoldBinOp machdep bop e1 e2 tres
+ | UnOp(unop, e1, tres) -> begin
+ try
+ let tk =
+ match unrollType tres with
+ TInt(ik, _) -> ik
+ | TEnum _ -> IInt
+ | _ -> raise Not_found (* probably a float *)
+ in
+ match constFold machdep e1 with
+ Const(CInt64(i,ik,_)) -> begin
+ match unop with
+ Neg -> kinteger64 tk (Int64.neg i)
+ | BNot -> kinteger64 tk (Int64.lognot i)
+ | LNot -> if i = Int64.zero then one else zero
+ end
+ | e1c -> UnOp(unop, e1c, tres)
+ with Not_found -> e
+ end
+ (* Characters are integers *)
+ | Const(CChr c) -> Const(charConstToInt c)
+ | Const(CEnum (v, _, _)) -> constFold machdep v
+ | SizeOf t when machdep -> begin
+ try
+ let bs = bitsSizeOf t in
+ kinteger !kindOfSizeOf (bs / 8)
+ with SizeOfError _ -> e
+ end
+ | SizeOfE e when machdep -> constFold machdep (SizeOf (typeOf e))
+ | 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
+ * type. I know that for strings this is not true *)
+ 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))
+ when machdep && isZero z -> begin
+ try
+ let start, width = bitsOffset bt off in
+ if start mod 8 <> 0 then
+ E.s (error "Using offset of bitfield\n");
+ constFold machdep (CastE(it, (integer (start / 8))))
+ with SizeOfError _ -> e
+ end
+
+
+ | CastE (t, e) -> begin
+ 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) = [] ->
+ let i', _ = truncateInteger64 nk i in
+ Const(CInt64(i', nk, None))
+ | e', _ -> CastE (t, e')
+ end
+ | Lval lv -> Lval (constFoldLval machdep lv)
+ | AddrOf lv -> AddrOf (constFoldLval machdep lv)
+ | StartOf lv -> StartOf (constFoldLval machdep lv)
+ | _ -> e
+
+and constFoldLval machdep (host,offset) =
+ let newhost =
+ match host with
+ | Mem e -> Mem (constFold machdep e)
+ | Var _ -> host
+ in
+ let rec constFoldOffset machdep = function
+ | NoOffset -> NoOffset
+ | Field (fi,offset) -> Field (fi, constFoldOffset machdep offset)
+ | Index (exp,offset) -> Index (constFold machdep exp,
+ constFoldOffset machdep offset)
+ in
+ (newhost, constFoldOffset machdep offset)
+
+and constFoldBinOp (machdep: bool) bop e1 e2 tres =
+ let e1' = constFold machdep e1 in
+ let e2' = constFold machdep e2 in
+ if isIntegralType tres then begin
+ let newe =
+ let rec mkInt = function
+ Const(CChr c) -> Const(charConstToInt c)
+ | Const(CEnum (v, s, ei)) -> mkInt v
+ | CastE(TInt (ik, ta), e) -> begin
+ match mkInt e with
+ Const(CInt64(i, _, _)) ->
+ let i', _ = truncateInteger64 ik i in
+ Const(CInt64(i', ik, None))
+
+ | e' -> CastE(TInt(ik, ta), e')
+ end
+ | e -> e
+ in
+ let tk =
+ match unrollType tres with
+ TInt(ik, _) -> ik
+ | TEnum _ -> IInt
+ | _ -> E.s (bug "constFoldBinOp")
+ in
+ (* See if the result is unsigned *)
+ let isunsigned typ = not (isSigned typ) in
+ let ge (unsigned: bool) (i1: int64) (i2: int64) : bool =
+ if unsigned then
+ let l1 = Int64.shift_right_logical i1 1 in
+ let l2 = Int64.shift_right_logical i2 1 in (* Both positive now *)
+ (l1 > l2) || (l1 = l2 &&
+ Int64.logand i1 Int64.one >= Int64.logand i2 Int64.one)
+ else i1 >= i2
+ in
+ let shiftInBounds i2 =
+ (* We only try to fold shifts if the second arg is positive and
+ less than the size of the type of the first argument.
+ Otherwise, the semantics are processor-dependent, so let the
+ compiler sort it out. *)
+ if machdep then
+ try
+ i2 >= Int64.zero && i2 < (Int64.of_int (bitsSizeOf (typeOf e1')))
+ with SizeOfError _ -> false
+ else false
+ in
+ (* Assume that the necessary promotions have been done *)
+ match bop, mkInt e1', mkInt e2' with
+ | PlusA, Const(CInt64(z,_,_)), e2'' when z = Int64.zero -> e2''
+ | PlusA, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1''
+ | PlusPI, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1''
+ | IndexPI, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1''
+ | MinusPI, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1''
+ | PlusA, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
+ kinteger64 tk (Int64.add i1 i2)
+ | MinusA, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
+ kinteger64 tk (Int64.sub i1 i2)
+ | Mult, Const(CInt64(i1,ik1,_)), Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
+ kinteger64 tk (Int64.mul i1 i2)
+ | Mult, Const(CInt64(0L,_,_)), _ -> zero
+ | Mult, Const(CInt64(1L,_,_)), e2'' -> e2''
+ | Mult, _, Const(CInt64(0L,_,_)) -> zero
+ | Mult, e1'', Const(CInt64(1L,_,_)) -> e1''
+ | Div, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> begin
+ try kinteger64 tk (Int64.div i1 i2)
+ with Division_by_zero -> BinOp(bop, e1', e2', tres)
+ end
+ | Div, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_))
+ when bytesSizeOfInt ik1 = bytesSizeOfInt ik2 -> begin
+ try kinteger64 tk (Int64.div i1 i2)
+ with Division_by_zero -> BinOp(bop, e1', e2', tres)
+ end
+ | Div, e1'', Const(CInt64(1L,_,_)) -> e1''
+
+ | Mod, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> begin
+ try kinteger64 tk (Int64.rem i1 i2)
+ with Division_by_zero -> BinOp(bop, e1', e2', tres)
+ end
+ | BAnd, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
+ kinteger64 tk (Int64.logand i1 i2)
+ | BAnd, Const(CInt64(0L,_,_)), _ -> zero
+ | BAnd, _, Const(CInt64(0L,_,_)) -> zero
+ | BOr, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
+ kinteger64 tk (Int64.logor i1 i2)
+ | BOr, _, _ when isZero e1' -> e2'
+ | BOr, _, _ when isZero e2' -> e1'
+ | BXor, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
+ kinteger64 tk (Int64.logxor i1 i2)
+
+ | Shiftlt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,_,_)) when shiftInBounds i2 ->
+ kinteger64 tk (Int64.shift_left i1 (i64_to_int i2))
+ | Shiftlt, Const(CInt64(0L,_,_)), _ -> zero
+ | Shiftlt, e1'', Const(CInt64(0L,_,_)) -> e1''
+
+ | Shiftrt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,_,_)) when shiftInBounds i2 ->
+ if isunsigned ik1 then
+ kinteger64 tk (Int64.shift_right_logical i1 (i64_to_int i2))
+ else
+ kinteger64 tk (Int64.shift_right i1 (i64_to_int i2))
+ | Shiftrt, Const(CInt64(0L,_,_)), _ -> zero
+ | Shiftrt, e1'', Const(CInt64(0L,_,_)) -> e1''
+
+ | Eq, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) ->
+ let i1', i2', _ = convertInts i1 ik1 i2 ik2 in
+ if i1' = i2' then one else zero
+ | Ne, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) ->
+ let i1', i2', _ = convertInts i1 ik1 i2 ik2 in
+ if i1' <> i2' then one else zero
+ | Le, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) ->
+ let i1', i2', ik' = convertInts i1 ik1 i2 ik2 in
+ if ge (isunsigned ik') i2' i1' then one else zero
+
+ | Ge, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) ->
+ let i1', i2', ik' = convertInts i1 ik1 i2 ik2 in
+ if ge (isunsigned ik') i1' i2' then one else zero
+
+ | Lt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) ->
+ let i1', i2', ik' = convertInts i1 ik1 i2 ik2 in
+ if i1' <> i2' && ge (isunsigned ik') i2' i1' then one else zero
+
+ | Gt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) ->
+ let i1', i2', ik' = convertInts i1 ik1 i2 ik2 in
+ if i1 <> i2 && ge (isunsigned ik') i1' i2' then one else zero
+
+ (* We rely on the fact that LAnd/LOr appear in global initializers
+ and should not have side effects. *)
+ | LAnd, _, _ when isZero e1' || isZero e2' -> zero
+ | LAnd, _, _ when isInteger e1' <> None -> e2' (* e1' is TRUE *)
+ | LAnd, _, _ when isInteger e2' <> None -> e1' (* e2' is TRUE *)
+ | LOr, _, _ when isZero e1' -> e2'
+ | LOr, _, _ when isZero e2' -> e1'
+ | LOr, _, _ when isInteger e1' <> None || isInteger e2' <> None ->
+ (* One of e1' or e2' is a nonzero constant *)
+ one
+ | _ -> BinOp(bop, e1', e2', tres)
+ in
+ 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 parseInt (str: string) : exp =
+ let hasSuffix str =
+ let l = String.length str in
+ fun s ->
+ let ls = String.length s in
+ l >= ls && s = String.uppercase (String.sub str (l - ls) ls)
+ in
+ let l = String.length str in
+ (* See if it is octal or hex *)
+ let octalhex = (l >= 1 && String.get str 0 = '0') in
+ (* The length of the suffix and a list of possible kinds. See ISO
+ * 6.4.4.1 *)
+ let hasSuffix = hasSuffix str in
+ let suffixlen, kinds =
+ if hasSuffix "ULL" || hasSuffix "LLU" then
+ 3, [IULongLong]
+ else if hasSuffix "LL" then
+ 2, if octalhex then [ILongLong; IULongLong] else [ILongLong]
+ else if hasSuffix "UL" || hasSuffix "LU" then
+ 2, [IULong; IULongLong]
+ else if hasSuffix "L" then
+ 1, if octalhex then [ILong; IULong; ILongLong; IULongLong]
+ else [ILong; ILongLong]
+ else if hasSuffix "U" then
+ 1, [IUInt; IULong; IULongLong]
+ else if (!msvcMode && hasSuffix "UI64") then
+ 4, [IULongLong]
+ else if (!msvcMode && hasSuffix "I64") then
+ 3, [ILongLong]
+ else
+ 0, if octalhex || true (* !!! This is against the ISO but it
+ * is what GCC and MSVC do !!! *)
+ then [IInt; IUInt; ILong; IULong; ILongLong; IULongLong]
+ else [IInt; ILong; IUInt; ILongLong]
+ in
+ (* Convert to integer. To prevent overflow we do the arithmetic
+ * on Int64 and we take care of overflow. We work only with
+ * positive integers since the lexer takes care of the sign *)
+ let rec toInt (base: int64) (acc: int64) (idx: int) : int64 =
+ let doAcc (what: int) =
+ let acc' =
+ Int64.add (Int64.mul base acc) (Int64.of_int what) in
+ if acc' < Int64.zero || (* We clearly overflow since base >= 2
+ * *)
+ (acc' > Int64.zero && acc' < acc) then
+ E.s (unimp "Cannot represent on 64 bits the integer %s\n"
+ str)
+ else
+ toInt base acc' (idx + 1)
+ in
+ if idx >= l - suffixlen then begin
+ acc
+ end else
+ let ch = String.get str idx in
+ if ch >= '0' && ch <= '9' then
+ doAcc (Char.code ch - Char.code '0')
+ else if ch >= 'a' && ch <= 'f' then
+ doAcc (10 + Char.code ch - Char.code 'a')
+ 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)"
+ str ch idx)
+ in
+ let i =
+ if octalhex then
+ if l >= 2 &&
+ (let c = String.get str 1 in c = 'x' || c = 'X') then
+ toInt (Int64.of_int 16) Int64.zero 2
+ else
+ toInt (Int64.of_int 8) Int64.zero 1
+ else
+ toInt (Int64.of_int 10) Int64.zero 0
+ in
+ (* Construct an integer of the first kinds that fits. i must be
+ * POSITIVE *)
+ let res =
+ let rec loop = function
+ k::rest ->
+ let nrBits =
+ let unsignedbits = 8 * (bytesSizeOfInt k) in
+ if isSigned k then
+ unsignedbits-1
+ else
+ unsignedbits
+ in
+ (* Will i fit in nrBits bits? *)
+ let bound : int64 = Int64.sub (Int64.shift_left 1L nrBits) 1L in
+ (* toInt has ensured that 0 <= i < 2^64.
+ So if nrBits >= 64, i fits *)
+ if (nrBits >= 64) || (i <= bound) then
+ kinteger64 k i
+ else
+ loop rest
+ | [] -> E.s (E.unimp "Cannot represent the integer %s\n"
+ (Int64.to_string i))
+ in
+ loop kinds
+ in
+ res
+(* with e -> begin *)
+(* ignore (E.log "int_of_string %s (%s)\n" str *)
+(* (Printexc.to_string e)); *)
+(* zero *)
+(* end *)
+
+
+
+let d_unop () u =
+ match u with
+ Neg -> text "-"
+ | BNot -> text "~"
+ | LNot -> text "!"
+
+let d_binop () b =
+ match b with
+ PlusA | PlusPI | IndexPI -> text "+"
+ | MinusA | MinusPP | MinusPI -> text "-"
+ | Mult -> text "*"
+ | Div -> text "/"
+ | Mod -> text "%"
+ | Shiftlt -> text "<<"
+ | Shiftrt -> text ">>"
+ | Lt -> text "<"
+ | Gt -> text ">"
+ | Le -> text "<="
+ | Ge -> text ">="
+ | Eq -> text "=="
+ | Ne -> text "!="
+ | BAnd -> text "&"
+ | BXor -> text "^"
+ | BOr -> text "|"
+ | LAnd -> text "&&"
+ | LOr -> text "||"
+
+let invalidStmt = mkStmt (Instr [])
+
+(** Construct a hash with the builtins *)
+let builtinFunctions : (string, typ * typ list * bool) H.t =
+ H.create 49
+
+(** Deprecated. For compatibility with older programs, these are
+ aliases for {!Cil.builtinFunctions} *)
+let gccBuiltins = builtinFunctions
+let msvcBuiltins = builtinFunctions
+
+(* 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
+ E.s (bug "builtins already initialized.");
+ let h = builtinFunctions in
+ (* See if we have builtin_va_list *)
+ let hasbva = !M.theMachine.M.__builtin_va_list in
+ let ulongLongType = TInt(IULongLong, []) in
+ let floatType = TFloat(FFloat, []) in
+ let longDoubleType = TFloat (FLongDouble, []) in
+ let voidConstPtrType = TPtr(TVoid [Attr ("const", [])], []) in
+ let sizeType = !upointType in
+ let v4sfType = TFloat (FFloat,[Attr("__vector_size__", [AInt 16])]) in
+
+ H.add h "__builtin___fprintf_chk" (intType, [ voidPtrType; intType; charConstPtrType ], true) (* first argument is really FILE*, not void*, but we don't want to build in the definition for FILE *);
+ H.add h "__builtin___memcpy_chk" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType; sizeType ], false);
+ H.add h "__builtin___memmove_chk" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType; sizeType ], false);
+ H.add h "__builtin___mempcpy_chk" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType; sizeType ], false);
+ H.add h "__builtin___memset_chk" (voidPtrType, [ voidPtrType; intType; sizeType; sizeType ], false);
+ H.add h "__builtin___printf_chk" (intType, [ intType; charConstPtrType ], true);
+ H.add h "__builtin___snprintf_chk" (intType, [ charPtrType; sizeType; intType; sizeType; charConstPtrType ], true);
+ H.add h "__builtin___sprintf_chk" (intType, [ charPtrType; intType; sizeType; charConstPtrType ], true);
+ H.add h "__builtin___stpcpy_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false);
+ H.add h "__builtin___strcat_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false);
+ H.add h "__builtin___strcpy_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false);
+ H.add h "__builtin___strncat_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType; sizeType ], false);
+ H.add h "__builtin___strncpy_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType; sizeType ], false);
+ H.add h "__builtin___vfprintf_chk" (intType, [ voidPtrType; intType; charConstPtrType; TBuiltin_va_list [] ], false) (* first argument is really FILE*, not void*, but we don't want to build in the definition for FILE *);
+ H.add h "__builtin___vprintf_chk" (intType, [ intType; charConstPtrType; TBuiltin_va_list [] ], false);
+ H.add h "__builtin___vsnprintf_chk" (intType, [ charPtrType; sizeType; intType; sizeType; charConstPtrType; TBuiltin_va_list [] ], false);
+ H.add h "__builtin___vsprintf_chk" (intType, [ charPtrType; intType; sizeType; charConstPtrType; TBuiltin_va_list [] ], false);
+
+ H.add h "__builtin_acos" (doubleType, [ doubleType ], false);
+ H.add h "__builtin_acosf" (floatType, [ floatType ], false);
+ 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);
+
+ H.add h "__builtin_atan" (doubleType, [ doubleType ], false);
+ H.add h "__builtin_atanf" (floatType, [ floatType ], false);
+ H.add h "__builtin_atanl" (longDoubleType, [ longDoubleType ], false);
+
+ 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;
+ longDoubleType ], false);
+
+ H.add h "__builtin_ceil" (doubleType, [ doubleType ], false);
+ H.add h "__builtin_ceilf" (floatType, [ floatType ], false);
+ H.add h "__builtin_ceill" (longDoubleType, [ longDoubleType ], false);
+
+ H.add h "__builtin_cos" (doubleType, [ doubleType ], false);
+ H.add h "__builtin_cosf" (floatType, [ floatType ], false);
+ H.add h "__builtin_cosl" (longDoubleType, [ longDoubleType ], false);
+
+ H.add h "__builtin_cosh" (doubleType, [ doubleType ], false);
+ H.add h "__builtin_coshf" (floatType, [ floatType ], false);
+ H.add h "__builtin_coshl" (longDoubleType, [ longDoubleType ], false);
+
+ H.add h "__builtin_clz" (intType, [ uintType ], false);
+ H.add h "__builtin_clzl" (intType, [ ulongType ], false);
+ H.add h "__builtin_clzll" (intType, [ ulongLongType ], false);
+ H.add h "__builtin_constant_p" (intType, [ intType ], false);
+ H.add h "__builtin_ctz" (intType, [ uintType ], false);
+ H.add h "__builtin_ctzl" (intType, [ ulongType ], false);
+ H.add h "__builtin_ctzll" (intType, [ ulongLongType ], false);
+
+ H.add h "__builtin_exp" (doubleType, [ doubleType ], false);
+ H.add h "__builtin_expf" (floatType, [ floatType ], false);
+ H.add h "__builtin_expl" (longDoubleType, [ longDoubleType ], false);
+
+ H.add h "__builtin_expect" (longType, [ longType; longType ], false);
+
+ H.add h "__builtin_fabs" (doubleType, [ doubleType ], false);
+ H.add h "__builtin_fabsf" (floatType, [ floatType ], false);
+ H.add h "__builtin_fabsl" (longDoubleType, [ longDoubleType ], false);
+
+ H.add h "__builtin_ffs" (intType, [ uintType ], false);
+ H.add h "__builtin_ffsl" (intType, [ ulongType ], false);
+ H.add h "__builtin_ffsll" (intType, [ ulongLongType ], false);
+ H.add h "__builtin_frame_address" (voidPtrType, [ uintType ], false);
+
+ H.add h "__builtin_floor" (doubleType, [ doubleType ], false);
+ H.add h "__builtin_floorf" (floatType, [ floatType ], false);
+ H.add h "__builtin_floorl" (longDoubleType, [ longDoubleType ], false);
+
+ H.add h "__builtin_huge_val" (doubleType, [], false);
+ H.add h "__builtin_huge_valf" (floatType, [], false);
+ H.add h "__builtin_huge_vall" (longDoubleType, [], false);
+ H.add h "__builtin_inf" (doubleType, [], false);
+ H.add h "__builtin_inff" (floatType, [], false);
+ 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,
+ [ voidPtrType; intType; intType ], false);
+ H.add h "__builtin_bcopy" (voidType, [ voidConstPtrType; voidPtrType; sizeType ], false);
+ H.add h "__builtin_bzero" (voidType,
+ [ voidPtrType; sizeType ], false);
+
+ H.add h "__builtin_fmod" (doubleType, [ doubleType ], false);
+ H.add h "__builtin_fmodf" (floatType, [ floatType ], false);
+ H.add h "__builtin_fmodl" (longDoubleType, [ longDoubleType ], false);
+
+ 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;
+ 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;
+ intType ], false);
+
+ H.add h "__builtin_log" (doubleType, [ doubleType ], false);
+ H.add h "__builtin_logf" (floatType, [ floatType ], false);
+ H.add h "__builtin_logl" (longDoubleType, [ longDoubleType ], false);
+
+ H.add h "__builtin_log10" (doubleType, [ doubleType ], false);
+ H.add h "__builtin_log10f" (floatType, [ floatType ], false);
+ H.add h "__builtin_log10l" (longDoubleType, [ longDoubleType ], false);
+
+ H.add h "__builtin_modff" (floatType, [ floatType;
+ TPtr(floatType,[]) ], false);
+ H.add h "__builtin_modfl" (longDoubleType, [ longDoubleType;
+ TPtr(longDoubleType, []) ],
+ false);
+
+ H.add h "__builtin_nan" (doubleType, [ charConstPtrType ], false);
+ H.add h "__builtin_nanf" (floatType, [ charConstPtrType ], false);
+ H.add h "__builtin_nanl" (longDoubleType, [ charConstPtrType ], false);
+ H.add h "__builtin_nans" (doubleType, [ charConstPtrType ], false);
+ H.add h "__builtin_nansf" (floatType, [ charConstPtrType ], false);
+ H.add h "__builtin_nansl" (longDoubleType, [ charConstPtrType ], false);
+ H.add h "__builtin_next_arg" ((if hasbva then TBuiltin_va_list [] else voidPtrType), [], false) (* When we parse builtin_next_arg we drop the argument *);
+ H.add h "__builtin_object_size" (sizeType, [ voidPtrType; intType ], false);
+
+ H.add h "__builtin_parity" (intType, [ uintType ], false);
+ H.add h "__builtin_parityl" (intType, [ ulongType ], false);
+ H.add h "__builtin_parityll" (intType, [ ulongLongType ], false);
+
+ H.add h "__builtin_popcount" (intType, [ uintType ], false);
+ H.add h "__builtin_popcountl" (intType, [ ulongType ], false);
+ H.add h "__builtin_popcountll" (intType, [ ulongLongType ], false);
+
+ H.add h "__builtin_powi" (doubleType, [ doubleType; intType ], false);
+ H.add h "__builtin_powif" (floatType, [ floatType; intType ], false);
+ H.add h "__builtin_powil" (longDoubleType, [ longDoubleType; intType ], false);
+ H.add h "__builtin_prefetch" (voidType, [ voidConstPtrType ], true);
+ H.add h "__builtin_return" (voidType, [ voidConstPtrType ], false);
+ H.add h "__builtin_return_address" (voidPtrType, [ uintType ], false);
+
+ H.add h "__builtin_sin" (doubleType, [ doubleType ], false);
+ H.add h "__builtin_sinf" (floatType, [ floatType ], false);
+ H.add h "__builtin_sinl" (longDoubleType, [ longDoubleType ], false);
+
+ H.add h "__builtin_sinh" (doubleType, [ doubleType ], false);
+ H.add h "__builtin_sinhf" (floatType, [ floatType ], false);
+ H.add h "__builtin_sinhl" (longDoubleType, [ longDoubleType ], false);
+
+ H.add h "__builtin_sqrt" (doubleType, [ doubleType ], false);
+ H.add h "__builtin_sqrtf" (floatType, [ floatType ], false);
+ H.add h "__builtin_sqrtl" (longDoubleType, [ longDoubleType ], false);
+
+ H.add h "__builtin_stpcpy" (charPtrType, [ charPtrType; charConstPtrType ], false);
+ H.add h "__builtin_strchr" (charPtrType, [ charPtrType; intType ], false);
+ H.add h "__builtin_strcmp" (intType, [ charConstPtrType; charConstPtrType ], false);
+ H.add h "__builtin_strcpy" (charPtrType, [ charPtrType; charConstPtrType ], false);
+ H.add h "__builtin_strcspn" (sizeType, [ charConstPtrType; charConstPtrType ], false);
+ H.add h "__builtin_strncat" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false);
+ H.add h "__builtin_strncmp" (intType, [ charConstPtrType; charConstPtrType; sizeType ], false);
+ H.add h "__builtin_strncpy" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false);
+ H.add h "__builtin_strspn" (sizeType, [ charConstPtrType; charConstPtrType ], false);
+ H.add h "__builtin_strpbrk" (charPtrType, [ charConstPtrType; charConstPtrType ], false);
+ (* When we parse builtin_types_compatible_p, we change its interface *)
+ H.add h "__builtin_types_compatible_p"
+ (intType, [ !typeOfSizeOf;(* Sizeof the type *)
+ !typeOfSizeOf (* Sizeof the type *) ],
+ false);
+ H.add h "__builtin_tan" (doubleType, [ doubleType ], false);
+ H.add h "__builtin_tanf" (floatType, [ floatType ], false);
+ H.add h "__builtin_tanl" (longDoubleType, [ longDoubleType ], false);
+
+ H.add h "__builtin_tanh" (doubleType, [ doubleType ], false);
+ H.add h "__builtin_tanhf" (floatType, [ floatType ], false);
+ H.add h "__builtin_tanhl" (longDoubleType, [ longDoubleType ], false);
+
+ (* MMX Builtins *)
+ H.add h "__builtin_ia32_addps" (v4sfType, [v4sfType; v4sfType], false);
+ H.add h "__builtin_ia32_subps" (v4sfType, [v4sfType; v4sfType], false);
+ H.add h "__builtin_ia32_mulps" (v4sfType, [v4sfType; v4sfType], false);
+ H.add h "__builtin_ia32_unpckhps" (v4sfType, [v4sfType; v4sfType], false);
+ H.add h "__builtin_ia32_unpcklps" (v4sfType, [v4sfType; v4sfType], false);
+ H.add h "__builtin_ia32_maxps" (v4sfType, [v4sfType; v4sfType], false);
+
+ if hasbva then begin
+ H.add h "__builtin_va_end" (voidType, [ TBuiltin_va_list [] ], false);
+ 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);
+ H.add h "__builtin_stdarg_start" (voidType, [ TBuiltin_va_list []; ],
+ false);
+ (* When we parse builtin_va_arg we change its interface *)
+ H.add h "__builtin_va_arg" (voidType, [ TBuiltin_va_list [];
+ !typeOfSizeOf;(* Sizeof the type *)
+ voidPtrType; (* Ptr to res *) ],
+ false);
+ H.add h "__builtin_va_copy" (voidType, [ TBuiltin_va_list [];
+ TBuiltin_va_list [] ],
+ false);
+ end;
+ ()
+
+(** Construct a hash with the builtins *)
+let initMsvcBuiltins () : unit =
+ if not !initCIL_called then
+ E.s (bug "Call initCIL before initGccBuiltins");
+ if H.length builtinFunctions <> 0 then
+ E.s (bug "builtins already initialized.");
+ let h = builtinFunctions in
+ (** 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 = "<compiler builtins>";
+ byte = 0;}
+
+
+
+let pTypeSig : (typ -> typsig) ref =
+ ref (fun _ -> E.s (E.bug "pTypeSig not initialized"))
+
+
+(** A printer interface for CIL trees. Create instantiations of
+ * this type by specializing the class {!Cil.defaultCilPrinter}. *)
+class type cilPrinter = object
+
+ method setCurrentFormals : varinfo list -> unit
+
+ method setPrintInstrTerminator : string -> unit
+ 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
+ * definitions. *)
+
+ method pVar: varinfo -> doc
+ (** Invoked on each variable use. *)
+
+ method pLval: unit -> lval -> doc
+ (** Invoked on each lvalue occurence *)
+
+ method pOffset: doc -> offset -> doc
+ (** Invoked on each offset occurence. 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
+ * {!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
+ * {!Cil.dumpGlobal}. *)
+
+ method dBlock: out_channel -> int -> block -> unit
+ (** 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
+ * [GVar] and [GFun]. *)
+
+ method dGlobal: out_channel -> global -> unit
+ (** Dump a global to a file. This is used by {!Cil.dumpGlobal}. *)
+
+ 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
+ * visit it. *)
+
+ method pAttr: attribute -> doc * bool
+ (** 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 pAttrs: unit -> attributes -> doc
+ (** Attribute lists *)
+
+ method pLabel: unit -> label -> doc
+ (** 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
+ * file name is stored in a private field inside the cilPrinter object. *)
+
+ method pStmtKind : stmt -> unit -> stmtkind -> Pretty.doc
+ (** Print a statement kind. The code to be printed is given in the
+ * {!Cil.stmtkind} argument. The initial {!Cil.stmt} argument
+ * records the statement which follows the one being printed;
+ * {!Cil.defaultCilPrinterClass} uses this information to prettify
+ * statement printing in certain special cases. *)
+
+ method pExp: unit -> exp -> doc
+ (** Print expressions *)
+
+ method pInit: unit -> init -> doc
+ (** 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
+ * {!Cil.dumpGlobal}. *)
+end
+
+
+class defaultCilPrinterClass : cilPrinter = object (self)
+ val mutable currentFormals : varinfo list = []
+ method private getLastNamedArgument (s:string) : exp =
+ 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) =
+ currentFormals <- fms
+
+ (*** VARIABLES ***)
+ (* variable use *)
+ method pVar (v:varinfo) = text v.vname
+
+ (* variable declaration *)
+ method pVDecl () (v:varinfo) =
+ let stom, rest = separateStorageModifiers v.vattr in
+ (* First the storage modifiers *)
+ text (if v.vinline then "__inline " else "")
+ ++ d_storage () v.vstorage
+ ++ (self#pAttrs () stom)
+ ++ (self#pType (Some (text v.vname)) () v.vtype)
+ ++ text " "
+ ++ self#pAttrs () rest
+
+ (*** L-VALUES ***)
+ method pLval () (lv:lval) = (* lval (base is 1st field) *)
+ match lv with
+ Var vi, o -> self#pOffset (self#pVar vi) o
+ | Mem e, Field(fi, o) ->
+ self#pOffset
+ ((self#pExpPrec arrowLevel () e) ++ text ("->" ^ fi.fname)) o
+ | Mem e, NoOffset ->
+ text "*" ++ self#pExpPrec derefStarLevel () e
+ | Mem e, o ->
+ self#pOffset
+ (text "(*" ++ self#pExpPrec derefStarLevel () e ++ text ")") o
+
+ (** Offsets **)
+ method pOffset (base: doc) = function
+ | NoOffset -> base
+ | 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 =
+ if getParenthLevel (Lval(lv)) >= contextprec then
+ text "(" ++ self#pLval () lv ++ text ")"
+ else
+ self#pLval () lv
+
+ (*** EXPRESSIONS ***)
+ 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,_) ->
+ (d_unop () u) ++ chr ' ' ++ (self#pExpPrec level () e1)
+
+ | BinOp(b,e1,e2,_) ->
+ align
+ ++ (self#pExpPrec level () e1)
+ ++ chr ' '
+ ++ (d_binop () b)
+ ++ chr ' '
+ ++ (self#pExpPrec level () e2)
+ ++ unalign
+
+ | CastE(t,e) ->
+ text "("
+ ++ self#pType None () t
+ ++ text ")"
+ ++ self#pExpPrec level () e
+
+ | SizeOf (t) ->
+ text "sizeof(" ++ self#pType None () t ++ chr ')'
+ | SizeOfE (e) ->
+ text "sizeof(" ++ self#pExp () e ++ chr ')'
+
+ | SizeOfStr s ->
+ text "sizeof(" ++ d_const () (CStr s) ++ chr ')'
+
+ | AlignOf (t) ->
+ text "__alignof__(" ++ self#pType None () t ++ chr ')'
+ | AlignOfE (e) ->
+ text "__alignof__(" ++ self#pExp () e ++ chr ')'
+ | AddrOf(lv) ->
+ text "& " ++ (self#pLvalPrec addrOfLevel () lv)
+
+ | StartOf(lv) -> self#pLval () lv
+
+ (* Print an expression, given the precedence of the context in which it
+ * appears. *)
+ method private pExpPrec (contextprec: int) () (e: exp) =
+ let thisLevel = getParenthLevel e in
+ let needParens =
+ if thisLevel >= contextprec then
+ true
+ else if contextprec == bitwiseLevel then
+ (* quiet down some GCC warnings *)
+ thisLevel == additiveLevel || thisLevel == comparativeLevel
+ else
+ false
+ in
+ if needParens then
+ chr '(' ++ self#pExp () e ++ chr ')'
+ else
+ self#pExp () e
+
+ method pInit () = function
+ SingleInit e -> self#pExp () e
+ | CompoundInit (t, initl) ->
+ (* We do not print the type of the Compound *)
+(*
+ let dinit e = d_init () e in
+ dprintf "{@[%a@]}"
+ (docList ~sep:(chr ',' ++ break) dinit) initl
+*)
+ let printDesignator =
+ if not !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 != [] &&
+ (List.hd ci.cfields) != f then
+ true
+ else
+ false
+ | _ -> false
+ end else
+ false
+ in
+ let d_oneInit = function
+ 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) ++
+ self#pInit () i
+ | _ -> E.s (unimp "Trying to print malformed initializer")
+ in
+ chr '{' ++ (align
+ ++ ((docList ~sep:(chr ',' ++ break) d_oneInit) () initl)
+ ++ unalign)
+ ++ chr '}'
+(*
+ | 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) =
+ (* Dump an array *)
+ 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 ->
+ if not isfirst then output_string out ", ";
+ 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
+ room_on_line - 1
+ in
+ self#dInit out (ind + 2) (getelem i);
+ outputElements false new_room_on_line rest
+ in
+ 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, _, _) ->
+ dumpArray bt initl (fun (_, i) -> i)
+ | _ ->
+ (* Now a structure or a union *)
+ fprint out !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 _ ->
+ 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
+ * print sequences of instructions separated by comma *)
+ val mutable printInstrTerminator = ";"
+
+ method private setPrintInstrTerminator (term : string) =
+ printInstrTerminator <- term
+
+ method private getPrintInstrTerminator () = printInstrTerminator
+
+ (*** INSTRUCTIONS ****)
+ method pInstr () (i:instr) = (* imperative instruction *)
+ match i with
+ | Set(lv,e,l) -> begin
+ (* Be nice to some special cases *)
+ match e with
+ BinOp((PlusA|PlusPI|IndexPI),Lval(lv'),Const(CInt64(one,_,_)),_)
+ when Util.equals lv lv' && one = Int64.one && not !printCilAsIs ->
+ self#pLineDirective l
+ ++ self#pLvalPrec indexLevel () lv
+ ++ text (" ++" ^ printInstrTerminator)
+
+ | BinOp((MinusA|MinusPI),Lval(lv'),
+ Const(CInt64(one,_,_)), _)
+ when Util.equals lv lv' && one = Int64.one && not !printCilAsIs ->
+ self#pLineDirective l
+ ++ self#pLvalPrec indexLevel () lv
+ ++ text (" --" ^ printInstrTerminator)
+
+ | BinOp((PlusA|PlusPI|IndexPI),Lval(lv'),Const(CInt64(mone,_,_)),_)
+ when Util.equals lv lv' && mone = Int64.minus_one
+ && not !printCilAsIs ->
+ self#pLineDirective l
+ ++ self#pLvalPrec indexLevel () lv
+ ++ text (" --" ^ printInstrTerminator)
+
+ | 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'
+ && not !printCilAsIs ->
+ self#pLineDirective l
+ ++ self#pLval () lv
+ ++ text " " ++ d_binop () bop
+ ++ 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
+ * 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
+ 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"
+ 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#pType None () t
+ ++ unalign)
+ ++ text (")" ^ printInstrTerminator)
+
+ (* 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)
+ when ((vi.vname = "__builtin_stdarg_start" ||
+ 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
+ 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
+ valid C. *)
+ self#pLineDirective l
+ ++ 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
+ * __builtin_next_arg. *)
+ | 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
+ * __builtin_types_compatible_p(sizeof t1, sizeof t2), so that we can
+ * 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 ->
+ self#pLineDirective l
+ (* Print the destination *)
+ ++ (match dest with
+ None -> nil
+ | Some lv -> self#pLval () lv ++ text " = ")
+ (* Now the call itself *)
+ ++ 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 ->
+ E.s (bug "__builtin_types_compatible_p: cabs2cil should have added sizeof to the arguments.")
+
+ | Call(dest,e,args,l) ->
+ self#pLineDirective l
+ ++ (match dest with
+ None -> nil
+ | 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, _, _, _)
+ 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
+ Lval(Var _, _) -> ed
+ | _ -> text "(" ++ ed ++ text ")")
+ ++ text "(" ++
+ (align
+ (* Now the arguments *)
+ ++ (docList ~sep:(chr ',' ++ break)
+ (self#pExp ()) () args)
+ ++ unalign)
+ ++ text (")" ^ printInstrTerminator)
+
+ | Asm(attrs, tmpls, outs, ins, clobs, l) ->
+ if !msvcMode then
+ self#pLineDirective l
+ ++ text "__asm {"
+ ++ (align
+ ++ (docList ~sep:line text () tmpls)
+ ++ unalign)
+ ++ text ("}" ^ printInstrTerminator)
+ else
+ self#pLineDirective l
+ ++ text ("__asm__ ")
+ ++ self#pAttrs () attrs
+ ++ text " ("
+ ++ (align
+ ++ (docList ~sep:line
+ (fun x -> text ("\"" ^ escape_string x ^ "\""))
+ () tmpls)
+ ++
+ (if outs = [] && ins = [] && clobs = [] then
+ chr ':'
+ else
+ (text ": "
+ ++ (docList ~sep:(chr ',' ++ break)
+ (fun (idopt, c, lv) ->
+ text(match idopt with
+ None -> ""
+ | Some id -> "[" ^ id ^ "] "
+ ) ++
+ text ("\"" ^ escape_string c ^ "\" (")
+ ++ self#pLval () lv
+ ++ text ")") () outs)))
+ ++
+ (if ins = [] && clobs = [] then
+ nil
+ else
+ (text ": "
+ ++ (docList ~sep:(chr ',' ++ break)
+ (fun (idopt, c, e) ->
+ text(match idopt with
+ None -> ""
+ | Some id -> "[" ^ id ^ "] "
+ ) ++
+ text ("\"" ^ escape_string c ^ "\" (")
+ ++ self#pExp () e
+ ++ text ")") () ins)))
+ ++
+ (if clobs = [] then nil
+ else
+ (text ": "
+ ++ (docList ~sep:(chr ',' ++ break)
+ (fun c -> text ("\"" ^ escape_string c ^ "\""))
+ ()
+ 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 dBlock (out: out_channel) (ind: int) (b:block) : unit =
+ fprint out !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)
+
+ method private pLabel () = function
+ Label (s, _, true) -> text (s ^ ": ")
+ | Label (s, _, false) -> text (s ^ ": /* CIL Label */ ")
+ | Case (e, _) -> text "case " ++ self#pExp () e ++ text ": "
+ | Default _ -> text "default: "
+
+ (* The pBlock will put the unalign itself *)
+ 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 ->
+ dorest (acc ++ (self#pStmtNext x () prev) ++ line)
+ x rest
+ in
+ (* Let the host of the block decide on the alignment. The d_block will
+ * pop the alignment as well *)
+ 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
+ * 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 =
+ currentLoc := l;
+ match !lineDirectiveStyle with
+ | None -> nil
+ | Some _ when l.line <= 0 -> nil
+
+ (* Do not print lineComment if the same line as above *)
+ | Some LineCommentSparse when l.line = lastLineNumber -> nil
+
+ | Some style ->
+ let directive =
+ match style with
+ | LineComment | LineCommentSparse -> text "//#line "
+ | LinePreprocessorOutput when not !msvcMode -> chr '#'
+ | LinePreprocessorOutput | LinePreprocessorInput -> text "#line"
+ in
+ lastLineNumber <- l.line;
+ let filename =
+ if forcefile || l.file <> lastFileName then
+ begin
+ lastFileName <- l.file;
+ text " \"" ++ text l.file ++ text "\""
+ end
+ else
+ nil
+ in
+ leftflush ++ directive ++ chr ' ' ++ num l.line ++ filename ++ line
+
+
+ method private pStmtKind (next: stmt) () = function
+ Return(None, l) ->
+ self#pLineDirective l
+ ++ text "return;"
+
+ | Return(Some e, l) ->
+ self#pLineDirective l
+ ++ text "return ("
+ ++ self#pExp () e
+ ++ text ");"
+
+ | Goto (sref, l) -> begin
+ (* Grab one of the labels *)
+ let rec pickLabel = function
+ [] -> None
+ | Label (l, _, _) :: _ -> Some l
+ | _ :: rest -> pickLabel rest
+ in
+ match pickLabel !sref.labels with
+ Some l -> text ("goto " ^ l ^ ";")
+ | None ->
+ ignore (error "Cannot find label for target of goto\n");
+ text "goto __invalid_label;"
+ end
+
+ | Break l ->
+ self#pLineDirective l
+ ++ text "break;"
+
+ | Continue l ->
+ self#pLineDirective l
+ ++ text "continue;"
+
+ | Instr il ->
+ align
+ ++ (docList ~sep:line (fun i -> self#pInstr () i) () il)
+ ++ unalign
+
+ | If(be,t,{bstmts=[];battrs=[]},l) when not !printCilAsIs ->
+ self#pLineDirective l
+ ++ text "if"
+ ++ (align
+ ++ text " ("
+ ++ self#pExp () be
+ ++ text ") "
+ ++ self#pBlock () t)
+
+ | If(be,t,{bstmts=[{skind=Goto(gref,_);labels=[]}];
+ battrs=[]},l)
+ when !gref == next && not !printCilAsIs ->
+ self#pLineDirective l
+ ++ text "if"
+ ++ (align
+ ++ text " ("
+ ++ self#pExp () be
+ ++ text ") "
+ ++ self#pBlock () t)
+
+ | If(be,{bstmts=[];battrs=[]},e,l) when not !printCilAsIs ->
+ self#pLineDirective l
+ ++ text "if"
+ ++ (align
+ ++ text " ("
+ ++ self#pExp () (UnOp(LNot,be,intType))
+ ++ text ") "
+ ++ self#pBlock () e)
+
+ | If(be,{bstmts=[{skind=Goto(gref,_);labels=[]}];
+ battrs=[]},e,l)
+ when !gref == next && not !printCilAsIs ->
+ self#pLineDirective l
+ ++ text "if"
+ ++ (align
+ ++ text " ("
+ ++ self#pExp () (UnOp(LNot,be,intType))
+ ++ text ") "
+ ++ self#pBlock () e)
+
+ | If(be,t,e,l) ->
+ self#pLineDirective l
+ ++ (align
+ ++ text "if"
+ ++ (align
+ ++ text " ("
+ ++ self#pExp () be
+ ++ text ") "
+ ++ self#pBlock () t)
+ ++ text " " (* sm: indent next code 2 spaces (was 4) *)
+ ++ (align
+ ++ text "else "
+ ++ self#pBlock () e)
+ ++ unalign)
+
+ | Switch(e,b,_,l) ->
+ self#pLineDirective l
+ ++ (align
+ ++ text "switch ("
+ ++ self#pExp () e
+ ++ text ") "
+ ++ self#pBlock () b)
+ | Loop(b, l, _, _) -> begin
+ (* Maybe the first thing is a conditional. Turn it into a WHILE *)
+ try
+ let term, bodystmts =
+ let rec skipEmpty = function
+ [] -> []
+ | {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
+ when not !printCilAsIs -> begin
+ match skipEmpty tb.bstmts, skipEmpty fb.bstmts with
+ [], {skind=Break _; labels=[]} :: _ -> e, rest
+ | {skind=Break _; labels=[]} :: _, []
+ -> UnOp(LNot, e, intType), rest
+ | _ -> raise Not_found
+ end
+ | _ -> raise Not_found
+ in
+ self#pLineDirective l
+ ++ text "wh"
+ ++ (align
+ ++ text "ile ("
+ ++ self#pExp () term
+ ++ text ") "
+ ++ self#pBlock () {bstmts=bodystmts; battrs=b.battrs})
+
+ with Not_found ->
+ self#pLineDirective l
+ ++ text "wh"
+ ++ (align
+ ++ text "ile (1) "
+ ++ self#pBlock () b)
+ end
+ | Block b -> align ++ self#pBlock () b
+
+ | TryFinally (b, h, l) ->
+ self#pLineDirective l
+ ++ text "__try "
+ ++ align
+ ++ self#pBlock () b
+ ++ text " __fin" ++ align ++ text "ally "
+ ++ self#pBlock () h
+
+ | TryExcept (b, (il, e), h, l) ->
+ self#pLineDirective l
+ ++ text "__try "
+ ++ align
+ ++ self#pBlock () b
+ ++ text " __e" ++ align ++ text "xcept(" ++ line
+ ++ align
+ (* Print the instructions but with a comma at the end, instead of
+ * semicolon *)
+ ++ (printInstrTerminator <- ",";
+ let res =
+ (docList ~sep:line (self#pInstr ())
+ () il)
+ in
+ printInstrTerminator <- ";";
+ res)
+ ++ self#pExp () e
+ ++ text ") " ++ unalign
+ ++ self#pBlock () h
+
+
+ (*** GLOBALS ***)
+ 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
+ * 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
+ else nil in
+ (* Temporarily remove the function attributes *)
+ fundec.svar.vattr <- [];
+ 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 "
+ ++ (self#pType (Some (text typ.tname)) () typ.ttype)
+ ++ text ";\n"
+
+ | GEnumTag (enum, l) ->
+ self#pLineDirective l ++
+ text "enum" ++ align ++ text (" " ^ enum.ename) ++
+ text " {" ++ line
+ ++ (docList ~sep:(chr ',' ++ line)
+ (fun (n,i, loc) ->
+ text (n ^ " = ")
+ ++ self#pExp () i)
+ () enum.eitems)
+ ++ unalign ++ line ++ text "} "
+ ++ self#pAttrs () enum.eattr ++ text";\n"
+
+ | GEnumTagDecl (enum, l) -> (* This is a declaration of a tag *)
+ self#pLineDirective l ++
+ text ("enum " ^ enum.ename ^ ";\n")
+
+ | GCompTag (comp, l) -> (* This is a definition of a tag *)
+ let n = comp.cname in
+ let su, su1, su2 =
+ if comp.cstruct then "struct", "str", "uct"
+ else "union", "uni", "on"
+ in
+ let sto_mod, rest_attr = separateStorageModifiers comp.cattr in
+ self#pLineDirective ~forcefile:true l ++
+ text su1 ++ (align ++ text su2 ++ chr ' ' ++ (self#pAttrs () sto_mod)
+ ++ text n
+ ++ text " {" ++ line
+ ++ ((docList ~sep:line (self#pFieldDecl ())) ()
+ comp.cfields)
+ ++ unalign)
+ ++ line ++ text "}" ++
+ (self#pAttrs () rest_attr) ++ text ";\n"
+
+ | GCompTagDecl (comp, l) -> (* This is a declaration of a tag *)
+ self#pLineDirective l ++
+ text (compFullName comp) ++ text ";\n"
+
+ | GVar (vi, io, l) ->
+ self#pLineDirective ~forcefile:true l ++
+ self#pVDecl () vi
+ ++ chr ' '
+ ++ (match io.init with
+ None -> nil
+ | Some i -> text " = " ++
+ (let islong =
+ match i with
+ CompoundInit (_, il) when List.length il >= 8 -> true
+ | _ -> false
+ in
+ 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) ->
+ if not !printCilAsIs && H.mem builtinFunctions vi.vname then begin
+ (* Compiler builtins need no prototypes. Just print them in
+ comments. *)
+ text "/* compiler builtin: \n " ++
+ (self#pVDecl () vi)
+ ++ text "; */\n"
+
+ end else
+ self#pLineDirective l ++
+ (self#pVDecl () vi)
+ ++ text ";\n"
+
+ | GAsm (s, l) ->
+ self#pLineDirective l ++
+ text ("__asm__(\"" ^ escape_string s ^ "\");\n")
+
+ | GPragma (Attr(an, args), l) ->
+ (* sm: suppress printing pragmas that gcc does not understand *)
+ (* assume anything starting with "ccured" is ours *)
+ (* also don't print the 'combiner' pragma *)
+ (* nor 'cilnoremove' *)
+ let suppress =
+ not !print_CIL_Input &&
+ not !msvcMode &&
+ ((startsWith "box" an) ||
+ (startsWith "ccured" an) ||
+ (an = "merger") ||
+ (an = "cilnoremove")) in
+ let d =
+ match an, args with
+ | _, [] ->
+ text an
+ | "weak", [ACons (symbol, [])] ->
+ text "weak " ++ text symbol
+ | _ ->
+ text (an ^ "(")
+ ++ docList ~sep:(chr ',') (self#pAttrParam ()) () args
+ ++ text ")"
+ in
+ 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
+ text s ++ text "\n"
+ else
+ nil
+
+
+ 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
+ * 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)
+ ++ chr ';' ++ line
+ else nil in
+ fprint out !lineLength
+ (proto ++ (self#pLineDirective ~forcefile:true l));
+ (* Temporarily remove the function attributes *)
+ fdec.svar.vattr <- [];
+ fprint out !lineLength (self#pFunDecl () fdec);
+ fdec.svar.vattr <- oldattr;
+ output_string out "\n"
+
+ | GVar (vi, {init = Some i}, l) -> begin
+ fprint out !lineLength
+ (self#pLineDirective ~forcefile:true l ++
+ self#pVDecl () vi
+ ++ text " = "
+ ++ (let islong =
+ match i with
+ CompoundInit (_, il) when List.length il >= 8 -> true
+ | _ -> false
+ in
+ 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)
+
+ method pFieldDecl () fi =
+ (self#pType
+ (Some (text (if fi.fname = missingFieldName then "" else fi.fname)))
+ ()
+ fi.ftype)
+ ++ text " "
+ ++ (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
+ ++ text "{ "
+ ++ (align
+ (* locals. *)
+ ++ (docList ~sep:line (fun vi -> self#pVDecl () vi ++ text ";")
+ () f.slocals)
+ ++ line ++ line
+ (* the body *)
+ ++ ((* remember the declaration *) currentFormals <- f.sformals;
+ let body = self#pBlock () f.sbody in
+ currentFormals <- [];
+ body))
+ ++ line
+ ++ text "}"
+
+ (***** PRINTING DECLARATIONS and TYPES ****)
+
+ 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 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.
+ * In fact, for MSVC we MUST print attributes such as __stdcall *)
+ if pa = nil then nil else
+ text "/*" ++ pa ++ text "*/"
+ | _ -> pa
+ in
+ match t with
+ TVoid a ->
+ text "void"
+ ++ self#pAttrs () a
+ ++ text " "
+ ++ name
+
+ | TInt (ikind,a) ->
+ d_ikind () ikind
+ ++ self#pAttrs () a
+ ++ text " "
+ ++ name
+
+ | 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
+ ++ name
+
+ | TEnum (enum, a) ->
+ text ("enum " ^ enum.ename ^ " ")
+ ++ 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
+ * the parenthesis. *)
+ 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'),
+ TFun(rt, args, isva, addAttributes an at)
+
+ | TFun _ | TArray _ -> Some (text "("), bt
+
+ | _ -> None, bt
+ in
+ let name' = text "*" ++ printAttributes a ++ name in
+ let name'' = (* Put the parenthesis *)
+ match paren with
+ Some p -> p ++ name' ++ text ")"
+ | _ -> name'
+ in
+ self#pType
+ (Some name'')
+ ()
+ bt'
+
+ | TArray (elemt, lo, a) ->
+ (* ignore the const attribute for arrays *)
+ 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 ")"
+ in
+ self#pType
+ (Some (name'
+ ++ 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
+ if nameOpt == None then printAttributes a else
+ text "(" ++ printAttributes a ++ name ++ text ")"
+ in
+ self#pType
+ (Some
+ (name'
+ ++ text "("
+ ++ (align
+ ++
+ (if args = Some [] && isvararg then
+ text "..."
+ else
+ (if args = None then nil
+ else if args = Some [] then text "void"
+ else
+ let pArg (aname, atype, aattr) =
+ let stom, rest = separateStorageModifiers aattr in
+ (* First the storage modifiers *)
+ (self#pAttrs () stom)
+ ++ (self#pType (Some (text aname)) () atype)
+ ++ text " "
+ ++ self#pAttrs () rest
+ in
+ (docList ~sep:(chr ',' ++ break) pArg) ()
+ (argsToList args))
+ ++ (if isvararg then break ++ text ", ..." else nil))
+ ++ unalign)
+ ++ text ")"))
+ ()
+ restyp
+
+ | TNamed (t, a) ->
+ text t.tname ++ self#pAttrs () a ++ text " " ++ name
+
+ | TBuiltin_va_list a ->
+ text "__builtin_va_list"
+ ++ self#pAttrs () a
+ ++ text " "
+ ++ name
+
+
+ (**** PRINTING ATTRIBUTES *********)
+ method pAttrs () (a: attributes) =
+ self#pAttrsGen false a
+
+
+ (* 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
+ "const", [] -> text "const", false
+ (* Put the aconst inside the attribute list *)
+ | "aconst", [] when not !msvcMode -> text "__const__", true
+ | "thread", [] when not !msvcMode -> text "__thread", false
+(*
+ | "used", [] when not !msvcMode -> text "__attribute_used__", false
+*)
+ | "volatile", [] -> text "volatile", false
+ | "restrict", [] -> text "__restrict", false
+ | "missingproto", [] -> text "/* missing proto */", false
+ | "cdecl", [] when !msvcMode -> text "__cdecl", false
+ | "stdcall", [] when !msvcMode -> text "__stdcall", false
+ | "fastcall", [] when !msvcMode -> text "__fastcall", false
+ | "declspec", args when !msvcMode ->
+ text "__declspec("
+ ++ docList (self#pAttrParam ()) () args
+ ++ text ")", false
+ | "w64", [] when !msvcMode -> text "__w64", false
+ | "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,[])] ->
+ text "/* mode(" ++ text tag ++ text ") */", false
+
+ (* sm: also suppress "format" because we seem to print it in *)
+ (* a way gcc does not like *)
+ | "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
+ (* [matth: may be inside another comment.]
+ -> text "/*mayPointToStack*/", false
+ *)
+ -> text "", false
+ | "arraylen", [a] ->
+ (* text "/*[" ++ self#pAttrParam () a ++ text "]*/" *) nil, false
+
+
+ | _ -> (* This is the dafault case *)
+ (* Add underscores to the name *)
+ let an' = if !msvcMode then "__" ^ an else "__" ^ an ^ "__" in
+ if args = [] then
+ text an', true
+ else
+ text (an' ^ "(")
+ ++ (docList (self#pAttrParam ()) () args)
+ ++ text ")",
+ true
+
+ method private pAttrPrec (contextprec: int) () (a: attrparam) =
+ let thisLevel = getParenthLevelAttrParam a in
+ let needParens =
+ if thisLevel >= contextprec then
+ true
+ else if contextprec == bitwiseLevel then
+ (* quiet down some GCC warnings *)
+ thisLevel == additiveLevel || thisLevel == comparativeLevel
+ else
+ false
+ in
+ if needParens then
+ chr '(' ++ self#pAttrParam () a ++ chr ')'
+ else
+ self#pAttrParam () a
+
+
+ method pAttrParam () a =
+ let level = getParenthLevelAttrParam a in
+ match a with
+ | AInt n -> num n
+ | AStr s -> text ("\"" ^ escape_string s ^ "\"")
+ | ACons(s, []) -> text s
+ | ACons(s,al) ->
+ text (s ^ "(")
+ ++ (docList (self#pAttrParam ()) () al)
+ ++ text ")"
+ | ASizeOfE a -> text "sizeof(" ++ self#pAttrParam () a ++ text ")"
+ | ASizeOf t -> text "sizeof(" ++ self#pType None () t ++ text ")"
+ | ASizeOfS ts -> text "sizeof(<typsig>)"
+ | AAlignOfE a -> text "__alignof__(" ++ self#pAttrParam () a ++ text ")"
+ | AAlignOf t -> text "__alignof__(" ++ self#pType None () t ++ text ")"
+ | AAlignOfS ts -> text "__alignof__(<typsig>)"
+ | AUnOp(u,a1) ->
+ (d_unop () u) ++ chr ' ' ++ (self#pAttrPrec level () a1)
+
+ | ABinOp(b,a1,a2) ->
+ align
+ ++ text "("
+ ++ (self#pAttrPrec level () a1)
+ ++ text ") "
+ ++ (d_binop () b)
+ ++ break
+ ++ text " (" ++ (self#pAttrPrec level () a2) ++ text ") "
+ ++ unalign
+ | ADot (ap, s) -> (self#pAttrParam () ap) ++ text ("." ^ s)
+ | AStar a1 ->
+ text "(*" ++ (self#pAttrPrec derefStarLevel () a1) ++ text ")"
+ | AAddrOf a1 -> text "& " ++ (self#pAttrPrec addrOfLevel () a1)
+ | AIndex (a1, a2) -> self#pAttrParam () a1 ++ text "[" ++
+ self#pAttrParam () a2 ++ text "]"
+ | AQuestion (a1, a2, a3) ->
+ self#pAttrParam () a1 ++ text " ? " ++
+ self#pAttrParam () a2 ++ text " : " ++
+ 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
+ * the __attribute__ list *)
+ let rec loop (in__attr__: doc list) = function
+ [] -> begin
+ match in__attr__ with
+ [] -> nil
+ | _ :: _->
+ (* sm: added 'forgcc' calls to not comment things out
+ * if CIL is the consumer; this is to address a case
+ * Daniel ran into where blockattribute(nobox) was being
+ * dropped by the merger
+ *)
+ (if block then
+ text (" " ^ (forgcc "/*") ^ " __blockattribute__(")
+ else
+ text "__attribute__((")
+
+ ++ (docList ~sep:(chr ',' ++ break)
+ (fun a -> a)) () in__attr__
+ ++ text ")"
+ ++ (if block then text (forgcc "*/") else text ")")
+ end
+ | x :: rest ->
+ let dx, ina = self#pAttr x in
+ if ina then
+ loop (dx :: in__attr__) rest
+ else if dx = nil then
+ loop in__attr__ rest
+ else
+ dx ++ text " " ++ loop in__attr__ rest
+ in
+ let res = loop [] a in
+ if res = nil then
+ res
+ else
+ text " " ++ res ++ text " "
+
+end (* class defaultCilPrinterClass *)
+
+let defaultCilPrinter = new defaultCilPrinterClass
+
+(* Top-level printing functions *)
+let printType (pp: cilPrinter) () (t: typ) : doc =
+ pp#pType None () t
+
+let printExp (pp: cilPrinter) () (e: exp) : doc =
+ pp#pExp () e
+
+let printLval (pp: cilPrinter) () (lv: lval) : doc =
+ pp#pLval () lv
+
+let printGlobal (pp: cilPrinter) () (g: global) : doc =
+ pp#pGlobal () g
+
+let dumpGlobal (pp: cilPrinter) (out: out_channel) (g: global) : unit =
+ pp#dGlobal out g
+
+let printAttr (pp: cilPrinter) () (a: attribute) : doc =
+ let ad, _ = pp#pAttr a in ad
+
+let printAttrs (pp: cilPrinter) () (a: attributes) : doc =
+ pp#pAttrs () a
+
+let printInstr (pp: cilPrinter) () (i: instr) : doc =
+ pp#pInstr () i
+
+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 *)
+ align ++ pp#pBlock () b
+
+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 =
+ pp#dBlock out ind b
+
+let printInit (pp: cilPrinter) () (i: init) : doc =
+ pp#pInit () i
+
+let dumpInit (pp: cilPrinter) (out: out_channel) (ind: int) (i: init) : unit =
+ pp#dInit out ind i
+
+(* Now define some short cuts *)
+let d_exp () e = printExp defaultCilPrinter () e
+let _ = pd_exp := d_exp
+let d_lval () lv = printLval defaultCilPrinter () lv
+let d_offset base () off = defaultCilPrinter#pOffset base off
+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_attr () a = printAttr defaultCilPrinter () a
+let _ = pd_attr := d_attr
+let d_attrparam () e = defaultCilPrinter#pAttrParam () e
+let d_label () l = defaultCilPrinter#pLabel () l
+let d_stmt () s = printStmt defaultCilPrinter () s
+let d_block () b = printBlock defaultCilPrinter () b
+let d_instr () i = printInstr defaultCilPrinter () i
+
+let d_shortglobal () = function
+ GPragma (Attr(an, _), _) -> dprintf "#pragma %s" an
+ | GType (ti, _) -> dprintf "typedef %s" ti.tname
+ | GVarDecl (vi, _) -> dprintf "declaration of %s" vi.vname
+ | GVar (vi, _, _) -> dprintf "definition of %s" vi.vname
+ | GCompTag(ci,_) -> dprintf "definition of %s" (compFullName ci)
+ | GCompTagDecl(ci,_) -> dprintf "declaration of %s" (compFullName ci)
+ | GEnumTag(ei,_) -> dprintf "definition of enum %s" ei.ename
+ | GEnumTagDecl(ei,_) -> dprintf "declaration of enum %s" ei.ename
+ | GFun(fd, _) -> dprintf "definition of %s" fd.svar.vname
+ | GText _ -> text "GText"
+ | GAsm _ -> text "GAsm"
+
+
+(* sm: given an ordinary CIL object printer, yield one which
+ * behaves the same, except it never prints #line directives
+ * (this is useful for debugging printfs) *)
+let dn_obj (func: unit -> 'a -> doc) : (unit -> 'a -> doc) =
+begin
+ (* construct the closure to return *)
+ let theFunc () (obj:'a) : doc =
+ begin
+ let prevStyle = !lineDirectiveStyle in
+ lineDirectiveStyle := None;
+ let ret = (func () obj) in (* call underlying printer *)
+ lineDirectiveStyle := prevStyle;
+ ret
+ end in
+ theFunc
+end
+
+(* now define shortcuts for the non-location-printing versions,
+ * with the naming prefix "dn_" *)
+let dn_exp = (dn_obj d_exp)
+let dn_lval = (dn_obj d_lval)
+(* dn_offset is missing because it has a different interface *)
+let dn_init = (dn_obj d_init)
+let dn_type = (dn_obj d_type)
+let dn_global = (dn_obj d_global)
+let dn_attrlist = (dn_obj d_attrlist)
+let dn_attr = (dn_obj d_attr)
+let dn_attrparam = (dn_obj d_attrparam)
+let dn_stmt = (dn_obj d_stmt)
+let dn_instr = (dn_obj d_instr)
+
+
+(* Now define a cilPlainPrinter *)
+class plainCilPrinterClass =
+ (* We keep track of the composite types that we have done to avoid
+ * recursion *)
+ let donecomps : (int, unit) H.t = H.create 13 in
+ object (self)
+
+ inherit defaultCilPrinterClass as super
+
+ (*** PLAIN TYPES ***)
+ 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
+ TVoid a -> dprintf "TVoid(@[%a@])" self#pAttrs a
+ | TInt(ikind, a) -> dprintf "TInt(@[%a,@?%a@])"
+ d_ikind ikind self#pAttrs a
+ | TFloat(fkind, a) ->
+ dprintf "TFloat(@[%a,@?%a@])" d_fkind fkind self#pAttrs a
+ | TNamed (t, 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
+ None -> text "None" | Some l -> dprintf "Some(@[%a@])" self#pExp l in
+ 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) ->
+ dprintf "TFun(@[%a,@?%a%s,@?%a@])"
+ 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))
+ ()
+ (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
+ 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@])"
+ (if comp.cstruct then "struct" else "union") comp.cname
+ (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 ->
+ dprintf "TBuiltin_va_list(%a)" self#pAttrs a
+
+
+ (* 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 =
+ match c with
+ CInt64(i, ik, so) ->
+ dprintf "Int64(%s,%a,%s)"
+ (Int64.format "%d" i)
+ d_ikind ik
+ (match so with Some s -> s | _ -> "None")
+ | CStr(s) ->
+ text ("CStr(\"" ^ escape_string 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)"
+ f
+ 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("
+ ++ (align
+ ++ self#pLval () lv
+ ++ unalign)
+ ++ text ")"
+
+ | CastE(t,e) -> dprintf "CastE(@[%a,@?%a@])" self#pOnlyType t self#pExp e
+
+ | UnOp(u,e1,_) ->
+ dprintf "UnOp(@[%a,@?%a@])"
+ d_unop u self#pExp e1
+
+ | BinOp(b,e1,e2,_) ->
+ let d_plainbinop () b =
+ match b with
+ PlusA -> text "PlusA"
+ | PlusPI -> text "PlusPI"
+ | IndexPI -> text "IndexPI"
+ | MinusA -> text "MinusA"
+ | MinusPP -> text "MinusPP"
+ | MinusPI -> text "MinusPI"
+ | _ -> d_binop () b
+ in
+ dprintf "%a(@[%a,@?%a@])" d_plainbinop b
+ self#pExp e1 self#pExp e2
+
+ | SizeOf (t) ->
+ text "sizeof(" ++ self#pType None () t ++ chr ')'
+ | SizeOfE (e) ->
+ text "sizeofE(" ++ self#pExp () e ++ chr ')'
+ | SizeOfStr (s) ->
+ text "sizeofStr(" ++ d_const () (CStr s) ++ chr ')'
+ | AlignOf (t) ->
+ text "__alignof__(" ++ self#pType None () t ++ chr ')'
+ | AlignOfE (e) ->
+ text "__alignof__(" ++ self#pExp () e ++ chr ')'
+
+ | StartOf lv -> dprintf "StartOf(%a)" self#pLval lv
+ | AddrOf (lv) -> dprintf "AddrOf(%a)" self#pLval lv
+
+
+
+ method private d_plainoffset () = function
+ NoOffset -> text "NoOffset"
+ | Field(fi,o) ->
+ dprintf "Field(@[%s:%a,@?%a@])"
+ fi.fname self#pOnlyType fi.ftype self#d_plainoffset o
+ | Index(e, o) ->
+ dprintf "Index(@[%a,@?%a@])" self#pExp e self#d_plainoffset o
+
+ method pInit () = function
+ SingleInit e -> dprintf "SI(%a)" d_exp e
+ | 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) ->
+ let idx = ref (- 1) in
+ 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
+ | 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
+
+
+end
+let plainCilPrinter = new plainCilPrinterClass
+
+(* And now some shortcuts *)
+let d_plainexp () e = plainCilPrinter#pExp () e
+let d_plaintype () t = plainCilPrinter#pType None () t
+let d_plaininit () i = plainCilPrinter#pInit () i
+let d_plainlval () l = plainCilPrinter#pLval () l
+
+class type descriptiveCilPrinter = object
+ inherit cilPrinter
+
+ method startTemps: unit -> unit
+ method stopTemps: unit -> unit
+ method pTemps: unit -> Pretty.doc
+end
+
+class descriptiveCilPrinterClass (enable: bool) : descriptiveCilPrinter =
+object (self)
+ (** Like defaultCilPrinterClass, but instead of temporary variable
+ names it prints the description that was provided when the temp was
+ created. This is usually better for messages that are printed for end
+ users, although you may want the temporary names for debugging.
+
+ 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
+ feature off. *)
+ inherit defaultCilPrinterClass as super
+
+ val mutable temps: (varinfo * string * doc) list = []
+ val mutable useTemps: bool = false
+
+ method startTemps () : unit =
+ temps <- [];
+ useTemps <- true
+
+ method stopTemps () : unit =
+ temps <- [];
+ useTemps <- false
+
+ method pTemps () : doc =
+ if temps = [] then
+ nil
+ else
+ text "\nWhere:\n " ++
+ docList ~sep:(text "\n ")
+ (fun (_, s, d) -> dprintf "%s = %a" s insert d) ()
+ (List.rev temps)
+
+ method private pVarDescriptive (vi: varinfo) : doc =
+ if vi.vdescr <> nil then begin
+ if vi.vdescrpure || not useTemps then
+ vi.vdescr
+ else begin
+ try
+ let _, name, _ = List.find (fun (vi', _, _) -> vi == vi') temps in
+ text name
+ with Not_found ->
+ let name = "tmp" ^ string_of_int (List.length temps) in
+ temps <- (vi, name, vi.vdescr) :: temps;
+ text name
+ end
+ end else
+ super#pVar vi
+
+ (* Only substitute temp vars that appear in expressions.
+ (Other occurrences of lvalues are the left-hand sides of assignments,
+ but we shouldn't substitute there since "foo(a,b) = foo(a,b)"
+ would make no sense to the user.) *)
+ method pExp () (e:exp) : doc =
+ if enable then
+ match e with
+ Lval (Var vi, o)
+ | StartOf (Var vi, o) ->
+ self#pOffset (self#pVarDescriptive 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
+ else
+ super#pExp () e
+end
+
+let descriptiveCilPrinter: descriptiveCilPrinter =
+ ((new descriptiveCilPrinterClass true) :> descriptiveCilPrinter)
+
+let dd_exp = descriptiveCilPrinter#pExp
+let dd_lval = descriptiveCilPrinter#pLval
+
+(* zra: this allows pretty printers not in cil.ml to
+ be exposed to cilmain.ml *)
+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"
+ | Some e -> "Some " ^ Int64.to_string e))
+ d_attrlist al
+ | TSPtr (ts, al) ->
+ dprintf "TSPtr(@[%a,@?%a@])"
+ d_typsig ts d_attrlist 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) ->
+ dprintf "TSFun(@[%a,@?%a,%b,@?%a@])"
+ d_typsig rt
+ (docList ~sep:(chr ',' ++ break) (d_typsig ())) args isva
+ d_attrlist 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
+ incr nextGlobalVID;
+ t
+
+ (* Make a varinfo. Used mostly as a helper function below *)
+let makeVarinfo global name typ =
+ (* Strip const from type for locals *)
+ let vi =
+ { vname = name;
+ vid = newVID ();
+ vglob = global;
+ vtype = if global then typ else typeRemoveAttributes ["const"] typ;
+ vdecl = lu;
+ vinline = false;
+ vattr = [];
+ vstorage = NoStorage;
+ vaddrof = false;
+ vreferenced = false;
+ vdescr = nil;
+ vdescrpure = true;
+ } in
+ vi
+
+let copyVarinfo (vi: varinfo) (newname: string) : varinfo =
+ let vi' = {vi with vname = newname; vid = newVID () } in
+ vi'
+
+let makeLocal fdec name typ = (* a helper function *)
+ fdec.smaxid <- 1 + fdec.smaxid;
+ let vi = makeVarinfo false name typ in
+ vi
+
+ (* Make a local variable and add it to a function *)
+let makeLocalVar fdec ?(insert = true) name typ =
+ let vi = makeLocal fdec name typ in
+ if insert then fdec.slocals <- fdec.slocals @ [vi];
+ vi
+
+let makeTempVar fdec ?(insert = true) ?(name = "__cil_tmp")
+ ?(descr = nil) ?(descrpure = true) typ : varinfo =
+ let rec findUniqueName () : string=
+ let n = name ^ (string_of_int (1 + fdec.smaxid)) in
+ (* Is this check a performance problem? We could bring the old
+ unchecked makeTempVar back as a separate function that assumes
+ the prefix name does not occur in the original program. *)
+ if (List.exists (fun vi -> vi.vname = n) fdec.slocals)
+ || (List.exists (fun vi -> vi.vname = n) fdec.sformals) then begin
+ fdec.smaxid <- 1 + fdec.smaxid;
+ findUniqueName ()
+ end else
+ n
+ in
+ let name = findUniqueName () in
+ let vi = makeLocalVar fdec ~insert name typ in
+ vi.vdescr <- descr;
+ vi.vdescrpure <- descrpure;
+ vi
+
+
+(* Set the formals and re-create the function name based on the information*)
+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 (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
+ * passed as the second argument *)
+let setFunctionType (f: fundec) (t: typ) =
+ match unrollType t with
+ TFun (rt, Some args, va, a) ->
+ if List.length f.sformals <> List.length args then
+ 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
+ * function type *)
+ 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
+ * passed as the second argument *)
+let setFunctionTypeMakeFormals (f: fundec) (t: typ) =
+ match unrollType t with
+ TFun (rt, Some args, va, a) ->
+ if f.sformals <> [] then
+ 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.sformals <- [];
+
+ f.sformals <- List.map (fun (n,t,a) -> makeLocal f n t) args;
+
+ setFunctionType f t
+
+ | _ -> E.s (E.bug "setFunctionTypeMakeFormals: not a function type: %a"
+ d_type t)
+
+
+let setMaxId (f: fundec) =
+ f.smaxid <- List.length f.sformals + List.length f.slocals
+
+
+ (* Make a formal variable for a function. Insert it in both the sformals
+ * and the type of the function. You can optionally specify where to insert
+ * this one. If where = "^" then it is inserted first. If where = "$" then
+ * it is inserted last. Otherwise where must be the name of a formal after
+ * which to insert this. By default it is inserted at the end. *)
+let makeFormalVar fdec ?(where = "$") name typ : varinfo =
+ (* Search for the insertion place *)
+ let thenewone = ref fdec.svar in (* Just a placeholder *)
+ let makeit () : varinfo =
+ let vi = makeLocal fdec name typ 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
+ loopFormals fdec.sformals in
+ setFormals fdec newformals;
+ !thenewone
+
+ (* Make a global variable. Your responsibility to make sure that the name
+ * is unique *)
+let makeGlobalVar name typ =
+ let vi = makeVarinfo true name typ in
+ vi
+
+
+ (* Make an empty function *)
+let emptyFunction name =
+ { svar = makeGlobalVar name (TFun(voidType, Some [], false,[]));
+ smaxid = 0;
+ slocals = [];
+ sformals = [];
+ sbody = mkBlock [];
+ smaxstmtid = None;
+ sallstmts = [];
+ }
+
+
+ (* A dummy function declaration handy for initialization *)
+let dummyFunDec = emptyFunction "@dummy"
+let dummyFile =
+ { globals = [];
+ fileName = "<dummy>";
+ globinit = None;
+ globinitcalled = false;}
+
+(***** Load and store files as unmarshalled Ocaml binary data. ****)
+type savedFile =
+ { savedFile: file;
+ savedNextVID: int;
+ savedNextCompinfoKey: int}
+
+let saveBinaryFileChannel (cil_file : file) (outchan : out_channel) =
+ let save = {savedFile = cil_file;
+ savedNextVID = !nextGlobalVID;
+ savedNextCompinfoKey = !nextCompinfoKey} in
+ 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
+
+(** 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 inchan = open_in_bin filename in
+ let loaded : savedFile = (Marshal.from_channel inchan : savedFile) in
+ close_in inchan ;
+ if !nextGlobalVID = 1 && !nextCompinfoKey = 1 then begin
+ nextGlobalVID := loaded.savedNextVID;
+ nextCompinfoKey := loaded.savedNextCompinfoKey;
+ end
+ else begin
+ (* In this case, we should change all of the varinfo and compinfo
+ keys in loaded.savedFile to prevent conflicts. But since that hasn't
+ been implemented yet, just print a warning. If you do implement this,
+ please send it to the CIL maintainers. *)
+ ignore (E.log "CIL error: you loading a binary file after another file has been loaded. This isn't currently supported, so varinfo and compinfo id numbers may conflict.")
+ end;
+ loaded.savedFile
+
+
+(* 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 l = String.length s in
+ for i = 0 to l - 1 do
+ let c = String.get s i in
+ let isinvalid =
+ match c with
+ '-' | '.' -> true
+ | _ -> false
+ in
+ if isinvalid then
+ String.set s i '_';
+ done;
+ s
+
+let rec addOffset (toadd: offset) (off: offset) : offset =
+ match off with
+ NoOffset -> toadd
+ | Field(fid', offset) -> Field(fid', addOffset toadd offset)
+ | Index(e, offset) -> Index(e, addOffset toadd offset)
+
+ (* 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
+ NoOffset -> NoOffset, NoOffset
+ | Field(f, NoOffset) -> NoOffset, off
+ | Index(i, NoOffset) -> NoOffset, off
+ | Field(f, restoff) ->
+ let off', last = removeOffset restoff in
+ Field(f, off'), last
+ | Index(i, restoff) ->
+ let off', last = removeOffset restoff in
+ Index(i, off'), last
+
+let removeOffsetLval ((b, off): lval) : lval * offset =
+ let off', last = removeOffset off in
+ (b, off'), last
+
+
+(*** Define the visiting engine ****)
+(* visit all the nodes in a Cil expression *)
+let doVisit (vis: cilVisitor)
+ (startvisit: 'a -> 'a visitAction)
+ (children: cilVisitor -> 'a -> 'a)
+ (node: 'a) : 'a =
+ let action = startvisit node in
+ match action with
+ SkipChildren -> node
+ | ChangeTo node' -> node'
+ | _ -> (* DoChildren and ChangeDoChildrenPost *)
+ let nodepre = match action with
+ ChangeDoChildrenPost (node', _) -> node'
+ | _ -> node
+ in
+ let nodepost = children vis nodepre in
+ match action with
+ ChangeDoChildrenPost (_, f) -> f nodepost
+ | _ -> nodepost
+
+(* mapNoCopy is like map but avoid copying the list if the function does not
+ * change the elements. *)
+let rec mapNoCopy (f: 'a -> 'a) = function
+ [] -> []
+ | (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
+
+let rec mapNoCopyList (f: 'a -> 'a list) = function
+ [] -> []
+ | (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'
+
+(* A visitor for lists *)
+let doVisitList (vis: cilVisitor)
+ (startvisit: 'a -> 'a list visitAction)
+ (children: cilVisitor -> 'a -> 'a)
+ (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]
+ in
+ let nodespost = mapNoCopy (children vis) nodespre in
+ match action with
+ ChangeDoChildrenPost (_, f) -> f nodespost
+ | _ -> nodespost
+
+let debugVisit = false
+
+let rec visitCilExpr (vis: cilVisitor) (e: exp) : exp =
+ doVisit vis vis#vexpr childrenExp e
+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
+ if v' != v then Const (CEnum(v', s, ei)) else e
+
+ | Const _ -> e
+ | SizeOf t ->
+ let t'= vTyp t in
+ if t' != t then SizeOf t' else e
+ | SizeOfE e1 ->
+ let e1' = vExp e1 in
+ if e1' != e1 then SizeOfE e1' else e
+ | SizeOfStr s -> e
+
+ | AlignOf t ->
+ let t' = vTyp t in
+ if t' != t then AlignOf t' else e
+ | AlignOfE e1 ->
+ let e1' = vExp e1 in
+ if e1' != e1 then AlignOfE e1' else e
+ | Lval lv ->
+ let lv' = vLval lv in
+ if lv' != lv then Lval lv' else e
+ | 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) ->
+ 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
+ | 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 ->
+ let lv' = vLval lv in
+ if lv' != lv then AddrOf lv' else e
+ | 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 =
+ let fExp e = visitCilExpr vis e in
+ let fTyp t = visitCilType vis t in
+ match i with
+ | SingleInit e ->
+ let e' = fExp e in
+ if e' != e then SingleInit e' else i
+ | CompoundInit (t, initl) ->
+ let t' = fTyp t in
+ (* Collect the new initializer list, in reverse. We prefer two
+ * traversals to ensure tail-recursion. *)
+ let newinitl : (offset * init) list ref = ref [] in
+ (* Keep track whether the list has changed *)
+ let hasChanged = ref false in
+ let doOneInit ((o, i) as oi) =
+ let o' = visitCilInitOffset vis o in (* use initializer version *)
+ let i' = visitCilInit vis forglob (addOffset o' atoff) i in
+ let newio =
+ if o' != o || i' != i then
+ begin hasChanged := true; (o', i') end else oi
+ in
+ newinitl := newio :: !newinitl
+ in
+ List.iter doOneInit initl;
+ let initl' = if !hasChanged then List.rev !newinitl else initl in
+ if t' != t || initl' != initl then CompoundInit (t', initl') else i
+ in
+ doVisit vis (vis#vinit forglob atoff) childrenInit i
+
+and visitCilLval (vis: cilVisitor) (lv: lval) : lval =
+ doVisit vis vis#vlval childrenLval lv
+and childrenLval (vis: cilVisitor) (lv: lval) : lval =
+ (* and visit its subexpressions *)
+ let vExp e = visitCilExpr vis e in
+ let vOff off = visitCilOffset vis off in
+ match lv with
+ Var v, off ->
+ let v' = doVisit vis vis#vvrbl (fun _ x -> x) v in
+ let off' = vOff off in
+ if v' != v || off' != off then Var v', off' else lv
+ | Mem e, off ->
+ let e' = vExp e in
+ let off' = vOff off in
+ if e' != e || off' != off then Mem e', off' else lv
+
+and visitCilOffset (vis: cilVisitor) (off: offset) : offset =
+ doVisit vis vis#voffs childrenOffset off
+and childrenOffset (vis: cilVisitor) (off: offset) : offset =
+ let vOff off = visitCilOffset vis off in
+ match off with
+ Field (f, o) ->
+ let o' = vOff o in
+ if o' != o then Field (f, o') else off
+ | Index (e, o) ->
+ let e' = visitCilExpr vis e in
+ let o' = vOff o in
+ if e' != e || o' != o then Index (e', o') else off
+ | NoOffset -> off
+
+(* sm: for offsets in initializers, the 'startvisit' will be the
+ * vinitoffs method, but we can re-use the childrenOffset from
+ * above since recursive offsets are visited by voffs. (this point
+ * is moot according to cil.mli which claims the offsets in
+ * initializers will never recursively contain offsets)
+ *)
+and visitCilInitOffset (vis: cilVisitor) (off: offset) : offset =
+ doVisit vis vis#vinitoffs childrenOffset off
+
+and visitCilInstr (vis: cilVisitor) (i: instr) : instr list =
+ let oldloc = !currentLoc in
+ currentLoc := (get_instrLoc i);
+ assertEmptyQueue vis;
+ let res = doVisitList vis vis#vinst childrenInstr i in
+ currentLoc := oldloc;
+ (* See if we have accumulated some instructions *)
+ vis#unqueueInstr () @ res
+
+and childrenInstr (vis: cilVisitor) (i: instr) : instr =
+ let fExp = visitCilExpr vis in
+ let fLval = visitCilLval vis in
+ match i with
+ | Set(lv,e,l) ->
+ let lv' = fLval lv in let e' = fExp e in
+ if lv' != lv || e' != e then Set(lv',e',l) else i
+ | Call(None,f,args,l) ->
+ let f' = fExp f in let args' = mapNoCopy fExp args in
+ if f' != f || args' != args then Call(None,f',args',l) else i
+ | Call(Some lv,fn,args,l) ->
+ let lv' = fLval lv in let fn' = fExp fn in
+ let args' = mapNoCopy fExp args in
+ if lv' != lv || fn' != fn || args' != args
+ then Call(Some lv', fn', args', l) else i
+
+ | Asm(sl,isvol,outs,ins,clobs,l) ->
+ let outs' = mapNoCopy (fun ((id,s,lv) as pair) ->
+ let lv' = fLval lv in
+ if lv' != lv then (id,s,lv') else pair) outs in
+ let ins' = mapNoCopy (fun ((id,s,e) as pair) ->
+ let e' = fExp e in
+ if e' != e then (id,s,e') else pair) ins in
+ if outs' != outs || ins' != ins then
+ Asm(sl,isvol,outs',ins',clobs,l) else i
+
+
+(* visit all nodes in a Cil statement tree in preorder *)
+and visitCilStmt (vis: cilVisitor) (s: stmt) : stmt =
+ let oldloc = !currentLoc in
+ currentLoc := (get_stmtLoc s.skind) ;
+ assertEmptyQueue vis;
+ let toPrepend : instr list ref = ref [] in (* childrenStmt may add to this *)
+ let res = doVisit vis vis#vstmt (childrenStmt toPrepend) s in
+ (* Now see if we have saved some instructions *)
+ toPrepend := !toPrepend @ vis#unqueueInstr ();
+ (match !toPrepend with
+ [] -> () (* Return the same statement *)
+ | _ ->
+ (* Make our statement contain the instructions to prepend *)
+ res.skind <- Block { battrs = []; bstmts = [ mkStmt (Instr !toPrepend);
+ mkStmt res.skind ] });
+ currentLoc := oldloc;
+ res
+
+and childrenStmt (toPrepend: instr list ref) (vis:cilVisitor) (s:stmt): stmt =
+ let fExp e = (visitCilExpr vis e) in
+ let fBlock b = visitCilBlock vis b in
+ let fInst i = visitCilInstr vis i in
+ (* Just change the statement kind *)
+ let skind' =
+ match s.skind with
+ Break _ | Continue _ | Goto _ | Return (None, _) -> s.skind
+ | 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) ->
+ 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 queued any instructions, pop them here and remember them so that
+ they are inserted before the If stmt, not in the then block. *)
+ toPrepend := vis#unqueueInstr ();
+ let s1'= fBlock s1 in let s2'= fBlock s2 in
+ (* the stmts in the blocks should have cleaned up after themselves.*)
+ assertEmptyQueue vis;
+ if e' != e || s1' != s1 || s2' != s2 then
+ If(e', s1', s2', l) else s.skind
+ | Switch (e, b, stmts, l) ->
+ let e' = fExp e in
+ toPrepend := vis#unqueueInstr (); (* insert these before the switch *)
+ let b' = fBlock b in
+ (* 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 ->
+ let il' = mapNoCopyList fInst il in
+ if il' != il then Instr il' else s.skind
+ | Block b ->
+ let b' = fBlock b in
+ if b' != b then Block b' else s.skind
+ | TryFinally (b, h, l) ->
+ let b' = fBlock b in
+ let h' = fBlock h in
+ if b' != b || h' != h then TryFinally(b', h', l) else s.skind
+ | TryExcept (b, (il, e), h, l) ->
+ let b' = fBlock b in
+ assertEmptyQueue vis;
+ (* visit the instructions *)
+ let il' = mapNoCopyList fInst il in
+ (* Visit the expression *)
+ let e' = fExp e in
+ let il'' =
+ let more = vis#unqueueInstr () in
+ if more != [] then
+ il' @ more
+ else
+ il'
+ in
+ let h' = fBlock h in
+ (* Now collect the instructions *)
+ if b' != b || il'' != il || e' != e || h' != h then
+ TryExcept(b', (il'', e'), h', l)
+ else s.skind
+ in
+ if skind' != s.skind then s.skind <- skind';
+ (* Visit the labels *)
+ let labels' =
+ let fLabel = function
+ Case (e, l) as lb ->
+ let e' = fExp e in
+ if e' != e then Case (e', l) else lb
+ | lb -> lb
+ in
+ mapNoCopy fLabel s.labels
+ in
+ if labels' != s.labels then s.labels <- labels';
+ s
+
+
+
+and visitCilBlock (vis: cilVisitor) (b: block) : block =
+ doVisit vis vis#vblock childrenBlock b
+and childrenBlock (vis: cilVisitor) (b: block) : block =
+ let fStmt s = visitCilStmt vis s in
+ let stmts' = mapNoCopy fStmt b.bstmts in
+ if stmts' != b.bstmts then { battrs = b.battrs; bstmts = stmts'} else b
+
+
+and visitCilType (vis : cilVisitor) (t : typ) : typ =
+ doVisit vis vis#vtype childrenType t
+and childrenType (vis : cilVisitor) (t : typ) : typ =
+ (* look for types referred to inside t's definition *)
+ let fTyp t = visitCilType vis t in
+ let fAttr a = visitCilAttributes vis a in
+ match t with
+ TPtr(t1, a) ->
+ let t1' = fTyp t1 in
+ let a' = fAttr a in
+ if t1' != t || a' != a then TPtr(t1', a') else t
+ | TArray(t1, None, a) ->
+ let t1' = fTyp t1 in
+ let a' = fAttr a in
+ if t1' != t || a' != a then TArray(t1', None, a') else t
+ | TArray(t1, Some e, a) ->
+ let t1' = fTyp t1 in
+ let e' = visitCilExpr vis e in
+ let a' = fAttr a in
+ if t1' != t || e' != e || a' != a then TArray(t1', Some e', a') else t
+
+ (* DON'T recurse into the compinfo, this is done in visitCilGlobal.
+ User can iterate over cinfo.cfields manually, if desired.*)
+ | TComp(cinfo, a) ->
+ let a' = fAttr a in
+ if a != a' then TComp(cinfo, a') else t
+
+ | TFun(rettype, args, isva, a) ->
+ let rettype' = fTyp rettype in
+ (* iterate over formals, as variable declarations *)
+ let argslist = argsToList args in
+ let visitArg ((an,at,aa) as arg) =
+ let at' = fTyp at in
+ let aa' = fAttr aa in
+ if at' != at || aa' != aa then (an,at',aa') else arg
+ in
+ let argslist' = mapNoCopy visitArg argslist in
+ let a' = fAttr a in
+ if rettype' != rettype || argslist' != argslist || a' != a then
+ let args' = if argslist' == argslist then args else Some argslist' in
+ TFun(rettype', args', isva, a') else t
+
+ | TNamed(t1, a) -> (* 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
+
+ | _ -> (* other types (TVoid, TInt, TFloat, TEnum, and TBuiltin_va_list)
+ don't contain nested types, but they do have attributes. *)
+ let a = typeAttrs t in
+ let a' = fAttr a in
+ if a' != a then setTypeAttrs t a' else t
+
+
+(* for declarations, we visit the types inside; but for uses, *)
+(* we just visit the varinfo node *)
+and visitCilVarDecl (vis : cilVisitor) (v : varinfo) : varinfo =
+ doVisit vis vis#vvdec childrenVarDecl v
+and childrenVarDecl (vis : cilVisitor) (v : varinfo) : varinfo =
+ v.vtype <- visitCilType vis v.vtype;
+ v.vattr <- visitCilAttributes vis v.vattr;
+ v
+
+and visitCilAttributes (vis: cilVisitor) (al: attribute list) : attribute list=
+ let al' =
+ mapNoCopyList (doVisitList vis vis#vattr childrenAttribute) al in
+ if al' != al then
+ (* Must re-sort *)
+ addAttributes al' []
+ else
+ al
+and childrenAttribute (vis: cilVisitor) (a: attribute) : attribute =
+ let fAttrP a = visitCilAttrParams vis a in
+ match a with
+ Attr (n, args) ->
+ let args' = mapNoCopy fAttrP args in
+ if args' != args then Attr(n, args') else a
+
+
+and visitCilAttrParams (vis: cilVisitor) (a: attrparam) : attrparam =
+ doVisit vis vis#vattrparam childrenAttrparam a
+and childrenAttrparam (vis: cilVisitor) (aa: attrparam) : attrparam =
+ let fTyp t = visitCilType vis t in
+ let fAttrP a = visitCilAttrParams vis a in
+ match aa with
+ AInt _ | AStr _ -> aa
+ | ACons(n, args) ->
+ let args' = mapNoCopy fAttrP args in
+ if args' != args then ACons(n, args') else aa
+ | ASizeOf t ->
+ let t' = fTyp t in
+ if t' != t then ASizeOf t' else aa
+ | ASizeOfE e ->
+ let e' = fAttrP e in
+ if e' != e then ASizeOfE e' else aa
+ | AAlignOf t ->
+ let t' = fTyp t in
+ if t' != t then AAlignOf t' else aa
+ | AAlignOfE e ->
+ let e' = fAttrP e in
+ if e' != e then AAlignOfE e' else aa
+ | ASizeOfS _ | AAlignOfS _ ->
+ ignore (warn "Visitor inside of a type signature.");
+ aa
+ | AUnOp (uo, e1) ->
+ let e1' = fAttrP e1 in
+ if e1' != e1 then AUnOp (uo, e1') else aa
+ | ABinOp (bo, e1, e2) ->
+ let e1' = fAttrP e1 in
+ let e2' = fAttrP e2 in
+ if e1' != e1 || e2' != e2 then ABinOp (bo, e1', e2') else aa
+ | ADot (ap, s) ->
+ let ap' = fAttrP ap in
+ if ap' != ap then ADot (ap', s) else aa
+ | AStar ap ->
+ let ap' = fAttrP ap in
+ if ap' != ap then AStar ap' else aa
+ | AAddrOf ap ->
+ let ap' = fAttrP ap in
+ if ap' != ap then AAddrOf ap' else aa
+ | AIndex (e1, e2) ->
+ let e1' = fAttrP e1 in
+ let e2' = fAttrP e2 in
+ if e1' != e1 || e2' != e2 then AIndex (e1', e2') else aa
+ | AQuestion (e1, e2, e3) ->
+ let e1' = fAttrP e1 in
+ let e2' = fAttrP e2 in
+ let e3' = fAttrP e3 in
+ if e1' != e1 || e2' != e2 || e3' != e3
+ then AQuestion (e1', e2', e3') else aa
+
+
+let rec visitCilFunction (vis : cilVisitor) (f : fundec) : fundec =
+ if debugVisit then ignore (E.log "Visiting function %s\n" f.svar.vname);
+ assertEmptyQueue vis;
+ let f = doVisit vis vis#vfunc childrenFunction f in
+
+ let toPrepend = vis#unqueueInstr () in
+ if toPrepend <> [] then
+ f.sbody.bstmts <- mkStmt (Instr toPrepend) :: f.sbody.bstmts;
+ f
+
+and childrenFunction (vis : cilVisitor) (f : fundec) : fundec =
+ f.svar <- visitCilVarDecl vis f.svar; (* hit the function name *)
+ (* visit local declarations *)
+ f.slocals <- mapNoCopy (visitCilVarDecl vis) f.slocals;
+ (* visit the formals *)
+ let newformals = mapNoCopy (visitCilVarDecl vis) f.sformals in
+ (* Make sure the type reflects the formals *)
+ setFormals f newformals;
+ (* Remember any new instructions that were generated while visiting
+ variable declarations. *)
+ let toPrepend = vis#unqueueInstr () in
+
+ f.sbody <- visitCilBlock vis f.sbody; (* visit the body *)
+ if toPrepend <> [] then
+ f.sbody.bstmts <- mkStmt (Instr toPrepend) :: f.sbody.bstmts;
+ f
+
+let rec visitCilGlobal (vis: cilVisitor) (g: global) : global list =
+ (*(trace "visit" (dprintf "visitCilGlobal\n"));*)
+ let oldloc = !currentLoc in
+ currentLoc := (get_globalLoc g) ;
+ currentGlobal := g;
+ let res = doVisitList vis vis#vglob childrenGlobal g in
+ currentLoc := oldloc;
+ res
+and childrenGlobal (vis: cilVisitor) (g: global) : global =
+ match g with
+ | GFun (f, l) ->
+ let f' = visitCilFunction vis f in
+ if f' != f then GFun (f', l) else g
+ | GType(t, l) ->
+ t.ttype <- visitCilType vis t.ttype;
+ g
+
+ | GEnumTagDecl _ | GCompTagDecl _ -> g (* Nothing to visit *)
+ | GEnumTag (enum, _) ->
+ (* (trace "visit" (dprintf "visiting global enum %s\n" enum.ename)); *)
+ (* Do the values and attributes of the enumerated items *)
+ let itemVisit (name, exp, loc) = (name, visitCilExpr vis exp, loc) in
+ enum.eitems <- mapNoCopy itemVisit enum.eitems;
+ enum.eattr <- visitCilAttributes vis enum.eattr;
+ g
+
+ | GCompTag (comp, _) ->
+ (* (trace "visit" (dprintf "visiting global comp %s\n" comp.cname)); *)
+ (* Do the types and attirbutes of the fields *)
+ let fieldVisit = fun fi ->
+ fi.ftype <- visitCilType vis fi.ftype;
+ fi.fattr <- visitCilAttributes vis fi.fattr
+ in
+ List.iter fieldVisit comp.cfields;
+ comp.cattr <- visitCilAttributes vis comp.cattr;
+ g
+
+ | GVarDecl(v, l) ->
+ let v' = visitCilVarDecl vis v in
+ if v' != v then GVarDecl (v', l) else g
+ | GVar (v, inito, l) ->
+ let v' = visitCilVarDecl vis v in
+ (match inito.init with
+ None -> ()
+ | Some i -> let i' = visitCilInit vis v NoOffset i in
+ if i' != i then inito.init <- Some i');
+
+ if v' != v then GVar (v', inito, l) else g
+
+ | GPragma (a, l) -> begin
+ match visitCilAttributes vis [a] with
+ [a'] -> if a' != a then GPragma (a', l) else g
+ | _ -> E.s (E.unimp "visitCilAttributes returns more than one attribute")
+ end
+ | _ -> g
+
+
+(** A visitor that does constant folding. If "machdep" is true then we do
+ * machine dependent simplification (e.g., sizeof) *)
+class constFoldVisitorClass (machdep: bool) : cilVisitor = object
+ inherit nopCilVisitor
+
+ method vinst i =
+ match i with
+ (* Skip two functions to which we add Sizeof to the type arguments.
+ See the comments for these above. *)
+ Call(_,(Lval (Var vi,NoOffset)),_,_)
+ when ((vi.vname = "__builtin_va_arg")
+ || (vi.vname = "__builtin_types_compatible_p")) ->
+ SkipChildren
+ | _ -> DoChildren
+ method vexpr (e: exp) =
+ (* Do it bottom up *)
+ ChangeDoChildrenPost (e, constFold machdep)
+
+end
+let constFoldVisitor (machdep: bool) = new constFoldVisitorClass machdep
+
+(* Iterate over all globals, including the global initializer *)
+let iterGlobals (fl: file)
+ (doone: global -> unit) : unit =
+ let doone' g =
+ currentLoc := get_globalLoc g;
+ doone g
+ in
+ List.iter doone' fl.globals;
+ (match fl.globinit with
+ None -> ()
+ | 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 =
+ currentLoc := get_globalLoc g;
+ doone acc g
+ in
+ let acc' = List.fold_left doone' acc fl.globals in
+ (match fl.globinit with
+ None -> acc'
+ | Some g -> doone' acc' (GFun(g, locUnknown)))
+
+(** Find a function or function prototype with the given name in the file.
+ * If it does not exist, create a prototype with the given type, and return
+ * the new varinfo. This is useful when you need to call a libc function
+ * whose prototype may or may not already exist in the file.
+ *
+ * Because the new prototype is added to the start of the file, you shouldn't
+ * refer to any struct or union types in the function type.*)
+let findOrCreateFunc (f:file) (name:string) (t:typ) : varinfo =
+ let rec search glist =
+ match glist with
+ GVarDecl(vi,_) :: rest when vi.vname = name ->
+ if not (isFunctionType vi.vtype) then
+ E.s (error ("findOrCreateFunc: can't create %s because another "
+ ^^"global exists with that name.") name);
+ vi
+ | _ :: rest -> search rest (* tail recursive *)
+ | [] -> (*not found, so create one *)
+ let t' = unrollTypeDeep t in
+ let new_decl = makeGlobalVar name t' in
+ f.globals <- GVarDecl(new_decl, locUnknown) :: f.globals;
+ new_decl
+ in
+ search f.globals
+
+
+
+(* 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
+ [g'] when g' == g || Util.equals g' g -> () (* Try to do the pointer check first *)
+ | 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);
+ ())
+
+(* Be careful with visiting the whole file because it might be huge. *)
+let visitCilFile (vis : cilVisitor) (f : file) : unit =
+ let fGlob g = visitCilGlobal vis g in
+ (* Scan the globals. Make sure this is tail recursive. *)
+ let rec loop (acc: global list) = function
+ [] -> f.globals <- List.rev acc
+ | g :: restg ->
+ loop ((List.rev (fGlob g)) @ acc) restg
+ in
+ loop [] f.globals;
+ (* the global initializer *)
+ (match f.globinit with
+ None -> ()
+ | Some g -> f.globinit <- Some (visitCilFunction vis g))
+
+
+
+(** Create or fetch the global initializer. Tries to put a call to the
+ * function with the main_name into it *)
+let getGlobInit ?(main_name="main") (fl: file) =
+ match fl.globinit with
+ Some f -> f
+ | None -> begin
+ (* Sadly, we cannot use the Filename library because it does not like
+ * function names with multiple . in them *)
+ let f =
+ let len = String.length fl.fileName in
+ (* Find the last path separator and record the first . that we see,
+ * going backwards *)
+ let lastDot = ref len in
+ let rec findLastPathSep i =
+ if i < 0 then -1 else
+ let c = String.get fl.fileName i in
+ if c = '/' || c = '\\' then i
+ else begin
+ if c = '.' && !lastDot = len then
+ lastDot := i;
+ findLastPathSep (i - 1)
+ end
+ in
+ let lastPathSep = findLastPathSep (len - 1) in
+ let basenoext =
+ String.sub fl.fileName (lastPathSep + 1) (!lastDot - lastPathSep - 1)
+ in
+ emptyFunction
+ (makeValidSymbolName ("__globinit_" ^ basenoext))
+ in
+ fl.globinit <- Some f;
+ (* Now try to add a call to the global initialized at the beginning of
+ * main *)
+ let inserted = ref false in
+ List.iter
+ (function
+ GFun(m, lm) when m.svar.vname = main_name ->
+ (* Prepend a prototype to the global initializer *)
+ fl.globals <- GVarDecl (f.svar, lm) :: fl.globals;
+ m.sbody.bstmts <-
+ compactStmts (mkStmt (Instr [Call(None,
+ Lval(var f.svar),
+ [], locUnknown)])
+ :: m.sbody.bstmts);
+ inserted := true;
+ if !E.verboseFlag then
+ ignore (E.log "Inserted the globinit\n");
+ fl.globinitcalled <- true;
+ | _ -> ())
+ fl.globals;
+
+ if not !inserted then
+ ignore (E.warn "Cannot find %s to add global initializer %s"
+ main_name f.svar.vname);
+
+ f
+ end
+
+
+
+(* Fold over all globals, including the global initializer *)
+let mapGlobals (fl: file)
+ (doone: global -> global) : unit =
+ fl.globals <- List.map doone fl.globals;
+ (match fl.globinit with
+ None -> ()
+ | Some g -> begin
+ match doone (GFun(g, locUnknown)) with
+ GFun(g', _) -> fl.globinit <- Some g'
+ | _ -> E.s (E.bug "mapGlobals: globinit is not a function")
+ end)
+
+
+
+let dumpFile (pp: cilPrinter) (out : out_channel) (outfile: string) file =
+ printDepth := 99999; (* We don't want ... in the output *)
+ (* If we are in RELEASE mode then we do not print indentation *)
+
+ Pretty.fastMode := true;
+
+ if !E.verboseFlag then
+ ignore (E.log "printing file %s\n" outfile);
+ let print x = fprint out 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 *)
+ flush out
+
+
+
+(******************
+ ******************
+ ******************)
+
+(* Convert an expression into an attribute, if possible. Otherwise raise
+ * NotAnAttrParam *)
+exception NotAnAttrParam of exp
+let rec expToAttrParam (e: exp) : attrparam =
+ match e with
+ Const(CInt64(i,k,_)) ->
+ let i', trunc = truncateInteger64 k i in
+ if trunc then
+ raise (NotAnAttrParam e);
+ let i2 = Int64.to_int i' in
+ if i' <> Int64.of_int i2 then
+ raise (NotAnAttrParam e);
+ AInt i2
+ | Lval (Var v, NoOffset) -> ACons(v.vname, [])
+ | SizeOf t -> ASizeOf t
+ | SizeOfE e' -> ASizeOfE (expToAttrParam e')
+
+ | UnOp(uo, e', _) -> AUnOp (uo, expToAttrParam e')
+ | BinOp(bo, e1',e2', _) -> ABinOp (bo, expToAttrParam e1',
+ expToAttrParam e2')
+ | _ -> raise (NotAnAttrParam e)
+
+(******************** OPTIMIZATIONS *****)
+let rec peepHole1 (* Process one statement and possibly replace it *)
+ (doone: instr -> instr list option)
+ (* Scan a block and recurse inside nested blocks *)
+ (ss: stmt list) : unit =
+ let rec doInstrList (il: instr list) : instr list =
+ match il with
+ [] -> []
+ | i :: rest -> begin
+ match doone i with
+ None -> i :: doInstrList rest
+ | Some sl -> doInstrList (sl @ rest)
+ end
+ in
+
+ List.iter
+ (fun s ->
+ match s.skind with
+ Instr il -> s.skind <- Instr (doInstrList il)
+ | 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;
+ peepHole1 doone h.bstmts
+ | TryExcept (b, (il, e), h, l) ->
+ peepHole1 doone b.bstmts;
+ peepHole1 doone h.bstmts;
+ s.skind <- TryExcept(b, (doInstrList il, e), h, l);
+ | Return _ | Goto _ | Break _ | Continue _ -> ())
+ ss
+
+let rec peepHole2 (* Process two statements 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
+ [] -> []
+ | [i] -> [i]
+ | (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 ->
+ match s.skind with
+ Instr il -> s.skind <- Instr (doInstrList il)
+ | 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;
+ peepHole2 dotwo h.bstmts
+ | TryExcept (b, (il, e), h, l) ->
+ peepHole2 dotwo b.bstmts;
+ peepHole2 dotwo h.bstmts;
+ s.skind <- TryExcept (b, (doInstrList il, e), h, l)
+
+ | Return _ | Goto _ | Break _ | Continue _ -> ())
+ ss
+
+
+
+
+(*** Type signatures ***)
+
+(* Helper class for typeSig: replace any types in attributes with typsigs *)
+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 =
+ if a0 == [] then t else
+ 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)
+ | TSComp (iss, n, a) -> TSComp (iss, n, addAttributes a0 a)
+ | TSEnum (n, a) -> TSEnum (n, addAttributes a0 a)
+ | TSFun(ts, tsargs, isva, a) -> TSFun(ts, tsargs, isva, addAttributes a0 a)
+
+(* 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 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' =
+ if ignoreSign then unsignedVersionOf ik else ik
+ in
+ TSBase (TInt (ik', doattr al))
+ | TFloat (fk, al) -> TSBase (TFloat (fk, doattr al))
+ | 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.
+ * So constant fold the lengths *)
+ 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
+ | None -> None
+ in
+ TSArray(typeSig t, l', doattr a)
+
+ | TComp (comp, a) ->
+ TSComp (comp.cstruct, comp.cname, doattr (addAttributes comp.cattr a))
+ | TFun(rt,args,isva,a) ->
+ TSFun(typeSig rt,
+ List.map (fun (_, atype, _) -> (typeSig atype)) (argsToList args),
+ isva, doattr a)
+ | TNamed(t, a) -> typeSigAddAttrs (doattr a) (typeSig t.ttype)
+ | TBuiltin_va_list al -> TSBase (TBuiltin_va_list (doattr al))
+
+let typeSig t =
+ typeSigWithAttrs (fun al -> al) t
+
+let _ = pTypeSig := typeSig
+
+(* Remove the attribute from the top-level of the type signature *)
+let setTypeSigAttrs (a: attribute list) = function
+ TSBase t -> TSBase (setTypeAttrs t a)
+ | TSPtr (ts, _) -> TSPtr (ts, a)
+ | TSArray (ts, l, _) -> TSArray(ts, l, a)
+ | TSComp (iss, n, _) -> TSComp (iss, n, a)
+ | TSEnum (n, _) -> TSEnum (n, a)
+ | TSFun (ts, tsargs, isva, _) -> TSFun (ts, tsargs, isva, a)
+
+
+let typeSigAttrs = function
+ TSBase t -> typeAttrs t
+ | TSPtr (ts, a) -> a
+ | TSArray (ts, l, a) -> a
+ | TSComp (iss, n, a) -> a
+ | TSEnum (n, a) -> a
+ | TSFun (ts, tsargs, isva, a) -> a
+
+
+
+let dExp: doc -> exp =
+ fun d -> Const(CStr(sprint !lineLength d))
+
+let dInstr: doc -> location -> instr =
+ fun d l -> Asm([], [sprint !lineLength d], [], [], [], l)
+
+let dGlobal: doc -> location -> global =
+ fun d l -> GAsm(sprint !lineLength d, l)
+
+ (* 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 =
+ (* Never take the address of a register variable *)
+ (match lval with
+ Var vi, off when vi.vstorage = Register -> vi.vstorage <- NoStorage
+ | _ -> ());
+ match lval with
+ Mem e, NoOffset -> e
+ | b, Index(z, NoOffset) when isZero z -> StartOf (b, NoOffset)(* array *)
+ | _ -> AddrOf lval
+
+
+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
+ * not apply. You must do the conversion yourself using AddrOf *)
+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
+ | _, _ -> Mem addr, off
+ in
+(* ignore (E.log "memof : %a:%a\nresult = %a\n"
+ d_plainexp addr d_plainoffset off d_plainexp res); *)
+ res
+
+
+
+let splitFunctionType (ftype: typ)
+ : typ * (string * typ * attributes) list option * bool * attributes =
+ match unrollType ftype with
+ TFun (rt, args, isva, a) -> rt, args, isva, a
+ | _ -> 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
+ 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
+ | 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
+
+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) =
+ (* 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
+ TInt(newik, []), Const(CInt64(i, _, _)) -> kinteger64 newik i
+ | _ -> CastE(newt,e)
+ end
+
+let mkCast ~(e: exp) ~(newt: typ) =
+ mkCastT e (typeOf e) newt
+
+type existsAction =
+ ExistsTrue (* We have found it *)
+ | ExistsFalse (* Stop processing this branch *)
+ | ExistsMaybe (* This node is not what we are
+ * looking for but maybe its
+ * successors are *)
+let existsType (f: typ -> existsAction) (t: typ) : bool =
+ let memo : (int, unit) H.t = H.create 17 in (* Memo table *)
+ let rec loop t =
+ match f t with
+ ExistsTrue -> true
+ | ExistsFalse -> false
+ | ExistsMaybe ->
+ (match t with
+ TNamed (t', _) -> loop t'.ttype
+ | TComp (c, _) -> loopComp c
+ | TArray (t', _, _) -> loop t'
+ | TPtr (t', _) -> loop t'
+ | TFun (rt, args, _, _) ->
+ (loop rt || List.exists (fun (_, at, _) -> loop at)
+ (argsToList args))
+ | _ -> false)
+ and loopComp c =
+ if H.mem memo c.ckey then
+ (* We are looping, the answer must be false *)
+ false
+ else begin
+ H.add memo c.ckey ();
+ List.exists (fun f -> loop f.ftype) c.cfields
+ end
+ in
+ loop t
+
+
+(* Try to do an increment, with constant folding *)
+let increm (e: exp) (i: int) =
+ let 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
+ None -> raise LenOfArray
+ | Some e -> begin
+ match constFold true e with
+ | 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 =
+ match unrollType t with
+ TInt (ik, _) -> SingleInit (Const(CInt64(Int64.zero, ik, None)))
+ | TFloat(fk, _) -> SingleInit(Const(CReal(0.0, fk, None)))
+ | TEnum _ -> SingleInit zero
+ | TComp (comp, _) as t' when comp.cstruct ->
+ let inits =
+ List.fold_right
+ (fun f acc ->
+ if f.fname <> missingFieldName then
+ (Field(f, NoOffset), makeZeroInit f.ftype) :: acc
+ else
+ acc)
+ comp.cfields []
+ in
+ CompoundInit (t', inits)
+
+ | TComp (comp, _) when not comp.cstruct ->
+ let fstfield, rest =
+ match comp.cfields with
+ f :: rest -> f, rest
+ | [] -> E.s (unimp "Cannot create init for empty union")
+ in
+ 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. *)
+ fstfield
+ else begin
+ (* gcc initializes the whole union to zero. So choose the largest
+ field, and set that to zero. Choose the first field if possible.
+ MSVC also initializes the whole union, but use the ISO behavior
+ for MSVC because it only allows compound initializers to refer
+ to the first union field. *)
+ let fieldSize f = try bitsSizeOf f.ftype with SizeOfError _ -> 0 in
+ let widestField, widestFieldWidth =
+ List.fold_left (fun acc thisField ->
+ let widestField, widestFieldWidth = acc in
+ let thisSize = fieldSize thisField in
+ if thisSize > widestFieldWidth then
+ thisField, thisSize
+ else
+ acc)
+ (fstfield, fieldSize fstfield)
+ rest
+ in
+ widestField
+ end
+ in
+ CompoundInit(t, [(Field(fieldToInit, NoOffset),
+ makeZeroInit fieldToInit.ftype)])
+
+ | 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 =
+ if i < 0 then acc
+ 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
+ * (see cabs2cil.ml, collectInitializer) *)
+ CompoundInit (t', [])
+
+ | TPtr _ as t ->
+ SingleInit(if !insertImplicitCasts then mkCast zero 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
+ * [List.fold_left] except we also pass the type of the initializer. *)
+let foldLeftCompound
+ ~(implicit: bool)
+ ~(doinit: offset -> init -> typ -> 'a -> 'a)
+ ~(ct: typ)
+ ~(initl: (offset * init) list)
+ ~(acc: 'a) : 'a =
+ match unrollType ct with
+ TArray(bt, leno, _) -> begin
+ (* Scan the existing initializer *)
+ let part =
+ List.fold_left (fun acc (o, i) -> doinit o i bt acc) acc initl in
+ (* See how many more we have to do *)
+ match leno with
+ Some lene when implicit -> begin
+ match constFold true lene 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
+ let zi = makeZeroInit bt in
+ let rec loop acc i =
+ if i >= len_array then acc
+ else
+ loop (doinit (Index(integer i, NoOffset)) zi bt acc)
+ (i + 1)
+ in
+ loop part (len_init + 1)
+ else
+ 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, _) ->
+ let getTypeOffset = function
+ Field(f, NoOffset) -> f.ftype
+ | _ -> E.s (bug "foldLeftCompound: malformed initializer")
+ in
+ 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")
+
+
+
+
+let rec isCompleteType t =
+ match unrollType t with
+ | TArray(t, None, _) -> false
+ | TArray(t, Some z, _) when isZero z -> false
+ | TComp (comp, _) -> (* Struct or union *)
+ List.for_all (fun fi -> isCompleteType fi.ftype) comp.cfields
+ | _ -> true
+
+
+module A = Alpha
+
+
+(** Uniquefy the variable names *)
+let uniqueVarNames (f: file) : unit =
+ (* Setup the alpha conversion table for globals *)
+ let gAlphaTable: (string,
+ location A.alphaTableData ref) 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
+ * 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) ->
+ (* 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"
+ vi.vname);
+ (* Here if we have used this name already. Go ahead *)
+ ()
+ with Not_found -> begin
+ (* Here if this is the first time we define a name *)
+ H.add globalNames vi.vname vi.vid;
+ (* And register it *)
+ A.registerAlphaName gAlphaTable None vi.vname !currentLoc;
+ ()
+ end)
+ | _ -> ());
+
+ (* Now we must scan the function bodies and rename the locals *)
+ iterGlobals f
+ (function
+ GFun(fdec, l) -> begin
+ currentLoc := l;
+ (* Setup an undo list to be able to revert the changes to the
+ * global alpha table *)
+ let undolist = ref [] in
+ (* Process one local variable *)
+ let processLocal (v: varinfo) =
+ let newname, oldloc =
+ A.newAlphaName gAlphaTable (Some undolist) v.vname
+ !currentLoc
+ 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)\n"
+ v.vname fdec.svar.vname newname d_loc oldloc);
+ v.vname <- newname
+ in
+ (* Do the formals first *)
+ List.iter processLocal fdec.sformals;
+ (* Fix the type again *)
+ setFormals fdec fdec.sformals;
+ (* And now the locals *)
+ List.iter processLocal fdec.slocals;
+ (* Undo the changes to the global table *)
+ A.undoAlphaChanges gAlphaTable !undolist;
+ ()
+ end
+ | _ -> ());
+ ()
+
+
+(* 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
+ (* 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 *)
+ (* Keep here a list of statements to be patched *)
+ val patches : stmt list ref = ref []
+
+ val argid = ref 0
+
+ (* This is the main function *)
+ 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
+ * svar *)
+ f'.svar.vname <- newname;
+ 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) =
+ match s.skind with
+ 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,
+ List.map (fun cs -> findStmt cs.sid) cases, l)
+ | _ -> ()
+ in
+ List.iter patchstmt !patches;
+ f'
+ in
+ patches := [];
+ sid := 0;
+ H.clear stmtmap;
+ ChangeDoChildrenPost (f', patchfunction)
+
+ (* We must create a new varinfo for each declaration. Memoize to
+ * maintain sharing *)
+ 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
+ end;
+ try
+ ChangeTo (H.find map v.vname)
+ with Not_found -> begin
+ let v' = {v with vid = newVID () } in
+ H.add map v.vname v';
+ ChangeDoChildrenPost (v', fun x -> x)
+ end
+
+ (* We must replace references to local variables *)
+ method vvrbl (v: varinfo) =
+ if v.vglob then SkipChildren else
+ try
+ ChangeTo (H.find map v.vname)
+ 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 =
+ s.sid <- !sid; incr sid;
+ let s' = {s with sid = s.sid} in
+ H.add stmtmap s.sid s'; (* Remember where we copied this *)
+ (* if we have a Goto or a Switch remember them to fixup at end *)
+ (match s'.skind with
+ (Goto _ | Switch _) -> patches := s' :: !patches
+ | _ -> ());
+ (* Do the children *)
+ ChangeDoChildrenPost (s', fun x -> x)
+
+ (* 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
+
+(* We need a function that copies a CIL function. *)
+let copyFunction (f: fundec) (newname: string) : fundec =
+ visitCilFunction (new copyFunctionVisitor(newname)) f
+
+(********* Compute the CFG ********)
+let sid_counter = ref 0
+
+let new_sid () =
+ let id = !sid_counter in
+ incr sid_counter;
+ id
+
+let statements : stmt list ref = ref []
+(* Clear all info about the CFG in statements *)
+class clear : cilVisitor = object
+ inherit nopCilVisitor
+ method vstmt s = begin
+ s.sid <- !sid_counter ;
+ incr sid_counter ;
+ statements := s :: !statements;
+ s.succs <- [] ;
+ s.preds <- [] ;
+ DoChildren
+ end
+ method vexpr _ = SkipChildren
+ method vtype _ = SkipChildren
+ method vinst _ = SkipChildren
+end
+
+let link source dest = begin
+ if not (List.mem dest source.succs) then
+ source.succs <- dest :: source.succs ;
+ if not (List.mem source dest.preds) then
+ dest.preds <- source :: dest.preds
+end
+let trylink source dest_option = match dest_option with
+ None -> ()
+| Some(dest) -> link source dest
+
+
+(** Cmopute the successors and predecessors of a block, given a fallthrough *)
+let rec succpred_block b fallthrough =
+ let rec handle sl = match sl with
+ [] -> ()
+ | [a] -> succpred_stmt a fallthrough
+ | hd :: ((next :: _) as tl) ->
+ succpred_stmt hd (Some next) ;
+ handle tl
+ in handle b.bstmts
+
+
+and succpred_stmt s fallthrough =
+ match s.skind with
+ Instr _ -> trylink s fallthrough
+ | Return _ -> ()
+ | Goto(dest,l) -> link s !dest
+ | Break _
+ | Continue _
+ | Switch _ ->
+ failwith "computeCFGInfo: cannot be called on functions with break, continue or switch statements. Use prepareCFG first to remove them."
+
+ | If(e1,b1,b2,l) ->
+ (match b1.bstmts with
+ [] -> trylink s fallthrough
+ | hd :: tl -> (link s hd ; succpred_block b1 fallthrough )) ;
+ (match b2.bstmts with
+ [] -> trylink s fallthrough
+ | hd :: tl -> (link s hd ; succpred_block b2 fallthrough ))
+
+ | Loop(b,l,_,_) ->
+ begin match b.bstmts with
+ [] -> failwith "computeCFGInfo: empty loop"
+ | hd :: tl ->
+ link s hd ;
+ succpred_block b (Some(hd))
+ end
+
+ | Block(b) -> begin match b.bstmts with
+ [] -> trylink s fallthrough
+ | hd :: tl -> link s hd ;
+ succpred_block b fallthrough
+ end
+ | TryExcept _ | TryFinally _ ->
+ failwith "computeCFGInfo: structured exception handling not implemented"
+
+(* [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.
+ *
+ * Here is the magic handling to
+ * (1) replace switch statements with if/goto
+ * (2) remove "break"
+ * (3) remove "default"
+ * (4) remove "continue"
+ *)
+let is_case_label l = match l with
+ | Case _ | Default _ -> true
+ | _ -> false
+
+let switch_count = ref (-1)
+let get_switch_count () =
+ switch_count := 1 + !switch_count ;
+ !switch_count
+
+let switch_label = ref (-1)
+
+let rec xform_switch_stmt s break_dest cont_dest label_index = begin
+ s.labels <- List.map (fun lab -> match lab with
+ Label _ -> lab
+ | Case(e,l) ->
+ let suffix =
+ match isInteger e with
+ | Some value ->
+ if value < Int64.zero then
+ "neg_" ^ Int64.to_string (Int64.neg value)
+ else
+ Int64.to_string value
+ | None ->
+ incr switch_label;
+ "exp_" ^ string_of_int !switch_label
+ in
+ let str = Pretty.sprint !lineLength
+ (Pretty.dprintf "switch_%d_%s" label_index suffix) in
+ (Label(str,l,false))
+ | Default(l) -> (Label(Printf.sprintf
+ "switch_%d_default" label_index,l,false))
+ ) s.labels ;
+ match s.skind with
+ | Instr _ | Return _ | Goto _ -> ()
+ | Break(l) -> begin try
+ s.skind <- Goto(break_dest (),l)
+ with e ->
+ ignore (error "prepareCFG: break: %a@!" d_stmt s) ;
+ raise e
+ end
+ | Continue(l) -> begin try
+ s.skind <- Goto(cont_dest (),l)
+ with e ->
+ ignore (error "prepareCFG: continue: %a@!" d_stmt s) ;
+ raise e
+ end
+ | If(e,b1,b2,l) -> xform_switch_block b1 break_dest cont_dest label_index ;
+ xform_switch_block b2 break_dest cont_dest label_index
+ | Switch(e,b,sl,l) -> begin
+ (* change
+ * switch (se) {
+ * case 0: s0 ;
+ * case 1: s1 ; break;
+ * ...
+ * }
+ *
+ * into:
+ *
+ * if (se == 0) goto label_0;
+ * else if (se == 1) goto label_1;
+ * ...
+ * else if (0) { // body_block
+ * label_0: s0;
+ * label_1: s1; goto label_break;
+ * ...
+ * } else if (0) { // break_block
+ * label_break: ; // break_stmt
+ * }
+ *)
+ let i = get_switch_count () in
+ let break_stmt = mkStmt (Instr []) in
+ break_stmt.labels <-
+ [Label((Printf.sprintf "switch_%d_break" i),l,false)] ;
+ let break_block = mkBlock [ break_stmt ] in
+ let body_block = b in
+ let body_if_stmtkind = (If(zero,body_block,break_block,l)) in
+
+ (* The default case, if present, must be used only if *all*
+ non-default cases fail [ISO/IEC 9899:1999, §6.8.4.2, ¶5]. As a
+ result, we sort the order in which we handle the labels (but not the
+ order in which we print out the statements, so fall-through still
+ works as expected). *)
+ let compare_choices s1 s2 = match s1.labels, s2.labels with
+ | (Default(_) :: _), _ -> 1
+ | _, (Default(_) :: _) -> -1
+ | _, _ -> 0
+ in
+
+ let rec handle_choices sl = match sl with
+ [] -> body_if_stmtkind
+ | stmt_hd :: stmt_tl -> begin
+ let rec handle_labels lab_list = begin
+ match lab_list with
+ [] -> handle_choices stmt_tl
+ | Case(ce,cl) :: lab_tl ->
+ let pred = BinOp(Eq,e,ce,intType) in
+ let then_block = mkBlock [ mkStmt (Goto(ref stmt_hd,cl)) ] in
+ let else_block = mkBlock [ mkStmt (handle_labels lab_tl) ] in
+ If(pred,then_block,else_block,cl)
+ | Default(dl) :: lab_tl ->
+ (* ww: before this was 'if (1) goto label', but as Ben points
+ out this might confuse someone down the line who doesn't have
+ special handling for if(1) into thinking that there are two
+ paths here. The simpler 'goto label' is what we want. *)
+ Block(mkBlock [ mkStmt (Goto(ref stmt_hd,dl)) ;
+ mkStmt (handle_labels lab_tl) ])
+ | Label(_,_,_) :: lab_tl -> handle_labels lab_tl
+ end in
+ handle_labels stmt_hd.labels
+ end in
+ s.skind <- handle_choices (List.sort compare_choices sl) ;
+ xform_switch_block b (fun () -> ref break_stmt) cont_dest i
+ end
+ | Loop(b,l,_,_) ->
+ let i = get_switch_count () in
+ let break_stmt = mkStmt (Instr []) in
+ break_stmt.labels <-
+ [Label((Printf.sprintf "while_%d_break" i),l,false)] ;
+ let cont_stmt = mkStmt (Instr []) in
+ cont_stmt.labels <-
+ [Label((Printf.sprintf "while_%d_continue" i),l,false)] ;
+ b.bstmts <- cont_stmt :: b.bstmts ;
+ 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
+ xform_switch_block b break_dest cont_dest label_index ;
+ 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 label_index
+
+ | TryExcept _ | TryFinally _ ->
+ failwith "xform_switch_statement: structured exception handling not implemented"
+
+end and xform_switch_block b break_dest cont_dest label_index =
+ try
+ let rec link_succs sl = match sl with
+ | [] -> ()
+ | hd :: tl -> (if hd.succs = [] then hd.succs <- tl) ; link_succs tl
+ in
+ link_succs b.bstmts ;
+ List.iter (fun stmt ->
+ xform_switch_stmt stmt break_dest cont_dest label_index) b.bstmts ;
+ with e ->
+ List.iter (fun stmt -> ignore
+ (warn "prepareCFG: %a@!" d_stmt stmt)) b.bstmts ;
+ raise e
+
+(* prepare a function for computeCFGInfo by removing break, continue,
+ * default and switch statements/labels and replacing them with Ifs and
+ * Gotos. *)
+let prepareCFG (fd : fundec) : unit =
+ xform_switch_block fd.sbody
+ (fun () -> failwith "prepareCFG: break with no enclosing loop")
+ (fun () -> failwith "prepareCFG: continue with no enclosing loop") (-1)
+
+(* 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 ;
+ statements := [];
+ let clear_it = new clear in
+ ignore (visitCilBlock clear_it f.sbody) ;
+ f.smaxstmtid <- Some (!sid_counter) ;
+ succpred_block f.sbody (None);
+ let res = List.rev !statements in
+ statements := [];
+ f.sallstmts <- res;
+ ()
+
+let initCIL () =
+ if not !initCIL_called then begin
+ (* Set the machine *)
+ begin
+ match !envMachine with
+ Some machine -> M.theMachine := machine
+ | None -> M.theMachine := if !msvcMode then M.msvc else M.gcc
+ end;
+ (* Pick type for string literals *)
+ stringLiteralType := if !M.theMachine.M.const_string_literals then
+ charConstPtrType
+ else
+ charPtrType;
+ (* Find the right ikind given the size *)
+ let findIkindSz (unsigned: bool) (sz: int) : ikind =
+ try
+ let kind = intKindForSize sz in
+ if unsigned then unsignedVersionOf kind else kind
+ with Not_found ->
+ E.s(E.unimp "initCIL: cannot find the right ikind for size %d\n" sz)
+ in
+ (* Find the right ikind given the name *)
+ let findIkindName (name: string) : ikind =
+ (* Test the most common sizes first *)
+ if name = "int" then IInt
+ else if name = "unsigned int" then IUInt
+ else if name = "long" then ILong
+ else if name = "unsigned long" then IULong
+ else if name = "short" then IShort
+ else if name = "unsigned short" then IUShort
+ else if name = "char" then IChar
+ else if name = "unsigned char" then IUChar
+ else E.s(E.unimp "initCIL: cannot find the right ikind for type %s\n" name)
+ in
+ upointType := TInt(findIkindSz true !M.theMachine.M.sizeof_ptr, []);
+ kindOfSizeOf := findIkindName !M.theMachine.M.size_t;
+ typeOfSizeOf := TInt(!kindOfSizeOf, []);
+ wcharKind := findIkindName !M.theMachine.M.wchar_t;
+ wcharType := TInt(!wcharKind, []);
+ char_is_unsigned := !M.theMachine.M.char_is_unsigned;
+ little_endian := !M.theMachine.M.little_endian;
+ underscore_name := !M.theMachine.M.underscore_name;
+(* nextGlobalVID := 1; *)
+(* nextCompinfoKey := 1; *)
+
+ initCIL_called := true;
+ if !msvcMode then
+ initMsvcBuiltins ()
+ else
+ initGccBuiltins ();
+ ()
+ end
+
+
+(* We want to bring all type declarations before the data declarations. This
+ * is needed for code of the following form:
+
+ int f(); // Prototype without arguments
+ typedef int FOO;
+ int f(FOO x) { ... }
+
+ In CIL the prototype also lists the type of the argument as being FOO,
+ which is undefined.
+
+ There is one catch with this scheme. If the type contains an array whose
+ length refers to variables then those variables must be declared before
+ the type *)
+
+let pullTypesForward = true
+
+
+ (* Scan a type and collect the variables that are refered *)
+class getVarsInGlobalClass (pacc: varinfo list ref) = object
+ inherit nopCilVisitor
+ method vvrbl (vi: varinfo) =
+ pacc := vi :: !pacc;
+ SkipChildren
+
+ method vglob = function
+ GType _ | GCompTag _ -> DoChildren
+ | _ -> SkipChildren
+
+end
+
+let getVarsInGlobal (g : global) : varinfo list =
+ let pacc : varinfo list ref = ref [] in
+ let v : cilVisitor = new getVarsInGlobalClass pacc in
+ ignore (visitCilGlobal v g);
+ !pacc
+
+let hasPrefix p s =
+ let pl = String.length p in
+ (String.length s >= pl) && String.sub s 0 pl = p
+
+let pushGlobal (g: global)
+ ~(types:global list ref)
+ ~(variables: global list ref) =
+ if not pullTypesForward then
+ variables := g :: !variables
+ else
+ begin
+ (* Collect a list of variables that are refered from the type. Return
+ * Some if the global should go with the types and None if it should go
+ * to the variables. *)
+ let varsintype : (varinfo list * location) option =
+ match g with
+ GType (_, l) | GCompTag (_, l) -> Some (getVarsInGlobal g, l)
+ | GEnumTag (_, l) | GPragma (Attr("pack", _), l)
+ | GCompTagDecl (_, l) | GEnumTagDecl (_, l) -> Some ([], l)
+ (** Move the warning pragmas early
+ | GPragma(Attr(s, _), l) when hasPrefix "warning" s -> Some ([], l)
+ *)
+ | _ -> None (* Does not go with the types *)
+ in
+ match varsintype with
+ None -> variables := g :: !variables
+ | Some (vl, loc) ->
+ types :=
+ (* insert declarations for referred variables ('vl'), before
+ * the type definition 'g' itself *)
+ g :: (List.fold_left (fun acc v -> GVarDecl(v, loc) :: acc)
+ !types vl)
+ end
+
+
+type formatArg =
+ Fe of exp
+ | Feo of exp option (** For array lengths *)
+ | Fu of unop
+ | Fb of binop
+ | Fk of ikind
+ | FE of exp list (** For arguments in a function call *)
+ | Ff of (string * typ * attributes) (** For a formal argument *)
+ | FF of (string * typ * attributes) list (* For formal argument lists *)
+ | Fva of bool (** For the ellipsis in a function type *)
+ | Fv of varinfo
+ | Fl of lval
+ | Flo of lval option (** For the result of a function call *)
+ | Fo of offset
+ | Fc of compinfo
+ | Fi of instr
+ | FI of instr list
+ | Ft of typ
+ | Fd of int
+ | Fg of string
+ | Fs of stmt
+ | FS of stmt list
+ | FA of attributes
+
+ | Fp of attrparam
+ | FP of attrparam list
+
+ | FX of string
+
+let d_formatarg () = function
+ Fe e -> dprintf "Fe(%a)" d_exp e
+ | Feo None -> dprintf "Feo(None)"
+ | Feo (Some e) -> dprintf "Feo(%a)" d_exp e
+ | FE _ -> dprintf "FE()"
+ | Fk ik -> dprintf "Fk()"
+ | Fva b -> dprintf "Fva(%b)" b
+ | Ff (an, _, _) -> dprintf "Ff(%s)" an
+ | FF _ -> dprintf "FF(...)"
+ | FA _ -> dprintf "FA(...)"
+ | Fu uo -> dprintf "Fu()"
+ | Fb bo -> dprintf "Fb()"
+ | Fv v -> dprintf "Fv(%s)" v.vname
+ | Fl l -> dprintf "Fl(%a)" d_lval l
+ | Flo None -> dprintf "Flo(None)"
+ | Flo (Some l) -> dprintf "Flo(%a)" d_lval l
+ | Fo o -> dprintf "Fo"
+ | Fc ci -> dprintf "Fc(%s)" ci.cname
+ | Fi i -> dprintf "Fi(...)"
+ | FI i -> dprintf "FI(...)"
+ | 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(...)"
+ | Fs _ -> dprintf "FS"
+ | FS _ -> dprintf "FS"
+
+ | FX _ -> dprintf "FX()"
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(*
+ * CIL: An intermediate language for analyzing C programs.
+ *
+ * George Necula
+ *
+ *)
+
+(** {b CIL API Documentation.} An html version of this document
+ * can be found at http://hal.cs.berkeley.edu/cil *)
+
+(** Call this function to perform some initialization. Call if after you have
+ * set {!Cil.msvcMode}. *)
+val initCIL: unit -> unit
+
+
+(** This 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
+ * 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
+ * type {!Cil.location}) *)
+
+type file =
+ { mutable fileName: string; (** The complete file name *)
+ mutable globals: global list; (** List of globals as they will appear
+ in the printed file *)
+ mutable globinit: fundec option;
+ (** An optional global initializer function. This is a function where
+ * you can put stuff that must be executed before the program is
+ * started. This function, is conceptually at the end of the file,
+ * although it is not part of the globals list. Use {!Cil.getGlobInit}
+ * to create/get one. *)
+ mutable globinitcalled: bool;
+ (** Whether the global initialization function is called in main. This
+ * should always be false if there is no global initializer. When you
+ * create a global initialization CIL will try to insert code in main
+ * to call it. 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
+ * 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
+ is the defined name and always not-empty. *)
+
+ | GCompTag of compinfo * location
+ (** Defines a struct/union tag with some fields. There must be one of
+ these for each struct/union tag that you use (through the [TComp]
+ constructor) since this is the only context in which the fields are
+ printed. Consequently nested structure tag definitions must be
+ broken into individual definitions with the innermost structure
+ defined first. *)
+
+ | GCompTagDecl of compinfo * location
+ (** Declares a struct/union tag. Use as a forward declaration. This is
+ * printed without the fields. *)
+
+ | GEnumTag of enuminfo * location
+ (** Declares an enumeration tag with some fields. There must be one of
+ these for each enumeration tag that you use (through the [TEnum]
+ constructor) since this is the only context in which the items are
+ printed. *)
+
+ | GEnumTagDecl of enuminfo * location
+ (** Declares an enumeration tag. Use as a forward declaration. This is
+ * printed without the items. *)
+
+ | GVarDecl of varinfo * location
+ (** A variable declaration (not a definition). If the variable has a
+ function type then this is a prototype. There can be several
+ declarations and at most one definition for a given variable. If both
+ forms appear then they must share the same varinfo structure. A
+ prototype shares the varinfo with the fundec of the definition. Either
+ has storage Extern or there must be a definition in this file *)
+
+ | GVar of varinfo * initinfo * location
+ (** A variable definition. Can have an initializer. The initializer is
+ * updateable so that you can change it without requiring to recreate
+ * the list of globals. There can be at most one definition for a
+ * variable in an entire program. Cannot have storage Extern or function
+ * type. *)
+
+ | GFun of fundec * location
+ (** A function definition. *)
+
+ | GAsm of string * location (** Global asm statement. These ones
+ can contain only a template *)
+ | GPragma of attribute * location (** Pragmas at top level. Use the same
+ syntax as attributes *)
+ | GText of string (** Some text (printed verbatim) at
+ top level. E.g., this way you can
+ put comments in the output. *)
+
+(** {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
+ * pragmas. *)
+
+and typ =
+ TVoid of attributes (** Void type. Also predefined as {!Cil.voidType} *)
+ | TInt of ikind * attributes
+ (** An integer type. The kind specifies the sign and width. Several
+ * useful variants are predefined as {!Cil.intType}, {!Cil.uintType},
+ * {!Cil.longType}, {!Cil.charType}. *)
+
+
+ | TFloat of fkind * attributes
+ (** A floating-point type. The kind specifies the precision. You can
+ * also use the predefined constant {!Cil.doubleType}. *)
+
+ | TPtr of typ * attributes
+ (** Pointer type. Several useful variants are predefined as
+ * {!Cil.charPtrType}, {!Cil.charConstPtrType} (pointer to a
+ * constant character), {!Cil.voidPtrType},
+ * {!Cil.intPtrType} *)
+
+ | TArray of typ * exp option * attributes
+ (** Array type. It indicates the base type and the array length. *)
+
+ | TFun of typ * (string * typ * attributes) list option * bool * attributes
+ (** Function type. Indicates the type of the result, the name, type
+ * and name attributes of the formal arguments ([None] if no
+ * arguments were specified, as in a function whose definition or
+ * prototype we have not seen; [Some \[\]] means void). Use
+ * {!Cil.argsToList} to obtain a list of arguments. The boolean
+ * indicates if it is a variable-argument function. If this is the
+ * type of a varinfo for which we have a function declaration then
+ * the information for the formals must match that in the
+ * function's sformals. Use {!Cil.setFormals}, or
+ * {!Cil.setFunctionType}, or {!Cil.makeFormalVar} for this
+ * purpose. *)
+
+ | TNamed of typeinfo * attributes
+ (** The use of a named type. 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
+ * 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
+ 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.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.
+
+ The other method for scanning types is provided by the visitor interface (see
+ {!Cil.cilVisitor}).
+
+ If you want to compare types (or to use them as hash-values) then you should
+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}.
+
+*)
+
+
+(** Various kinds of integers *)
+and ikind =
+ IChar (** [char] *)
+ | ISChar (** [signed char] *)
+ | IUChar (** [unsigned char] *)
+ | IInt (** [int] *)
+ | IUInt (** [unsigned int] *)
+ | IShort (** [short] *)
+ | IUShort (** [unsigned short] *)
+ | ILong (** [long] *)
+ | IULong (** [unsigned long] *)
+ | ILongLong (** [long long] (or [_int64] on Microsoft Visual C) *)
+ | IULongLong (** [unsigned long long] (or [unsigned _int64] on Microsoft
+ Visual C) *)
+
+(** Various kinds of floating-point numbers*)
+and fkind =
+ FFloat (** [float] *)
+ | FDouble (** [double] *)
+ | FLongDouble (** [long double] *)
+
+
+(** {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
+ * 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
+ * attribute list and maintain the sortedness. *)
+and attributes = attribute list
+
+(** The type of parameters of attributes *)
+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
+ parentheses are not printed. *)
+ | ASizeOf of typ (** A way to talk about types *)
+ | ASizeOfE of attrparam
+ | ASizeOfS of typsig (** Replacement for ASizeOf in type
+ signatures. Only used for
+ attributes inside typsigs.*)
+ | AAlignOf of typ
+ | AAlignOfE of attrparam
+ | AAlignOfS of typsig
+ | AUnOp of unop * attrparam
+ | ABinOp of binop * attrparam * attrparam
+ | ADot of attrparam * string (** a.foo **)
+ | AStar of attrparam (** * a *)
+ | AAddrOf of attrparam (** & a **)
+ | AIndex of attrparam * attrparam (** a1[a2] *)
+ | AQuestion of attrparam * attrparam * attrparam (** a1 ? a2 : a3 **)
+
+(** {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].
+
+ * 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
+ * key is assigned and that the fields have the right pointers to parents.). *)
+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 the struct or union) *)
+ mutable ckey: int;
+ (** A unique integer. This is assigned by {!Cil.mkCompInfo} using a
+ * global variable in the Cil module. Thus two identical structs in two
+ * different files might have different keys. Use {!Cil.copyCompInfo} to
+ * copy structures so that a new key is assigned. *)
+ mutable cfields: fieldinfo list;
+ (** Information about the fields. Notice that each fieldinfo has a
+ * pointer back to the host compinfo. This means that you should not
+ * share fieldinfo's between two compinfo's *)
+ mutable cattr: attributes;
+ (** The attributes that are defined at the same time as the composite
+ * type. These attributes can be supplemented individually at each
+ * reference to this [compinfo] using the [TComp] type constructor. *)
+ mutable cdefined: bool;
+ (** This boolean flag can be used to distinguish between structures
+ that have not been defined and those that have been defined but have
+ no fields (such things are allowed in gcc). *)
+ mutable creferenced: bool;
+ (** True if used. Initially set to false. *)
+ }
+
+(** {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
+ * [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
+ * participate in initialization *)
+ 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
+ * the alignment of fields. *)
+ mutable fattr: attributes;
+ (** The attributes for this field (not for its type) *)
+ mutable floc: location;
+ (** The location where this field is defined *)
+}
+
+
+
+(** {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;
+ (** The name. Always non-empty. *)
+ mutable eitems: (string * exp * location) list;
+ (** 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
+ * reference to this [enuminfo] using the [TEnum] type constructor. *)
+ mutable ereferenced: bool;
+ (** True if used. Initially set to false*)
+}
+
+(** {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 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 referred to from the file *)
+ mutable ttype: typ;
+ (** The actual type. This includes the attributes that were present in
+ * the typedef *)
+ mutable treferenced: bool;
+ (** True if used. Initially set to false*)
+}
+
+(** {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}.
+
+ All references to a given global or local variable must refer to the same
+copy of the [varinfo]. Each [varinfo] has a globally unique identifier that
+can be used to index maps and hashtables (the name can also be used for this
+purpose, except for locals from different functions). This identifier is
+constructor using a global counter.
+
+ It is very important that you construct [varinfo] structures using only one
+ of the following functions:
+- {!Cil.makeGlobalVar} : to make a global variable
+- {!Cil.makeTempVar} : to make a temporary local variable whose name
+will be generated so that to avoid conflict with other locals.
+- {!Cil.makeLocalVar} : like {!Cil.makeTempVar} but you can specify the
+exact name to be used.
+- {!Cil.copyVarinfo}: make a shallow copy of a varinfo assigning a new name
+and a new unique identifier
+
+ A [varinfo] is also used in a function type to denote the list of formals.
+
+*)
+
+(** Information about a variable. *)
+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;
+ (** The declared type of the variable. *)
+
+ mutable vattr: attributes;
+ (** A list of attributes associated with the variable.*)
+ mutable vstorage: storage;
+ (** The storage-class *)
+
+ mutable vglob: bool;
+ (** True if this is a global variable*)
+
+ mutable vinline: bool;
+ (** Whether this varinfo is for an inline function. *)
+
+ mutable vdecl: location;
+ (** Location of variable declaration. *)
+
+ mutable vid: int;
+ (** A unique integer identifier. This field will be
+ * set for you if you use one of the {!Cil.makeFormalVar},
+ * {!Cil.makeLocalVar}, {!Cil.makeTempVar}, {!Cil.makeGlobalVar}, or
+ * {!Cil.copyVarinfo}. *)
+
+ mutable vaddrof: bool;
+ (** True if the address of this variable is taken. CIL will set these
+ * flags when it parses C, but you should make sure to set the flag
+ * whenever your transformation create [AddrOf] expression. *)
+
+ mutable vreferenced: bool;
+ (** True if this variable is ever referenced. This is computed by
+ * [removeUnusedVars]. It is safe to just initialize this to False *)
+
+ mutable vdescr: Pretty.doc;
+ (** For most temporary variables, a description of what the var holds.
+ * (e.g. for temporaries used for function call results, this string
+ * is a representation of the function call.) *)
+
+ mutable vdescrpure: bool;
+ (** Indicates whether the vdescr above is a pure expression or call.
+ * Printing a non-pure vdescr more than once may yield incorrect
+ * results. *)
+}
+
+(** Storage-class information *)
+and storage =
+ NoStorage (** The default storage. Nothing is printed *)
+ | Static
+ | Register
+ | 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:
+
+ Integer and floating point constants can carry their textual representation.
+This way the integer 15 can be printed as 0xF if that is how it occurred in the
+source.
+
+ CIL uses 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).
+
+ Use the functions {!Cil.isConstant} and {!Cil.isInteger} to test if
+an expression is a constant and a constant integer respectively.
+
+ CIL keeps the type of all unary and binary expressions. You can think of that
+type qualifying the operator. Furthermore there are different operators for
+arithmetic and comparisons on arithmetic types and on pointers.
+
+ Another unusual aspect of CIL is that the implicit conversion between an
+expression of array type and one of pointer type is made explicit, using the
+[StartOf] expression constructor (which is not printed). If you apply the
+[AddrOf}]constructor to an lvalue of type [T] then you will be getting an
+expression of type [TPtr(T)].
+
+ You can find the type of an expression with {!Cil.typeOf}.
+
+ You can perform constant folding on expressions using the function
+{!Cil.constFold}.
+*)
+
+(** Expressions (Side-effect free)*)
+and exp =
+ Const of constant (** Constant *)
+ | Lval of lval (** Lvalue *)
+ | SizeOf of typ
+ (** sizeof(<type>). Has [unsigned int] type (ISO 6.5.3.4). This is not
+ * turned into a constant because some transformations might want to
+ * change types *)
+
+ | SizeOfE of exp
+ (** sizeof(<expression>) *)
+
+ | SizeOfStr of string
+ (** sizeof(string_literal). We separate this case out because this is the
+ * only instance in which a string literal should not be treated as
+ * having type pointer to character. *)
+
+ | AlignOf of typ
+ (** This corresponds to the GCC __alignof_. Has [unsigned int] type *)
+ | AlignOfE of exp
+
+
+ | UnOp of unop * exp * typ
+ (** Unary operation. Includes the type of the result. *)
+
+ | BinOp of binop * exp * exp * typ
+ (** Binary operation. Includes the type of the result. The arithmetic
+ * conversions are made explicit for the arguments. *)
+
+ | 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
+ * one to use. *)
+
+ | 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
+ * 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
+ * SizeOfStr. *)
+ | 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
+ * the sense that L"A\xabcd" remains "A\xabcd" rather than being
+ * represented as the wide character list with two elements: 65 and
+ * 43981. That "interpretation" depends on the underlying wide
+ * character type. *)
+ | CChr of char
+ (** Character constant. This has type int, so use charConstToInt
+ * to read the value in case sign-extension is needed. *)
+ | CReal of float * fkind * string option
+ (** Floating point constant. Give the fkind (see ISO 6.4.4.2) and also
+ * the textual representation, if available. *)
+ | CEnum of 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
+ * constants. *)
+
+(** Unary operators *)
+and unop =
+ Neg (** Unary minus *)
+ | BNot (** Bitwise complement (~) *)
+ | LNot (** Logical Not (!) *)
+
+(** Binary operations *)
+and binop =
+ PlusA (** arithmetic + *)
+ | PlusPI (** pointer + integer *)
+ | IndexPI (** pointer + integer but only when
+ * it arises from an expression
+ * [e\[i\]] when [e] is a pointer and
+ * not an array. This is semantically
+ * the same as PlusPI but CCured uses
+ * this as a hint that the integer is
+ * probably positive. *)
+ | MinusA (** arithmetic - *)
+ | MinusPI (** pointer - integer *)
+ | MinusPP (** pointer - pointer *)
+ | Mult (** * *)
+ | Div (** / *)
+ | Mod (** % *)
+ | Shiftlt (** shift left *)
+ | Shiftrt (** shift right *)
+
+ | Lt (** < (arithmetic comparison) *)
+ | Gt (** > (arithmetic comparison) *)
+ | Le (** <= (arithmetic comparison) *)
+ | Ge (** > (arithmetic comparison) *)
+ | Eq (** == (arithmetic comparison) *)
+ | Ne (** != (arithmetic comparison) *)
+ | BAnd (** bitwise and *)
+ | BXor (** exclusive-or *)
+ | BOr (** inclusive-or *)
+
+ | LAnd (** logical and. Unlike other
+ * expressions this one does not
+ * always evaluate both operands. If
+ * you want to use these, you must
+ * set {!Cil.useLogicalOperators}. *)
+ | LOr (** logical or. Unlike other
+ * expressions this one does not
+ * always evaluate both operands. If
+ * you want to use these, you must
+ * set {!Cil.useLogicalOperators}. *)
+
+(** {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
+a[0][1][2]
+ v}
+ might involve 1, 2 or 3 memory reads when used in an expression context,
+depending on the declared type of the variable [a]. If [a] has type [int
+\[4\]\[4\]\[4\]] then we have one memory read from somewhere inside the area
+that stores the array [a]. On the other hand if [a] has type [int ***] then
+the expression really means [* ( * ( * (a + 0) + 1) + 2)], in which case it is
+clear that it involves three separate memory operations.
+
+An lvalue denotes the contents of a range of memory addresses. This range
+is denoted as a host object along with an offset within the object. The
+host object can be of two kinds: a local or global variable, or an object
+whose address is in a pointer expression. We distinguish the two cases so
+that we can tell quickly whether we are accessing some component of a
+variable directly or we are accessing a memory location through a pointer.
+To make it easy to
+tell what an lvalue means CIL represents lvalues as a host object and an
+offset (see {!Cil.lval}). The host object (represented as
+{!Cil.lhost}) can be a local or global variable or can be the object
+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.
+
+ The following are a few useful function for operating on lvalues:
+- {!Cil.mkMem} - makes an lvalue of [Mem] kind. Use this to ensure
+that certain equivalent forms of lvalues are canonized.
+For example, [*&x = x].
+- {!Cil.typeOfLval} - the type of an lvalue
+- {!Cil.typeOffset} - the type of an offset, given the type of the
+host.
+- {!Cil.addOffset} and {!Cil.addOffsetLval} - extend sequences
+of offsets.
+- {!Cil.removeOffset} and {!Cil.removeOffsetLval} - shrink sequences
+of offsets.
+
+The following equivalences hold {v
+Mem(AddrOf(Mem a, aoff)), off = Mem a, aoff + off
+Mem(AddrOf(Var v, aoff)), off = Var v, aoff + off
+AddrOf (Mem a, NoOffset) = a
+ v}
+
+*)
+(** An lvalue *)
+and lval =
+ lhost * offset
+
+(** The host part of an {!Cil.lval}. *)
+and lhost =
+ | Var of varinfo
+ (** The host is a variable. *)
+
+ | Mem of exp
+ (** The host is an object of type [T] when the expression has pointer
+ * [TPtr(T)]. *)
+
+
+(** The offset part of an {!Cil.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
+ * offsets. *)
+
+ | Field of fieldinfo * offset
+ (** A field offset. Can be applied only to an lvalue
+ * that denotes a structure or a union that contains
+ * the mentioned field. This advances the offset to the
+ * beginning of the mentioned field and changes the
+ * type to the type of the mentioned field. *)
+
+ | Index of exp * offset
+ (** An array index offset. Can be applied only to an
+ * lvalue that denotes an array. This advances the
+ * starting address of the lval to the beginning of the
+ * mentioned array element and changes the denoted type
+ * to be the type of the array element *)
+
+
+(** {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
+ * {!Cil.foldLeftCompound}. *)
+
+
+(** We want to be able to update an initializer in a global variable, so we
+ * define it as a mutable field *)
+and initinfo = {
+ mutable init : init option;
+ }
+
+(** {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 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}.
+*)
+(** Function definitions. *)
+and fundec =
+ { mutable svar: varinfo;
+ (** Holds the name and type as a variable, so we can refer to it
+ * easily from the program. All references to this function either
+ * in a function call or in a prototype must point to the same
+ * [varinfo]. *)
+ mutable sformals: varinfo list;
+ (** Formals. These must be in the same order and with the same
+ * information as the formal information in the type of the function.
+ * Use {!Cil.setFormals} or
+ * {!Cil.setFunctionType} 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
+ * these because the body refers to them. *)
+ mutable smaxid: int; (** Max local id. Starts at 0. Used for
+ * creating the names of new temporary
+ * variables. Updated by
+ * {!Cil.makeLocalVar} and
+ * {!Cil.makeTempVar}. You can also use
+ * {!Cil.setMaxId} to set it after you
+ * have added the formals and locals. *)
+ mutable sbody: block; (** The function body. *)
+ mutable smaxstmtid: int option; (** max id of a (reachable) statement
+ * in this function, if we have
+ * computed it. range = 0 ...
+ * (smaxstmtid-1). This is computed by
+ * {!Cil.computeCFGInfo}. *)
+ 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
+ one element to the next *)
+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
+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
+is.
+
+ Use {!Cil.mkStmt} to make a statement and the fill-in the fields.
+
+CIL also comes with support for control-flow graphs. The [sid] field in
+[stmt] can be used to give unique numbers to statements, and the [succs]
+and [preds] fields can be used to maintain a list of successors and
+predecessors for every statement. The CFG information is not computed by
+default. Instead you must explicitly use the functions
+{!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
+ * default statements. *)
+
+ mutable skind: stmtkind;
+ (** The kind of statement *)
+
+ mutable sid: int;
+ (** A number (>= 0) that is unique in a function. Filled in only after
+ * the CFG is computed. *)
+ mutable succs: stmt list;
+ (** The successor statements. They can always be computed from the skind
+ * and the context in which this statement appears. Filled in only after
+ * the CFG is computed. *)
+ mutable preds: stmt list;
+ (** The inverse of the succs function. *)
+ }
+
+(** Labels *)
+and label =
+ Label of string * location * bool
+ (** A real label. If the bool is "true", the label is from the
+ * input source program. If the bool is "false", the label was
+ * created by CIL or some other transformation *)
+ | Case of exp * location (** A case statement. This expression
+ * is lowered into a constant if
+ * {!Cil.lowerConstants} is set to
+ * true. *)
+ | Default of location (** A default statement *)
+
+
+
+(** The various kinds of control-flow statements statements *)
+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 leaf in the CFG. *)
+
+ | Goto of stmt ref * location
+ (** A goto statement. Appears from actual goto's in the code or from
+ * goto's that have been inserted during elaboration. The reference
+ * points to the statement that is the target of the Goto. This means that
+ * you have to update the reference whenever you replace the target
+ * statement. The target statement MUST have at least a label. *)
+
+ | Break of location
+ (** A break to the end of the nearest enclosing Loop or Switch *)
+
+ | Continue of location
+ (** A continue to the start of the nearest enclosing [Loop] *)
+ | If of exp * block * block * location
+ (** A conditional. Two successors, the "then" and the "else" branches.
+ * Both branches fall-through to the successor of the If statement. *)
+
+ | Switch of exp * block * (stmt list) * location
+ (** A switch statement. 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 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
+ * 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. 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 !!!
+ *)
+ | TryExcept of block * (instr list * exp) * block * location
+
+
+(** {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
+ * with that of the lvalue *)
+ | 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
+ * type T) is encoded SizeOf(T) *)
+
+ | Asm of attributes * (* Really only const and volatile can appear
+ * here *)
+ string list * (* templates (CR-separated) *)
+ (string option * string * lval) list *
+ (* outputs must be lvals with
+ * optional names and constraints.
+ * I would like these
+ * to be actually variables, but I
+ * run into some trouble with ASMs
+ * in the Linux sources *)
+ (string option * string * exp) list *
+ (* inputs with optional names and constraints *)
+ string list * (* register clobbers *)
+ location
+ (** 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)
+ : "r1", "r2", ..., "nL" );
+ v}
+
+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
+ refer to the input and output expressions. I think they're numbered
+ 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
+ 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
+ "+" to indicate it is both read and written; 'oi' is the
+ name of a C lvalue (probably a variable name) to be used as
+ the output destination
+ - "dj" (ij): pairs of constraint and input expression; the constraint
+ is similar to the "ci"s. the 'ij' is an arbitrary C expression
+ to be loaded into the corresponding register
+ - "rk": registers to be regarded as "clobbered" by the instruction;
+ "memory" may be specified for arbitrary memory effects
+
+an example (from gcc manual):
+{v
+ asm volatile ("movc3 %0,%1,%2"
+ : /* no outputs */
+ : "g" (from), "g" (to), "g" (count)
+ : "r0", "r1", "r2", "r3", "r4", "r5");
+ v}
+
+ Starting with gcc 3.1, the operands may have names:
+
+{v
+ asm volatile ("movc3 %[in0],%1,%2"
+ : /* no outputs */
+ : [in0] "g" (from), "g" (to), "g" (count)
+ : "r0", "r1", "r2", "r3", "r4", "r5");
+ v}
+
+*)
+
+(** Describes a location in a source file. *)
+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]
+ * constructors are unrolled. *)
+and typsig =
+ TSArray of typsig * int64 option * attribute list
+ | TSPtr of typsig * attribute list
+ | TSComp of bool * string * attribute list
+ | TSFun of typsig * typsig list * bool * attribute list
+ | TSEnum of string * attribute list
+ | TSBase of typ
+
+
+
+(** {b Lowering Options} *)
+
+val lowerConstants: bool ref
+ (** Do lower constants (default true) *)
+
+val insertImplicitCasts: bool ref
+ (** Do insert implicit casts (default true) *)
+
+(** To be able to add/remove features easily, each feature should be package
+ * as an interface with the following interface. These features should be *)
+type featureDescr = {
+ fd_enabled: bool ref;
+ (** The enable flag. Set to default value *)
+
+ fd_name: string;
+ (** This is used to construct an option "--doxxx" and "--dontxxx" that
+ * enable and disable the feature *)
+
+ fd_description: string;
+ (** A longer name that can be used to document the new options *)
+
+ fd_extraopt: (string * Arg.spec * string) list;
+ (** Additional command line options. The description strings should
+ usually start with a space for Arg.align to print the --help nicely. *)
+
+ fd_doit: (file -> unit);
+ (** This performs the transformation *)
+
+ fd_post_check: bool;
+ (** Whether to perform a CIL consistency checking after this stage, if
+ * checking is enabled (--check is passed to cilly). Set this to true if
+ * your feature makes any changes for the program. *)
+}
+
+(** Comparison function for locations.
+ ** Compares first by filename, then line, then byte *)
+val compareLoc: location -> location -> int
+
+(** {b Values for manipulating globals} *)
+
+(** Make an empty function *)
+val emptyFunction: string -> fundec
+
+(** Update the formals of a [fundec] and make sure that the function type
+ has the same information. Will copy the name as well into the type. *)
+val setFormals: fundec -> varinfo list -> unit
+
+(** Set the types of arguments and results as given by the function type
+ * passed as the second argument. Will not copy the names from the function
+ * type to the formals *)
+val setFunctionType: fundec -> typ -> unit
+
+
+(** Set the type of the function and make formal arguments for them *)
+val setFunctionTypeMakeFormals: fundec -> typ -> unit
+
+(** Update the smaxid after you have populated with locals and formals
+ * (unless you constructed those using {!Cil.makeLocalVar} or
+ * {!Cil.makeTempVar}. *)
+val setMaxId: fundec -> unit
+
+(** A dummy function declaration handy when you need one as a placeholder. It
+ * contains inside a dummy varinfo. *)
+val dummyFunDec: fundec
+
+(** A dummy file *)
+val dummyFile: file
+
+(** Write a {!Cil.file} in binary form to the filesystem. The file can be
+ * read back in later using {!Cil.loadBinaryFile}, possibly saving parsing
+ * time. The second argument is the name of the file that should be
+ * created. *)
+val saveBinaryFile : file -> string -> unit
+
+(** Write a {!Cil.file} in binary form to the filesystem. The file can be
+ * read back in later using {!Cil.loadBinaryFile}, possibly saving parsing
+ * time. Does not close the channel. *)
+val saveBinaryFileChannel : file -> out_channel -> unit
+
+(** 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. *)
+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
+ * the main function named by the optional argument (default "main") *)
+val getGlobInit: ?main_name:string -> file -> fundec
+
+(** Iterate over all globals, including the global initializer *)
+val iterGlobals: file -> (global -> unit) -> unit
+
+(** Fold over all globals, including the global initializer *)
+val foldGlobals: file -> ('a -> global -> 'a) -> 'a -> 'a
+
+(** Map over all globals, including the global initializer and change things
+ in place *)
+val mapGlobals: file -> (global -> global) -> unit
+
+(** Find a function or function prototype with the given name in the file.
+ * If it does not exist, create a prototype with the given type, and return
+ * the new varinfo. This is useful when you need to call a libc function
+ * whose prototype may or may not already exist in the file.
+ *
+ * Because the new prototype is added to the start of the file, you shouldn't
+ * refer to any struct or union types in the function type.*)
+val findOrCreateFunc: file -> string -> typ -> varinfo
+
+
+val new_sid : unit -> int
+
+(** Prepare a function for CFG information computation by
+ * {!Cil.computeCFGInfo}. This function converts all [Break], [Switch],
+ * [Default] and [Continue] {!Cil.stmtkind}s and {!Cil.label}s into [If]s
+ * and [Goto]s, giving the function body a very CFG-like character. This
+ * function modifies its argument in place. *)
+val prepareCFG: fundec -> unit
+
+(** Compute the CFG information for all statements in a fundec and return a
+ * list of the statements. The input fundec cannot have [Break], [Switch],
+ * [Default], or [Continue] {!Cil.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.
+ *
+ * NOTE: unless you want the simpler control-flow graph provided by
+ * prepareCFG, or you need the function's smaxstmtid and sallstmt fields
+ * filled in, we recommend you use {!Cfg.computeFileCFG} instead of this
+ * function to compute control-flow information.
+ * {!Cfg.computeFileCFG} is newer and will handle switch, break, and
+ * continue correctly.*)
+val computeCFGInfo: fundec -> bool -> unit
+
+
+(** Create a deep copy of a function. There should be no sharing between the
+ * copy and the original function *)
+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
+ * variables to the types stack *)
+val pushGlobal: global -> types: global list ref
+ -> variables: global list ref -> unit
+
+(** An empty statement. Used in pretty printing *)
+val invalidStmt: stmt
+
+
+(** A list of the built-in functions for the current compiler (GCC or
+ * MSVC, depending on [!msvcMode]). Maps the name to the
+ * result and argument types, and whether it is vararg.
+ * Initialized by {!Cil.initCIL}
+ *
+ * This map replaces [gccBuiltins] and [msvcBuiltins] in previous
+ * versions of CIL.*)
+val builtinFunctions : (string, typ * typ list * bool) Hashtbl.t
+
+(** @deprecated. For compatibility with older programs, these are
+ aliases for {!Cil.builtinFunctions} *)
+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
+
+(** This is used as the location of the prototypes of builtin functions. *)
+val builtinLoc: location
+
+
+
+(** {b Values for manipulating initializers} *)
+
+(** Make a initializer for zero-ing a data type *)
+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.
+
+ * This is a good way to use it to scan even nested initializers :
+{v
+ let rec myInit (lv: lval) (i: init) (acc: 'a) : 'a =
+ match i with
+ SingleInit e -> ... do something with lv and e and acc ...
+ | CompoundInit (ct, initl) ->
+ foldLeftCompound ~implicit:false
+ ~doinit:(fun off' i' t' acc ->
+ myInit (addOffsetLval lv off') i' acc)
+ ~ct:ct
+ ~initl:initl
+ ~acc:acc
+v}
+*)
+val foldLeftCompound:
+ implicit:bool ->
+ doinit: (offset -> init -> typ -> 'a -> 'a) ->
+ ct: typ ->
+ initl: (offset * init) list ->
+ acc: 'a -> 'a
+
+
+(** {b Values for manipulating types} *)
+
+(** void *)
+val voidType: typ
+
+(** is the given type "void"? *)
+val isVoidType: typ -> bool
+
+(** is the given type "void *"? *)
+val isVoidPtrType: typ -> bool
+
+(** int *)
+val intType: typ
+
+(** unsigned int *)
+val uintType: typ
+
+(** long *)
+val longType: typ
+
+(** unsigned long *)
+val ulongType: typ
+
+(** char *)
+val charType: typ
+
+(** char * *)
+val charPtrType: typ
+
+(** wchar_t (depends on architecture) and is set when you call
+ * {!Cil.initCIL}. *)
+val wcharKind: ikind ref
+val wcharType: typ ref
+
+(** char const * *)
+val charConstPtrType: typ
+
+(** void * *)
+val voidPtrType: typ
+
+(** int * *)
+val intPtrType: typ
+
+(** unsigned int * *)
+val uintPtrType: typ
+
+(** double *)
+val doubleType: typ
+
+(** An unsigned integer type that fits pointers. Depends on {!Cil.msvcMode}
+ * and is set when you call {!Cil.initCIL}. *)
+val upointType: typ ref
+
+(** 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}.
+ * Set when you call {!Cil.initCIL}. *)
+val kindOfSizeOf: ikind ref
+
+(** Returns true if and only if the given integer type is signed. *)
+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
+ * 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 ->
+ (string * typ * int option * attributes * location) list) ->
+ (* a function that when given a forward
+ representation of the structure type constructs the type of
+ the fields. The function can ignore this argument if not
+ constructing a recursive type. *)
+ attributes -> compinfo
+
+(** Makes a shallow copy of a {!Cil.compinfo} changing the name and the key.*)
+val copyCompInfo: compinfo -> string -> compinfo
+
+(** This is a constant used as the name of an unnamed bitfield. These fields
+ do not participate in initialization and their name is not printed. *)
+val missingFieldName: string
+
+(** Get the full name of a comp *)
+val compFullName: compinfo -> string
+
+(** Returns true if this is a complete type.
+ This means that sizeof(t) makes sense.
+ Incomplete types are not yet defined
+ structures and empty arrays. *)
+val isCompleteType: typ -> bool
+
+(** Unroll a type until it exposes a non
+ * [TNamed]. Will collect all attributes appearing in [TNamed]!!! *)
+val unrollType: typ -> typ
+
+(** Unroll all the TNamed in a type (even under type constructors such as
+ * [TPtr], [TFun] or [TArray]. Does not unroll the types of fields in [TComp]
+ * types. Will collect all attributes *)
+val unrollTypeDeep: typ -> typ
+
+(** Separate out the storage-modifier name attributes *)
+val separateStorageModifiers: attribute list -> attribute list * attribute list
+
+(** 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
+ floating point *)
+val isArithmeticType: typ -> bool
+
+(**True if the argument is a pointer type *)
+val isPointerType: typ -> bool
+
+(** True if the argument is a function type *)
+val isFunctionType: typ -> bool
+
+(** Obtain the argument list ([] if None) *)
+val argsToList: (string * typ * attributes) list option
+ -> (string * typ * attributes) list
+
+(** True if the argument is an array type *)
+val isArrayType: typ -> bool
+
+(** Raised when {!Cil.lenOfArray} fails either because the length is [None]
+ * or because it is a non-constant expression *)
+exception LenOfArray
+
+(** Call to compute the array length as present in the array type, to an
+ * integer. Raises {!Cil.LenOfArray} if not able to compute the length, such
+ * as when there is no length or the length is not a constant. *)
+val lenOfArray: exp option -> int
+
+(** Return a named fieldinfo in compinfo, or raise Not_found *)
+val getCompField: compinfo -> string -> fieldinfo
+
+
+(** A datatype to be used in conjunction with [existsType] *)
+type existsAction =
+ ExistsTrue (** We have found it *)
+ | ExistsFalse (** Stop processing this branch *)
+ | ExistsMaybe (** This node is not what we are
+ * looking for but maybe its
+ * successors are *)
+
+(** Scans a type by applying the function on all elements.
+ When the function returns ExistsTrue, the scan stops with
+ true. When the function returns ExistsFalse then the current branch is not
+ scanned anymore. Care is taken to
+ apply the function only once on each composite type, thus avoiding
+ circularity. When the function returns ExistsMaybe then the types that
+ construct the current type are scanned (e.g. the base type for TPtr and
+ TArray, the type of fields for a TComp, etc). *)
+val existsType: (typ -> existsAction) -> typ -> bool
+
+
+(** Given a function type split it into return type,
+ * arguments, is_vararg and attributes. An error is raised if the type is not
+ * a function type *)
+val splitFunctionType:
+ typ -> typ * (string * typ * attributes) list option * bool * attributes
+(** Same as {!Cil.splitFunctionType} but takes a varinfo. Prints a nicer
+ * error message if the varinfo is not for a function *)
+val splitFunctionTypeVI:
+ varinfo -> typ * (string * typ * attributes) list option * bool * attributes
+
+
+(** {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]
+ * constructors are unrolled. *)
+
+(** Print a type signature *)
+val d_typsig: unit -> typsig -> Pretty.doc
+
+(** Compute a type signature *)
+val typeSig: typ -> typsig
+
+(** Like {!Cil.typeSig} but customize the incorporation of attributes.
+ Use ~ignoreSign:true to convert all signed integer types to unsigned,
+ so that signed and unsigned will compare the same. *)
+val typeSigWithAttrs: ?ignoreSign:bool -> (attributes -> attributes) -> typ -> typsig
+
+(** Replace the attributes of a signature (only at top level) *)
+val setTypeSigAttrs: attributes -> typsig -> typsig
+
+(** Get the top-level attributes of a signature *)
+val typeSigAttrs: typsig -> attributes
+
+(*********************************************************)
+(** LVALUES *)
+
+(** Make a varinfo. Use this (rarely) to make a raw varinfo. Use other
+ * functions to make locals ({!Cil.makeLocalVar} or {!Cil.makeFormalVar} or
+ * {!Cil.makeTempVar}) and globals ({!Cil.makeGlobalVar}). Note that this
+ * function will assign a new identifier. The first argument specifies
+ * whether the varinfo is for a global. *)
+val makeVarinfo: bool -> string -> 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
+ 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
+ set insert=false. *)
+val makeLocalVar: fundec -> ?insert:bool -> string -> typ -> varinfo
+
+(** Make a temporary variable and add it to a function's slocals. CIL will
+ ensure that the name of the new variable is unique in this function, and
+ will generate this name by appending a number to the specified string
+ ("__cil_tmp" by default).
+
+ The variable will be added to the function's slocals unless you explicitly
+ set insert=false. (Make sure you know what you are doing if you set
+ insert=false.)
+
+ Optionally, you can give the variable a description of its contents
+ that will be printed by descriptiveCilPrinter.
+*)
+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 *)
+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
+ * 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
+ * and the offset are compatible. *)
+val addOffsetLval: offset -> lval -> lval
+
+(** [addOffset o1 o2] adds [o1] to the end of [o2]. *)
+val addOffset: offset -> offset -> offset
+
+(** Remove ONE offset from the end of an lvalue. Returns the lvalue with the
+ * trimmed offset and the final offset. If the final offset is [NoOffset]
+ * then the original [lval] did not have an offset. *)
+val removeOffsetLval: lval -> lval * offset
+
+(** Remove ONE offset from the end of an offset sequence. Returns the
+ * trimmed offset and the final offset. If the final offset is [NoOffset]
+ * then the original [lval] did not have an offset. *)
+val removeOffset: offset -> offset * offset
+
+(** Compute the type of an lvalue *)
+val typeOfLval: lval -> typ
+
+(** Compute the type of an offset from a base type *)
+val typeOffset: typ -> offset -> typ
+
+
+(*******************************************************)
+(** {b Values for manipulating expressions} *)
+
+
+(* Construct integer constants *)
+
+(** 0 *)
+val zero: exp
+
+(** 1 *)
+val one: exp
+
+(** -1 *)
+val mone: exp
+
+
+(** Construct an integer of a given kind, using OCaml's int64 type. If needed
+ * it will truncate the integer to be within the representable range for the
+ * given kind. *)
+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
+ * the Char or Short kinds *)
+val kinteger: ikind -> int -> exp
+
+(** Construct an integer of kind IInt. You can use this always since the
+ OCaml integers are 31 bits and are guaranteed to fit in an IInt *)
+val integer: int -> exp
+
+
+(** If the given expression is a (possibly cast'ed)
+ character or an integer constant, return that integer.
+ Otherwise, return None. *)
+val isInteger: exp -> int64 option
+
+(** Convert a 64-bit int to an OCaml int, or raise an exception if that
+ can't be done. *)
+val i64_to_int: int64 -> int
+
+(** True if the expression is a compile-time constant *)
+val isConstant: exp -> bool
+
+(** True if the given offset contains only field nanmes or constant indices. *)
+val isConstantOffset: offset -> bool
+
+(** True if the given expression is a (possibly cast'ed) integer or character
+ constant with value zero *)
+val isZero: exp -> bool
+
+(** Given the character c in a (CChr c), sign-extend it to 32 bits.
+ (This is the official way of interpreting character constants, according to
+ ISO C 6.4.4.4.10, which says that character constants are chars cast to ints)
+ Returns CInt64(sign-extened c, IInt, None) *)
+val charConstToInt: char -> constant
+
+val convertInts: int64 -> ikind -> int64 -> ikind -> int64 * int64 * ikind
+
+(** Do constant folding on an expression. If the first argument is true then
+ will also compute compiler-dependent expressions such as sizeof.
+ See also {!Cil.constFoldVisitor}, which will run constFold on all
+ expressions in a given AST node.*)
+val constFold: bool -> exp -> exp
+
+(** Do constant folding on 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 *)
+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
+ type ptr(T). It optimizes somewhat expressions like "& v" and "& v[0]" *)
+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
+ 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
+ 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
+ * 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
+
+(** Removes casts from this expression, but ignores casts within
+ other expression constructs. So we delete the (A) and (B) casts from
+ "(A)(B)(x + (C)y)", but leave the (C) cast. *)
+val stripCasts: exp -> exp
+
+(** Compute the type of an expression *)
+val typeOf: exp -> typ
+
+(** 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
+
+
+(**********************************************)
+(** {b Values for manipulating statements} *)
+
+(** Construct a statement, given its kind. Initialize the [sid] field to -1,
+ and [labels], [succs] and [preds] to the empty list *)
+val mkStmt: stmtkind -> stmt
+
+(** Construct a block with no attributes, given a list of statements *)
+val mkBlock: stmt list -> block
+
+(** Construct a statement consisting of just one instruction *)
+val mkStmtOneInstr: instr -> stmt
+
+(** Try to compress statements so as to get maximal basic blocks.
+ * use this instead of List.@ because you get fewer basic blocks *)
+val compactStmts: stmt list -> stmt list
+
+(** Returns an empty statement (of kind [Instr]) *)
+val mkEmptyStmt: unit -> stmt
+
+(** A instr to serve as a placeholder *)
+val dummyInstr: instr
+
+(** A statement consisting of just [dummyInstr] *)
+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<past; i += incr) \{ ... \}. The body
+ can contain Break but not Continue. Can be used with i a pointer
+ or an integer. Start and done must have the same type but incr
+ must be an integer *)
+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 ->
+ 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
+ specifier *)
+ | AttrFunType of bool
+ (** Attribute of a function type. If argument is true and we are on
+ MSVC then the attribute is printed just before the function name *)
+ | AttrType (** Attribute of a type *)
+
+(** This table contains the mapping of predefined attributes to classes.
+ Extend this table with more attributes as you need. This table is used to
+ determine how to associate attributes with names or types *)
+val attributeHash: (string, attributeClass) Hashtbl.t
+
+(** Partition the attributes into classes:name attributes, function type,
+ and type attributes *)
+val partitionAttributes: default:attributeClass ->
+ attributes -> attribute list * (* AttrName *)
+ attribute list * (* AttrFunType *)
+ attribute list (* AttrType *)
+
+(** Add an attribute. Maintains the attributes in sorted order of the second
+ argument *)
+val addAttribute: attribute -> attributes -> attributes
+
+(** Add a list of attributes. Maintains the attributes in sorted order. The
+ second argument must be sorted, but not necessarily the first *)
+val addAttributes: attribute list -> attributes -> attributes
+
+(** Remove all attributes with the given name. Maintains the attributes in
+ sorted order. *)
+val dropAttribute: string -> attributes -> attributes
+
+(** Remove all attributes with names appearing in the string list.
+ * Maintains the attributes in sorted order *)
+val dropAttributes: string list -> attributes -> attributes
+
+(** Retains attributes with the given name *)
+val filterAttributes: string -> attributes -> attributes
+
+(** True if the named attribute appears in the attribute list. The list of
+ attributes must be sorted. *)
+val hasAttribute: string -> attributes -> bool
+
+(** Returns 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
+
+val setTypeAttrs: typ -> attributes -> typ (* Resets the attributes *)
+
+
+(** Add some attributes to a type *)
+val typeAddAttributes: attribute list -> typ -> typ
+
+(** Remove all attributes with the given names from a type. Note that this
+ does not remove attributes from typedef and tag definitions, just from
+ their uses *)
+val typeRemoveAttributes: string list -> typ -> typ
+
+
+(** Convert an expression into an attrparam, if possible. Otherwise raise
+ NotAnAttrParam with the offending subexpression *)
+val expToAttrParam: exp -> attrparam
+
+exception NotAnAttrParam of exp
+
+(******************
+ ****************** VISITOR
+ ******************)
+(** {b The visitor} *)
+
+(** Different visiting actions. 'a will be instantiated with [exp], [instr],
+ etc. *)
+type 'a visitAction =
+ SkipChildren (** Do not visit the children. Return
+ the node as it is. *)
+ | DoChildren (** Continue with the children of this
+ node. Rebuild the node on return
+ if any of the children changes
+ (use == test) *)
+ | 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
+ 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
+ * 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
+ * definition. *)
+
+ method vvrbl: varinfo -> varinfo visitAction
+ (** Invoked on each variable use. Here only the [SkipChildren] and
+ * [ChangeTo] actions make sense since there are no subtrees. Note that
+ * the type and attributes of the variable are not traversed for a
+ * variable use *)
+
+ method vexpr: exp -> exp visitAction
+ (** Invoked on each expression occurrence. The subtrees are the
+ * subexpressions, the types (for a [Cast] or [SizeOf] expression) or the
+ * variable use. *)
+
+ method vlval: lval -> lval visitAction
+ (** Invoked on each lvalue occurrence *)
+
+ method voffs: offset -> offset visitAction
+ (** Invoked on each offset occurrence that is *not* as part
+ * of an initializer list specification, i.e. in an lval or
+ * recursively inside an offset. *)
+
+ method vinitoffs: offset -> offset visitAction
+ (** Invoked on each offset appearing in the list of a
+ * CompoundInit initializer. *)
+
+ method vinst: instr -> instr list visitAction
+ (** Invoked on each instruction occurrence. The [ChangeTo] action can
+ * replace this instruction with a list of instructions *)
+
+ method vstmt: stmt -> stmt visitAction
+ (** Control-flow statement. 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
+ (** Initializers for globals,
+ * pass the global where this
+ * occurs, and the offset *)
+ method vtype: typ -> typ visitAction (** Use of some type. Note
+ * that for structure/union
+ * and enumeration types the
+ * definition of the
+ * composite type is not
+ * visited. Use [vglob] to
+ * visit it. *)
+ method vattr: attribute -> attribute list visitAction
+ (** Attribute. Each attribute can be replaced by a list *)
+ method vattrparam: attrparam -> attrparam visitAction
+ (** Attribute parameters. *)
+
+ (** Add here instructions while visiting to queue them to preceede the
+ * current statement or instruction being processed. 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. *)
+ method unqueueInstr: unit -> instr list
+
+end
+
+(** Default Visitor. Traverses the CIL tree without modifying anything *)
+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
+ * not change the list of globals. *)
+val visitCilFile: cilVisitor -> file -> unit
+
+(** A visitor for the whole file that does not change the globals (but maybe
+ * changes things inside the globals). Use this function instead of
+ * {!Cil.visitCilFile} whenever appropriate because it is more efficient for
+ * long files. *)
+val visitCilFileSameGlobals: cilVisitor -> file -> unit
+
+(** Visit a global *)
+val visitCilGlobal: cilVisitor -> global -> global list
+
+(** Visit a function definition *)
+val visitCilFunction: cilVisitor -> fundec -> fundec
+
+(* Visit an expression *)
+val visitCilExpr: cilVisitor -> exp -> exp
+
+(** Visit an lvalue *)
+val visitCilLval: cilVisitor -> lval -> lval
+
+(** Visit an lvalue or recursive offset *)
+val visitCilOffset: cilVisitor -> offset -> offset
+
+(** Visit an initializer offset *)
+val visitCilInitOffset: cilVisitor -> offset -> offset
+
+(** Visit an instruction *)
+val visitCilInstr: cilVisitor -> instr -> instr list
+
+(** Visit a statement *)
+val visitCilStmt: cilVisitor -> stmt -> stmt
+
+(** Visit a block *)
+val visitCilBlock: cilVisitor -> block -> block
+
+(** Visit a type *)
+val visitCilType: cilVisitor -> typ -> typ
+
+(** Visit a variable declaration *)
+val visitCilVarDecl: cilVisitor -> varinfo -> varinfo
+
+(** Visit an initializer, pass also the global to which this belongs and the
+ * offset. *)
+val visitCilInit: cilVisitor -> varinfo -> offset -> init -> init
+
+
+(** Visit a list of attributes *)
+val visitCilAttributes: cilVisitor -> attribute list -> attribute list
+
+(* And some generic visitors. The above are built with these *)
+
+
+(** {b Utility functions} *)
+
+(** 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
+
+
+(** 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
+
+
+(** 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
+ * visual inspection *)
+ | 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 *)
+
+(** How to print line directives *)
+val lineDirectiveStyle: lineDirectiveStyle option ref
+
+(** 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. These is one case howewer in which if you
+ * turn this on you will get code that does not compile: if you use varargs
+ * the __builtin_va_arg function will be printed in its internal form. *)
+val printCilAsIs: bool ref
+
+(** The length used when wrapping output lines. Setting this variable to
+ * a large integer will prevent wrapping and make #line directives more
+ * accurate.
+ *)
+val lineLength: int ref
+
+(** Return the string 's' if we're printing output for gcc, suppres
+ * it if we're printing for CIL to parse back in. the purpose is to
+ * hide things from gcc that it complains about, but still be able
+ * to do lossless transformations when CIL is the consumer *)
+val forgcc: string -> string
+
+(** {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
+ * will print the location. *)
+val currentLoc: location ref
+
+(** A reference to the current global being visited *)
+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}).
+
+ 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
+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
+a corresponding function that pretty-prints an element of that type:
+*)
+
+
+(** Pretty-print a location *)
+val d_loc: unit -> location -> Pretty.doc
+
+(** Pretty-print the {!Cil.currentLoc} *)
+val d_thisloc: unit -> Pretty.doc
+
+(** Pretty-print an integer of a given kind *)
+val d_ikind: unit -> ikind -> Pretty.doc
+
+(** Pretty-print a floating-point kind *)
+val d_fkind: unit -> fkind -> Pretty.doc
+
+(** Pretty-print storage-class information *)
+val d_storage: unit -> storage -> Pretty.doc
+
+(** Pretty-print a constant *)
+val d_const: unit -> constant -> Pretty.doc
+
+
+val derefStarLevel: int
+val indexLevel: int
+val arrowLevel: int
+val addrOfLevel: int
+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
+ * stronger precedence!
+ *)
+val getParenthLevel: exp -> int
+
+(** A printer interface for CIL trees. Create instantiations of
+ * this type by specializing the class {!Cil.defaultCilPrinterClass}. *)
+class type cilPrinter = object
+
+ method setCurrentFormals : varinfo list -> unit
+
+ method setPrintInstrTerminator : string -> unit
+ 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
+ * definitions. *)
+
+ method pVar: varinfo -> Pretty.doc
+ (** Invoked on each variable use. *)
+
+ method pLval: unit -> lval -> Pretty.doc
+ (** Invoked on each lvalue occurrence *)
+
+ method pOffset: Pretty.doc -> offset -> Pretty.doc
+ (** Invoked on each offset occurrence. The second argument is the base. *)
+
+ method pInstr: unit -> instr -> Pretty.doc
+ (** Invoked on each instruction occurrence. *)
+
+ method pLabel: unit -> label -> Pretty.doc
+ (** Print a label. *)
+
+ method pStmt: unit -> stmt -> Pretty.doc
+ (** 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 {!Cil.dumpGlobal}. *)
+
+ method dBlock: out_channel -> int -> block -> unit
+ (** 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
+ * {!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
+ * {!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
+ * visit it. *)
+
+ method pAttr: attribute -> Pretty.doc * bool
+ (** Attribute. Also return an indication whether this attribute must be
+ * printed inside the __attribute__ list or not. *)
+
+ 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
+ * file name is stored in a private field inside the cilPrinter object. *)
+
+ method pStmtKind: stmt -> unit -> stmtkind -> Pretty.doc
+ (** Print a statement kind. The code to be printed is given in the
+ * {!Cil.stmtkind} argument. The initial {!Cil.stmt} argument
+ * records the statement which follows the one being printed;
+ * {!Cil.defaultCilPrinterClass} uses this information to prettify
+ * statement printing in certain special cases. *)
+
+ method pExp: unit -> exp -> Pretty.doc
+ (** Print expressions *)
+
+ method pInit: unit -> init -> Pretty.doc
+ (** 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
+ * {!Cil.dumpGlobal} *)
+end
+
+class defaultCilPrinterClass: cilPrinter
+val defaultCilPrinter: cilPrinter
+
+(** 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
+
+class type descriptiveCilPrinter = object
+ inherit cilPrinter
+
+ method startTemps: unit -> unit
+ method stopTemps: unit -> unit
+ method pTemps: unit -> Pretty.doc
+end
+
+class descriptiveCilPrinterClass : bool -> descriptiveCilPrinter
+ (** Like defaultCilPrinterClass, but instead of temporary variable
+ names it prints the description that was provided when the temp was
+ created. This is usually better for messages that are printed for end
+ users, although you may want the temporary names for debugging.
+
+ 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
+ feature off. *)
+
+val descriptiveCilPrinter: descriptiveCilPrinter
+
+(** zra: This is the pretty printer that Maincil will use.
+ by default it is set to defaultCilPrinter *)
+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
+
+(** Print an lvalue given a pretty printer *)
+val printLval: cilPrinter -> unit -> lval -> Pretty.doc
+
+(** Print a global given a pretty printer *)
+val printGlobal: cilPrinter -> unit -> global -> Pretty.doc
+
+(** Print an attribute given a pretty printer *)
+val printAttr: cilPrinter -> unit -> attribute -> Pretty.doc
+
+(** Print a set of attributes given a pretty printer *)
+val printAttrs: cilPrinter -> unit -> attributes -> Pretty.doc
+
+(** Print an instruction given a pretty printer *)
+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}
+ * 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}
+ * instead. *)
+val printBlock: cilPrinter -> unit -> block -> Pretty.doc
+
+(** 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
+ * {!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}
+ * instead. *)
+val printInit: cilPrinter -> unit -> init -> Pretty.doc
+
+(** 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
+
+(** Pretty-print a type using {!Cil.defaultCilPrinter} *)
+val d_type: unit -> typ -> Pretty.doc
+
+(** Pretty-print an expression using {!Cil.defaultCilPrinter} *)
+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
+ * 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
+ * {!Cil.dumpInit} instead. *)
+val d_init: unit -> init -> Pretty.doc
+
+(** Pretty-print a binary operator *)
+val d_binop: unit -> binop -> Pretty.doc
+
+(** Pretty-print a unary operator *)
+val d_unop: unit -> unop -> Pretty.doc
+
+(** Pretty-print an attribute using {!Cil.defaultCilPrinter} *)
+val d_attr: unit -> attribute -> Pretty.doc
+
+(** Pretty-print an argument of an attribute using {!Cil.defaultCilPrinter} *)
+val d_attrparam: unit -> attrparam -> Pretty.doc
+
+(** Pretty-print a list of attributes using {!Cil.defaultCilPrinter} *)
+val d_attrlist: unit -> attributes -> Pretty.doc
+
+(** Pretty-print an instruction using {!Cil.defaultCilPrinter} *)
+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
+ * {!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
+ * {!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
+ * {!Cil.dumpGlobal} instead. *)
+val d_global: unit -> global -> Pretty.doc
+
+
+(** Versions of the above pretty printers, that don't print #line directives *)
+val dn_exp : unit -> exp -> Pretty.doc
+val dn_lval : unit -> lval -> Pretty.doc
+(* dn_offset is missing because it has a different interface *)
+val dn_init : unit -> init -> Pretty.doc
+val dn_type : unit -> typ -> Pretty.doc
+val dn_global : unit -> global -> Pretty.doc
+val dn_attrlist : unit -> attributes -> Pretty.doc
+val dn_attr : unit -> attribute -> Pretty.doc
+val dn_attrparam : unit -> attrparam -> Pretty.doc
+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
+ * messages *)
+val d_shortglobal: unit -> global -> Pretty.doc
+
+(** Pretty-print a global. Here you give the channel where the printout
+ * should be sent. *)
+val dumpGlobal: cilPrinter -> out_channel -> global -> unit
+
+(** Pretty-print an entire file. Here you give the channel where the printout
+ * should be sent. *)
+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
+ * that *)
+
+(** Like {!Errormsg.bug} except that {!Cil.currentLoc} is also printed *)
+val bug: ('a,unit,Pretty.doc) format -> 'a
+
+(** Like {!Errormsg.unimp} except that {!Cil.currentLoc}is also printed *)
+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,
+ * instead of using the {!Cil.currentLoc} *)
+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.
+ * 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
+ is also printed *)
+val warnContext: ('a,unit,Pretty.doc) format -> 'a
+
+(** 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,
+ * instead of using the {!Cil.currentLoc} *)
+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
+ * not valid C *)
+
+(** Pretty-print the internal representation of an expression *)
+val d_plainexp: unit -> exp -> Pretty.doc
+
+(** Pretty-print the internal representation of an integer *)
+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
+val d_plainoffset: unit -> offset -> Pretty.doc *)
+
+(** Pretty-print the internal representation of a type *)
+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,
+ that var will not be replaced by a description; use "dd_exp () (Lval lv)"
+ if that's what you want. *)
+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
+ * conflicts with a global *)
+val uniqueVarNames: file -> unit
+
+(** {b Optimization Passes} *)
+
+(** A peephole optimizer that processes two adjacent statements and possibly
+ replaces them both. If some replacement happens, then the new statements
+ 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
+ one statement, 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 *)
+exception SizeOfError of string * typ
+
+(** Give the unsigned kind corresponding to any integer kind *)
+val unsignedVersionOf : ikind -> ikind
+
+(** The signed integer kind for a given size. Raises Not_found
+ * if no such kind exists *)
+val intKindForSize : int -> ikind
+
+(** The float kind for a given size. Raises Not_found
+ * if no such kind exists *)
+val floatKindForSize : int-> fkind
+
+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
+ * call {!Cil.initCIL}. Remember that on GCC sizeof(void) is 1! *)
+val bitsSizeOf: typ -> int
+
+val truncateInteger64: ikind -> int64 -> int64 * bool
+
+(** The size of a type, in bytes. Returns a constant expression or a "sizeof"
+ * expression if it cannot compute the size. This function is architecture
+ * dependent, so you should only call this after you call {!Cil.initCIL}. *)
+val sizeOf: typ -> exp
+
+(** The minimum alignment (in bytes) for a type. This function is
+ * architecture dependent, so you should only call this after you call
+ * {!Cil.initCIL}. *)
+val 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
+ * this after you call {!Cil.initCIL}. *)
+val bitsOffset: typ -> offset -> int * int
+
+
+(** Whether "char" is unsigned. Set after you call {!Cil.initCIL} *)
+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
+ identifier. That is, will function foo() have the label "foo", or "_foo"?
+ Set after you call {!Cil.initCIL} *)
+val underscore_name: bool ref
+
+(** Represents a location that cannot be determined *)
+val locUnknown: location
+
+(** Return the location of an instruction *)
+val get_instrLoc: instr -> location
+
+(** Return the location of a global, or locUnknown *)
+val get_globalLoc: global -> location
+
+(** Return the location of a statement, or locUnknown *)
+val get_stmtLoc: stmtkind -> location
+
+
+(** Generate an {!Cil.exp} to be used in case of errors. *)
+val dExp: Pretty.doc -> exp
+
+(** Generate an {!Cil.instr} to be used in case of errors. *)
+val dInstr: Pretty.doc -> location -> instr
+
+(** Generate a {!Cil.global} to be used in case of errors. *)
+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
+ list *)
+val mapNoCopyList: ('a -> 'a list) -> 'a list -> 'a list
+
+(** sm: return true if the first is a prefix of the second string *)
+val startsWith: string -> string -> bool
+
+(** return true if the first is a suffix of the second string *)
+val endsWith: string -> string -> bool
+
+(** If string has leading and trailing __, strip them. *)
+val stripUnderscores: string -> string
+
+
+(** {b An Interpreter for constructing CIL constructs} *)
+
+(** The type of argument for the interpreter *)
+type formatArg =
+ Fe of exp
+ | Feo of exp option (** For array lengths *)
+ | Fu of unop
+ | Fb of binop
+ | Fk of ikind
+ | FE of exp list (** For arguments in a function call *)
+ | Ff of (string * typ * attributes) (** For a formal argument *)
+ | FF of (string * typ * attributes) list (** For formal argument lists *)
+ | Fva of bool (** For the ellipsis in a function type *)
+ | Fv of varinfo
+ | Fl of lval
+ | Flo of lval option
+
+ | Fo of offset
+
+ | Fc of compinfo
+ | Fi of instr
+ | FI of instr list
+ | Ft of typ
+ | Fd of int
+ | Fg of string
+ | Fs of stmt
+ | FS of stmt list
+ | FA of attributes
+
+ | Fp of attrparam
+ | FP of attrparam list
+
+ | FX of string
+
+
+(** Pretty-prints a format arg *)
+val d_formatarg: unit -> formatArg -> Pretty.doc
+
+(** Emit warnings when truncating integer constants (default true) *)
+val warnTruncate: bool ref
+
+(** Machine model specified via CIL_MACHINE environment variable *)
+val envMachine : Machdep.mach option ref
--- /dev/null
+Alpha
+Availexps
+Availexpslv
+Bitmap
+Cabs
+Cabs2cil
+Cabshelper
+Cabsvisit
+Callgraph
+Canonicalize
+Cfg
+Check
+Cil
+Cillower
+Ciloptions
+Ciltools
+Cilutil
+Cilversion
+Clexer
+Clist
+Cparser
+Cprint
+Dataflow
+Dataslicing
+Deadcodeelim
+Dominators
+Epicenter
+Errormsg
+Escape
+Expcompare
+Feature_config
+Formatcil
+Formatlex
+Formatparse
+Frontc
+GrowArray
+Heap
+Heapify
+Inthash
+Lexerhack
+Liveness
+Logcalls
+Logwrites
+Longarray
+Machdep
+Mergecil
+Olf
+Oneret
+Partial
+Patch
+Predabst
+Pretty
+Ptranal
+Reachingdefs
+Rmtmps
+Setp
+Sfi
+Simplemem
+Simplify
+Ssa
+Stats
+Testcil
+Trace
+Uref
+Usedef
+Util
+Whitetrack
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2003,
+ * 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.
+ *
+ * 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 number of lowering passes over CIL *)
+open Cil
+open Pretty
+module E = Errormsg
+
+(** Lower CEnum constants *)
+class lowerEnumVisitorClass : cilVisitor = object (self)
+ inherit nopCilVisitor
+
+ method vexpr (e: exp) =
+ match e with
+ Const (CEnum(v, s, ei)) ->
+ ChangeTo (visitCilExpr (self :>cilVisitor) v)
+
+ | _ -> DoChildren
+
+end
+
+let lowerEnumVisitor = new lowerEnumVisitorClass
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2003,
+ * 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.
+ *
+ * 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 number of lowering passes over CIL *)
+
+(** Replace enumeration constants with integer constants *)
+val lowerEnumVisitor : Cil.cilVisitor
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2003,
+ * 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.
+ *
+ * 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.
+ *
+ *)
+
+
+module E = Errormsg
+
+let setDebugFlag v name =
+ E.debugFlag := v;
+ if v then Pretty.flushOften := true
+
+type outfile =
+ { fname: string;
+ fchan: out_channel }
+
+ (* Processign of output file arguments *)
+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 fileNames : string list ref = ref []
+let recordFile fname =
+ fileNames := fname :: (!fileNames)
+
+ (* Parsing of files with additional names *)
+let parseExtraFile (s: string) =
+ try
+ let sfile = open_in s in
+ while true do
+ let line = try input_line sfile with e -> (close_in sfile; raise e) in
+ let linelen = String.length line in
+ let rec scan (pos: int) (* next char to look at *)
+ (start: int) : unit (* start of the word,
+ or -1 if none *) =
+ if pos >= linelen then
+ if start >= 0 then
+ recordFile (String.sub line start (pos - start))
+ else
+ () (* Just move on to the next line *)
+ else
+ let c = String.get line pos in
+ match c with
+ ' ' | '\n' | '\r' | '\t' ->
+ (* whitespace *)
+ if start >= 0 then begin
+ recordFile (String.sub line start (pos - start));
+ end;
+ scan (pos + 1) (-1)
+
+ | _ -> (* non-whitespace *)
+ if start >= 0 then
+ scan (pos + 1) start
+ else
+ scan (pos + 1) pos
+ in
+ scan 0 (-1)
+ done
+ with Sys_error _ -> E.s (E.error "Cannot find extra file: %s\n" s)
+ | End_of_file -> ()
+
+
+let options : (string * Arg.spec * string) list =
+ let is_default = function
+ true -> " (default)"
+ | false -> "" in
+ [
+ (* General Options *)
+ "", Arg.Unit (fun () -> ()), " \n\t\tGeneral Options\n";
+
+ "--version",
+ Arg.Unit (fun _ ->
+ print_endline ("CIL version " ^ Cil.cilVersion ^
+ "\nMore information at http://cil.sourceforge.net/\n");
+ exit 0),
+ " Output version information and exit";
+
+ "--verbose",
+ Arg.Set E.verboseFlag,
+ (" Print lots of random stuff; this is passed on from cilly" ^
+ is_default !E.verboseFlag);
+
+ "--noverbose",
+ Arg.Clear E.verboseFlag,
+ (" Undo effect of verbose flag" ^ is_default (not !E.verboseFlag));
+
+ "--warnall",
+ Arg.Set E.warnFlag,
+ (" Show optional warnings" ^ is_default !E.warnFlag);
+
+ "--nowarnall",
+ Arg.Clear E.warnFlag,
+ (" Disable optional warnings" ^ is_default (not !E.warnFlag));
+
+ "--noTruncateWarning",
+ Arg.Clear Cil.warnTruncate,
+ " Suppress warning about truncating integer constants";
+
+ "--debug",
+ Arg.String (setDebugFlag true),
+ "<xxx> Turn on debugging flag xxx";
+
+ "--nodebug",
+ Arg.String (setDebugFlag false),
+ "<xxx> Turn off debugging flag xxx";
+
+ "--flush",
+ Arg.Set Pretty.flushOften,
+ (" Flush the output streams often; aids debugging" ^
+ is_default !Pretty.flushOften);
+
+ "--noflush",
+ Arg.Clear Pretty.flushOften,
+ (" Only flush output streams when inevitable" ^
+ is_default (not !Pretty.flushOften));
+
+ "--check",
+ Arg.Set Cilutil.doCheck,
+ (" Run a consistency check over the CIL after every operation" ^
+ is_default !Cilutil.doCheck);
+
+ "--nocheck",
+ Arg.Clear Cilutil.doCheck,
+ (" Turn off consistency checking of CIL" ^
+ is_default (not !Cilutil.doCheck));
+
+ "--strictcheck", Arg.Unit (fun _ -> Cilutil.doCheck := true;
+ Cilutil.strictChecking := true),
+ " Same as --check, but treats problems as errors not warnings.";
+ "", Arg.Unit (fun _ -> ()), "";
+
+ "--noPrintLn",
+ Arg.Unit (fun _ ->
+ Cil.lineDirectiveStyle := None;
+ Cprint.printLn := false),
+ " Do not output #line directives in the output";
+
+ "--commPrintLn",
+ Arg.Unit (fun _ ->
+ Cil.lineDirectiveStyle := Some Cil.LineComment;
+ Cprint.printLnComment := true),
+ " Print #line directives in the output, but put them in comments";
+
+ "--commPrintLnSparse",
+ Arg.Unit (fun _ ->
+ Cil.lineDirectiveStyle := Some Cil.LineCommentSparse;
+ Cprint.printLnComment := true),
+ " Print commented #line directives in the output only when\n\t\t\t\tthe line number changes.";
+
+ "--stats",
+ Arg.Set Cilutil.printStats,
+ (" Print statistics about running times and memory usage" ^
+ is_default !Cilutil.printStats);
+
+ "--nostats",
+ Arg.Clear Cilutil.printStats,
+ (" Do not print statistics" ^
+ is_default (not !Cilutil.printStats));
+
+ "--log",
+ Arg.String (openFile "log" (fun oc -> E.logChannel := oc.fchan)),
+ "<filename> Set the name of the log file; by default use stderr";
+
+ "--MSVC",
+ Arg.Unit (fun _ ->
+ Cil.msvcMode := true;
+ Frontc.setMSVCMode ();
+ if not Machdep.hasMSVC then
+ ignore (E.warn "Will work in MSVC mode but will be using machine-dependent parameters for GCC since you do not have the MSVC compiler installed\n")),
+ " Enable MSVC compatibility; default is GNU";
+
+ "--envmachine",
+ Arg.Unit (fun _ ->
+ try
+ let machineModel = Sys.getenv "CIL_MACHINE" in
+ Cil.envMachine := Some (Machdepenv.modelParse machineModel);
+ with
+ Not_found ->
+ ignore (E.error "CIL_MACHINE environment variable is not set")
+ | Failure msg ->
+ ignore (E.error "CIL_MACHINE machine model is invalid: %s" msg)),
+ " Use machine model specified in CIL_MACHINE environment variable";
+
+ "--testcil",
+ Arg.String (fun s -> Cilutil.testcil := s),
+ "<compiler> Test CIL using the given compiler";
+
+ "--ignore-merge-conflicts",
+ Arg.Set Mergecil.ignore_merge_conflicts,
+ (" Ignore merging conflicts" ^
+ is_default !Mergecil.ignore_merge_conflicts);
+
+(* Little-used: *)
+(* "--noignore-merge-conflicts", *)
+(* Arg.Clear Mergecil.ignore_merge_conflicts, *)
+(* (" Do not ignore merging conflicts" ^ *)
+(* is_default (not !Mergecil.ignore_merge_conflicts)); *)
+
+ "--sliceGlobal",
+ Arg.Set Cilutil.sliceGlobal,
+ " Output is the slice of #pragma cilnoremove(sym) symbols";
+
+ (* sm: some more debugging options *)
+ "--tr",
+ Arg.String Trace.traceAddMulti,
+ "<sys> Subsystem to show debug printfs for";
+
+ "--extrafiles",
+ Arg.String parseExtraFile,
+ "<filename> File that contains a list of additional files to process,\n\t\t\t\tseparated by newlines";
+
+ (* Lowering Options *)
+ "", Arg.Unit (fun () -> ()), " \n\t\tLowering Options\n";
+
+ "--lowerConstants",
+ Arg.Set Cil.lowerConstants,
+ (" Lower constant expressions" ^ is_default !Cil.lowerConstants);
+
+ "--noLowerConstants",
+ Arg.Clear Cil.lowerConstants,
+ (" Do not lower constant expressions" ^
+ is_default (not !Cil.lowerConstants));
+
+ "--insertImplicitCasts",
+ Arg.Set Cil.insertImplicitCasts,
+ (" Insert implicit casts" ^ is_default !Cil.insertImplicitCasts);
+
+ "--noInsertImplicitCasts",
+ Arg.Clear Cil.insertImplicitCasts,
+ (" Do not insert implicit casts" ^
+ is_default (not !Cil.insertImplicitCasts));
+
+ "--forceRLArgEval",
+ Arg.Set Cabs2cil.forceRLArgEval,
+ (" Forces right to left evaluation of function arguments" ^
+ is_default !Cabs2cil.forceRLArgEval);
+
+ "--noForceRLArgEval",
+ Arg.Clear Cabs2cil.forceRLArgEval,
+ (" Evaluate function arguments in unspecified order" ^
+ is_default (not !Cabs2cil.forceRLArgEval));
+
+ "--nocil",
+ Arg.Int (fun n -> Cabs2cil.nocil := n),
+ "<index> Do not compile to CIL the global with the given index";
+
+ "--noDisallowDuplication",
+ Arg.Set Cabs2cil.allowDuplication,
+ (" Duplicate small chunks of code if necessary" ^
+ is_default !Cabs2cil.allowDuplication);
+
+ "--disallowDuplication",
+ Arg.Clear Cabs2cil.allowDuplication,
+ (" Prevent small chunks of code from being duplicated" ^
+ is_default (not !Cabs2cil.allowDuplication));
+
+ "--keepunused",
+ Arg.Set Rmtmps.keepUnused,
+ (" Do not remove the unused variables and types" ^
+ is_default !Rmtmps.keepUnused);
+
+ "--nokeepunused",
+ Arg.Clear Rmtmps.keepUnused,
+ (" Remove unused variables and types" ^
+ is_default (not !Rmtmps.keepUnused));
+
+ "--rmUnusedInlines",
+ Arg.Set Rmtmps.rmUnusedInlines,
+ (" Delete any unused inline functions; this is the default in MSVC mode" ^
+ is_default !Rmtmps.rmUnusedInlines);
+
+ "--noRmUnusedInlines",
+ Arg.Clear Rmtmps.rmUnusedInlines,
+ (" Do not delete any unused inline functions" ^
+ is_default (not !Rmtmps.rmUnusedInlines));
+
+ (* Output Options *)
+ "", Arg.Unit (fun () -> ()), " \n\t\tOutput Options\n";
+
+ "--printCilAsIs",
+ Arg.Set Cil.printCilAsIs,
+ (" Do not try to simplify the CIL when printing." ^
+ is_default !Cil.printCilAsIs);
+
+ "--noPrintCilAsIs",
+ Arg.Clear Cil.printCilAsIs,
+ (" Simplify the CIL when printing. This produces prettier output\n\t\t\t\tby e.g. changing while(1) into more meaningful loops " ^ is_default (not !Cil.printCilAsIs));
+
+ "--noWrap",
+ Arg.Unit (fun _ -> Cil.lineLength := 100_000),
+ " Do not wrap long lines when printing";
+
+ "--pdepth",
+ Arg.Int (fun n -> Pretty.printDepth := n),
+ ("<n> Set max print depth (default: " ^
+ string_of_int !Pretty.printDepth ^ ")");
+
+ (* Don't just add new flags at the end ... place options
+ in the correct category *)
+ ]
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2003,
+ * 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.
+ *
+ * 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.
+ *
+ *)
+
+
+(** The command-line options for CIL *)
+val options : (string * Arg.spec * string) list
+
+
+(** The list of file names *)
+val fileNames : string list ref
+
+(** Adds the file to the start of fileNames *)
+val recordFile: string -> unit
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(* Keep here the globally-visible flags *)
+let doCheck= ref false (* Whether to check CIL *)
+let strictChecking= ref false (* If doCheck is true and warnings are found,
+ * treat them as errors. *)
+
+let logCalls = ref false (* Whether to produce a log with all the function
+ * calls made *)
+let logWrites = ref false (* Whether to produce a log with all the mem
+ * writes made *)
+let doPartial = ref false (* Whether to do partial evaluation and constant
+ * folding *)
+let doSimpleMem = ref false (* reduce complex memory expressions so that
+ * they contain at most one lval *)
+let doOneRet = ref false (* make a functions have at most one 'return' *)
+let doStackGuard = ref false (* instrument function calls and returns to
+maintain a separate stack for return addresses *)
+let doHeapify = ref false (* move stack-allocated arrays to the heap *)
+let makeCFG = ref false (* turn the input CIL file into something more like
+ * a CFG *)
+let printStats = ref false
+
+(* when 'sliceGlobal' is set, then when 'rmtmps' runs, only globals*)
+(* marked with #pragma cilnoremove(whatever) are kept; when used with *)
+(* cilly.asm.exe, the effect is to slice the input on the noremove symbols *)
+let sliceGlobal = ref false
+
+
+let printStages = ref false
+
+
+let doCxxPP = ref false
+
+let libDir = ref ""
+
+let dumpFCG = ref false
+let testcil = ref ""
+
--- /dev/null
+(* @configure_input@ *)
+
+let cilVersionMajor = @CIL_VERSION_MAJOR@
+let cilVersionMinor = @CIL_VERSION_MINOR@
+let cilVersionRev = @CIL_VERSION_REV@
+let cilVersion = "@CIL_VERSION@"
--- /dev/null
+(*
+ *
+ * Copyright (c) 2003,
+ * Ben Liblit <liblit@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+
+(** OCaml types used to represent wide characters and strings *)
+type wchar = int64
+type wstring = wchar list
+
+
+let escape_char = function
+ | '\007' -> "\\a"
+ | '\b' -> "\\b"
+ | '\t' -> "\\t"
+ | '\n' -> "\\n"
+ | '\011' -> "\\v"
+ | '\012' -> "\\f"
+ | '\r' -> "\\r"
+ | '"' -> "\\\""
+ | '\'' -> "\\'"
+ | '\\' -> "\\\\"
+ | ' ' .. '~' as printable -> String.make 1 printable
+ | unprintable -> Printf.sprintf "\\%03o" (Char.code unprintable)
+
+let escape_string str =
+ let length = String.length str in
+ let buffer = Buffer.create length in
+ for index = 0 to length - 1 do
+ Buffer.add_string buffer (escape_char (String.get str index))
+ done;
+ Buffer.contents buffer
+
+(* a wide char represented as an int64 *)
+let escape_wchar =
+ (* limit checks whether upper > probe *)
+ let limit upper probe = (Int64.to_float (Int64.sub upper probe)) > 0.5 in
+ let fits_byte = limit (Int64.of_int 0x100) in
+ let fits_octal_escape = limit (Int64.of_int 0o1000) in
+ let fits_universal_4 = limit (Int64.of_int 0x10000) in
+ let fits_universal_8 = limit (Int64.of_string "0x100000000") in
+ fun charcode ->
+ if fits_byte charcode then
+ escape_char (Char.chr (Int64.to_int charcode))
+ else if fits_octal_escape charcode then
+ Printf.sprintf "\\%03Lo" charcode
+ else if fits_universal_4 charcode then
+ Printf.sprintf "\\u%04Lx" charcode
+ else if fits_universal_8 charcode then
+ Printf.sprintf "\\u%04Lx" charcode
+ else
+ invalid_arg "Cprint.escape_string_intlist"
+
+(* a wide string represented as a list of int64s *)
+let escape_wstring (str : int64 list) =
+ let length = List.length str in
+ let buffer = Buffer.create length in
+ let append charcode =
+ let addition = escape_wchar charcode in
+ Buffer.add_string buffer addition
+ in
+ List.iter append str;
+ Buffer.contents buffer
--- /dev/null
+(*
+ *
+ * Copyright (c) 2003,
+ * Ben Liblit <liblit@cs.berkeley.edu>
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * 3. The names of the contributors may not be used to endorse or promote
+ * products derived from this software without specific prior written
+ * permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+ * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+ * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+ * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+ * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+ * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+ * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+ * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+ * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+ * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+ * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ *
+ *)
+
+(*
+ * Character and string escaping utilities
+ *)
+
+(** OCaml types used to represent wide characters and strings *)
+type wchar = int64
+type wstring = wchar list
+
+(** escape various constructs in accordance with C lexical rules *)
+val escape_char : char -> string
+val escape_string : string -> string
+val escape_wchar : wchar -> string
+val escape_wstring : wstring -> string
--- /dev/null
+# subdirectories containing source code
+"pta": include
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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 Pretty
+module E = Errormsg
+module CG = Callgraph
+module H = Hashtbl
+module U = Util
+module IH = Inthash
+module VS = Usedef.VS
+
+module S = Ssa
+
+let debug = false
+let prologue = "["
+let epilogue = "]"
+
+let arithAbsOut = ref stdout
+let setArithAbsFile (s: string) =
+ try
+ arithAbsOut := open_out s
+ with _ -> ignore (E.warn "Cannot open the output file %s" s)
+
+(* Print out *)
+let pd ?(ind=0) (d: doc) : unit =
+ Pretty.fprint !arithAbsOut 80 (indent ind d)
+
+let p ?(ind=0) (fmt : ('a,unit,doc) format) : 'a =
+ let f d =
+ pd ~ind:ind d;
+ nil
+ in
+ Pretty.gprintf f fmt
+
+
+(** Variables whose address is taken are ignores. Set this to true if you
+ * want references to the address of such variables to be printed as the only
+ * accesses of the variable *)
+let treatAddressOfAsRead = true
+
+(** The globals written, indexed by Id of the function variable. Each inner
+ * table is indexed by the global id *)
+let globalsWritten: (varinfo IH.t) IH.t = IH.create 13
+let currentGlobalsWritten: (varinfo IH.t) ref = ref (IH.create 13)
+
+
+(** The transitive closure of the globals written *)
+let globalsWrittenTransitive: (varinfo IH.t) IH.t = IH.create 13
+
+let globalsRead: (varinfo IH.t) IH.t = IH.create 13
+let currentGlobalsRead: (varinfo IH.t) ref = ref (IH.create 13)
+
+let globalsReadTransitive: (varinfo IH.t) IH.t = IH.create 13
+
+
+let getGlobalsWrittenTransitive (f: varinfo): varinfo list =
+ try
+ let glob_written_trans =
+ IH.find globalsWrittenTransitive f.vid
+ in
+ IH.fold
+ (fun _ g acc -> g :: acc)
+ glob_written_trans
+ []
+ with Not_found -> [] (* not a defined function *)
+
+let getGlobalsReadTransitive (f: varinfo) =
+ try
+ let glob_read_trans =
+ IH.find globalsReadTransitive f.vid
+ in
+ IH.fold
+ (fun _ g acc -> g :: acc)
+ glob_read_trans
+ []
+ with Not_found -> []
+
+let considerType (t: typ) : bool =
+ (* Only consider those types for this we can do arithmetic *)
+ (match unrollType t with
+ TInt _ | TEnum _ | TPtr _ | TFloat _ -> true
+ | _ -> false)
+
+let considerVariable (v: varinfo) : bool =
+ not v.vaddrof && considerType v.vtype
+
+class gwVisitorClass : cilVisitor = object (self)
+ inherit nopCilVisitor
+
+ method vexpr = function
+ Lval (Var v, _) when v.vglob && considerVariable v ->
+ IH.replace !currentGlobalsRead v.vid v;
+ DoChildren
+
+ (* We pretend that when we see the address of a global, we are reading
+ * from the variable. Note that these variables will not be among those
+ * that we "considerVariable" so, there will be no writing to them *)
+ | StartOf (Var v, NoOffset)
+ | AddrOf (Var v, NoOffset) when treatAddressOfAsRead && v.vglob ->
+ IH.replace !currentGlobalsRead v.vid v;
+ DoChildren
+
+ | _ -> DoChildren
+
+ method vinst = function
+ Set ((Var v, _), _, _)
+ | Call (Some (Var v, _), _, _, _) when v.vglob && considerVariable v ->
+ IH.replace !currentGlobalsWritten v.vid v;
+ (* When we write a global, we also consider that we are reading it.
+ * This is useful if the global is not written on all paths *)
+ IH.replace !currentGlobalsRead v.vid v;
+ DoChildren
+ | _ -> DoChildren
+end
+
+let gwVisitor = new gwVisitorClass
+
+
+(** Functions can be defined or just declared *)
+type funinfo =
+ Decl of varinfo
+ | Def of fundec
+
+(* All functions indexed by the variable ID *)
+let allFunctions: funinfo IH.t = IH.create 13
+
+
+(** Compute the SSA form *)
+
+
+
+
+let fundecToCFGInfo (fdec: fundec) : S.cfgInfo =
+ (* Go over the statments and make sure they are numbered properly *)
+ let count = ref 0 in
+ List.iter (fun s -> s.sid <- !count; incr count) fdec.sallstmts;
+
+ let start: stmt =
+ match fdec.sbody.bstmts with
+ [] -> E.s (E.bug "Function %s with no body" fdec.svar.vname)
+ | fst :: _ -> fst
+ in
+ if start.sid <> 0 then
+ E.s (E.bug "The first block must have index 0");
+
+
+ let ci =
+ { S.name = fdec.svar.vname;
+ S.start = start.sid;
+ S.size = !count;
+ S.successors = Array.make !count [];
+ S.predecessors = Array.make !count [];
+ S.blocks = Array.make !count { S.bstmt = start;
+ S.instrlist = [];
+ S.reachable = true;
+ S.livevars = [] };
+ S.nrRegs = 0;
+ S.regToVarinfo = Array.make 0 dummyFunDec.svar;
+ }
+ in
+
+ (* Map a variable to a register *)
+ let varToRegMap: S.reg IH.t = IH.create 13 in
+ let regToVarMap: varinfo IH.t = IH.create 13 in
+ let varToReg (v: varinfo) : S.reg =
+ try IH.find varToRegMap v.vid
+ with Not_found ->
+ let res = ci.S.nrRegs in
+ ci.S.nrRegs <- 1 + ci.S.nrRegs;
+ IH.add varToRegMap v.vid res;
+ IH.add regToVarMap res v;
+ res
+ in
+ (* For functions, we use the transitively computed set of globals and
+ * locals as the use/def *)
+ Usedef.getUseDefFunctionRef :=
+ (fun f args ->
+ match f with
+ Lval (Var fv, NoOffset) ->
+ let varDefs = ref VS.empty in
+ let varUsed = ref VS.empty in
+ (try
+ let gw = IH.find globalsWrittenTransitive fv.vid in
+ IH.iter
+ (fun _ g -> varDefs := VS.add g !varDefs) gw
+ with Not_found -> (* Do not have a definition for it *)
+ ());
+ (* Now look for globals read *)
+ (try
+ let gr = IH.find globalsReadTransitive fv.vid in
+ IH.iter
+ (fun _ g -> varUsed := VS.add g !varUsed) gr
+ with Not_found -> ());
+
+ !varUsed, !varDefs, args
+
+ | _ -> VS.empty, VS.empty, args);
+
+
+ Usedef.considerVariableUse :=
+ (fun v -> considerVariable v);
+ Usedef.considerVariableDef :=
+ (fun v -> considerVariable v);
+ Usedef.considerVariableAddrOfAsUse :=
+ (fun v -> treatAddressOfAsRead);
+
+ (* Filter out the variables we do not care about *)
+ let vsToRegList (vs: VS.t) : int list =
+ VS.fold (fun v acc -> (varToReg v) :: acc) vs []
+ in
+ List.iter
+ (fun s ->
+ ci.S.successors.(s.sid) <- List.map (fun s' -> s'.sid) s.succs;
+ ci.S.predecessors.(s.sid) <- List.map (fun s' -> s'.sid) s.preds;
+ ci.S.blocks.(s.sid) <- begin
+ let instrs: (S.reg list * S.reg list) list =
+ match s.skind with
+ Instr il ->
+ (* Each instruction is transformed independently *)
+ List.map (fun i ->
+ let vused, vdefs = Usedef.computeUseDefInstr i in
+ (vsToRegList vdefs, vsToRegList vused)) il
+
+ | Return (Some e, _)
+ | If (e, _, _, _)
+ | Switch (e, _, _, _) ->
+ let vused = Usedef.computeUseExp e in
+ [ ([], vsToRegList vused) ]
+
+ | Break _ | Continue _ | Goto _ | Block _ | Loop _ | Return _ -> [ ]
+ | TryExcept _ | TryFinally _ -> assert false
+ in
+ { S.bstmt = s;
+ S.instrlist = instrs;
+ S.livevars = []; (* Will be filled in later *)
+ S.reachable = true; (* Will be set later *)
+ }
+ end
+ ) fdec.sallstmts;
+
+ (* Set the mapping from registers to variables *)
+ ci.S.regToVarinfo <-
+ Array.make ci.S.nrRegs dummyFunDec.svar;
+ IH.iter (fun rid v ->
+ ci.S.regToVarinfo.(rid) <- v) regToVarMap;
+
+ ci
+
+(* Compute strongly-connected components *)
+let stronglyConnectedComponents (cfg: S.cfgInfo) : bool -> S.sccInfo =
+ S.stronglyConnectedComponents cfg
+
+
+let globalsDumped = IH.create 13
+
+
+(** We print variable names in a special way *)
+let variableName (v: varinfo) (freshId: int) =
+ (if v.vaddrof then begin
+ assert treatAddressOfAsRead;
+ "addrof_"
+ end else "") ^
+ (if v.vglob then "glob_" else "") ^
+ (if freshId = 0 then
+ v.vname
+ else
+ v.vname ^ "___" ^ string_of_int freshId)
+
+(** Use a hash table indexed by varinfo *)
+module VH = Hashtbl.Make(struct
+ type t = varinfo
+ let hash (v: varinfo) = v.vid
+ let equal v1 v2 = v1.vid = v2.vid
+ end)
+
+let vhToList (vh: 'a VH.t) : (varinfo * 'a) list =
+ VH.fold (fun v id acc -> (v, id) :: acc) vh []
+
+let debugRename = false
+
+(** We define a new printer *)
+class absPrinterClass (callgraph: CG.callgraph) : cilPrinter =
+
+ let lastFreshId= ref 0 in
+
+ (* freshVarId returns at least 1 *)
+ let freshVarId () = incr lastFreshId; !lastFreshId in
+
+
+ object (self)
+ inherit defaultCilPrinterClass as super
+
+ val mutable idomData: stmt option IH.t = IH.create 13
+
+ val mutable cfgInfo: S.cfgInfo option = None
+
+
+ val mutable sccInfo: S.sccInfo option = None
+
+ val mutable currentFundec = dummyFunDec
+
+ (** For each block end, a mapping from IDs of variables to their ID
+ * at the end of the block *)
+ val mutable blockEndData: int VH.t array =
+ Array.make 0 (VH.create 13)
+
+ (** For each block start, remember the starting newFreshId as we
+ * start the block *)
+ val mutable blockStartData: int array =
+ Array.make 0 (-1)
+
+
+ val mutable varRenameState: int VH.t = VH.create 13
+
+ (* All the fresh variables *)
+ val mutable freshVars: string list = []
+
+ (* The uninitialized variables are those that are live on input but
+ * not globals or formals. *)
+ val mutable uninitVars: string list = []
+
+ method private initVarRenameState (b: S.cfgBlock) =
+ VH.clear varRenameState;
+
+ let cfgi =
+ match cfgInfo with
+ None -> assert false
+ | Some cfgi -> cfgi
+ in
+
+ (* Initialize it based on the livevars info in the block *)
+ List.iter
+ (fun (rid, defblk) ->
+ let v = cfgi.S.regToVarinfo.(rid) in
+ if defblk = b.S.bstmt.sid then
+ (* Is a phi variable or a live variable at start *)
+ if defblk = cfgi.S.start then begin
+ (* For the start block, use ID=0 for all variables, except the
+ * locals that are not function formals. Those are fresh
+ * variables. *)
+ let isUninitializedLocal =
+ not v.vglob &&
+ (not (List.exists (fun v' -> v'.vid = v.vid)
+ currentFundec.sformals)) in
+ VH.add varRenameState v 0;
+ let vn = self#variableUse varRenameState v in
+ if isUninitializedLocal then
+ uninitVars <- vn :: uninitVars;
+ end else begin
+ VH.add varRenameState v (freshVarId ());
+ let vn = self#variableUse varRenameState v in
+ freshVars <- vn :: freshVars
+ end
+ else begin
+ let fid =
+ try VH.find blockEndData.(defblk) v
+ with Not_found ->
+ E.s (E.bug "In block %d: Cannot find data for variable %s in block %d"
+ b.S.bstmt.sid v.vname defblk)
+ in
+ VH.add varRenameState v fid
+ end)
+ b.S.livevars;
+
+ if debugRename then
+ ignore (E.log "At start of block %d:\n @[%a@]\n"
+ b.S.bstmt.sid
+ (docList ~sep:line
+ (fun (v, id) ->
+ dprintf "%s: %d" v.vname id))
+ (vhToList varRenameState));
+ ()
+
+ (** This is called for reading from a variable we consider (meaning that
+ * its address is not taken and has the right type) *)
+ method private variableUse ?(print=true)
+ (state: int VH.t) (v: varinfo) : string =
+ let freshId =
+ try VH.find state v
+ with Not_found ->
+ E.s (E.bug "%a: varUse: varRenameState does not know anything about %s"
+ d_loc !currentLoc v.vname )
+ in
+ if debugRename && print then
+ ignore (E.log "At %a: variableUse(%s) : %d\n"
+ d_loc !currentLoc v.vname freshId);
+ variableName v freshId
+
+ method private variableDef (state: int VH.t) (v: varinfo) : string =
+ assert (not v.vaddrof);
+ let newid = freshVarId () in
+ VH.replace state v newid;
+ if debugRename then
+ ignore (E.log "At %a: variableDef(%s) : %d\n"
+ d_loc !currentLoc v.vname newid);
+ let n = self#variableUse ~print:false state v in
+ freshVars <- n :: freshVars;
+ n
+
+ method pExp () = function
+ | Const (CInt64(i, _, _)) -> text (Int64.to_string i)
+ | Const (CStr _) -> text "(@rand)"
+ | BinOp (bop, e1, e2, _) ->
+ dprintf "(%a @[%a@?%a@])"
+ d_binop bop
+ self#pExp e1 self#pExp e2
+ | UnOp (uop, e1, _) ->
+ dprintf "(%a @[%a@])"
+ d_unop uop self#pExp e1
+ | CastE (t, e) -> self#pExp () e (* Ignore casts *)
+
+ | Lval (Var v, NoOffset) when considerVariable v ->
+ text (self#variableUse varRenameState v)
+
+ (* We ignore all other Lval *)
+ | Lval _ -> text "(@rand)"
+
+
+ | AddrOf (Var v, NoOffset)
+ | StartOf (Var v, NoOffset) ->
+ if treatAddressOfAsRead then
+ text (self#variableUse varRenameState v)
+ else
+ text "(@rand)"
+
+
+ | e -> super#pExp () e
+
+ method pInstr () (i: instr) =
+ (* Print a call *)
+ let printCall (dest: varinfo option)
+ (f: varinfo) (args: exp list) (l: location) =
+ currentLoc := l;
+ let gwt: varinfo list = getGlobalsWrittenTransitive f in
+ let grt: varinfo list = getGlobalsReadTransitive f in
+
+ let gwt' =
+ match dest with
+ Some dest -> gwt @ [dest]
+ | _ -> gwt
+
+ in
+ (* Prepare the arguments first *)
+ let argdoc: doc =
+ (docList ~sep:break (self#pExp ()))
+ ()
+ (args @ (List.map (fun v -> Lval (Var v, NoOffset)) grt))
+ in
+ dprintf "%a = (%s @[%a@]);"
+ (docList
+ (fun v ->
+ text (self#variableDef varRenameState v)))
+ gwt'
+ f.vname
+ insert argdoc
+ in
+ match i with
+ | Set ((Var v, NoOffset), e, l) when considerVariable v ->
+ currentLoc := l;
+ (* We must do the use first *)
+ let use = self#pExp () e in
+ text (self#variableDef varRenameState v)
+ ++ text "=" ++ use ++ text ";"
+
+ | Call (Some (Var v, NoOffset),
+ Lval (Var f, NoOffset), args, l) when considerVariable v ->
+ printCall (Some v)
+ f args l
+
+ (* Ignore the result if not a variable we are considering *)
+ | Call (_, Lval (Var f, NoOffset), args, l) ->
+ printCall None f args l
+
+
+ | _ -> nil (* Ignore the other instructions *)
+
+
+ method dBlock (out: out_channel) (ind: int) (b: block) : unit =
+ ignore (p ~ind:ind "%sblock\n" prologue);
+ List.iter (self#dStmt out (ind+ 2)) b.bstmts;
+ ignore (p ~ind:ind "%s\n" epilogue)
+
+ method dStmt (out: out_channel) (ind: int) (s: stmt) : unit =
+ currentLoc := get_stmtLoc s.skind;
+ (* Initialize the renamer for this statement *)
+ lastFreshId := blockStartData.(s.sid);
+ if debugRename then
+ ignore (E.log "Initialize the renamer for block %d to %d\n"
+ s.sid !lastFreshId);
+ assert (!lastFreshId >= 0);
+
+ let cfgi =
+ match cfgInfo with
+ Some cfgi -> cfgi
+ | None -> assert false
+ in
+ let blk: S.cfgBlock = cfgi.S.blocks.(s.sid) in
+ assert (blk.S.bstmt == s);
+
+ self#initVarRenameState blk;
+
+ let phivars: varinfo list =
+ List.fold_left
+ (fun acc (i, defblk) ->
+ if defblk = s.sid then
+ cfgi.S.regToVarinfo.(i) :: acc
+ else
+ acc)
+ []
+ blk.S.livevars
+ in
+ (* do not emit phi for start block *)
+ let phivars: varinfo list =
+ if s.sid = cfgi.S.start then
+ []
+ else
+ phivars
+ in
+
+ (* Get the predecessors information *)
+ let getPhiAssignment (v: varinfo) : (string * string list) =
+ (* initVarRenameState has already set the state for the phi register *)
+ let lhs: string = self#variableUse varRenameState v in
+ let rhs: string list =
+ List.map
+ (fun p ->
+ self#variableUse blockEndData.(p) v)
+ cfgi.S.predecessors.(s.sid)
+ in
+ (lhs, rhs)
+ in
+
+ pd (self#pLineDirective (get_stmtLoc s.skind));
+ (* Lookup its dominator *)
+ let idom: doc =
+ match Dominators.getIdom idomData s with
+ Some dom -> num dom.sid
+ | None -> nil
+ in
+
+ let headerstuff =
+ (* See if this block is a header *)
+ let scc =
+ match sccInfo with Some x -> x
+ | _ -> E.s (E.bug "sccInfo is not set")
+ in
+ if List.exists (fun sci -> List.mem s.sid sci.S.headers) scc then begin
+ (* We get the variables at the end of any predecessor. *)
+ let p: int =
+ match cfgi.S.predecessors.(s.sid) with
+ p :: _ -> p
+ | [] -> E.s (E.bug "Header block %d has no predecessors" s.sid)
+ in
+ let pend: int VH.t = blockEndData.(p) in
+ let allvars: (varinfo * int) list = vhToList pend in
+
+ let nonphi: (varinfo * int) list =
+ List.filter
+ (fun (v, _) ->
+ not (List.exists (fun v' -> v'.vid = v.vid) phivars)) allvars
+ in
+
+ dprintf "%snonphi %a%s\n"
+ prologue
+ (docList
+ (fun (v, vvariant) ->
+ text (variableName v vvariant)))
+ nonphi
+ epilogue
+ end else
+ nil
+ in
+
+ let succs = List.filter (fun s' -> cfgi.S.blocks.(s'.sid).S.reachable) s.succs in
+ let preds = List.filter (fun s' -> cfgi.S.blocks.(s'.sid).S.reachable) s.preds in
+ ignore (p ~ind:ind
+ "%sstmt %d %a %ssuccs %a%s %spreds %a%s %sidom %a%s\n @[%a@]\n"
+ prologue s.sid (** Statement id *)
+ insert headerstuff
+ prologue (d_list "," (fun _ s' -> num s'.sid)) succs epilogue
+ prologue (d_list "," (fun _ s' -> num s'.sid)) preds epilogue
+ prologue insert idom epilogue
+ (docList ~sep:line
+ (fun pv ->
+ let (lhs, rhs) = getPhiAssignment pv in
+ dprintf "%s = (@@phi %a);"
+ lhs (docList ~sep:break text) rhs))
+ phivars
+ );
+ (* Now the statement kind *)
+ let ind = ind + 2 in
+ (match s.skind with
+ | Instr il ->
+ if (cfgi.S.blocks.(s.sid).S.reachable) then begin
+ List.iter
+ (fun i ->
+ pd ~ind:ind (self#pInstr () i ++ line))
+ il
+ end
+ | Block b -> List.iter (self#dStmt out ind) b.bstmts
+ | Goto (s, _) -> ignore (p ~ind:ind "%sgoto %d%s\n" prologue !s.sid epilogue)
+ | Return (what, _) -> begin
+
+ let gwt: varinfo list =
+ getGlobalsWrittenTransitive currentFundec.svar
+ in
+ let res: varinfo list =
+ match what with
+ None -> gwt
+ | Some (Lval (Var v, NoOffset)) when v.vname = "__retres" ->
+ if considerType v.vtype then
+ gwt @ [ v ]
+ else
+ gwt
+ | Some e ->
+ E.s (E.bug "Return with no __retres: %a" d_exp e)
+ in
+ ignore (p ~ind:ind
+ "return %a;"
+ (docList
+ (fun v ->
+ text (self#variableUse varRenameState v)))
+ res);
+ end
+
+ | If(e, b1, b2, _) ->
+ ignore (p ~ind:ind "%sif %a\n" prologue self#pExp e);
+ self#dBlock out (ind + 2) b1;
+ self#dBlock out (ind + 2) b2;
+ ignore (p ~ind:ind "%s\n" epilogue)
+
+ | Loop (b, _, Some co, Some br) ->
+ ignore (p ~ind:ind "%sloop %scont %d%s %sbreak %d%s\n"
+ prologue
+ prologue co.sid epilogue
+ prologue br.sid epilogue);
+ List.iter (self#dStmt out (ind+ 2)) b.bstmts;
+ ignore (p ~ind:ind "%s\n" epilogue)
+
+ (* The other cases should have been removed already *)
+ | _ -> E.s (E.unimp "try except"));
+
+ (* The termination *)
+ let ind = ind - 2 in
+ ignore (p ~ind:ind "%s\n" epilogue)
+
+
+ method dGlobal (out: out_channel) (g: global) : unit =
+ match g with
+ GFun (fdec, l) ->
+ currentFundec <- fdec;
+ if debugRename then
+ ignore (E.log "Renaming for function %s\n" fdec.svar.vname);
+
+ (* Make sure we use one return at most *)
+ Oneret.oneret fdec;
+
+ (* Now compute the immediate dominators. This will fill in the CFG
+ * info as well *)
+ idomData <- Dominators.computeIDom fdec;
+
+ (** Get the callgraph node for this function *)
+ let cg_node: CG.callnode =
+ try H.find callgraph fdec.svar.vname
+ with Not_found -> E.s (E.bug "Cannot find call graph info for %s"
+ fdec.svar.vname)
+ in
+
+ (** Get the globals read and written *)
+ let glob_read =
+ (try IH.find globalsRead fdec.svar.vid
+ with Not_found -> assert false) in
+ let glob_read_trans =
+ (try IH.find globalsReadTransitive fdec.svar.vid
+ with Not_found -> assert false) in
+
+
+ let glob_written =
+ (try IH.find globalsWritten fdec.svar.vid
+ with Not_found -> assert false) in
+ let glob_written_trans =
+ (try IH.find globalsWrittenTransitive fdec.svar.vid
+ with Not_found -> assert false) in
+
+ (* Compute the control flow graph info, for SSA computation *)
+ let cfgi = S.prune_cfg (fundecToCFGInfo fdec) in
+ cfgInfo <- Some cfgi;
+ (* Call here the SSA function to fill-in the cfgInfo *)
+ S.add_ssa_info cfgi;
+
+ (* Compute strongly connected components *)
+ let scc: S.sccInfo =
+ stronglyConnectedComponents cfgi false in
+ sccInfo <- Some scc;
+
+ (* Now do the SSA renaming. *)
+
+ blockStartData <- Array.make cfgi.S.size (-1);
+ blockEndData <- Array.make cfgi.S.size (VH.create 13);
+
+ lastFreshId := 0;
+
+ freshVars <- [];
+ uninitVars <- [];
+
+ if debugRename then
+ ignore (E.log "Starting renaming phase I for %s\n"
+ fdec.svar.vname);
+ Array.iteri (fun i (b: S.cfgBlock) ->
+ (* compute the initial state *)
+ blockStartData.(i) <- !lastFreshId;
+ if debugRename then
+ ignore (E.log "Save the rename state for block %d to %d\n"
+ i !lastFreshId);
+
+ (* Initialize the renaming state *)
+ self#initVarRenameState b;
+
+ (* Now scan the block and keep track of the definitions. This is
+ * a huge hack. We try to rename the variables in the same order
+ * in which we will rename them during actual printing of the
+ * block. It would have been cleaner to print the names of the
+ * variables after printing the function. *)
+ (match b.S.bstmt.skind with
+ Instr il -> begin
+ List.iter
+ (fun i ->
+ let doCall (dest: varinfo option) (f: varinfo) : unit =
+ let gwt: varinfo list =
+ getGlobalsWrittenTransitive f in
+ let gwt' =
+ match dest with
+ Some v ->
+ gwt @ [ v ]
+ | _ -> gwt
+ in
+ List.iter (fun v ->
+ ignore (self#variableDef varRenameState v))
+ gwt'
+ in
+ match i with
+ Set ((Var v, NoOffset), _, l)
+ when considerVariable v ->
+ currentLoc := l;
+ ignore (self#variableDef varRenameState v)
+ | Call (Some (Var v, NoOffset),
+ Lval (Var f, NoOffset), _, l)
+ when considerVariable v ->
+ currentLoc := l;
+ doCall (Some v) f
+
+
+ | Call (_,
+ Lval (Var f, NoOffset), _, l) ->
+ currentLoc := l;
+ doCall None f
+
+ | _ -> ())
+ il
+ end
+
+ | _ -> (* No definitions *)
+ ()
+ );
+
+ if debugRename then
+ ignore (E.log "At end of block %d:\n @[%a@]\n"
+ i
+ (docList ~sep:line
+ (fun (v, id) ->
+ dprintf "%s: %d" v.vname id))
+ (vhToList varRenameState));
+
+ blockEndData.(i) <- VH.copy varRenameState;
+ )
+ cfgi.S.blocks;
+
+ if debugRename then
+ ignore (E.log "Starting renaming phase II (printing) for %s\n"
+ fdec.svar.vname);
+
+
+ (** For each basic block *)
+
+
+ (* The header *)
+ pd (self#pLineDirective ~forcefile:true l);
+
+ ignore (p "%sfunction %s\n %sformals %a%s\n %sglobalsreadtransitive %a%s\n %sglobalswrittentransitive %a%s\n %slocals %a%s\n %suninitlocals %a%s\n %sglobalsread %a%s\n %sglobalswritten %a%s\n %scalls %a%s\n %scalledby %a%s\n %a"
+ prologue fdec.svar.vname
+ prologue (docList (fun v -> text (variableName v 0)))
+ fdec.sformals epilogue
+ prologue (d_list "," (fun () v -> text (variableName v 0)))
+ (getGlobalsReadTransitive fdec.svar) epilogue
+ prologue (d_list "," (fun () v -> text (variableName v 0)))
+ (getGlobalsWrittenTransitive fdec.svar) epilogue
+ prologue (docList text) freshVars epilogue
+ prologue (docList text) uninitVars epilogue
+ prologue (d_list "," (fun () (_, v) -> text (variableName v 0))) (IH.tolist glob_read) epilogue
+ prologue (d_list "," (fun () (_, v) -> text (variableName v 0))) (IH.tolist glob_written) epilogue
+ prologue (U.docHash (fun k _ -> text k)) cg_node.CG.cnCallees epilogue
+ prologue (U.docHash (fun k _ -> text k)) cg_node.CG.cnCallers epilogue
+ (docList ~sep:line
+ (fun oneScc ->
+ dprintf "%sSCC %sheaders %a%s %snodes %a%s%s\n"
+ prologue
+ prologue (docList num) oneScc.S.headers epilogue
+ prologue (docList num) oneScc.S.nodes epilogue
+ epilogue))
+ scc);
+
+
+ (* The block *)
+ self#dBlock out 2 fdec.sbody;
+
+ (* The end *)
+ ignore (p "\n%s\n\n" epilogue)
+
+ (* Emit the globals whose address is not taken *)
+ | GVarDecl (vi, l) | GVar (vi, _, l) when
+ not vi.vaddrof && isIntegralType vi.vtype
+ && not (IH.mem globalsDumped vi.vid)
+ ->
+ IH.add globalsDumped vi.vid ();
+ pd (self#pLineDirective ~forcefile:true l);
+ ignore (p "%sglobal %s%s\n" prologue vi.vname epilogue)
+
+ | _ -> ()
+end
+
+
+let arithAbs (absPrinter: cilPrinter) (g: global) =
+ dumpGlobal absPrinter !arithAbsOut g
+
+let feature : featureDescr =
+ { fd_name = "arithabs";
+ fd_enabled = ref false;
+ fd_description = "generation of an arithmetic abstraction";
+ fd_extraopt = [
+ ("--arithabs_file", Arg.String setArithAbsFile,
+ "the name of the file to dump the arithmetic abstraction to") ];
+ fd_doit =
+ (function (f : file) ->
+ (* Call the simplify *)
+ Simplify.onlyVariableBasics := true;
+ Simplify.feature.fd_doit f;
+ (* Compute the call graph *)
+ let graph = CG.computeGraph f in
+
+ (* Compute the globals written by each function *)
+ IH.clear globalsWritten;
+ IH.clear globalsWrittenTransitive;
+ IH.clear globalsRead;
+
+ IH.clear allFunctions;
+
+
+ (* Compute the globals read and written *)
+ iterGlobals
+ f
+ (function
+ GFun(fdec, _) ->
+ IH.replace allFunctions fdec.svar.vid (Def fdec);
+ currentGlobalsRead := IH.create 13;
+ IH.add globalsRead fdec.svar.vid !currentGlobalsRead;
+ currentGlobalsWritten := IH.create 13;
+ IH.add globalsWritten fdec.svar.vid !currentGlobalsWritten;
+ ignore (visitCilBlock gwVisitor fdec.sbody)
+
+ | GVarDecl (vd, _) when isFunctionType vd.vtype &&
+ not (IH.mem allFunctions vd.vid)
+ ->
+ IH.add allFunctions vd.vid (Decl vd)
+ | _ -> ());
+
+ (* Now do transitive closure of the globals written by each function *)
+ (* Initialize each function with the globals it writes itself *)
+ IH.iter
+ (fun fid gw ->
+ IH.add globalsWrittenTransitive fid (IH.copy gw))
+ globalsWritten;
+
+ IH.iter
+ (fun fid gr ->
+ IH.add globalsReadTransitive fid (IH.copy gr))
+ globalsRead;
+
+ (* A work list initialized with all functions, that are defined *)
+ let worklist: int Queue.t = Queue.create () in
+ IH.iter (fun fid finfo ->
+ match finfo with
+ Def _ -> Queue.add fid worklist
+ | _ -> ())
+
+ allFunctions;
+
+ (* Now run until we reach a fixed point *)
+ let rec fixedpoint () =
+ try
+ let next = Queue.take worklist in
+ (* Get the function info for this one *)
+ let finfo =
+ try IH.find allFunctions next
+ with Not_found ->
+ E.s (E.bug "Function id=%d not in allFunctions" next)
+ in
+ (* If this is just a declaration, we ignore *)
+ (match finfo with
+ Decl _ -> ()
+ | Def fdec -> begin
+ (* Find the callnode for it *)
+ let cnode: CG.callnode =
+ try H.find graph fdec.svar.vname
+ with Not_found ->
+ E.s (E.bug "Function %s does not have a call node"
+ fdec.svar.vname)
+ in
+ (* Union in all the variables modified by the functions this
+ * calls. Remember if we made a change. If we do, we add to the
+ * worklist the callers of this one. *)
+ let changeMade = ref false in
+
+ (* Our written *)
+ let ourWritten =
+ try IH.find globalsWrittenTransitive fdec.svar.vid
+ with Not_found ->
+ E.s (E.bug "Function %s not in globalsWrittenTransitive"
+ fdec.svar.vname)
+ in
+
+ (* Our read *)
+ let ourRead =
+ try IH.find globalsReadTransitive fdec.svar.vid
+ with Not_found ->
+ E.s (E.bug "Function %s not in globalsReadTransitive"
+ fdec.svar.vname)
+ in
+(*
+ ignore (E.log "fixedpoint: doing %s\n read so far: %a\n written so far: %a\n"
+ fdec.svar.vname
+ (docList (fun (_, v) -> text v.vname))
+ (IH.tolist ourRead)
+ (docList (fun (_, v) -> text v.vname))
+ (IH.tolist ourRead));
+*)
+ H.iter
+ (fun n cn ->
+ (* Get the callee's written *)
+ (try
+ let callee_written =
+ IH.find globalsWrittenTransitive cn.CG.cnInfo.vid in
+ IH.iter
+ (fun gwid gw ->
+ if not (IH.mem ourWritten gwid) then begin
+ IH.add ourWritten gwid gw;
+ changeMade := true
+ end)
+ callee_written;
+ with Not_found -> (* Callee not defined here *)
+ ());
+
+ (* Get the callee's read *)
+ (try
+ let callee_read =
+ IH.find globalsReadTransitive cn.CG.cnInfo.vid in
+ IH.iter
+ (fun grid gr ->
+ if not (IH.mem ourRead grid) then begin
+ IH.add ourRead grid gr;
+ changeMade := true
+ end)
+ callee_read;
+ with Not_found -> (* Callee not defined here *)
+ ());
+
+
+ )
+ cnode.CG.cnCallees;
+
+ if !changeMade then begin
+ H.iter
+ (fun _ caller -> Queue.add caller.CG.cnInfo.vid worklist)
+ cnode.CG.cnCallers
+ end
+ end);
+
+ fixedpoint ();
+
+ with Queue.Empty -> ()
+ in
+ fixedpoint ();
+
+
+ let absPrinter: cilPrinter = new absPrinterClass graph in
+ IH.clear globalsDumped;
+ iterGlobals f
+ (arithAbs absPrinter);
+
+ (* compute SCC for the call-graph *)
+ let nodeIdToNode: CG.callnode IH.t = IH.create 13 in
+ let funidToNodeId: int IH.t = IH.create 13 in
+ let nrNodes = ref 0 in
+ let mainNode = ref 0 in
+ H.iter
+ (fun vn cn ->
+ if vn= "main" then mainNode := !nrNodes;
+ IH.add nodeIdToNode !nrNodes cn;
+ IH.add funidToNodeId cn.CG.cnInfo.vid !nrNodes;
+ incr nrNodes) graph;
+
+ let ci: S.cfgInfo =
+ { S.name = "call-graph";
+ S.start = !mainNode;
+ S.size = !nrNodes;
+ S.successors = Array.make !nrNodes [];
+ S.predecessors = Array.make !nrNodes [];
+ S.blocks = Array.make !nrNodes { S.bstmt = mkEmptyStmt ();
+ S.instrlist = [];
+ S.livevars = [];
+ S.reachable = true };
+ S.nrRegs = 0;
+ S.regToVarinfo = Array.create 0 dummyFunDec.svar;
+ }
+ in
+ let ci = ci in
+ nrNodes := 0;
+ IH.iter (fun idx cn ->
+ let cnlistToNodeList (cnl: (string, CG.callnode) H.t) : int list =
+ List.map
+ (fun (_, sn) ->
+ try IH.find funidToNodeId sn.CG.cnInfo.vid
+ with Not_found -> assert false
+ )
+ (U.hash_to_list cnl)
+ in
+ (* we want to construct the callee graph not the caller graph *)
+ ci.S.successors.(idx) <- cnlistToNodeList cn.CG.cnCallers;
+ ci.S.predecessors.(idx) <- cnlistToNodeList cn.CG.cnCallees;
+
+ ) nodeIdToNode;
+
+ let scc: S.sccInfo =
+ stronglyConnectedComponents ci false in
+ List.iter
+ (fun oneScc ->
+ ignore (p "%sSCC %sheaders %a%s %snodes %a%s%s\n"
+ prologue
+ prologue (docList
+ (fun h ->
+ (try
+ text (IH.find nodeIdToNode h).CG.cnInfo.vname
+ with Not_found -> assert false)))
+ oneScc.S.headers epilogue
+ prologue (docList
+ (fun n ->
+ (try text (IH.find nodeIdToNode n).CG.cnInfo.vname
+ with Not_found -> assert false)))
+ oneScc.S.nodes epilogue
+ epilogue))
+ scc;
+
+
+ );
+
+
+
+
+ fd_post_check = false;
+ }
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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
+module E = Errormsg
+(*
+ * Weimer: an AST Slicer for use in Daniel's Delta Debugging Algorithm.
+ *)
+let debug = ref false
+
+(*
+ * This type encapsulates a mapping form program locations to names
+ * in our naming convention.
+ *)
+type enumeration_info = {
+ statements : (stmt, string) Hashtbl.t ;
+ instructions : (instr, string) Hashtbl.t ;
+}
+
+(**********************************************************************
+ * Enumerate 1
+ *
+ * Given a cil file, enumerate all of the statement names in it using
+ * our naming scheme.
+ **********************************************************************)
+let enumerate out (f : Cil.file) =
+ let st_ht = Hashtbl.create 32767 in
+ let in_ht = Hashtbl.create 32767 in
+
+ let emit base i ht elt =
+ let str = Printf.sprintf "%s.%d" base !i in
+ Printf.fprintf out "%s\n" str ;
+ Hashtbl.add ht elt str ;
+ incr i
+ in
+ let emit_call base i str2 ht elt =
+ let str = Printf.sprintf "%s.%d" base !i in
+ Printf.fprintf out "%s - %s\n" str str2 ;
+ Hashtbl.add ht elt str ;
+ incr i
+ in
+ let descend base i =
+ let res = (Printf.sprintf "%s.%d" base !i),(ref 0) in
+ res
+ in
+ let rec doBlock b base i =
+ doStmtList b.bstmts base i
+ and doStmtList sl base i =
+ List.iter (fun s -> match s.skind with
+ | Instr(il) -> doIL il base i
+ | Return(_,_)
+ | Goto(_,_)
+ | Continue(_)
+ | Break(_) -> emit base i st_ht s
+ | If(e,b1,b2,_) ->
+ emit base i st_ht s ;
+ decr i ;
+ Printf.fprintf out "(\n" ;
+ let base',i' = descend base i in
+ doBlock b1 base' i' ;
+ Printf.fprintf out ") (\n" ;
+ let base'',i'' = descend base i in
+ doBlock b2 base'' i'' ;
+ Printf.fprintf out ")\n" ;
+ incr i
+ | Switch(_,b,_,_)
+ | Loop(b,_,_,_)
+ | Block(b) ->
+ emit base i st_ht s ;
+ decr i ;
+ let base',i' = descend base i in
+ Printf.fprintf out "(\n" ;
+ doBlock b base' i' ;
+ Printf.fprintf out ")\n" ;
+ incr i
+ | TryExcept _ | TryFinally _ ->
+ E.s (E.unimp "astslicer:enumerate")
+ ) sl
+ and doIL il base i =
+ List.iter (fun ins -> match ins with
+ | Set _
+ | Asm _ -> emit base i in_ht ins
+ | Call(_,(Lval(Var(vi),NoOffset)),_,_) ->
+ emit_call base i vi.vname in_ht ins
+ | Call(_,f,_,_) -> emit_call base i "*" in_ht ins
+ ) il
+ in
+ let doGlobal g = match g with
+ | GFun(fd,_) ->
+ Printf.fprintf out "%s (\n" fd.svar.vname ;
+ let cur = ref 0 in
+ doBlock fd.sbody fd.svar.vname cur ;
+ Printf.fprintf out ")\n" ;
+ ()
+ | _ -> ()
+ in
+ List.iter doGlobal f.globals ;
+ { statements = st_ht ;
+ instructions = in_ht ; }
+
+(**********************************************************************
+ * Enumerate 2
+ *
+ * Given a cil file and some enumeration information, do a log-calls-like
+ * transformation on it that prints out our names as you reach them.
+ **********************************************************************)
+(*
+ * This is the visitor that handles annotations
+ *)
+let print_it pfun name =
+ ((Call(None,Lval(Var(pfun),NoOffset),
+ [mkString (name ^ "\n")],locUnknown)))
+
+class enumVisitor pfun st_ht in_ht = object
+ inherit nopCilVisitor
+ method vinst i =
+ if Hashtbl.mem in_ht i then begin
+ let name = Hashtbl.find in_ht i in
+ let newinst = print_it pfun name in
+ ChangeTo([newinst ; i])
+ end else
+ DoChildren
+ method vstmt s =
+ if Hashtbl.mem st_ht s then begin
+ let name = Hashtbl.find st_ht s in
+ let newinst = print_it pfun name in
+ let newstmt = mkStmtOneInstr newinst in
+ let newblock = mkBlock [newstmt ; s] in
+ let replace_with = mkStmt (Block(newblock)) in
+ ChangeDoChildrenPost(s,(fun i -> replace_with))
+ end else
+ DoChildren
+ method vfunc f =
+ let newinst = print_it pfun f.svar.vname in
+ let newstmt = mkStmtOneInstr newinst in
+ let new_f = { f with sbody = { f.sbody with
+ bstmts = newstmt :: f.sbody.bstmts }} in
+ ChangeDoChildrenPost(new_f,(fun i -> i))
+end
+
+let annotate (f : Cil.file) ei = begin
+ (* Create a prototype for the logging function *)
+ let printfFun =
+ let fdec = emptyFunction "printf" in
+ let argf = makeLocalVar fdec "format" charConstPtrType in
+ fdec.svar.vtype <- TFun(intType, Some [ ("format", charConstPtrType, [])],
+ true, []);
+ fdec
+ in
+ let visitor = (new enumVisitor printfFun.svar ei.statements
+ ei.instructions) in
+ visitCilFileSameGlobals visitor f;
+ f
+end
+
+(**********************************************************************
+ * STAGE 2
+ *
+ * Perform a transitive-closure-like operation on the parts of the program
+ * that the user wants to keep. We use a CIL visitor to walk around
+ * and a number of hash tables to keep track of the things we want to keep.
+ **********************************************************************)
+(*
+ * Hashtables:
+ * ws - wanted stmts
+ * wi - wanted instructions
+ * wt - wanted typeinfo
+ * wc - wanted compinfo
+ * we - wanted enuminfo
+ * wv - wanted varinfo
+ *)
+
+let mode = ref false (* was our parented wanted? *)
+let finished = ref true (* set to false if we update something *)
+
+(* In the given hashtable, mark the given element was "wanted" *)
+let update ht elt =
+ if Hashtbl.mem ht elt && (Hashtbl.find ht elt = true) then ()
+ else begin
+ Hashtbl.add ht elt true ;
+ finished := false
+ end
+
+(* Handle a particular stage of the AST tree walk. Use "mode" (i.e.,
+ * whether our parent was wanted) and the hashtable (which tells us whether
+ * the user had any special instructions for this element) to determine
+ * what do to. *)
+let handle ht elt rep =
+ if !mode then begin
+ if Hashtbl.mem ht elt && (Hashtbl.find ht elt = false) then begin
+ (* our parent is Wanted but we were told to ignore this subtree,
+ * so we won't be wanted. *)
+ mode := false ;
+ ChangeDoChildrenPost(rep,(fun elt -> mode := true ; elt))
+ end else begin
+ (* we were not told to ignore this subtree, and our parent is
+ * Wanted, so we will be Wanted too! *)
+ update ht elt ;
+ DoChildren
+ end
+ end else if Hashtbl.mem ht elt && (Hashtbl.find ht elt = true) then begin
+ (* our parent was not wanted but we were wanted, so turn the
+ * mode on for now *)
+ mode := true ;
+ ChangeDoChildrenPost(rep,(fun elt -> mode := false ; elt))
+ end else
+ DoChildren
+
+let handle_no_default ht elt rep old_mode =
+ if Hashtbl.mem ht elt && (Hashtbl.find ht elt = true) then begin
+ (* our parent was not wanted but we were wanted, so turn the
+ * mode on for now *)
+ mode := true ;
+ ChangeDoChildrenPost(rep,(fun elt -> mode := old_mode ; elt))
+ end else begin
+ mode := false ;
+ ChangeDoChildrenPost(rep,(fun elt -> mode := old_mode ; elt))
+ end
+
+(*
+ * This is the visitor that handles elements (marks them as wanted)
+ *)
+class transVisitor ws wi wt wc we wv = object
+ inherit nopCilVisitor
+
+ method vvdec vi = handle_no_default wv vi vi !mode
+ method vvrbl vi = handle wv vi vi
+ method vinst i = handle wi i [i]
+ method vstmt s = handle ws s s
+ method vfunc f = handle wv f.svar f
+ method vglob g = begin
+ match g with
+ | GType(ti,_) -> handle wt ti [g]
+ | GCompTag(ci,_)
+ | GCompTagDecl(ci,_) -> handle wc ci [g]
+ | GEnumTag(ei,_)
+ | GEnumTagDecl(ei,_) -> handle we ei [g]
+ | GVarDecl(vi,_)
+ | GVar(vi,_,_) -> handle wv vi [g]
+ | GFun(f,_) -> handle wv f.svar [g]
+ | _ -> DoChildren
+ end
+ method vtype t = begin
+ match t with
+ | TNamed(ti,_) -> handle wt ti t
+ | TComp(ci,_) -> handle wc ci t
+ | TEnum(ei,_) -> handle we ei t
+ | _ -> DoChildren
+ end
+end
+
+(**********************************************************************
+ * STAGE 3
+ *
+ * Eliminate all of the elements from the program that are not marked
+ * "keep".
+ **********************************************************************)
+(*
+ * This is the visitor that throws away elements
+ *)
+let handle ht elt keep drop =
+ if (Hashtbl.mem ht elt) && (Hashtbl.find ht elt = true) then
+ (* DoChildren *) ChangeDoChildrenPost(keep,(fun a -> a))
+ else
+ ChangeTo(drop)
+
+class dropVisitor ws wi wt wc we wv = object
+ inherit nopCilVisitor
+
+ method vinst i = handle wi i [i] []
+ method vstmt s = handle ws s s (mkStmt (Instr([])))
+ method vglob g = begin
+ match g with
+ | GType(ti,_) -> handle wt ti [g] []
+ | GCompTag(ci,_)
+ | GCompTagDecl(ci,_) -> handle wc ci [g] []
+ | GEnumTag(ei,_)
+ | GEnumTagDecl(ei,_) -> handle we ei [g] []
+ | GVarDecl(vi,_)
+ | GVar(vi,_,_) -> handle wv vi [g] []
+ | GFun(f,l) ->
+ let new_locals = List.filter (fun vi ->
+ Hashtbl.mem wv vi && (Hashtbl.find wv vi = true)) f.slocals in
+ let new_fundec = { f with slocals = new_locals} in
+ handle wv f.svar [(GFun(new_fundec,l))] []
+ | _ -> DoChildren
+ end
+end
+
+(**********************************************************************
+ * STAGE 1
+ *
+ * Mark up the file with user-given information about what to keep and
+ * what to drop.
+ **********************************************************************)
+type mark = Wanted | Unwanted | Unspecified
+(* Given a cil file and a list of strings, mark all of the given ASTSlicer
+ * points as wanted or unwanted. *)
+let mark_file (f : Cil.file) (names : (string, mark) Hashtbl.t) =
+ let ws = Hashtbl.create 32767 in
+ let wi = Hashtbl.create 32767 in
+ let wt = Hashtbl.create 32767 in
+ let wc = Hashtbl.create 32767 in
+ let we = Hashtbl.create 32767 in
+ let wv = Hashtbl.create 32767 in
+ if !debug then Printf.printf "Applying user marks to file ...\n" ;
+ let descend base i =
+ let res = (Printf.sprintf "%s.%d" base !i),(ref 0) in
+ res
+ in
+ let check base i (default : mark) =
+ let str = Printf.sprintf "%s.%d" base !i in
+ if !debug then Printf.printf "Looking for [%s]\n" str ;
+ try Hashtbl.find names str
+ with _ -> default
+ in
+ let mark ht stmt wanted = match wanted with
+ Unwanted -> Hashtbl.replace ht stmt false
+ | Wanted -> Hashtbl.replace ht stmt true
+ | Unspecified -> ()
+ in
+ let rec doBlock b base i default =
+ doStmtList b.bstmts base i default
+ and doStmtList sl base i default =
+ List.iter (fun s -> match s.skind with
+ | Instr(il) -> doIL il base i default
+ | Return(_,_)
+ | Goto(_,_)
+ | Continue(_)
+ | Break(_) ->
+ mark ws s (check base i default) ; incr i
+ | If(e,b1,b2,_) ->
+ let inside = check base i default in
+ mark ws s inside ;
+ let base',i' = descend base i in
+ doBlock b1 base' i' inside ;
+ let base'',i'' = descend base i in
+ doBlock b2 base'' i'' inside ;
+ incr i
+ | Switch(_,b,_,_)
+ | Loop(b,_,_,_)
+ | Block(b) ->
+ let inside = check base i default in
+ mark ws s inside ;
+ let base',i' = descend base i in
+ doBlock b base' i' inside ;
+ incr i
+ | TryExcept _ | TryFinally _ ->
+ E.s (E.unimp "astslicer: mark")
+ ) sl
+ and doIL il base i default =
+ List.iter (fun ins -> mark wi ins (check base i default) ; incr i) il
+ in
+ let doGlobal g = match g with
+ | GFun(fd,_) ->
+ let cur = ref 0 in
+ if Hashtbl.mem names fd.svar.vname then begin
+ if Hashtbl.find names fd.svar.vname = Wanted then begin
+ Hashtbl.replace wv fd.svar true ;
+ doBlock fd.sbody fd.svar.vname cur (Wanted);
+ end else begin
+ Hashtbl.replace wv fd.svar false ;
+ doBlock fd.sbody fd.svar.vname cur (Unspecified);
+ end
+ end else begin
+ doBlock fd.sbody fd.svar.vname cur (Unspecified);
+ end
+ | _ -> ()
+ in
+ List.iter doGlobal f.globals ;
+ if !debug then begin
+ Hashtbl.iter (fun k v ->
+ ignore (Pretty.printf "want-s %b %a\n" v d_stmt k)) ws ;
+ Hashtbl.iter (fun k v ->
+ ignore (Pretty.printf "want-i %b %a\n" v d_instr k)) wi ;
+ Hashtbl.iter (fun k v ->
+ ignore (Pretty.printf "want-v %b %s\n" v k.vname)) wv ;
+ end ;
+ (*
+ * Now repeatedly mark all other things that must be kept.
+ *)
+ let visitor = (new transVisitor ws wi wt wc we wv) in
+ finished := false ;
+ if !debug then (Printf.printf "\nPerforming Transitive Closure\n\n" );
+ while not !finished do
+ finished := true ;
+ visitCilFileSameGlobals visitor f
+ done ;
+ if !debug then begin
+ Hashtbl.iter (fun k v ->
+ if v then ignore (Pretty.printf "want-s %a\n" d_stmt k)) ws ;
+ Hashtbl.iter (fun k v ->
+ if v then ignore (Pretty.printf "want-i %a\n" d_instr k)) wi ;
+ Hashtbl.iter (fun k v ->
+ if v then ignore (Pretty.printf "want-t %s\n" k.tname)) wt ;
+ Hashtbl.iter (fun k v ->
+ if v then ignore (Pretty.printf "want-c %s\n" k.cname)) wc ;
+ Hashtbl.iter (fun k v ->
+ if v then ignore (Pretty.printf "want-e %s\n" k.ename)) we ;
+ Hashtbl.iter (fun k v ->
+ if v then ignore (Pretty.printf "want-v %s\n" k.vname)) wv ;
+ end ;
+
+ (*
+ * Now drop everything we didn't need.
+ *)
+ if !debug then (Printf.printf "Dropping Unwanted Elements\n" );
+ let visitor = (new dropVisitor ws wi wt wc we wv) in
+ visitCilFile visitor f
--- /dev/null
+(* compute available expressions, although in a somewhat
+ non-traditional way. the abstract state is a mapping from
+ variable ids to expressions as opposed to a set of
+ expressions *)
+
+open Cil
+open Pretty
+open Expcompare
+
+module E = Errormsg
+module DF = Dataflow
+module UD = Usedef
+module IH = Inthash
+module U = Util
+module S = Stats
+
+let debug = ref false
+let doTime = ref false
+
+
+let time s f a =
+ if !doTime then
+ S.time s f a
+ else f a
+
+(*
+ * When ignore_inst returns true, then
+ * the instruction in question has no
+ * effects on the abstract state.
+ * When ignore_call returns true, then
+ * the instruction only has side-effects
+ * from the assignment if there is one.
+ *)
+let ignore_inst = ref (fun i -> false)
+let ignore_call = ref (fun i -> false)
+
+let registerIgnoreInst (f : instr -> bool) : unit =
+ let f' = !ignore_inst in
+ ignore_inst := (fun i -> (f i) || (f' i))
+
+let registerIgnoreCall (f : instr -> bool) : unit =
+ let f' = !ignore_call in
+ ignore_call := (fun i -> (f i) || (f' i))
+
+
+(* exp IH.t -> exp IH.t -> bool *)
+let eh_equals eh1 eh2 =
+ if not(IH.length eh1 = IH.length eh2)
+ then false
+ else IH.fold (fun vid e b ->
+ if not b then b else
+ try let e2 = IH.find eh2 vid in
+ if not(compareExpStripCasts e e2)
+ then false
+ else true
+ with Not_found -> false)
+ eh1 true
+
+let eh_pretty () eh = line ++ seq line (fun (vid,e) ->
+ text "AE:vid:" ++ num vid ++ text ": " ++
+ (d_exp () e)) (IH.tolist eh)
+
+(* the result must be the intersection of eh1 and eh2 *)
+(* exp IH.t -> exp IH.t -> exp IH.t *)
+let eh_combine eh1 eh2 =
+ if !debug then ignore(E.log "eh_combine: combining %a\n and\n %a\n"
+ eh_pretty eh1 eh_pretty eh2);
+ let eh' = IH.copy eh1 in (* eh' gets all of eh1 *)
+ IH.iter (fun vid e1 ->
+ try let e2l = IH.find_all eh2 vid in
+ if not(List.exists (fun e2 -> compareExpStripCasts e1 e2) e2l)
+ (* remove things from eh' that eh2 doesn't have *)
+ then let e1l = IH.find_all eh' vid in
+ let e1l' = List.filter (fun e -> not(compareExpStripCasts e e1)) e1l in
+ IH.remove_all eh' vid;
+ List.iter (fun e -> IH.add eh' vid e) e1l'
+ with Not_found ->
+ IH.remove_all eh' vid) eh1;
+ if !debug then ignore(E.log "with result %a\n"
+ eh_pretty eh');
+ eh'
+
+
+(* On a memory write, kill expressions containing memory reads
+ variables whose address has been taken, and globals. *)
+class memReadOrAddrOfFinderClass br = object(self)
+ inherit nopCilVisitor
+
+ method vexpr e = match e with
+ | Lval(Mem _, _) -> begin
+ br := true;
+ SkipChildren
+ end
+ | AddrOf(Var vi, NoOffset) ->
+ (* Writing to memory won't change the address of something *)
+ SkipChildren
+ | _ -> DoChildren
+
+ method vvrbl vi =
+ if vi.vaddrof || vi.vglob then
+ (br := true;
+ SkipChildren)
+ else DoChildren
+
+end
+
+(* exp -> bool *)
+let exp_has_mem_read e =
+ let br = ref false in
+ let vis = new memReadOrAddrOfFinderClass br in
+ ignore(visitCilExpr vis e);
+ !br
+
+
+let eh_kill_mem eh =
+ IH.iter (fun vid e ->
+ if exp_has_mem_read e
+ then IH.remove eh vid)
+ eh
+
+(* need to kill exps containing a particular vi sometimes *)
+class viFinderClass vi br = object(self)
+ inherit nopCilVisitor
+
+ method vvrbl vi' =
+ if vi.vid = vi'.vid
+ then (br := true; SkipChildren)
+ else DoChildren
+
+end
+
+let exp_has_vi vi e =
+ let br = ref false in
+ let vis = new viFinderClass vi br in
+ ignore(visitCilExpr vis e);
+ !br
+
+let eh_kill_vi eh vi =
+ IH.iter (fun vid e ->
+ if exp_has_vi vi e
+ then IH.remove eh vid)
+ eh
+
+(* need to kill exps containing a particular lval sometimes *)
+class lvalFinderClass lv br = object(self)
+ inherit nopCilVisitor
+
+ method vlval l =
+ if compareLval l lv
+ then (br := true; SkipChildren)
+ else DoChildren
+
+end
+
+let exp_has_lval lv e =
+ let br = ref false in
+ let vis = new lvalFinderClass lv br in
+ ignore(visitCilExpr vis e);
+ !br
+
+let eh_kill_lval eh lv =
+ IH.iter (fun vid e ->
+ if exp_has_lval lv e
+ then IH.remove eh vid)
+ eh
+
+
+class volatileFinderClass br = object(self)
+ inherit nopCilVisitor
+
+ method vexpr e =
+ if (hasAttribute "volatile" (typeAttrs (typeOf e)))
+ then (br := true; SkipChildren)
+ else DoChildren
+end
+
+let exp_is_volatile e : bool =
+ let br = ref false in
+ let vis = new volatileFinderClass br in
+ ignore(visitCilExpr vis e);
+ !br
+
+let varHash = IH.create 32
+
+let eh_kill_addrof_or_global eh =
+ if !debug then ignore(E.log "eh_kill: in eh_kill\n");
+ IH.iter (fun vid e ->
+ try let vi = IH.find varHash vid in
+ if vi.vaddrof
+ then begin
+ if !debug then ignore(E.log "eh_kill: %s has its address taken\n"
+ vi.vname);
+ IH.remove eh vid
+ end
+ else if vi.vglob
+ then begin
+ if !debug then ignore(E.log "eh_kill: %s is global\n"
+ vi.vname);
+ IH.remove eh vid
+ end
+ with Not_found -> ()) 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.
+ also kill mappings from vars that have had their address taken,
+ and globals.
+ otherwise kill things with lv in them and add e *)
+ Set(lv,e,_) -> (match lv with
+ (Mem _, _) ->
+ (eh_kill_mem eh;
+ eh_kill_addrof_or_global eh;
+ eh)
+ | (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
+ (IH.replace eh vi.vid e;
+ eh_kill_vi eh vi;
+ eh)
+ | _ ->
+ (IH.replace eh vi.vid e;
+ eh_kill_vi eh vi;
+ eh))
+ | (Var vi, _ ) -> begin
+ (* must remove mapping for vi *)
+ IH.remove eh vi.vid;
+ eh_kill_lval eh lv;
+ eh
+ end)
+ | Call(Some(Var vi,NoOffset),_,_,_) ->
+ (IH.remove eh vi.vid;
+ eh_kill_vi eh vi;
+ if not((!ignore_call) i) then begin
+ eh_kill_mem eh;
+ eh_kill_addrof_or_global eh
+ end;
+ eh)
+ | Call(_,_,_,_) ->
+ (eh_kill_mem eh;
+ eh_kill_addrof_or_global eh;
+ eh)
+ | Asm(_,_,_,_,_,_) ->
+ let _,d = UD.computeUseDefInstr i in
+ (UD.VS.iter (fun vi ->
+ eh_kill_vi eh vi) d;
+ eh)
+
+module AvailableExps =
+ struct
+
+ let name = "Available Expressions"
+
+ let debug = debug
+
+ (* mapping from var id to expression *)
+ type t = exp IH.t
+
+ let copy = IH.copy
+
+ let stmtStartData = IH.create 64
+
+ let pretty = eh_pretty
+
+ let computeFirstPredecessor stm eh = eh
+
+ let combinePredecessors (stm:stmt) ~(old:t) (eh:t) =
+ if time "eh_equals" (eh_equals old) eh then None else
+ Some(time "eh_combine" (eh_combine old) eh)
+
+ let doInstr i eh =
+ let action = eh_handle_inst i in
+ DF.Post(action)
+
+ let doStmt stm astate = DF.SDefault
+
+ let doGuard c astate = DF.GDefault
+
+ let filterStmt stm = true
+
+ end
+
+module AE = DF.ForwardsDataFlow(AvailableExps)
+
+(* make an exp IH.t with everything in it,
+ * also, fill in varHash while we're here.
+ *)
+class varHashMakerClass = object(self)
+ inherit nopCilVisitor
+
+ method vvrbl vi =
+ (if not(IH.mem varHash vi.vid)
+ 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));
+ DoChildren
+
+end
+
+let varHashMaker = new varHashMakerClass
+
+let make_var_hash fd =
+ IH.clear varHash;
+ ignore(visitCilFunction varHashMaker fd)
+
+(*
+ * Computes AEs for function fd.
+ *
+ *
+ *)
+let computeAEs fd =
+ try let slst = fd.sbody.bstmts in
+ let first_stm = List.hd slst in
+ time "make_var_hash" make_var_hash 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")
+ | Not_found -> if !debug then ignore(E.log "no data for first_stm?\n")
+
+
+(* get the AE data for a statement *)
+let getAEs sid =
+ try Some(IH.find AvailableExps.stmtStartData sid)
+ with Not_found -> None
+
+(* get the AE data for an instruction list *)
+let instrAEs il sid eh out =
+ let proc_one hil i =
+ match hil with
+ [] -> let eh' = IH.copy eh in
+ let eh'' = eh_handle_inst i eh' in
+ eh''::hil
+ | eh'::ehrst as l ->
+ let eh' = IH.copy eh' in
+ let eh'' = eh_handle_inst i eh' in
+ eh''::l
+ in
+ let folded = List.fold_left proc_one [eh] il in
+ let foldednotout = List.rev (List.tl folded) in
+ foldednotout
+
+class aeVisitorClass = object(self)
+ inherit nopCilVisitor
+
+ val mutable sid = -1
+
+ val mutable ae_dat_lst = []
+
+ val mutable cur_ae_dat = None
+
+ method vstmt stm =
+ sid <- stm.sid;
+ match getAEs sid with
+ None ->
+ if !debug then ignore(E.log "aeVis: stm %d has no data\n" sid);
+ cur_ae_dat <- None;
+ DoChildren
+ | Some eh ->
+ match stm.skind with
+ Instr il ->
+ if !debug then ignore(E.log "aeVist: visit il\n");
+ ae_dat_lst <- time "instrAEs" (instrAEs il stm.sid eh) false;
+ DoChildren
+ | _ ->
+ if !debug then ignore(E.log "aeVisit: visit non-il\n");
+ cur_ae_dat <- None;
+ DoChildren
+
+ 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
+ let data = List.hd ae_dat_lst in
+ cur_ae_dat <- Some(data);
+ 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" ->
+ if !debug then ignore(E.log "aeVis: il ae_dat_lst mismatch\n");
+ DoChildren
+
+ method get_cur_eh () =
+ match cur_ae_dat with
+ None -> getAEs sid
+ | Some eh -> Some eh
+
+end
--- /dev/null
+(* compute available expressions, although in a somewhat
+ non-traditional way. the abstract state is a mapping from
+ lvalues to expressions as opposed to a set of
+ expressions *)
+
+open Cil
+open Pretty
+open Expcompare
+
+module E = Errormsg
+module DF = Dataflow
+module UD = Usedef
+module IH = Inthash
+module H = Hashtbl
+module U = Util
+module S = Stats
+
+let debug = ref false
+let doTime = ref false
+
+
+let time s f a =
+ if !doTime then
+ S.time s f a
+ else f a
+
+(*
+ * When ignore_inst returns true, then
+ * the instruction in question has no
+ * effects on the abstract state.
+ * When ignore_call returns true, then
+ * the instruction only has side-effects
+ * from the assignment if there is one.
+ *)
+let ignore_inst = ref (fun i -> false)
+let ignore_call = ref (fun i -> false)
+
+let registerIgnoreInst (f : instr -> bool) : unit =
+ let f' = !ignore_inst in
+ ignore_inst := (fun i -> (f i) || (f' i))
+
+let registerIgnoreCall (f : instr -> bool) : unit =
+ let f' = !ignore_call in
+ ignore_call := (fun i -> (f i) || (f' i))
+
+
+module LvExpHash =
+ H.Make(struct
+ type t = lval
+ let equal lv1 lv2 = compareLval lv1 lv2
+ let hash = H.hash
+ end)
+
+(* exp LvExpHash.t -> exp LvExpHash.t -> bool *)
+let lvh_equals lvh1 lvh2 =
+ if not(LvExpHash.length lvh1 = LvExpHash.length lvh2)
+ then false
+ else LvExpHash.fold (fun lv e b ->
+ if not b then b else
+ try let e2 = LvExpHash.find lvh2 lv in
+ if not(compareExpStripCasts e e2)
+ then false
+ else true
+ with Not_found -> false)
+ lvh1 true
+
+let lvh_pretty () lvh = LvExpHash.fold (fun lv e d ->
+ d ++ line ++ (d_lval () lv) ++ text " -> " ++ (d_exp () e))
+ lvh nil
+
+
+(* the result must be the intersection of eh1 and eh2 *)
+(* exp IH.t -> exp IH.t -> exp IH.t *)
+let lvh_combine lvh1 lvh2 =
+ if !debug then ignore(E.log "lvh_combine: combining %a\n and\n %a\n"
+ lvh_pretty lvh1 lvh_pretty lvh2);
+ let lvh' = LvExpHash.copy lvh1 in (* eh' gets all of eh1 *)
+ LvExpHash.iter (fun lv e1 ->
+ try let e2l = LvExpHash.find_all lvh2 lv in
+ if not(List.exists (fun e2 -> compareExpStripCasts e1 e2) e2l)
+ (* remove things from eh' that eh2 doesn't have *)
+ then let e1l = LvExpHash.find_all lvh' lv in
+ let e1l' = List.filter (fun e -> not(compareExpStripCasts e e1)) e1l in
+ LvExpHash.remove lvh' lv;
+ List.iter (fun e -> LvExpHash.add lvh' lv e) e1l'
+ with Not_found ->
+ LvExpHash.remove lvh' lv) lvh1;
+ if !debug then ignore(E.log "with result %a\n"
+ lvh_pretty lvh');
+ lvh'
+
+
+(* On a memory write, kill expressions containing memory reads
+ variables whose address has been taken, and globals. *)
+class memReadOrAddrOfFinderClass br = object(self)
+ inherit nopCilVisitor
+
+ method vexpr e = match e with
+ | AddrOf(Mem _, _)
+ | StartOf(Mem _, _)
+ | Lval(Mem _, _) -> begin
+ br := true;
+ SkipChildren
+ end
+ | AddrOf(Var vi, NoOffset) ->
+ (* Writing to memory won't change the address of something *)
+ SkipChildren
+ | _ -> DoChildren
+
+ method vvrbl vi =
+ if vi.vaddrof || vi.vglob then
+ (br := true;
+ SkipChildren)
+ else DoChildren
+
+end
+
+
+(* exp -> bool *)
+let exp_has_mem_read e =
+ let br = ref false in
+ let vis = new memReadOrAddrOfFinderClass br in
+ ignore(visitCilExpr vis e);
+ !br
+
+let lval_has_mem_read lv =
+ let br = ref false in
+ let vis = new memReadOrAddrOfFinderClass br in
+ ignore(visitCilLval vis lv);
+ !br
+
+let offset_has_mem_read off =
+ let br = ref false in
+ let vis = new memReadOrAddrOfFinderClass br in
+ ignore(visitCilOffset vis off);
+ !br
+
+let lvh_kill_mem lvh =
+ LvExpHash.iter (fun lv e ->
+ match lv with
+ | (Mem _, _) -> LvExpHash.remove lvh lv
+ | _ ->
+ if exp_has_mem_read e || lval_has_mem_read lv
+ then LvExpHash.remove lvh lv)
+ lvh
+
+(* need to kill exps containing a particular vi sometimes *)
+class viFinderClass vi br = object(self)
+ inherit nopCilVisitor
+
+ method vvrbl vi' =
+ if vi.vid = vi'.vid
+ then (br := true; SkipChildren)
+ else DoChildren
+
+end
+
+let instr_has_vi vi i =
+ let br = ref false in
+ let vis = new viFinderClass vi br in
+ ignore(visitCilInstr vis i);
+ !br
+
+let exp_has_vi vi e =
+ let br = ref false in
+ let vis = new viFinderClass vi br in
+ ignore(visitCilExpr vis e);
+ !br
+
+let lval_has_vi vi lv =
+ let br = ref false in
+ let vis = new viFinderClass vi br in
+ ignore(visitCilLval vis lv);
+ !br
+
+let lvh_kill_vi lvh vi =
+ LvExpHash.iter (fun lv e ->
+ if exp_has_vi vi e || lval_has_vi vi lv
+ then LvExpHash.remove lvh lv)
+ lvh
+
+(* need to kill exps containing a particular lval sometimes *)
+class lvalFinderClass lv br = object(self)
+ inherit nopCilVisitor
+
+ method vlval l =
+ if compareLval l lv
+ then (br := true; SkipChildren)
+ else DoChildren
+
+end
+
+let exp_has_lval lv e =
+ let br = ref false in
+ let vis = new lvalFinderClass lv br in
+ ignore(visitCilExpr vis e);
+ !br
+
+let lval_has_lval lv (host,hostoff) =
+ let br = ref false in
+ let vis = new lvalFinderClass lv br in
+ (match host with
+ | Mem e -> ignore(visitCilExpr vis e)
+ | _ -> ());
+ ignore(visitCilOffset vis hostoff);
+ !br
+
+let lvh_kill_lval lvh lv =
+ LvExpHash.iter (fun lv' e ->
+ if exp_has_lval lv e || lval_has_lval lv lv'
+ then LvExpHash.remove lvh lv')
+ lvh
+
+
+class volatileFinderClass br = object(self)
+ inherit nopCilVisitor
+
+ method vexpr e =
+ if (hasAttribute "volatile" (typeAttrs (typeOf e)))
+ then (br := true; SkipChildren)
+ else DoChildren
+end
+
+let exp_is_volatile e : bool =
+ let br = ref false in
+ let vis = new volatileFinderClass br in
+ ignore(visitCilExpr vis e);
+ !br
+
+(* let varHash = IH.create 32 *)
+
+class addrOfOrGlobalFinderClass br = object(self)
+ inherit nopCilVisitor
+
+ method vvrbl vi =
+ if vi.vaddrof || vi.vglob
+ then (br := true; SkipChildren)
+ else DoChildren
+
+end
+
+let exp_has_addrof_or_global e =
+ let br = ref false in
+ let vis = new addrOfOrGlobalFinderClass br in
+ ignore(visitCilExpr vis e);
+ !br
+
+let lval_has_addrof_or_global lv =
+ let br = ref false in
+ let vis = new addrOfOrGlobalFinderClass br in
+ ignore(visitCilLval vis lv);
+ !br
+
+let lvh_kill_addrof_or_global lvh =
+ LvExpHash.iter (fun lv e ->
+ if lval_has_addrof_or_global lv
+ then LvExpHash.remove lvh lv)
+ lvh
+
+
+let lvh_handle_inst i lvh =
+ if (!ignore_inst) i then lvh else
+ match i with
+ Set(lv,e,_) -> begin
+ match lv with
+ | (Mem _, _) -> begin
+ LvExpHash.replace lvh lv e;
+ lvh_kill_mem lvh;
+ lvh_kill_addrof_or_global lvh;
+ lvh
+ end
+ | _ when not (exp_is_volatile e) -> begin
+ (* ignore x = x *)
+ if compareExpStripCasts (Lval lv) e then lvh
+ else begin
+ LvExpHash.replace lvh lv e;
+ lvh_kill_lval lvh lv;
+ lvh
+ end
+ end
+ | _ -> begin (* e is volatile *)
+ (* must remove mapping for lv *)
+ if !debug then ignore(E.log "lvh_handle_inst: %a is volatile. killing %a\n"
+ d_exp e d_lval lv);
+ LvExpHash.remove lvh lv;
+ lvh_kill_lval lvh lv;
+ lvh
+ end
+ end
+ | Call(Some lv,_,_,_) -> begin
+ LvExpHash.remove lvh lv;
+ lvh_kill_lval lvh lv;
+ if not((!ignore_call) i) then begin
+ lvh_kill_mem lvh;
+ lvh_kill_addrof_or_global lvh
+ end;
+ lvh
+ end
+ | Call(_,_,_,_) -> begin
+ if not((!ignore_call) i) then begin
+ lvh_kill_mem lvh;
+ lvh_kill_addrof_or_global lvh;
+ end;
+ lvh
+ end
+ | Asm(_,_,_,_,_,_) -> begin
+ let _,d = UD.computeUseDefInstr i in
+ UD.VS.iter (fun vi ->
+ lvh_kill_vi lvh vi) d;
+ lvh
+ end
+
+module AvailableExps =
+ struct
+
+ let name = "Available Expressions"
+
+ let debug = debug
+
+ (* mapping from var id to expression *)
+ type t = exp LvExpHash.t
+
+ let copy = LvExpHash.copy
+
+ let stmtStartData = IH.create 64
+
+ let pretty = lvh_pretty
+
+ let computeFirstPredecessor stm lvh = lvh
+
+ let combinePredecessors (stm:stmt) ~(old:t) (lvh:t) =
+ if time "lvh_equals" (lvh_equals old) lvh then None else
+ Some(time "lvh_combine" (lvh_combine old) lvh)
+
+ let doInstr i lvh =
+ let action = lvh_handle_inst i in
+ DF.Post(action)
+
+ let doStmt stm astate = DF.SDefault
+
+ let doGuard c astate = DF.GDefault
+
+ let filterStmt stm = true
+
+ end
+
+module AE = DF.ForwardsDataFlow(AvailableExps)
+
+
+(*
+ * Computes AEs for function fd.
+ *
+ *
+ *)
+let computeAEs fd =
+ try let slst = fd.sbody.bstmts in
+ let first_stm = List.hd slst in
+ (*time "make_var_hash" make_var_hash 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")
+ | Not_found -> if !debug then ignore(E.log "no data for first_stm?\n")
+
+
+(* get the AE data for a statement *)
+let getAEs sid =
+ try Some(IH.find AvailableExps.stmtStartData sid)
+ with Not_found -> None
+
+(* get the AE data for an instruction list *)
+let instrAEs il sid lvh out =
+ if !debug then ignore(E.log "instrAEs\n");
+ let proc_one hil i =
+ match hil with
+ [] -> let lvh' = LvExpHash.copy lvh in
+ let lvh'' = lvh_handle_inst i lvh' in
+ lvh''::hil
+ | lvh'::ehrst as l ->
+ let lvh' = LvExpHash.copy lvh' in
+ let lvh'' = lvh_handle_inst i lvh' in
+ lvh''::l
+ in
+ let folded = List.fold_left proc_one [lvh] il in
+ let foldednotout = List.rev (List.tl folded) in
+ foldednotout
+
+class aeVisitorClass = object(self)
+ inherit nopCilVisitor
+
+ val mutable sid = -1
+
+ val mutable ae_dat_lst = []
+
+ val mutable cur_ae_dat = None
+
+ method vstmt stm =
+ sid <- stm.sid;
+ match getAEs sid with
+ None ->
+ if !debug then ignore(E.log "aeVis: stm %d has no data\n" sid);
+ cur_ae_dat <- None;
+ DoChildren
+ | Some eh ->
+ match stm.skind with
+ Instr il ->
+ if !debug then ignore(E.log "aeVist: visit il\n");
+ ae_dat_lst <- time "instrAEs" (instrAEs il stm.sid eh) false;
+ DoChildren
+ | _ ->
+ if !debug then ignore(E.log "aeVisit: visit non-il\n");
+ cur_ae_dat <- None;
+ DoChildren
+
+ 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
+ let data = List.hd ae_dat_lst in
+ cur_ae_dat <- Some(data);
+ 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" ->
+ if !debug then ignore(E.log "aeVis: il ae_dat_lst mismatch\n");
+ DoChildren
+
+ method get_cur_eh () =
+ match cur_ae_dat with
+ None -> getAEs sid
+ | Some eh -> Some eh
+
+end
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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 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, List.map 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 " <blocks>"
+ | BlockPoint -> output_string !E.logChannel " <blockpt>"
+ | EndPoint -> output_string !E.logChannel " <endpt>"
+ end;
+ if n.scanned then (* Already dumped *)
+ output_string !E.logChannel " <rec> "
+ 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 (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;
+ 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 : featureDescr =
+ { fd_name = "FCG";
+ fd_enabled = ref 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;
+ }
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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: Cil.featureDescr
--- /dev/null
+(* callgraph.ml *)
+(* code for callgraph.mli *)
+
+(* see copyright notice at end of this file *)
+
+open Cil
+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 ("<indirect>", 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 doCallGraph = ref false
+
+let feature : featureDescr =
+ { fd_name = "callgraph";
+ fd_enabled = doCallGraph;
+ fd_description = "generation of a static call graph";
+ fd_extraopt = [];
+ fd_doit =
+ (function (f: file) ->
+ let graph:callgraph = computeGraph f in
+ printGraph stdout graph);
+ fd_post_check = false;
+ }
+
+
+(*
+ *
+ * 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.
+ *
+ *)
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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: Cil.featureDescr
+(*
+ *
+ * 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.
+ *
+ *)
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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
+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.\n"
+ 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.\n"
+ 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 = 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' = 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 : featureDescr =
+ { fd_name = "canonicalize";
+ fd_enabled = ref false;
+ fd_description = "fixing some C-isms so that the result is C++ compliant.";
+ fd_extraopt = [];
+ fd_doit = canonicalize;
+ fd_post_check = true;
+ }
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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: Cil.featureDescr
--- /dev/null
+(*
+ *
+ * Copyright (c) 2004,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 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\n")
+ 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\n" 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\n")
+ d_type t1 d_type t2);
+ true (* TODO: improve this check *)
+ | _, TVoid _
+ | TVoid _, _ ->
+ ignore (warning ("unchecked void cast\n" ^^
+ " to: %a\n from: %a\n")
+ 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\n"
+ d_type t d_type eType);
+ if not (checkCast tFacts eFacts) then
+ ignore (error "cannot verify cast\n to: %a\n from: %a\n"
+ d_facts tFacts d_facts eFacts)
+ end;
+ SFacts tFacts
+ end
+ | Const (CStr s) ->
+ SFacts (FactSet.singleton ("*", ANT 0))
+ | Const _ ->
+ begin
+ match isInteger e with
+ | Some i -> SInt (Int64.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
+
+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\n" 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 isInteger (constFold true (SizeOf t)) with
+ | Some i -> Int64.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\n")
+ 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\n")
+ 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" && isInteger chr = Some Int64.zero ->
+ 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\n")
+ | 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 outSubst = Hashtbl.create 7 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\n")
+ end else
+ ignore (error "too many actuals\n")
+ | _ :: _, [] ->
+ ignore (error "too many formals\n")
+ 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 fFacts = 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\n")
+ end
+ | Set (lv, e, l) ->
+ doSet lv (typeOf e) (summaryToFacts (evaluateExp e state) state)
+ | Asm (_, _, _, _, _, l) ->
+ if not !suppress then
+ ignore (warning "ignoring asm\n")
+ 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\n")
+ 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\n")
+ 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")
+ 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 =
+ 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 := List.map fst expStats.verified;
+ verifiedArgs := 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\n")
+
+let feature : featureDescr =
+ { fd_name = "CCL";
+ fd_enabled = ref 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;
+ }
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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: Cil.featureDescr
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2003,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * Simon Goldsmith <sfg@cs.berkeley.edu>
+ * 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:
+ *
+ * 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.
+ *
+ *)
+
+(* Authors: Aman Bhargava, S. P. Rahul *)
+(* sfg: this stuff was stolen from optim.ml - the code to print the cfg as
+ a dot graph is mine *)
+
+open Pretty
+open Cil
+module E=Errormsg
+
+(* entry points: cfgFun, printCfgChannel, printCfgFilename *)
+
+(* known issues:
+ * -sucessors of if somehow end up with two edges each
+ *)
+
+(*------------------------------------------------------------*)
+(* Notes regarding CFG computation:
+ 1) Initially only succs and preds are computed. sid's are filled in
+ later, in whatever order is suitable (e.g. for forward problems, reverse
+ depth-first postorder).
+ 2) If a stmt (return, break or continue) has no successors, then
+ function return must follow.
+ No predecessors means it is the start of the function
+ 3) We use the fact that initially all the succs and preds are assigned []
+*)
+
+(* Fill in the CFG info for the stmts in a block
+ next = succ of the last stmt in this block
+ break = succ of any Break in this block
+ cont = succ of any Continue in this block
+ None means the succ is the function return. It does not mean the break/cont
+ is invalid. We assume the validity has already been checked.
+*)
+(* At the end of CFG computation,
+ - numNodes = total number of CFG nodes
+ - length(nodeList) = numNodes
+*)
+
+let numNodes = ref 0 (* number of nodes in the CFG *)
+let nodeList : stmt list ref = ref [] (* All the nodes in a flat list *) (* ab: Added to change dfs from quadratic to linear *)
+let start_id = ref 0 (* for unique ids across many functions *)
+
+class caseLabeledStmtFinder slr = object(self)
+ inherit nopCilVisitor
+
+ method vstmt s =
+ if List.exists (fun l ->
+ match l with | Case(_, _) | Default _ -> true | _ -> false)
+ s.labels
+ then begin
+ slr := s :: (!slr);
+ match s.skind with
+ | Switch(_,_,_,_) -> SkipChildren
+ | _ -> DoChildren
+ end else match s.skind with
+ | Switch(_,_,_,_) -> SkipChildren
+ | _ -> DoChildren
+end
+
+let findCaseLabeledStmts (b : block) : stmt list =
+ let slr = ref [] in
+ let vis = new caseLabeledStmtFinder slr in
+ ignore(visitCilBlock vis b);
+ !slr
+
+(* entry point *)
+
+(** Compute a control flow graph for fd. Stmts in fd have preds and succs
+ filled in *)
+let rec cfgFun (fd : fundec): int =
+ begin
+ numNodes := !start_id;
+ nodeList := [];
+
+ cfgBlock fd.sbody None None None;
+
+ fd.smaxstmtid <- Some(!numNodes);
+ fd.sallstmts <- List.rev !nodeList;
+ nodeList := [];
+
+ !numNodes - !start_id
+ end
+
+
+and cfgStmts (ss: stmt list)
+ (next:stmt option) (break:stmt option) (cont:stmt option) =
+ match ss with
+ [] -> ();
+ | [s] -> cfgStmt s next break cont
+ | hd::tl ->
+ cfgStmt hd (Some (List.hd tl)) break cont;
+ cfgStmts tl next break cont
+
+and cfgBlock (blk: block)
+ (next:stmt option) (break:stmt option) (cont:stmt option) =
+ cfgStmts blk.bstmts next break cont
+
+
+(* Fill in the CFG info for a stmt
+ Meaning of next, break, cont should be clear from earlier comment
+*)
+and cfgStmt (s: stmt) (next:stmt option) (break:stmt option) (cont:stmt option) =
+ incr numNodes;
+ s.sid <- !numNodes;
+ nodeList := s :: !nodeList; (* Future traversals can be made in linear time. e.g. *)
+ if s.succs <> [] then
+ E.s (bug "CFG must be cleared before being computed!");
+ let addSucc (n: stmt) =
+ if not (List.memq n s.succs) then
+ s.succs <- n::s.succs;
+ if not (List.memq s n.preds) then
+ n.preds <- s::n.preds
+ in
+ let addOptionSucc (n: stmt option) =
+ match n with
+ None -> ()
+ | Some n' -> addSucc n'
+ in
+ let addBlockSucc (b: block) (n: stmt option) =
+ (* Add the first statement in b as a successor to the current stmt.
+ Or, if b is empty, add n as a successor *)
+ match b.bstmts with
+ [] -> addOptionSucc n
+ | hd::_ -> addSucc hd
+ in
+ let instrFallsThrough (i : instr) : bool = match i with
+ Call (_, Lval (Var vf, NoOffset), _, _) ->
+ (* See if this has the noreturn attribute *)
+ not (hasAttribute "noreturn" vf.vattr)
+ | Call (_, f, _, _) ->
+ not (hasAttribute "noreturn" (typeAttrs (typeOf f)))
+ | _ -> true
+ in
+ match s.skind with
+ Instr il ->
+ if List.for_all instrFallsThrough il then
+ addOptionSucc next
+ else
+ ()
+ | Return _ -> ()
+ | Goto (p,_) -> addSucc !p
+ | Break _ -> addOptionSucc break
+ | Continue _ -> addOptionSucc cont
+ | If (_, blk1, blk2, _) ->
+ (* The succs of If is [true branch;false branch] *)
+ addBlockSucc blk2 next;
+ addBlockSucc blk1 next;
+ cfgBlock blk1 next break cont;
+ cfgBlock blk2 next break cont
+ | Block b ->
+ addBlockSucc b next;
+ cfgBlock b next break cont
+ | Switch(_,blk,l,_) ->
+ let bl = findCaseLabeledStmts blk in
+ List.iter addSucc (List.rev bl(*l*)); (* Add successors in order *)
+ (* sfg: if there's no default, need to connect s->next *)
+ if not (List.exists
+ (fun stmt -> List.exists
+ (function Default _ -> true | _ -> false)
+ stmt.labels)
+ bl)
+ then
+ addOptionSucc next;
+ cfgBlock blk next next cont
+ | Loop(blk, loc, s1, s2) ->
+ s.skind <- Loop(blk, loc, (Some s), next);
+ addBlockSucc blk (Some s);
+ cfgBlock blk (Some s) next (Some s)
+ (* Since all loops have terminating condition true, we don't put
+ any direct successor to stmt following the loop *)
+ | TryExcept _ | TryFinally _ ->
+ E.s (E.unimp "try/except/finally")
+
+(*------------------------------------------------------------*)
+
+(**************************************************************)
+(* do something for all stmts in a fundec *)
+
+let rec forallStmts (todo) (fd : fundec) =
+ begin
+ fasBlock todo fd.sbody;
+ end
+
+and fasBlock (todo) (b : block) =
+ List.iter (fasStmt todo) b.bstmts
+
+and fasStmt (todo) (s : stmt) =
+ begin
+ ignore(todo s);
+ match s.skind with
+ | Block b -> fasBlock todo b
+ | If (_, tb, fb, _) -> (fasBlock todo tb; fasBlock todo fb)
+ | Switch (_, b, _, _) -> fasBlock todo b
+ | Loop (b, _, _, _) -> fasBlock todo b
+ | (Return _ | Break _ | Continue _ | Goto _ | Instr _) -> ()
+ | TryExcept _ | TryFinally _ -> E.s (E.unimp "try/except/finally")
+ end
+;;
+
+(**************************************************************)
+(* printing the control flow graph - you have to compute it first *)
+
+let d_cfgnodename () (s : stmt) =
+ dprintf "%d" s.sid
+
+let d_cfgnodelabel () (s : stmt) =
+ let label =
+ begin
+ match s.skind with
+ | If (e, _, _, _) -> "if" (*sprint ~width:999 (dprintf "if %a" d_exp e)*)
+ | Loop _ -> "loop"
+ | Break _ -> "break"
+ | Continue _ -> "continue"
+ | Goto _ -> "goto"
+ | Instr _ -> "instr"
+ | Switch _ -> "switch"
+ | Block _ -> "block"
+ | Return _ -> "return"
+ | TryExcept _ -> "try-except"
+ | TryFinally _ -> "try-finally"
+ end in
+ dprintf "%d: %s" s.sid label
+
+let d_cfgedge (src) () (dest) =
+ dprintf "%a -> %a"
+ d_cfgnodename src
+ d_cfgnodename dest
+
+let d_cfgnode () (s : stmt) =
+ dprintf "%a [label=\"%a\"]\n\t%a"
+ d_cfgnodename s
+ d_cfgnodelabel s
+ (d_list "\n\t" (d_cfgedge s)) s.succs
+
+(**********************************************************************)
+(* entry points *)
+
+(** print control flow graph (in dot form) for fundec to channel *)
+let printCfgChannel (chan : out_channel) (fd : fundec) =
+ let pnode (s:stmt) = fprintf chan "%a\n" d_cfgnode s in
+ begin
+ ignore (fprintf chan "digraph CFG_%s {\n" fd.svar.vname);
+ forallStmts pnode fd;
+ ignore(fprintf chan "}\n");
+ end
+
+(** Print control flow graph (in dot form) for fundec to file *)
+let printCfgFilename (filename : string) (fd : fundec) =
+ let chan = open_out filename in
+ begin
+ printCfgChannel chan fd;
+ close_out chan;
+ end
+
+
+;;
+
+(**********************************************************************)
+
+
+let clearCFGinfo (fd : fundec) =
+ let clear s =
+ s.sid <- -1;
+ s.succs <- [];
+ s.preds <- [];
+ in
+ forallStmts clear fd
+
+let clearFileCFG (f : file) =
+ start_id := 0; numNodes := 0;
+ iterGlobals f (fun g ->
+ match g with GFun(fd,_) ->
+ clearCFGinfo fd
+ | _ -> ())
+
+let computeFileCFG (f : file) =
+ iterGlobals f (fun g ->
+ match g with GFun(fd,_) ->
+ numNodes := cfgFun fd;
+ start_id := !start_id + !numNodes
+ | _ -> ())
--- /dev/null
+(** Code to compute the control-flow graph of a function or file.
+ This will fill in the [preds] and [succs] fields of {!Cil.stmt}
+
+ This is required for several other extensions, such as {!Dataflow}.
+*)
+
+open Cil
+
+
+(** Compute the CFG for an entire file, by calling cfgFun on each function. *)
+val computeFileCFG: Cil.file -> unit
+
+(** clear the sid, succs, and preds fields of each statement. *)
+val clearFileCFG: Cil.file -> unit
+
+(** Compute a control flow graph for fd. Stmts in fd have preds and succs
+ filled in *)
+val cfgFun : fundec -> int
+
+(** clear the sid, succs, and preds fields of each statment in a function *)
+val clearCFGinfo: Cil.fundec -> unit
+
+(** print control flow graph (in dot form) for fundec to channel *)
+val printCfgChannel : out_channel -> fundec -> unit
+
+(** Print control flow graph (in dot form) for fundec to file *)
+val printCfgFilename : string -> fundec -> unit
+
+(** Next statement id that will be assigned. *)
+val start_id: int ref
+
+(** All of the nodes in a file. *)
+val nodeList : stmt list ref
+
+(** number of nodes in the CFG *)
+val numNodes : int ref
--- /dev/null
+open Cil
+
+(* Contributed by Nathan Cooprider *)
+
+let isOne e =
+ isInteger e = Some Int64.one
+
+
+(* written by Zach *)
+let is_volatile_tp 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
+ | _ -> 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 . . .
+ ****************************************************************************)
+
+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.
+ ****************************************************************************)
+
+let unbox_int_type (ye : typ) : (int * sign) =
+ let tp = unrollType ye in
+ let s =
+ match tp with
+ TInt (i, _) ->
+ if (isSigned i) then
+ Signed
+ else
+ Unsigned
+ | _ -> raise Not_an_integer
+ in
+ (bitsSizeOf tp), s
+
+(* depricated. Use isInteger directly instead *)
+let unbox_int_exp (e : exp) : int64 =
+ match isInteger e with
+ None -> raise Not_an_integer
+ | Some (x) -> x
+
+let box_int_to_exp (n : int64) (ye : typ) : exp =
+ let tp = unrollType ye in
+ match tp with
+ TInt (i, _) ->
+ kinteger64 i n
+ | _ -> raise Not_an_integer
+
+let cil_to_ocaml_int (e : exp) : (int64 * int * sign) =
+ let v, s = unbox_int_type (typeOf e) in
+ unbox_int_exp (e), v, s
+
+exception Weird_bitwidth
+
+(* (int64 * int * sign) : exp *)
+let ocaml_int_to_cil v n s =
+ let char_size = bitsSizeOf charType in
+ let int_size = bitsSizeOf intType in
+ let short_size = bitsSizeOf (TInt(IShort,[]))in
+ let long_size = bitsSizeOf longType in
+ let longlong_size = bitsSizeOf (TInt(ILongLong,[])) in
+ let i =
+ match s with
+ Signed ->
+ if (n = char_size) then
+ ISChar
+ else if (n = int_size) then
+ IInt
+ else if (n = short_size) then
+ IShort
+ else if (n = long_size) then
+ ILong
+ else if (n = longlong_size) then
+ ILongLong
+ else
+ raise Weird_bitwidth
+ | Unsigned ->
+ if (n = char_size) then
+ IUChar
+ else if (n = int_size) then
+ IUInt
+ else if (n = short_size) then
+ IUShort
+ else if (n = long_size) then
+ IULong
+ else if (n = longlong_size) then
+ IULongLong
+ else
+ raise Weird_bitwidth
+ in
+ kinteger64 i v
+
+(*****************************************************************************
+ * a couple of type functions that I thought would be useful:
+ ****************************************************************************)
+
+let rec isCompositeType tp =
+ match tp with
+ TComp _ -> true
+ | TPtr(x, _) -> isCompositeType x
+ | TArray(x,_,_) -> isCompositeType x
+ | TFun(x,_,_,_) -> isCompositeType x
+ | TNamed (x,_) -> isCompositeType x.ttype
+ | _ -> false
+
+(** START OF deepHasAttribute ************************************************)
+let visited = ref []
+class attribute_checker target rflag = object (self)
+ inherit nopCilVisitor
+ 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
+ rflag := true
+ else
+ ignore(visitCilType (new attribute_checker target rflag)
+ f.ftype)) cinfo.cfields;
+ end;
+ DoChildren
+ | TNamed(t1, a) ->
+ if(not (List.exists (fun x -> t1.tname = x) !visited )) then begin
+ visited := t1.tname :: !visited;
+ ignore(visitCilType (new attribute_checker target rflag) t1.ttype);
+ end;
+ DoChildren
+ | _ ->
+ DoChildren
+ method vattr (Attr(name,params)) =
+ if (name = target) then rflag := true;
+ DoChildren
+end
+
+let deepHasAttribute s t =
+ let found = ref false in
+ visited := [];
+ ignore(visitCilType (new attribute_checker s found) t);
+ !found
+(** END OF deepHasAttribute **************************************************)
+
+(** Stuff from ptranal, slightly modified ************************************)
+
+(*****************************************************************************
+ * A transformation to make every instruction be in its own statement.
+ ****************************************************************************)
+
+class callBBVisitor = object
+ inherit nopCilVisitor
+
+ method vstmt s =
+ match s.skind with
+ Instr(il) -> begin
+ if (List.length il > 1) then
+ let list_of_stmts = List.map (fun one_inst ->
+ mkStmtOneInstr one_inst) il in
+ let block = mkBlock list_of_stmts in
+ s.skind <- Block block;
+ ChangeTo(s)
+ else
+ SkipChildren
+ end
+ | _ -> DoChildren
+
+ 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
+
+(*****************************************************************************
+ * 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
+
+(** End of stuff from ptranal ************************************************)
+
+class sidVisitor = object
+ inherit nopCilVisitor
+ val count = ref 0
+
+ method vstmt s =
+ s.sid <- !count ;
+ incr count ;
+ DoChildren
+end
+
+let globally_unique_sids f =
+ let thisVisitor = new sidVisitor in
+ visitCilFileSameGlobals thisVisitor f
+
+(** Comparing expressions without a Out_of_memory error **********************)
+
+let compare_exp x y =
+ compare x y
+
--- /dev/null
+
+(*
+ * "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 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\n" 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)\n"
+ 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' = isInteger (constFold true size) in
+ if size' = None then E.s (error "Non-constant array size");
+ let size'' = (Int64.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'<len+4);
+ vi.vtype <- TArray(bt, Some (integer len'), a);
+ | _ -> ());
+ 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;
+ ()
+
+
+
+let enableAnn = ref false
+
+(***********************
+ * 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 : featureDescr =
+ { fd_name = "CqualAnn";
+ fd_enabled = enableAnn;
+ 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
+ }
+
--- /dev/null
+
+module IH = Inthash
+module E = Errormsg
+
+open Cil
+open Pretty
+
+(** A framework for data flow analysis for CIL code. Before using
+ this framework, you must initialize the Control-flow Graph for your
+ program, e.g using {!Cfg.computeFileCFG} *)
+
+type 't action =
+ Default (** The default action *)
+ | Done of 't (** Do not do the default action. Use this result *)
+ | Post of ('t -> 't) (** The default action, followed by the given
+ * transformer *)
+
+type 't stmtaction =
+ SDefault (** The default action *)
+ | SDone (** Do not visit this statement or its successors *)
+ | SUse of 't (** Visit the instructions and successors of this statement
+ as usual, but use the specified state instead of the
+ one that was passed to doStmt *)
+
+(* For if statements *)
+type 't guardaction =
+ GDefault (** The default state *)
+ | GUse of 't (** Use this data for the branch *)
+ | GUnreachable (** The branch will never be taken. *)
+
+
+(******************************************************************
+ **********
+ ********** FORWARDS
+ **********
+ ********************************************************************)
+
+module type ForwardsTransfer = sig
+ val name: string (** For debugging purposes, the name of the analysis *)
+
+ val debug: bool ref (** Whether to turn on debugging *)
+
+ type t (** The type of the data we compute for each block start. May be
+ * imperative. *)
+
+ val copy: t -> t
+ (** Make a deep copy of the data *)
+
+
+ val 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
+ * of the analysis this means that the block is not reachable. *)
+
+ 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
+ * 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
+ * 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
+ * continue with the state unchanged. *)
+
+ val doStmt: Cil.stmt -> t -> t stmtaction
+ (** 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
+ * 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".
+ *)
+
+ val filterStmt: Cil.stmt -> bool
+ (** Whether to put this statement in the worklist. This is called when a
+ * block would normally be put in the worklist. *)
+
+end
+
+
+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
+ * 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
+ * state. *)
+ let reachedStatement (s: stmt) (d: T.t) : unit =
+ let loc = get_stmtLoc s.skind in
+ 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"
+ s.sid T.pretty d);
+ let newdata: T.t option =
+ try
+ 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
+ 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"
+ 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"
+ T.name s.sid T.pretty d');
+ Some d'
+ in
+ E.popContext ();
+ match newdata with
+ None -> ()
+ | Some d' ->
+ IH.replace T.stmtStartData s.sid d';
+ if T.filterStmt s &&
+ not (Queue.fold (fun exists s' -> exists || s'.sid = s.sid)
+ false
+ worklist) then
+ Queue.add s worklist
+
+
+ (** Get the two successors of an If statement *)
+ let ifSuccs (s:stmt) : stmt * stmt =
+ let fstStmt blk = match blk.bstmts with
+ [] -> Cil.dummyStmt
+ | fst::_ -> fst
+ in
+ match s.skind with
+ If(e, b1, b2, _) ->
+ let thenSucc = fstStmt b1 in
+ let elseSucc = fstStmt b2 in
+ let oneFallthrough () =
+ let fallthrough =
+ List.filter
+ (fun s' -> thenSucc != s' && elseSucc != s')
+ s.succs
+ in
+ match fallthrough with
+ [] -> E.s (bug "Bad CFG: missing fallthrough for If.")
+ | [s'] -> s'
+ | _ -> E.s (bug "Bad CFG: multiple fallthrough for If.")
+ in
+ (* If thenSucc or elseSucc is Cil.dummyStmt, it's an empty block.
+ So the successor is the statement after the if *)
+ let stmtOrFallthrough s' =
+ if s' == Cil.dummyStmt then
+ oneFallthrough ()
+ else
+ s'
+ in
+ (stmtOrFallthrough thenSucc,
+ stmtOrFallthrough elseSucc)
+
+ | _-> E.s (bug "ifSuccs on a non-If Statement.")
+
+ (** Process a statement *)
+ let processStmt (s: stmt) : unit =
+ currentLoc := get_stmtLoc s.skind;
+ 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 ->
+ E.s (E.bug "FF(%s): processing block without data" T.name)
+ in
+
+ (** See what the custom says *)
+ match T.doStmt s init with
+ SDone -> ()
+ | (SDefault | SUse _) as act -> begin
+ let curr = match act with
+ SDefault -> init
+ | SUse d -> d
+ | SDone -> E.s (bug "SDone")
+ in
+ (* Do the instructions in order *)
+ 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
+ | Done s' -> s'
+ | Default -> s (* do nothing *)
+ | Post f -> f s
+ in
+ s'
+ in
+
+ let after: T.t =
+ match s.skind with
+ Instr il ->
+ (* Handle instructions starting with the first one *)
+ List.fold_left handleInstruction curr il
+
+ | Goto _ | 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
+ let not_e = UnOp(LNot, e, intType) in
+ let thenGuard = T.doGuard e after in
+ let elseGuard = T.doGuard not_e after in
+ if thenGuard = GDefault && elseGuard = GDefault then
+ (* this is the common case *)
+ s.succs
+ else begin
+ let doBranch succ guard =
+ 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"
+ T.name succ.sid);
+
+ ()
+ in
+ let thenSucc, elseSucc = ifSuccs s in
+ doBranch thenSucc thenGuard;
+ doBranch elseSucc elseGuard;
+ []
+ end
+ end
+ | _ -> s.succs
+ in
+ (* Reach the successors *)
+ List.iter (fun s' -> reachedStatement s' after) succsToReach;
+
+ end
+
+
+
+
+ (** Compute the data flow. Must have the CFG initialized *)
+ let compute (sources: stmt list) =
+ Queue.clear worklist;
+ List.iter (fun s -> Queue.add s worklist) sources;
+
+ (** All initial stmts must have non-bottom data *)
+ List.iter (fun s ->
+ if not (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
+ (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
+ processStmt s;
+ true
+ with Queue.Empty ->
+ if !T.debug then
+ ignore (E.log "FF(%s): done\n\n" T.name);
+ false
+ in
+ if keepgoing then
+ fixedpoint ()
+ in
+ fixedpoint ()
+
+ end
+
+
+
+(******************************************************************
+ **********
+ ********** BACKWARDS
+ **********
+ ********************************************************************)
+module type BackwardsTransfer = sig
+ val name: string (* For debugging purposes, the name of the analysis *)
+
+ val debug: bool ref (** Whether to turn on debugging *)
+
+ type t (** The type of the data we compute for each block start. In many
+ * presentations of backwards data flow analysis we maintain the
+ * data at the block end. This is not easy to do with JVML because
+ * a block has many exceptional ends. So we maintain the data for
+ * the statement start. *)
+
+ val pretty: 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
+ * 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
+ 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
+ * list. *)
+
+
+ val combineSuccessors: t -> t -> t
+ (** Take the data from two successors and combine it *)
+
+
+ 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
+ * (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
+ * 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
+ * changed) *)
+
+end
+
+module BackwardsDataFlow =
+ functor (T : BackwardsTransfer) ->
+ struct
+
+ let getStmtStartData (s: stmt) : T.t =
+ try IH.find T.stmtStartData s.sid
+ 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
+ * addresses on its entry has changed. *)
+ 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
+ Done d -> d
+ | (Default | Post _) as action -> begin
+ (* Do the default one. Combine the successors *)
+ let res =
+ match s.succs with
+ [] -> T.funcExitData
+ | fst :: rest ->
+ List.fold_left (fun acc succ ->
+ T.combineSuccessors acc (getStmtStartData succ))
+ (getStmtStartData fst)
+ rest
+ in
+ (* Now do the instructions *)
+ let res' =
+ match s.skind with
+ Instr il ->
+ (* Now scan the instructions in reverse order. This may
+ * Stack_overflow on very long blocks ! *)
+ let handleInstruction (i: instr) (s: T.t) : T.t =
+ currentLoc := get_instrLoc i;
+ (* First handle the instruction itself *)
+ let action = T.doInstr i s in
+ match action with
+ | Done s' -> s'
+ | Default -> s (* do nothing *)
+ | Post f -> f s
+ in
+ (* Handle instructions starting with the last one *)
+ List.fold_right handleInstruction il res
+
+ | _ -> res
+ in
+ match action with
+ Post f -> f res'
+ | _ -> res'
+ end
+ in
+
+ (* See if the state has changed. The only changes are that it may grow.*)
+ let s0 = getStmtStartData s in
+
+ match T.combineStmtStartData s ~old:s0 d with
+ None -> (* The old data is good enough *)
+ false
+
+ | Some d' ->
+ (* We have changed the data *)
+ if !T.debug then
+ 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 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"
+ T.name
+ (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
+ if changes then begin
+ (* We must add all predecessors of block b, only if not already
+ * in and if the filter accepts them. *)
+ List.iter
+ (fun p ->
+ if not (Queue.fold (fun exists s' -> exists || p.sid = s'.sid)
+ false worklist) &&
+ T.filterStmt p s then
+ Queue.add p worklist)
+ s.preds;
+ end;
+ true
+
+ with Queue.Empty ->
+ if !T.debug then
+ ignore (E.log "BF(%s): done\n\n" T.name);
+ false
+ in
+ if keepgoing then
+ fixedpoint ();
+ in
+ fixedpoint ();
+
+ end
+
+
+(** Helper utility that finds all of the statements of a function.
+ It also lists the return statments (including statements that
+ fall through the end of a void function). Useful when you need an
+ initial set of statements for BackwardsDataFlow.compute. *)
+let sink_stmts = ref []
+let all_stmts = ref []
+let sinkFinder = object(self)
+ inherit nopCilVisitor
+
+ method vstmt s =
+ all_stmts := s ::(!all_stmts);
+ match s.succs with
+ [] -> (sink_stmts := s :: (!sink_stmts);
+ DoChildren)
+ | _ -> DoChildren
+
+end
+
+(* returns (all_stmts, return_stmts). *)
+let find_stmts (fdec:fundec) : (stmt list * stmt list) =
+ ignore(visitCilFunction (sinkFinder) fdec);
+ let all = !all_stmts in
+ let ret = !sink_stmts in
+ all_stmts := [];
+ sink_stmts := [];
+ all, ret
+
--- /dev/null
+(** A framework for data flow analysis for CIL code. Before using
+ this framework, you must initialize the Control-flow Graph for your
+ program, e.g using {!Cfg.computeFileCFG} *)
+
+type 't action =
+ Default (** The default action *)
+ | Done of 't (** Do not do the default action. Use this result *)
+ | Post of ('t -> 't) (** The default action, followed by the given
+ * transformer *)
+
+type 't stmtaction =
+ SDefault (** The default action *)
+ | SDone (** Do not visit this statement or its successors *)
+ | SUse of 't (** Visit the instructions and successors of this statement
+ as usual, but use the specified state instead of the
+ one that was passed to doStmt *)
+
+(* For if statements *)
+type 't guardaction =
+ GDefault (** The default state *)
+ | GUse of 't (** Use this data for the branch *)
+ | GUnreachable (** The branch will never be taken. *)
+
+
+(******************************************************************
+ **********
+ ********** FORWARDS
+ **********
+ ********************************************************************)
+
+module type ForwardsTransfer = sig
+ val name: string (** For debugging purposes, the name of the analysis *)
+
+ val debug: bool ref (** Whether to turn on debugging *)
+
+ type t (** The type of the data we compute for each block start. May be
+ * imperative. *)
+
+ val copy: t -> t
+ (** Make a deep copy of the data *)
+
+
+ val 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
+ * of the analysis this means that the block is not reachable. *)
+
+ 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
+ * 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
+ * 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
+ * continue with the state unchanged. *)
+
+ val doStmt: Cil.stmt -> t -> t stmtaction
+ (** 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
+ * 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".
+ *)
+
+ val filterStmt: Cil.stmt -> bool
+ (** Whether to put this statement in the worklist. This is called when a
+ * block would normally be put in the worklist. *)
+
+end
+
+module ForwardsDataFlow (T : ForwardsTransfer) : sig
+ val compute: Cil.stmt list -> unit
+ (** Fill in the T.stmtStartData, given a number of initial statements to
+ * start from. All of the initial statements must have some entry in
+ * T.stmtStartData (i.e., the initial data should not be bottom) *)
+end
+
+(******************************************************************
+ **********
+ ********** BACKWARDS
+ **********
+ ********************************************************************)
+module type BackwardsTransfer = sig
+ val name: string (** For debugging purposes, the name of the analysis *)
+
+ val debug: bool ref (** Whether to turn on debugging *)
+
+ type t (** The type of the data we compute for each block start. In many
+ * presentations of backwards data flow analysis we maintain the
+ * data at the block end. This is not easy to do with JVML because
+ * a block has many exceptional ends. So we maintain the data for
+ * the statement start. *)
+
+ val pretty: 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
+ * 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
+ 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
+ * list. *)
+
+
+ val combineSuccessors: t -> t -> t
+ (** Take the data from two successors and combine it *)
+
+
+ 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
+ * (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
+ * 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
+ * changed) *)
+
+end
+
+module BackwardsDataFlow (T : BackwardsTransfer) : sig
+ val compute: Cil.stmt list -> unit
+ (** Fill in the T.stmtStartData, given a number of initial statements to
+ * start from (the sinks for the backwards data flow). All of the statements
+ * (not just the initial ones!) must have some entry in T.stmtStartData
+ * If you want to use bottom for the initial data, you should pass the
+ * complete list of statements to {!compute}, so that everything is visited.
+ * {!find_stmts} may be useful here. *)
+end
+
+
+(** Returns (all_stmts, sink_stmts), where all_stmts is a list of the
+ statements in a function, and sink_stmts is a list of the return statments
+ (including statements that fall through the end of a void function).
+ Useful when you need an initial set of statements for
+ BackwardsDataFlow.compute. *)
+val find_stmts: Cil.fundec -> (Cil.stmt list * Cil.stmt list)
--- /dev/null
+(*
+ *
+ * Copyright (c) 2004,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 Pretty
+module E = Errormsg
+
+let debug = false
+
+let numRegions : int = 2
+
+let newGlobals : global list ref = ref []
+
+let curFundec : fundec ref = ref dummyFunDec
+let curLocation : location ref = ref locUnknown
+
+let applyOption (fn : 'a -> 'b) (ao : 'a option) : 'b option =
+ match ao with
+ | Some a -> Some (fn a)
+ | None -> None
+
+let getRegion (attrs : attributes) : int =
+ try
+ match List.hd (filterAttributes "region" attrs) with
+ | Attr (_, [AInt i]) -> i
+ | _ -> E.s (bug "bad region attribute")
+ with Failure _ ->
+ 1
+
+let checkRegion (i : int) (attrs : attributes) : bool =
+ (getRegion attrs) = i
+
+let regionField (i : int) : string =
+ "r" ^ (string_of_int i)
+
+let regionStruct (i : int) (name : string) : string =
+ name ^ "_r" ^ (string_of_int i)
+
+let foldRegions (fn : int -> 'a -> 'a) (base : 'a) : 'a =
+ let rec helper (i : int) : 'a =
+ if i <= numRegions then
+ fn i (helper (i + 1))
+ else
+ base
+ in
+ helper 1
+
+let rec getTypeName (t : typ) : string =
+ match t with
+ | TVoid _ -> "void"
+ | TInt _ -> "int"
+ | TFloat _ -> "float"
+ | TComp (cinfo, _) -> "comp_" ^ cinfo.cname
+ | TNamed (tinfo, _) -> "td_" ^ tinfo.tname
+ | TPtr (bt, _) -> "ptr_" ^ (getTypeName bt)
+ | TArray (bt, _, _) -> "array_" ^ (getTypeName bt)
+ | TFun _ -> "fn"
+ | _ -> E.s (unimp "typename")
+
+let isAllocFunction (fn : exp) : bool =
+ match fn with
+ | Lval (Var vinfo, NoOffset) when vinfo.vname = "malloc" -> true
+ | _ -> false
+
+let isExternalFunction (fn : exp) : bool =
+ match fn with
+ | Lval (Var vinfo, NoOffset) when vinfo.vstorage = Extern -> true
+ | _ -> false
+
+let types : (int * typsig, typ) Hashtbl.t = Hashtbl.create 113
+let typeInfos : (int * string, typeinfo) Hashtbl.t = Hashtbl.create 113
+let compInfos : (int * int, compinfo) Hashtbl.t = Hashtbl.create 113
+let varTypes : (typsig, typ) Hashtbl.t = Hashtbl.create 113
+let varCompInfos : (typsig, compinfo) Hashtbl.t = Hashtbl.create 113
+
+let rec sliceCompInfo (i : int) (cinfo : compinfo) : compinfo =
+ try
+ Hashtbl.find compInfos (i, cinfo.ckey)
+ with Not_found ->
+ mkCompInfo cinfo.cstruct (regionStruct i cinfo.cname)
+ (fun cinfo' ->
+ Hashtbl.add compInfos (i, cinfo.ckey) cinfo';
+ List.fold_right
+ (fun finfo rest ->
+ let t = sliceType i finfo.ftype in
+ if not (isVoidType t) then
+ (finfo.fname, t, finfo.fbitfield,
+ finfo.fattr, finfo.floc) :: rest
+ else
+ rest)
+ cinfo.cfields [])
+ cinfo.cattr
+
+and sliceTypeInfo (i : int) (tinfo : typeinfo) : typeinfo =
+ try
+ Hashtbl.find typeInfos (i, tinfo.tname)
+ with Not_found ->
+ let result =
+ { tinfo with tname = regionStruct i tinfo.tname;
+ ttype = sliceType i tinfo.ttype; }
+ in
+ Hashtbl.add typeInfos (i, tinfo.tname) result;
+ result
+
+and sliceType (i : int) (t : typ) : typ =
+ let ts = typeSig t in
+ try
+ Hashtbl.find types (i, ts)
+ with Not_found ->
+ let result =
+ match t with
+ | TVoid _ -> t
+ | TInt (_, attrs) -> if checkRegion i attrs then t else TVoid []
+ | TFloat (_, attrs) -> if checkRegion i attrs then t else TVoid []
+ | TComp (cinfo, attrs) -> TComp (sliceCompInfo i cinfo, attrs)
+ | TNamed (tinfo, attrs) -> TNamed (sliceTypeInfo i tinfo, attrs)
+ | TPtr (TVoid _, _) -> t (* Avoid discarding void*. *)
+ | TPtr (bt, attrs) ->
+ let bt' = sliceType i bt in
+ if not (isVoidType bt') then TPtr (bt', attrs) else TVoid []
+ | TArray (bt, eo, attrs) ->
+ TArray (sliceType i bt, applyOption (sliceExp 1) eo, attrs)
+ | TFun (ret, args, va, attrs) ->
+ if checkRegion i attrs then
+ TFun (sliceTypeAll ret,
+ applyOption
+ (List.map (fun (aname, atype, aattrs) ->
+ (aname, sliceTypeAll atype, aattrs)))
+ args,
+ va, attrs)
+ else
+ TVoid []
+ | TBuiltin_va_list _ -> t
+ | _ -> E.s (unimp "type %a" d_type t)
+ in
+ Hashtbl.add types (i, ts) result;
+ result
+
+and sliceTypeAll (t : typ) : typ =
+ begin
+ match t with
+ | TComp (cinfo, _) when hasAttribute "var_type_sliced" cinfo.cattr ->
+ E.s (bug "tried to slice twice")
+ | _ -> ()
+ end;
+ let ts = typeSig t in
+ try
+ Hashtbl.find varTypes ts
+ with Not_found ->
+ let cinfo =
+ let name = ("var_" ^ (getTypeName t)) in
+ if debug then ignore (E.log "creating %s\n" name);
+ try
+ Hashtbl.find varCompInfos ts
+ with Not_found ->
+ mkCompInfo true name
+ (fun cinfo ->
+ Hashtbl.add varCompInfos ts cinfo;
+ foldRegions
+ (fun i rest ->
+ let t' = sliceType i t in
+ if not (isVoidType t') then
+ (regionField i, t', None, [], !curLocation) :: rest
+ else
+ rest)
+ [])
+ [Attr ("var_type_sliced", [])]
+ in
+ let t' =
+ if List.length cinfo.cfields > 1 then
+ begin
+ newGlobals := GCompTag (cinfo, !curLocation) :: !newGlobals;
+ TComp (cinfo, [])
+ end
+ else
+ t
+ in
+ Hashtbl.add varTypes ts t';
+ t'
+
+and sliceLval (i : int) (lv : lval) : lval =
+ if debug then ignore (E.log "lval %a\n" d_lval lv);
+ let lh, offset = lv in
+ match lh with
+ | Var vinfo ->
+ let t = sliceTypeAll vinfo.vtype in
+ let offset' =
+ match t with
+ | TComp (cinfo, _) when hasAttribute "var_type_sliced" cinfo.cattr ->
+ Field (getCompField cinfo (regionField i), offset)
+ | _ -> offset
+ in
+ Var vinfo, offset'
+ | Mem e ->
+ Mem (sliceExp i e), offset
+
+and sliceExp (i : int) (e : exp) : exp =
+ if debug then ignore (E.log "exp %a\n" d_exp e);
+ match e with
+ | Const c -> Const c
+ | Lval lv -> Lval (sliceLval i lv)
+ | UnOp (op, e1, t) -> UnOp (op, sliceExp i e1, sliceType i t)
+ | BinOp (op, e1, e2, t) -> BinOp (op, sliceExp i e1, sliceExp i e2,
+ sliceType i t)
+ | CastE (t, e) -> sliceCast i t e
+ | AddrOf lv -> AddrOf (sliceLval i lv)
+ | StartOf lv -> StartOf (sliceLval i lv)
+ | SizeOf t -> SizeOf (sliceTypeAll t)
+ | _ -> E.s (unimp "exp %a" d_exp e)
+
+and sliceCast (i : int) (t : typ) (e : exp) : exp =
+ let te = typeOf e in
+ match t, te with
+ | TInt (k1, _), TInt (k2, attrs2) when k1 = k2 ->
+ (* Note: We strip off integer cast operations. *)
+ sliceExp (getRegion attrs2) e
+ | TInt (k1, _), TPtr _ ->
+ (* Note: We strip off integer cast operations. *)
+ sliceExp i e
+ | TPtr _, _ when isZero e ->
+ CastE (sliceType i t, sliceExp i e)
+ | TPtr (bt1, _), TPtr (bt2, _) when (typeSig bt1) = (typeSig bt2) ->
+ CastE (sliceType i t, sliceExp i e)
+ | _ ->
+ E.s (unimp "sketchy cast (%a) -> (%a)\n" d_type te d_type t)
+
+and sliceExpAll (e : exp) (l : location) : instr list * exp =
+ let t = typeOf e in
+ let t' = sliceTypeAll t in
+ match t' with
+ | TComp (cinfo, _) when hasAttribute "var_type_sliced" cinfo.cattr ->
+ let vinfo = makeTempVar !curFundec t in
+ let instrs =
+ foldRegions
+ (fun i rest ->
+ try
+ let finfo = getCompField cinfo (regionField i) in
+ if not (isVoidType finfo.ftype) then
+ Set ((Var vinfo, Field (finfo, NoOffset)),
+ sliceExp i e, l) :: rest
+ else
+ rest
+ with Not_found ->
+ rest)
+ []
+ in
+ instrs, Lval (var vinfo)
+ | _ -> [], sliceExp 1 e
+
+let sliceVar (vinfo : varinfo) : unit =
+ if hasAttribute "var_sliced" vinfo.vattr then
+ E.s (bug "tried to slice a var twice");
+ let t = sliceTypeAll vinfo.vtype in
+ if debug then ignore (E.log "setting %s type to %a\n" vinfo.vname d_type t);
+ vinfo.vattr <- addAttribute (Attr ("var_sliced", [])) vinfo.vattr;
+ vinfo.vtype <- t
+
+let sliceInstr (inst : instr) : instr list =
+ match inst with
+ | Set (lv, e, loc) ->
+ if debug then ignore (E.log "set %a %a\n" d_lval lv d_exp e);
+ let t = typeOfLval lv in
+ foldRegions
+ (fun i rest ->
+ if not (isVoidType (sliceType i t)) then
+ Set (sliceLval i lv, sliceExp i e, loc) :: rest
+ else
+ rest)
+ []
+ | Call (ret, fn, args, l) when isAllocFunction fn ->
+ let lv =
+ match ret with
+ | Some lv -> lv
+ | None -> E.s (bug "malloc call has no return lval")
+ in
+ let t = typeOfLval lv in
+ foldRegions
+ (fun i rest ->
+ if not (isVoidType (sliceType i t)) then
+ Call (Some (sliceLval i lv), sliceExp 1 fn,
+ List.map (sliceExp i) args, l) :: rest
+ else
+ rest)
+ []
+ | Call (ret, fn, args, l) when isExternalFunction fn ->
+ [Call (applyOption (sliceLval 1) ret, sliceExp 1 fn,
+ List.map (sliceExp 1) args, l)]
+ | Call (ret, fn, args, l) ->
+ let ret', set =
+ match ret with
+ | Some lv ->
+ let vinfo = makeTempVar !curFundec (typeOfLval lv) in
+ Some (var vinfo), [Set (lv, Lval (var vinfo), l)]
+ | None ->
+ None, []
+ in
+ let instrs, args' =
+ List.fold_right
+ (fun arg (restInstrs, restArgs) ->
+ let instrs, arg' = sliceExpAll arg l in
+ instrs @ restInstrs, (arg' :: restArgs))
+ args ([], [])
+ in
+ instrs @ (Call (ret', sliceExp 1 fn, args', l) :: set)
+ | _ -> E.s (unimp "inst %a" d_instr inst)
+
+let sliceReturnExp (eo : exp option) (l : location) : stmtkind =
+ match eo with
+ | Some e ->
+ begin
+ match sliceExpAll e l with
+ | [], e' -> Return (Some e', l)
+ | instrs, e' -> Block (mkBlock [mkStmt (Instr instrs);
+ mkStmt (Return (Some e', l))])
+ end
+ | None -> Return (None, l)
+
+let rec sliceStmtKind (sk : stmtkind) : stmtkind =
+ match sk with
+ | Instr instrs -> Instr (List.flatten (List.map sliceInstr instrs))
+ | Block b -> Block (sliceBlock b)
+ | If (e, b1, b2, l) -> If (sliceExp 1 e, sliceBlock b1, sliceBlock b2, l)
+ | Break l -> Break l
+ | Continue l -> Continue l
+ | Return (eo, l) -> sliceReturnExp eo l
+ | Switch (e, b, sl, l) -> Switch (sliceExp 1 e, sliceBlock b,
+ List.map sliceStmt sl, l)
+ | Loop (b, l, so1, so2) -> Loop (sliceBlock b, l,
+ applyOption sliceStmt so1,
+ applyOption sliceStmt so2)
+ | Goto _ -> sk
+ | _ -> E.s (unimp "statement")
+
+and sliceStmt (s : stmt) : stmt =
+ (* Note: We update statements destructively so that goto/switch work. *)
+ s.skind <- sliceStmtKind s.skind;
+ s
+
+and sliceBlock (b : block) : block =
+ ignore (List.map sliceStmt b.bstmts);
+ b
+
+let sliceFundec (fd : fundec) (l : location) : unit =
+ curFundec := fd;
+ curLocation := l;
+ ignore (sliceBlock fd.sbody);
+ curFundec := dummyFunDec;
+ curLocation := locUnknown
+
+let sliceGlobal (g : global) : unit =
+ match g with
+ | GType (tinfo, l) ->
+ newGlobals :=
+ foldRegions (fun i rest -> GType (sliceTypeInfo i tinfo, l) :: rest)
+ !newGlobals
+ | GCompTag (cinfo, l) ->
+ newGlobals :=
+ foldRegions (fun i rest -> GCompTag (sliceCompInfo i cinfo, l) :: rest)
+ !newGlobals
+ | GCompTagDecl (cinfo, l) ->
+ newGlobals :=
+ foldRegions (fun i rest -> GCompTagDecl (sliceCompInfo i cinfo, l) ::
+ rest)
+ !newGlobals
+ | GFun (fd, l) ->
+ sliceFundec fd l;
+ newGlobals := GFun (fd, l) :: !newGlobals
+ | GVarDecl _
+ | GVar _ ->
+ (* Defer processing of vars until end. *)
+ newGlobals := g :: !newGlobals
+ | _ ->
+ E.s (unimp "global %a\n" d_global g)
+
+let sliceGlobalVars (g : global) : unit =
+ match g with
+ | GFun (fd, l) ->
+ curFundec := fd;
+ curLocation := l;
+ List.iter sliceVar fd.slocals;
+ List.iter sliceVar fd.sformals;
+ setFunctionType fd (sliceType 1 fd.svar.vtype);
+ curFundec := dummyFunDec;
+ curLocation := locUnknown;
+ | GVar (vinfo, _, l) ->
+ curLocation := l;
+ sliceVar vinfo;
+ curLocation := locUnknown
+ | _ -> ()
+
+class dropAttrsVisitor = object
+ inherit nopCilVisitor
+
+ method vvrbl (vinfo : varinfo) =
+ vinfo.vattr <- dropAttribute "var_sliced" vinfo.vattr;
+ DoChildren
+
+ method vglob (g : global) =
+ begin
+ match g with
+ | GCompTag (cinfo, _) ->
+ cinfo.cattr <- dropAttribute "var_type_sliced" cinfo.cattr;
+ | _ -> ()
+ end;
+ DoChildren
+end
+
+let sliceFile (f : file) : unit =
+ newGlobals := [];
+ List.iter sliceGlobal f.globals;
+ List.iter sliceGlobalVars f.globals;
+ f.globals <- List.rev !newGlobals;
+ visitCilFile (new dropAttrsVisitor) f
+
+let feature : featureDescr =
+ { fd_name = "DataSlicing";
+ fd_enabled = ref false;
+ fd_description = "data slicing";
+ fd_extraopt = [];
+ fd_doit = sliceFile;
+ fd_post_check = true;
+ }
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 feature implements data slicing. The user annotates base types
+ * and function types with region(i) annotations, and this transformation
+ * will separate the fields into parallel data structures accordingly. *)
+
+val feature: Cil.featureDescr
--- /dev/null
+(* Eliminate assignment instructions whose results are not
+ used *)
+
+open Cil
+open Pretty
+open Expcompare
+
+module E = Errormsg
+module RD = Reachingdefs
+module UD = Usedef
+module IH = Inthash
+module S = Stats
+
+module IS = Set.Make(
+ struct
+ type t = int
+ let compare = compare
+ end)
+
+let debug = RD.debug
+
+
+let doTime = ref false
+
+let time s f a =
+ if !doTime then
+ S.time s f a
+ else f a
+
+(* This function should be set by the client if it
+ * knows of functions returning a result that have
+ * no side effects. If the result is not used, then
+ * the call will be eliminated. *)
+let callHasNoSideEffects : (instr -> bool) ref =
+ ref (fun _ -> false)
+
+
+(* the set of used definition ids *)
+let usedDefsSet = ref IS.empty
+
+(* a mapping d -> {u_1,...,u_n} where d is a
+ * definition id, and the u's are definition
+ * ids corresponding to definitions in which
+ * d was used *)
+let defUseSetHash = IH.create 100
+
+(* a mapping d -> {sid_1,...,sid_n} where d is
+ * a definition id and the sids are statement ids
+ * corresponding to non-Instr statements where d
+ * was used *)
+let sidUseSetHash = IH.create 100
+
+(* put used def ids into usedDefsSet *)
+(* assumes reaching definitions have already been computed *)
+class usedDefsCollectorClass = object(self)
+ inherit RD.rdVisitorClass as super
+
+ method add_defids iosh e u =
+ UD.VS.iter (fun vi ->
+ if IH.mem iosh vi.vid then
+ let ios = IH.find iosh vi.vid in
+ if !debug then 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) ->
+ 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 =
+ let u = UD.computeUseExp e in
+ match self#get_cur_iosh() with
+ Some(iosh) -> self#add_defids iosh e u; DoChildren
+ | None ->
+ if !debug then ignore(E.log "DCE: use but no rd data: %a\n" d_plainexp e);
+ DoChildren
+
+ method vstmt s =
+ ignore(super#vstmt s);
+ match s.skind with
+ | Instr _ -> DoChildren
+ | _ -> begin
+ let u,d = UD.computeUseDefStmtKind s.skind in
+ match self#get_cur_iosh() with
+ | Some iosh ->
+ UD.VS.iter (fun vi ->
+ if IH.mem iosh vi.vid then
+ let ios = IH.find iosh vi.vid in
+ RD.IOS.iter (function
+ | Some i -> begin (* add s.sid to set for i *)
+ try
+ let set = IH.find sidUseSetHash i in
+ IH.replace sidUseSetHash i (IS.add s.sid set)
+ with Not_found ->
+ IH.add sidUseSetHash i (IS.singleton s.sid)
+ end
+ | None -> ()) ios) u;
+ DoChildren
+ | None -> DoChildren
+ end
+
+ method vinst i =
+ let handle_inst iosh i = match i with
+ | Asm(_,_,slvl,_,_,_) -> List.iter (fun (_,s,lv) ->
+ match lv with (Var v, off) ->
+ if s.[0] = '+' then
+ self#add_defids iosh (Lval(Var v, off)) (UD.VS.singleton v)
+ | _ -> ()) slvl
+ | Call(_,ce,el,_) when not (!callHasNoSideEffects i) ->
+ List.iter (fun e ->
+ let u = UD.computeUseExp e in
+ UD.VS.iter (fun vi ->
+ if IH.mem iosh vi.vid then
+ let ios = IH.find iosh vi.vid in
+ RD.IOS.iter (function
+ | Some i -> begin (* add sid to set for i *)
+ try
+ let set = IH.find sidUseSetHash i in
+ IH.replace sidUseSetHash i (IS.add sid set)
+ with Not_found ->
+ IH.add sidUseSetHash i (IS.singleton sid)
+ end
+ | None -> ()) ios) u) (ce::el)
+ | Set((Mem _,_) as lh, rhs,l) ->
+ List.iter (fun e ->
+ let u = UD.computeUseExp e in
+ UD.VS.iter (fun vi ->
+ if IH.mem iosh vi.vid then
+ let ios = IH.find iosh vi.vid in
+ RD.IOS.iter (function
+ | Some i -> begin (* add sid to set for i *)
+ try
+ let set = IH.find sidUseSetHash i in
+ IH.replace sidUseSetHash i (IS.add sid set)
+ with Not_found ->
+ 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
+ if !debug then ignore(E.log "DCE: instr with no cur_rd_dat\n");
+ (* handle_inst *)
+ DoChildren
+ end
+ | Some(_,s,iosh) -> begin
+ let u,d = UD.computeUseDefInstr i in
+ (* add things in d to the U sets for things in u *)
+ let rec loop n =
+ if n < 0 then () else begin
+ UD.VS.iter (fun vi ->
+ if IH.mem iosh vi.vid then
+ let ios = IH.find iosh vi.vid in
+ RD.IOS.iter (function
+ | Some i -> begin (* add n + s to set for i *)
+ try
+ let set = IH.find defUseSetHash i in
+ IH.replace defUseSetHash i (IS.add (n+s) set)
+ with Not_found ->
+ IH.add defUseSetHash i (IS.singleton (n+s))
+ end
+ | None -> ()) ios
+ else ()) u;
+ loop (n-1)
+ end
+ in
+ loop (UD.VS.cardinal d - 1);
+ handle_inst iosh i;
+ DoChildren
+ end
+
+end
+
+(***************************************************
+ * 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
+ ***************************************************)
+class hasVolatile flag = object (self)
+ inherit nopCilVisitor
+ method vlval l =
+ let tp = typeOfLval l in
+ if (Ciltools.is_volatile_tp tp) then flag := true;
+ DoChildren
+ method vexpr e =
+ DoChildren
+end
+
+let exp_has_volatile e =
+ let flag = ref false in
+ ignore (visitCilExpr (new hasVolatile flag) e);
+ !flag
+
+let el_has_volatile =
+ List.fold_left (fun b e ->
+ b || (exp_has_volatile e)) false
+ (***************************************************)
+
+(*
+let rec compareExp (e1: exp) (e2: exp) : bool =
+(* log "CompareExp %a and %a.\n" d_plainexp e1 d_plainexp e2; *)
+ e1 == e2 ||
+ match e1, e2 with
+ | Lval lv1, Lval lv2
+ | StartOf lv1, StartOf lv2
+ | AddrOf lv1, AddrOf lv2 -> compareLval lv1 lv2
+ | BinOp(bop1, l1, r1, _), BinOp(bop2, l2, r2, _) ->
+ bop1 = bop2 && compareExp l1 l2 && compareExp r1 r2
+ | _ -> begin
+ match isInteger (constFold true e1), isInteger (constFold true e2) with
+ Some i1, Some i2 -> i1 = i2
+ | _ -> false
+ end
+
+and compareLval (lv1: lval) (lv2: lval) : bool =
+ let rec compareOffset (off1: offset) (off2: offset) : bool =
+ match off1, off2 with
+ | Field (fld1, off1'), Field (fld2, off2') ->
+ fld1 == fld2 && compareOffset off1' off2'
+ | Index (e1, off1'), Index (e2, off2') ->
+ compareExp e1 e2 && compareOffset off1' off2'
+ | NoOffset, NoOffset -> true
+ | _ -> false
+ in
+ lv1 == lv2 ||
+ match lv1, lv2 with
+ | (Var vi1, off1), (Var vi2, off2) ->
+ vi1 == vi2 && compareOffset off1 off2
+ | (Mem e1, off1), (Mem e2, off2) ->
+ compareExp e1 e2 && compareOffset off1 off2
+ | _ -> false
+
+let rec stripNopCasts (e:exp): exp =
+ match e with
+ CastE(t, e') -> begin
+ match unrollType (typeOf e'), unrollType t with
+ TPtr _, TPtr _ -> (* okay to strip *)
+ stripNopCasts e'
+ (* strip casts from pointers to unsigned int/long*)
+ | (TPtr _ as t1), (TInt(ik,_) as t2)
+ when bitsSizeOf t1 = bitsSizeOf t2
+ && not (isSigned ik) ->
+ stripNopCasts e'
+ | (TInt _ as t1), (TInt _ as t2)
+ when bitsSizeOf t1 = bitsSizeOf t2 -> (* Okay to strip.*)
+ stripNopCasts e'
+ | _ -> e
+ end
+ | _ -> e
+
+let compareExpStripCasts (e1: exp) (e2: exp) : bool =
+ compareExp (stripNopCasts e1) (stripNopCasts e2)
+*)
+
+let removedCount = ref 0
+(* Filter out instructions whose definition ids are not
+ in usedDefsSet *)
+class uselessInstrElim : cilVisitor = object(self)
+ inherit nopCilVisitor
+
+ method vstmt stm =
+
+ (* give a set of varinfos and an iosh and get
+ * the set of definition ids definining the vars *)
+ let viSetToDefIdSet iosh vis =
+ UD.VS.fold (fun vi s ->
+ if IH.mem iosh vi.vid then
+ let ios = IH.find iosh vi.vid in
+ RD.IOS.fold (fun io s ->
+ match io with None -> s
+ | Some i -> IS.add i s) ios s
+ else s) vis IS.empty
+ in
+
+ (* false when U(defid)\subeq instruses and SU(d) = empty *)
+ let check_defid i instruses iosh defid =
+ IS.mem defid (!usedDefsSet) &&
+ try
+ let defuses = IH.find defUseSetHash defid in
+ (*let siduses = IH.find sidUseSetHash defid in*)
+ if IH.mem sidUseSetHash defid then begin
+ if !debug then ignore(E.log "siduses not empty: %a\n" d_instr i);
+ true
+ end else begin
+ (* true if there is something in defuses not in instruses or when
+ * something from defuses is in instruses and is also used somewhere else *)
+ if UD.VS.exists (fun vi -> vi.vglob) instruses then true else
+ let instruses = viSetToDefIdSet iosh instruses in
+ 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
+ end else
+ (* can only use the definition i' at the definition defid *)
+ let i'_uses = IH.find defUseSetHash i' in
+ IH.mem sidUseSetHash i' ||
+ if not(IS.equal i'_uses (IS.singleton defid)) then begin
+ IS.iter (fun iu -> match RD.getSimpRhs iu with
+ | Some(RD.RDExp e) ->
+ if !debug then 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"
+ (IS.cardinal i'_uses) d_instr i)
+ | None -> ()) i'_uses;
+ true
+ end else b) defuses false
+ end
+ with Not_found -> true
+ in
+
+ let test (i,(_,s,iosh)) =
+ match i with
+ | Call(Some(Var vi,NoOffset),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);
+ true
+ end else begin
+ if !debug then ignore(E.log "found call w/o side effects: %a\n" d_instr i);
+ (vi.vglob || (Ciltools.is_volatile_vi vi) || (el_has_volatile el) ||
+ let uses, defd = UD.computeUseDefInstr i in
+ let rec loop n =
+ n >= 0 &&
+ (check_defid i uses iosh (n+s) || loop (n-1))
+ in
+ loop (UD.VS.cardinal defd - 1) || (incr removedCount; false))
+ end
+ | Call _ -> true
+ | Set(lh,e,_) when compareExpStripCasts (Lval lh) e -> false (* filter x = x *)
+ | Set((Var vi,NoOffset),e,_) ->
+ vi.vglob || (Ciltools.is_volatile_vi vi) || (exp_has_volatile e) ||
+ let uses, defd = UD.computeUseDefInstr i in
+ let rec loop n =
+ n >= 0 &&
+ (check_defid i uses iosh (n+s) || loop (n-1))
+ in
+ loop (UD.VS.cardinal defd - 1) || (incr removedCount; false)
+ | _ -> true
+ in
+
+ let filter il stmdat =
+ let rd_dat_lst = RD.instrRDs il stm.sid stmdat false in
+ let ildatlst = List.combine il rd_dat_lst in
+ let ildatlst' = List.filter test ildatlst in
+ let (newil,_) = List.split ildatlst' in
+ newil
+ in
+
+ match RD.getRDs stm.sid with
+ None -> DoChildren
+ | Some(_,s,iosh) ->
+ match stm.skind with
+ Instr il ->
+ stm.skind <- Instr(filter il ((),s,iosh));
+ SkipChildren
+ | _ -> DoChildren
+
+end
+
+(* until fixed point is reached *)
+let elim_dead_code_fp (fd : fundec) : fundec =
+ (* fundec -> fundec *)
+ let rec loop fd =
+ usedDefsSet := IS.empty;
+ IH.clear defUseSetHash;
+ IH.clear sidUseSetHash;
+ removedCount := 0;
+ time "reaching definitions" RD.computeRDs fd;
+ ignore(time "ud-collector"
+ (visitCilFunction (new usedDefsCollectorClass :> cilVisitor)) fd);
+ let fd' = time "useless-elim" (visitCilFunction (new uselessInstrElim)) fd in
+ if !removedCount = 0 then fd' else loop fd'
+ in
+ loop fd
+
+(* just once *)
+let elim_dead_code (fd : fundec) : fundec =
+ (* fundec -> fundec *)
+ usedDefsSet := IS.empty;
+ IH.clear defUseSetHash;
+ IH.clear sidUseSetHash;
+ removedCount := 0;
+ time "reaching definitions" RD.computeRDs fd;
+ if !debug then ignore(E.log "DCE: collecting used definitions\n");
+ 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
+ fd'
+
+class deadCodeElimClass : cilVisitor = object(self)
+ inherit nopCilVisitor
+
+ method vfunc fd =
+ let fd' = elim_dead_code(*_fp*) fd in
+ ChangeTo(fd')
+
+end
+
+let dce f =
+ if !debug then ignore(E.log "DCE: starting dead code elimination\n");
+ visitCilFile (new deadCodeElimClass) f
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(** Compute dominator information for the statements in a function *)
+open Cil
+open Pretty
+module E = Errormsg
+module H = Hashtbl
+module U = Util
+module IH = Inthash
+
+module DF = Dataflow
+
+let debug = false
+
+(* For each statement we maintain a set of statements that dominate it *)
+module BS = Set.Make(struct
+ type t = Cil.stmt
+ let compare v1 v2 = Pervasives.compare v1.sid v2.sid
+ end)
+
+
+
+
+(** Customization module for dominators *)
+module DT = struct
+ let name = "dom"
+
+ let debug = ref debug
+
+ type t = BS.t
+
+ (** 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}"
+ (docList (fun s -> dprintf "%d" s.sid))
+ (BS.elements d)
+
+ let computeFirstPredecessor (s: stmt) (d: BS.t) : BS.t =
+ (* Make sure we add this block to the set *)
+ BS.add s d
+
+ let combinePredecessors (s: stmt) ~(old: BS.t) (d: BS.t) : BS.t option =
+ (* First, add this block to the data from the predecessor *)
+ let d' = BS.add s d in
+ if BS.subset old d' then
+ None
+ else
+ Some (BS.inter old d')
+
+ let doInstr (i: instr) (d: t) = DF.Default
+
+ let doStmt (s: stmt) (d: t) = DF.SDefault
+
+ let doGuard condition _ = DF.GDefault
+
+
+ let filterStmt _ = true
+end
+
+
+
+module Dom = DF.ForwardsDataFlow(DT)
+
+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) =
+ try IH.find idomInfo s.sid
+ 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"
+ * field has been computed. *)
+let rec dominates (idomInfo: stmt option IH.t) (s1: stmt) (s2: stmt) =
+ s1 == s2 ||
+ (let s2idom = getIdom idomInfo s2 in
+ match s2idom with
+ None -> false
+ | Some s2idom -> dominates idomInfo s1 s2idom)
+
+
+
+
+let computeIDom ?(doCFG:bool=true) (f: fundec) : stmt option IH.t =
+ (* We must prepare the CFG info first *)
+ if doCFG then begin
+ prepareCFG f;
+ computeCFGInfo f false
+ end;
+ IH.clear DT.stmtStartData;
+ let idomData: stmt option IH.t = IH.create 13 in
+
+ let _ =
+ match f.sbody.bstmts with
+ [] -> () (* function has no body *)
+ | start :: _ -> begin
+ (* We start with only the start block *)
+ IH.add DT.stmtStartData start.sid (BS.singleton start);
+
+ Dom.compute [start];
+
+ (* Dump the dominators information *)
+ if debug then
+ List.iter
+ (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
+ 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
+ ignore (IH.find idomData s.sid)
+ (* Already set *)
+ with Not_found -> begin
+ (* Get the dominators *)
+ 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
+ sofar (* Ignore the block itself *)
+ else begin
+ (* fill the idom information recursively *)
+ fillOneIdom d;
+ match sofar with
+ None -> Some d
+ | Some sofar' ->
+ (* See if d is dominated by sofar. We know that the
+ * idom information has been computed for both sofar
+ * and for d*)
+ if dominates idomData sofar' d then
+ Some d
+ else
+ sofar
+ end)
+ sdoms
+ None
+ in
+ IH.replace idomData s.sid idom
+ end
+ in
+ (* Scan all blocks and compute the idom *)
+ List.iter fillOneIdom f.sallstmts
+ end
+ in
+ idomData
+
+type tree = stmt option * BS.t IH.t
+
+(* 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 =
+ (* We must prepare the CFG info first *)
+ if doCFG then begin
+ prepareCFG f;
+ computeCFGInfo f false
+ end;
+ IH.clear DT.stmtStartData;
+ 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
+ [] -> () (* 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
+ List.iter
+ (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
+ 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
+ ignore (IH.find idomData s.sid)
+ (* Already set *)
+ with Not_found -> begin
+ (* Get the dominators *)
+ 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
+ sofar (* Ignore the block itself *)
+ else begin
+ (* fill the idom information recursively *)
+ fillOneIdom d;
+ match sofar with
+ None -> Some d
+ | Some sofar' ->
+ (* See if d is dominated by sofar. We know that the
+ * idom information has been computed for both sofar
+ * and for d*)
+ if dominates idomData sofar' d then
+ Some d
+ else
+ sofar
+ end)
+ sdoms
+ None
+ in
+ IH.replace idomData s.sid idom;
+ match idom with
+ | None -> ()
+ | Some d -> begin
+ 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
+ in
+ (* Scan all blocks and compute the idom *)
+ List.iter fillOneIdom f.sallstmts
+ end
+ in
+ try idomData, (Some(List.hd f.sbody.bstmts), treeData)
+ with Failure "hd" -> idomData, (None, treeData)
+
+type order = PreOrder | PostOrder
+
+let rec domTreeIter (f: stmt -> unit)
+ (o : order)
+ (t: tree)
+ : unit
+ =
+ let doChildren s =
+ match IH.tryfind (snd t) s.sid with
+ | None -> () (* No children *)
+ | Some bs -> begin
+ BS.iter (fun s -> domTreeIter f o (Some s, snd t)) bs
+ end
+ in
+ match fst t with
+ | None -> ()
+ | Some s -> begin (* s is the current root *)
+ match o with
+ | PreOrder -> begin (* do s first *)
+ f s;
+ doChildren s
+ end
+ | PostOrder -> begin (* do s's children first *)
+ doChildren s;
+ f s
+ end
+ end
+
+let children (t: tree) (s: stmt) : stmt list =
+ match IH.tryfind (snd t) s.sid with
+ | 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
+ * start *)
+let findNaturalLoops (f: fundec)
+ (idomData: stmt option IH.t) : (stmt * stmt list) list =
+ let loops =
+ List.fold_left
+ (fun acc b ->
+ (* Iterate over all successors, and see if they are among the
+ * dominators for this block *)
+ List.fold_left
+ (fun acc s ->
+ if dominates idomData s b then
+ (* s is the start of a natural loop *)
+ let rec addNaturalLoop = function
+ [] -> [(s, [b])]
+ | (s', backs) :: rest when s'.sid = s.sid ->
+ (s', b :: backs) :: rest
+ | l :: rest -> l :: addNaturalLoop rest
+ in
+ addNaturalLoop acc
+ else
+ acc)
+ acc
+ b.succs)
+ []
+ f.sallstmts
+ in
+
+ if debug then
+ ignore (E.log "Natural loops:\n%a\n"
+ (docList ~sep:line
+ (fun (s, backs) ->
+ dprintf " Start: %d, backs:%a"
+ s.sid
+ (docList (fun b -> num b.sid))
+ backs))
+ loops);
+
+ loops
--- /dev/null
+
+
+(** Compute dominators using data flow analysis *)
+(** Author: George Necula
+ 5/28/2004
+ **)
+
+(** Invoke on a code after filling in the CFG info and it computes the
+ * immediate dominator information. We map each statement to its immediate
+ * dominator (None for the start statement, and for the unreachable
+ * statements). *)
+val computeIDom: ?doCFG:bool -> Cil.fundec -> Cil.stmt option Inthash.t
+
+type tree
+
+(** returns the IDoms and a map from statement ids to
+ * the set of statements that are dominated *)
+val computeDomTree: ?doCFG:bool ->
+ Cil.fundec ->
+ Cil.stmt option Inthash.t * tree
+
+(** This is like Inthash.find but gives an error if the information is
+ * Not_found *)
+val getIdom: Cil.stmt option Inthash.t -> Cil.stmt -> Cil.stmt option
+
+(** Check whether one statement dominates another. *)
+val dominates: Cil.stmt option Inthash.t -> Cil.stmt -> Cil.stmt -> bool
+
+(** Return a list of statements dominated by the argument *)
+val children: tree -> Cil.stmt -> Cil.stmt list
+
+type order = PreOrder | PostOrder
+
+(** Iterate over a dominator tree *)
+val domTreeIter: (Cil.stmt -> unit) -> order -> tree -> unit
+
+(** Compute the start of the natural loops. This assumes that the "idom"
+ * field has been computed. For each start, keep a list of origin of a back
+ * edge. The loop consists of the loop start and all predecessors of the
+ * origins of back edges, up to and including the loop start *)
+val findNaturalLoops: Cil.fundec ->
+ Cil.stmt option Inthash.t ->
+ (Cil.stmt * Cil.stmt list) list
--- /dev/null
+(* epicenter.ml *)
+(* code for epicenter.mli *)
+
+(* module maintainer: scott *)
+(* see copyright at end of this file *)
+
+open Callgraph
+open Cil
+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 doEpicenter = ref false
+let epicenterName = ref ""
+let epicenterHops = ref 0
+
+let feature : featureDescr =
+ { fd_name = "epicenter";
+ fd_enabled = doEpicenter;
+ 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),
+ "<name> do an epicenter slice starting from function <name>");
+ ("--epicenter-hops", Arg.Int (fun n -> epicenterHops := n),
+ "<n> specify max # of hops for epicenter slice");
+ ];
+
+ fd_doit =
+ (fun f ->
+ sliceFile f !epicenterName !epicenterHops);
+
+ fd_post_check = true;
+ }
+
+
+(*
+ *
+ * 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.
+ *
+ *)
--- /dev/null
+(*
+ *
+ * Copyright (c) 2004,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 Pretty
+
+module E = Errormsg
+
+(**************************************************************************)
+(* Helpers *)
+
+let isConstType (t: typ) : bool =
+ hasAttribute "const" (typeAttrs t)
+
+(**************************************************************************)
+(* Expression/type comparison *)
+
+let rec compareExp (e1: exp) (e2: exp) : bool =
+ (*log "CompareExp %a and %a.\n" d_plainexp e1 d_plainexp e2; *)
+ e1 == e2 ||
+ match e1, e2 with
+ | Lval lv1, Lval lv2
+ | StartOf lv1, StartOf lv2
+ | AddrOf lv1, AddrOf lv2 -> compareLval lv1 lv2
+ | BinOp(bop1, l1, r1, _), BinOp(bop2, l2, r2, _) ->
+ bop1 = bop2 && compareExp l1 l2 && compareExp r1 r2
+ | CastE(t1, e1), CastE(t2, e2) ->
+ t1 == t2 && compareExp e1 e2
+ | _ -> begin
+ match isInteger (constFold true e1), isInteger (constFold true e2) with
+ Some i1, Some i2 -> i1 = i2
+ | _ -> false
+ end
+
+and compareLval (lv1: lval) (lv2: lval) : bool =
+ let rec compareOffset (off1: offset) (off2: offset) : bool =
+ match off1, off2 with
+ | Field (fld1, off1'), Field (fld2, off2') ->
+ fld1 == fld2 && compareOffset off1' off2'
+ | Index (e1, off1'), Index (e2, off2') ->
+ compareExp e1 e2 && compareOffset off1' off2'
+ | NoOffset, NoOffset -> true
+ | _ -> false
+ in
+ lv1 == lv2 ||
+ match lv1, lv2 with
+ | (Var vi1, off1), (Var vi2, off2) ->
+ vi1 == vi2 && compareOffset off1 off2
+ | (Mem e1, off1), (Mem e2, off2) ->
+ compareExp e1 e2 && compareOffset off1 off2
+ | _ -> false
+
+(* Remove casts that do not effect the value of the expression, such
+ * as casts between different pointer types. Of course, these casts
+ * change the type, so don't use this within e.g. an arithmetic
+ * expression.
+ *
+ * We remove casts from pointer types to unsigned int or unsigned long.
+ *
+ * We also prune casts between equivalent integer types, such as a
+ * difference in sign or int vs long. But we keep other arithmetic casts,
+ * since they actually change the value of the expression. *)
+let rec stripNopCasts (e:exp): exp =
+ match e with
+ CastE(t, e') -> begin
+ match unrollType (typeOf e'), unrollType t with
+ TPtr (bt1, a1), TPtr (bt2, a2)
+ 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
+ && not (isSigned ik) ->
+ stripNopCasts e'
+ | (TInt(ik1,_) as t1), (TInt(ik2,_) as t2)
+ (* promotion when signedness is the same doesn't change value *)
+ (* promotion of unsigned to signed of larger bitsize doesn't change
+ value *)
+ when bitsSizeOf t1 = bitsSizeOf t2 ||
+ (isSigned ik1 = isSigned ik2 &&
+ bitsSizeOf t1 < bitsSizeOf t2) ||
+ (not(isSigned ik1) &&
+ bitsSizeOf t1 < bitsSizeOf t2) -> (* Okay to strip.*)
+ stripNopCasts e'
+ | _ -> e
+ end
+ | _ -> e
+
+let compareExpStripCasts (e1: exp) (e2: exp) : bool =
+ compareExp (stripNopCasts e1) (stripNopCasts e2)
+
+(* A more conservative form of stripNopCasts. Here, we only strip pointer
+ casts if the base types have the same width. Using this on the left operand
+ of pointer arithmetic shouldn't change the resulting value. *)
+let rec stripCastsForPtrArith (e:exp): exp =
+ match e with
+ | CastE(t, e') -> begin
+ match unrollType (typeOf e'), unrollType t with
+ (* Keep casts from void to something else. Among other things,
+ * we keep casts from void* to char* that would otherwise be
+ * eliminated. *)
+ | TPtr (TVoid _, _), TPtr (bt2, _) when not (isVoidType bt2) ->
+ e
+ (* Remove casts between pointers with equal-sized base types. *)
+ | TPtr (bt1, a1), TPtr (bt2, a2) -> begin
+ try
+ if bitsSizeOf bt1 = bitsSizeOf bt2 &&
+ isConstType bt1 = isConstType bt2 then
+ stripCastsForPtrArith e'
+ else
+ e
+ with SizeOfError _ -> (* bt1 or bt2 is abstract; don't strip. *)
+ e
+ end
+ (* strip casts from pointers to unsigned int/long*)
+ | (TPtr _ as t1), (TInt(ik,_) as t2)
+ when bitsSizeOf t1 = bitsSizeOf t2
+ && not (isSigned ik) ->
+ stripCastsForPtrArith e'
+ | (TInt(ik1,_) as t1), (TInt(ik2,_) as t2)
+ (*when bitsSizeOf t1 = bitsSizeOf t2 ->*) (* Okay to strip.*)
+ when bitsSizeOf t1 = bitsSizeOf t2 ||
+ (isSigned ik1 = isSigned ik2 &&
+ bitsSizeOf t1 < bitsSizeOf t2) ||
+ (not(isSigned ik1) &&
+ bitsSizeOf t1 < bitsSizeOf t2) -> (* Okay to strip.*)
+ stripCastsForPtrArith e'
+ | _ -> e
+ end
+ | _ -> e
+
+let compareTypes ?(ignoreSign=true)
+ ?(importantAttr : attribute -> bool = (fun _ -> true))
+ (t1 : typ) (t2 : typ) : bool =
+ let typeSigNC (t : typ) : typsig =
+ let attrFilter (attr : attribute) : bool =
+ match attr with
+ | Attr ("poly", _) (* TODO: hack hack! *)
+ | Attr ("assumeconst", _)
+ | Attr ("_ptrnode", _)
+ | Attr ("missing_annot", _)
+ | Attr ("const", [])
+ | Attr ("aligned", _)
+ | Attr ("volatile", [])
+ | Attr ("deprecated", [])
+ | Attr ("always_inline", []) -> false
+ | _ -> importantAttr attr
+ in
+ typeSigWithAttrs ~ignoreSign (List.filter attrFilter) t
+ in
+ (typeSigNC t1) = (typeSigNC t2)
+
+let compareTypesNoAttributes ?(ignoreSign=true) (t1 : typ) (t2 : typ) : bool =
+ let typSig = typeSigWithAttrs ~ignoreSign:ignoreSign (fun _ -> []) in
+ Util.equals (typSig t1) (typSig t2)
+
+class volatileFinderClass br = object(self)
+ inherit nopCilVisitor
+
+ method vtype (t : typ) =
+ if hasAttribute "volatile" (typeAttrs t) then begin
+ br := true;
+ SkipChildren
+ end
+ else
+ DoChildren
+
+end
+
+let isTypeVolatile t =
+ let br = ref false in
+ let vis = new volatileFinderClass br in
+ ignore(visitCilType vis t);
+ !br
+
+(* strip every cast between equal pointer types *)
+let rec stripCastsDeepForPtrArith (e:exp): exp =
+ match e with
+ | CastE(t, e') when not(isTypeVolatile t) -> begin
+ let e' = stripCastsDeepForPtrArith e' in
+ match unrollType (typeOf e'), unrollType t with
+ (* Keep casts from void to something else. Among other things,
+ * we keep casts from void* to char* that would otherwise be
+ * eliminated. *)
+ | TPtr (TVoid _, _), TPtr (bt2, _) when not (isVoidType bt2) ->
+ e
+ (* Remove casts between pointers with equal-sized base types. *)
+ | TPtr (bt1, a1), TPtr (bt2, a2) -> begin
+ try
+ if bitsSizeOf bt1 = bitsSizeOf bt2 &&
+ isConstType bt1 = isConstType bt2 then
+ e'
+ 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) ->
+ 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
+ (typeOf e1) (typeOf e2))
+ then BinOp(MinusPP, mkCast ~e:e1 ~newt:(typeOf e2), e2, t)
+ else BinOp(MinusPP, e1, e2, t)
+ | BinOp(op,e1,e2,t) ->
+ let e1 = stripCastsDeepForPtrArith e1 in
+ let e2 = stripCastsDeepForPtrArith e2 in
+ BinOp(op,e1,e2,t)
+ | Lval lv -> Lval(stripCastsForPtrArithLval lv)
+ | AddrOf lv -> AddrOf(stripCastsForPtrArithLval lv)
+ | StartOf lv -> StartOf(stripCastsForPtrArithLval lv)
+ | _ -> e
+
+and stripCastsForPtrArithLval (lv : lval) : lval =
+ match lv with
+ | (Var vi, off) -> (Var vi, stripCastsForPtrArithOff off)
+ | (Mem e, off) ->
+ let e = stripCastsDeepForPtrArith e in
+ let off = stripCastsForPtrArithOff off in
+ (Mem e, off)
+
+and stripCastsForPtrArithOff (off : offset ) : offset =
+ match off with
+ | NoOffset -> NoOffset
+ | Field(fi, off) -> Field(fi, stripCastsForPtrArithOff off)
+ | Index(e, off) ->
+ let e = stripCastsDeepForPtrArith e in
+ let off = stripCastsForPtrArithOff off in
+ Index(e, off)
+
+let compareExpDeepStripCasts (e1 : exp) (e2 : exp) : bool =
+ compareExp (stripCastsDeepForPtrArith e1) (stripCastsDeepForPtrArith e2)
+
+
+let rec compareAttrParam (ap1 : attrparam) (ap2 : attrparam) : bool =
+ ap1 == ap2 ||
+ match ap1, ap2 with
+ | AInt i1, AInt i2 -> i1 = i2
+ | AStr s1, AStr s2 -> s1 = s2
+ | ACons(s1,apl1), ACons(s2,apl2) -> s1 = s2 &&
+ List.length apl1 = List.length apl2 &&
+ not(List.exists2 (fun ap1 ap2 -> not(compareAttrParam ap1 ap2)) apl1 apl2)
+ | ASizeOf t1, ASizeOf t2 -> compareTypes t1 t2
+ | ASizeOfE ap1, ASizeOfE ap2 -> compareAttrParam ap1 ap2
+ | ASizeOfS ts1, ASizeOfS ts2 -> Util.equals ts1 ts2
+ | AAlignOf t1, AAlignOf t2 -> compareTypes t1 t2
+ | AAlignOfE ap1, AAlignOfE ap2 -> compareAttrParam ap1 ap2
+ | AAlignOfS ts1, AAlignOfS ts2 -> Util.equals ts1 ts2
+ | AUnOp(uop1,ap1), AUnOp(uop2,ap2) -> uop1 = uop2 && compareAttrParam ap1 ap2
+ | ABinOp(bop1,ap11,ap12), ABinOp(bop2,ap21,ap22) -> bop1 = bop2 &&
+ compareAttrParam ap11 ap21 && compareAttrParam ap12 ap22
+ | ADot(ap1,s1), ADot(ap2,s2) -> compareAttrParam ap1 ap2 && s1 = s2
+ | AStar ap1, AStar ap2 -> compareAttrParam ap1 ap2
+ | AAddrOf ap1, AAddrOf ap2 -> compareAttrParam ap1 ap2
+ | AIndex(ap11,ap12), AIndex(ap21,ap22) ->
+ compareAttrParam ap11 ap21 && compareAttrParam ap12 ap22
+ | AQuestion(ap11,ap12,ap13), AQuestion(ap21,ap22,ap23) ->
+ compareAttrParam ap11 ap21 && compareAttrParam ap12 ap22 &&
+ compareAttrParam ap13 ap23
+ | _, _ -> false
+
--- /dev/null
+(* 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 <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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
+
+(* 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 : featureDescr =
+ { fd_name = "stackGuard";
+ fd_enabled = Cilutil.doStackGuard;
+ 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 : featureDescr =
+ { fd_name = "heapify";
+ fd_enabled = Cilutil.doHeapify;
+ 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;
+ }
+
+
+
+
+
+
--- /dev/null
+(*\r
+ *\r
+ * Copyright (c) 2007, \r
+ * George C. Necula <necula@cs.berkeley.edu>\r
+ * All rights reserved.\r
+ * \r
+ * Redistribution and use in source and binary forms, with or without\r
+ * modification, are permitted provided that the following conditions are\r
+ * met:\r
+ *\r
+ * 1. Redistributions of source code must retain the above copyright\r
+ * notice, this list of conditions and the following disclaimer.\r
+ *\r
+ * 2. Redistributions in binary form must reproduce the above copyright\r
+ * notice, this list of conditions and the following disclaimer in the\r
+ * documentation and/or other materials provided with the distribution.\r
+ *\r
+ * 3. The names of the contributors may not be used to endorse or promote\r
+ * products derived from this software without specific prior written\r
+ * permission.\r
+ *\r
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS\r
+ * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED\r
+ * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A\r
+ * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER\r
+ * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,\r
+ * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,\r
+ * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR\r
+ * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF\r
+ * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING\r
+ * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS\r
+ * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r
+ *\r
+ *)\r
+\r
+\r
+(** This module provides inlining functions. You can run it from the cilly \r
+ * command line by passing the names of the functions to inline:\r
+ * \r
+ * cilly --save-temps --inline=toinline module.c\r
+ * \r
+ * This module has not been tested extensively, so you should run it with \r
+ * the --check argument to ensure that it does not break any CIL invariants \r
+ *\r
+ * \r
+ * You can also call directly the [doFile] and [doFunction] functions.\r
+ \r
+ *)\r
+\r
+open Pretty\r
+open Cil\r
+module E = Errormsg\r
+module H = Hashtbl\r
+module IH = Inthash\r
+module A = Alpha\r
+\r
+let doInline = ref false\r
+let debug = true\r
+\r
+exception Recursion (* Used to signal recursion *)\r
+\r
+(* A visitor that makes a deep copy of a function body for use inside a host \r
+ * function, replacing duplicate labels, returns, etc. *)\r
+class copyBodyVisitor (host: fundec) (* The host of the \r
+ * inlining *) \r
+ (inlining: varinfo) (* Function being \r
+ * inlined *)\r
+ (replVar: varinfo -> varinfo) (* Maps locals of the \r
+ * inlined function \r
+ * to locals of the \r
+ * host *)\r
+ (retlval: varinfo option) (* The destination \r
+ * for the "return" *)\r
+ (replLabel: string -> string) \r
+ (* A renamer for \r
+ * labels *)\r
+ (retlab: stmt) (* The label for the \r
+ * return *)\r
+ = object (self)\r
+ inherit nopCilVisitor\r
+\r
+ (* Keep here a maping from statements to their copies, indexed by their \r
+ * original ID *)\r
+ val stmtmap : stmt IH.t = IH.create 113\r
+\r
+ (* Keep here a list of statements to be patched *)\r
+ val patches : stmt list ref = ref []\r
+\r
+ val argid = ref 0\r
+\r
+ (* This is the entry point *)\r
+ method vfunc (f: fundec) : fundec visitAction = \r
+ let patchfunction (f' : fundec) = \r
+ let findStmt (i: int) = \r
+ try IH.find stmtmap i \r
+ with Not_found -> E.s (bug "Cannot find the copy of stmt#%d" i)\r
+ in\r
+ E.log "Patching gotos\n";\r
+ let patchstmt (s: stmt) = \r
+ match s.skind with\r
+ Goto (sr, l) -> \r
+ if debug then\r
+ E.log "patching goto\n";\r
+ (* Make a copy of the reference *)\r
+ let sr' = ref (findStmt !sr.sid) in\r
+ s.skind <- Goto (sr',l)\r
+ | Switch (e, body, cases, l) -> \r
+ s.skind <- Switch (e, body, \r
+ List.map (fun cs -> findStmt cs.sid) cases, l)\r
+ | _ -> ()\r
+ in\r
+ List.iter patchstmt !patches;\r
+ f'\r
+ in\r
+ patches := [];\r
+ IH.clear stmtmap;\r
+ ChangeDoChildrenPost (f, patchfunction)\r
+ \r
+ (* We must replace references to local variables *)\r
+ method vvrbl (v: varinfo) = \r
+ if v.vglob then \r
+ SkipChildren \r
+ else \r
+ let v' = replVar v in \r
+ if v == v' then \r
+ SkipChildren\r
+ else\r
+ ChangeTo v'\r
+\r
+\r
+ method vinst (i: instr) = \r
+ match i with \r
+ Call (_, Lval (Var vi, _), _, _) when vi.vid == inlining.vid -> \r
+ raise Recursion\r
+\r
+ | _ -> DoChildren\r
+\r
+ (* Replace statements. *)\r
+ method vstmt (s: stmt) : stmt visitAction = \r
+ (* There is a possibility that we did not have the statements IDed \r
+ * propertly. So, we change the ID even on the replaced copy so that we \r
+ * can index on them ! *)\r
+ (match host.smaxstmtid with \r
+ Some id ->\r
+ s.sid <- 1 + id\r
+ | None -> \r
+ s.sid <- 1);\r
+ (* Copy and change ID *)\r
+ let s' = {s with sid = s.sid} in\r
+ host.smaxstmtid <- Some s'.sid;\r
+\r
+ IH.add stmtmap s.sid s'; (* Remember where we copied this statement *)\r
+ (* if we have a Goto or a Switch remember them to fixup at end *)\r
+ (match s'.skind with\r
+ (Goto _ | Switch _) -> \r
+ E.log "Found goto\n";\r
+ patches := s' :: !patches\r
+ | _ -> ());\r
+ \r
+ (* Change the returns *)\r
+ let postProc (s': stmt) : stmt = \r
+ (* Rename the labels if necessary *)\r
+ s'.labels <- \r
+ List.map (fun lb -> \r
+ match lb with\r
+ Label (n, l, fromsrc) -> Label(replLabel n, l, fromsrc)\r
+ | _ -> lb) s'.labels;\r
+\r
+ (* Now deal with the returns *)\r
+ (match s'.skind with \r
+ | Return (ro, l) -> begin\r
+ (* Change this into an assignment followed by a Goto *)\r
+ match ro, retlval with \r
+ _, None -> (* Function called with no return lval *)\r
+ s'.skind <- Goto (ref retlab, l)\r
+ \r
+ | None, _ -> \r
+ ignore (warn "Found return without value in inlined function");\r
+ s'.skind <- Goto (ref retlab, l)\r
+ \r
+ | Some rv, Some retvar-> \r
+ s'.skind <-\r
+ Block (mkBlock [ mkStmt (Instr [(Set (var retvar, rv, l))]);\r
+ mkStmt (Goto (ref retlab, l)) ])\r
+ end\r
+ | _ -> ());\r
+ s'\r
+ in\r
+ (* Do the children then postprocess *)\r
+ ChangeDoChildrenPost (s', postProc)\r
+\r
+ (* Copy blocks since they are mutable *)\r
+ method vblock (b: block) = \r
+ ChangeDoChildrenPost ({b with bstmts = b.bstmts}, fun x -> x)\r
+\r
+\r
+ method vglob _ = E.s (bug "copyFunction should not be used on globals")\r
+end\r
+\r
+(** Replace a statement with the result of inlining *)\r
+let replaceStatement (host: fundec) (* The host *)\r
+ (inlineWhat: varinfo -> fundec option) (* What to inline *)\r
+ (replLabel: string -> string) (* label \r
+ * replacement *)\r
+ (anyInlining: bool ref) (* will set this \r
+ * to true if we \r
+ * did any \r
+ * inlining *)\r
+ (s: stmt) : stmt = \r
+ match s.skind with \r
+ Instr il when il <> [] -> \r
+ let prevrstmts: stmt list ref = ref [] in (* Reversed list of previous \r
+ * statements *)\r
+ let prevrinstr: instr list ref = ref [] in (* Reverse list of previous \r
+ * instructions, in this \r
+ * statement *)\r
+ let emptyPrevrinstr () = \r
+ if !prevrinstr <> [] then begin\r
+ prevrstmts := mkStmt (Instr (List.rev !prevrinstr)) :: !prevrstmts;\r
+ prevrinstr := []\r
+ end\r
+ in\r
+ \r
+ let rec loop (rest: instr list) (* Remaining instructions *)\r
+ : unit = \r
+ match rest with \r
+ [] -> (* Done *) ()\r
+\r
+ | (Call (lvo, Lval (Var fvi, NoOffset), args, l) as i) :: resti -> begin\r
+ if debug then \r
+ E.log "Checking whether to inline %s\n" fvi.vname;\r
+ let replo: fundec option = \r
+ match inlineWhat fvi with \r
+ Some repl -> \r
+ if repl.svar.vid = host.svar.vid then begin\r
+ ignore (warn "Inliner encountered recursion in inlined function %s" \r
+ host.svar.vname);\r
+ None\r
+ end else\r
+ Some repl\r
+ | None -> None\r
+ in\r
+ match replo with \r
+ | None -> prevrinstr := i :: !prevrinstr;\r
+ loop resti\r
+ \r
+ | Some repl -> begin\r
+ anyInlining := true;\r
+ E.log "Done inlining\n";\r
+\r
+ (* We must inline *)\r
+ (* Prepare the mapping of local variables *)\r
+ let vmap : varinfo IH.t = IH.create 13 in \r
+ let replVar (vi: varinfo) = \r
+ if vi.vglob then vi\r
+ else \r
+ try IH.find vmap vi.vid\r
+ with Not_found -> begin\r
+ E.s (bug "Cannot find the new copy of local variable %s" \r
+ vi.vname)\r
+ end\r
+ in\r
+ (* Do the actual arguments, and keep extending prevrinstr *)\r
+ let rec loopArgs (args: exp list) (formals: varinfo list) = \r
+ match args, formals with \r
+ [], [] -> ()\r
+ | (a :: args'), (f :: formals') -> begin\r
+ (* We must copy the argument even if it is already a \r
+ * variable, to obey call by value *)\r
+ (* Make a local and a copy *)\r
+ let f' = makeTempVar host ~name:f.vname f.vtype in\r
+ prevrinstr := (Set (var f', a, l)) :: !prevrinstr;\r
+ IH.add vmap f.vid f';\r
+ \r
+ loopArgs args' formals'\r
+ end\r
+ | _, _ -> E.bug "Invalid number of arguments"\r
+ in\r
+ loopArgs args repl.sformals;\r
+ \r
+ (* Copy the locals *)\r
+ List.iter (fun loc -> \r
+ let loc' = makeTempVar host ~name:loc.vname loc.vtype in \r
+ IH.add vmap loc.vid loc') repl.slocals;\r
+ \r
+ \r
+ (* Make the return statement *)\r
+ let (ret : stmt), (retvar: varinfo option) = \r
+ let rt, _, isva, _ = splitFunctionType repl.svar.vtype in\r
+ match rt with \r
+ TVoid _ -> mkStmt (Instr []), None\r
+ | _ -> begin\r
+ match lvo with \r
+ None -> mkStmt (Instr []), None\r
+ | Some lv -> \r
+ (* Make a return variable *)\r
+ let rv = makeTempVar \r
+ host ~name:("ret_" ^ repl.svar.vname) rt in\r
+ mkStmtOneInstr (Set (lv, Lval (var rv), l)), Some rv\r
+ end\r
+ in\r
+ ret.labels <- [Label (replLabel ("Lret_" ^ repl.svar.vname),\r
+ l, false)];\r
+ let oldBody = repl.sbody in \r
+ (* Now replace the body *)\r
+ (try\r
+ ignore (visitCilFunction \r
+ (new copyBodyVisitor host repl.svar replVar \r
+ retvar replLabel ret) \r
+ repl);\r
+ currentLoc := l;\r
+ let body' = repl.sbody in \r
+ (* Replace the old body in the function to inline *)\r
+ repl.sbody <- oldBody;\r
+ \r
+ emptyPrevrinstr ();\r
+ prevrstmts := ret :: (mkStmt (Block body')) :: !prevrstmts\r
+ with Recursion -> \r
+ ignore (warn "Encountered recursion in function %s\n" \r
+ repl.svar.vname);\r
+ prevrinstr := i :: !prevrinstr);\r
+\r
+ loop resti\r
+ end\r
+ end\r
+ | i :: resti -> \r
+ prevrinstr := i :: !prevrinstr; \r
+ loop resti\r
+ in\r
+ loop il;\r
+\r
+ emptyPrevrinstr ();\r
+ if List.length !prevrstmts > 1 then \r
+ s.skind <- Block (mkBlock (List.rev !prevrstmts));\r
+\r
+ s\r
+\r
+ | _ -> s\r
+ \r
+ \r
+(** Apply inlining to a function, modify in place *)\r
+let doFunction (host: fundec) (* The function into which to inline *)\r
+ (inlineWhat: varinfo -> fundec option) (* The functions to \r
+ * inline, as a \r
+ * partial map \r
+ * from varinfo to \r
+ * body *)\r
+ (anyInlining: bool ref) (* Will be set to true \r
+ * if any inlining \r
+ * took place *)\r
+ : unit = \r
+ if debug then \r
+ E.log "Doing inlining for %s\n" host.svar.vname;\r
+\r
+ (* Scan the host function and build the alpha-conversion table for labels *)\r
+ let labTable: (string, unit A.alphaTableData ref) H.t = H.create 5 in\r
+ ignore (visitCilBlock \r
+ (object \r
+ inherit nopCilVisitor\r
+ method vstmt (s: stmt) = \r
+ List.iter \r
+ (fun l ->\r
+ match l with \r
+ Label(ln, _, _) -> \r
+ ignore (A.registerAlphaName ~alphaTable:labTable \r
+ ~undolist:None ~data:() ~lookupname:ln)\r
+ | _ -> ())\r
+ s.labels;\r
+ DoChildren\r
+ \r
+ end)\r
+ host.sbody);\r
+ (* Now the label replacement function *)\r
+ let replLabel (ln: string) : string = \r
+ let ln', _ = A.newAlphaName \r
+ ~alphaTable:labTable ~undolist:None ~lookupname:ln ~data:() in\r
+ ln'\r
+ in\r
+ (* Now scan the function to do the inlining *)\r
+ let body' : block = \r
+ visitCilBlock (object\r
+ inherit nopCilVisitor\r
+ method vstmt (s: stmt) = \r
+ ChangeDoChildrenPost (s, \r
+ replaceStatement host inlineWhat \r
+ replLabel anyInlining)\r
+ end) host.sbody in \r
+ host.sbody <- body';\r
+ ()\r
+\r
+\r
+(** Apply inlining to a whole file *)\r
+let doFile (inlineWhat: varinfo -> fundec option) (* What to inline. See \r
+ * comments for [doFunction] *)\r
+ (fl: file) = \r
+ iterGlobals fl (fun g -> \r
+ match g with \r
+ GFun(fd, l) -> \r
+ (* Keep doing inlining until there is no more. We will catch \r
+ * recursion eventually when we want to inline a function into itself*) \r
+ let anyInlining = ref true in\r
+ while !anyInlining do\r
+ anyInlining := false;\r
+ doFunction fd inlineWhat anyInlining\r
+ done\r
+\r
+ | _ -> ())\r
+ \r
+\r
+(* Function names to inline *)\r
+let toinline: string list ref = ref []\r
+let doit (fl: file) = \r
+ (* Scan the file and build the hashtable of functions to inline *)\r
+ let inlineTable: (string, fundec) H.t = H.create 5 in \r
+ visitCilFile (object\r
+ inherit nopCilVisitor\r
+ method vfunc (fd: fundec) =\r
+ if List.mem fd.svar.vname !toinline then \r
+ H.add inlineTable fd.svar.vname fd;\r
+ SkipChildren\r
+ end) fl;\r
+ let inlineWhat (vi: varinfo) : fundec option = \r
+ try Some (H.find inlineTable vi.vname)\r
+ with Not_found -> None\r
+ in\r
+ (* Give warnings if we cannot find some fundecs *)\r
+ List.iter (fun fn -> \r
+ if not (H.mem inlineTable fn) then \r
+ ignore (warn "Cannot inline function %s because we cannot find its definition" fn))\r
+ !toinline;\r
+\r
+ doFile inlineWhat fl\r
+\r
+let feature : featureDescr = \r
+ { fd_name = "inliner";\r
+ fd_enabled = doInline;\r
+ fd_description = "inline function calls";\r
+ fd_extraopt = [\r
+ "--inline", Arg.String (fun s -> doInline := true;\r
+ toinline := s :: !toinline), \r
+ "<func> inline this function";\r
+ ];\r
+ fd_doit = doit;\r
+ fd_post_check = true;\r
+ } \r
+\r
--- /dev/null
+
+(* Calculate which variables are live at
+ * each statememnt.
+ *
+ *
+ *
+ *)
+
+open Cil
+open Pretty
+
+module DF = Dataflow
+module UD = Usedef
+module IH = Inthash
+module E = Errormsg
+
+let debug = ref false
+
+(*
+ * When ignore_inst returns true, then
+ * the instruction in question has no
+ * effects on the abstract state.
+ * When ignore_call returns true, then
+ * the instruction only has side-effects
+ * from the assignment if there is one.
+ *)
+let ignore_inst = ref (fun i -> false)
+let ignore_call = ref (fun i -> false)
+
+let registerIgnoreInst (f : instr -> bool) : unit =
+ let f' = !ignore_inst in
+ ignore_inst := (fun i -> (f i) || (f' i))
+
+let registerIgnoreCall (f : instr -> bool) : unit =
+ let f' = !ignore_call in
+ ignore_call := (fun i -> (f i) || (f' i))
+
+let live_label = ref ""
+let live_func = ref ""
+
+module VS = UD.VS
+
+let debug_print () vs = (VS.fold
+ (fun vi d ->
+ d ++ text "name: " ++ text vi.vname
+ ++ text " id: " ++ num vi.vid ++ text " ")
+ vs nil) ++ line
+
+let min_print () vs = (VS.fold
+ (fun vi d ->
+ d ++ text vi.vname
+ ++ text "(" ++ d_type () vi.vtype ++ text ")"
+ ++ text ",")
+ vs nil) ++ line
+
+let printer = ref debug_print
+
+module LiveFlow = struct
+ let name = "Liveness"
+ let debug = debug
+ type t = VS.t
+
+ let pretty () vs =
+ let fn = !printer in
+ fn () vs
+
+ let stmtStartData = IH.create 32
+
+ let funcExitData = VS.empty
+
+ let combineStmtStartData (stm:stmt) ~(old:t) (now:t) =
+ if not(VS.compare old now = 0)
+ then Some(VS.union old now)
+ else None
+
+ let combineSuccessors = VS.union
+
+ let doStmt stmt =
+ if !debug then ignore(E.log "looking at: %a\n" d_stmt stmt);
+ let handle_stm vs = match stmt.skind with
+ Instr _ -> vs
+ | s -> let u, d = UD.computeUseDefStmtKind s in
+ VS.union u (VS.diff vs d)
+ in
+ DF.Post handle_stm
+
+ let doInstr i vs =
+ let transform vs' =
+ if (!ignore_inst) i then vs' else
+ let u,d = UD.computeUseDefInstr i in
+ VS.union u (VS.diff vs' d)
+ in
+ DF.Post transform
+
+ let filterStmt stm1 stm2 = true
+
+end
+
+module L = DF.BackwardsDataFlow(LiveFlow)
+
+(* XXX: This does not compute the best ordering to
+ * give to the work-list algorithm.
+ *)
+let all_stmts = ref []
+class nullAdderClass = object(self)
+ inherit nopCilVisitor
+
+ method vstmt s =
+ all_stmts := s :: (!all_stmts);
+ IH.add LiveFlow.stmtStartData s.sid VS.empty;
+ DoChildren
+
+end
+
+let null_adder fdec =
+ ignore(visitCilFunction (new nullAdderClass) fdec);
+ !all_stmts
+
+let computeLiveness fdec =
+ IH.clear LiveFlow.stmtStartData;
+ UD.onlyNoOffsetsAreDefs := false;
+ all_stmts := [];
+ let a = null_adder fdec in
+ try
+ L.compute a
+ with E.Error -> begin
+ ignore(E.log "Liveness failed on function:\n %a\n" d_global (GFun(fdec,locUnknown)));
+ E.s "Bug in Liveness compute"
+ end
+
+let getLiveSet sid =
+ try Some(IH.find LiveFlow.stmtStartData sid)
+ with Not_found -> None
+
+let getLiveness (s:stmt) = Inthash.find LiveFlow.stmtStartData s.sid
+
+let getPostLiveness (s:stmt) : LiveFlow.t =
+ let foldLiveness live s = VS.union live (getLiveness s) in
+ List.fold_left foldLiveness VS.empty s.succs
+
+let instrLiveness (il : instr list) (stm : stmt) (vs : VS.t) (out: bool) : VS.t list =
+ let proc_one vsl i =
+ match vsl with
+ | [] ->
+ if (!ignore_inst) i then vs::vsl else
+ let u,d = UD.computeUseDefInstr i in
+ (VS.union u (VS.diff vs d))::vsl
+ | vs'::rst ->
+ if (!ignore_inst) i then vs'::vsl else
+ let u,d = UD.computeUseDefInstr i in
+ (VS.union u (VS.diff vs' d))::vsl
+ in
+ let liveout = getPostLiveness stm in
+ let folded = List.fold_left proc_one [liveout] (List.rev il) in
+ if out then List.tl folded else folded
+
+(* Inherit from this to visit with liveness info at instructions.
+ If out is true, then gives liveness after instructions.
+ If out is false, then gives liveness before instructions. *)
+class livenessVisitorClass (out : bool) = object(self)
+ inherit nopCilVisitor
+
+ val mutable sid = -1
+
+ val mutable liv_dat_lst = []
+
+ val mutable cur_liv_dat = None
+
+ method vstmt stm =
+ sid <- stm.sid;
+ match getLiveSet sid with
+ | None -> begin
+ if !debug then E.log "livVis: stm %d has no data\n" sid;
+ cur_liv_dat <- None;
+ DoChildren
+ end
+ | Some vs -> begin
+ match stm.skind with
+ | Instr il -> begin
+ liv_dat_lst <- instrLiveness il stm vs out;
+ DoChildren
+ end
+ | _ -> begin
+ cur_liv_dat <- None;
+ DoChildren
+ end
+ end
+
+ method vinst i =
+ try
+ let data = List.hd liv_dat_lst in
+ cur_liv_dat <- Some(data);
+ liv_dat_lst <- List.tl liv_dat_lst;
+ if !debug then E.log "livVis: at %a, data is %a\n"
+ d_instr i debug_print data;
+ DoChildren
+ with Failure "hd" ->
+ if !debug then E.log "livnessVisitor: il liv_dat_lst mismatch\n";
+ DoChildren
+end
+
+(* Inherit from this to visit instructions with
+ data about which variables are newly dead after
+ the instruction in post_dead_vars
+ (and which variables are dead *before* each /statement/,
+ also, confusingly, in post_dead_vars).
+ post_live_vars contains vars that are newly live
+ after each instruction *)
+class deadnessVisitorClass = object(self)
+ inherit nopCilVisitor
+
+ val mutable sid = -1
+
+ val mutable liv_dat_lst = []
+
+ val mutable cur_liv_dat = None
+
+ val mutable post_dead_vars = VS.empty
+ val mutable post_live_vars = VS.empty
+
+ method vstmt stm =
+ sid <- stm.sid;
+ match getLiveSet sid with
+ | None -> begin
+ if !debug then E.log "deadVis: stm %d has no data\n" sid;
+ cur_liv_dat <- None;
+ post_dead_vars <- VS.empty;
+ post_live_vars <- VS.empty;
+ DoChildren
+ end
+ | Some vs -> begin
+ let (dead,live) =
+ List.fold_left (fun (dead,live) stm ->
+ VS.union dead (VS.diff (getPostLiveness stm) vs),
+ VS.union live (getPostLiveness stm))
+ (VS.empty, VS.empty)
+ stm.preds
+ in
+ if !debug then E.log "deadVis: before %a, %a die, %a come to live\n"
+ d_stmt stm debug_print dead debug_print live;
+ post_dead_vars <- dead;
+ post_live_vars <- VS.diff vs live;
+ match stm.skind with
+ | Instr il -> begin
+ liv_dat_lst <- instrLiveness il stm vs true;
+ DoChildren
+ end
+ | _ -> begin
+ cur_liv_dat <- None;
+ DoChildren
+ end
+ end
+
+ method vinst i =
+ try
+ let data = List.hd liv_dat_lst in
+ cur_liv_dat <- Some(data);
+ liv_dat_lst <- List.tl liv_dat_lst;
+ let u,d = UD.computeUseDefInstr i in
+ let inlive = VS.union u (VS.diff data d) in
+ post_dead_vars <- VS.diff inlive data;
+ post_live_vars <- VS.diff data inlive;
+ if !debug then
+ 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" ->
+ if !debug then E.log "deadnessVisitor: il liv_dat_lst mismatch\n";
+ post_dead_vars <- VS.empty;
+ post_live_vars <- VS.empty;
+ DoChildren
+end
+
+let print_everything () =
+ let d = IH.fold (fun i vs d ->
+ d ++ num i ++ text ": " ++ LiveFlow.pretty () vs)
+ LiveFlow.stmtStartData nil in
+ ignore(printf "%t" (fun () -> d))
+
+let match_label lbl = match lbl with
+ Label(str,_,b) ->
+ if !debug then ignore(E.log "Liveness: label seen: %s\n" str);
+ (*b && *)(String.compare str (!live_label) = 0)
+| _ -> false
+
+class doFeatureClass = object(self)
+ inherit nopCilVisitor
+
+ method vfunc fd =
+ if String.compare fd.svar.vname (!live_func) = 0 then
+ (Cfg.clearCFGinfo fd;
+ ignore(Cfg.cfgFun fd);
+ computeLiveness fd;
+ if String.compare (!live_label) "" = 0 then
+ (printer := min_print;
+ print_everything();
+ SkipChildren)
+ else DoChildren)
+ else SkipChildren
+
+ method vstmt s =
+ if List.exists match_label s.labels then try
+ let vs = IH.find LiveFlow.stmtStartData s.sid in
+ (printer := min_print;
+ ignore(printf "%a" LiveFlow.pretty vs);
+ SkipChildren)
+ with Not_found ->
+ if !debug then ignore(E.log "Liveness: stmt: %d not found\n" s.sid);
+ DoChildren
+ else
+ (if List.length s.labels = 0 then
+ if !debug then ignore(E.log "Liveness: no label at sid=%d\n" s.sid);
+ DoChildren)
+
+end
+
+let do_live_feature (f:file) =
+ visitCilFile (new doFeatureClass) f
+
+let feature =
+ {
+ fd_name = "Liveness";
+ fd_enabled = ref false;
+ fd_description = "Spit out live variables at a label";
+ fd_extraopt = [
+ "--live_label",
+ Arg.String (fun s -> live_label := s),
+ " Output the variables live at this label";
+ "--live_func",
+ Arg.String (fun s -> live_func := s),
+ " Output the variables live at each statement in this function.";
+ "--live_debug",
+ Arg.Unit (fun n -> debug := true),
+ " Print lots of debugging info";];
+ fd_doit = do_live_feature;
+ fd_post_check = false
+ }
--- /dev/null
+(** See copyright notice at the end of this file *)
+
+(** Add printf before each function call *)
+
+open Pretty
+open Cil
+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 *)
+ (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 : featureDescr =
+ { fd_name = "logcalls";
+ fd_enabled = Cilutil.logCalls;
+ 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
+ }
+
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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: Cil.featureDescr
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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
+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 : featureDescr =
+ { fd_name = "logwrites";
+ fd_enabled = Cilutil.logWrites;
+ 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;
+ }
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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 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\n" fname);
+ if not hasRet && retval <> None then
+ E.s (error "Found return in subroutine %s\n" 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 _ | 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 : featureDescr =
+ { fd_name = "oneRet";
+ fd_enabled = Cilutil.doOneRet;
+ 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;
+ }
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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 : Cil.featureDescr
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(* Define some utilities for optimization *)
+open Cil
+open Pretty
+
+module E = Errormsg
+
+(** A normal form for expression that generalizes constant folding: *)
+(* E = n0 * E0 + n *)
+(* where n0 and n are constants *)
+type normalExp = (
+ int * exp (* A scaled expression *)
+ * int (* plus a constant *)
+ ) option
+
+(** A normal form for addresses that exposes the base, address and the index *)
+(* A = Base + scale * Index + offset *)
+(* where scale and offset are constants *)
+(* and Base is an Lval, AddrOf, StartOf *)
+(* all arithemtic is done on integer types *)
+(** We keep a normal form for addresses *)
+type normalAddr = (
+ exp (* The base address, a Lval, AddrOf, StartOf *)
+ * int * exp (* A scale (maybe 0) times an index *)
+ * int (* An offset *)
+ ) option
+
+let d_nexp () = function
+ None -> text "NoNormExp"
+ | Some (s, i, o) -> dprintf "%d*%a+%d" s d_exp i o
+
+let d_naddr () = function
+ None -> text "NoNormAddr"
+ | Some (b, s, i, o) -> dprintf "%a+%d*%a+%d" d_exp b s d_exp i o
+
+
+(** Multiply a normalized expression *)
+let multNormalExp (ne: normalExp) (fact: int) : normalExp =
+ match ne with
+ None -> None
+ | Some (s, e, o) -> Some (s * fact, e, o * fact)
+
+(* Add two normalized expressions *)
+let addNormalExp (ne: normalExp) (ne': normalExp) : normalExp =
+ match ne, ne' with
+ None, _ -> None
+ | _, None -> None
+ | Some (s, e, o), Some (s', e', o') ->
+ if s = 0 then Some (s', e', o + o')
+ else if s' = 0 then Some (s, e, o + o')
+ else
+ (* Both s and s' are non-null. Hope that e are the same *)
+ if e == e' then
+ Some (s + s', e, o + o')
+ else
+ None
+
+(* Add a normal expression to a normal address *)
+let addNormalAddr (na: normalAddr) (ne: normalExp): normalAddr =
+ match na, ne with
+ None, _ -> None
+ | _, None -> None
+ | Some (b, s, i, o), Some (s', i', o') -> begin
+ match addNormalExp (Some (s, i, o)) (Some (s', i', o')) with
+ None -> None
+ | Some (s'', i'', o'') -> Some (b, s'', i'', o'')
+ end
+
+(** Normalize an expression *)
+let rec normalizeExp (e: exp) : normalExp =
+ match e with
+ CastE(_, e) -> normalizeExp e
+ | Const(CInt64(i, _, _)) -> Some (0, zero, Int64.to_int i)
+ | BinOp(PlusA, e1, e2, _) ->
+ addNormalExp (normalizeExp e1) (normalizeExp e2)
+ | BinOp(MinusA, e1, e2, _) ->
+ addNormalExp (normalizeExp e1) (multNormalExp (normalizeExp e2) (-1))
+ | BinOp(Mult, Const(CInt64(i, _, _)), e2, _) ->
+ multNormalExp (normalizeExp e2) (Int64.to_int i)
+ | BinOp(Mult, e1, Const(CInt64(i, _, _)), _) ->
+ multNormalExp (normalizeExp e1) (Int64.to_int i)
+ | SizeOf (t) -> begin
+ try
+ Some (0, zero, bitsSizeOf t / 8)
+ with _ -> None
+ end
+ | SizeOfE (e) -> begin
+ try
+ Some (0, zero, bitsSizeOf (typeOf e) / 8)
+ with _ -> None
+ end
+ | e -> Some (1, e, 0)
+
+(** Normalize an address *)
+let rec normalizeAddr (a: exp): normalAddr =
+ match a with
+ | CastE (_, a) -> normalizeAddr a
+ | StartOf _ | Lval _ -> Some (a, 0, zero, 0)
+ | BinOp((PlusPI|IndexPI), a, off, TPtr(bt, _)) -> begin
+ try
+ let bt_size = bitsSizeOf bt / 8 in
+ addNormalAddr (normalizeAddr a)
+ (multNormalExp (normalizeExp off) bt_size)
+ with _ -> None
+ end
+ | BinOp(MinusPI, a, off, TPtr(bt, _)) -> begin
+ try
+ let bt_size = bitsSizeOf bt / 8 in
+ addNormalAddr (normalizeAddr a)
+ (multNormalExp (normalizeExp off) (- bt_size))
+ with _ -> None
+ end
+ | AddrOf (h, off) -> begin
+ (* Hopefully it is ...[i] *)
+ let rec getHostIndex (off: offset) : (offset * exp) option =
+ match off with
+ | NoOffset -> None
+ | Index(idx, NoOffset) -> Some (NoOffset, idx)
+ | Field (f, off) -> begin
+ match getHostIndex off with
+ None -> None
+ | Some (hoff, idx) -> Some (Field(f, hoff), idx)
+ end
+ | Index(idx0, off) -> begin
+ match getHostIndex off with
+ None -> None
+ | Some (hoff, idx) -> Some (Index(idx0, hoff), idx)
+ end
+ in
+ match getHostIndex off with
+ None -> Some (a, 0, zero, 0)
+ | Some (hoff, idx) ->
+ try
+ let bt_size = bitsSizeOf (typeOfLval (h, off)) / 8 in
+ addNormalAddr
+ (normalizeAddr (StartOf (h, hoff)))
+ (multNormalExp (normalizeExp idx) bt_size)
+ with _ -> None
+ end
+ | _ -> None
+
+(* For debugging
+let normalizeExp (e: exp) : normalExp =
+ let res = normalizeExp e in
+ ignore (E.log "normalizeExp(%a) = %a\n" d_exp e d_nexp res);
+ res
+
+let normalizeAddr (a: exp) : normalAddr =
+ let res = normalizeAddr a in
+ ignore (E.log "normalizeAddr(%a) = %a\n" d_exp a d_naddr res);
+ res
+*)
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(* Define some utilities for optimization *)
+
+(** A normal form for expression that generalizes constant folding: *)
+(* E = n0 * E0 + n *)
+(* where n0 and n are constants *)
+type normalExp = (
+ int * Cil.exp (* A scaled expression *)
+ * int (* plus a constant *)
+ ) option
+
+(** A normal form for addresses that exposes the base, address and the index *)
+(* A = Base + scale * Index + offset *)
+(* where scale and offset are constants *)
+(* and Base is an Lval, AddrOf, StartOf *)
+(* all arithemtic is done on integer types *)
+(** We keep a normal form for addresses *)
+type normalAddr = (
+ Cil.exp (* The base address, a Lval, AddrOf, StartOf *)
+ * int * Cil.exp (* A scale (maybe 0) times an index *)
+ * int (* An offset *)
+ ) option
+
+
+(** Pretty printer for {!Optutil.normalExp} *)
+val d_nexp: unit -> normalExp -> Pretty.doc
+
+(** Pretty printer for {!Optutil.normalAddr} *)
+val d_naddr: unit -> normalAddr -> Pretty.doc
+
+
+(** Normalize an expression *)
+val normalizeExp: Cil.exp -> normalExp
+
+(** Normalize an address *)
+val normalizeAddr: Cil.exp -> normalAddr
+
+
+(** Multiply a normalized expression by an integer factor. *)
+val multNormalExp: normalExp -> int -> normalExp
+
+(** Add two normalized expressions *)
+val addNormalExp: normalExp -> normalExp -> normalExp
+
+(** Add a normal expression to a normal address *)
+val addNormalAddr: normalAddr -> normalExp -> normalAddr
+
--- /dev/null
+(* 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 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;
+ n1.calledBy <- n1.fd :: n1.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 =
+ 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 =
+ 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' = 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' = 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 _ | 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
+ | _ -> 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
+ | 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 isInteger e with
+ Some x -> x <> Int64.zero
+ | 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 !Cilutil.makeCFG then
+ Errormsg.s (Errormsg.error
+ "--dopartial: you must also specify --domakeCFG\n");
+ if not !(Ptranal.feature.fd_enabled) &&
+ !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 : featureDescr = {
+ fd_name = "partial";
+ fd_enabled = Cilutil.doPartial;
+ 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
+}
+
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * Christoph L. Spiel <Christoph.Spiel@partner.bmw.de>
+ * 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.
+ *
+ *)
--- /dev/null
+(*
+ * predabst.ml
+ *
+ * This is a CIL module for computing the
+ * predicate abstraction of a C program.
+ *
+ * It assumes that expressions contain at
+ * most one pointer dereference. I.e.
+ *
+ * Simplify.simplify has been run on the file.
+ *
+ * Also assumes that there has been a pointer analysis after
+ * the simplemem transformation, the results for which
+ * can be accessed through the Ptranal module.
+ *
+ * Further assumes that each function has only one return
+ * of the form "return r" where r is a variable.
+ *)
+
+open Cil
+open Pretty
+open Expcompare
+
+module E = Errormsg
+module P = Ptranal
+module DF = Dataflow
+module IH = Inthash
+module H = Hashtbl
+module U = Util
+module S = Stats
+
+(* Should debugging info be dumped? *)
+let debug = ref false
+
+(* This function should be defined by a client to
+ * specify the predicates in a function that
+ * the abstraction should track *)
+let collectPredicates = ref (fun (fd:fundec) -> [])
+
+(* This function should be set by a client to
+ * specify any instructions that should be ignored
+ * by the analysis *)
+let ignoreInstruction = ref (fun (i:instr) -> false)
+
+(* This function should be set by a client to
+ * indicate that a function has no side-effects *)
+let instrHasNoSideEffects = ref (fun (i:instr) -> false)
+
+(* This function should be set by a client to
+ * obtain asserted predicates from an instruction. i.e.
+ * an assert or other runtime check. *)
+(* (instr -> exp list) ref *)
+let getPredsFromInstr = ref (fun (i:instr) -> [])
+
+
+module ExpIntHash =
+ H.Make(struct
+ type t = exp
+ let equal e1 e2 = compareExpStripCasts e1 e2
+ let hash = H.hash
+ end)
+
+
+module type TRANSLATOR =
+ sig
+ type exp
+ type unop = exp -> exp
+ type binop = exp -> exp -> exp
+ val mkTrue : unit -> exp
+ val mkFalse : unit -> exp
+
+ val mkAnd : binop
+ val mkOr : binop
+ val mkNot : unop
+ val mkIte : exp -> exp -> exp -> exp
+ val mkImp : binop
+
+ val mkEq : binop
+ val mkNe : binop
+ val mkLt : binop
+ val mkLe : binop
+ val mkGt : binop
+ val mkGe : binop
+
+ val mkPlus : binop
+ val mkTimes : binop
+ val mkMinus : binop
+ val mkDiv : binop
+ val mkMod : binop
+ val mkLShift : binop
+ val mkRShift : binop
+ val mkBAnd : binop
+ val mkBXor : binop
+ val mkBOr : binop
+
+ val mkNeg : unop
+ val mkCompl : unop
+
+ val mkVar : string -> exp
+ val mkConst : int -> exp
+
+ val isValid : exp -> bool
+
+ end
+
+module NullTranslator : TRANSLATOR =
+ struct
+ type exp = int
+ type unop = int -> int
+ type binop = int -> int -> int
+
+ let binop x y = 0
+ let unop x = 0
+
+ let mkTrue () = 0
+ let mkFalse () = 0
+
+ let mkAnd = binop
+ let mkOr = binop
+ let mkNot = unop
+ let mkIte i t e = 0
+ let mkImp = binop
+
+ let mkEq = binop
+ let mkNe = binop
+ let mkLt = binop
+ let mkLe = binop
+ let mkGt = binop
+ let mkGe = binop
+
+ let mkPlus = binop
+ let mkTimes = binop
+ let mkMinus = binop
+ let mkDiv = binop
+ let mkMod = binop
+ let mkLShift = binop
+ let mkRShift = binop
+ let mkBAnd = binop
+ let mkBXor = binop
+ let mkBOr = binop
+
+ let mkNeg = unop
+ let mkCompl = unop
+
+ let mkVar s = 0
+ let mkConst i = 0
+
+ let isValid i = false
+
+ end
+
+module type SOLVER =
+ sig
+ type exp
+
+ val transExp : Cil.exp -> exp
+
+ (* does the first exp imply the second *)
+ val isValid : exp -> exp -> bool
+ end
+
+(* Takes a translator and produces a solver *)
+module Solver = functor(T:TRANSLATOR) ->
+ struct
+ type exp = T.exp
+
+ exception NYI
+
+ let transUnOp op e =
+ match op with
+ | Neg -> T.mkNeg e
+ | BNot -> T.mkCompl e
+ | _ -> raise NYI
+
+ let transBinOp op e1 e2 =
+ match op with
+ | PlusA | PlusPI | IndexPI -> T.mkPlus e1 e2
+ | MinusA | MinusPI | MinusPP -> T.mkMinus e1 e2
+ | Mult -> T.mkTimes e1 e2
+ | Div -> T.mkDiv e1 e2
+ | Mod -> T.mkMod e1 e2
+ | Shiftlt -> T.mkLShift e1 e2
+ | Shiftrt -> T.mkRShift e1 e2
+ | Lt -> T.mkLt e1 e2
+ | Gt -> T.mkGt e1 e2
+ | Le -> T.mkLe e1 e2
+ | Ge -> T.mkGe e1 e2
+ | Eq -> T.mkEq e1 e2
+ | Ne -> T.mkNe e1 e2
+ | BAnd -> T.mkBAnd e1 e2
+ | BXor -> T.mkBXor e1 e2
+ | BOr -> T.mkBOr e1 e2
+ | LAnd -> T.mkAnd e1 e2
+ | LOr -> T.mkOr e1 e2
+
+ let rec transExp e =
+ match e with
+ | Const(CInt64(v,k,so)) -> T.mkConst (Int64.to_int v)
+ | Const _ -> raise NYI
+ | Lval(Var vi,NoOffset) when vi.vname = "_ZERO_" ->
+ T.mkConst 0
+ | Lval l -> T.mkVar (sprint 80 (d_lval () l))
+ | UnOp(op,e,_) ->
+ let e = transExp e in
+ transUnOp op e
+ | BinOp(op,e1,e2,_) ->
+ let e1 = transExp e1 in
+ let e2 = transExp e2 in
+ transBinOp op e1 e2
+ | SizeOf typ -> T.mkConst ((bitsSizeOf typ)/8)
+ | SizeOfE e -> transExp (SizeOf(typeOf e))
+ | SizeOfStr s -> T.mkConst (1 + String.length s)
+ | AlignOf typ -> T.mkConst (alignOf_int typ)
+ | AlignOfE e -> transExp (AlignOf(typeOf e))
+ | CastE(typ,e) -> transExp e
+ (* Cast should check if signed type, and if so, make an ite term *)
+ | AddrOf lv -> T.mkVar (sprint 80 (d_exp () e))
+ | StartOf lv -> T.mkVar (sprint 80 (d_exp () e))
+
+ let isValid e1 e2 =
+ let e_imp = T.mkImp e1 e2 in
+ T.isValid e_imp
+
+ end
+
+module NullSolver = Solver(NullTranslator)
+
+module PredAbst = functor(S:SOLVER) ->
+ struct
+ type boolLat = True | False | Top | Bottom
+
+ let combineBoolLat b1 b2 = match b1,b2 with
+ | Top, _
+ | _, Top
+ | True, False
+ | False, True -> Top
+ | b, Bottom
+ | Bottom, b -> b
+ | _, _ when b1 = b2 -> b1
+ | _, _ -> Bottom
+
+ let d_bl () bl = match bl with
+ | True -> text "True"
+ | False -> text "False"
+ | Top -> text "Top"
+ | Bottom -> text "Bottom"
+
+ type funcSig =
+ {
+ (* The set of formal parameters of the procedure *)
+ mutable fsFormals : varinfo list;
+
+ (* The return variable of the procedure *)
+ mutable fsReturn : varinfo option;
+
+ (* All of the predicates relevant to a function *)
+ mutable fsAllPreds : exp list;
+
+ (* Predicates of the procedure that refer only
+ * to the formals *)
+ mutable fsFPPreds : exp list;
+
+ (* Predicates of the procedure that refer only
+ * to the return variable and formals and
+ * which refer to globals or dereferences of formals *)
+ mutable fsRetPreds : exp list;
+ }
+
+ (* A list of mappings from predicate id to an element of the
+ * boolean lattice for a list of instructions, or just one
+ * such mapping for any other statement. *)
+ type stmtState =
+ | ILState of (boolLat IH.t) list
+ | StmState of boolLat IH.t
+
+ type absState = stmtState IH.t
+
+ type context =
+ {
+ mutable cFuncSigs : funcSig IH.t;
+ mutable cPredicates : exp IH.t;
+ mutable cRPredMap : int ExpIntHash.t;
+ mutable cNextPred : int;
+ }
+
+ let emptyContext () =
+ {
+ cFuncSigs = IH.create 100;
+ cPredicates = IH.create 100;
+ cRPredMap = ExpIntHash.create 100;
+ cNextPred = 0;
+ }
+
+ (**********************************
+ *
+ * Functions and classes for making the function signatures.
+ *
+ **********************************)
+
+ class returnFinderClass vor = object(self)
+ inherit nopCilVisitor
+
+ method vstmt s = match s.skind with
+ | Return(Some(Lval(Var vi,NoOffset)),_) -> begin
+ vor := Some(vi);
+ SkipChildren
+ end
+ | _ -> DoChildren
+
+ end
+
+ let findReturn (fd:fundec) =
+ let vor = ref None in
+ ignore(visitCilFunction (new returnFinderClass vor) fd);
+ !vor
+
+ class viFinderClass vi br = object(self)
+ inherit nopCilVisitor
+
+ method vvrbl vi' =
+ if vi.vid = vi'.vid
+ then (br := true; SkipChildren)
+ else DoChildren
+
+ end
+
+ let expContainsVi e vi =
+ let br = ref false in
+ let vis = new viFinderClass vi br in
+ ignore(visitCilExpr vis e);
+ !br
+
+ class derefFinderClass vi br = object(self)
+ inherit nopCilVisitor
+
+ method vlval lv = match lv with
+ | (Mem(Lval(Var vi,_)),_) -> begin
+ br := true;
+ SkipChildren
+ end
+ | _ -> DoChildren
+
+ end
+
+ let expContainsDeref e vi =
+ let br = ref false in
+ let vis = new derefFinderClass vi br in
+ ignore(visitCilExpr vis e);
+ !br
+
+ class globalFinderClass br = object(self)
+ inherit nopCilVisitor
+ method vvrbl vi =
+ if vi.vglob then br := true;
+ DoChildren
+ end
+
+ let expContainsGlobal e =
+ let br = ref false in
+ let vis = new globalFinderClass br in
+ ignore(visitCilExpr vis e);
+ !br
+
+ class aliasFinderClass ae br = object(self)
+ inherit nopCilVisitor
+ method vexpr e =
+ if Ptranal.may_alias e ae then br := true;
+ DoChildren
+ end
+
+ (* Does he contain an alias to ae? *)
+ let expHasAlias e ae =
+ let br = ref false in
+ let vis = new aliasFinderClass ae br in
+ ignore(visitCilExpr vis e);
+ !br
+
+ (* filter out predicates from preds that refer to locals *)
+ let makeFormalPreds (locals : varinfo list)
+ (preds : exp list)
+ =
+ List.filter
+ (fun e -> not(List.exists (expContainsVi e) locals))
+ preds
+
+ (* filter out predicates from pred that contain locals
+ * and that don't refer to globals or dereferences of
+ * formals *)
+ let makeReturnPreds (ret : varinfo option)
+ (locals : varinfo list)
+ (formals : varinfo list)
+ (preds : exp list)
+ (fpreds : exp list)
+ =
+ let localsNoRet =
+ match ret with
+ | Some ret ->
+ List.filter
+ (fun vi -> not(vi.vid = ret.vid))
+ locals
+ | None -> locals
+ in
+ let retPreds = makeFormalPreds localsNoRet preds in
+ let retPreds =
+ match ret with
+ | Some ret ->
+ List.filter
+ (fun e -> not(expContainsVi e ret))
+ retPreds
+ | None -> retPreds
+ in
+ let retPreds' = List.filter
+ (fun e -> (expContainsGlobal e) ||
+ (List.exists (expContainsDeref e) formals))
+ fpreds in
+ retPreds@retPreds'
+
+ let funSigHash = IH.create 100
+ class funcSigMakerClass = object(self)
+ inherit nopCilVisitor
+
+ method vfunc fd =
+ if IH.mem funSigHash fd.svar.vid then SkipChildren else
+ let formals = fd.sformals in
+ let locals = fd.slocals in
+ let ret = findReturn fd in
+ let preds = !collectPredicates fd in
+ let formalPreds = makeFormalPreds locals preds in
+ let returnPreds = makeReturnPreds ret locals formals
+ preds formalPreds in
+ let fs = { fsFormals = formals;
+ fsReturn = ret;
+ fsAllPreds = preds;
+ fsFPPreds = formalPreds;
+ fsRetPreds = returnPreds;} in
+ IH.add funSigHash fd.svar.vid fs;
+ SkipChildren
+
+ end
+
+ let makeFunctionSigs (f:file) =
+ IH.clear funSigHash;
+ visitCilFileSameGlobals (new funcSigMakerClass) f;
+ funSigHash
+
+ let h_equals h1 h2 =
+ (* must be the same length *)
+ IH.fold (fun pid bl b ->
+ b &&
+ try let bl2 = IH.find h2 pid in
+ bl = bl2
+ with Not_found -> false)
+ h1 true
+
+ let hl_equals hl1 hl2 =
+ List.fold_left2
+ (fun b h1 h2 -> b && (h_equals h1 h2))
+ true hl1 hl2
+
+ let h_combine h1 h2 =
+ let h' = IH.copy h1 in
+ IH.iter (fun pid bl1 ->
+ try let bl2 = IH.find h2 pid in
+ IH.replace h' pid (combineBoolLat bl1 bl2)
+ with Not_found -> ()) h1;
+ h'
+
+ let hl_combine hl1 hl2 =
+ List.map
+ (fun (h1, h2) -> h_combine h1 h2)
+ (List.combine hl1 hl2)
+
+ let substitute (rhse : exp) (* for *)
+ (lv : lval) (* in *)
+ (e : exp)
+ =
+ (* return a list of a list of conjuncts that are the aliasing
+ * constraints, and the expression we get when those
+ * constraints are satisfied *)
+ let rec helper e =
+ match e with
+ | Const _ -> [(one,e)]
+ | AddrOf(Var v, NoOffset) -> [(one, e)]
+ | StartOf(Var v, NoOffset) -> [(one, e)]
+ | Lval(Mem me, NoOffset) ->
+ if Ptranal.may_alias me (AddrOf lv) then
+ [(BinOp(Eq,me,AddrOf lv,intType),
+ rhse);
+ (UnOp(LNot,BinOp(Eq,me,AddrOf lv,intType),intType),
+ e)]
+ else [(one,e)]
+ | Lval(Var v, off) ->
+ if compareLval (Var v, off) lv then
+ [(one,rhse)]
+ else
+ [(one,e)]
+ | BinOp(op, e1, e2,t) ->
+ let pl1 = helper e1 in
+ let pl2 = helper e2 in
+ (* for every pair of things from pl1 and pl2 *)
+ List.fold_left (fun l (c1,e1) ->
+ l @ (List.map (fun (c2,e2) ->
+ (BinOp(LAnd,c1,c2,intType),BinOp(op,e1,e2,t))) pl2))
+ [] pl1
+ | UnOp(op, e, t) ->
+ let pl = helper e in
+ List.map (fun (c,e) ->
+ (c,UnOp(op,e,t)))
+ pl
+ | CastE(t, e) ->
+ let pl = helper e in
+ List.map (fun (c,e) ->
+ (c,CastE(t,e)))
+ pl
+ | _ -> raise (E.s "Simplify has not been run\n")
+ in
+ let makeDisjunction pl =
+ List.fold_left (fun d (c,e) ->
+ BinOp(LOr,d,BinOp(LAnd,c,e,intType),intType))
+ zero pl
+ in
+ let rec cleanUpExp e = match e with
+ | BinOp(LAnd,e1,e2,_) when compareExp (cleanUpExp e1) one ->
+ cleanUpExp e2
+ | BinOp(LAnd,e1,e2,_) when compareExp (cleanUpExp e2) one ->
+ cleanUpExp e1
+ | BinOp(LOr,e1,e2,_) when compareExp (cleanUpExp e1) zero ->
+ cleanUpExp e2
+ | BinOp(LOr,e1,e2,_) when compareExp (cleanUpExp e2) zero ->
+ cleanUpExp e1
+ | UnOp(LNot,e,_) when compareExp (cleanUpExp e) one ->
+ zero
+ | UnOp(LNot,e,_) when compareExp (cleanUpExp e) zero ->
+ one
+ | _ -> e
+ in
+ cleanUpExp (makeDisjunction (helper e))
+
+
+ (* computes WP(i,e) as Some(wp) *)
+ let weakestPrecondition (i : instr)
+ (e : exp)
+ =
+ match i with
+ | Set((Var vi, off) as lh, rhse, l) ->
+ Some(substitute rhse (* for *) lh (* in *) e)
+ | Set((Mem me, NoOffset) as lh, rhse, l) ->
+ Some(substitute rhse (* for *) lh (* in *) e)
+ | Set(_,_,_) -> raise (E.s "Simplify has not been run\n")
+ | _ -> None (* Call and Asm are handled elsewhere *)
+
+
+ let getPred (ctxt : context)
+ (pid : int)
+ =
+ (* if pid isn't mapped, then there is a bug, so don't
+ try to handle Not_found *)
+ IH.find ctxt.cPredicates pid
+
+
+ (* Use the state and any extra conjuncts to build a precondition.
+ * Add to the new state any preds that are implied, and combine
+ * with the old state. *)
+ let buildPreAndTest (ctxt : context) (* The context *)
+ (inss : boolLat IH.t) (* The new in-state *)
+ (oldss : boolLat IH.t) (* The old out-state *)
+ (extra : exp list) (* extra conjuncts *)
+ (dowp : bool) (* whether wp should be calc'd *)
+ (io : instr option) (* instruction if wp is calc'd *)
+ =
+ let inss' = IH.copy inss in
+ let pre =
+ IH.fold (fun pid bl pre ->
+ (* XXX: do optimizations here. *)
+ match bl with
+ | Top | Bottom -> pre
+ | True -> BinOp(LAnd,pre,getPred ctxt pid,intType)
+ | False -> BinOp(LAnd,pre,UnOp(LNot,getPred ctxt pid,intType),intType))
+ inss one
+ in
+ let pre =
+ List.fold_left (fun ce e ->
+ BinOp(LAnd,ce,e,intType))
+ pre extra
+ in
+ IH.iter (fun pid bl ->
+ let e = getPred ctxt pid in
+ let wp =
+ if dowp then
+ match io with
+ | Some i -> begin
+ match weakestPrecondition i e with
+ | Some wp -> wp
+ | None -> raise (E.s "given instr had no wp\n")
+ end
+ | None -> raise (E.s "No instruction for wp calc.\n")
+ else
+ e
+ in
+ let oldbl = try IH.find oldss pid with Not_found -> Bottom in
+ if S.isValid (S.transExp pre) (S.transExp wp) then
+ IH.replace inss' pid (combineBoolLat True oldbl)
+ else if S.isValid (S.transExp pre) (S.transExp (UnOp(LNot,e,intType)))
+ then
+ IH.replace inss' pid (combineBoolLat False oldbl)
+ else
+ IH.replace inss' pid Top)
+ inss;
+ inss'
+
+
+ (* determine if inss => wp(i,e).
+ If so, merge assertion of e with oldss *)
+ let handleSetInstr (ctxt : context)
+ (asserted : exp list)
+ (inss : boolLat IH.t)
+ (i : instr)
+ (oldss : boolLat IH.t)
+ =
+ buildPreAndTest ctxt inss oldss asserted true (Some i)
+
+
+ let handleCallInstr (ctxt : context)
+ (asserted : exp list)
+ (inss : boolLat IH.t)
+ (i : instr)
+ (oldss : boolLat IH.t)
+ =
+ match i with
+ | Call(lvo, Lval(Var vi, NoOffset), el, _) -> begin
+ (* This function wasn't extern, so it has to be defined here *)
+ let fsig = IH.find ctxt.cFuncSigs vi.vid in
+ (* replace the formals in rpreds with the
+ expressions given as arguments *)
+ let rpreds =
+ List.map (fun e ->
+ List.fold_left2 (fun e vi ae ->
+ substitute ae (* for *) (Var vi, NoOffset) (* in *) e)
+ e fsig.fsFormals el)
+ fsig.fsRetPreds
+ in
+ let rpreds =
+ match lvo, fsig.fsReturn with
+ | None, None -> rpreds
+ | Some lv, Some rvi ->
+ (* replace fsig.fsReturn in rpreds with Lval(lv) *)
+ List.map (fun e ->
+ substitute (Lval lv) (* for *) (Var rvi,NoOffset) (* in *) e)
+ rpreds
+ | _, _ -> raise (E.s "fsReturn is wrong in handleCallInstr\n")
+ in
+ buildPreAndTest ctxt inss oldss (rpreds@asserted) false None
+ end
+ | _ -> raise (E.s "Bad instr in handleCallInstr\n")
+
+
+ (* move predicates containing globals or dereferences of exps
+ * that alias exps in args or the return value to Top *)
+ let fixForExternCall (ctxt : context)
+ (inss : boolLat IH.t)
+ (reto : lval option)
+ (args : exp list)
+ =
+ let inss' = IH.copy inss in
+ let args =
+ match reto with
+ | Some lv -> (Lval lv)::args
+ | None -> args
+ in
+ IH.iter (fun pid bl ->
+ let e = getPred ctxt pid in
+ if List.exists (expHasAlias e) args ||
+ expContainsGlobal e
+ then IH.replace inss' pid Top)
+ inss;
+ inss'
+
+
+ let handleIl (ctxt : context)
+ (il : instr list)
+ (ss : stmtState)
+ =
+ match ss with
+ | StmState _ -> raise (E.s "StmState for instruction list?\n")
+ | ILState hl -> begin
+ let newhl =
+ List.fold_left (fun inss (i,oldss) ->
+ (* if i is a Set:
+ =>determine if inss => wp(i,e), if so, merge assertion of e
+ with oldss.
+ similarly for not(e).
+ if i is a Call:
+ =>assert things implied by predicates in E_r.
+ combine with oldss.
+ if i is inline assembly.
+ =>give up! (but fix later)
+ *)
+ if !ignoreInstruction i then inss else
+ let asserted = !getPredsFromInstr i in
+ match i with
+ | Set(_,_,_) ->
+ (handleSetInstr ctxt asserted (List.hd inss) i oldss)::inss
+ | Call(lvo,Lval(Var vi,NoOffset),el,l)
+ when not(vi.vstorage = Extern) ->
+ (handleCallInstr ctxt asserted (List.hd inss) i oldss)::inss
+ | Call(lvo,_,el,_) -> begin
+ (* There are 2 cases:
+ 1. no side-effects: assert consequences of things in asserted
+ 2. side-effects: move predicates with globals or
+ which contain dereferences of
+ aliases of pointer arguments to Top, assert
+ consequences of things in asserted *)
+ if !instrHasNoSideEffects i then
+ let inhd = List.hd inss in
+ (buildPreAndTest ctxt inhd oldss asserted false None)::inss
+ else
+ let inhd = fixForExternCall ctxt (List.hd inss) lvo el in
+ (buildPreAndTest ctxt inhd oldss asserted false None)::inss
+ end
+ | Asm(_,_,_,_,_,_) -> begin
+ (* all go to top for now *)
+ let inss' = IH.copy (List.hd inss) in
+ IH.iter (fun pid _ -> IH.replace inss' pid Top) inss';
+ inss'::inss
+ end) [(List.hd hl)] (List.combine il (List.tl hl))
+ in
+ ILState(List.rev newhl)
+ end
+
+ let handleStmt (ctxt : context)
+ (stm : stmt)
+ (ss : stmtState)
+ =
+ match stm.skind with
+ | Instr il -> handleIl ctxt il ss
+ | _ -> ss
+
+ (* add the set of things implied by e to ss *)
+ let handleBranch (ctxt : context)
+ (e : exp)
+ (ss : stmtState)
+ =
+ (* go through each of the predicates and assert the
+ * ones that are implied by the condition *)
+ let inss =
+ match ss with
+ | ILState hl -> List.hd hl
+ | StmState h -> h
+ in
+ StmState(buildPreAndTest ctxt inss (IH.create 16) [e] false None)
+
+
+ let rec listInit n x =
+ if n = 0 then [] else x::(listInit (n-1) x)
+
+ let currentContext = emptyContext()
+ module PredFlow =
+ struct
+ let name = "Predicate Flow"
+
+ let debug = debug
+
+ type t = stmtState
+
+ let copy ss = match ss with
+ | ILState hl -> begin
+ ILState(List.map (fun h -> IH.copy h) hl)
+ end
+ | StmState h -> StmState(IH.copy h)
+
+ let stmtStartData = IH.create 100
+
+ let pretty () ss = match ss with
+ | ILState hl -> begin
+ line ++ seq line (fun h ->
+ seq line (fun (pid,bl) ->
+ text "PF: pid: " ++ num pid ++ text ": " ++
+ (d_bl () bl)) (IH.tolist h)) hl
+ end
+ | StmState h -> begin
+ line ++ seq line (fun (pid,bl) ->
+ text "PF: pid: " ++ num pid ++ text ": " ++
+ (d_bl () bl)) (IH.tolist h)
+ end
+
+ let computeFirstPredecessor stm ss =
+ let h =
+ match ss with
+ | ILState hl -> List.hd (List.rev hl)
+ | StmState h -> h
+ in
+ match stm.skind with
+ | Instr il ->
+ (* +1 so that we have the state *into* the first instruction
+ at the head of the list *)
+ ILState(listInit ((List.length il) + 1) h)
+ | _ -> StmState h
+
+ let combinePredecessors (stm:stmt) ~(old:t) (ss:t) =
+ match old,ss with
+ | ILState hlold, ILState hlnew -> begin
+ if hl_equals hlold hlnew then None else
+ Some(ILState(hl_combine hlold hlnew))
+ end
+ | StmState hold, StmState hnew -> begin
+ if h_equals hold hnew then None else
+ Some(StmState(h_combine hold hnew))
+ end
+ | _, _ -> raise (E.s "PredFlow: old and new states different type\n")
+
+ (* Take care of everything in doStmt and doGuard *)
+ let doInstr i ss = DF.Default
+
+ let doStmt stm ss = DF.SUse(handleStmt currentContext stm ss)
+
+ let doGuard e ss = DF.GUse(handleBranch currentContext e ss)
+
+ let filterStmt stm = true
+
+ end
+
+ module PA = DF.ForwardsDataFlow(PredFlow)
+
+ let registerFile (f : file) : unit =
+ (* add the function signatures to currentContext *)
+ currentContext.cFuncSigs <- makeFunctionSigs f
+
+ let makePreds (el : exp list) : unit =
+ IH.clear currentContext.cPredicates;
+ ExpIntHash.clear currentContext.cRPredMap;
+ List.iter (fun e ->
+ if not(ExpIntHash.mem currentContext.cRPredMap e) then begin
+ let pid = currentContext.cNextPred in
+ currentContext.cNextPred <- pid + 1;
+ IH.add currentContext.cPredicates pid e;
+ ExpIntHash.add currentContext.cRPredMap e pid
+ end)
+ el
+
+ let makeAllBottom (eh : exp IH.t) : boolLat IH.t =
+ let blh = IH.create 100 in
+ IH.iter (fun pid _ ->
+ IH.add blh pid Bottom)
+ eh;
+ blh
+
+ let analyze (fd : fundec) : unit =
+ (* take the AllPreds out of the function signature and
+ add them to the context *)
+ let fs =
+ try IH.find currentContext.cFuncSigs fd.svar.vid
+ with Not_found -> raise (E.s "run registerFile on file first\n")
+ in
+ makePreds fs.fsAllPreds;
+ try
+ let slst = fd.sbody.bstmts in
+ let first_stm = List.hd slst in
+ IH.clear PredFlow.stmtStartData;
+ let firstData = makeAllBottom currentContext.cPredicates in
+ IH.add PredFlow.stmtStartData first_stm.sid (StmState firstData);
+ PA.compute [first_stm]
+ with Failure "hd" -> 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")
+
+ let getPAs sid =
+ try Some(IH.find PredFlow.stmtStartData sid)
+ with Not_found -> None
+
+ class paVisitorClass = object(self)
+ inherit nopCilVisitor
+
+ val mutable sid = -1
+
+ val mutable pa_dat_lst = []
+
+ val mutable cur_pa_dat = None
+
+ method vstmt stm =
+ sid <- stm.sid;
+ match getPAs sid with
+ | None -> begin
+ if !debug then
+ ignore(E.log "paVis: stm %d has no data\n" sid);
+ cur_pa_dat <- None;
+ DoChildren
+ end
+ | Some ss -> begin
+ match ss with
+ | StmState eh -> begin
+ cur_pa_dat <- Some eh;
+ DoChildren
+ end
+ | ILState ehl -> begin
+ pa_dat_lst <- ehl;
+ DoChildren
+ end
+ end
+
+ method vinst i =
+ try
+ let data = List.hd pa_dat_lst in
+ cur_pa_dat <- Some data;
+ pa_dat_lst <- List.tl pa_dat_lst;
+ DoChildren
+ with Failure "hd" -> DoChildren
+
+ method get_cur_dat () = cur_pa_dat
+
+ end
+
+ let query (blh : boolLat IH.t) (e : exp) : boolLat =
+ try
+ let pid = ExpIntHash.find currentContext.cRPredMap e in
+ IH.find blh pid
+ with Not_found -> Bottom
+
+ end
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * John Kodumal <jkodumal@eecs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(***********************************************************************)
+(* *)
+(* Exceptions *)
+(* *)
+(***********************************************************************)
+
+exception Inconsistent (* raised if constraint system is inconsistent *)
+exception WellFormed (* raised if types are not well-formed *)
+exception NoContents
+exception APFound (* raised if an alias pair is found, a control
+ flow exception *)
+
+
+module U = Uref
+module S = Setp
+module H = Hashtbl
+module Q = Queue
+
+
+(** Subtyping kinds *)
+type polarity =
+ Pos
+ | Neg
+ | Sub
+
+(** Path kinds, for CFL reachability *)
+type pkind =
+ Positive
+ | Negative
+ | Match
+ | Seed
+
+(** Context kinds -- open or closed *)
+type context =
+ Open
+ | Closed
+
+(* A configuration is a context (open or closed) coupled with a pair
+ of stamps representing a state in the cartesian product DFA. *)
+type configuration = context * int * int
+
+module ConfigHash =
+struct
+ type t = configuration
+ let equal t t' = t = t'
+ let hash t = Hashtbl.hash t
+end
+
+module CH = H.Make (ConfigHash)
+
+type config_map = unit CH.t
+
+(** Generic bounds *)
+type 'a bound = {index : int; info : 'a U.uref}
+
+(** For label paths. *)
+type 'a path = {
+ kind : pkind;
+ reached_global : bool;
+ head : 'a U.uref;
+ tail : 'a U.uref
+}
+
+module Bound =
+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)
+end
+
+module Path =
+struct
+ type 'a t = 'a path
+ let compare (x : 'a t) (y : 'a t) =
+ if U.equal (x.head, y.head) then
+ begin
+ 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
+ end
+ else Pervasives.compare (U.deref x.tail) (U.deref y.tail)
+ end
+ else Pervasives.compare (U.deref x.head) (U.deref y.head)
+end
+
+module B = S.Make (Bound)
+
+module P = S.Make (Path)
+
+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
+ for use with the Cil frontend, but for now, this will do *)
+type constant = int * string * Cil.varinfo
+
+module Constant =
+struct
+ type t = constant
+ let compare (xid, _, _) (yid, _, _) = xid - yid
+end
+module C = Set.Make (Constant)
+
+(** Sets of constants. Set union is used when two labels containing
+ constant sets are unified *)
+type constantset = C.t
+
+type lblinfo = {
+ mutable l_name: string;
+ (** either empty or a singleton, the initial location for this label *)
+ loc : constantset;
+ (** Name of this label *)
+ l_stamp : int;
+ (** Unique integer for this label *)
+ mutable l_global : bool;
+ (** True if this location is globally accessible *)
+ mutable aliases: constantset;
+ (** Set of constants (tags) for checking aliases *)
+ mutable p_lbounds: lblinfo boundset;
+ (** Set of umatched (p) lower bounds *)
+ mutable n_lbounds: lblinfo boundset;
+ (** Set of unmatched (n) lower bounds *)
+ mutable p_ubounds: lblinfo boundset;
+ (** Set of umatched (p) upper bounds *)
+ mutable n_ubounds: lblinfo boundset;
+ (** Set of unmatched (n) upper bounds *)
+ mutable m_lbounds: lblinfo boundset;
+ (** Set of matched (m) lower bounds *)
+ mutable m_ubounds: lblinfo boundset;
+ (** Set of matched (m) upper bounds *)
+
+ mutable m_upath: lblinfo pathset;
+ mutable m_lpath: lblinfo pathset;
+ mutable n_upath: lblinfo pathset;
+ mutable n_lpath: lblinfo pathset;
+ mutable p_upath: lblinfo pathset;
+ mutable p_lpath: lblinfo pathset;
+
+ mutable l_seeded : bool;
+ mutable l_ret : bool;
+ mutable l_param : bool;
+}
+
+(** Constructor labels *)
+and label = lblinfo U.uref
+
+(** The type of lvalues. *)
+type lvalue = {
+ l: label;
+ contents: tau
+}
+
+and vinfo = {
+ v_stamp : int;
+ v_name : string;
+
+ mutable v_hole : (int,unit) H.t;
+ mutable v_global : bool;
+ mutable v_mlbs : tinfo boundset;
+ mutable v_mubs : tinfo boundset;
+ mutable v_plbs : tinfo boundset;
+ mutable v_pubs : tinfo boundset;
+ mutable v_nlbs : tinfo boundset;
+ mutable v_nubs : tinfo boundset
+}
+
+and rinfo = {
+ r_stamp : int;
+ rl : label;
+ points_to : tau;
+ mutable r_global: bool;
+}
+
+and finfo = {
+ f_stamp : int;
+ fl : label;
+ ret : tau;
+ mutable args : tau list;
+ mutable f_global : bool;
+}
+
+and pinfo = {
+ p_stamp : int;
+ ptr : tau;
+ lam : tau;
+ mutable p_global : bool;
+}
+
+and tinfo = Var of vinfo
+ | Ref of rinfo
+ | Fun of finfo
+ | Pair of pinfo
+
+and tau = tinfo U.uref
+
+type tconstraint = Unification of tau * tau
+ | Leq of tau * (int * polarity) * tau
+
+
+(** 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
+ 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.
+
+ 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.
+
+ -- In the recursive call, we see that 'a (or ref('a)) is already in the
+ association list, so the type is recursive. We check the string option,
+ which is None, meaning that this is the first recurrence of the type. We
+ create a new recursive variable, rv and set the string option to 'rv. Next,
+ we prepend u rv. to the string representation we have seen before, "ref(",
+ and return "rv" as the string representation of this type.
+
+ -- The string so far is "u rv.ref(". The recursive call returns, and we
+ 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
+ reuse the same recursive variable name.
+*)
+type association = tau * string ref * string option ref
+
+module PathHash =
+struct
+ type t = int list
+ let equal t t' = t = t'
+ let hash t = Hashtbl.hash t
+end
+
+module PH = H.Make (PathHash)
+
+(***********************************************************************)
+(* *)
+(* Global Variables *)
+(* *)
+(***********************************************************************)
+
+(** Print the instantiations constraints. *)
+let print_constraints : bool ref = ref false
+
+(** If true, print all constraints (including induced) and show
+ additional debug output. *)
+let debug = ref false
+
+(** Just debug all the constraints (including induced) *)
+let debug_constraints = ref false
+
+(** Debug smart alias queries *)
+let debug_aliases = ref false
+
+let smart_aliases = ref false
+
+(** If true, make the flow step a no-op *)
+let no_flow = ref false
+
+(** If true, disable subtyping (unification at all levels) *)
+let no_sub = ref false
+
+(** If true, treat indexed edges as regular subtyping *)
+let analyze_mono = ref true
+
+(** A list of equality constraints. *)
+let eq_worklist : tconstraint Q.t = Q.create ()
+
+(** A list of leq constraints. *)
+let leq_worklist : tconstraint Q.t = Q.create ()
+
+let path_worklist : (lblinfo path) Q.t = Q.create ()
+
+let path_hash : (lblinfo path) PH.t = PH.create 32
+
+(** A count of the constraints introduced from the AST. Used for debugging. *)
+let toplev_count = ref 0
+
+(** A hashtable containing stamp pairs of labels that must be aliased. *)
+let cached_aliases : (int * int,unit) H.t = H.create 64
+
+(** A hashtable mapping pairs of tau's to their join node. *)
+let join_cache : (int * int, tau) H.t = H.create 64
+
+(***********************************************************************)
+(* *)
+(* Utility Functions *)
+(* *)
+(***********************************************************************)
+
+let find = U.deref
+
+let die s =
+ Printf.printf "*******\nAssertion failed: %s\n*******\n" s;
+ assert false
+
+let fresh_appsite : (unit -> int) =
+ let appsite_index = ref 0 in
+ fun () ->
+ incr appsite_index;
+ !appsite_index
+
+(** Generate a unique integer. *)
+let fresh_index : (unit -> int) =
+ let counter = ref 0 in
+ fun () ->
+ incr counter;
+ !counter
+
+let fresh_stamp : (unit -> int) =
+ let stamp = ref 0 in
+ fun () ->
+ incr stamp;
+ !stamp
+
+(** Return a unique integer representation of a tau *)
+let get_stamp (t : tau) : int =
+ match find t with
+ Var v -> v.v_stamp
+ | Ref r -> r.r_stamp
+ | Pair p -> p.p_stamp
+ | Fun f -> f.f_stamp
+
+(** Negate a polarity. *)
+let negate (p : polarity) : polarity =
+ match p with
+ Pos -> Neg
+ | Neg -> Pos
+ | Sub -> die "negate"
+
+(** Consistency checks for inferred types *)
+let pair_or_var (t : tau) =
+ match find t with
+ Pair _ -> true
+ | Var _ -> true
+ | _ -> false
+
+let ref_or_var (t : tau) =
+ match find t with
+ Ref _ -> true
+ | Var _ -> true
+ | _ -> false
+
+let fun_or_var (t : tau) =
+ match find t with
+ Fun _ -> true
+ | Var _ -> true
+ | _ -> false
+
+
+
+(** Apply [f] structurally down [t]. Guaranteed to terminate, even if [t]
+ is recursive *)
+let iter_tau f t =
+ let visited : (int,tau) H.t = H.create 4 in
+ let rec iter_tau' t =
+ if H.mem visited (get_stamp t) then () else
+ begin
+ f t;
+ H.add visited (get_stamp t) t;
+ match U.deref t with
+ Pair p ->
+ iter_tau' p.ptr;
+ iter_tau' p.lam
+ | Fun f ->
+ List.iter iter_tau' (f.args);
+ iter_tau' f.ret
+ | Ref r -> iter_tau' r.points_to
+ | _ -> ()
+ end
+ in
+ iter_tau' t
+
+(* Extract a label's bounds according to [positive] and [upper]. *)
+let get_bounds (p :polarity ) (upper : bool) (l : label) : lblinfo boundset =
+ let li = find l in
+ match p with
+ Pos -> if upper then li.p_ubounds else li.p_lbounds
+ | Neg -> if upper then li.n_ubounds else li.n_lbounds
+ | Sub -> if upper then li.m_ubounds else li.m_lbounds
+
+let equal_tau (t : tau) (t' : tau) =
+ get_stamp t = get_stamp t'
+
+let get_label_stamp (l : label) : int =
+ (find l).l_stamp
+
+(** Return true if [t] is global (treated monomorphically) *)
+let get_global (t : tau) : bool =
+ match find t with
+ Var v -> v.v_global
+ | Ref r -> r.r_global
+ | Pair p -> p.p_global
+ | Fun f -> f.f_global
+
+let is_ret_label l = (find l).l_ret || (find l).l_global (* todo - check *)
+
+let is_param_label l = (find l).l_param || (find l).l_global
+
+let is_global_label l = (find l).l_global
+
+let is_seeded_label l = (find l).l_seeded
+
+let set_global_label (l : label) (b : bool) : unit =
+ assert ((not (is_global_label l)) || b);
+ (U.deref l).l_global <- b
+
+(** Aliases for set_global *)
+let global_tau = get_global
+
+
+(** Get_global for lvalues *)
+let global_lvalue lv = get_global lv.contents
+
+
+
+(***********************************************************************)
+(* *)
+(* Printing Functions *)
+(* *)
+(***********************************************************************)
+
+let string_of_configuration (c, i, i') =
+ let context = match c with
+ Open -> "O"
+ | Closed -> "C"
+ in
+ Printf.sprintf "(%s,%d,%d)" context i i'
+
+let string_of_polarity p =
+ match p with
+ Pos -> "+"
+ | Neg -> "-"
+ | Sub -> "M"
+
+(** Convert a label to a string, short representation *)
+let string_of_label (l : label) : string =
+ "\"" ^ (find l).l_name ^ "\""
+
+(** Return true if the element [e] is present in the association list,
+ according to uref equality *)
+let rec assoc_list_mem (e : tau) (l : association list) =
+ match l with
+ | [] -> None
+ | (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 =
+ match find t with
+ Pair p -> "rvp" ^ string_of_int p.p_stamp
+ | Ref r -> "rvr" ^ string_of_int r.r_stamp
+ | Fun f -> "rvf" ^ string_of_int f.f_stamp
+ | _ -> die "fresh_recvar_name"
+
+
+(** Return a string representation of a tau, using association lists. *)
+let string_of_tau (t : tau) : string =
+ let tau_map : association list ref = ref [] in
+ 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
+ match !so with
+ None ->
+ let rv = fresh_recvar_name t in
+ s := "u " ^ rv ^ "." ^ !s;
+ so := Some rv;
+ rv
+ | Some rv -> rv
+ end
+ | None -> (* type's not recursive. Add it to the assoc list and cont. *)
+ let s = ref ""
+ and so : string option ref = ref None in
+ tau_map := (t, s, so) :: !tau_map;
+ begin
+ match find t with
+ Var v -> s := v.v_name;
+ | Pair p ->
+ assert (ref_or_var p.ptr);
+ assert (fun_or_var p.lam);
+ s := "{";
+ s := !s ^ string_of_tau' p.ptr;
+ s := !s ^ ",";
+ s := !s ^ string_of_tau' p.lam;
+ s := !s ^"}"
+ | Ref r ->
+ assert (pair_or_var r.points_to);
+ s := "ref(|";
+ s := !s ^ string_of_label r.rl;
+ s := !s ^ "|,";
+ s := !s ^ string_of_tau' r.points_to;
+ s := !s ^ ")"
+ | Fun f ->
+ assert (pair_or_var f.ret);
+ let rec string_of_args = function
+ h :: [] ->
+ assert (pair_or_var h);
+ s := !s ^ string_of_tau' h
+ | h :: t ->
+ assert (pair_or_var h);
+ s := !s ^ string_of_tau' h ^ ",";
+ string_of_args t
+ | [] -> ()
+ in
+ s := "fun(|";
+ s := !s ^ string_of_label f.fl;
+ s := !s ^ "|,";
+ s := !s ^ "<";
+ if List.length f.args > 0 then string_of_args f.args
+ else s := !s ^ "void";
+ s := !s ^">,";
+ s := !s ^ string_of_tau' f.ret;
+ s := !s ^ ")"
+ end;
+ tau_map := List.tl !tau_map;
+ !s
+ in
+ string_of_tau' t
+
+(** Convert an lvalue to a string *)
+let rec 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 *)
+ Printf.sprintf "[%s]^(%s)" contents l
+
+let print_path (p : lblinfo path) : unit =
+ let string_of_pkind = function
+ Positive -> "p"
+ | Negative -> "n"
+ | Match -> "m"
+ | Seed -> "s"
+ in
+ Printf.printf
+ "%s --%s--> %s (%d) : "
+ (string_of_label p.head)
+ (string_of_pkind p.kind)
+ (string_of_label p.tail)
+ (PathHash.hash p)
+
+(** Print a list of tau elements, comma separated *)
+let rec print_tau_list (l : tau list) : unit =
+ let rec print_t_strings = function
+ h :: [] -> print_endline h
+ | h :: t ->
+ print_string h;
+ print_string ", ";
+ print_t_strings t
+ | [] -> ()
+ in
+ print_t_strings (List.map string_of_tau l)
+
+let print_constraint (c : tconstraint) =
+ match c with
+ Unification (t, t') ->
+ let lhs = string_of_tau t
+ and rhs = string_of_tau t' in
+ Printf.printf "%s == %s\n" lhs rhs
+ | Leq (t, (i, p), t') ->
+ let lhs = string_of_tau t
+ and rhs = string_of_tau t' in
+ Printf.printf "%s <={%d,%s} %s\n" lhs i (string_of_polarity p) rhs
+
+(***********************************************************************)
+(* *)
+(* Type Operations -- these do not create any constraints *)
+(* *)
+(***********************************************************************)
+
+(** Create an lvalue with label [lbl] and tau contents [t]. *)
+let make_lval (lbl, t : label * tau) : lvalue =
+ {l = lbl; contents = t}
+
+let make_label_int (is_global : bool) (name :string) (vio : Cil.varinfo option) : label =
+ let locc =
+ match vio with
+ Some vi -> C.add (fresh_index (), name, vi) C.empty
+ | None -> C.empty
+ in
+ U.uref {
+ l_name = name;
+ l_global = is_global;
+ l_stamp = fresh_stamp ();
+ loc = locc;
+ aliases = locc;
+ p_ubounds = B.empty;
+ p_lbounds = B.empty;
+ n_ubounds = B.empty;
+ n_lbounds = B.empty;
+ m_ubounds = B.empty;
+ m_lbounds = B.empty;
+ m_upath = P.empty;
+ m_lpath = P.empty;
+ n_upath = P.empty;
+ n_lpath = P.empty;
+ p_upath = P.empty;
+ p_lpath = P.empty;
+ l_seeded = false;
+ l_ret = false;
+ l_param = false
+ }
+
+(** Create a new label with name [name]. Also adds a fresh constant
+ with name [name] to this label's aliases set. *)
+let make_label (is_global : bool) (name : string) (vio : Cil.varinfo option) : label =
+ make_label_int is_global name vio
+
+(** Create a new label with an unspecified name and an empty alias set. *)
+let fresh_label (is_global : bool) : label =
+ let index = fresh_index () in
+ make_label_int is_global ("l_" ^ string_of_int index) None
+
+(** Create a fresh bound (edge in the constraint graph). *)
+let make_bound (i, a : int * label) : lblinfo bound =
+ {index = i; info = a}
+
+let make_tau_bound (i, a : int * tau) : tinfo 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_hole = H.create 8;
+ v_stamp = fresh_index ();
+ v_global = b;
+ v_mlbs = B.empty;
+ v_mubs = B.empty;
+ v_plbs = B.empty;
+ v_pubs = B.empty;
+ v_nlbs = B.empty;
+ v_nubs = B.empty})
+
+(** Create a fresh unnamed variable (name will be 'fv). *)
+let fresh_var (is_global : bool) : tau =
+ make_var is_global ("fv" ^ string_of_int (fresh_index ()))
+
+(** Create a fresh unnamed variable (name will be 'fi). *)
+let fresh_var_i (is_global : bool) : tau =
+ make_var is_global ("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_stamp = fresh_index ();
+ f_global = false;
+ args = a;
+ ret = r })
+
+(** Create a Ref constructor. *)
+let make_ref (lbl,pt : label * tau) : tau =
+ U.uref (Ref {rl = lbl;
+ r_stamp = fresh_index ();
+ r_global = false;
+ points_to = pt})
+
+(** Create a Pair constructor. *)
+let make_pair (p,f : tau * tau) : tau =
+ U.uref (Pair {ptr = p;
+ p_stamp = fresh_index ();
+ p_global = false;
+ lam = f})
+
+(** Copy the toplevel constructor of [t], putting fresh variables in each
+ argement of the constructor. *)
+let copy_toplevel (t : tau) : tau =
+ match find t with
+ Pair _ -> make_pair (fresh_var_i false, fresh_var_i false)
+ | Ref _ -> make_ref (fresh_label false, fresh_var_i false)
+ | Fun f ->
+ let fresh_fn = fun _ -> fresh_var_i false in
+ make_fun (fresh_label false,
+ List.map fresh_fn f.args, fresh_var_i false)
+ | _ -> die "copy_toplevel"
+
+
+let has_same_structure (t : tau) (t' : tau) =
+ match find t, find t' with
+ Pair _, Pair _ -> true
+ | Ref _, Ref _ -> true
+ | Fun _, Fun _ -> true
+ | Var _, Var _ -> true
+ | _ -> false
+
+
+let pad_args (f, f' : finfo * finfo) : unit =
+ let padding = ref ((List.length f.args) - (List.length f'.args))
+ in
+ if !padding == 0 then ()
+ else
+ let to_pad =
+ if !padding > 0 then f' else (padding := -(!padding); f)
+ in
+ for i = 1 to !padding do
+ to_pad.args <- to_pad.args @ [fresh_var false]
+ done
+
+
+let pad_args2 (fi, tlr : finfo * tau list ref) : unit =
+ let padding = ref (List.length fi.args - List.length !tlr)
+ in
+ if !padding == 0 then ()
+ else
+ if !padding > 0 then
+ for i = 1 to !padding do
+ tlr := !tlr @ [fresh_var false]
+ done
+ else
+ begin
+ padding := -(!padding);
+ for i = 1 to !padding do
+ fi.args <- fi.args @ [fresh_var false]
+ done
+ end
+
+(***********************************************************************)
+(* *)
+(* Constraint Generation/ Resolution *)
+(* *)
+(***********************************************************************)
+
+
+(** Make the type a global type *)
+let set_global (t : tau) (b : bool) : unit =
+ let set_global_down t =
+ match find t with
+ Var v -> v.v_global <- true
+ | Ref r -> set_global_label r.rl true
+ | Fun f -> set_global_label f.fl true
+ | _ -> ()
+ in
+ if !debug && b then Printf.printf "Set global: %s\n" (string_of_tau t);
+ assert ((not (get_global t)) || b);
+ if b then iter_tau set_global_down t;
+ match find t with
+ Var v -> v.v_global <- b
+ | Ref r -> r.r_global <- b
+ | Pair p -> p.p_global <- b
+ | Fun f -> f.f_global <- b
+
+
+let rec unify_int (t, t' : tau * tau) : unit =
+ if equal_tau t t' then ()
+ else
+ let ti, ti' = find t, find t' in
+ U.unify combine (t, t');
+ match ti, ti' with
+ Var v, Var v' ->
+ set_global t' (v.v_global || get_global t');
+ merge_vholes (v, v');
+ merge_vlbs (v, v');
+ merge_vubs (v, v')
+ | Var v, _ ->
+ set_global t' (v.v_global || get_global t');
+ trigger_vhole v t';
+ notify_vlbs t v;
+ notify_vubs t v
+ | _, Var v ->
+ set_global t (v.v_global || get_global t);
+ trigger_vhole v t;
+ notify_vlbs t' v;
+ notify_vubs t' v
+ | Ref r, Ref r' ->
+ set_global t (r.r_global || r'.r_global);
+ unify_ref (r, r')
+ | Fun f, Fun f' ->
+ set_global t (f.f_global || f'.f_global);
+ unify_fun (f, f')
+ | Pair p, Pair p' -> ()
+ | _ -> raise Inconsistent
+and notify_vlbs (t : tau) (vi : vinfo) : unit =
+ let notify p bounds =
+ List.iter
+ (fun b ->
+ add_constraint (Unification (b.info,copy_toplevel t));
+ add_constraint (Leq (b.info, (b.index, p), t)))
+ bounds
+ in
+ notify Sub (B.elements vi.v_mlbs);
+ notify Pos (B.elements vi.v_plbs);
+ notify Neg (B.elements vi.v_nlbs)
+and notify_vubs (t : tau) (vi : vinfo) : unit =
+ let notify p bounds =
+ List.iter
+ (fun b ->
+ add_constraint (Unification (b.info,copy_toplevel t));
+ add_constraint (Leq (t, (b.index, p), b.info)))
+ bounds
+ in
+ notify Sub (B.elements vi.v_mubs);
+ notify Pos (B.elements vi.v_pubs);
+ notify Neg (B.elements vi.v_nubs)
+and unify_ref (ri,ri' : rinfo * rinfo) : unit =
+ add_constraint (Unification (ri.points_to, ri'.points_to))
+and unify_fun (fi, fi' : finfo * finfo) : unit =
+ let rec union_args = function
+ _, [] -> false
+ | [], _ -> true
+ | h :: t, h' :: t' ->
+ add_constraint (Unification (h, h'));
+ union_args(t, t')
+ in
+ unify_label(fi.fl, fi'.fl);
+ add_constraint (Unification (fi.ret, fi'.ret));
+ if union_args (fi.args, fi'.args) then fi.args <- fi'.args;
+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
+ li.l_name <- li'.l_name
+ else ()
+ in
+ let combine_label (li, li' : lblinfo *lblinfo) : lblinfo =
+ let rm_self b = not (li.l_stamp = get_label_stamp b.info)
+ in
+ pick_name (li, li');
+ li.l_global <- li.l_global || li'.l_global;
+ li.aliases <- C.union li.aliases li'.aliases;
+ li.p_ubounds <- B.union li.p_ubounds li'.p_ubounds;
+ li.p_lbounds <- B.union li.p_lbounds li'.p_lbounds;
+ li.n_ubounds <- B.union li.n_ubounds li'.n_ubounds;
+ li.n_lbounds <- B.union li.n_lbounds li'.n_lbounds;
+ li.m_ubounds <- B.union li.m_ubounds (B.filter rm_self li'.m_ubounds);
+ li.m_lbounds <- B.union li.m_lbounds (B.filter rm_self li'.m_lbounds);
+ li.m_upath <- P.union li.m_upath li'.m_upath;
+ li.m_lpath<- P.union li.m_lpath li'.m_lpath;
+ li.n_upath <- P.union li.n_upath li'.n_upath;
+ li.n_lpath <- P.union li.n_lpath li'.n_lpath;
+ li.p_upath <- P.union li.p_upath li'.p_upath;
+ li.p_lpath <- P.union li.p_lpath li'.p_lpath;
+ li.l_seeded <- li.l_seeded || li'.l_seeded;
+ li.l_ret <- li.l_ret || li'.l_ret;
+ li.l_param <- li.l_param || li'.l_param;
+ li
+ in
+ if !debug_constraints then
+ Printf.printf "%s == %s\n" (string_of_label l) (string_of_label l');
+ U.unify combine_label (l, l')
+and merge_vholes (vi, vi' : vinfo * vinfo) : unit =
+ H.iter
+ (fun i -> fun _ -> H.replace vi'.v_hole i ())
+ vi.v_hole
+and merge_vlbs (vi, vi' : vinfo * vinfo) : unit =
+ vi'.v_mlbs <- B.union vi.v_mlbs vi'.v_mlbs;
+ vi'.v_plbs <- B.union vi.v_plbs vi'.v_plbs;
+ vi'.v_nlbs <- B.union vi.v_nlbs vi'.v_nlbs
+and merge_vubs (vi, vi' : vinfo * vinfo) : unit =
+ vi'.v_mubs <- B.union vi.v_mubs vi'.v_mubs;
+ vi'.v_pubs <- B.union vi.v_pubs vi'.v_pubs;
+ vi'.v_nubs <- B.union vi.v_nubs vi'.v_nubs
+and trigger_vhole (vi : vinfo) (t : tau) =
+ let add_self_loops (t : tau) : unit =
+ match find t with
+ Var v ->
+ H.iter
+ (fun i -> fun _ -> H.replace v.v_hole i ())
+ vi.v_hole
+ | Ref r ->
+ H.iter
+ (fun i -> fun _ ->
+ leq_label (r.rl, (i, Pos), r.rl);
+ leq_label (r.rl, (i, Neg), r.rl))
+ vi.v_hole
+ | Fun f ->
+ H.iter
+ (fun i -> fun _ ->
+ leq_label (f.fl, (i, Pos), f.fl);
+ leq_label (f.fl, (i, Neg), f.fl))
+ vi.v_hole
+ | _ -> ()
+ 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.
+ All other actions (e.g., updating the info) is done in unify_int *)
+and combine (ti, ti' : tinfo * tinfo) : tinfo =
+ match ti, ti' with
+ Var _, _ -> ti'
+ | _, _ -> ti
+and leq_int (t, (i, p), t') : unit =
+ if equal_tau t t' then ()
+ else
+ let ti, ti' = find t, find t' in
+ match ti, ti' with
+ Var v, Var v' ->
+ begin
+ match p with
+ Pos ->
+ v.v_pubs <- B.add (make_tau_bound (i, t')) v.v_pubs;
+ v'.v_plbs <- B.add (make_tau_bound (i, t)) v'.v_plbs
+ | Neg ->
+ v.v_nubs <- B.add (make_tau_bound (i, t')) v.v_nubs;
+ v'.v_nlbs <- B.add (make_tau_bound (i, t)) v'.v_nlbs
+ | Sub ->
+ v.v_mubs <- B.add (make_tau_bound (i, t')) v.v_mubs;
+ v'.v_mlbs <- B.add (make_tau_bound (i, t)) v'.v_mlbs
+ end
+ | Var v, _ ->
+ add_constraint (Unification (t, copy_toplevel t'));
+ add_constraint (Leq (t, (i, p), t'))
+ | _, Var v ->
+ add_constraint (Unification (t', copy_toplevel t));
+ add_constraint (Leq (t, (i, p), t'))
+ | Ref r, Ref r' -> leq_ref (r, (i, p), r')
+ | Fun f, Fun f' -> add_constraint (Unification (t, t'))
+ | Pair pr, Pair pr' ->
+ add_constraint (Leq (pr.ptr, (i, p), pr'.ptr));
+ add_constraint (Leq (pr.lam, (i, p), pr'.lam))
+ | _ -> raise Inconsistent
+and leq_ref (ri, (i, p), ri') : unit =
+ let add_self_loops (t : tau) : unit =
+ match find t with
+ Var v -> H.replace v.v_hole i ()
+ | Ref r ->
+ leq_label (r.rl, (i, Pos), r.rl);
+ leq_label (r.rl, (i, Neg), r.rl)
+ | Fun f ->
+ leq_label (f.fl, (i, Pos), f.fl);
+ leq_label (f.fl, (i, Neg), f.fl)
+ | _ -> ()
+ in
+ iter_tau add_self_loops ri.points_to;
+ add_constraint (Unification (ri.points_to, ri'.points_to));
+ leq_label(ri.rl, (i, p), ri'.rl)
+and leq_label (l,(i, p), l') : unit =
+ if !debug_constraints then
+ Printf.printf
+ "%s <={%d,%s} %s\n"
+ (string_of_label l) i (string_of_polarity p) (string_of_label l');
+ let li, li' = find l, find l' in
+ match p with
+ Pos ->
+ li.l_ret <- true;
+ li.p_ubounds <- B.add (make_bound (i, l')) li.p_ubounds;
+ li'.p_lbounds <- B.add (make_bound (i, l)) li'.p_lbounds
+ | Neg ->
+ li'.l_param <- true;
+ li.n_ubounds <- B.add (make_bound (i, l')) li.n_ubounds;
+ li'.n_lbounds <- B.add (make_bound (i, l)) li'.n_lbounds
+ | Sub ->
+ if U.equal (l, l') then ()
+ else
+ begin
+ li.m_ubounds <- B.add (make_bound(0, l')) li.m_ubounds;
+ li'.m_lbounds <- B.add (make_bound(0, l)) li'.m_lbounds
+ end
+and add_constraint_int (c : tconstraint) (toplev : bool) =
+ if !debug_constraints && toplev then
+ begin
+ Printf.printf "%d:>" !toplev_count;
+ print_constraint c;
+ incr toplev_count
+ end
+ else
+ if !debug_constraints then print_constraint c else ();
+ begin
+ match c with
+ Unification _ -> Q.add c eq_worklist
+ | Leq _ -> Q.add c leq_worklist
+ end;
+ solve_constraints ()
+and add_constraint (c : tconstraint) =
+ add_constraint_int c false
+and add_toplev_constraint (c : tconstraint) =
+ if !print_constraints && not !debug_constraints then
+ begin
+ Printf.printf "%d:>" !toplev_count;
+ incr toplev_count;
+ print_constraint c
+ end
+ else ();
+ add_constraint_int c true
+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
+ Some c ->
+ begin
+ match c with
+ Unification (t, t') -> unify_int (t, t')
+ | Leq (t, (i, p), t') ->
+ if !no_sub then unify_int (t, t')
+ else
+ if !analyze_mono then leq_int (t, (0, Sub), t')
+ else leq_int (t, (i, p), t')
+ end;
+ solve_constraints ()
+ | None -> ()
+
+
+(***********************************************************************)
+(* *)
+(* Interface Functions *)
+(* *)
+(***********************************************************************)
+
+(** Return the contents of the lvalue. *)
+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
+ Pair p ->
+ begin
+ match U.deref p.ptr with
+ Var _ ->
+ let is_global = global_tau p.ptr in
+ let points_to = fresh_var is_global in
+ let l = fresh_label is_global in
+ let r = make_ref (l, points_to)
+ in
+ add_toplev_constraint (Unification (p.ptr, r));
+ make_lval (l, points_to)
+ | Ref r -> make_lval (r.rl, r.points_to)
+ | _ -> raise WellFormed
+ end
+ | Var v ->
+ let is_global = global_tau t in
+ add_toplev_constraint
+ (Unification (t, make_pair (fresh_var is_global,
+ fresh_var is_global)));
+ deref t
+ | _ -> raise WellFormed
+
+(** Form the union of [t] and [t'], if it doesn't exist already. *)
+let join (t : tau) (t' : tau) : tau =
+ try H.find join_cache (get_stamp t, get_stamp t')
+ with Not_found ->
+ let t'' = fresh_var false in
+ add_toplev_constraint (Leq (t, (0, Sub), t''));
+ add_toplev_constraint (Leq (t', (0, Sub), t''));
+ H.add join_cache (get_stamp t, get_stamp t') t'';
+ t''
+
+(** 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 t' = fresh_var false in
+ List.iter
+ (fun t -> add_toplev_constraint (Leq (t, (0, Sub), t')))
+ tl;
+ t'
+
+(** Take the address of an lvalue. Does not add constraints. *)
+let address (lv : lvalue) : tau =
+ make_pair (make_ref (lv.l, lv.contents), fresh_var false)
+
+(** For this version of golf, instantiation is handled at [apply] *)
+let instantiate (lv : lvalue) (i : int) : lvalue =
+ lv
+
+(** Constraint generated from assigning [t] to [lv]. *)
+let assign (lv : lvalue) (t : tau) : unit =
+ add_toplev_constraint (Leq (t, (0, Sub), lv.contents))
+
+let assign_ret (i : int) (lv : lvalue) (t : tau) : unit =
+ add_toplev_constraint (Leq (t, (i, Pos), lv.contents))
+
+(** Project out the first (ref) component or a pair. If the argument [t] has
+ no discovered structure, raise NoContents. *)
+let proj_ref (t : tau) : tau =
+ match U.deref t with
+ Pair p -> p.ptr
+ | Var v -> raise NoContents
+ | _ -> raise WellFormed
+
+(* 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 =
+ match U.deref t with
+ Pair p -> p.lam
+ | Var v ->
+ let p, f = fresh_var false, fresh_var false in
+ add_toplev_constraint (Unification (t, make_pair(p, f)));
+ f
+ | _ -> raise WellFormed
+
+let get_args (t : tau) : tau list =
+ match U.deref t with
+ Fun f -> f.args
+ | _ -> raise WellFormed
+
+let get_finfo (t : tau) : finfo =
+ match U.deref t with
+ Fun f -> f
+ | _ -> raise WellFormed
+
+(** 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 plus the index of this application site. *)
+let apply (t : tau) (al : tau list) : (tau * int) =
+ let i = fresh_appsite () in
+ let f = proj_fun t in
+ let actuals = ref al in
+ let fi,ret =
+ match U.deref f with
+ Fun fi -> fi, fi.ret
+ | Var v ->
+ let new_l, new_ret, new_args =
+ fresh_label false, fresh_var false,
+ List.map (function _ -> fresh_var false) !actuals
+ in
+ let new_fun = make_fun (new_l, new_args, new_ret) in
+ add_toplev_constraint (Unification (new_fun, f));
+ (get_finfo new_fun, new_ret)
+ | _ -> raise WellFormed
+ in
+ pad_args2 (fi, actuals);
+ List.iter2
+ (fun actual -> fun formal ->
+ add_toplev_constraint (Leq (actual,(i, Neg), formal)))
+ !actuals fi.args;
+ (ret, i)
+
+(** 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 false name None,
+ List.map (fun x -> rvalue x) formals,
+ ret)
+ in
+ make_pair (fresh_var false, f)
+
+(** Create an lvalue. If [is_global] is true, the lvalue will be treated
+ monomorphically. *)
+let make_lvalue (is_global : bool) (name : string) (vio : Cil.varinfo option) : lvalue =
+ if !debug && is_global then
+ Printf.printf "Making global lvalue : %s\n" name
+ else ();
+ make_lval (make_label is_global name vio, 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 =
+ make_var false "bottom"
+
+(** Unify the result of a function with its return value. *)
+let return (t : tau) (t' : tau) =
+ add_toplev_constraint (Leq (t', (0, Sub), t))
+
+(***********************************************************************)
+(* *)
+(* Query/Extract Solutions *)
+(* *)
+(***********************************************************************)
+
+let make_summary = leq_label
+
+let path_signature k l l' b : int list =
+ let ksig =
+ match k with
+ Positive -> 1
+ | Negative -> 2
+ | _ -> 3
+ in
+ [ksig;
+ get_label_stamp l;
+ get_label_stamp l';
+ if b then 1 else 0]
+
+let make_path (k, l, l', b) =
+ let psig = path_signature k l l' b in
+ if PH.mem path_hash psig then ()
+ else
+ let new_path = {kind = k; head = l; tail = l'; reached_global = b}
+ and li, li' = find l, find l' in
+ PH.add path_hash psig new_path;
+ Q.add new_path path_worklist;
+ begin
+ match k with
+ Positive ->
+ li.p_upath <- P.add new_path li.p_upath;
+ li'.p_lpath <- P.add new_path li'.p_lpath
+ | Negative ->
+ li.n_upath <- P.add new_path li.n_upath;
+ li'.n_lpath <- P.add new_path li'.n_lpath
+ | _ ->
+ li.m_upath <- P.add new_path li.m_upath;
+ li'.m_lpath <- P.add new_path li'.m_lpath
+ end;
+ if !debug then
+ begin
+ print_string "Discovered path : ";
+ print_path new_path;
+ print_newline ()
+ end
+
+let backwards_tabulate (l : label) : unit =
+ let rec loop () =
+ let rule1 p =
+ if !debug then print_endline "rule1";
+ B.iter
+ (fun lb ->
+ make_path (Match, lb.info, p.tail,
+ p.reached_global || is_global_label p.head))
+ (find p.head).m_lbounds
+ and rule2 p =
+ if !debug then print_endline "rule2";
+ B.iter
+ (fun lb ->
+ make_path (Negative, lb.info, p.tail,
+ p.reached_global || is_global_label p.head))
+ (find p.head).n_lbounds
+ and rule2m p =
+ if !debug then print_endline "rule2m";
+ B.iter
+ (fun lb ->
+ make_path (Match, lb.info, p.tail,
+ p.reached_global || is_global_label p.head))
+ (find p.head).n_lbounds
+ and rule3 p =
+ if !debug then print_endline "rule3";
+ B.iter
+ (fun lb ->
+ make_path (Positive, lb.info, p.tail,
+ p.reached_global || is_global_label p.head))
+ (find p.head).p_lbounds
+ and rule4 p =
+ if !debug then print_endline "rule4";
+ B.iter
+ (fun lb ->
+ make_path(Negative, lb.info, p.tail,
+ p.reached_global || is_global_label p.head))
+ (find p.head).m_lbounds
+ and rule5 p =
+ if !debug then print_endline "rule5";
+ B.iter
+ (fun lb ->
+ make_path (Positive, lb.info, p.tail,
+ p.reached_global || is_global_label p.head))
+ (find p.head).m_lbounds
+ and rule6 p =
+ if !debug then print_endline "rule6";
+ B.iter
+ (fun lb ->
+ if is_seeded_label lb.info then ()
+ else
+ begin
+ (find lb.info).l_seeded <- true; (* set seeded *)
+ make_path (Seed, lb.info, lb.info,
+ is_global_label lb.info)
+ end)
+ (find p.head).p_lbounds
+ and rule7 p =
+ if !debug then print_endline "rule7";
+ if not (is_ret_label p.tail && is_param_label p.head) then ()
+ else
+ B.iter
+ (fun lb ->
+ B.iter
+ (fun ub ->
+ if lb.index = ub.index then
+ begin
+ if !debug then
+ Printf.printf "New summary : %s %s\n"
+ (string_of_label lb.info)
+ (string_of_label ub.info);
+ make_summary (lb.info, (0, Sub), ub.info);
+ (* rules 1, 4, and 5 *)
+ P.iter
+ (fun ubp -> (* rule 1 *)
+ make_path (Match, lb.info, ubp.tail,
+ ubp.reached_global))
+ (find ub.info).m_upath;
+ P.iter
+ (fun ubp -> (* rule 4 *)
+ make_path (Negative, lb.info, ubp.tail,
+ ubp.reached_global))
+ (find ub.info).n_upath;
+ P.iter
+ (fun ubp -> (* rule 5 *)
+ make_path (Positive, lb.info, ubp.tail,
+ ubp.reached_global))
+ (find ub.info).p_upath
+ end)
+ (find p.tail).p_ubounds)
+ (find p.head).n_lbounds
+ in
+ let matched_backward_rules p =
+ rule1 p;
+ if p.reached_global then rule2m p else rule2 p;
+ rule3 p;
+ rule6 p;
+ rule7 p
+ and negative_backward_rules p =
+ rule2 p;
+ rule3 p;
+ rule4 p;
+ rule6 p;
+ rule7 p
+ and positive_backward_rules p =
+ rule3 p;
+ rule5 p;
+ rule6 p;
+ rule7 p
+ in (* loop *)
+ if Q.is_empty path_worklist then ()
+ else
+ let p = Q.take path_worklist in
+ if !debug then
+ begin
+ print_string "Processing path: ";
+ print_path p;
+ print_newline ()
+ end;
+ begin
+ match p.kind with
+ Positive ->
+ if is_global_label p.tail then matched_backward_rules p
+ else positive_backward_rules p
+ | Negative -> negative_backward_rules p
+ | _ -> matched_backward_rules p
+ end;
+ loop ()
+ in (* backwards_tabulate *)
+ if !debug then
+ begin
+ Printf.printf "Tabulating for %s..." (string_of_label l);
+ if is_global_label l then print_string "(global)";
+ print_newline ()
+ end;
+ make_path (Seed, l, l, is_global_label l);
+ loop ()
+
+let collect_ptsets (l : label) : constantset = (* todo -- cache aliases *)
+ let li = find l
+ and collect init s =
+ P.fold (fun x a -> C.union a (find x.head).aliases) s init
+ in
+ backwards_tabulate l;
+ collect (collect (collect li.aliases li.m_lpath) li.n_lpath) li.p_lpath
+
+let extract_ptlabel (lv : lvalue) : label option =
+ try
+ match find (proj_ref lv.contents) with
+ Var v -> None
+ | Ref r -> Some r.rl;
+ | _ -> raise WellFormed
+ with NoContents -> None
+
+let points_to_aux (t : tau) : constant list =
+ try
+ match find (proj_ref t) with
+ Var v -> []
+ | Ref r -> C.elements (collect_ptsets r.rl)
+ | _ -> raise WellFormed
+ with NoContents -> []
+
+let points_to_names (lv : lvalue) : string list =
+ List.map (fun (_, str, _) -> str) (points_to_aux lv.contents)
+
+let points_to (lv : lvalue) : Cil.varinfo list =
+ let rec get_vinfos l : Cil.varinfo list = match l with
+ | (_, _, h) :: t -> h :: get_vinfos t
+ | [] -> []
+ in
+ get_vinfos (points_to_aux lv.contents)
+
+let epoints_to (t : tau) : Cil.varinfo list =
+ let rec get_vinfos l : Cil.varinfo list = match l with
+ | (_, _, h) :: t -> h :: get_vinfos t
+ | [] -> []
+ in
+ get_vinfos (points_to_aux t)
+
+let smart_alias_query (l : label) (l' : label) : bool =
+ (* Set of dead configurations *)
+ 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) =
+ B.filter (fun (b : lblinfo bound) -> i = b.index)
+ in
+ let rec simulate c l l' =
+ let config = (c, get_label_stamp l, get_label_stamp l') in
+ if U.equal (l, l') then
+ begin
+ if !debug then
+ Printf.printf
+ "%s and %s are aliased\n"
+ (string_of_label l)
+ (string_of_label l');
+ raise APFound
+ end
+ else if CH.mem discovered config then ()
+ else
+ begin
+ if !debug_aliases then
+ Printf.printf
+ "Exploring configuration %s\n"
+ (string_of_configuration config);
+ CH.add discovered config ();
+ B.iter
+ (fun lb -> simulate c lb.info l')
+ (get_bounds Sub false l); (* epsilon closure of l *)
+ B.iter
+ (fun lb -> simulate c l lb.info)
+ (get_bounds Sub false l'); (* epsilon closure of l' *)
+ B.iter
+ (fun lb ->
+ let matching =
+ filter_match lb.index (get_bounds Pos false l')
+ in
+ B.iter
+ (fun b -> simulate Closed lb.info b.info)
+ matching;
+ if is_global_label l' then (* positive self-loops on l' *)
+ simulate Closed lb.info l')
+ (get_bounds Pos false l); (* positive transitions on l *)
+ if is_global_label l then
+ B.iter
+ (fun lb -> simulate Closed l lb.info)
+ (get_bounds Pos false l'); (* positive self-loops on l *)
+ begin
+ match c with (* negative transitions on l, only if Open *)
+ Open ->
+ B.iter
+ (fun lb ->
+ let matching =
+ filter_match lb.index (get_bounds Neg false l')
+ in
+ B.iter
+ (fun b -> simulate Open lb.info b.info)
+ matching ;
+ if is_global_label l' then (* neg self-loops on l' *)
+ simulate Open lb.info l')
+ (get_bounds Neg false l);
+ if is_global_label l then
+ B.iter
+ (fun lb -> simulate Open l lb.info)
+ (get_bounds Neg false l') (* negative self-loops on l *)
+ | _ -> ()
+ end;
+ (* if we got this far, then the configuration was not used *)
+ CH.add dead_configs config ();
+ end
+ in
+ try
+ begin
+ if H.mem cached_aliases (get_label_stamp l, get_label_stamp l') then
+ true
+ else
+ begin
+ simulate Open l l';
+ if !debug then
+ Printf.printf
+ "%s and %s are NOT aliased\n"
+ (string_of_label l)
+ (string_of_label l');
+ false
+ end
+ end
+ with APFound ->
+ CH.iter
+ (fun config -> fun _ ->
+ if not (CH.mem dead_configs config) then
+ H.add
+ cached_aliases
+ (get_label_stamp l, get_label_stamp l')
+ ())
+ discovered;
+ true
+
+(** todo : uses naive alias query for now *)
+let may_alias (t1 : tau) (t2 : tau) : bool =
+ try
+ let l1 =
+ match find (proj_ref t1) with
+ Ref r -> r.rl
+ | Var v -> raise NoContents
+ | _ -> raise WellFormed
+ and l2 =
+ match find (proj_ref t2) with
+ Ref r -> r.rl
+ | Var v -> raise NoContents
+ | _ -> raise WellFormed
+ in
+ not (C.is_empty (C.inter (collect_ptsets l1) (collect_ptsets l2)))
+ with NoContents -> false
+
+let alias_query (b : bool) (lvl : lvalue list) : int * int =
+ let naive_count = ref 0 in
+ let smart_count = ref 0 in
+ let lbls = List.map extract_ptlabel lvl in (* label option list *)
+ let ptsets =
+ List.map
+ (function
+ Some l -> collect_ptsets l
+ | None -> C.empty)
+ lbls in
+ let record_alias s lo s' lo' =
+ match lo, lo' with
+ Some l, Some l' ->
+ if !debug_aliases then
+ Printf.printf
+ "Checking whether %s and %s are aliased...\n"
+ (string_of_label l)
+ (string_of_label l');
+ if C.is_empty (C.inter s s') then ()
+ else
+ begin
+ incr naive_count;
+ if !smart_aliases && smart_alias_query l l' then
+ incr smart_count
+ end
+ | _ -> ()
+ in
+ let rec check_alias sets labels =
+ match sets,labels with
+ s :: st, l :: lt ->
+ List.iter2 (record_alias s l) ptsets lbls;
+ check_alias st lt
+ | [], [] -> ()
+ | _ -> die "check_alias"
+ in
+ check_alias ptsets lbls;
+ (!naive_count, !smart_count)
+
+let alias_frequency (lvl : (lvalue * bool) list) : int * int =
+ let extract_lbl (lv, b : lvalue * bool) = (lv.l, b) in
+ let naive_count = ref 0 in
+ let smart_count = ref 0 in
+ let lbls = List.map extract_lbl lvl in
+ let ptsets =
+ List.map
+ (fun (lbl, b) ->
+ if b then (find lbl).loc (* symbol access *)
+ else collect_ptsets lbl)
+ lbls in
+ let record_alias s (l, b) s' (l', b') =
+ if !debug_aliases then
+ Printf.printf
+ "Checking whether %s and %s are aliased...\n"
+ (string_of_label l)
+ (string_of_label l');
+ if C.is_empty (C.inter s s') then ()
+ else
+ begin
+ if !debug_aliases then
+ Printf.printf
+ "%s and %s are aliased naively...\n"
+ (string_of_label l)
+ (string_of_label l');
+ incr naive_count;
+ if !smart_aliases then
+ if b || b' || smart_alias_query l l' then incr smart_count
+ else
+ Printf.printf
+ "%s and %s are not aliased by smart queries...\n"
+ (string_of_label l)
+ (string_of_label l');
+ end
+ in
+ let rec check_alias sets labels =
+ match sets, labels with
+ s :: st, l :: lt ->
+ List.iter2 (record_alias s l) ptsets lbls;
+ check_alias st lt
+ | [], [] -> ()
+ | _ -> die "check_alias"
+ in
+ check_alias ptsets lbls;
+ (!naive_count, !smart_count)
+
+
+(** an interface for extracting abstract locations from this analysis *)
+
+type absloc = label
+
+let absloc_of_lvalue (l : lvalue) : absloc = l.l
+let absloc_eq (a1, a2) = smart_alias_query a1 a2
+let absloc_print_name = ref true
+let d_absloc () (p : absloc) =
+ let a = find p in
+ if !absloc_print_name then Pretty.dprintf "%s" a.l_name
+ else Pretty.dprintf "%d" a.l_stamp
+
+let phonyAddrOf (lv : lvalue) : lvalue =
+ make_lval (fresh_label true, address lv)
+
+(* transitive closure of points to, starting from l *)
+let rec tauPointsTo (l : tau) : absloc list =
+ match find l with
+ Var _ -> []
+ | Ref r -> r.rl :: tauPointsTo r.points_to
+ | _ -> []
+
+let rec absloc_points_to (l : lvalue) : absloc list =
+ tauPointsTo l.contents
+
+
+(** The following definitions are only introduced for the
+ compatability with Olf. *)
+
+exception UnknownLocation
+
+let finished_constraints () = ()
+let apply_undefined (_ : tau list) = (fresh_var true, 0)
+let assign_undefined (_ : lvalue) = ()
+
+let absloc_epoints_to = tauPointsTo
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * John Kodumal <jkodumal@eecs.berkeley.edu>
+ * 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.
+ *
+ *)
+type lvalue
+type tau
+type absloc
+
+(* only for compatability with Olf *)
+exception UnknownLocation
+
+val debug : bool ref
+val debug_constraints : bool ref
+val debug_aliases : bool ref
+val smart_aliases : bool ref
+val finished_constraints : unit -> unit (* only for compatability with Olf *)
+val print_constraints : bool ref
+val no_flow : bool ref
+val no_sub : bool ref
+val analyze_mono : bool ref
+val solve_constraints : unit -> unit
+val rvalue : lvalue -> tau
+val deref : tau -> lvalue
+val join : tau -> tau -> tau
+val join_inits : tau list -> tau
+val address : lvalue -> tau
+val instantiate : lvalue -> int -> lvalue
+val assign : lvalue -> tau -> unit
+val assign_ret : int -> lvalue -> tau -> unit
+val apply : tau -> tau list -> (tau * int)
+val apply_undefined : tau list -> (tau * int) (* only for compatability with Olf *)
+val assign_undefined : lvalue -> unit (* only for compatability with Olf *)
+val make_function : string -> lvalue list -> tau -> tau
+val make_lvalue : bool -> string -> (Cil.varinfo option) -> lvalue
+val bottom : unit -> tau
+val return : tau -> tau -> unit
+val make_fresh : string -> tau
+val points_to_names : lvalue -> string list
+val points_to : lvalue -> Cil.varinfo list
+val epoints_to : tau -> Cil.varinfo list
+val string_of_lvalue : lvalue -> string
+val global_lvalue : lvalue -> bool
+val alias_query : bool -> lvalue list -> int * int
+val alias_frequency : (lvalue * bool) list -> int * int
+
+val may_alias : tau -> tau -> bool
+
+val absloc_points_to : lvalue -> absloc list
+val absloc_epoints_to : tau -> absloc list
+val absloc_of_lvalue : lvalue -> absloc
+val absloc_eq : (absloc * absloc) -> bool
+val d_absloc : unit -> absloc -> Pretty.doc
+val phonyAddrOf : lvalue -> lvalue
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * John Kodumal <jkodumal@eecs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(***********************************************************************)
+(* *)
+(* Exceptions *)
+(* *)
+(***********************************************************************)
+
+exception Inconsistent (* raised if constraint system is inconsistent *)
+exception WellFormed (* raised if types are not well-formed *)
+exception NoContents
+exception APFound (* raised if an alias pair is found, a control
+ flow exception *)
+exception ReachedTop (* raised if top (from an undefined function)
+ flows to a c_absloc during the flow step *)
+exception UnknownLocation
+
+let solve_constraints () = () (* only for compatability with Golf *)
+
+open Cil
+
+module U = Uref
+module S = Setp
+module H = Hashtbl
+module Q = Queue
+
+(** Generic bounds *)
+type 'a bound = {info : 'a U.uref}
+
+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)
+end
+
+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
+ varinfo for use with the Cil frontend, but for now, this will do *)
+type absloc = int * string * Cil.varinfo option
+
+module Absloc =
+struct
+ type t = absloc
+ let compare (xid, _, _) (yid, _, _) = xid - yid
+end
+
+module C = Set.Make (Absloc)
+
+(** Sets of abslocs. Set union is used when two c_abslocs containing
+ absloc sets are unified *)
+type abslocset = C.t
+
+let d_absloc () (a: absloc) : Pretty.doc =
+ let i,s,_ = a in
+ Pretty.dprintf "<%d, %s>" i s
+
+type c_abslocinfo = {
+ mutable l_name: string; (** name of the location *)
+ loc : absloc;
+ l_stamp : int;
+ mutable l_top : bool;
+ mutable aliases : abslocset;
+ mutable lbounds : c_abslocinfo boundset;
+ mutable ubounds : c_abslocinfo boundset;
+ mutable flow_computed : bool
+}
+and c_absloc = c_abslocinfo U.uref
+
+(** The type of lvalues. *)
+type lvalue = {
+ l: c_absloc;
+ contents: tau
+}
+and vinfo = {
+ v_stamp : int;
+ v_name : string;
+ mutable v_top : bool;
+ mutable v_lbounds : tinfo boundset;
+ mutable v_ubounds : tinfo boundset
+}
+and rinfo = {
+ r_stamp : int;
+ rl : c_absloc;
+ points_to : tau
+}
+and finfo = {
+ f_stamp : int;
+ fl : c_absloc;
+ ret : tau;
+ mutable args : tau list
+}
+and pinfo = {
+ p_stamp : int;
+ ptr : tau;
+ lam : tau
+}
+and tinfo =
+ Var of vinfo
+ | Ref of rinfo
+ | Fun of finfo
+ | Pair of pinfo
+and tau = tinfo U.uref
+
+type tconstraint =
+ Unification of tau * tau
+ | Leq of tau * tau
+
+(** 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 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.
+
+ 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.
+
+ -- In the recursive call, we see that 'a (or ref('a)) is already
+ in the association list, so the type is recursive. We check the
+ string option, which is None, meaning that this is the first
+ recurrence of the type. We create a new recursive variable, rv and
+ set the string option to 'rv. Next, we prepend u rv. to the string
+ representation we have seen before, "ref(", and return "rv" as the
+ string representation of this type.
+
+ -- The string so far is "u rv.ref(". The recursive call returns,
+ and we 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 reuse the same recursive variable name.
+*)
+type association = tau * string ref * string option ref
+
+(** The current state of the solver engine either adding more
+ constraints, or finished adding constraints and querying graph *)
+type state =
+ AddingConstraints
+ | FinishedConstraints
+
+(***********************************************************************)
+(* *)
+(* Global Variables *)
+(* *)
+(***********************************************************************)
+
+(** A count of the constraints introduced from the AST. Used for
+ debugging. *)
+let toplev_count = ref 0
+
+let solver_state : state ref = ref AddingConstraints
+
+(** Print the instantiations constraints. *)
+let print_constraints : bool ref = ref false
+
+(** If true, print all constraints (including induced) and show
+ additional debug output. *)
+let debug = ref false
+
+(** Just debug all the constraints (including induced) *)
+let debug_constraints = ref false
+
+(** Debug the flow step *)
+let debug_flow_step = ref false
+
+(** Compatibility with GOLF *)
+let debug_aliases = ref false
+let smart_aliases = ref false
+let no_flow = ref false
+let analyze_mono = ref false
+
+(** If true, disable subtyping (unification at all levels) *)
+let no_sub = ref false
+
+(** A list of equality constraints. *)
+let eq_worklist : tconstraint Q.t = Q.create ()
+
+(** A list of leq constraints. *)
+let leq_worklist : tconstraint Q.t = Q.create ()
+
+(** A hashtable containing stamp pairs of c_abslocs that must be aliased. *)
+let cached_aliases : (int * int, unit) H.t = H.create 64
+
+(** A hashtable mapping pairs of tau's to their join node. *)
+let join_cache : (int * int, tau) H.t = H.create 64
+
+(** *)
+let label_prefix = "l_"
+
+
+(***********************************************************************)
+(* *)
+(* Utility Functions *)
+(* *)
+(***********************************************************************)
+
+let starts_with s p =
+ let n = String.length p in
+ if String.length s < n then false
+ else String.sub s 0 n = p
+
+
+let die s =
+ Printf.printf "*******\nAssertion failed: %s\n*******\n" s;
+ assert false
+
+let insist b s =
+ if not b then die s else ()
+
+
+let can_add_constraints () =
+ !solver_state = AddingConstraints
+
+let can_query_graph () =
+ !solver_state = FinishedConstraints
+
+let finished_constraints () =
+ insist (!solver_state = AddingConstraints) "inconsistent states";
+ solver_state := FinishedConstraints
+
+let find = U.deref
+
+(** return the prefix of the list up to and including the first
+ element satisfying p. if no element satisfies p, return the empty
+ list *)
+let rec keep_until p l =
+ match l with
+ [] -> []
+ | x :: xs -> if p x then [x] else x :: keep_until p xs
+
+
+(** Generate a unique integer. *)
+let fresh_index : (unit -> int) =
+ let counter = ref 0 in
+ fun () ->
+ incr counter;
+ !counter
+
+let fresh_stamp : (unit -> int) =
+ let stamp = ref 0 in
+ fun () ->
+ incr stamp;
+ !stamp
+
+(** Return a unique integer representation of a tau *)
+let get_stamp (t : tau) : int =
+ match find t with
+ Var v -> v.v_stamp
+ | Ref r -> r.r_stamp
+ | Pair p -> p.p_stamp
+ | Fun f -> f.f_stamp
+
+(** Consistency checks for inferred types *)
+let pair_or_var (t : tau) =
+ match find t with
+ Pair _ -> true
+ | Var _ -> true
+ | _ -> false
+
+let ref_or_var (t : tau) =
+ match find t with
+ Ref _ -> true
+ | Var _ -> true
+ | _ -> false
+
+let fun_or_var (t : tau) =
+ match find t with
+ Fun _ -> true
+ | Var _ -> true
+ | _ -> false
+
+
+(** Apply [f] structurally down [t]. Guaranteed to terminate, even if [t]
+ is recursive *)
+let iter_tau f t =
+ let visited : (int, tau) H.t = H.create 4 in
+ let rec iter_tau' t =
+ if H.mem visited (get_stamp t) then () else
+ begin
+ f t;
+ H.add visited (get_stamp t) t;
+ match find t with
+ Pair p ->
+ iter_tau' p.ptr;
+ iter_tau' p.lam
+ | Fun f ->
+ List.iter iter_tau' f.args;
+ iter_tau' f.ret;
+ | Ref r -> iter_tau' r.points_to
+ | _ -> ()
+ end
+ in
+ iter_tau' t
+
+let equal_absloc = function
+ (i, _, _), (i', _, _) -> i = i'
+
+let equal_c_absloc l l' =
+ (find l).l_stamp = (find l').l_stamp
+
+let equal_tau (t : tau) (t' : tau) =
+ get_stamp t = get_stamp t'
+
+let top_c_absloc l =
+ (find l).l_top
+
+let get_flow_computed l =
+ (find l).flow_computed
+
+let set_flow_computed l =
+ (find l).flow_computed <- true
+
+let rec top_tau (t : tau) =
+ match find t with
+ Pair p -> top_tau p.ptr || top_tau p.lam
+ | Ref r -> top_c_absloc r.rl
+ | Fun f -> top_c_absloc f.fl
+ | Var v -> v.v_top
+
+let get_c_absloc_stamp (l : c_absloc) : int =
+ (find l).l_stamp
+
+let set_top_c_absloc (l : c_absloc) (b: bool) : unit =
+ (find l).l_top <- b
+
+let get_aliases (l : c_absloc) =
+ if top_c_absloc l then raise ReachedTop
+ else (find l).aliases
+
+(***********************************************************************)
+(* *)
+(* Printing Functions *)
+(* *)
+(***********************************************************************)
+
+(** Convert a c_absloc to a string, short representation *)
+let string_of_c_absloc (l : c_absloc) : string =
+ "\"" ^
+ (find l).l_name ^
+ if top_c_absloc l then "(top)" else "" ^
+ "\""
+
+(** Return true if the element [e] is present in the association list,
+ according to uref equality *)
+let rec assoc_list_mem (e : tau) (l : association list) =
+ match l with
+ [] -> None
+ | (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 =
+ match find t with
+ Pair p -> "rvp" ^ string_of_int p.p_stamp
+ | Ref r -> "rvr" ^ string_of_int r.r_stamp
+ | Fun f -> "rvf" ^ string_of_int f.f_stamp
+ | _ -> die "fresh_recvar_name"
+
+
+(** Return a string representation of a tau, using association lists. *)
+let string_of_tau (t : tau) : string =
+ let tau_map : association list ref = ref [] in
+ 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
+ match !so with
+ None ->
+ let rv = fresh_recvar_name t in
+ s := "u " ^ rv ^ "." ^ !s;
+ so := Some rv;
+ rv
+ | Some rv -> rv
+ end
+ | None -> (* type's not recursive. Add it to the assoc list and cont. *)
+ let s = ref ""
+ and so : string option ref = ref None in
+ tau_map := (t, s, so) :: !tau_map;
+ begin
+ match find t with
+ Var v -> s := v.v_name
+ | Pair p ->
+ insist (ref_or_var p.ptr) "wellformed";
+ insist (fun_or_var p.lam) "wellformed";
+ s := "{";
+ s := !s ^ string_of_tau' p.ptr;
+ s := !s ^ ",";
+ s := !s ^ string_of_tau' p.lam;
+ s := !s ^ "}"
+ | Ref r ->
+ insist (pair_or_var r.points_to) "wellformed";
+ s := "ref(|";
+ s := !s ^ string_of_c_absloc r.rl;
+ s := !s ^ "|,";
+ s := !s ^ string_of_tau' r.points_to;
+ s := !s ^ ")"
+ | Fun f ->
+ let rec string_of_args = function
+ [] -> ()
+ | h :: [] ->
+ insist (pair_or_var h) "wellformed";
+ s := !s ^ string_of_tau' h
+ | h :: t ->
+ insist (pair_or_var h) "wellformed";
+ s := !s ^ string_of_tau' h ^ ",";
+ string_of_args t
+ in
+ insist (pair_or_var f.ret) "wellformed";
+ s := "fun(|";
+ s := !s ^ string_of_c_absloc f.fl;
+ s := !s ^ "|,";
+ s := !s ^ "<";
+ if List.length f.args > 0 then string_of_args f.args
+ else s := !s ^ "void";
+ s := !s ^ ">,";
+ s := !s ^ string_of_tau' f.ret;
+ s := !s ^ ")"
+ end;
+ tau_map := List.tl !tau_map;
+ !s
+ in
+ string_of_tau' t
+
+(** Convert an lvalue to a string *)
+let rec string_of_lvalue (lv : lvalue) : string =
+ let contents = string_of_tau lv.contents
+ and l = string_of_c_absloc lv.l
+ in
+ insist (pair_or_var lv.contents) "inconsistency at string_of_lvalue";
+ (* do a consistency check *)
+ Printf.sprintf "[%s]^(%s)" contents l
+
+(** Print a list of tau elements, comma separated *)
+let rec print_tau_list (l : tau list) : unit =
+ let rec print_t_strings = function
+ [] -> ()
+ | h :: [] -> print_endline h
+ | h :: t ->
+ print_string h;
+ print_string ", ";
+ print_t_strings t
+ in
+ print_t_strings (List.map string_of_tau l)
+
+let print_constraint (c : tconstraint) =
+ match c with
+ Unification (t, t') ->
+ let lhs = string_of_tau t in
+ let rhs = string_of_tau t' in
+ Printf.printf "%s == %s\n" lhs rhs
+ | Leq (t, t') ->
+ let lhs = string_of_tau t in
+ let rhs = string_of_tau t' in
+ Printf.printf "%s <= %s\n" lhs rhs
+
+(***********************************************************************)
+(* *)
+(* Type Operations -- these do not create any constraints *)
+(* *)
+(***********************************************************************)
+
+(** Create an lvalue with c_absloc [lbl] and tau contents [t]. *)
+let make_lval (loc, t : c_absloc * tau) : lvalue =
+ {l = loc; contents = t}
+
+let make_c_absloc_int (is_top : bool) (name : string) (vio : Cil.varinfo option) : c_absloc =
+ let my_absloc = (fresh_index (), name, vio) in
+ let locc = C.add my_absloc C.empty
+ in
+ U.uref {
+ l_name = name;
+ l_top = is_top;
+ l_stamp = fresh_stamp ();
+ loc = my_absloc;
+ aliases = locc;
+ ubounds = B.empty;
+ lbounds = B.empty;
+ flow_computed = false
+ }
+
+(** Create a new c_absloc with name [name]. Also adds a fresh absloc
+ with name [name] to this c_absloc's aliases set. *)
+let make_c_absloc (is_top : bool) (name : string) (vio : Cil.varinfo option) =
+ make_c_absloc_int is_top name vio
+
+let fresh_c_absloc (is_top : bool) : c_absloc =
+ let index = fresh_index () in
+ make_c_absloc_int is_top (label_prefix ^ string_of_int index) None
+
+(** Create a fresh bound (edge in the constraint graph). *)
+let make_bound (a : c_absloc) : c_abslocinfo bound =
+ {info = a}
+
+let make_tau_bound (t : tau) : tinfo bound =
+ {info = t}
+
+(** Create a fresh named variable with name '[name]. *)
+let make_var (is_top : bool) (name : string) : tau =
+ U.uref (Var {v_name = ("'" ^ name);
+ v_top = is_top;
+ v_stamp = fresh_index ();
+ v_lbounds = B.empty;
+ v_ubounds = B.empty})
+
+let fresh_var (is_top : bool) : tau =
+ make_var is_top ("fi" ^ string_of_int (fresh_index ()))
+
+(** Create a fresh unnamed variable (name will be 'fi). *)
+let fresh_var_i (is_top : bool) : tau =
+ make_var is_top ("fi" ^ string_of_int (fresh_index ()))
+
+(** Create a Fun constructor. *)
+let make_fun (lbl, a, r : c_absloc * (tau list) * tau) : tau =
+ U.uref (Fun {fl = lbl;
+ f_stamp = fresh_index ();
+ args = a;
+ ret = r})
+
+(** Create a Ref constructor. *)
+let make_ref (lbl, pt : c_absloc * tau) : tau =
+ U.uref (Ref {rl = lbl;
+ r_stamp = fresh_index ();
+ points_to = pt})
+
+(** Create a Pair constructor. *)
+let make_pair (p, f : tau * tau) : tau =
+ U.uref (Pair {ptr = p;
+ p_stamp = fresh_index ();
+ lam = f})
+
+(** Copy the toplevel constructor of [t], putting fresh variables in each
+ argement of the constructor. *)
+let copy_toplevel (t : tau) : tau =
+ match find t with
+ Pair _ -> make_pair (fresh_var_i false, fresh_var_i false)
+ | Ref _ -> make_ref (fresh_c_absloc false, fresh_var_i false)
+ | Fun f ->
+ make_fun (fresh_c_absloc false,
+ List.map (fun _ -> fresh_var_i false) f.args,
+ fresh_var_i false)
+ | _ -> die "copy_toplevel"
+
+let has_same_structure (t : tau) (t' : tau) =
+ match find t, find t' with
+ Pair _, Pair _ -> true
+ | Ref _, Ref _ -> true
+ | Fun _, Fun _ -> true
+ | Var _, Var _ -> true
+ | _ -> false
+
+let pad_args (fi, tlr : finfo * tau list ref) : unit =
+ let padding = List.length fi.args - List.length !tlr
+ in
+ if padding == 0 then ()
+ else
+ if padding > 0 then
+ for i = 1 to padding do
+ tlr := !tlr @ [fresh_var false]
+ done
+ else
+ for i = 1 to -padding do
+ fi.args <- fi.args @ [fresh_var false]
+ done
+
+(***********************************************************************)
+(* *)
+(* Constraint Generation/ Resolution *)
+(* *)
+(***********************************************************************)
+
+let set_top (b : bool) (t : tau) : unit =
+ let set_top_down t =
+ match find t with
+ Var v -> v.v_top <- b
+ | Ref r -> set_top_c_absloc r.rl b
+ | Fun f -> set_top_c_absloc f.fl b
+ | Pair p -> ()
+ in
+ iter_tau set_top_down t
+
+let rec unify_int (t, t' : tau * tau) : unit =
+ if equal_tau t t' then ()
+ else
+ let ti, ti' = find t, find t' in
+ U.unify combine (t, t');
+ match ti, ti' with
+ Var v, Var v' ->
+ set_top (v.v_top || v'.v_top) t';
+ merge_v_lbounds (v, v');
+ merge_v_ubounds (v, v')
+ | Var v, _ ->
+ set_top (v.v_top || top_tau t') t';
+ notify_vlbounds t v;
+ notify_vubounds t v
+ | _, Var v ->
+ set_top (v.v_top || top_tau t) t;
+ notify_vlbounds t' v;
+ notify_vubounds t' v
+ | Ref r, Ref r' -> unify_ref (r, r')
+ | Fun f, Fun f' -> unify_fun (f, f')
+ | Pair p, Pair p' -> unify_pair (p, p')
+ | _ -> raise Inconsistent
+and notify_vlbounds (t : tau) (vi : vinfo) : unit =
+ let notify bounds =
+ List.iter
+ (fun b ->
+ add_constraint (Unification (b.info, copy_toplevel t));
+ add_constraint (Leq (b.info, t)))
+ bounds
+ in
+ notify (B.elements vi.v_lbounds)
+and notify_vubounds (t : tau) (vi : vinfo) : unit =
+ let notify bounds =
+ List.iter
+ (fun b ->
+ add_constraint (Unification (b.info, copy_toplevel t));
+ add_constraint (Leq (t, b.info)))
+ bounds
+ in
+ notify (B.elements vi.v_ubounds)
+and unify_ref (ri, ri' : rinfo * rinfo) : unit =
+ unify_c_abslocs (ri.rl, ri'.rl);
+ add_constraint (Unification (ri.points_to, ri'.points_to))
+and unify_fun (fi, fi' : finfo * finfo) : unit =
+ let rec union_args = function
+ _, [] -> false
+ | [], _ -> true
+ | h :: t, h' :: t' ->
+ add_constraint (Unification (h, h'));
+ union_args(t, t')
+ in
+ unify_c_abslocs (fi.fl, fi'.fl);
+ add_constraint (Unification (fi.ret, fi'.ret));
+ if union_args (fi.args, fi'.args) then fi.args <- fi'.args
+and unify_pair (pi, pi' : pinfo * pinfo) : unit =
+ add_constraint (Unification (pi.ptr, pi'.ptr));
+ add_constraint (Unification (pi.lam, pi'.lam))
+and unify_c_abslocs (l, l' : c_absloc * c_absloc) : unit =
+ let pick_name (li, li' : c_abslocinfo * c_abslocinfo) =
+ if starts_with li.l_name label_prefix then li.l_name <- li'.l_name
+ else () in
+ let combine_c_absloc (li, li' : c_abslocinfo * c_abslocinfo) : c_abslocinfo =
+ pick_name (li, li');
+ li.l_top <- li.l_top || li'.l_top;
+ li.aliases <- C.union li.aliases li'.aliases;
+ li.ubounds <- B.union li.ubounds li'.ubounds;
+ li.lbounds <- B.union li.lbounds li'.lbounds;
+ li
+ in
+ if !debug_constraints then
+ Printf.printf
+ "%s == %s\n"
+ (string_of_c_absloc l)
+ (string_of_c_absloc l');
+ U.unify combine_c_absloc (l, l')
+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;
+(** 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. All other actions (e.g., updating
+ the info) is done in unify_int *)
+and combine (ti, ti' : tinfo * tinfo) : tinfo =
+ match ti, ti' with
+ Var _, _ -> ti'
+ | _, _ -> ti
+and leq_int (t, t') : unit =
+ if equal_tau t t' then ()
+ else
+ let ti, ti' = find t, find t' in
+ match ti, ti' with
+ Var v, Var v' ->
+ v.v_ubounds <- B.add (make_tau_bound t') v.v_ubounds;
+ v'.v_lbounds <- B.add (make_tau_bound t) v'.v_lbounds
+ | Var v, _ ->
+ add_constraint (Unification (t, copy_toplevel t'));
+ add_constraint (Leq (t, t'))
+ | _, Var v ->
+ add_constraint (Unification (t', copy_toplevel t));
+ add_constraint (Leq (t, t'))
+ | Ref r, Ref r' -> leq_ref (r, r')
+ | Fun f, Fun f' ->
+ (* TODO: check, why not do subtyping here? *)
+ add_constraint (Unification (t, t'))
+ | Pair pr, Pair pr' ->
+ add_constraint (Leq (pr.ptr, pr'.ptr));
+ add_constraint (Leq (pr.lam, pr'.lam))
+ | _ -> raise Inconsistent
+and leq_ref (ri, ri') : unit =
+ leq_c_absloc (ri.rl, ri'.rl);
+ add_constraint (Unification (ri.points_to, ri'.points_to))
+and leq_c_absloc (l, l') : unit =
+ let li, li' = find l, find l' in
+ if !debug_constraints then
+ Printf.printf
+ "%s <= %s\n"
+ (string_of_c_absloc l)
+ (string_of_c_absloc l');
+ if U.equal (l, l') then ()
+ else
+ begin
+ li.ubounds <- B.add (make_bound l') li.ubounds;
+ li'.lbounds <- B.add (make_bound l) li'.lbounds
+ end
+and add_constraint_int (c : tconstraint) (toplev : bool) =
+ if !debug_constraints && toplev then
+ begin
+ Printf.printf "%d:>" !toplev_count;
+ print_constraint c;
+ incr toplev_count
+ end
+ else
+ if !debug_constraints then print_constraint c else ();
+ insist (can_add_constraints ())
+ "can't add constraints after compute_results is called";
+ begin
+ match c with
+ Unification _ -> Q.add c eq_worklist
+ | Leq _ -> Q.add c leq_worklist
+ end;
+ solve_constraints () (* solve online *)
+and add_constraint (c : tconstraint) =
+ add_constraint_int c false
+and add_toplev_constraint (c : tconstraint) =
+ if !print_constraints && not !debug_constraints then
+ begin
+ Printf.printf "%d:>" !toplev_count;
+ incr toplev_count;
+ print_constraint c
+ end
+ else ();
+ add_constraint_int c true
+and fetch_constraint () : tconstraint option =
+ try Some (Q.take eq_worklist)
+ with Q.Empty ->
+ begin
+ try Some (Q.take leq_worklist)
+ with Q.Empty -> None
+ end
+(** The main solver loop. *)
+and solve_constraints () : unit =
+ match fetch_constraint () with
+ None -> ()
+ | Some c ->
+ begin
+ match c with
+ Unification (t, t') -> unify_int (t, t')
+ | Leq (t, t') ->
+ if !no_sub then unify_int (t, t')
+ else leq_int (t, t')
+ end;
+ solve_constraints ()
+
+(***********************************************************************)
+(* *)
+(* Interface Functions *)
+(* *)
+(***********************************************************************)
+
+(** Return the contents of the lvalue. *)
+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 find t with
+ Pair p ->
+ begin
+ match find p.ptr with
+ | Var _ ->
+ let is_top = top_tau p.ptr in
+ let points_to = fresh_var is_top in
+ let l = fresh_c_absloc is_top in
+ let r = make_ref (l, points_to)
+ in
+ add_toplev_constraint (Unification (p.ptr, r));
+ make_lval (l, points_to)
+ | Ref r -> make_lval (r.rl, r.points_to)
+ | _ -> raise WellFormed
+ end
+ | Var v ->
+ let is_top = top_tau t in
+ add_toplev_constraint
+ (Unification (t, make_pair (fresh_var is_top, fresh_var is_top)));
+ deref t
+ | _ -> raise WellFormed
+
+
+(** Form the union of [t] and [t'], if it doesn't exist already. *)
+let join (t : tau) (t' : tau) : tau =
+ let s, s' = get_stamp t, get_stamp t' in
+ try H.find join_cache (s, s')
+ with Not_found ->
+ let t'' = fresh_var false in
+ add_toplev_constraint (Leq (t, t''));
+ add_toplev_constraint (Leq (t', t''));
+ H.add join_cache (s, s') t'';
+ t''
+
+(** 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 t' = fresh_var false in
+ List.iter (function t -> add_toplev_constraint (Leq (t, t'))) tl;
+ t'
+
+(** Take the address of an lvalue. Does not add constraints. *)
+let address (lv : lvalue) : tau =
+ make_pair (make_ref (lv.l, lv.contents), fresh_var false )
+
+(** No instantiation in this analysis *)
+let instantiate (lv : lvalue) (i : int) : lvalue =
+ lv
+
+(** Constraint generated from assigning [t] to [lv]. *)
+let assign (lv : lvalue) (t : tau) : unit =
+ add_toplev_constraint (Leq (t, lv.contents))
+
+let assign_ret (i : int) (lv : lvalue) (t : tau) : unit =
+ add_toplev_constraint (Leq (t, lv.contents))
+
+(** Project out the first (ref) component or a pair. If the argument
+ [t] has no discovered structure, raise NoContents. *)
+let proj_ref (t : tau) : tau =
+ match find t with
+ Pair p -> p.ptr
+ | Var v -> raise NoContents
+ | _ -> raise WellFormed
+
+(* 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 =
+ match find t with
+ Pair p -> p.lam
+ | Var v ->
+ let p, f = fresh_var false, fresh_var false in
+ add_toplev_constraint (Unification (t, make_pair (p, f)));
+ f
+ | _ -> raise WellFormed
+
+let get_args (t : tau) : tau list =
+ match find t with
+ Fun f -> f.args
+ | _ -> raise WellFormed
+
+let get_finfo (t : tau) : finfo =
+ match find t with
+ Fun f -> f
+ | _ -> raise WellFormed
+
+(** 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 plus the index
+ of this application site.
+
+ For this analysis, the application site is always 0 *)
+let apply (t : tau) (al : tau list) : (tau * int) =
+ let f = proj_fun t in
+ let actuals = ref al in
+ let fi, ret =
+ match find f with
+ Fun fi -> fi, fi.ret
+ | Var v ->
+ let new_l, new_ret, new_args =
+ fresh_c_absloc false,
+ fresh_var false,
+ List.map (function _ -> fresh_var false) !actuals
+ in
+ let new_fun = make_fun (new_l, new_args, new_ret) in
+ add_toplev_constraint (Unification (new_fun, f));
+ (get_finfo new_fun, new_ret)
+ | _ -> raise WellFormed
+ in
+ pad_args (fi, actuals);
+ List.iter2
+ (fun actual -> fun formal ->
+ add_toplev_constraint (Leq (actual, formal)))
+ !actuals fi.args;
+ (ret, 0)
+
+let make_undefined_lvalue () =
+ make_lval (make_c_absloc false "undefined" None,
+ make_var true "undefined")
+
+let make_undefined_rvalue () =
+ make_var true "undefined"
+
+let assign_undefined (lv : lvalue) : unit =
+ assign lv (make_undefined_rvalue ())
+
+let apply_undefined (al : tau list) : (tau * int) =
+ List.iter
+ (fun actual -> assign (make_undefined_lvalue ()) actual)
+ al;
+ (fresh_var true, 0)
+
+(** 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_c_absloc false name None,
+ List.map (fun x -> rvalue x) formals,
+ ret)
+ in
+ make_pair (fresh_var false, f)
+
+(** Create an lvalue. *)
+let make_lvalue (b : bool ) (name : string) (vio : Cil.varinfo option) =
+ make_lval (make_c_absloc false name vio,
+ make_var false name)
+
+(** Create a fresh named variable. *)
+let make_fresh (name : string) : tau =
+ make_var false name
+
+(** The default type for abslocs. *)
+let bottom () : tau =
+ make_var false "bottom"
+
+(** Unify the result of a function with its return value. *)
+let return (t : tau) (t' : tau) =
+ add_toplev_constraint (Leq (t', t))
+
+(***********************************************************************)
+(* *)
+(* Query/Extract Solutions *)
+(* *)
+(***********************************************************************)
+
+module IntHash = Hashtbl.Make (struct
+ type t = int
+ let equal x y = x = y
+ let hash x = x
+ end)
+
+(** todo : reached_top !! *)
+let collect_ptset_fast (l : c_absloc) : abslocset =
+ let onpath : unit IntHash.t = IntHash.create 101 in
+ let path : c_absloc list ref = ref [] in
+ let compute_path (i : int) =
+ keep_until (fun l -> i = get_c_absloc_stamp l) !path in
+ let collapse_cycle (cycle : c_absloc list) =
+ match cycle with
+ l :: ls ->
+ List.iter (fun l' -> unify_c_abslocs (l, l')) ls;
+ C.empty
+ | [] -> die "collapse cycle" in
+ let rec flow_step (l : c_absloc) : abslocset =
+ let stamp = get_c_absloc_stamp l in
+ if IntHash.mem onpath stamp then (* already seen *)
+ collapse_cycle (compute_path stamp)
+ else
+ let li = find l in
+ IntHash.add onpath stamp ();
+ path := l :: !path;
+ B.iter
+ (fun lb -> li.aliases <- C.union li.aliases (flow_step lb.info))
+ li.lbounds;
+ path := List.tl !path;
+ IntHash.remove onpath stamp;
+ li.aliases
+ in
+ insist (can_query_graph ()) "collect_ptset_fast can't query graph";
+ if get_flow_computed l then get_aliases l
+ else
+ begin
+ set_flow_computed l;
+ flow_step l
+ end
+
+(** this is a quadratic flow step. keep it for debugging the fast
+ version above. *)
+let collect_ptset_slow (l : c_absloc) : abslocset =
+ let onpath : unit IntHash.t = IntHash.create 101 in
+ let rec flow_step (l : c_absloc) : abslocset =
+ if top_c_absloc l then raise ReachedTop
+ else
+ let stamp = get_c_absloc_stamp l in
+ if IntHash.mem onpath stamp then C.empty
+ else
+ let li = find l in
+ IntHash.add onpath stamp ();
+ B.iter
+ (fun lb -> li.aliases <- C.union li.aliases (flow_step lb.info))
+ li.lbounds;
+ li.aliases
+ in
+ insist (can_query_graph ()) "collect_ptset_slow can't query graph";
+ if get_flow_computed l then get_aliases l
+ else
+ begin
+ set_flow_computed l;
+ flow_step l
+ end
+
+let collect_ptset =
+ collect_ptset_slow
+ (* if !debug_flow_step then collect_ptset_slow
+ else collect_ptset_fast *)
+
+let may_alias (t1 : tau) (t2 : tau) : bool =
+ let get_l (t : tau) : c_absloc =
+ match find (proj_ref t) with
+ Ref r -> r.rl
+ | Var v -> raise NoContents
+ | _ -> raise WellFormed
+ in
+ try
+ let l1 = get_l t1
+ and l2 = get_l t2 in
+ equal_c_absloc l1 l2 ||
+ not (C.is_empty (C.inter (collect_ptset l1) (collect_ptset l2)))
+ with
+ NoContents -> false
+ | ReachedTop -> raise UnknownLocation
+
+let points_to_aux (t : tau) : absloc list =
+ try
+ match find (proj_ref t) with
+ Var v -> []
+ | Ref r -> C.elements (collect_ptset r.rl)
+ | _ -> raise WellFormed
+ with
+ NoContents -> []
+ | ReachedTop -> raise UnknownLocation
+
+let points_to (lv : lvalue) : Cil.varinfo list =
+ let rec get_vinfos l : Cil.varinfo list =
+ match l with
+ [] -> []
+ | (_, _, Some h) :: t -> h :: get_vinfos t
+ | (_, _, None) :: t -> get_vinfos t
+ in
+ get_vinfos (points_to_aux lv.contents)
+
+let epoints_to (t : tau) : Cil.varinfo list =
+ let rec get_vinfos l : Cil.varinfo list = match l with
+ [] -> []
+ | (_, _, Some h) :: t -> h :: get_vinfos t
+ | (_, _, None) :: t -> get_vinfos t
+ in
+ get_vinfos (points_to_aux t)
+
+let points_to_names (lv : lvalue) : string list =
+ List.map (fun v -> v.vname) (points_to lv)
+
+let absloc_points_to (lv : lvalue) : absloc list =
+ points_to_aux lv.contents
+
+let absloc_epoints_to (t : tau) : absloc list =
+ points_to_aux t
+
+let absloc_of_lvalue (lv : lvalue) : absloc =
+ (find lv.l).loc
+
+let absloc_eq = equal_absloc
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * John Kodumal <jkodumal@eecs.berkeley.edu>
+ * 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.
+ *
+ *)
+type lvalue
+type tau
+type absloc
+
+(** Raised if a pointer flows to an undefined function.
+ We assume that such a function can have any effect on the pointer's contents
+*)
+exception UnknownLocation
+
+val debug : bool ref
+val debug_constraints : bool ref
+val debug_aliases : bool ref
+val smart_aliases : bool ref
+val finished_constraints : unit -> unit
+val print_constraints : bool ref
+val no_flow : bool ref
+val no_sub : bool ref
+val analyze_mono : bool ref
+val solve_constraints : unit -> unit (* only for compatability with Golf *)
+val rvalue : lvalue -> tau
+val deref : tau -> lvalue
+val join : tau -> tau -> tau
+val join_inits : tau list -> tau
+val address : lvalue -> tau
+val instantiate : lvalue -> int -> lvalue
+val assign : lvalue -> tau -> unit
+val assign_ret : int -> lvalue -> tau -> unit
+val apply : tau -> tau list -> (tau * int)
+val apply_undefined : tau list -> (tau * int)
+val assign_undefined : lvalue -> unit
+val make_function : string -> lvalue list -> tau -> tau
+val make_lvalue : bool -> string -> (Cil.varinfo option) -> lvalue
+val bottom : unit -> tau
+val return : tau -> tau -> unit
+val make_fresh : string -> tau
+val points_to_names : lvalue -> string list
+val points_to : lvalue -> Cil.varinfo list
+val epoints_to : tau -> Cil.varinfo list
+val string_of_lvalue : lvalue -> string
+val may_alias : tau -> tau -> bool
+
+val absloc_points_to : lvalue -> absloc list
+val absloc_epoints_to : tau -> absloc list
+val absloc_of_lvalue : lvalue -> absloc
+val absloc_eq : (absloc * absloc) -> bool
+val d_absloc : unit -> absloc -> Pretty.doc
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * John Kodumal <jkodumal@eecs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+exception Bad_return
+exception Bad_function
+
+
+open Cil
+
+module H = Hashtbl
+
+module A = Olf
+exception UnknownLocation = A.UnknownLocation
+
+type access = A.lvalue * bool
+
+type access_map = (lval, access) H.t
+
+(** a mapping from varinfo's back to fundecs *)
+module VarInfoKey =
+struct
+ type t = varinfo
+ let compare v1 v2 = v1.vid - v2.vid
+end
+
+module F = Map.Make (VarInfoKey)
+
+
+(***********************************************************************)
+(* *)
+(* Global Variables *)
+(* *)
+(***********************************************************************)
+
+let model_strings = ref false
+let print_constraints = A.print_constraints
+let debug_constraints = A.debug_constraints
+let debug_aliases = A.debug_aliases
+let smart_aliases = A.smart_aliases
+let debug = A.debug
+let analyze_mono = A.analyze_mono
+let no_flow = A.no_flow
+let no_sub = A.no_sub
+let fun_ptrs_as_funs = ref false
+let show_progress = ref false
+let debug_may_aliases = ref false
+
+let found_undefined = ref false
+
+let conservative_undefineds = ref false
+
+let current_fundec : fundec option ref = ref None
+
+let fun_access_map : (fundec, access_map) H.t = H.create 64
+
+(* A mapping from varinfos to fundecs *)
+let fun_varinfo_map = ref F.empty
+
+let current_ret : A.tau option ref = ref None
+
+let lvalue_hash : (varinfo,A.lvalue) H.t = H.create 64
+
+let expressions : (exp,A.tau) H.t = H.create 64
+
+let lvalues : (lval,A.lvalue) H.t = H.create 64
+
+let fresh_index : (unit -> int) =
+ let count = ref 0 in
+ fun () ->
+ incr count;
+ !count
+
+let alloc_names = [
+ "malloc";
+ "calloc";
+ "realloc";
+ "xmalloc";
+ "__builtin_alloca";
+ "alloca";
+ "kmalloc"
+]
+
+(* This function should be set by the client if it
+ * knows of functions returning a result that have
+ * no side effects. If the result is not used, then
+ * the call will be eliminated. *)
+let callHasNoSideEffects : (exp -> bool) ref =
+ ref (fun _ -> false)
+
+let all_globals : varinfo list ref = ref []
+let all_functions : fundec list ref = ref []
+
+
+(***********************************************************************)
+(* *)
+(* Utility Functions *)
+(* *)
+(***********************************************************************)
+
+let is_undefined_fun = function
+ Lval (lh, o) ->
+ if isFunctionType (typeOfLval (lh, o)) then
+ match lh with
+ Var v -> v.vstorage = Extern
+ | _ -> false
+ else false
+ | _ -> false
+
+let is_alloc_fun = function
+ Lval (lh, o) ->
+ if isFunctionType (typeOfLval (lh, o)) then
+ match lh with
+ Var v -> List.mem v.vname alloc_names
+ | _ -> false
+ else false
+ | _ -> false
+
+let next_alloc = function
+ Lval (Var v, o) ->
+ let name = Printf.sprintf "%s@%d" v.vname (fresh_index ())
+ in
+ A.address (A.make_lvalue false name (Some v)) (* check *)
+ | _ -> raise Bad_return
+
+let is_effect_free_fun = function
+ Lval (lh, o) when isFunctionType (typeOfLval (lh, o)) ->
+ begin
+ match lh with
+ Var v ->
+ begin
+ try ("CHECK_" = String.sub v.vname 0 6 ||
+ !callHasNoSideEffects (Lval(lh,o)))
+ with Invalid_argument _ -> false
+ end
+ | _ -> false
+ end
+ | _ -> false
+
+
+(***********************************************************************)
+(* *)
+(* AST Traversal Functions *)
+(* *)
+(***********************************************************************)
+
+(* should do nothing, might need to worry about Index case *)
+(* let analyzeOffset (o : offset ) : A.tau = A.bottom () *)
+
+let analyze_var_decl (v : varinfo ) : A.lvalue =
+ try H.find lvalue_hash v
+ with Not_found ->
+ let lv = A.make_lvalue false v.vname (Some v)
+ in
+ H.add lvalue_hash v lv;
+ lv
+
+let isFunPtrType (t : typ) : bool =
+ match t with
+ TPtr (t, _) -> isFunctionType t
+ | _ -> false
+
+let rec analyze_lval (lv : lval ) : A.lvalue =
+ let find_access (l : A.lvalue) (is_var : bool) : A.lvalue =
+ match !current_fundec with
+ None -> l
+ | Some f ->
+ let accesses = H.find fun_access_map f in
+ if H.mem accesses lv then l
+ else
+ begin
+ H.add accesses lv (l, is_var);
+ l
+ end in
+ let result =
+ match lv with
+ Var v, _ -> (* instantiate every syntactic occurrence of a function *)
+ let alv =
+ if isFunctionType (typeOfLval lv) then
+ A.instantiate (analyze_var_decl v) (fresh_index ())
+ else analyze_var_decl v
+ in
+ find_access alv true
+ | Mem e, _ ->
+ (* assert (not (isFunctionType(typeOf(e))) ); *)
+ let alv =
+ if !fun_ptrs_as_funs && isFunPtrType (typeOf e) then
+ analyze_expr_as_lval e
+ else A.deref (analyze_expr e)
+ in
+ find_access alv false
+ in
+ H.replace lvalues lv result;
+ result
+and analyze_expr_as_lval (e : exp) : A.lvalue =
+ match e with
+ Lval l -> analyze_lval l
+ | _ -> assert false (* todo -- other kinds of expressions? *)
+and analyze_expr (e : exp ) : A.tau =
+ let result =
+ match e with
+ Const (CStr s) ->
+ if !model_strings then
+ A.address (A.make_lvalue
+ false
+ s
+ (Some (makeVarinfo false s charConstPtrType)))
+ else A.bottom ()
+ | Const c -> A.bottom ()
+ | Lval l -> A.rvalue (analyze_lval l)
+ | SizeOf _ -> A.bottom ()
+ | SizeOfStr _ -> A.bottom ()
+ | AlignOf _ -> A.bottom ()
+ | UnOp (op, e, t) -> analyze_expr e
+ | BinOp (op, e, e', t) -> A.join (analyze_expr e) (analyze_expr e')
+ | CastE (t, e) -> analyze_expr e
+ | AddrOf l ->
+ if !fun_ptrs_as_funs && isFunctionType (typeOfLval l) then
+ A.rvalue (analyze_lval l)
+ else A.address (analyze_lval l)
+ | StartOf l -> A.address (analyze_lval l)
+ | AlignOfE _ -> A.bottom ()
+ | SizeOfE _ -> A.bottom ()
+ in
+ H.add expressions e result;
+ result
+
+
+(* check *)
+let rec analyze_init (i : init ) : A.tau =
+ match i with
+ SingleInit e -> analyze_expr e
+ | CompoundInit (t, oi) ->
+ A.join_inits (List.map (function (_, i) -> analyze_init i) oi)
+
+let analyze_instr (i : instr ) : unit =
+ match i with
+ Set (lval, rhs, l) ->
+ A.assign (analyze_lval lval) (analyze_expr rhs)
+ | Call (res, fexpr, actuals, l) ->
+ if not (isFunctionType (typeOf fexpr)) then
+ () (* todo : is this a varargs? *)
+ else if is_alloc_fun fexpr then
+ begin
+ if !debug then print_string "Found allocation function...\n";
+ match res with
+ Some r -> A.assign (analyze_lval r) (next_alloc fexpr)
+ | None -> ()
+ end
+ else if is_effect_free_fun fexpr then
+ List.iter (fun e -> ignore (analyze_expr e)) actuals
+ 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 (List.map analyze_expr actuals)
+ else
+ A.apply (analyze_expr fexpr) (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
+ | None -> ()
+ end
+ | Asm _ -> ()
+
+let rec analyze_stmt (s : stmt ) : unit =
+ match s.skind with
+ Instr il -> List.iter analyze_instr il
+ | Return (eo, l) ->
+ begin
+ match eo with
+ Some e ->
+ begin
+ match !current_ret with
+ Some ret -> A.return ret (analyze_expr e)
+ | None -> raise Bad_return
+ end
+ | None -> ()
+ end
+ | Goto (s', l) -> () (* analyze_stmt(!s') *)
+ | If (e, b, b', l) ->
+ (* ignore the expression e; expressions can't be side-effecting *)
+ analyze_block b;
+ analyze_block b'
+ | Switch (e, b, sl, l) ->
+ analyze_block b;
+ List.iter analyze_stmt sl
+ | Loop (b, l, _, _) -> analyze_block b
+ | Block b -> analyze_block b
+ | TryFinally (b, h, _) ->
+ analyze_block b;
+ analyze_block h
+ | TryExcept (b, (il, _), h, _) ->
+ analyze_block b;
+ List.iter analyze_instr il;
+ analyze_block h
+ | Break l -> ()
+ | Continue l -> ()
+
+
+and analyze_block (b : block ) : unit =
+ List.iter analyze_stmt b.bstmts
+
+let analyze_function (f : fundec ) : unit =
+ let oldlv = analyze_var_decl f.svar in
+ let ret = A.make_fresh (f.svar.vname ^ "_ret") in
+ let formals = List.map analyze_var_decl f.sformals in
+ let newf = A.make_function f.svar.vname formals ret in
+ if !show_progress then
+ Printf.printf "Analyzing function %s\n" f.svar.vname;
+ fun_varinfo_map := F.add f.svar f (!fun_varinfo_map);
+ current_fundec := Some f;
+ H.add fun_access_map f (H.create 8);
+ A.assign oldlv newf;
+ current_ret := Some ret;
+ analyze_block f.sbody
+
+let analyze_global (g : global ) : unit =
+ match g with
+ GVarDecl (v, l) -> () (* ignore (analyze_var_decl(v)) -- no need *)
+ | GVar (v, init, l) ->
+ all_globals := v :: !all_globals;
+ begin
+ match init.init with
+ Some i -> A.assign (analyze_var_decl v) (analyze_init i)
+ | None -> ignore (analyze_var_decl v)
+ end
+ | GFun (f, l) ->
+ all_functions := f :: !all_functions;
+ analyze_function f
+ | _ -> ()
+
+let analyze_file (f : file) : unit =
+ iterGlobals f analyze_global
+
+
+(***********************************************************************)
+(* *)
+(* High-level Query Interface *)
+(* *)
+(***********************************************************************)
+
+(* Same as analyze_expr, but no constraints. *)
+let rec traverse_expr (e : exp) : A.tau =
+ H.find expressions e
+
+and traverse_expr_as_lval (e : exp) : A.lvalue =
+ match e with
+ | Lval l -> traverse_lval l
+ | _ -> assert false (* todo -- other kinds of expressions? *)
+
+and traverse_lval (lv : lval ) : A.lvalue =
+ H.find lvalues lv
+
+let may_alias (e1 : exp) (e2 : exp) : bool =
+ let tau1,tau2 = traverse_expr e1, traverse_expr e2 in
+ let result = A.may_alias tau1 tau2 in
+ if !debug_may_aliases then
+ begin
+ let doc1 = d_exp () e1 in
+ let doc2 = d_exp () e2 in
+ let s1 = Pretty.sprint ~width:30 doc1 in
+ let s2 = Pretty.sprint ~width:30 doc2 in
+ Printf.printf
+ "%s and %s may alias? %s\n"
+ s1
+ s2
+ (if result then "yes" else "no")
+ end;
+ result
+
+let resolve_lval (lv : lval) : varinfo list =
+ A.points_to (traverse_lval lv)
+
+let resolve_exp (e : exp) : varinfo list =
+ A.epoints_to (traverse_expr e)
+
+let resolve_funptr (e : exp) : fundec list =
+ let varinfos = A.epoints_to (traverse_expr e) in
+ List.fold_left
+ (fun fdecs -> fun vinf ->
+ try F.find vinf !fun_varinfo_map :: fdecs
+ with Not_found -> fdecs)
+ []
+ varinfos
+
+let count_hash_elts h =
+ let result = ref 0 in
+ H.iter (fun _ -> fun _ -> incr result) lvalue_hash;
+ !result
+
+let compute_may_aliases (b : bool) : unit =
+ let rec compute_may_aliases_aux (exps : exp list) =
+ match exps with
+ [] -> ()
+ | h :: t ->
+ ignore (List.map (may_alias h) t);
+ compute_may_aliases_aux t
+ and exprs : exp list ref = ref [] in
+ H.iter (fun e -> fun _ -> exprs := e :: !exprs) expressions;
+ compute_may_aliases_aux !exprs
+
+
+let compute_results (show_sets : bool) : unit =
+ let total_pointed_to = ref 0
+ and total_lvalues = H.length lvalue_hash
+ and counted_lvalues = ref 0
+ and lval_elts : (string * (string list)) list ref = ref [] in
+ let print_result (name, set) =
+ let rec print_set s =
+ match s with
+ [] -> ()
+ | h :: [] -> print_string h
+ | h :: t ->
+ print_string (h ^ ", ");
+ print_set t
+ and ptsize = List.length set in
+ total_pointed_to := !total_pointed_to + ptsize;
+ if ptsize > 0 then
+ begin
+ print_string (name ^ "(" ^ (string_of_int ptsize) ^ ") -> ");
+ print_set set;
+ print_newline ()
+ end
+ in
+ (* Make the most pessimistic assumptions about globals if an
+ undefined function is present. Such a function can write to every
+ global variable *)
+ let hose_globals () : unit =
+ List.iter
+ (fun vd -> A.assign_undefined (analyze_var_decl vd))
+ !all_globals
+ in
+ let show_progress_fn (counted : int ref) (total : int) : unit =
+ incr counted;
+ if !show_progress then
+ Printf.printf "Computed flow for %d of %d sets\n" !counted total
+ in
+ if !conservative_undefineds && !found_undefined then hose_globals ();
+ A.finished_constraints ();
+ if show_sets then
+ begin
+ print_endline "Computing points-to sets...";
+ Hashtbl.iter
+ (fun vinf -> fun lv ->
+ show_progress_fn counted_lvalues total_lvalues;
+ try lval_elts := (vinf.vname, A.points_to_names lv) :: !lval_elts
+ with A.UnknownLocation -> ())
+ lvalue_hash;
+ List.iter print_result !lval_elts;
+ Printf.printf
+ "Total number of things pointed to: %d\n"
+ !total_pointed_to
+ end;
+ if !debug_may_aliases then
+ begin
+ Printf.printf "Printing may alias relationships\n";
+ compute_may_aliases true
+ end
+
+let print_types () : unit =
+ print_string "Printing inferred types of lvalues...\n";
+ Hashtbl.iter
+ (fun vi -> fun lv ->
+ Printf.printf "%s : %s\n" vi.vname (A.string_of_lvalue lv))
+ lvalue_hash
+
+
+
+(** Alias queries. For each function, gather sets of locals, formals, and
+ globals. Do n^2 work for each of these functions, reporting whether or not
+ each pair of values is aliased. Aliasing is determined by taking points-to
+ set intersections.
+*)
+let compute_aliases = compute_may_aliases
+
+
+(***********************************************************************)
+(* *)
+(* Abstract Location Interface *)
+(* *)
+(***********************************************************************)
+
+type absloc = A.absloc
+
+let rec lvalue_of_varinfo (vi : varinfo) : A.lvalue =
+ H.find lvalue_hash vi
+
+let lvalue_of_lval = traverse_lval
+let tau_of_expr = traverse_expr
+
+(** return an abstract location for a varinfo, resp. lval *)
+let absloc_of_varinfo vi =
+ A.absloc_of_lvalue (lvalue_of_varinfo vi)
+
+let absloc_of_lval lv =
+ A.absloc_of_lvalue (lvalue_of_lval lv)
+
+let absloc_e_points_to e =
+ A.absloc_epoints_to (tau_of_expr e)
+
+let absloc_lval_aliases lv =
+ A.absloc_points_to (lvalue_of_lval lv)
+
+(* all abslocs that e transitively points to *)
+let absloc_e_transitive_points_to (e : Cil.exp) : absloc list =
+ let rec lv_trans_ptsto (worklist : varinfo list) (acc : varinfo list) : absloc list =
+ match worklist with
+ [] -> List.map absloc_of_varinfo acc
+ | vi :: wklst'' ->
+ if List.mem vi acc then lv_trans_ptsto wklst'' acc
+ else
+ lv_trans_ptsto
+ (List.rev_append
+ (A.points_to (lvalue_of_varinfo vi))
+ wklst'')
+ (vi :: acc)
+ in
+ lv_trans_ptsto (A.epoints_to (tau_of_expr e)) []
+
+let absloc_eq a b = A.absloc_eq (a, b)
+
+let d_absloc: unit -> absloc -> Pretty.doc = A.d_absloc
+
+
+let ptrAnalysis = ref false
+let ptrResults = ref false
+let ptrTypes = ref false
+
+
+
+(** Turn this into a CIL feature *)
+let feature : featureDescr = {
+ fd_name = "ptranal";
+ fd_enabled = ptrAnalysis;
+ fd_description = "alias analysis";
+ fd_extraopt = [
+ ("--ptr_may_aliases",
+ Arg.Unit (fun _ -> debug_may_aliases := true),
+ " Print out results of may alias queries");
+ ("--ptr_unify", Arg.Unit (fun _ -> no_sub := true),
+ " Make the alias analysis unification-based");
+ ("--ptr_model_strings", Arg.Unit (fun _ -> model_strings := true),
+ " Make the alias analysis model string constants");
+ ("--ptr_conservative",
+ Arg.Unit (fun _ -> conservative_undefineds := true),
+ " Treat undefineds conservatively in alias analysis");
+ ("--ptr_results", Arg.Unit (fun _ -> ptrResults := true),
+ " print the results of the alias analysis");
+ ("--ptr_mono", Arg.Unit (fun _ -> analyze_mono := true),
+ " run alias analysis monomorphically");
+ ("--ptr_types",Arg.Unit (fun _ -> ptrTypes := true),
+ " print inferred points-to analysis types")
+ ];
+ fd_doit = (function (f: file) ->
+ analyze_file f;
+ compute_results !ptrResults;
+ if !ptrTypes then print_types ());
+ fd_post_check = false (* No changes *)
+}
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * John Kodumal <jkodumal@eecs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(***********************************************************************)
+(* *)
+(* Flags *)
+(* *)
+(***********************************************************************)
+
+(** Print extra debugging info *)
+val debug : bool ref
+
+(** Debug constraints (print all constraints) *)
+val debug_constraints : bool ref
+
+(** Debug smart alias queries *)
+val debug_aliases : bool ref
+
+(** Debug may alias queries *)
+val debug_may_aliases : bool ref
+
+val smart_aliases : bool ref
+
+(** Print out the top level constraints *)
+val print_constraints : bool ref
+
+(** Make the analysis monomorphic *)
+val analyze_mono : bool ref
+
+(** Disable subtyping *)
+val no_sub : bool ref
+
+(** Make the flow step a no-op *)
+val no_flow : bool ref
+
+(** Show the progress of the flow step *)
+val show_progress : bool ref
+
+(** Treat undefined functions conservatively *)
+val conservative_undefineds : bool ref
+
+(** client can specify particular external functions that
+ * have no side effects *)
+val callHasNoSideEffects : (Cil.exp -> bool) ref
+
+(***********************************************************************)
+(* *)
+(* Building the Points-to Graph *)
+(* *)
+(***********************************************************************)
+
+(** Analyze a file *)
+val analyze_file : Cil.file -> unit
+
+(** Print the type of each lvalue in the program *)
+val print_types : unit -> unit
+
+(***********************************************************************)
+(* *)
+(* High-level Query Interface *)
+(* *)
+(***********************************************************************)
+
+(** If undefined functions are analyzed conservatively, any of the
+ high-level queries may raise this exception *)
+exception UnknownLocation
+
+val may_alias : Cil.exp -> Cil.exp -> bool
+
+val resolve_lval : Cil.lval -> (Cil.varinfo list)
+
+val resolve_exp : Cil.exp -> (Cil.varinfo list)
+
+val resolve_funptr : Cil.exp -> (Cil.fundec list)
+
+(***********************************************************************)
+(* *)
+(* Low-level Query Interface *)
+(* *)
+(***********************************************************************)
+
+(** type for abstract locations *)
+type absloc
+
+(** Give an abstract location for a varinfo *)
+val absloc_of_varinfo : Cil.varinfo -> absloc
+
+(** Give an abstract location for an Cil lvalue *)
+val absloc_of_lval : Cil.lval -> absloc
+
+(** may the two abstract locations be aliased? *)
+val absloc_eq : absloc -> absloc -> bool
+
+val absloc_e_points_to : Cil.exp -> absloc list
+val absloc_e_transitive_points_to : Cil.exp -> absloc list
+
+val absloc_lval_aliases : Cil.lval -> absloc list
+
+(** Print a string representing an absloc, for debugging. *)
+val d_absloc : unit -> absloc -> Pretty.doc
+
+
+(***********************************************************************)
+(* *)
+(* Printing results *)
+(* *)
+(***********************************************************************)
+
+(** Compute points to sets for variables. If true is passed, print the sets. *)
+val compute_results : bool -> unit
+
+(*
+
+Deprecated these. -- jk
+
+(** Compute alias relationships. If true is passed, print all alias pairs. *)
+ val compute_aliases : bool -> unit
+
+(** Compute alias frequncy *)
+val compute_alias_frequency : unit -> unit
+
+
+*)
+
+val compute_aliases : bool -> unit
+
+
+val feature: Cil.featureDescr
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * John Kodumal <jkodumal@eecs.berkeley.edu>
+ * 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.
+ *
+ *)
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU Library General Public License, with *)
+(* the special exception on linking described in file ../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+(* $Id: setp.ml 3691 2003-02-19 19:26:31Z jkodumal $ *)
+
+(* Sets over ordered types *)
+
+module type PolyOrderedType =
+ sig
+ type 'a t
+ val compare: 'a t -> 'a t -> int
+ end
+
+module type S =
+ sig
+ type 'a elt
+ type 'a t
+ val empty: 'a t
+ val is_empty: 'a t -> bool
+ val mem: 'a elt -> 'a t -> bool
+ val add: 'a elt -> 'a t -> 'a t
+ val singleton: 'a elt -> 'a t
+ val remove: 'a elt -> 'a t -> 'a t
+ val union: 'a t -> 'a t -> 'a t
+ val inter: 'a t -> 'a t -> 'a t
+ val diff: 'a t -> 'a t -> 'a t
+ val compare: 'a t -> 'a t -> int
+ val equal: 'a t -> 'a t -> bool
+ val subset: 'a t -> 'a t -> bool
+ val iter: ('a elt -> unit) -> 'a t -> unit
+ val fold: ('a elt -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ val for_all: ('a elt -> bool) -> 'a t -> bool
+ val exists: ('a elt -> bool) -> 'a t -> bool
+ val filter: ('a elt -> bool) -> 'a t -> 'a t
+ val partition: ('a elt -> bool) -> 'a t -> 'a t * 'a t
+ val cardinal: 'a t -> int
+ val elements: 'a t -> 'a elt list
+ val min_elt: 'a t -> 'a elt
+ val max_elt: 'a t -> 'a elt
+ val choose: 'a t -> 'a elt
+ end
+
+module Make(Ord: PolyOrderedType) =
+ struct
+ type 'a elt = 'a Ord.t
+ type 'a t = Empty | Node of 'a t * 'a elt * 'a t * int
+
+ (* Sets are represented by balanced binary trees (the heights of the
+ children differ by at most 2 *)
+
+ let height = function
+ Empty -> 0
+ | Node(_, _, _, h) -> h
+
+ (* Creates a new node with left son l, value x and right son r.
+ l and r must be balanced and | height l - height r | <= 2.
+ Inline expansion of height for better speed. *)
+
+ let create l x r =
+ let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
+ let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+ Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1))
+
+ (* Same as create, but performs one step of rebalancing if necessary.
+ Assumes l and r balanced.
+ Inline expansion of create for better speed in the most frequent case
+ where no rebalancing is required. *)
+
+ let bal l x r =
+ let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
+ let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+ if hl > hr + 2 then begin
+ match l with
+ Empty -> invalid_arg "Set.bal"
+ | Node(ll, lv, lr, _) ->
+ if height ll >= height lr then
+ create ll lv (create lr x r)
+ else begin
+ match lr with
+ Empty -> invalid_arg "Set.bal"
+ | Node(lrl, lrv, lrr, _)->
+ create (create ll lv lrl) lrv (create lrr x r)
+ end
+ end else if hr > hl + 2 then begin
+ match r with
+ Empty -> invalid_arg "Set.bal"
+ | Node(rl, rv, rr, _) ->
+ if height rr >= height rl then
+ create (create l x rl) rv rr
+ else begin
+ match rl with
+ Empty -> invalid_arg "Set.bal"
+ | Node(rll, rlv, rlr, _) ->
+ create (create l x rll) rlv (create rlr rv rr)
+ end
+ end else
+ Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1))
+
+ (* Same as bal, but repeat rebalancing until the final result
+ is balanced. *)
+
+ let rec join l x r =
+ match bal l x r with
+ Empty -> invalid_arg "Set.join"
+ | Node(l', x', r', _) as t' ->
+ let d = height l' - height r' in
+ if d < -2 || d > 2 then join l' x' r' else t'
+
+ (* Merge two trees l and r into one.
+ All elements of l must precede the elements of r.
+ Assumes | height l - height r | <= 2. *)
+
+ let rec merge t1 t2 =
+ match (t1, t2) with
+ (Empty, t) -> t
+ | (t, Empty) -> t
+ | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+ bal l1 v1 (bal (merge r1 l2) v2 r2)
+
+ (* Same as merge, but does not assume anything about l and r. *)
+
+ let rec concat t1 t2 =
+ match (t1, t2) with
+ (Empty, t) -> t
+ | (t, Empty) -> t
+ | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+ join l1 v1 (join (concat r1 l2) v2 r2)
+
+ (* Splitting *)
+
+ let rec split x = function
+ Empty ->
+ (Empty, None, Empty)
+ | Node(l, v, r, _) ->
+ let c = Ord.compare x v in
+ if c = 0 then (l, Some v, r)
+ else if c < 0 then
+ let (ll, vl, rl) = split x l in (ll, vl, join rl v r)
+ else
+ let (lr, vr, rr) = split x r in (join l v lr, vr, rr)
+
+ (* Implementation of the set operations *)
+
+ let empty = Empty
+
+ let is_empty = function Empty -> true | _ -> false
+
+ let rec mem x = function
+ Empty -> false
+ | Node(l, v, r, _) ->
+ let c = Ord.compare x v in
+ c = 0 || mem x (if c < 0 then l else r)
+
+ let rec add x = function
+ Empty -> Node(Empty, x, Empty, 1)
+ | Node(l, v, r, _) as t ->
+ let c = Ord.compare x v in
+ if c = 0 then t else
+ if c < 0 then bal (add x l) v r else bal l v (add x r)
+
+ let singleton x = Node(Empty, x, Empty, 1)
+
+ let rec remove x = function
+ Empty -> Empty
+ | Node(l, v, r, _) ->
+ let c = Ord.compare x v in
+ if c = 0 then merge l r else
+ if c < 0 then bal (remove x l) v r else bal l v (remove x r)
+
+ let rec union s1 s2 =
+ match (s1, s2) with
+ (Empty, t2) -> t2
+ | (t1, Empty) -> t1
+ | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+ if h1 >= h2 then
+ if h2 = 1 then add v2 s1 else begin
+ let (l2, _, r2) = split v1 s2 in
+ join (union l1 l2) v1 (union r1 r2)
+ end
+ else
+ if h1 = 1 then add v1 s2 else begin
+ let (l1, _, r1) = split v2 s1 in
+ join (union l1 l2) v2 (union r1 r2)
+ end
+
+ let rec inter s1 s2 =
+ match (s1, s2) with
+ (Empty, t2) -> Empty
+ | (t1, Empty) -> Empty
+ | (Node(l1, v1, r1, _), t2) ->
+ match split v1 t2 with
+ (l2, None, r2) ->
+ concat (inter l1 l2) (inter r1 r2)
+ | (l2, Some _, r2) ->
+ join (inter l1 l2) v1 (inter r1 r2)
+
+ let rec diff s1 s2 =
+ match (s1, s2) with
+ (Empty, t2) -> Empty
+ | (t1, Empty) -> t1
+ | (Node(l1, v1, r1, _), t2) ->
+ match split v1 t2 with
+ (l2, None, r2) ->
+ join (diff l1 l2) v1 (diff r1 r2)
+ | (l2, Some _, r2) ->
+ concat (diff l1 l2) (diff r1 r2)
+
+ let rec compare_aux l1 l2 =
+ match (l1, l2) with
+ ([], []) -> 0
+ | ([], _) -> -1
+ | (_, []) -> 1
+ | (Empty :: t1, Empty :: t2) ->
+ compare_aux t1 t2
+ | (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) ->
+ let c = Ord.compare v1 v2 in
+ if c <> 0 then c else compare_aux (r1::t1) (r2::t2)
+ | (Node(l1, v1, r1, _) :: t1, t2) ->
+ compare_aux (l1 :: Node(Empty, v1, r1, 0) :: t1) t2
+ | (t1, Node(l2, v2, r2, _) :: t2) ->
+ compare_aux t1 (l2 :: Node(Empty, v2, r2, 0) :: t2)
+
+ let compare s1 s2 =
+ compare_aux [s1] [s2]
+
+ let equal s1 s2 =
+ compare s1 s2 = 0
+
+ let rec subset s1 s2 =
+ match (s1, s2) with
+ Empty, _ ->
+ true
+ | _, Empty ->
+ false
+ | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) ->
+ let c = Ord.compare v1 v2 in
+ if c = 0 then
+ subset l1 l2 && subset r1 r2
+ else if c < 0 then
+ subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2
+ else
+ subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2
+
+ let rec iter f = function
+ Empty -> ()
+ | Node(l, v, r, _) -> iter f l; f v; iter f r
+
+ let rec fold f s accu =
+ match s with
+ Empty -> accu
+ | Node(l, v, r, _) -> fold f l (f v (fold f r accu))
+
+ let rec for_all p = function
+ Empty -> true
+ | Node(l, v, r, _) -> p v && for_all p l && for_all p r
+
+ let rec exists p = function
+ Empty -> false
+ | Node(l, v, r, _) -> p v || exists p l || exists p r
+
+ let filter p s =
+ let rec filt accu = function
+ | Empty -> accu
+ | Node(l, v, r, _) ->
+ filt (filt (if p v then add v accu else accu) l) r in
+ filt Empty s
+
+ let partition p s =
+ let rec part (t, f as accu) = function
+ | Empty -> accu
+ | Node(l, v, r, _) ->
+ part (part (if p v then (add v t, f) else (t, add v f)) l) r in
+ part (Empty, Empty) s
+
+ let rec cardinal = function
+ Empty -> 0
+ | Node(l, v, r, _) -> cardinal l + 1 + cardinal r
+
+ let rec elements_aux accu = function
+ Empty -> accu
+ | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l
+
+ let elements s =
+ elements_aux [] s
+
+ let rec min_elt = function
+ Empty -> raise Not_found
+ | Node(Empty, v, r, _) -> v
+ | Node(l, v, r, _) -> min_elt l
+
+ let rec max_elt = function
+ Empty -> raise Not_found
+ | Node(l, v, Empty, _) -> v
+ | Node(l, v, r, _) -> max_elt r
+
+ let choose = min_elt
+
+ end
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * John Kodumal <jkodumal@eecs.berkeley.edu>
+ * 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.
+ *
+ *)
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU Library General Public License, with *)
+(* the special exception on linking described in file ../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+(* $Id: setp.mli 3691 2003-02-19 19:26:31Z jkodumal $ *)
+
+(** Sets over ordered types.
+
+ This module implements the set data structure, given a total ordering
+ function over the set elements. All operations over sets
+ 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.
+*)
+
+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
+ [f e1 e2] is zero if the elements [e1] and [e2] are equal,
+ [f e1 e2] is strictly negative if [e1] is smaller than [e2],
+ and [f e1 e2] is strictly positive if [e1] is greater than [e2].
+ Example: a suitable ordering function is
+ the generic structural comparison function {!Pervasives.compare}. *)
+ end
+(** Input signature of the functor {!Set.Make}. *)
+
+module type S =
+ sig
+ type 'a elt
+ (** The type of the set elements. *)
+
+ type 'a t
+ (** The type of sets. *)
+
+ val empty: 'a t
+ (** The empty set. *)
+
+ val is_empty: 'a t -> bool
+ (** Test whether a set is empty or not. *)
+
+ val mem: 'a elt -> 'a t -> bool
+ (** [mem x s] tests whether [x] belongs to the set [s]. *)
+
+ val add: 'a elt -> 'a t -> 'a t
+ (** [add x s] returns a set containing all elements of [s],
+ plus [x]. If [x] was already in [s], [s] is returned unchanged. *)
+
+ val singleton: 'a elt -> 'a t
+ (** [singleton x] returns the one-element set containing only [x]. *)
+
+ val remove: 'a elt -> 'a t -> 'a t
+ (** [remove x s] returns a set containing all elements of [s],
+ except [x]. If [x] was not in [s], [s] is returned unchanged. *)
+
+ val union: 'a t -> 'a t -> 'a t
+ (** Set union. *)
+
+ val inter: 'a t -> 'a t -> 'a t
+ (** Set interseection. *)
+
+ (** Set difference. *)
+ val diff: 'a t -> 'a t -> 'a t
+
+ val compare: 'a t -> 'a t -> int
+ (** Total ordering between sets. Can be used as the ordering function
+ for doing sets of sets. *)
+
+ val equal: 'a t -> 'a t -> bool
+ (** [equal s1 s2] tests whether the sets [s1] and [s2] are
+ equal, that is, contain equal elements. *)
+
+ val subset: 'a t -> 'a t -> bool
+ (** [subset s1 s2] tests whether the set [s1] is a subset of
+ the set [s2]. *)
+
+ val iter: ('a elt -> unit) -> 'a t -> unit
+ (** [iter f s] applies [f] in turn to all elements of [s].
+ The order in which the elements of [s] are presented to [f]
+ is unspecified. *)
+
+ val fold: ('a elt -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)],
+ where [x1 ... xN] are the elements of [s].
+ The order in which elements of [s] are presented to [f] is
+ unspecified. *)
+
+ val for_all: ('a elt -> bool) -> 'a t -> bool
+ (** [for_all p s] checks if all elements of the set
+ satisfy the predicate [p]. *)
+
+ 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]. *)
+
+ val partition: ('a elt -> bool) -> 'a t -> 'a t * 'a t
+ (** [partition p s] returns a pair of sets [(s1, s2)], where
+ [s1] is the set of all the elements of [s] that satisfy the
+ predicate [p], and [s2] is the set of all the elements of
+ [s] that do not satisfy [p]. *)
+
+ val cardinal: 'a t -> int
+ (** Return the number of elements of a set. *)
+
+ val elements: 'a t -> 'a elt list
+ (** Return the list of all elements of the given set.
+ The returned list is sorted in increasing order with respect
+ to the ordering [Ord.compare], where [Ord] is the argument
+ given to {!Set.Make}. *)
+
+ val min_elt: 'a t -> 'a elt
+ (** Return the smallest element of the given set
+ (with respect to the [Ord.compare] ordering), or raise
+ [Not_found] if the set is empty. *)
+
+ val max_elt: 'a t -> 'a elt
+ (** Same as {!Set.S.min_elt}, but returns the largest element of the
+ given set. *)
+
+ val choose: 'a t -> 'a elt
+ (** Return one element of the given set, or raise [Not_found] if
+ the set is empty. Which element is chosen is unspecified,
+ but equal elements will be chosen for equal sets. *)
+ end
+(** Output signature of the functor {!Set.Make}. *)
+
+module Make (Ord : PolyOrderedType) : S with type 'a elt = 'a Ord.t
+(** Functor building an implementation of the set structure
+ given a totally ordered type. *)
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * John Kodumal <jkodumal@eecs.berkeley.edu>
+ * 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 file is currently unused by CIL. It is included in the *)
+(* distribution for reference only. *)
+(* *)
+(* *)
+(***********************************************************************)
+
+
+(***********************************************************************)
+(* *)
+(* Type Declarations *)
+(* *)
+(***********************************************************************)
+
+exception Inconsistent of string
+exception Bad_cache
+exception No_contents
+exception Bad_proj
+exception Bad_type_copy
+exception Instantiation_cycle
+
+module U = Uref
+module S = Setp
+module H = Hashtbl
+module Q = Queue
+
+(** Polarity kinds-- positive, negative, or nonpolar. *)
+type polarity = Pos
+ | Neg
+ | Non
+
+(** 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
+ incorrect. However, the bounds will always be correct because if two tau's
+ get unified, their cached instantiations will be re-entered into the
+ worklist, ensuring that any labels find the new bounds *)
+module Bound =
+struct
+ type 'a t = 'a bound
+ let compare (x : 'a t) (y : 'a t) =
+ Pervasives.compare x y
+end
+
+module B = S.Make(Bound)
+
+type 'a boundset = 'a B.t
+
+(** Constants, which identify elements in points-to sets *)
+type constant = int * string
+
+module Constant =
+struct
+ type t = constant
+
+ let compare ((xid,_) : t) ((yid,_) : t) =
+ Pervasives.compare xid yid
+end
+
+module C = Set.Make(Constant)
+
+(** Sets of constants. Set union is used when two labels containing
+ constant sets are unified *)
+type constantset = C.t
+
+type lblinfo = {
+ mutable l_name: string;
+ (** Name of this label *)
+ mutable aliases: constantset;
+ (** Set of constants (tags) for checking aliases *)
+ p_bounds: label boundset U.uref;
+ (** Set of umatched (p) lower bounds *)
+ 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 *)
+ mutable n_cached: bool;
+ (** Flag indicating whether all reachable n edges have been locally cached *)
+ mutable on_path: bool;
+ (** For cycle detection during reachability queries *)
+}
+
+(** Constructor labels *)
+and label = lblinfo U.uref
+
+(** The type of lvalues. *)
+type lvalue = {
+ l: label;
+ contents: tau
+}
+
+(** Data for variables. *)
+and vinfo = {
+ 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;
+ r_cache: cache
+}
+
+(** Data for fun constructors. *)
+and finfo = {
+ 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;
+ p_cache: cache
+}
+
+(** Type constructors discovered by type inference *)
+and tinfo = Wild
+ | Var of vinfo
+ | Ref of rinfo
+ | Fun of finfo
+ | Pair of pinfo
+
+(** The top-level points-to type. *)
+and tau = tinfo U.uref
+
+(** The instantiation constraint cache. The index is used as a key. *)
+and cache = (int,polarity * tau) H.t
+
+(* Type of semi-unification constraints *)
+type su_constraint = Instantiation of tau * (int * polarity) * tau
+ | Unification of tau * tau
+
+(** 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
+ 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.
+
+ 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.
+
+ -- In the recursive call, we see that 'a (or ref('a)) is already in the
+ association list, so the type is recursive. We check the string option,
+ which is None, meaning that this is the first recurrence of the type. We
+ create a new recursive variable, rv and set the string option to 'rv. Next,
+ we prepend u rv. to the string representation we have seen before, "ref(",
+ and return "rv" as the string representation of this type.
+
+ -- The string so far is "u rv.ref(". The recursive call returns, and we
+ 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
+ reuse the same recursive variable name.
+*)
+type association = tau * string ref * string option ref
+
+(***********************************************************************)
+(* *)
+(* Global Variables *)
+(* *)
+(***********************************************************************)
+
+(** Print the instantiations constraints (loops with cyclic structures). *)
+let print_constraints : bool ref = ref false
+
+(** Solve constraints as they are introduced. If this is false, constraints
+ 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
+ debug output. *)
+let debug = ref false
+let debug_constraints = debug
+
+(** If true, print out extra verbose debug information (including contents
+ of label sets *)
+let verbose_debug = ref false
+
+
+(** If true, make the flow step a no-op *)
+let no_flow = ref false
+
+let no_sub = ref false
+
+(** If true, do not add instantiation constraints *)
+let analyze_mono = ref false
+
+(** A counter for generating unique integers. *)
+let counter : int ref = ref 0
+
+(** A list of equality constraints. *)
+let eq_worklist : su_constraint Q.t = Q.create()
+
+(** A list of instantiation constraints. *)
+let inst_worklist : su_constraint Q.t = Q.create()
+
+(***********************************************************************)
+(* *)
+(* Utility Functions *)
+(* *)
+(***********************************************************************)
+
+(** Consistency check for inferred types *)
+let pair_or_var (t : tau) =
+ match (U.deref t) with
+ | Pair _ -> true
+ | Var _ -> true
+ | _ -> false
+
+let ref_or_var (t : tau) =
+ match (U.deref t) with
+ | Ref _ -> true
+ | Var _ -> true
+ | _ -> false
+
+let fun_or_var (t : tau) =
+ match (U.deref t) with
+ | Fun _ -> true
+ | Var _ -> true
+ | _ -> false
+
+(** Generate a unique integer. *)
+let fresh_index () : int =
+ incr counter;
+ !counter
+
+(** Negate a polarity. *)
+let negate (p : polarity) : polarity =
+ match p with
+ | Pos -> Neg
+ | Neg -> Pos
+ | Non -> Non
+
+(** Compute the least-upper-bounds of two polarities. *)
+let lub (p,p' : polarity * polarity) : polarity =
+ match p with
+ | Pos ->
+ begin
+ match p' with
+ | Pos -> Pos
+ | _ -> Non
+ end
+ | Neg ->
+ begin
+ match p' with
+ | Neg -> Neg
+ | _ -> Non
+ end
+ | Non -> Non
+
+(** Extract the cache from a type *)
+let get_cache (t : tau) : cache =
+ match U.deref t with
+ | Wild -> raise Bad_cache
+ | Var v -> v.v_cache
+ | Ref r -> r.r_cache
+ | Pair p -> p.p_cache
+ | Fun f -> f.f_cache
+
+(** Determine whether or not a type is global *)
+let get_global (t : tau) : bool =
+ match U.deref t with
+ | Wild -> false
+ | Var v -> v.v_global
+ | Ref r -> r.r_global
+ | Pair p -> p.p_global
+ | Fun f -> f.f_global
+
+(** Return true if a type is monomorphic (global). *)
+let global_tau = get_global
+
+let global_lvalue lv = get_global lv.contents
+
+(** Return true if e is a member of l (according to uref equality) *)
+let rec ulist_mem e l =
+ match l with
+ | [] -> false
+ | 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
+ | Pos -> "+"
+ | Neg -> "-"
+ | Non -> "T"
+
+(** Convert a label to a string, short representation *)
+let string_of_label2 (l : label) : string =
+ "\"" ^ (U.deref l).l_name ^ "\""
+
+(** Convert a label to a string, long representation *)
+let string_of_label (l : label ) : string =
+ let rec constset_to_string = function
+ | (_,s) :: [] -> s
+ | (_,s) :: t -> s ^ "," ^ (constset_to_string t)
+ | [] -> ""
+ in
+ let aliases = constset_to_string (C.elements ((U.deref l).aliases))
+ in
+ if ( (aliases = "") || (not !verbose_debug))
+ 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 ->
+ 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 =
+ match U.deref t with
+ | 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 tau_map : association list ref = ref [] in
+ 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
+ match (!so) with
+ | None ->
+ begin
+ let rv = fresh_recvar_name(t) in
+ s := "u " ^ rv ^ "." ^ (!s);
+ so := Some (rv);
+ rv
+ end
+ | Some rv -> rv
+ end
+ | None -> (* type's not recursive. Add it to the assoc list and cont. *)
+ let s = ref "" in
+ let so : string option ref = ref None in
+ begin
+ tau_map := (t,s,so) :: (!tau_map);
+
+ (match (U.deref t) with
+ | Wild -> s := "_";
+ | Var v -> s := v.v_name;
+ | Pair p ->
+ begin
+ assert (ref_or_var(p.ptr));
+ assert (fun_or_var(p.lam));
+ s := "{";
+ s := (!s) ^ (string_of_tau' p.ptr);
+ s := (!s) ^ ",";
+ s := (!s) ^ (string_of_tau' p.lam);
+ s := (!s) ^"}"
+
+ end
+ | Ref r ->
+ begin
+ assert(pair_or_var(r.points_to));
+ s := "ref(|";
+ s := (!s) ^ (string_of_label r.rl);
+ s := (!s) ^ "|,";
+ s := (!s) ^ (string_of_tau' r.points_to);
+ s := (!s) ^ ")"
+
+ end
+ | Fun f ->
+ begin
+ assert(pair_or_var(f.ret));
+ let rec string_of_args = function
+ | h :: [] ->
+ begin
+ assert(pair_or_var(h));
+ s := (!s) ^ (string_of_tau' h)
+ end
+ | h :: t ->
+ begin
+ assert(pair_or_var(h));
+ s := (!s) ^ (string_of_tau' h) ^ ",";
+ string_of_args t
+ end
+ | [] -> ()
+ in
+ s := "fun(|";
+ s := (!s) ^ (string_of_label f.fl);
+ s := (!s) ^ "|,";
+ s := (!s) ^ "<";
+ if (List.length !(f.args) > 0)
+ then
+ string_of_args !(f.args)
+ else
+ s := (!s) ^ "void";
+ s := (!s) ^">,";
+ s := (!s) ^ (string_of_tau' f.ret);
+ s := (!s) ^ ")"
+ end);
+ tau_map := List.tl (!tau_map);
+ !s
+ end
+ in
+ string_of_tau' t
+
+(** Convert an lvalue to a string *)
+let rec 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 t_strings = List.map string_of_tau l in
+ let rec print_t_strings = function
+ | h :: [] -> print_string h; print_newline();
+ | h :: t -> print_string h; print_string ", "; print_t_strings t
+ | [] -> ()
+ in
+ print_t_strings t_strings
+
+(** Print a constraint. *)
+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
+ Printf.printf "%s == %s\n" lhs rhs
+ | Instantiation (t,(i,p),t') ->
+ let lhs = string_of_tau t in
+ let rhs = string_of_tau t' in
+ let index = string_of_int i in
+ let pol = string_of_polarity p in
+ 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. *)
+let get_bounds (positive : bool) (l : label) : label boundset U.uref =
+ if (positive) then
+ (U.deref l).p_bounds
+ else
+ (U.deref l).n_bounds
+
+(** Used for cycle detection during the flow step. Returns true if the
+ label [l] is found on the current path. *)
+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. *)
+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
+ Printf.printf "Setting a new global : %s\n" (string_of_tau t);
+ begin
+ assert ( (not (get_global(t)) ) || b );
+ (match U.deref t with
+ | Wild -> ()
+ | Var v -> v.v_global <- b
+ | Ref r -> r.r_global <- b
+ | Pair p -> p.p_global <- b
+ | Fun f -> f.f_global <- b);
+ b
+ end
+
+(** Return a label's bounds as a string *)
+let string_of_bounds (is_pos : bool) (l : label) : string =
+ let bounds =
+ if (is_pos) then
+ U.deref ((U.deref l).p_bounds)
+ else
+ U.deref ((U.deref l).n_bounds)
+ in
+ B.fold (fun b -> fun res -> res ^ (string_of_label2 b.info) ^ " "
+ ) bounds ""
+
+(***********************************************************************)
+(* *)
+(* Type Operations -- these do not create any constraints *)
+(* *)
+(***********************************************************************)
+
+let wild_val = U.uref Wild
+
+(** The wild (don't care) value. *)
+let wild () : tau =
+ wild_val
+
+(** Create an lvalue with label [lbl] and tau contents [t]. *)
+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. *)
+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);
+ 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. *)
+let fresh_label () : label =
+ U.uref {
+ l_name = "l_" ^ (string_of_int (fresh_index()));
+ aliases = (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 fresh 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;
+ v_cache = H.create 4})
+
+(** Create a fresh unnamed variable (name will be 'fv). *)
+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 =
+ 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;
+ 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;
+ r_cache = H.create 4})
+
+(** Create a Pair constructor. *)
+let make_pair (p,f : tau * tau) : tau =
+ U.uref (Pair {ptr = p;
+ p_global = false;
+ 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 =
+ match U.deref t with
+ | Pair _ ->
+ make_pair (fresh_var_i(), fresh_var_i())
+ | Ref _ ->
+ make_ref (fresh_label(),fresh_var_i())
+ | Fun f ->
+ let fresh_fn = fun _ -> fresh_var_i()
+ in
+ make_fun (fresh_label(), List.map fresh_fn !(f.args) , fresh_var_i())
+ | _ -> raise Bad_type_copy
+
+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 =
+ if (!padding > 0) then l' else (padding := -(!padding);l)
+ in
+ for i = 1 to (!padding) do
+ to_pad := (!to_pad) @ [fresh_var()]
+ done
+
+(***********************************************************************)
+(* *)
+(* Constraint Generation/ Resolution *)
+(* *)
+(***********************************************************************)
+
+(** 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 ti,ti' = U.deref t, U.deref t' in
+ match ti,ti' with
+ | Wild, _ -> true
+ | _, Wild -> true
+ | _ -> false
+
+exception Cycle_found
+
+(** Cycle detection between instantiations. Returns true if there is a cycle
+ from t to t' *)
+let exists_cycle (t,t' : tau * tau) : bool =
+ let visited : tau list ref = ref [] in
+ let rec exists_cycle' t =
+ if (ulist_mem t (!visited))
+ then
+ begin (*
+ print_string "Instantiation cycle found :";
+ print_tau_list (!visited);
+ print_newline();
+ print_string (string_of_tau t);
+ print_newline(); *)
+ (* raise Instantiation_cycle *)
+ (* visited := List.tl (!visited) *) (* check *)
+ end
+ else
+ begin
+ visited := t :: (!visited);
+ if (U.equal(t,t'))
+ then raise Cycle_found
+ else
+ H.iter (fun _ -> fun (_,t'') ->
+ if (U.equal (t,t'')) then ()
+ else
+ ignore (exists_cycle' t'')
+ ) (get_cache t) ;
+ visited := List.tl (!visited)
+ end
+ in
+ try
+ exists_cycle' t;
+ false
+ with
+ | Cycle_found -> true
+
+exception Subterm
+
+(** Returns true if [t'] is a proper subterm of [t] *)
+let proper_subterm (t,t') =
+ let visited : tau list ref = ref [] in
+ let rec proper_subterm' t =
+ if (ulist_mem t (!visited))
+ then () (* recursive type *)
+ else
+ if (U.equal (t,t'))
+ then raise Subterm
+ else
+ begin
+ visited := t :: (!visited);
+ (
+ match (U.deref t) with
+ | Wild -> ()
+ | Var _ -> ()
+ | Ref r ->
+ proper_subterm' r.points_to
+ | Pair p ->
+ proper_subterm' p.ptr;
+ proper_subterm' p.lam
+ | Fun f ->
+ proper_subterm' f.ret;
+ List.iter (proper_subterm') !(f.args)
+ );
+ visited := List.tl (!visited)
+ end
+ in
+ try
+ if (U.equal(t,t')) then false
+ else
+ begin
+ proper_subterm' t;
+ false
+ end
+ with
+ | Subterm -> true
+
+(** The extended occurs check. Search for a cycle of instantiations from [t]
+ to [t']. If such a cycle exists, check to see that [t'] is a proper subterm
+ of [t]. If it is, then return true *)
+let eoc (t,t') : bool =
+ if (exists_cycle(t,t') && proper_subterm(t,t'))
+ then
+ begin
+ if (!debug)
+ then
+ Printf.printf "Occurs check : %s occurs within %s\n" (string_of_tau t')
+ (string_of_tau t)
+ else
+ ();
+ 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'))) ||
+ U.equal(t,t') )
+ then ()
+ else
+ let ti,ti' = U.deref t, U.deref t' in
+ match ti,ti' with
+ | Ref r, Ref r' ->
+ instantiate_ref(r,(i,p),r')
+ | Fun f, Fun f' ->
+ instantiate_fun(f,(i,p),f')
+ | Pair pr, Pair pr' ->
+ begin
+ add_constraint_int (Instantiation (pr.ptr,(i,p),pr'.ptr));
+ add_constraint_int (Instantiation (pr.lam,(i,p),pr'.lam))
+ end
+ | Var v, _ -> ()
+ | _,Var v' ->
+ if eoc(t,t')
+ 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'))
+ end
+ | _ -> raise (Inconsistent("instantiate"))
+
+(** Apply instantiations to the ref's label, and structurally down the type.
+ Contents of ref constructors are instantiated with polarity Non. *)
+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.
+ 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')))
+ !(fi.args) !(fi'.args);
+ instantiate_label (fi.fl,(i,p),fi'.fl)
+
+(** 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
+ (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,
+ B.add(make_bound (i,l)) (U.deref li'.p_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,
+ B.add(make_bound (i,l)) (U.deref li'.p_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
+ 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
+ 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'))
+ then ()
+ else
+ let ti, ti' = U.deref t, U.deref t' in
+ begin
+ U.unify combine (t,t');
+ match ti,ti' with
+ | 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
+ 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' ->
+ begin
+ if (set_global t (r.r_global || r'.r_global))
+ then (H.iter (merge_cache t) (get_cache t))
+ else ();
+ H.iter (merge_cache t) r'.r_cache;
+ unify_ref(r,r')
+ end
+ | 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 ();
+ H.iter (merge_cache t) f'.f_cache;
+ unify_fun (f,f');
+ end
+ | Pair p, Pair p' ->
+ begin
+ if (set_global t (p.p_global || p'.p_global))
+ then (H.iter (merge_cache t) (get_cache t))
+ 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))
+ end
+ | _ -> raise (Inconsistent("unify"))
+ end
+
+(** 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 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 =
+ let rec union_args = function
+ | _, [] -> false
+ | [], _ -> true
+ | 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)))
+ 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
+ li.l_name <- li'.l_name
+ else ()
+ in
+ let combine_label (li,li' : lblinfo *lblinfo) : lblinfo =
+ 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
+ begin
+ pick_name(li,li');
+ li.aliases <- C.union (li.aliases) (li'.aliases);
+ U.update (li.p_bounds, (B.union p_bounds p_bounds'));
+ U.update (li.n_bounds, (B.union n_bounds n_bounds'));
+ li
+ end
+ in(*
+ if (!debug) then
+ begin
+ 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);
+ Printf.printf "pbounds : %s\n" (string_of_bounds true l');
+ Printf.printf "nbounds : %s\n\n" (string_of_bounds false l')
+ end; *)
+ U.unify combine_label (l,l')
+ (* if (!debug) then
+ begin
+ Printf.printf "pbounds : %s\n" (string_of_bounds true l);
+ Printf.printf "nbounds : %s\n" (string_of_bounds false l)
+ end *)
+
+(** 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 =
+ match ti,ti' with
+ | Var _, _ -> 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 ();
+ begin
+ match c with
+ | Instantiation _ ->
+ Q.add c inst_worklist
+ | Unification _ ->
+ Q.add c eq_worklist
+ end;
+ if (!debug) then solve_constraints() else ()
+
+(** 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 (!solve_online) then solve_constraints() else ()
+ end
+
+
+(* Fetch constraints, preferring equalities. *)
+and fetch_constraint () : su_constraint option =
+ if (Q.length eq_worklist > 0)
+ then
+ Some (Q.take eq_worklist)
+ else if (Q.length inst_worklist > 0)
+ then
+ Some (Q.take inst_worklist)
+ else
+ 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)
+ else
+ try
+ Some (H.find cache i)
+ 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
+ match target(t,i,p) with
+ | Some (p'',t'') ->
+ if (U.equal (t',t'') && (lub(p,p'') = p''))
+ then
+ false
+ else
+ begin
+ 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'')
+ then ()
+ else
+ begin
+ unstore(t,i);
+ add_constraint_int (Instantiation (t,(i,lub(p,p'')),t''))
+ end;
+ false
+ end
+ | None ->
+ begin
+ H.add cache i (p,t');
+ true
+ end
+
+(** Remove a cached instantiation. Used when type structure changes *)
+and unstore (t,i : tau * int) =
+let cache = get_cache t in
+ H.remove cache i
+
+(** The main solver loop. *)
+and solve_constraints () : unit =
+ match fetch_constraint () with
+ | Some c ->
+ begin
+ (match c with
+ | Instantiation (t,(i,p),t') -> instantiate_int (t,(i,p),t')
+ | Unification (t,t') -> unify_int (t,t')
+ );
+ solve_constraints()
+ end
+ | None -> ()
+
+
+(***********************************************************************)
+(* *)
+(* Interface Functions *)
+(* *)
+(***********************************************************************)
+
+(** Return the contents of the lvalue. *)
+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
+ | Pair p ->
+ (
+ match U.deref (p.ptr) with
+ | Var _ ->
+ begin
+ (* let points_to = make_pair(fresh_var(),fresh_var()) in *)
+ let points_to = fresh_var() in
+ let l = fresh_label() in
+ let r = make_ref(l,points_to)
+ in
+ add_constraint (Unification (p.ptr,r));
+ make_lval(l, points_to)
+ end
+ | Ref r -> make_lval(r.rl, r.points_to)
+ | _ -> raise (Inconsistent("deref"))
+ )
+ | Var v ->
+ begin
+ add_constraint (Unification (t,make_pair(fresh_var(),fresh_var())));
+ deref t
+ end
+ | _ -> raise (Inconsistent("deref -- no top level pair"))
+
+(** Form the union of [t] and [t']. *)
+let join (t : tau) (t' : tau) : tau =
+ let t'' = fresh_var() in
+ add_constraint (Unification (t,t''));
+ add_constraint (Unification (t',t''));
+ t''
+
+(** 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 t' = fresh_var() in
+ begin
+ List.iter (function t'' -> add_constraint (Unification(t',t''))) tl;
+ t'
+ end
+
+(** Take the address of an lvalue. Does not add constraints. *)
+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.
+ Adds an instantiation constraint. *)
+let instantiate (lv : lvalue) (i : int) : lvalue =
+ if (!analyze_mono) then lv
+ else
+ begin
+ let l' = fresh_label () in
+ let t' = fresh_var_i () in
+ instantiate_label(lv.l,(i,Pos),l');
+ add_constraint (Instantiation (lv.contents,(i,Pos),t'));
+ make_lval(l',t') (* check -- fresh label ?? *)
+ end
+
+(** Constraint generated from assigning [t] to [lv]. *)
+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 =
+ match U.deref t with
+ | Pair p -> p.ptr
+ | Var v -> raise No_contents
+ | _ -> raise Bad_proj
+
+(* 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 =
+ match U.deref t with
+ | Pair p -> p.lam
+ | 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
+ | 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
+ [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 f = proj_fun(t) 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 (),
+ 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));
+ (get_args new_fun,new_ret)
+ | Ref _ -> raise (Inconsistent ("apply_ref"))
+ | Pair _ -> raise (Inconsistent ("apply_pair"))
+ | Wild -> raise (Inconsistent("apply_wild"))
+ in
+ pad_args(formals,actuals);
+ 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
+ [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),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
+ monomorphically. *)
+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 =
+ make_var false ("bottom")
+
+(** Unify the result of a function with its return value. *)
+let return (t : tau) (t' : tau) =
+ add_constraint (Unification (t,t'))
+
+
+(***********************************************************************)
+(* *)
+(* Query/Extract Solutions *)
+(* *)
+(***********************************************************************)
+
+(** Unify the data stored in two label bounds. *)
+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
+ first occurence of the specified element [elt]. *)
+let truncate l elt =
+ let keep = ref true in
+ List.filter
+ (fun x ->
+ if (not (!keep))
+ then
+ false
+ else
+ begin
+ if (U.equal(x,elt))
+ then
+ keep := false
+ else ();
+ true
+ end
+ ) l
+
+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)
+ (string_of_label2 h)
+ | h :: t ->
+ begin
+ Printf.printf "%s --> %s\n" (string_of_bounds is_pos h)
+ (string_of_label2 h);
+ debug_cycle_bounds' t
+ end
+ | [] -> ()
+ in
+ debug_cycle_bounds' 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
+ | h :: [] -> string_of_label2 h
+ | [] -> ""
+ | h :: t -> Printf.sprintf "%s,%s" (string_of_label2 h) (string_of_cycle t)
+ in
+ Printf.printf "Collapsing %s cycle around %s:\n" kind (string_of_label2 l);
+ Printf.printf "Elements are: %s\n" (string_of_cycle c);
+ Printf.printf "Per-element bounds:\n";
+ debug_cycle_bounds is_pos c;
+ Printf.printf "Full path is: %s" (string_of_cycle p);
+ print_newline()
+
+(** 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
+ argument label *)
+let rec flow (is_pos : bool) (path : label list) (l : label) : label boundset =
+ let collapse_cycle () =
+ let cycle = truncate path l in
+ debug_cycle (is_pos,cycle,l,path);
+ List.iter (fun x -> U.unify combine_lbounds
+ ((get_bounds is_pos x),get_bounds is_pos l)
+ ) cycle
+ in
+ if (on_path l)
+ then
+ begin
+ collapse_cycle ();
+ (* set_on_path l false; *)
+ B.empty
+ end
+ else
+ 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)
+ end
+ else
+ begin
+ 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
+ (U.deref l).n_cached <- true;
+ B.iter
+ (fun x ->
+ if (U.equal(x.info,l)) then ()
+ else
+ (newbounds :=
+ (B.union (!newbounds) (flow is_pos (l :: path) x.info)))
+ ) (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
+ begin
+ ignore (flow true [] l);
+ B.iter (fun x -> result := C.union (!result) (U.deref(x.info)).aliases )
+ (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);
+ 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 =
+ let result = ref C.empty in
+ begin
+ B.iter (fun x -> result := C.union (!result) (pos_flow x.info))
+ (U.deref (get_bounds false l));
+ !result
+ end
+
+(** Compute a points-to set by computing positive, then negative, then
+ positive-negative flow for a label. *)
+let points_to_int (lv : lvalue) : constantset =
+ let visited_caches : cache list ref = ref [] in
+ let rec points_to_tau (t : tau) : constantset =
+ try
+ begin
+ match U.deref (proj_ref t) with
+ | Var v -> C.empty
+ | Ref r ->
+ begin
+ let pos = pos_flow r.rl in
+ let neg = neg_flow r.rl in
+ let interproc = C.union (pos_neg_flow r.rl) (C.union pos neg)
+ in
+ C.union ((U.deref(r.rl)).aliases) interproc
+ end
+ | _ -> raise (Inconsistent ("points_to"))
+ end
+ with
+ | No_contents ->
+ begin
+ match (U.deref t) with
+ | Var v -> rebuild_flow v.v_cache
+ | _ -> raise (Inconsistent ("points_to"))
+ end
+ and rebuild_flow (c : cache) : constantset =
+ if (List.mem c (!visited_caches) ) (* cyclic instantiations *)
+ then
+ begin
+ (* visited_caches := List.tl (!visited_caches); *) (* check *)
+ C.empty
+ end
+ else
+ begin
+ visited_caches := c :: (!visited_caches);
+ let result = ref (C.empty) in
+ 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
+ (U.deref lv.l).aliases
+ else
+ points_to_tau (lv.contents)
+
+let points_to (lv : lvalue) : string list =
+ List.map snd (C.elements (points_to_int lv))
+
+let alias_query (a_progress : bool) (lv : lvalue list) : int * int =
+ (0,0) (* todo *)
+(*
+ let a_count = ref 0 in
+ let ptsets = 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'))
+ then ()
+ else (incr a_count)
+ in
+ let rec check_alias = function
+ | h :: t ->
+ begin
+ List.iter (record_alias h) ptsets;
+ check_alias t
+ end
+ | [] -> ()
+ in
+ check_alias ptsets;
+ !a_count
+*)
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * John Kodumal <jkodumal@eecs.berkeley.edu>
+ * 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 file is currently unused by CIL. It is included in the *)
+(* distribution for reference only. *)
+(* *)
+(* *)
+(***********************************************************************)
+
+type lvalue
+type tau
+val debug : bool ref
+val debug_constraints : bool ref
+val print_constraints : bool ref
+val no_flow : bool ref
+val no_sub : bool ref
+val analyze_mono : bool ref
+val solve_online : bool ref
+val solve_constraints : unit -> unit
+val rvalue : lvalue -> tau
+val deref : tau -> lvalue
+val join : tau -> tau -> tau
+val join_inits : tau list -> tau
+val address : lvalue -> tau
+val instantiate : lvalue -> int -> lvalue
+val assign : lvalue -> tau -> unit
+val apply : tau -> tau list -> tau
+val make_function : string -> lvalue list -> tau -> tau
+val make_lvalue : bool -> string -> lvalue
+val bottom : unit -> tau
+val return : tau -> tau -> unit
+val make_fresh : string -> tau
+val points_to : lvalue -> string list
+val string_of_lvalue : lvalue -> string
+val global_lvalue : lvalue -> bool
+val alias_query : bool -> lvalue list -> int * int
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * John Kodumal <jkodumal@eecs.berkeley.edu>
+ * 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.
+ *
+ *)
+exception Bad_find
+
+type 'a urefC =
+ Ecr of 'a * int
+ | Link of 'a uref
+and 'a uref = 'a urefC ref
+
+let rec find p =
+ match !p with
+ | Ecr _ -> p
+ | Link p' ->
+ let p'' = find p'
+ in p := Link p''; p''
+
+let uref x = ref (Ecr(x,0))
+
+let equal (p,p') = (find p == find p')
+
+let deref p =
+ match ! (find p) with
+ | Ecr (x,_) -> x
+ | _ -> raise Bad_find
+
+let update (p,x) =
+ let p' = find p
+ in
+ match !p' with
+ | Ecr (_,rank) -> p' := Ecr(x,rank)
+ | _ -> raise Bad_find
+
+let unify f (p,q) =
+ let p',q' = find p, find q in
+ match (!p',!q') with
+ | (Ecr(px,pr),Ecr(qx,qr)) ->
+ let x () = f(px,qx) in
+ if (p' == q') then
+ p' := Ecr(x (),pr)
+ else if pr == qr then
+ (p' := Link q'; q' := Ecr(x (),qr+1))
+ else if pr < qr then
+ (p' := Link q'; q' := Ecr(x (),qr))
+ else (* pr > qr *)
+ (q' := Link p'; p' := Ecr(x (),pr))
+ | _ -> raise Bad_find
+
+let union (p,q) =
+ let p',q' = find p, find q in
+ match (!p',!q') with
+ | (Ecr(px,pr),Ecr(qx,qr)) ->
+ if (p' == q') then
+ ()
+ else if pr == qr then
+ (q' := Ecr(qx, qr+1); p' := Link q')
+ else if pr < qr then
+ p' := Link q'
+ else (* pr > qr *)
+ q' := Link p'
+ | _ -> raise Bad_find
+
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * John Kodumal <jkodumal@eecs.berkeley.edu>
+ * 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.
+ *
+ *)
+type 'a uref
+
+(** Union-find with union by rank and path compression
+
+ This is an implementation of Tarjan's union-find data structure using
+ generics. The interface is analagous to standard references, with the
+ addition of a union operation which makes two references indistinguishable.
+
+*)
+
+val uref: 'a -> 'a uref
+ (** Create a new uref *)
+
+val equal: 'a uref * 'a uref -> bool
+ (** Test whether two urefs share the same equivalence class *)
+
+val deref: 'a uref -> 'a
+ (** Extract the contents of this reference *)
+
+val update: 'a uref * 'a -> unit
+ (** Update the value stored in this reference *)
+
+val unify: ('a * 'a -> 'a) -> 'a uref * 'a uref -> unit
+ (** [unify f (p,q)] unifies references [p] and [q], making them
+ indistinguishable. The contents of the reference are the result of
+ [f] *)
+
+val union: 'a uref * 'a uref -> unit
+ (** [unify (p,q)] unifies references [p] and [q], making them
+ indistinguishable. The contents of the reference are the contents of
+ one of the first or second arguments (unspecified) *)
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * Sumit Gulwani <gulwani@cs.berkeley.edu>
+ * 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
+module E = Errormsg
+module H = Hashtbl
+
+let enabled = ref false
+
+
+(** This is some testing code for polynomial encoding of trees *)
+
+
+(* A tree with named leaves *)
+type tree = Leaf of string | Node of tree * tree
+
+
+(* A polynomial is a list of leaf * monomial. A monomial is a sorted list of
+ * variables. *)
+type mono = int list
+type poly = (string * mono) list
+
+
+(* Multiply a monomial by a variable. Keep the monomial sorted *)
+let rec varTimesMono (v: int) (m: mono) =
+ match m with
+ [] -> [v]
+ | v' :: rest when v' >= v -> v :: m
+ | v' :: rest -> v' :: varTimesMono v rest
+
+(* Multiply a polynomial by a variable *)
+let varTimesPoly (v: int) (p: poly) : poly =
+ List.map (fun (l, m) -> (l, varTimesMono v m)) p
+
+
+(* Add a number of polynomials *)
+let addPoly (pl : poly list) = List.concat pl
+
+
+(* Group a polynomial by leaf *)
+let groupByLeaf (p: poly) : (string * mono list) list =
+ let h: (string, mono) H.t = H.create 127 in
+ let leaves: (string, unit) H.t = H.create 13 in
+ List.iter
+ (fun (l, m) ->
+ H.replace leaves l ();
+ H.add h l m)
+ p;
+ (* Sort the leaves *)
+ let ll = H.fold (fun l _ acc -> l :: acc) leaves [] in
+ let ll = List.sort (fun l1 l2 -> compare l1 l2) ll in
+ List.map
+ (fun l ->
+ let ml = H.find_all h l in
+ (l, ml))
+ ll
+
+
+(* Group a polynomial by monomials *)
+let groupByMonomial (p: poly) : (mono * string list) list =
+ let h: (mono, string) H.t = H.create 127 in
+ let monomials: (mono, unit) H.t = H.create 13 in
+ List.iter
+ (fun (l, m) ->
+ H.replace monomials m ();
+ H.add h m l)
+ p;
+ (* Sort the monomials *)
+ let ml = H.fold (fun m _ acc -> m :: acc) monomials [] in
+ let ml = List.sort (fun l1 l2 -> compare l1 l2) ml in
+ List.map
+ (fun m ->
+ let ll = H.find_all h m in
+ let ll = List.sort compare ll in
+ (m, ll))
+ ml
+
+let docMono (m: mono) : doc =
+ let rec loop (v: int) (degree: int) (rest: mono) : doc =
+ match rest with
+ v' :: rest' when v = v' -> loop v (degree + 1) rest'
+ | _ ->
+ let this =
+ if degree = 1 then
+ dprintf "V%d" v
+ else
+ dprintf "V%d^%d" v degree
+ in
+ this ++
+ (match rest with
+ v :: rest -> loop v 1 rest
+ | [] -> nil)
+ in
+ match m with
+ [] -> num 1
+ | v :: rest -> loop v 1 rest
+
+let printPolyByLeaf (p: poly) =
+ let poly' = groupByLeaf p in
+ List.iter
+ (fun (l, ml) ->
+ ignore (E.log " %s * (@[%a@]) +\n"
+ l (docList (chr '+' ++ break) docMono) ml))
+ poly'
+
+let printPolyByMonomial (p: poly) =
+ let poly' = groupByMonomial p in
+ List.iter
+ (fun (m, ll) ->
+ ignore (E.log " %a * (@[%a@]) +\n"
+ insert (docMono m)
+ (docList (chr '+' ++ break) text) ll))
+ poly'
+
+
+(* Solve a polynomial to find the leaves *)
+let solved: (string, unit) H.t = H.create 17
+let nrSolved = ref 0
+let rec solve (p: poly) =
+ let solvedOne = ref false in
+ (* Find the monos with singletons *)
+ let rec solveMono
+ (mono: (mono * string list))
+ (acc : (mono * string list) list)
+ : (mono * string list) list
+ =
+ let m, vl = mono in
+ (* Find how many unsolved variables we have for this monomial *)
+ let unsolved = List.filter (fun v -> not (H.mem solved v)) vl in
+ match unsolved with
+ [] -> (* Drop it *) acc
+ | [v] -> (* One new variable *)
+ ignore (E.log "Solved %s\n" v);
+ solvedOne := true;
+ H.add solved v ();
+ (* Drop this monomial *)
+ acc
+ | _ -> (m, unsolved) :: acc
+ in
+ H.clear solved;
+ nrSolved := 0;
+ let rec repeat (m: (mono * string list) list) =
+ solvedOne := false;
+ let m' =
+ List.fold_left
+ (fun acc m -> solveMono m acc)
+ []
+ m
+ in
+ if m' = [] then
+ ignore (E.log "That worked\n")
+ else
+ if !solvedOne then repeat m' else begin
+ ignore (E.log "Got stuck with:\n");
+ List.iter
+ (fun (m, ll) ->
+ ignore (E.log " %a * (@[%a@]) +\n"
+ insert (docMono m)
+ (docList (chr '+' ++ break) text) ll))
+ m'
+ end
+ in
+ repeat (groupByMonomial p)
+
+(* Evaluate the ith polynomial for a tree *)
+let rec eval2 (i: int) (t: tree) =
+ match i, t with
+ _, Leaf l -> [(l, [])]
+ | 1, Node (t1, t2) ->
+ addPoly [ varTimesPoly 0 (eval2 1 t1);
+ varTimesPoly 0 (eval2 1 t2);
+ varTimesPoly 1 (eval2 2 t1);
+ varTimesPoly 2 (eval2 2 t2) ]
+ | 2, Node(t1, t2) ->
+ addPoly [ eval2 2 t1;
+ eval2 2 t2 ]
+ | _ -> E.s (bug "eval2")
+
+
+let rec eval2m (i: int) (t: tree) =
+ match i, t with
+ _, Leaf l -> [(l, [])]
+ | 1, Node (t1, t2) ->
+ addPoly [ varTimesPoly 0 (eval2m 1 t1);
+ varTimesPoly 1 (eval2m 1 t2);
+ varTimesPoly 2 (eval2m 2 t1);
+ varTimesPoly 3 (eval2m 2 t2) ]
+ | 2, Node(t1, t2) ->
+ addPoly [ varTimesPoly 4 (eval2m 2 t1);
+ varTimesPoly 5 (eval2m 2 t2) ]
+ | _ -> E.s (bug "eval2m")
+
+let rec eval2t (i: int) (t: tree) =
+ match i, t with
+ _, Leaf l -> [(l, [])]
+ | 1, Node (t1, t2) ->
+ addPoly [ varTimesPoly 0 (eval2t 1 t1);
+ varTimesPoly 1 (eval2t 1 t2);
+ varTimesPoly 2 (eval2t 2 t1);
+ varTimesPoly 3 (eval2t 2 t2) ]
+ | 2, Node(t1, t2) ->
+ addPoly [ varTimesPoly 4 (eval2t 1 t1);
+ varTimesPoly 5 (eval2t 1 t2);
+ varTimesPoly 6 (eval2t 2 t1);
+ varTimesPoly 7 (eval2t 2 t2) ]
+ | _ -> E.s (bug "eval2m")
+
+let rec eval3t (i: int) (t: tree) =
+ match i, t with
+ _, Leaf l -> [(l, [])]
+ | 1, Node (t1, t2) ->
+ addPoly [ varTimesPoly 0 (eval3t 1 t1);
+ varTimesPoly 1 (eval3t 1 t2);
+ varTimesPoly 2 (eval3t 2 t1);
+ varTimesPoly 3 (eval3t 2 t2) ]
+ | 2, Node(t1, t2) ->
+ addPoly [ varTimesPoly 4 (eval3t 2 t1);
+ varTimesPoly 5 (eval3t 2 t2);
+ varTimesPoly 6 (eval3t 3 t1);
+ varTimesPoly 7 (eval3t 3 t2) ]
+ | 3, Node(t1, t2) ->
+ addPoly [ varTimesPoly 8 (eval3t 3 t1);
+ varTimesPoly 9 (eval3t 3 t2);
+ varTimesPoly 10 (eval3t 1 t1);
+ varTimesPoly 11 (eval3t 1 t2) ]
+ | _ -> E.s (bug "eval2m")
+
+let treeDepth = ref 8
+
+let test_poly () =
+ ignore (E.log "Here I am playing with polynomials\n");
+ let rec mkBalanced (path: string) (depth: int) =
+ if depth = 0 then
+ Leaf path
+ else
+ Node (mkBalanced (path ^ "L") (depth - 1),
+ mkBalanced (path ^ "R") (depth - 1))
+ in
+ let t = mkBalanced "" !treeDepth in
+ let p = eval3t 1 t in
+ printPolyByMonomial p;
+ solve p;
+ ()
+
+let doit (f: file) =
+ let rec doOneFunction (fi: fundec) =
+ ignore (E.log "RAND: doing function %s\n" fi.svar.vname);
+ (* Let's do a topological sort of the statements. We scan statements and
+ * we remember those that we have done. We also keep a todo list. These
+ * are statements that are waiting on some predecessor to be done *)
+ let root: stmt option =
+ match fi.sbody.bstmts with
+ [] -> (* Empty function *) None
+ | f :: _ -> Some f
+ in
+ let todo: stmt list ref =
+ ref (match root with None -> [] | Some r -> [r]) in
+ let doneStmts : (int, unit) H.t = H.create 13 in
+ let doOneStatement (s: stmt) =
+ if H.mem doneStmts s.sid then () else begin
+ ignore (E.log " %d," s.sid);
+ H.add doneStmts s.sid ();
+ (* Now add all successors to the todo list *)
+ todo := s.succs @ !todo
+ end
+ in
+ let rec loop () =
+ match !todo with
+ [] -> (* We are done *) ()
+ | n :: rest ->
+ (* Pick one that has all the predecessors done *)
+ let ready, notready =
+ List.partition
+ (fun n ->
+ H.mem doneStmts n.sid ||
+ List.for_all (fun p -> H.mem doneStmts p.sid) n.preds)
+ !todo
+ in
+ (* See if there are no ready statements *)
+ if ready = [] then begin
+ (* Break a cycle on the first element in todo *)
+ ignore (E.log "(*)");
+ todo := rest;
+ doOneStatement n;
+ loop ();
+ end else begin
+ todo := notready; (* notready is shorter now *)
+ (* Do all the ready ones *)
+ List.iter doOneStatement ready;
+ loop ()
+ end
+
+ in
+ Stats.time "rand" loop ();
+ ignore (E.log "\n");
+ in
+ List.iter
+ (fun g ->
+ match g with
+ GFun (fi, _) -> doOneFunction fi
+ | _ -> ())
+ f.globals
+
+
+let feature : featureDescr =
+ { fd_name = "rand";
+ fd_enabled = enabled;
+ fd_description = "randomized global value numbering";
+ fd_extraopt = [
+ ("--rand-test-poly", Arg.Unit test_poly,
+ "do some testing with polynomials");
+ ("--rand-test-depth", Arg.Int (fun n -> treeDepth := n),
+ "the depth of the tree")
+ ];
+ fd_doit = doit;
+ fd_post_check = false; (* No changes to the file *)
+}
+
--- /dev/null
+(* Calculate reaching definitions for each instruction.
+ * Determine when it is okay to replace some variables with
+ * expressions.
+ *
+ * After calling computeRDs on a fundec,
+ * ReachingDef.stmtStartData will contain a mapping from
+ * statement ids to data about which definitions reach each
+ * statement. ReachingDef.defIdStmtHash will contain a
+ * mapping from definition ids to the statement in which
+ * that definition takes place.
+ *
+ * instrRDs takes a list of instructions, and the
+ * definitions that reach the first instruction, and
+ * for each instruction figures out which definitions
+ * reach into or out of each instruction.
+ *
+ *)
+
+open Cil
+open Pretty
+
+module E = Errormsg
+module DF = Dataflow
+module UD = Usedef
+module L = Liveness
+module IH = Inthash
+module U = Util
+module S = Stats
+
+let debug_fn = ref ""
+
+let doTime = ref false
+
+let time s f a =
+ if !doTime then
+ S.time s f a
+ else f a
+
+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, None -> 1
+ | None, Some i2 -> -1
+ | None, None -> 0
+ end)
+
+let debug = ref false
+
+(* return the intersection of
+ Inthashes ih1 and ih2 *)
+let ih_inter ih1 ih2 =
+ let ih' = IH.copy ih1 in
+ IH.iter (fun id vi ->
+ if not(IH.mem ih2 id) then
+ IH.remove ih' id else
+ ()) ih1;
+ ih'
+
+let ih_union ih1 ih2 =
+ let ih' = IH.copy ih1 in
+ IH.iter (fun id vi ->
+ if not(IH.mem ih' id)
+ then IH.add ih' id vi
+ else ()) ih2;
+ ih'
+
+(* Lookup varinfo in iosh. If the set contains None
+ or is not a singleton, return None, otherwise
+ return Some of the singleton *)
+(* IOS.t IH.t -> varinfo -> int option *)
+let iosh_singleton_lookup iosh vi =
+ if IH.mem iosh vi.vid then
+ let ios = IH.find iosh vi.vid in
+ if not (IOS.cardinal ios = 1) then None
+ else IOS.choose ios
+ else None
+
+(* IOS.t IH.t -> varinfo -> IOS.t *)
+let iosh_lookup iosh vi =
+ if IH.mem iosh vi.vid
+ then Some(IH.find iosh vi.vid)
+ else None
+
+(* return Some(vid) if iosh contains defId.
+ return None otherwise *)
+(* IOS.t IH.t -> int -> int option *)
+let iosh_defId_find iosh defId =
+ (* int -> IOS.t -> int option -> int option*)
+ let get_vid vid ios io =
+ match io with
+ Some(i) -> Some(i)
+ | None ->
+ let there = IOS.exists
+ (function None -> false
+ | Some(i') -> defId = i') ios in
+ if there then Some(vid) else None
+ in
+ IH.fold get_vid iosh None
+
+(* The resulting iosh will contain the
+ union of the same entries from iosh1 and
+ iosh2. If iosh1 has an entry that iosh2
+ does not, then the result will contain
+ None in addition to the things from the
+ entry in iosh1. *)
+(* XXX this function is a performance bottleneck *)
+let iosh_combine iosh1 iosh2 =
+ let iosh' = IH.copy iosh1 in
+ IH.iter (fun id ios1 ->
+ try let ios2 = IH.find iosh2 id in
+ let newset = IOS.union ios1 ios2 in
+ IH.replace iosh' id newset;
+ with Not_found ->
+ let newset = IOS.add None ios1 in
+ IH.replace iosh' id newset) iosh1;
+ IH.iter (fun id ios2 ->
+ try ignore(IH.find iosh1 id)
+ with Not_found -> begin
+ (*if not(IH.mem iosh1 id) then*)
+ let newset = IOS.add None ios2 in
+ IH.add iosh' id newset end) iosh2;
+ iosh'
+
+
+(* determine if two IOS.t IH.t s are the same *)
+let iosh_equals iosh1 iosh2 =
+(* if IH.length iosh1 = 0 && not(IH.length iosh2 = 0) ||
+ IH.length iosh2 = 0 && not(IH.length iosh1 = 0)*)
+ if not(IH.length iosh1 = IH.length iosh2)
+ then
+ (if !debug then ignore(E.log "iosh_equals: length not same: %d %d\n"
+ (IH.length iosh1) (IH.length iosh2));
+ false)
+ else
+ IH.fold (fun vid ios b ->
+ if not b then b else
+ try let ios2 = IH.find iosh2 vid in
+ if not(IOS.compare ios ios2 = 0) then
+ (if !debug then ignore(E.log "iosh_equals: sets for vid %d not equal\n" vid);
+ false)
+ else true
+ 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 *)
+let iosh_replace iosh i vi =
+ if IH.mem iosh vi.vid then
+ let newset = IOS.singleton (Some i) in
+ IH.replace iosh vi.vid newset
+ else
+ let newset = IOS.singleton (Some i) in
+ IH.add iosh vi.vid newset
+
+
+let iosh_filter_dead iosh vs = iosh
+(* IH.iter (fun vid _ ->
+ if not(UD.VS.exists (fun vi -> vid = vi.vid) vs)
+ then IH.remove iosh vid)
+ iosh;
+ iosh*)
+
+
+(* remove definitions that are killed.
+ add definitions that are gend *)
+(* Takes the defs, the data, and a function for
+ obtaining the next def id *)
+(* VS.t -> IOS.t IH.t -> (unit->int) -> unit *)
+let proc_defs vs iosh f =
+ let pd vi =
+ let newi = f() in
+ if !debug then
+ ignore (E.log "proc_defs: genning %d\n" newi);
+ iosh_replace iosh newi vi
+ in
+ UD.VS.iter pd vs
+
+let idMaker () start =
+ let counter = ref start in
+ fun () ->
+ let ret = !counter in
+ counter := !counter + 1;
+ ret
+
+(* given reaching definitions into a list of
+ instructions, figure out the definitions that
+ reach in/out of each instruction *)
+(* if out is true then calculate the definitions that
+ go out of each instruction, if it is false then
+ calculate the definitions reaching into each instruction *)
+(* instr list -> int -> (varinfo IH.t * int) -> bool -> (varinfo IH.t * int) list *)
+let iRDsHtbl = Hashtbl.create 128
+let instrRDs il sid (ivih, s, iosh) out =
+ if Hashtbl.mem iRDsHtbl (sid,out) then Hashtbl.find iRDsHtbl (sid,out) else
+
+(* let print_instr i (_,s', iosh') = *)
+(* let d = d_instr () i ++ line in *)
+(* fprint stdout 80 d; *)
+(* flush stdout *)
+(* in *)
+
+ let proc_one hil i =
+ match hil with
+ | [] ->
+ let _, defd = UD.computeUseDefInstr i in
+ if UD.VS.is_empty defd
+ then ((*if !debug then print_instr i ((), s, iosh);*)
+ [((), s, iosh)])
+ else
+ let iosh' = IH.copy iosh in
+ proc_defs defd iosh' (idMaker () s);
+ (*if !debug then
+ print_instr i ((), s + UD.VS.cardinal defd, iosh');*)
+ ((), s + UD.VS.cardinal defd, iosh')::hil
+ | (_, s', iosh')::hrst as l ->
+ let _, defd = UD.computeUseDefInstr i in
+ if UD.VS.is_empty defd
+ then
+ ((*if !debug then
+ print_instr i ((),s', iosh');*)
+ ((), s', iosh')::l)
+ else let iosh'' = IH.copy iosh' in
+ proc_defs defd iosh'' (idMaker () s');
+ (*if !debug then
+ print_instr i ((), s' + UD.VS.cardinal defd, iosh'');*)
+ ((),s' + UD.VS.cardinal defd, iosh'')::l
+ in
+ let folded = List.fold_left proc_one [((),s,iosh)] il in
+ let foldedout = List.tl (List.rev folded) in
+ let foldednotout = List.rev (List.tl folded) in
+ Hashtbl.add iRDsHtbl (sid,true) foldedout;
+ Hashtbl.add iRDsHtbl (sid,false) foldednotout;
+ if out then foldedout else foldednotout
+
+
+
+(* The right hand side of an assignment is either
+ a function call or an expression *)
+type rhs = RDExp of exp | RDCall of instr
+
+(* take the id number of a definition and return
+ the rhs of the definition if there is one.
+ Returns None if, for example, the definition is
+ caused by an assembly instruction *)
+(* stmt IH.t -> (()*int*IOS.t IH.t) IH.t -> int -> (rhs * int * IOS.t IH.t) option *)
+let rhsHtbl = IH.create 64 (* to avoid recomputation *)
+let getDefRhs didstmh stmdat defId =
+ if IH.mem rhsHtbl defId then IH.find rhsHtbl defId else
+ let stm =
+ try IH.find didstmh defId
+ with Not_found -> E.s (E.error "getDefRhs: defId %d not found\n" defId) in
+ let (_,s,iosh) =
+ try IH.find stmdat stm.sid
+ with Not_found -> E.s (E.error "getDefRhs: sid %d not found \n" stm.sid) in
+ match stm.skind with
+ Instr il ->
+ let ivihl = instrRDs il stm.sid ((),s,iosh) true in (* defs that reach out of each instr *)
+ let ivihl_in = instrRDs il stm.sid ((),s,iosh) false in (* defs that reach into each instr *)
+ begin try
+ let iihl = List.combine (List.combine il ivihl) ivihl_in in
+ (try let ((i,(_,_,diosh)),(_,_,iosh_in)) = List.find (fun ((i,(_,_,iosh')),_) ->
+ match time "iosh_defId_find" (iosh_defId_find iosh') defId with
+ Some vid ->
+ (match i with
+ Set((Var vi',NoOffset),_,_) -> vi'.vid = vid (* _ -> NoOffset *)
+ | Call(Some(Var vi',NoOffset),_,_,_) -> vi'.vid = vid (* _ -> NoOffset *)
+ | Call(None,_,_,_) -> false
+ | Asm(_,_,sll,_,_,_) -> List.exists
+ (function (_,_,(Var vi',NoOffset)) -> vi'.vid = vid | _ -> false) sll
+ | _ -> false)
+ | None -> false) iihl in
+ (match i with
+ Set((lh,_),e,_) ->
+ (match lh with
+ Var(vi') ->
+ (IH.add rhsHtbl defId (Some(RDExp(e),stm.sid,iosh_in));
+ Some(RDExp(e), stm.sid, iosh_in))
+ | _ -> E.s (E.error "Reaching Defs getDefRhs: right vi not first\n"))
+ | 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) (* ? *)
+ with Not_found ->
+ (if !debug then ignore (E.log "getDefRhs: No instruction defines %d\n" defId);
+ IH.add rhsHtbl defId None;
+ None))
+ with Invalid_argument _ -> None end
+ | _ -> E.s (E.error "getDefRhs: defining statement not an instruction list %d\n" defId)
+ (*None*)
+
+let prettyprint didstmh stmdat () (_,s,iosh) = (*text ""*)
+ seq line (fun (vid,ios) ->
+ num vid ++ text ": " ++
+ IOS.fold (fun io d -> match io with
+ None -> d ++ text "None "
+ | Some i ->
+ (*let stm = IH.find didstmh i in*)
+ match getDefRhs didstmh stmdat i with
+ None -> d ++ num i
+ | Some(RDExp(e),_,_) ->
+ d ++ num i ++ text " " ++ (d_exp () e)
+ | Some(RDCall(c),_,_) ->
+ d ++ num i ++ text " " ++ (d_instr () c))
+ ios nil)
+ (IH.tolist iosh)
+
+module ReachingDef =
+ struct
+
+ let name = "Reaching Definitions"
+
+ let debug = debug
+
+ (* Should the analysis calculate may-reach
+ or must-reach *)
+ let mayReach = ref false
+
+
+ (* An integer that tells the id number of
+ the first definition *)
+ (* Also a hash from variable ids to a set of
+ definition ids that reach this statement.
+ None means there is a path to this point on which
+ there is no definition of the variable *)
+ type t = (unit * int * IOS.t IH.t)
+
+ let copy (_, i, iosh) = ((), i, IH.copy iosh)
+
+ (* entries for starting statements must
+ be added before calling compute *)
+ let stmtStartData = IH.create 32
+
+ (* a mapping from definition ids to
+ the statement corresponding to that id *)
+ let defIdStmtHash = IH.create 32
+
+ (* mapping from statement ids to statements
+ for better performance of ok_to_replace *)
+ let sidStmtHash = IH.create 64
+
+ (* pretty printer *)
+ let pretty = prettyprint defIdStmtHash stmtStartData
+
+
+ (* The first id to use when computeFirstPredecessor
+ is next called *)
+ let nextDefId = ref 0
+
+ (* Count the number of variable definitions in
+ a statement *)
+ let num_defs stm =
+ match stm.skind with
+ Instr(il) -> List.fold_left (fun s i ->
+ let _, d = UD.computeUseDefInstr i in
+ s + UD.VS.cardinal d) 0 il
+ | _ -> let _, d = UD.computeUseDefStmtKind stm.skind in
+ UD.VS.cardinal d
+
+ (* the first predecessor is just the data in along with
+ the id of the first definition of the statement,
+ which we get from nextDefId *)
+ let computeFirstPredecessor stm (_, s, iosh) =
+ let startDefId = max !nextDefId s in
+ let numds = num_defs stm in
+ let rec loop n =
+ if n < 0
+ then ()
+ else
+ (if !debug then
+ ignore (E.log "RD: defId %d -> stm %d\n" (startDefId + n) stm.sid);
+ IH.add defIdStmtHash (startDefId + n) stm;
+ loop (n-1))
+ in
+ loop (numds - 1);
+ nextDefId := startDefId + numds;
+ match L.getLiveSet stm.sid with
+ | 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
+ else begin
+ Some((), os, time "iosh_combine" (iosh_combine oiosh) iosh)
+ end
+ end
+
+ (* return an action that removes things that
+ are redefinied and adds the generated defs *)
+ let doInstr inst (_, s, iosh) =
+ if !debug then E.log "RD: looking at %a\n" d_instr inst;
+ let transform (_, s', iosh') =
+ let _, defd = UD.computeUseDefInstr inst in
+ proc_defs defd iosh' (idMaker () s');
+ ((), s' + UD.VS.cardinal defd, iosh')
+ in
+ DF.Post transform
+
+ (* all the work gets done at the instruction level *)
+ let doStmt stm (_, s, iosh) =
+ if not(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
+ | None -> DF.SDefault
+ | Some vs -> begin
+ DF.SUse((),s,iosh_filter_dead iosh vs)
+ (*DF.SDefault*)
+ end
+
+
+ let doGuard condition _ = DF.GDefault
+
+ let filterStmt stm = true
+
+end
+
+module RD = DF.ForwardsDataFlow(ReachingDef)
+
+(* map all variables in vil to a set containing
+ None in iosh *)
+(* IOS.t IH.t -> varinfo list -> () *)
+let iosh_none_fill iosh vil =
+ List.iter (fun vi ->
+ IH.add iosh vi.vid (IOS.singleton None))
+ vil
+
+let clearMemos () =
+ IH.clear rhsHtbl;
+ Hashtbl.clear iRDsHtbl
+
+(* Computes the reaching definitions for a
+ function. *)
+(* Cil.fundec -> unit *)
+let computeRDs fdec =
+ try
+ if compare fdec.svar.vname (!debug_fn) = 0 then
+ (debug := true;
+ ignore (E.log "%s =\n%a\n" (!debug_fn) d_block fdec.sbody));
+ let bdy = fdec.sbody in
+ let slst = bdy.bstmts in
+ IH.clear ReachingDef.stmtStartData;
+ IH.clear ReachingDef.defIdStmtHash;
+ IH.clear rhsHtbl;
+ Hashtbl.clear iRDsHtbl;
+ ReachingDef.nextDefId := 0;
+ let fst_stm = List.hd slst in
+ let fst_iosh = IH.create 32 in
+ UD.onlyNoOffsetsAreDefs := true;
+ IH.add ReachingDef.stmtStartData fst_stm.sid ((), 0, fst_iosh);
+ time "liveness" L.computeLiveness fdec;
+ UD.onlyNoOffsetsAreDefs := true;
+ ignore(ReachingDef.computeFirstPredecessor fst_stm ((), 0, fst_iosh));
+ (match L.getLiveSet fst_stm.sid with
+ | None -> if !debug then ignore(E.log "Nothing live at fst_stm\n")
+ | Some vs -> ignore(iosh_filter_dead fst_iosh vs));
+ if !debug then
+ ignore (E.log "computeRDs: fst_stm.sid=%d\n" fst_stm.sid);
+ RD.compute [fst_stm];
+ 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
+ debug := false
+
+(* return the definitions that reach the statement
+ with statement id sid *)
+let getRDs sid =
+ try
+ Some (IH.find ReachingDef.stmtStartData sid)
+ with Not_found ->
+ None
+(* E.s (E.error "getRDs: sid %d not found\n" sid) *)
+
+let getDefIdStmt defid =
+ try
+ Some(IH.find ReachingDef.defIdStmtHash defid)
+ with Not_found ->
+ None
+
+let getStmt sid =
+ try Some(IH.find ReachingDef.sidStmtHash sid)
+ with Not_found -> None
+
+(* returns the rhs for the definition *)
+let getSimpRhs defId =
+ let rhso = getDefRhs ReachingDef.defIdStmtHash
+ ReachingDef.stmtStartData defId in
+ match rhso with None -> None
+ | Some(r,_,_) -> Some(r)
+
+(* check if i is responsible for defId *)
+(* instr -> int -> bool *)
+let isDefInstr i defId =
+ match getSimpRhs defId with
+ Some(RDCall i') -> Util.equals i i'
+ | _ -> false
+
+(* Pretty print the reaching definition data for
+ a function *)
+let ppFdec fdec =
+ seq line (fun stm ->
+ let ivih = IH.find ReachingDef.stmtStartData stm.sid in
+ ReachingDef.pretty () ivih) fdec.sbody.bstmts
+
+
+(* If this class is extended with a visitor on expressions,
+ then the current rd data is available at each expression *)
+class rdVisitorClass = object (self)
+ inherit nopCilVisitor
+
+ (* the statement being worked on *)
+ val mutable sid = -1
+
+ (* if a list of instructions is being processed,
+ then this is the corresponding list of
+ reaching definitions *)
+ val mutable rd_dat_lst = []
+
+ (* these are the reaching defs for the current
+ instruction if there is one *)
+ val mutable cur_rd_dat = None
+
+ method vstmt stm =
+ sid <- stm.sid;
+ match getRDs sid with
+ None ->
+ if !debug then ignore(E.log "rdVis: stm %d had no data\n" sid);
+ cur_rd_dat <- None;
+ DoChildren
+ | Some(_,s,iosh) ->
+ match stm.skind with
+ Instr il ->
+ if !debug then ignore(E.log "rdVis: visit il\n");
+ rd_dat_lst <- instrRDs il stm.sid ((),s,iosh) false;
+ DoChildren
+ | _ ->
+ if !debug then ignore(E.log "rdVis: visit non-il\n");
+ cur_rd_dat <- None;
+ DoChildren
+
+ 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" ->
+ if !debug then ignore(E.log "rdVis: il rd_dat_lst mismatch\n");
+ DoChildren
+
+ method get_cur_iosh () =
+ match cur_rd_dat with
+ None -> (match getRDs sid with
+ None -> None
+ | Some(_,_,iosh) -> Some iosh)
+ | Some(_,_,iosh) -> Some iosh
+
+end
+
--- /dev/null
+(* These are functions etc. for removing CIL generated
+ temporary variables. Some can be removed immediately,
+ others must wait until pretty printing *)
+
+open Cil
+open Pretty
+open Expcompare
+
+module E = Errormsg
+module RD = Reachingdefs
+module AELV = Availexpslv
+module UD = Usedef
+module IH = Inthash
+module S = Stats
+
+module IS =
+ Set.Make(struct
+ type t = int
+ let compare = Pervasives.compare
+ end)
+
+let debug = RD.debug
+
+let doTime = ref false
+
+let time s f a =
+ if !doTime then
+ S.time s f a
+ else f a
+
+
+(* Type for the form of temporary variable names *)
+type nameform = Suffix of string | Prefix of string | Exact of string
+
+(* take the id number of a definition and return
+ the rhs of the definition if there is one.
+ Returns None if, for example, the definition is
+ caused by an assembly instruction *)
+(* int -> (rhs * int * IOS.t IH.t) option *)
+let getDefRhs = RD.getDefRhs
+ RD.ReachingDef.defIdStmtHash
+ RD.ReachingDef.stmtStartData
+
+(* exp_is_ok_replacement -
+ Returns false if the argument contains a pointer dereference
+ or a variable whose address is taken anywhere *)
+
+let exp_ok = ref true
+class memReadOrAddrOfFinderClass = object(self)
+ inherit nopCilVisitor
+
+ method vexpr e = match e with
+ Lval(Mem _, _) ->
+ exp_ok := false;
+ SkipChildren
+ | _ -> DoChildren
+
+ 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
+ ignore(E.log "memReadOrAddrOfFinder: %s has its address taken\n"
+ vi.vname);
+ exp_ok := false;
+ SkipChildren)
+ else (if !debug then ignore(E.log "memReadOrAddrOfFinder: %s does not have its address taken\n"
+ vi.vname);
+ DoChildren)
+
+end
+
+let memReadOrAddrOfFinder = new memReadOrAddrOfFinderClass
+
+(* exp -> bool *)
+let exp_is_ok_replacement e =
+ if !debug then ignore(E.log "exp_is_ok_replacement: in exp_is_ok_replacement with %a\n"
+ d_exp e);
+ exp_ok := true;
+ ignore(visitCilExpr memReadOrAddrOfFinder e);
+ !exp_ok
+
+let emptyStmt = mkEmptyStmt ()
+let fsr = ref emptyStmt
+class stmtFinderClass sid = object(self)
+ inherit nopCilVisitor
+
+ method vstmt stm =
+ if stm.sid = sid
+ then (fsr := stm; SkipChildren)
+ else DoChildren
+
+end
+
+let find_statement f sid = RD.getStmt sid
+
+(* Are there writes to memory in between
+ the two statements with the given ids *)
+(* fundec -> int -> int -> bool *)
+let wbHtbl = Hashtbl.create 256
+let writes_between f dsid sid =
+ if Hashtbl.mem wbHtbl (dsid,sid) then Hashtbl.find wbHtbl (dsid,sid) else
+ let dstmo = find_statement f dsid in
+ let stmo = find_statement f sid in
+ let find_write s = match s.skind with
+ Instr il -> List.exists (fun i ->
+ match i with
+ Set((Mem _,_),_,_) -> true (* pointer write *)
+ | Set((_,Index (_,_)),_,_) -> true (* array write *)
+ | Call(_,_,_,_) -> true
+ | _ -> false) il
+ | _ -> false
+ in
+ (* is there a path from start to goal that includes an
+ instruction that writes to memory? Do a dfs *)
+ let visited_sid_isr = ref IS.empty in
+ let rec dfs goal b start =
+ if !debug then ignore(E.log "writes_between: dfs visiting %a\n" d_stmt start);
+ if start.sid = goal.sid then
+ let wh = find_write start in
+ (if !debug && b then ignore(E.log "writes_between: start=goal and found a write\n");
+ if !debug && (not b) then ignore(E.log "writes_between: start=goal and no write\n");
+ 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
+ (* 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
+ | 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 ->
+ E.s (E.error "writes_between: defining stmt not an instr\n")
+ | Some stm, Some dstm ->
+ let _ = visited_sid_isr := IS.singleton stm.sid in
+ let from_stm = List.fold_left (dfs stm) false stm.succs in
+ let _ = visited_sid_isr := IS.empty in
+ let from_dstm = dfs stm false dstm in
+ (Hashtbl.add wbHtbl (dsid,sid) (from_stm || from_dstm);
+ from_stm || from_dstm)
+
+(* returns true when the variables in uses
+ * have the same definition ids in both curiosh
+ * and defiosh or are global and not defined in
+ * the current function *)
+let verify_unmodified uses fdefs curiosh defiosh =
+ UD.VS.fold (fun vi b ->
+ let curido = RD.iosh_singleton_lookup curiosh vi in
+ let defido = RD.iosh_singleton_lookup defiosh vi in
+ match curido, defido with
+ Some(curid), Some(defid) ->
+ (if !debug then ignore (E.log "verify_unmodified: curido: %d defido: %d\n" curid defid);
+ curid = defid && b)
+ | 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
+ 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)
+ RD.ReachingDef.pretty ((),0,defiosh));
+ false))
+ uses true
+
+let fdefs = ref UD.VS.empty
+let udDeepSkindHtbl = IH.create 64
+class defCollectorClass = object(self)
+ inherit nopCilVisitor
+
+ method vstmt s =
+ let _,d = if IH.mem udDeepSkindHtbl s.sid
+ then IH.find udDeepSkindHtbl s.sid
+ else let u',d' = UD.computeDeepUseDefStmtKind s.skind in
+ IH.add udDeepSkindHtbl s.sid (u',d');
+ (u',d') in
+ fdefs := UD.VS.union !fdefs d;
+ DoChildren
+
+end
+
+let defCollector = new defCollectorClass
+
+let collect_fun_defs fd =
+ fdefs := UD.VS.empty;
+ ignore(visitCilFunction defCollector fd);
+ !fdefs
+
+(* ok_to_replace *)
+(* is it alright to replace a variable use with the expression
+ that the variable was defined to be? *)
+(* Takes the definitions that reached the place where the
+ variable was defined and the definitions that reach the
+ place the variable is used. If the same definitions for
+ the variables used in the expression reach both places,
+ then it is okay to replace the variable with the expression. *)
+(* With regards to globals and parameters there are two
+ possibilities if the reverse lookup returns None for both
+ sets of reaching definitions:
+ 1) The global or parameter is actually not redefined.
+ 2) At both points no one definition *must* reach there.
+ For this reason, this function also takes the fundec,
+ so that it can be figured out which is the case *)
+(* varinfo -> varinfo IH.t -> sid -> varinfo IH.t -> fundec -> rhs -> bool *)
+(* sid is an int that is the statement id of the statement where
+ we are trying to do a replacement *)
+(* vi is the varinfo of the variable that we are trying to replace *)
+let ok_to_replace vi curiosh sid defiosh dsid f r =
+ let uses, safe = match r with
+ RD.RDExp e -> (UD.computeUseExp e, exp_is_ok_replacement e)
+ | RD.RDCall (Call(_,_,el,_) as i) ->
+ let safe = List.fold_left (fun b e ->
+ (exp_is_ok_replacement e) && b) true el in
+ let u,d = UD.computeUseDefInstr i in
+ u, safe
+ | _ -> E.s (E.bug "ok_to_replace: got non Call in RDCall.")
+ in
+ let target_addrof = if vi.vaddrof || vi.vglob then
+ (if !debug then ignore(E.log "ok_to_replace: target %s had its address taken or is a global\n" vi.vname);
+ true)
+ else (if !debug then ignore(E.log "ok_to_replace: target %s does not have its address taken\n" vi.vname);
+ false) in
+ let writes = if safe && not(target_addrof) then false else (time "writes_between" (writes_between f dsid) sid) in
+ 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)
+ 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
+ verify_unmodified uses fdefs curiosh defiosh
+
+let useList = ref []
+(* Visitor for making a list of statements that use a definition *)
+class useListerClass (defid:int) (vi:varinfo) = object(self)
+ inherit RD.rdVisitorClass
+
+ method vexpr e =
+ match e with
+ | Lval(Var vi', off) -> begin
+ match self#get_cur_iosh() with
+ Some iosh ->
+ let vido = RD.iosh_defId_find iosh defid in
+ let exists = match vido with Some _ -> true | None -> false in
+ if Util.equals vi vi' && exists
+ then (useList := sid::(!useList); DoChildren)
+ else DoChildren
+ | _ -> DoChildren (*E.s (E.error "useLister: no data for statement\n")*)
+ end
+ | _ -> DoChildren
+
+end
+
+(* ok_to_replace_with_incdec *)
+(* Find out if it is alright to replace the use of a variable
+ with a post-incrememnt/decrement of the variable it is assigned to be *)
+(* Takes the definitions reaching the variable use, the definitions
+ reaching the place where the variable was defined, the fundec,
+ the varinfo for the variable being considered and the right
+ hand side of its definition. *)
+let ok_to_replace_with_incdec curiosh defiosh f id vi r =
+
+ (* number of uses of vi where definition id reaches *)
+ let num_uses () =
+ let _ = useList := [] in
+ let ulc = new useListerClass id vi in
+ let _ = visitCilFunction (ulc :> cilVisitor) f in
+ List.length (!useList)
+ in
+
+ (* Is e the addition or subtraction of one to vi?
+ Return Some(PlusA) if it's an addition,
+ Some(MinusA) if it's a subtraction,
+ and None otherwise *)
+ let inc_or_dec e vi =
+ match e with
+ BinOp((PlusA|PlusPI|IndexPI), Lval(Var vi', NoOffset),
+ Const(CInt64(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)
+ else None
+ | BinOp((MinusA|MinusPI), Lval(Var vi', NoOffset),
+ Const(CInt64(one,_,_)),_) ->
+ if vi.vid = vi'.vid && one = Int64.one
+ then Some(MinusA)
+ else None
+ | _ -> None
+ in
+
+ match r with
+ RD.RDExp(Lval(Var rhsvi, NoOffset)) ->
+ let curido = RD.iosh_singleton_lookup curiosh rhsvi in
+ let defido = RD.iosh_singleton_lookup defiosh rhsvi in
+ (match curido, defido with
+ Some(curid), _ ->
+ let defios = try IH.find defiosh rhsvi.vid
+ with Not_found -> RD.IOS.empty in
+ let redefrhso = getDefRhs curid in
+ (match redefrhso with
+ None -> (if !debug then ignore (E.log "ok_to_replace: couldn't get rhs for redef: %d\n" curid);
+ None)
+ | Some(redefrhs, _, redefiosh) ->
+ let tmprdido = RD.iosh_singleton_lookup redefiosh vi in
+ match tmprdido with
+ None -> (if !debug then ignore (E.log "ok_to_replace: conflicting defs of %s reach redef of %s\n" vi.vname rhsvi.vname);
+ None)
+ | Some tmprdid ->
+ 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
+ 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\n" curid) in
+ if not (RD.IOS.compare defios redefios = 0) then
+ (if !debug then ignore (E.log "ok_to_replace: different sets of definitions of %s reach the def of %s and the redef of %s\n"
+ rhsvi.vname vi.vname rhsvi.vname);
+ None)
+ else
+ (match redefrhs with
+ RD.RDExp(e) -> (match inc_or_dec e rhsvi with
+ Some(PlusA) ->
+ if num_uses () = 1 then
+ Some(curdef_stmt.sid, curid, rhsvi, PlusA)
+ else (if !debug then ignore (E.log "ok_to_replace: tmp used more than once\n");
+ None)
+ | Some(MinusA) ->
+ 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)
+ | None ->
+ (if !debug then ignore (E.log "ok_to_replace: redef isn't adding or subtracting one from itself\n");
+ None)
+ | _ -> E.s (E.error "ok_to_replace: unexpected op in inc/dec info."))
+ | _ -> (if !debug then ignore (E.log "ok_to_replace: redef a call\n");
+ None)))
+ | _ -> (if !debug then ignore (E.log "ok_to_replace: %s has conflicting definitions\n" rhsvi.vname);
+ None))
+ | _ -> (if !debug then ignore (E.log "ok_to_replace: rhs not of correct form\n");
+ None)
+
+(* A hash from variable ids to Call instruction
+ options. If a variable id is in this table,
+ and it is mapped to Some(Call()), then the
+ function call can be printed instead of the
+ variable *)
+let iioh = IH.create 16
+
+(* A hash from variable ids to information that
+ can be used to print a post increment/decrement
+ that can replace the variable *)
+let incdecHash = IH.create 16
+
+(* A hash from variable ids to a list of statement ids.
+ Because a post-inc/dec will be printed elsewhere,
+ the assignments of the variable in these statements
+ don't need to be printed *)
+let idDefHash = IH.create 16
+
+(* Add a pair to the list for vid and create a list if one
+ doesn't exist *)
+let id_dh_add vid p =
+ if IH.mem idDefHash vid then
+ let oldlist = IH.find idDefHash vid in
+ let newlist = p::oldlist in
+ IH.replace idDefHash vid newlist
+ else
+ IH.add idDefHash vid [p]
+
+(* check if a name matches a form *)
+(* string -> nameform -> bool *)
+let check_form s f =
+ match f with
+ Suffix sfx ->
+ let frmlen = String.length sfx in
+ let slen = String.length s in
+ slen >= frmlen &&
+ compare (String.sub s (slen - frmlen) frmlen) sfx = 0
+ | Prefix pfx ->
+ let frmlen = String.length pfx in
+ String.length s >= frmlen &&
+ compare (String.sub s 0 frmlen) pfx = 0
+ | Exact ext ->
+ let frmlen = String.length ext in
+ String.length s = frmlen &&
+ compare s ext = 0
+
+(* check a name against a list of forms
+ if it matches any then return true *)
+(* string -> nameform list -> bool *)
+let check_forms s fl =
+ List.fold_left (fun b f -> b || check_form s f)
+ false fl
+
+let forms = [Exact "tmp";
+ Prefix "tmp___";
+ Prefix "__cil_tmp";
+ Suffix "__e";
+ Suffix "__b";]
+
+(* action: 'a -> varinfo -> fundec -> bool -> exp option
+ * iosh: 'a
+ * fd: fundec
+ * nofrm: bool
+ *
+ * Replace Lval(Var vi, NoOffset) with
+ * e where action iosh sid vi fd nofrm returns Some(e) *)
+let varXformClass action data sid fd nofrm = object(self)
+ inherit nopCilVisitor
+
+ method vexpr e = match e with
+ Lval(Var vi, NoOffset) ->
+ (match action data sid vi fd nofrm with
+ None -> DoChildren
+ | Some e' ->
+ (* Cast e' to the correct type. *)
+ let e'' = mkCast ~e:e' ~newt:vi.vtype in
+ ChangeTo e'')
+ | Lval(Mem e', off) ->
+ (* don't substitute constants in memory lvals *)
+ let post e = match e with
+ Lval(Mem(Const _),off') -> Lval(Mem e', off')
+ | _ -> e
+ in
+ ChangeDoChildrenPost(Lval(Mem e', off), post)
+ | _ -> DoChildren
+
+end
+
+(* action: 'a -> lval -> fundec -> bool -> exp option
+ * lvh: 'a
+ * fd: fundec
+ * nofrm: bool
+ *
+ * Replace Lval(lv) with
+ * e where action lvh sid lv fd nofrm returns Some(e) *)
+let lvalXformClass action data sid fd nofrm = object(self)
+ inherit nopCilVisitor
+
+ method vexpr e =
+ let castrm e = e
+ (*stripCastsForPtrArith e*)
+ in
+ match e with
+ | Lval((Mem e', off) as lv)-> begin
+ match action data sid lv fd nofrm with
+ | None ->
+ (* don't substitute constants in memory lvals *)
+ let post e =
+ match e with
+ | Lval(Mem(Const _),off') -> Lval(Mem e', off')
+ | _ -> castrm e
+ in
+ ChangeDoChildrenPost(Lval(Mem e', off), post)
+ | Some e' ->
+ let e'' = mkCast ~e:e' ~newt:(typeOf(Lval lv)) in
+ ChangeDoChildrenPost(e'', castrm)
+ end
+ | Lval lv -> begin
+ match action data sid lv fd nofrm with
+ | None -> DoChildren
+ | Some e' -> begin
+ (* Cast e' to the correct type. *)
+ let e'' = mkCast ~e:e' ~newt:(typeOf(Lval lv)) in
+ ChangeDoChildrenPost(e'', castrm)
+ end
+ end
+ | e -> ChangeDoChildrenPost(castrm e, castrm)
+
+end
+
+(* Returns the set of definitions of vi in iosh that
+ are not due to assignments of the form x = x *)
+(* IOS.t IH.t -> varinfo -> int option *)
+let iosh_get_useful_def iosh vi =
+ if IH.mem iosh vi.vid then
+ let ios = IH.find iosh vi.vid in
+ let ios' = RD.IOS.filter (fun ido ->
+ match ido with None -> true | Some(id) ->
+ match time "getDefRhs" getDefRhs id with
+ Some(RD.RDExp(Lval(Var vi',NoOffset)),_,_)
+ | Some(RD.RDExp(CastE(_,Lval(Var vi',NoOffset))),_,_) ->
+ not(vi.vid = vi'.vid) (* false if they are the same *)
+ | _ -> true) ios
+ in
+ if not(RD.IOS.cardinal ios' = 1)
+ then (if !debug then 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)
+
+let ae_tmp_to_exp_change = ref false
+let ae_tmp_to_exp eh sid vi fd nofrm =
+ if nofrm || (check_forms vi.vname forms)
+ then try begin
+ let e = IH.find eh vi.vid in
+ if !debug then ignore(E.log "tmp_to_exp: changing %s to %a\n"
+ vi.vname d_plainexp e);
+ match e with
+ | Const(CStr _)
+ | Const(CWStr _) -> None (* don't fwd subst str lits *)
+ | _ -> begin
+ ae_tmp_to_exp_change := true;
+ Some e
+ end
+ end
+ with Not_found -> None
+ else None
+
+let ae_lval_to_exp_change = ref false
+let ae_lval_to_exp ?(propStrings:bool = false) lvh sid lv fd nofrm =
+ match lv, nofrm with
+ | (Var vi, NoOffset), false ->
+ (* If the var is not a temp, then don't replace *)
+ if check_forms vi.vname forms then begin
+ try
+ let e = AELV.LvExpHash.find lvh lv in
+ match e with
+ | Const(CStr _)
+ | Const(CWStr _) ->
+ if propStrings then (Some e) else None
+ | _ -> begin
+ ae_lval_to_exp_change := true;
+ if !debug then ignore(E.log "ae: replacing %a with %a\n"
+ d_lval lv d_exp e);
+ Some e
+ end
+ with Not_found -> None
+ end else None
+ | _, true -> begin
+ (* replace everything *)
+ try
+ let e = AELV.LvExpHash.find lvh lv in
+ match e with
+ | Const(CStr _)
+ | Const(CWStr _) ->
+ if propStrings then (Some e) else None
+ | _ -> begin
+ ae_lval_to_exp_change := true;
+ if !debug then ignore(E.log "ae: replacing %a with %a\n"
+ d_lval lv d_exp e);
+ Some e
+ end
+ with Not_found -> None
+ end
+ | _, _ -> None
+
+
+(* if the temp with varinfo vi can be
+ replaced by an expression then return
+ Some of that expression. o/w None.
+ If b is true, then don't check the form *)
+(* IOS.t IH.t -> sid -> varinfo -> fundec -> bool -> exp option *)
+let rd_tmp_to_exp_change = ref false
+let rd_tmp_to_exp iosh sid vi fd nofrm =
+ if nofrm || (check_forms vi.vname forms)
+ then let ido = iosh_get_useful_def iosh vi in
+ match ido with None ->
+ if !debug then 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 ->
+ 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
+ (if !debug then ignore(E.log "tmp_to_exp: changing %s to %a\n" vi.vname d_plainexp e);
+ match e with
+ | Const(CStr _)
+ | Const(CWStr _) -> None
+ | _ -> begin
+ rd_tmp_to_exp_change := true;
+ Some e
+ end)
+ 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
+ (if !debug then ignore(E.log "tmp_to_exp: %s didn't match form or nofrm\n" vi.vname);
+ None)
+
+let rd_fwd_subst data sid e fd nofrm =
+ rd_tmp_to_exp_change := false;
+ let e' = visitCilExpr (varXformClass rd_tmp_to_exp data sid fd nofrm) e in
+ (e', !rd_tmp_to_exp_change)
+
+let ae_fwd_subst data sid e fd nofrm =
+ ae_tmp_to_exp_change := false;
+ let e' = visitCilExpr (varXformClass ae_tmp_to_exp data sid fd nofrm) e in
+ (e', !ae_tmp_to_exp_change)
+
+let ae_lv_fwd_subst ?(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
+ in
+ (e', !ae_lval_to_exp_change)
+
+let ae_simp_fwd_subst data e nofrm =
+ ae_fwd_subst data (-1) e dummyFunDec nofrm
+
+let ae_lv_simp_fwd_subst data e nofrm =
+ ae_lv_fwd_subst data (-1) e dummyFunDec nofrm
+
+let ae_tmp_to_const_change = ref false
+let ae_tmp_to_const eh sid vi fd nofrm =
+ if nofrm || check_forms vi.vname forms then
+ try begin let e = IH.find eh vi.vid in
+ match e with Const c -> begin
+ ae_tmp_to_const_change := true;
+ Some(Const c) end
+ | _ -> None end
+ with Not_found -> None
+ else None
+
+(* See if vi can be replaced by a constant
+ by checking all of the definitions reaching
+ this use of vi *)
+let tmp_to_const_change = ref false
+let tmp_to_const iosh sid vi fd nofrm =
+ if nofrm || check_forms vi.vname forms then
+ match RD.iosh_lookup iosh vi with
+ None -> None
+ | Some(ios) ->
+ let defido =
+ try RD.IOS.choose ios
+ with Not_found -> None in
+ match defido with None -> None | Some defid ->
+ match time "getDefRhs" getDefRhs defid with
+ None -> None
+ | Some(RD.RDExp(Const c), _, defiosh) ->
+ (match RD.getDefIdStmt defid with
+ None -> E.s (E.error "tmp_to_const: defid has no statement\n")
+ | Some(stm) -> if ok_to_replace vi iosh sid defiosh stm.sid fd (RD.RDExp(Const c)) then
+ let same = RD.IOS.for_all (fun defido ->
+ match defido with None -> false | Some defid ->
+ match time "getDefRhs" getDefRhs defid with
+ None -> false
+ | Some(RD.RDExp(Const c'),_,defiosh) ->
+ if Util.equals c c' then
+ match RD.getDefIdStmt defid with
+ None -> E.s (E.error "tmp_to_const: defid has no statement\n")
+ | Some(stm) -> ok_to_replace vi iosh sid defiosh stm.sid fd (RD.RDExp(Const c'))
+ else false
+ | _ -> false) ios
+ in
+ if same
+ then (tmp_to_const_change := true; Some(Const c))
+ else None
+ else None)
+ | _ -> None
+ else None
+
+let const_prop iosh sid e fd nofrm =
+ tmp_to_const_change := false;
+ let e' = visitCilExpr (varXformClass tmp_to_const iosh sid fd nofrm) e in
+ (e', !tmp_to_const_change)
+
+let ae_const_prop eh sid e fd nofrm =
+ ae_tmp_to_const_change := false;
+ let e' = visitCilExpr (varXformClass ae_tmp_to_const eh sid fd nofrm) e in
+ (e', !ae_tmp_to_const_change)
+
+class expTempElimClass (fd:fundec) = object (self)
+ inherit RD.rdVisitorClass
+
+ method vexpr e =
+
+ let do_change iosh vi =
+ let ido = RD.iosh_singleton_lookup iosh vi in
+ (match ido with
+ Some id ->
+ let riviho = getDefRhs id in
+ (match riviho with
+ Some(RD.RDExp(e) as r, dsid, defiosh) ->
+ if !debug then 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
+ (if !debug then ignore(E.log "Yes.\n");
+ ChangeTo(e))
+ else (if !debug then ignore(E.log "No.\n");
+ DoChildren)
+ | _ -> DoChildren)
+ | _ -> DoChildren)
+ in
+
+ match e with
+ Lval (Var vi,NoOffset) ->
+ (if check_forms vi.vname forms then
+ (* only allowed to replace a tmp with a function call once *)
+ (match cur_rd_dat with
+ Some(_,s,iosh) -> do_change iosh vi
+ | None -> let iviho = RD.getRDs sid in
+ match iviho with
+ Some(_,s,iosh) ->
+ (if !debug then ignore (E.log "Try to change %s outside of instruction.\n" vi.vname);
+ do_change iosh vi)
+ | None ->
+ (if !debug then ignore (E.log "%s in statement w/o RD info\n" vi.vname);
+ DoChildren))
+ else DoChildren)
+ | _ -> DoChildren
+
+end
+
+class expLvTmpElimClass (fd : fundec) = object(self)
+ inherit AELV.aeVisitorClass
+
+ method vexpr e =
+ match self#get_cur_eh () with
+ | None -> DoChildren
+ | Some eh -> begin
+ let e', _ = ae_lv_fwd_subst ~propStrings:true eh sid e fd false in
+ ChangeTo e'
+ end
+
+end
+
+class incdecTempElimClass (fd:fundec) = object (self)
+ inherit RD.rdVisitorClass
+
+ method vexpr e =
+
+ let do_change iosh vi =
+ let ido = RD.iosh_singleton_lookup iosh vi in
+ (match ido with
+ Some id ->
+ let riviho = getDefRhs id in
+ (match riviho with
+ Some(RD.RDExp(e) as r, _, defiosh) ->
+ (match ok_to_replace_with_incdec iosh defiosh fd id vi r with
+ Some(curdef_stmt_id,redefid, rhsvi, b) ->
+ (if !debug then ignore(E.log "No, but I can replace it with a post-inc/dec\n");
+ if !debug then ignore(E.log "cdsi: %d redefid: %d name: %s\n"
+ curdef_stmt_id redefid rhsvi.vname);
+ IH.add incdecHash vi.vid (redefid, rhsvi, b);
+ id_dh_add rhsvi.vid (curdef_stmt_id, redefid);
+ DoChildren)
+ | None ->
+ (if !debug then ignore(E.log "No.\n");
+ DoChildren))
+ | _ -> DoChildren)
+ | _ -> DoChildren)
+ in
+
+ match e with
+ Lval (Var vi,NoOffset) ->
+ (if check_forms vi.vname forms then
+ (* only allowed to replace a tmp with an inc/dec if there is only one use *)
+ (match cur_rd_dat with
+ Some(_,s,iosh) -> do_change iosh vi
+ | None -> let iviho = RD.getRDs sid in
+ match iviho with
+ Some(_,s,iosh) ->
+ (if !debug then ignore (E.log "Try to change %s outside of instruction.\n" vi.vname);
+ do_change iosh vi)
+ | None ->
+ (if !debug then ignore (E.log "%s in statement w/o RD info\n" vi.vname);
+ DoChildren))
+ else DoChildren)
+ | _ -> DoChildren
+
+end
+
+class callTempElimClass (fd:fundec) = object (self)
+ inherit RD.rdVisitorClass
+
+ method vexpr e =
+
+ let do_change iosh vi =
+ let ido = RD.iosh_singleton_lookup iosh vi in
+ (match ido with
+ Some id ->
+ let riviho = getDefRhs id in
+ (match riviho with
+ Some(RD.RDCall(i) as r, dsid, defiosh) ->
+ if !debug then ignore(E.log "Can I replace %s with %a?\n" vi.vname d_instr i);
+ if ok_to_replace vi iosh sid defiosh dsid fd r
+ then (if !debug then ignore(E.log "Yes.\n");
+ IH.add iioh vi.vid (Some(i));
+ DoChildren)
+ else (if !debug then ignore(E.log "No.\n");
+ DoChildren)
+ | _ -> DoChildren)
+ | _ -> DoChildren)
+ in
+
+ match e with
+ Lval (Var vi,NoOffset) ->
+ (if check_forms vi.vname forms then
+ (* only allowed to replace a tmp with a function call if there is only one use *)
+ if IH.mem iioh vi.vid
+ then (IH.replace iioh vi.vid None; DoChildren)
+ else
+ (match cur_rd_dat with
+ Some(_,s,iosh) -> do_change iosh vi
+ | None -> let iviho = RD.getRDs sid in
+ match iviho with
+ 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 ->
+ (if !debug then ignore (E.log "%s in statement w/o RD info\n" vi.vname);
+ DoChildren))
+ else DoChildren)
+ | _ -> DoChildren
+
+ (* Unused definitions cause multiple replacements
+ unless they are found and the replacement prevented.
+ It will be possible to replace more temps if dead
+ code elimination is performed before printing. *)
+ method vinst i =
+ (* Need to copy this from rdVisitorClass because we are overriding *)
+ if !debug then 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" ->
+ if !debug then ignore(E.log "rdVis: il rd_dat_lst mismatch\n"));
+ match i with
+ Set((Var vi,off),_,_) ->
+ if IH.mem iioh vi.vid
+ then (IH.replace iioh vi.vid None; DoChildren)
+ else (IH.add iioh vi.vid None; DoChildren)
+ | _ -> DoChildren
+
+end
+
+
+
+(* Remove local declarations that aren't set or used *)
+(* fundec -> unit *)
+let rm_unused_locals fd =
+ let oldIgnoreSizeof = !UD.ignoreSizeof in
+ UD.ignoreSizeof := false;
+ let used = List.fold_left (fun u s ->
+ let u', d' = UD.computeDeepUseDefStmtKind s.skind in
+ UD.VS.union u (UD.VS.union u' d')) UD.VS.empty fd.sbody.bstmts in
+ UD.ignoreSizeof := oldIgnoreSizeof;
+
+ let good_var vi = UD.VS.mem vi used in
+ let good_locals = List.filter good_var fd.slocals in
+ fd.slocals <- good_locals
+
+
+(* see if a vi is volatile *)
+let is_volatile vi =
+ let vi_vol =
+ List.exists (function (Attr("volatile",_)) -> true
+ | _ -> false) vi.vattr in
+ let typ_vol =
+ List.exists (function (Attr("volatile",_)) -> true
+ | _ -> false) (typeAttrs vi.vtype) in
+ if !debug && (vi_vol || typ_vol) then
+ ignore(E.log "unusedRemover: %s is volatile\n" vi.vname);
+ if !debug && not(vi_vol || typ_vol) then
+ ignore(E.log "unusedRemover: %s is not volatile\n" vi.vname);
+ vi_vol || typ_vol
+
+
+(* Remove temp variables that are set but not used *)
+(* This is different from dead code elimination because
+ temps that can be eliminated during pretty printing
+ are also considered *)
+class unusedRemoverClass : cilVisitor = object(self)
+ inherit nopCilVisitor
+
+ val mutable unused_set = UD.VS.empty
+ val mutable cur_func = dummyFunDec
+
+ (* figure out which locals aren't used *)
+ method vfunc f =
+ cur_func <- f;
+ (* the set of used variables *)
+ let used = List.fold_left (fun u s ->
+ let u', _ = UD.computeDeepUseDefStmtKind s.skind in
+ UD.VS.union u u') UD.VS.empty f.sbody.bstmts in
+ let used = UD.computeUseLocalTypes ~acc_used:used f in
+
+ (* the set of unused locals *)
+ let unused = List.fold_left (fun un vi ->
+ if UD.VS.mem vi used
+ then un
+ else (if !debug then 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 =
+ (is_volatile vi) || (* have to keep if it's volatile *)
+ (not(UD.VS.mem vi unused) && (* have to keep if it's used and if *)
+ (not(IH.mem iioh vi.vid) || (* it's not getting eliminated during pp *)
+ (match IH.find iioh vi.vid with (* getting eliminated *)
+ None -> true | Some _ -> false)) &&
+ not(IH.mem incdecHash vi.vid))
+ in
+ let good_locals = List.filter good_var f.slocals in
+ f.slocals <- good_locals;
+ unused_set <- unused;
+ DoChildren
+
+ (* remove instructions that set variables
+ that aren't used. Also remove instructions
+ that set variables mentioned in iioh *)
+ method vstmt stm =
+
+ (* return the list of pairs with fst = f *)
+ let findf_in_pl f pl =
+ List.filter (fun (fst,snd) ->
+ if fst = f then true else false)
+ pl
+ in
+
+ (* Return true if the assignment of this
+ variable in this statement is going to be
+ replaced by a post-inc/dec *)
+ let check_incdec vi e =
+ if IH.mem idDefHash vi.vid then
+ let pl = IH.find idDefHash vi.vid in
+ match findf_in_pl stm.sid pl with (sid,redefid)::l ->
+ let rhso = getDefRhs redefid in
+ (match rhso with
+ None -> (if !debug then ignore (E.log "check_incdec: couldn't find rhs for def %d\n" redefid);
+ false)
+ | Some(rhs, _, indiosh) ->
+ (match rhs with
+ RD.RDCall _ -> (if !debug then ignore (E.log "check_incdec: rhs not an expression\n");
+ false)
+ | 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);
+ false)))
+ | [] -> (if !debug then ignore (E.log "check_incdec: current statement not in list: %d. %s = %a\n"
+ stm.sid vi.vname d_exp e);
+ false)
+ else (if !debug then ignore (E.log "check_incdec: %s not in idDefHash\n" vi.vname);
+ false)
+ in
+
+ (* return true if the rhs will get
+ pretty printed as a function call *)
+ let will_be_call e =
+ match e with
+ Lval(Var vi,NoOffset) ->
+ if not(IH.mem iioh vi.vid) then false
+ else (match IH.find iioh vi.vid with
+ None -> false | Some _ -> true)
+ | _ -> false
+ in
+
+ (* a filter function for picking out
+ the instructions that we want to keep *)
+ (* instr -> bool *)
+ let good_instr i =
+ match i with
+ | Set((Var(vi),_),e,_) -> begin
+ if will_be_call e &&
+ not(List.mem vi cur_func.slocals) &&
+ not vi.vglob
+ then cur_func.slocals <- vi::cur_func.slocals;
+ is_volatile vi ||
+ (not (UD.VS.mem vi unused_set) &&
+ not (IH.mem incdecHash vi.vid) &&
+ not (check_incdec vi e)) ||
+ will_be_call e
+ end
+ | Call (Some(Var(vi),_),_,_,_) -> begin
+ (* If not in the table or entry is None,
+ then it's good *)
+ not (IH.mem iioh vi.vid) ||
+ (match IH.find iioh vi.vid with
+ None -> true | Some _ -> false)
+ end
+ | Asm(_,_,slvlst,_,_,_) -> begin
+ (* make sure the outputs are in the locals list *)
+ List.iter (fun (_,s,lv) ->
+ match lv with (Var vi,_) ->
+ if List.mem vi cur_func.slocals
+ then ()
+ else cur_func.slocals <- vi::cur_func.slocals
+ |_ -> ()) slvlst;
+ true
+ end
+ | _ -> true
+ in
+
+ (* If the result of a function call isn't used,
+ then change to Call(None,...) *)
+ let call_fixer i =
+ match i with
+ Call (Some(Var(vi),_),e,el,l) as c ->
+ if UD.VS.mem vi unused_set then
+ Call(None,e,el,l)
+ else c
+ | _ -> i
+ in
+
+ match stm.skind with
+ Instr il ->
+ let newil = List.filter good_instr il in
+ let newil' = List.map call_fixer newil in
+ stm.skind <- Instr(newil');
+ SkipChildren
+ | _ -> DoChildren
+
+end
+
+(* from cleaner.ml *)
+
+(* Lifts child blocks into parents if the block has no attributes or labels *)
+let rec fold_blocks b =
+ b.bstmts <- List.fold_right
+ (fun s acc ->
+ match s.skind with
+ Block ib ->
+ fold_blocks ib;
+ if (List.length ib.battrs = 0 &&
+ List.length s.labels = 0) then
+ ib.bstmts @ acc
+ else
+ s::acc
+ | Instr il when il = [] && s.labels = [] ->
+ acc
+ | _ -> s::acc)
+ b.bstmts
+ []
+
+class removeBrackets = object (self)
+ inherit nopCilVisitor
+ method vblock b =
+ fold_blocks b;
+ DoChildren
+end
+
+(* clean up the code and
+ eliminate some temporaries
+ for pretty printing a whole function *)
+(* Cil.fundec -> Cil.fundec *)
+let eliminate_temps f =
+ ignore(visitCilFunction (new removeBrackets) f);
+ Cfg.clearCFGinfo f;
+ ignore(Cfg.cfgFun f);
+ UD.ignoreSizeof := false;
+ RD.computeRDs f;
+ IH.clear iioh;
+ IH.clear incdecHash;
+ IH.clear idDefHash;
+ let etec = new expLvTmpElimClass f in
+ let f' = visitCilFunction (etec :> cilVisitor) f in
+ RD.clearMemos (); (* we changed instructions and invalidated the "cache" *)
+ let idtec = new incdecTempElimClass f' in
+ let f' = visitCilFunction (idtec :> cilVisitor) f' in
+ let ctec = new callTempElimClass f' in
+ let f' = visitCilFunction (ctec :> cilVisitor) f' in
+ let f' = visitCilFunction (new unusedRemoverClass) f' in
+ f'
+
+(* same as above, but doesn't remove the
+ obviated instructions and declarations.
+ Use this before using zrapp to print
+ expressions without temps *)
+let eliminateTempsForExpPrinting f =
+ Cfg.clearCFGinfo f;
+ ignore(Cfg.cfgFun f);
+ UD.ignoreSizeof := false;
+ RD.computeRDs f;
+ IH.clear iioh;
+ IH.clear incdecHash;
+ IH.clear idDefHash;
+ let etec = new expLvTmpElimClass f in
+ let f' = visitCilFunction (etec :> cilVisitor) f in
+ RD.clearMemos (); (* we changed instructions and invalidated the "cache" *)
+ let idtec = new incdecTempElimClass f' in
+ let f' = visitCilFunction (idtec :> cilVisitor) f' in
+ let ctec = new callTempElimClass f' in
+ let f' = visitCilFunction (ctec :> cilVisitor) f' in
+ f'
--- /dev/null
+(*
+ *
+ * Copyright (c) 2005,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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
+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 : featureDescr =
+ { fd_name = "sfi";
+ fd_enabled = doSfi;
+ 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;
+ }
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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
+
+(* 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 : featureDescr =
+ { fd_name = "simpleMem";
+ fd_enabled = Cilutil.doSimpleMem;
+ fd_description = "simplify all memory expressions" ;
+ fd_extraopt = [];
+ fd_doit = (function (f: file) -> ignore (simplemem f)) ;
+ fd_post_check = true;
+ }
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * Sumit Gulwani <gulwani@cs.berkeley.edu>
+ * 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
+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
+
+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
+ | Lval lv -> Lval (simplifyLval setTemp lv)
+ | BinOp(bo, e1, e2, tres) ->
+ BinOp(bo, makeBasic setTemp e1, makeBasic setTemp e2, tres)
+ | 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)
+ | _ -> (* 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 ->
+ 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
+
+ | Var v, off when v.vaddrof -> (* We are taking this variable's address *)
+ 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' = 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 *)
+ 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;
+ 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\n"
+ 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
+ (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
+ (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;
+ (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.\n"
+ 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 : featureDescr =
+ { fd_name = "simplify";
+ fd_enabled = ref false;
+ fd_description = "compiles CIL to 3-address code";
+ fd_extraopt = [
+ ("--no-split-structs", Arg.Clear splitStructs,
+ " do not split structured variables");
+ ];
+ fd_doit = (function f -> iterGlobals f doGlobal);
+ fd_post_check = true;
+}
+
--- /dev/null
+module B=Bitmap
+module E = Errormsg
+
+open Cil
+open Pretty
+
+let debug = false
+
+(* Globalsread, Globalswritten should be closed under call graph *)
+
+module StringOrder =
+ struct
+ type t = string
+ let compare s1 s2 =
+ if s1 = s2 then 0 else
+ if s1 < s2 then -1 else 1
+ end
+
+module StringSet = Set.Make (StringOrder)
+
+module IntOrder =
+ struct
+ type t = int
+ let compare i1 i2 =
+ if i1 = i2 then 0 else
+ if i1 < i2 then -1 else 1
+ end
+
+module IntSet = Set.Make (IntOrder)
+
+
+type cfgInfo = {
+ name: string; (* The function name *)
+ start : int;
+ size : int;
+ blocks: cfgBlock array; (** Dominating blocks must come first *)
+ successors: int list array; (* block indices *)
+ predecessors: int list array;
+ mutable nrRegs: int;
+ mutable regToVarinfo: varinfo array; (** Map register IDs to varinfo *)
+ }
+
+(** A block corresponds to a statement *)
+and cfgBlock = {
+ bstmt: Cil.stmt;
+
+ (* We abstract the statement as a list of def/use instructions *)
+ instrlist: instruction list;
+ mutable livevars: (reg * int) list;
+ (** For each variable ID that is live at the start of the block, the
+ * block whose definition reaches this point. If that block is the same
+ * as the current one, then the variable is a phi variable *)
+ mutable reachable: bool;
+ }
+
+and instruction = (reg list * reg list)
+ (* lhs variables, variables on rhs. *)
+
+
+and reg = int
+
+type idomInfo = int array (* immediate dominator *)
+
+and dfInfo = (int list) array (* dominance frontier *)
+
+and oneSccInfo = {
+ nodes: int list;
+ headers: int list;
+ backEdges: (int*int) list;
+ }
+
+and sccInfo = oneSccInfo list
+
+(* Muchnick's Domin_Fast, 7.16 *)
+
+let compute_idom (flowgraph: cfgInfo): idomInfo =
+ let start = flowgraph.start in
+ let size = flowgraph.size in
+ let successors = flowgraph.successors in
+ let predecessors = flowgraph.predecessors in
+ let n0 = size in (* a new node (not in the flowgraph) *)
+ let idom = Array.make size (-1) in (* Make an array of immediate dominators *)
+ let nnodes = size + 1 in
+ let nodeSet = B.init nnodes (fun i -> true) in
+
+ let ndfs = Array.create nnodes 0 in (* mapping from depth-first
+ * number to nodes. DForder
+ * starts at 1, with 0 used as
+ * an invalid entry *)
+ let parent = Array.create nnodes 0 in (* the parent in depth-first
+ * spanning tree *)
+
+ (* A semidominator of w is the node v with the minimal DForder such
+ * that there is a path from v to w containing only nodes with the
+ * DForder larger than w. *)
+ let sdno = Array.create nnodes 0 in (* depth-first number of
+ * semidominator *)
+
+ (* The set of nodes whose
+ * semidominator is ndfs(i) *)
+ let bucket = Array.init nnodes (fun _ -> B.cloneEmpty nodeSet) in
+
+ (* The functions link and eval maintain a forest within the
+ * depth-first spanning tree. Ancestor is n0 is the node is a root in
+ * the forest. Label(v) is the node in the ancestor chain with the
+ * smallest depth-first number of its semidominator. Child and Size
+ * are used to keep the trees in the forest balanced *)
+ let ancestor = Array.create nnodes 0 in
+ let label = Array.create nnodes 0 in
+ let child = Array.create nnodes 0 in
+ let size = Array.create nnodes 0 in
+
+
+ let n = ref 0 in (* depth-first scan and numbering.
+ * Initialize data structures. *)
+ ancestor.(n0) <- n0;
+ label.(n0) <- n0;
+ let rec depthFirstSearchDom v =
+ incr n;
+ sdno.(v) <- !n;
+ ndfs.(!n) <- v; label.(v) <- v;
+ ancestor.(v) <- n0; (* All nodes are roots initially *)
+ child.(v) <- n0; size.(v) <- 1;
+ List.iter
+ (fun w ->
+ if sdno.(w) = 0 then begin
+ parent.(w) <- v; depthFirstSearchDom w
+ end)
+ successors.(v);
+ in
+ (* Determine the ancestor of v whose semidominator has the the minimal
+ * DFnumber. In the process, compress the paths in the forest. *)
+ let eval v =
+ let rec compress v =
+ if ancestor.(ancestor.(v)) <> n0 then
+ begin
+ compress ancestor.(v);
+ if sdno.(label.(ancestor.(v))) < sdno.(label.(v)) then
+ label.(v) <- label.(ancestor.(v));
+ ancestor.(v) <- ancestor.(ancestor.(v))
+ end
+ in
+ if ancestor.(v) = n0 then label.(v)
+ else begin
+ compress v;
+ if sdno.(label.(ancestor.(v))) >= sdno.(label.(v)) then
+ label.(v)
+ else label.(ancestor.(v))
+ end
+ in
+
+ let link v w =
+ let s = ref w in
+ while sdno.(label.(w)) < sdno.(label.(child.(!s))) do
+ if size.(!s) + size.(child.(child.(!s))) >= 2* size.(child.(!s)) then
+ (ancestor.(child.(!s)) <- !s;
+ child.(!s) <- child.(child.(!s)))
+ else
+ (size.(child.(!s)) <- size.(!s);
+ ancestor.(!s) <- child.(!s); s := child.(!s));
+ done;
+ label.(!s) <- label.(w);
+ size.(v) <- size.(v) + size.(w);
+ if size.(v) < 2 * size.(w) then begin
+ let tmp = !s in
+ s := child.(v);
+ child.(v) <- tmp;
+ end;
+ while !s <> n0 do
+ ancestor.(!s) <- v;
+ s := child.(!s);
+ done;
+ in
+ (* Start now *)
+ depthFirstSearchDom start;
+ for i = !n downto 2 do
+ let w = ndfs.(i) in
+ List.iter (fun v ->
+ let u = eval v in
+ if sdno.(u) < sdno.(w) then sdno.(w) <- sdno.(u);)
+ predecessors.(w);
+ B.setTo bucket.(ndfs.(sdno.(w))) w true;
+ link parent.(w) w;
+ while not (B.empty bucket.(parent.(w))) do
+ let v =
+ match B.toList bucket.(parent.(w)) with
+ x :: _ -> x
+ | [] -> ignore(print_string "Error in dominfast");0 in
+ B.setTo bucket.(parent.(w)) v false;
+ let u = eval v in
+ idom.(v) <- if sdno.(u) < sdno.(v) then u else parent.(w);
+ done;
+ done;
+
+ for i=2 to !n do
+ let w = ndfs.(i) in
+ if idom.(w) <> ndfs.(sdno.(w)) then begin
+ let newDom = idom.(idom.(w)) in
+ idom.(w) <- newDom;
+ end
+ done;
+ idom
+
+
+
+
+
+let dominance_frontier (flowgraph: cfgInfo) : dfInfo =
+ let idom = compute_idom flowgraph in
+ let size = flowgraph.size in
+ let children = Array.create size [] in
+ for i = 0 to size - 1 do
+ if (idom.(i) != -1) then children.(idom.(i)) <- i :: children.(idom.(i));
+ done;
+
+ let size = flowgraph.size in
+ let start = flowgraph.start in
+ let successors = flowgraph.successors in
+
+ let df = Array.create size [] in
+ (* Compute the dominance frontier *)
+
+ let bottom = Array.make size true in (* bottom of the dominator tree *)
+ for i = 0 to size - 1 do
+ if (i != start) && idom.(i) <> -1 then bottom.(idom.(i)) <- false;
+ done;
+
+ let processed = Array.make size false in (* to record the nodes added to work_list *)
+ let workList = ref ([]) in (* to iterate in a bottom-up traversal of the dominator tree *)
+ for i = 0 to size - 1 do
+ if (bottom.(i)) then workList := i :: !workList;
+ done;
+ while (!workList != []) do
+ let x = List.hd !workList in
+ let update y = if idom.(y) <> x then df.(x) <- y::df.(x) in
+ (* compute local component *)
+
+(* We use whichPred instead of whichSucc because ultimately this info is
+ * needed by control dependence dag which is constructed from REVERSE
+ * dominance frontier *)
+ List.iter (fun succ -> update succ) successors.(x);
+ (* add on up component *)
+ List.iter (fun z -> List.iter (fun y -> update y) df.(z)) children.(x);
+ processed.(x) <- true;
+ workList := List.tl !workList;
+ if (x != start) then begin
+ let i = idom.(x) in
+ if i <> -1 &&
+ (List.for_all (fun child -> processed.(child)) children.(i)) then workList := i :: !workList;
+ end;
+ done;
+ df
+
+
+(* Computes for each register, the set of nodes that need a phi definition
+ * for the register *)
+
+let add_phi_functions_info (flowgraph: cfgInfo) : unit =
+ let df = dominance_frontier flowgraph in
+ let size = flowgraph.size in
+ let nrRegs = flowgraph.nrRegs in
+
+
+ let defs = Array.init size (fun i -> B.init nrRegs (fun j -> false)) in
+ for i = 0 to size-1 do
+ List.iter
+ (fun (lhs,rhs) ->
+ List.iter (fun (r: reg) -> B.setTo defs.(i) r true) lhs;
+ )
+ flowgraph.blocks.(i).instrlist
+ done;
+ let iterCount = ref 0 in
+ let hasAlready = Array.create size 0 in
+ let work = Array.create size 0 in
+ let w = ref ([]) in
+ let dfPlus = Array.init nrRegs (
+ fun i ->
+ let defIn = B.make size in
+ for j = 0 to size - 1 do
+ if B.test defs.(j) i then B.setTo defIn j true
+ done;
+ let res = ref [] in
+ incr iterCount;
+ B.iter (fun x -> work.(x) <- !iterCount; w := x :: !w;) defIn;
+ while (!w != []) do
+ let x = List.hd !w in
+ w := List.tl !w;
+ List.iter (fun y ->
+ if (hasAlready.(y) < !iterCount) then begin
+ res := y :: !res;
+ hasAlready.(y) <- !iterCount;
+ if (work.(y) < !iterCount) then begin
+ work.(y) <- !iterCount;
+ w := y :: !w;
+ end;
+ end;
+ ) df.(x)
+ done;
+ (* res := List.filter (fun blkId -> B.test liveIn.(blkId) i) !res; *)
+ !res
+ ) in
+ let result = Array.create size ([]) in
+ for i = 0 to nrRegs - 1 do
+ List.iter (fun node -> result.(node) <- i::result.(node);) dfPlus.(i)
+ done;
+(* result contains for each node, the list of variables that need phi
+ * definition *)
+ for i = 0 to size-1 do
+ flowgraph.blocks.(i).livevars <-
+ List.map (fun r -> (r, i)) result.(i);
+ done
+
+
+
+(* add dominating definitions info *)
+
+let add_dom_def_info (f: cfgInfo): unit =
+ let blocks = f.blocks in
+ let start = f.start in
+ let size = f.size in
+ let nrRegs = f.nrRegs in
+
+ let idom = compute_idom f in
+ let children = Array.create size [] in
+ for i = 0 to size - 1 do
+ if (idom.(i) != -1) then children.(idom.(i)) <- i :: children.(idom.(i));
+ done;
+
+ if debug then begin
+ ignore (E.log "Immediate dominators\n");
+ for i = 0 to size - 1 do
+ ignore (E.log " block %d: idom=%d, children=%a\n"
+ i idom.(i)
+ (docList num) children.(i));
+ done
+ end;
+
+ (* For each variable, maintain a stack of blocks that define it. When you
+ * process a block, the top of the stack is the closest dominator that
+ * defines the variable *)
+ let s = Array.make nrRegs ([start]) in
+
+ (* Search top-down in the idom tree *)
+ let rec search (x: int): unit = (* x is a graph node *)
+ (* Push the current block for the phi variables *)
+ List.iter
+ (fun ((r: reg), dr) ->
+ if x = dr then s.(r) <- x::s.(r))
+ blocks.(x).livevars;
+
+ (* Clear livevars *)
+ blocks.(x).livevars <- [];
+
+ (* Compute livevars *)
+ for i = 0 to nrRegs-1 do
+ match s.(i) with
+ | [] -> assert false
+ | fst :: _ ->
+ blocks.(x).livevars <- (i, fst) :: blocks.(x).livevars
+ done;
+
+
+ (* Update s for the children *)
+ List.iter
+ (fun (lhs,rhs) ->
+ List.iter (fun (lreg: reg) -> s.(lreg) <- x::s.(lreg) ) lhs;
+ )
+ blocks.(x).instrlist;
+
+
+ (* Go and do the children *)
+ List.iter search children.(x);
+
+ (* Then we pop x, whenever it is on top of a stack *)
+ Array.iteri
+ (fun i istack ->
+ let rec dropX = function
+ [] -> []
+ | x' :: rest when x = x' -> dropX rest
+ | l -> l
+ in
+ s.(i) <- dropX istack)
+ s;
+ in
+ search(start)
+
+
+
+let prune_cfg (f: cfgInfo): cfgInfo =
+ let size = f.size in
+ if size = 0 then f else
+ let reachable = Array.make size false in
+ let worklist = ref([f.start]) in
+ while (!worklist != []) do
+ let h = List.hd !worklist in
+ worklist := List.tl !worklist;
+ reachable.(h) <- true;
+ List.iter (fun s -> if (reachable.(s) = false) then worklist := s::!worklist;
+ ) f.successors.(h);
+ done;
+(*
+ let dummyblock = { bstmt = mkEmptyStmt ();
+ instrlist = [];
+ livevars = [] }
+ in
+*)
+ let successors = Array.init size (fun i -> List.filter (fun s -> reachable.(s)) f.successors.(i)) in
+ let predecessors = Array.init size (fun i -> List.filter (fun s -> reachable.(s)) f.predecessors.(i)) in
+ Array.iteri (fun i b -> b.reachable <- reachable.(i)) f.blocks;
+ let result: cfgInfo =
+ { name = f.name;
+ start = f.start;
+ size = f.size;
+ successors = successors;
+ predecessors = predecessors;
+ blocks = f.blocks;
+ nrRegs = f.nrRegs;
+ regToVarinfo = f.regToVarinfo;
+ }
+ in
+ result
+
+
+let add_ssa_info (f: cfgInfo): unit =
+ let f = prune_cfg f in
+ let d_reg () (r: int) =
+ dprintf "%s(%d)" f.regToVarinfo.(r).vname r
+ in
+ if debug then begin
+ ignore (E.log "Doing SSA for %s. Initial data:\n" f.name);
+ Array.iteri (fun i b ->
+ ignore (E.log " block %d:\n succs=@[%a@]\n preds=@[%a@]\n instr=@[%a@]\n"
+ i
+ (docList num) f.successors.(i)
+ (docList num) f.predecessors.(i)
+ (docList ~sep:line (fun (lhs, rhs) ->
+ dprintf "%a := @[%a@]"
+ (docList (d_reg ())) lhs (docList (d_reg ())) rhs))
+ b.instrlist))
+ f.blocks;
+ end;
+
+ add_phi_functions_info f;
+ add_dom_def_info f;
+
+ if debug then begin
+ ignore (E.log "After SSA\n");
+ Array.iter (fun b ->
+ ignore (E.log " block %d livevars: @[%a@]\n"
+ b.bstmt.sid
+ (docList (fun (i, fst) ->
+ dprintf "%a def at %d" d_reg i fst))
+ b.livevars))
+ f.blocks;
+ end
+
+
+let set2list s =
+ let result = ref([]) in
+ IntSet.iter (fun element -> result := element::!result) s;
+ !result
+
+
+
+
+let preorderDAG (nrNodes: int) (successors: (int list) array): int list =
+ let processed = Array.make nrNodes false in
+ let revResult = ref ([]) in
+ let predecessorsSet = Array.make nrNodes (IntSet.empty) in
+ for i = 0 to nrNodes -1 do
+ List.iter (fun s -> predecessorsSet.(s) <- IntSet.add i predecessorsSet.(s)) successors.(i);
+ done;
+ let predecessors = Array.init nrNodes (fun i -> set2list predecessorsSet.(i)) in
+ let workList = ref([]) in
+ for i = 0 to nrNodes - 1 do
+ if (predecessors.(i) = []) then workList := i::!workList;
+ done;
+ while (!workList != []) do
+ let x = List.hd !workList in
+ workList := List.tl !workList;
+ revResult := x::!revResult;
+ processed.(x) <- true;
+ List.iter (fun s ->
+ if (List.for_all (fun p -> processed.(p)) predecessors.(s)) then
+ workList := s::!workList;
+ ) successors.(x);
+ done;
+ List.rev !revResult
+
+
+(* Muchnick Fig 7.12 *)
+(* takes an SCC description as an input and returns prepares the appropriate SCC *)
+let preorder (nrNodes: int) (successors: (int list) array) (r: int): oneSccInfo =
+ if debug then begin
+ ignore (E.log "Inside preorder \n");
+ for i = 0 to nrNodes - 1 do
+ ignore (E.log "succ(%d) = %a" i (docList (fun i -> num i)) successors.(i));
+ done;
+ end;
+ let i = ref(0) in
+ let j = ref(0) in
+ let pre = Array.make nrNodes (-1) in
+ let post = Array.make nrNodes (-1) in
+ let visit = Array.make nrNodes (false) in
+ let backEdges = ref ([]) in
+ let headers = ref(IntSet.empty) in
+ let rec depth_first_search_pp (x:int) =
+ visit.(x) <- true;
+ pre.(x) <- !j;
+ incr j;
+ List.iter (fun (y:int) ->
+ if (not visit.(y)) then
+ (depth_first_search_pp y)
+ else
+ if (post.(y) = -1) then begin
+ backEdges := (x,y)::!backEdges;
+ headers := IntSet.add y !headers;
+ end;
+ ) successors.(x);
+ post.(x) <- !i;
+ incr i;
+ in
+ depth_first_search_pp r;
+ let nodes = Array.make nrNodes (-1) in
+ for y = 0 to nrNodes - 1 do
+ if (pre.(y) != -1) then nodes.(pre.(y)) <- y;
+ done;
+ let nodeList = List.filter (fun i -> (i != -1)) (Array.to_list nodes) in
+ let result = { headers = set2list !headers; backEdges = !backEdges; nodes = nodeList; } in
+ result
+
+
+exception Finished
+
+
+let strong_components (f: cfgInfo) (debug: bool) =
+ let size = f.size in
+ let parent = Array.make size (-1) in
+ let color = Array.make size (-1) in
+ let finish = Array.make size (-1) in
+ let root = Array.make size (-1) in
+
+(* returns a list of SCC. Each SCC is a tuple of SCC root and SCC nodes *)
+ let dfs (successors: (int list) array) (order: int array) =
+ let time = ref(-1) in
+ let rec dfs_visit u =
+ color.(u) <- 1;
+ incr time;
+ (* d.(u) <- time; *)
+ List.iter (fun v ->
+ if color.(v) = 0 then (parent.(v) <- u; dfs_visit v)
+ ) successors.(u);
+ color.(u) <- 2;
+ incr time;
+ finish.(u) <- !time
+ in
+ for u = 0 to size - 1 do
+ color.(u) <- 0; (* white = 0, gray = 1, black = 2 *)
+ parent.(u) <- -1; (* nil = -1 *)
+ root.(u) <- 0; (* Is u a root? *)
+ done;
+ time := 0;
+ Array.iter (fun u ->
+ if (color.(u) = 0) then begin
+ root.(u) <- 1;
+ dfs_visit u;
+ end;
+ ) order;
+ in
+
+ let simpleOrder = Array.init size (fun i -> i) in
+ dfs f.successors simpleOrder;
+ Array.sort (fun i j -> if (finish.(i) > finish.(j)) then -1 else 1) simpleOrder;
+
+ dfs f.predecessors simpleOrder;
+(* SCCs have been computed. (The trees represented by non-null parent edges
+ * represent the SCCS. We call the black nodes as the roots). Now put the
+ * result in the ouput format *)
+ let allScc = ref([]) in
+ for u = 0 to size - 1 do
+ if root.(u) = 1 then begin
+ let sccNodes = ref(IntSet.empty) in
+ let workList = ref([u]) in
+ while (!workList != []) do
+ let h=List.hd !workList in
+ workList := List.tl !workList;
+ sccNodes := IntSet.add h !sccNodes;
+ List.iter (fun s -> if parent.(s)=h then workList := s::!workList;) f.predecessors.(h);
+ done;
+ allScc := (u,!sccNodes)::!allScc;
+ if (debug) then begin
+ ignore (E.log "Got an SCC with root %d and nodes %a" u (docList num) (set2list !sccNodes));
+ end;
+ end;
+ done;
+ !allScc
+
+
+let stronglyConnectedComponents (f: cfgInfo) (debug: bool): sccInfo =
+ let size = f.size in
+ if (debug) then begin
+ ignore (E.log "size = %d\n" size);
+ for i = 0 to size - 1 do
+ ignore (E.log "Successors(%d): %a\n" i (docList (fun n -> num n)) f.successors.(i));
+ done;
+ end;
+
+ let allScc = strong_components f debug in
+ let all_sccArray = Array.of_list allScc in
+
+ if (debug) then begin
+ ignore (E.log "Computed SCCs\n");
+ for i = 0 to (Array.length all_sccArray) - 1 do
+ ignore(E.log "SCC #%d: " i);
+ let (_,sccNodes) = all_sccArray.(i) in
+ IntSet.iter (fun i -> ignore(E.log "%d, " i)) sccNodes;
+ ignore(E.log "\n");
+ done;
+ end;
+
+
+ (* Construct sccId: Node -> Scc Id *)
+ let sccId = Array.make size (-1) in
+ Array.iteri (fun i (r,sccNodes) ->
+ IntSet.iter (fun n -> sccId.(n) <- i) sccNodes;
+ ) all_sccArray;
+
+ if (debug) then begin
+ ignore (E.log "\nComputed SCC IDs: ");
+ for i = 0 to size - 1 do
+ ignore (E.log "SCCID(%d) = %d " i sccId.(i));
+ done;
+ end;
+
+
+ (* Construct sccCFG *)
+ let nrScc = Array.length all_sccArray in
+ let successors = Array.make nrScc [] in
+ for x = 0 to nrScc - 1 do
+ successors.(x) <-
+ let s = ref(IntSet.empty) in
+ IntSet.iter (fun y ->
+ List.iter (fun z ->
+ let sy = sccId.(y) in
+ let sz = sccId.(z) in
+ if (not(sy = sz)) then begin
+ s := IntSet.add sz !s;
+ end
+ ) f.successors.(y)
+ ) (snd all_sccArray.(x));
+ set2list !s
+ done;
+
+ if (debug) then begin
+ ignore (E.log "\nComputed SCC CFG, which should be a DAG:");
+ ignore (E.log "nrSccs = %d " nrScc);
+ for i = 0 to nrScc - 1 do
+ ignore (E.log "successors(%d) = [%a] " i (docList (fun j -> num j)) successors.(i));
+ done;
+ end;
+
+
+ (* Order SCCs. The graph is a DAG here *)
+ let sccorder = preorderDAG nrScc successors in
+
+ if (debug) then begin
+ ignore (E.log "\nComputed SCC Preorder: ");
+ ignore (E.log "Nodes in Preorder = [%a]" (docList (fun i -> num i)) sccorder);
+ end;
+
+ (* Order nodes of each SCC. The graph is a SCC here.*)
+ let scclist = List.map (fun i ->
+ let successors = Array.create size [] in
+ for j = 0 to size - 1 do
+ successors.(j) <- List.filter (fun x -> IntSet.mem x (snd all_sccArray.(i))) f.successors.(j);
+ done;
+ preorder f.size successors (fst all_sccArray.(i))
+ ) sccorder in
+ if (debug) then begin
+ ignore (E.log "Computed Preorder for Nodes of each SCC\n");
+ List.iter (fun scc ->
+ ignore (E.log "BackEdges = %a \n"
+ (docList (fun (src,dest) -> dprintf "(%d,%d)" src dest))
+ scc.backEdges);)
+ scclist;
+ end;
+ scclist
+
+
+
+
+
+
+
+
+
--- /dev/null
+type cfgInfo = {
+ name: string; (* The function name *)
+ start : int;
+ size : int;
+ blocks: cfgBlock array; (** Dominating blocks must come first *)
+ successors: int list array; (* block indices *)
+ predecessors: int list array;
+ mutable nrRegs: int;
+ mutable regToVarinfo: Cil.varinfo array; (** Map register IDs to varinfo *)
+ }
+
+(** A block corresponds to a statement *)
+and cfgBlock = {
+ bstmt: Cil.stmt;
+
+ (* We abstract the statement as a list of def/use instructions *)
+ instrlist: instruction list;
+ mutable livevars: (reg * int) list;
+ (** For each variable ID that is live at the start of the block, the
+ * block whose definition reaches this point. If that block is the same
+ * as the current one, then the variable is a phi variable *)
+ mutable reachable: bool;
+ }
+
+and instruction = (reg list * reg list)
+ (* lhs variables, variables on rhs. *)
+
+
+and reg = int
+
+type idomInfo = int array (* immediate dominator *)
+
+and dfInfo = (int list) array (* dominance frontier *)
+
+and oneSccInfo = {
+ nodes: int list;
+ headers: int list;
+ backEdges: (int*int) list;
+ }
+
+and sccInfo = oneSccInfo list
+
+val add_ssa_info: cfgInfo -> unit
+val stronglyConnectedComponents: cfgInfo -> bool -> sccInfo
+val prune_cfg: cfgInfo -> cfgInfo
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+module H = Hashtbl
+open Cil
+open Pretty
+module E = Errormsg
+
+let debug = false
+
+
+(* For each function we have a node *)
+type node = { name: string;
+ mutable scanned: bool;
+ mutable mustcheck: bool;
+ mutable succs: node list }
+(* We map names to nodes *)
+let functionNodes: (string, node) H.t = H.create 113
+let getFunctionNode (n: string) : node =
+ Util.memoize
+ functionNodes
+ n
+ (fun _ -> { name = n; mustcheck = false; scanned = false; succs = [] })
+
+(** Dump the function call graph. Assume that there is a main *)
+let dumpGraph = true
+let dumpFunctionCallGraph () =
+ H.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 ^ " ");
+ if n.scanned then (* Already dumped *)
+ output_string !E.logChannel " <rec> "
+ else begin
+ n.scanned <- true;
+ List.iter (dumpOneNode (ind + 1)) n.succs
+ end
+ in
+ try
+ let main = H.find functionNodes "main" in
+ dumpOneNode 0 main
+ with Not_found -> begin
+ ignore (E.log
+ "I would like to dump the function graph but there is no main");
+ end
+
+(* 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@@"
+
+let checkSomeFunctions = ref false
+
+let init () =
+ H.clear functionNodes;
+ checkSomeFunctions := false
+
+
+let addCall (caller: string) (callee: string) =
+ let callerNode = getFunctionNode caller in
+ let calleeNode = getFunctionNode callee in
+ if not (List.exists (fun n -> n.name = callee) callerNode.succs) then begin
+ if debug then
+ ignore (E.log "found call from %s to %s\n" caller callee);
+ callerNode.succs <- calleeNode :: callerNode.succs;
+ end;
+ ()
+
+
+class findCallsVisitor (host: string) : cilVisitor = object
+ inherit nopCilVisitor
+
+ method vinst i =
+ match i with
+ | Call(_,Lval(Var(vi),NoOffset),_,l) ->
+ addCall host vi.vname;
+ SkipChildren
+
+ | Call(_,e,_,l) -> (* Calling a function pointer *)
+ addCall host functionPointerName;
+ SkipChildren
+
+ | _ -> SkipChildren (* No calls in other instructions *)
+
+ (* There are no calls in expressions and types *)
+ method vexpr e = SkipChildren
+ method vtype t = SkipChildren
+
+end
+
+(* Now detect the cycles in the call graph. Do a depth first search of the
+ * graph (stack is the list of nodes already visited in the current path).
+ * Return true if we have found a cycle. *)
+let rec breakCycles (stack: node list) (n: node) : bool =
+ if n.scanned then (* We have already scanned this node. There are no cycles
+ * going through this node *)
+ false
+ else if n.mustcheck then
+ (* We are reaching a node that we already know we much check. Return with
+ * no new cycles. *)
+ false
+ else if List.memq n stack then begin
+ (* We have found a cycle. Mark the node n to be checked and return *)
+ if debug then
+ ignore (E.log "Will place an overflow check in %s\n" n.name);
+ checkSomeFunctions := true;
+ n.mustcheck <- true;
+ n.scanned <- true;
+ true
+ end else begin
+ let res = List.exists (fun nd -> breakCycles (n :: stack) nd) n.succs in
+ n.scanned <- true;
+ if res && n.mustcheck then
+ false
+ else
+ res
+ end
+let findCheckPlacement () =
+ H.iter (fun _ nd ->
+ if nd.name <> functionPointerName
+ && not nd.scanned && not nd.mustcheck then begin
+ ignore (breakCycles [] nd)
+ end)
+ functionNodes
+
+let makeFunctionCallGraph (f: Cil.file) : unit =
+ init ();
+ (* Scan the file and construct the control-flow graph *)
+ List.iter
+ (function
+ GFun(fdec, _) ->
+ if fdec.svar.vaddrof then
+ addCall functionPointerName fdec.svar.vname;
+ let vis = new findCallsVisitor fdec.svar.vname in
+ ignore (visitCilBlock vis fdec.sbody)
+
+ | _ -> ())
+ f.globals
+
+let makeAndDumpFunctionCallGraph (f: file) =
+ makeFunctionCallGraph f;
+ dumpFunctionCallGraph ()
+
+
+let addCheck (f: Cil.file) : unit =
+ makeFunctionCallGraph f;
+ findCheckPlacement ();
+ if !checkSomeFunctions then begin
+ (* Add a declaration for the stack threshhold variable. The program is
+ * stopped when the stack top is less than this value. *)
+ let stackThreshholdVar = makeGlobalVar "___stack_threshhold" !upointType in
+ stackThreshholdVar.vstorage <- Extern;
+ (* And the initialization function *)
+ let computeStackThreshhold =
+ makeGlobalVar "___compute_stack_threshhold"
+ (TFun(!upointType, Some [], false, [])) in
+ computeStackThreshhold.vstorage <- Extern;
+ (* And the failure function *)
+ let stackOverflow =
+ makeGlobalVar "___stack_overflow"
+ (TFun(voidType, Some [], false, [])) in
+ stackOverflow.vstorage <- Extern;
+ f.globals <-
+ GVar(stackThreshholdVar, {init=None}, locUnknown) ::
+ GVarDecl(computeStackThreshhold, locUnknown) ::
+ GVarDecl(stackOverflow, locUnknown) :: f.globals;
+ (* Now scan and instrument each function definition *)
+ List.iter
+ (function
+ GFun(fdec, l) ->
+ (* If this is main we must introduce the initialization of the
+ * bottomOfStack *)
+ let nd = getFunctionNode fdec.svar.vname in
+ if fdec.svar.vname = "main" then begin
+ if nd.mustcheck then
+ E.s (E.error "The \"main\" function is recursive!!");
+ let loc = makeLocalVar fdec "__a_local" intType in
+ loc.vaddrof <- true;
+ fdec.sbody <-
+ mkBlock
+ [ mkStmtOneInstr
+ (Call (Some(var stackThreshholdVar),
+ Lval(var computeStackThreshhold), [], l));
+ mkStmt (Block fdec.sbody) ]
+ end else if nd.mustcheck then begin
+ let loc = makeLocalVar fdec "__a_local" intType in
+ loc.vaddrof <- true;
+ fdec.sbody <-
+ mkBlock
+ [ mkStmt
+ (If(BinOp(Le,
+ CastE(!upointType, AddrOf (var loc)),
+ Lval(var stackThreshholdVar), intType),
+ mkBlock [mkStmtOneInstr
+ (Call(None, Lval(var stackOverflow),
+ [], l))],
+ mkBlock [],
+ l));
+ mkStmt (Block fdec.sbody) ]
+ end else
+ ()
+
+ | _ -> ())
+ f.globals;
+ ()
+ end
+
+
+
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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 inserts code to check for stack overflow. It saves the address
+ * of the top of the stack in "main" and then it picks one function *)
+
+val addCheck: Cil.file -> unit
+
+val makeAndDumpFunctionCallGraph: Cil.file -> unit
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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 Pretty
+module E = Errormsg
+module CG = Callgraph
+module H = Hashtbl
+module U = Util
+module IH = Inthash
+module VS = Usedef.VS
+
+module S = Ssa
+
+let debug = false
+let prologue = "["
+let epilogue = "]"
+
+let ufsArithAbsOut = ref stdout
+let setUFSArithAbsFile (s: string) =
+ try
+ ufsArithAbsOut := open_out s
+ with _ -> ignore (E.warn "Cannot open the output file %s" s)
+
+(* Print out *)
+let pd ?(ind=0) (d: doc) : unit =
+ Pretty.fprint !ufsArithAbsOut 80 (indent ind d)
+
+let p ?(ind=0) (fmt : ('a,unit,doc) format) : 'a =
+ let f d =
+ pd ~ind:ind d;
+ nil
+ in
+ Pretty.gprintf f fmt
+
+
+(** Variables whose address is taken are ignores. Set this to true if you
+ * want references to the address of such variables to be printed as the only
+ * accesses of the variable *)
+let treatAddressOfAsRead = true
+
+(** The globals written, indexed by Id of the function variable. Each inner
+ * table is indexed by the global id *)
+let globalsWritten: (varinfo IH.t) IH.t = IH.create 13
+let currentGlobalsWritten: (varinfo IH.t) ref = ref (IH.create 13)
+
+
+(** The transitive closure of the globals written *)
+let globalsWrittenTransitive: (varinfo IH.t) IH.t = IH.create 13
+
+let globalsRead: (varinfo IH.t) IH.t = IH.create 13
+let currentGlobalsRead: (varinfo IH.t) ref = ref (IH.create 13)
+
+let globalsReadTransitive: (varinfo IH.t) IH.t = IH.create 13
+
+
+(* ***************************************************** *)
+let getGlobalsWrittenTransitive (f: varinfo): varinfo list =
+ try
+ let glob_written_trans =
+ IH.find globalsWrittenTransitive f.vid
+ in
+ IH.fold
+ (fun _ g acc -> g :: acc)
+ glob_written_trans
+ []
+ with Not_found -> [] (* not a defined function *)
+(* ***************************************************** *)
+
+(* ***************************************************** *)
+let getGlobalsReadTransitive (f: varinfo) =
+ try
+ let glob_read_trans =
+ IH.find globalsReadTransitive f.vid
+ in
+ IH.fold
+ (fun _ g acc -> g :: acc)
+ glob_read_trans
+ []
+ with Not_found -> []
+(* ***************************************************** *)
+
+(* ASHISH: Change here? TArray _ | TFun _ | TNamed _ | TComp _ *)
+let considerType (t: typ) : bool =
+ (* Only consider those types for this we can do arithmetic *)
+ (match unrollType t with
+ TInt _ | TEnum _ | TPtr _ | TFloat _ -> true
+ | _ -> false)
+
+(* ASHISH: remove v.vaddrof, since we can handle variable whose addr is taken *)
+let considerVariable (v: varinfo) : bool =
+ not v.vaddrof && considerType v.vtype
+
+(* ***************************************************** *)
+class gwVisitorClass : cilVisitor = object (self)
+ inherit nopCilVisitor
+
+ (* *************************************************** *)
+ method vexpr = function
+ Lval (Var v, _) when v.vglob && considerVariable v ->
+ IH.replace !currentGlobalsRead v.vid v;
+ DoChildren
+
+ (* We pretend that when we see the address of a global, we are reading
+ * from the variable. Note that these variables will not be among those
+ * that we "considerVariable" so, there will be no writing to them *)
+ | StartOf (Var v, NoOffset)
+ | AddrOf (Var v, NoOffset) when treatAddressOfAsRead && v.vglob ->
+ IH.replace !currentGlobalsRead v.vid v;
+ DoChildren
+
+ | _ -> DoChildren
+ (* *************************************************** *)
+
+ (* *************************************************** *)
+ method vinst = function
+ Set ((Var v, _), _, _)
+ | Call (Some (Var v, _), _, _, _) when v.vglob && considerVariable v ->
+ IH.replace !currentGlobalsWritten v.vid v;
+ (* When we write a global, we also consider that we are reading it.
+ * This is useful if the global is not written on all paths *)
+ IH.replace !currentGlobalsRead v.vid v;
+ DoChildren
+ | _ -> DoChildren
+ (* *************************************************** *)
+end
+(* ***************************************************** *)
+
+let gwVisitor = new gwVisitorClass
+
+
+(** Functions can be defined or just declared *)
+type funinfo =
+ Decl of varinfo
+ | Def of fundec
+
+(* All functions indexed by the variable ID *)
+let allFunctions: funinfo IH.t = IH.create 13
+
+
+(* ***************************************************** *)
+(* ASHISH: called from dGlobal( GFun ) *)
+(** Compute the SSA form *)
+let fundecToCFGInfo (fdec: fundec) : S.cfgInfo =
+ (* Go over the statments and make sure they are numbered properly *)
+ let count = ref 0 in
+ List.iter (fun s -> s.sid <- !count; incr count) fdec.sallstmts;
+
+ let start: stmt =
+ match fdec.sbody.bstmts with
+ [] -> E.s (E.bug "Function %s with no body" fdec.svar.vname)
+ | fst :: _ -> fst
+ in
+ if start.sid <> 0 then
+ E.s (E.bug "The first block must have index 0");
+
+
+ let ci =
+ { S.name = fdec.svar.vname;
+ S.start = start.sid;
+ S.size = !count;
+ S.successors = Array.make !count [];
+ S.predecessors = Array.make !count [];
+ S.blocks = Array.make !count { S.bstmt = start;
+ S.instrlist = [];
+ S.reachable = true;
+ S.livevars = [] };
+ S.nrRegs = 0;
+ S.regToVarinfo = Array.make 0 dummyFunDec.svar;
+ }
+ in
+
+ (* Map a variable to a register *)
+ let varToRegMap: S.reg IH.t = IH.create 13 in
+ let regToVarMap: varinfo IH.t = IH.create 13 in
+ let varToReg (v: varinfo) : S.reg =
+ try IH.find varToRegMap v.vid
+ with Not_found ->
+ let res = ci.S.nrRegs in
+ ci.S.nrRegs <- 1 + ci.S.nrRegs;
+ IH.add varToRegMap v.vid res;
+ IH.add regToVarMap res v;
+ res
+ in
+ (* For functions, we use the transitively computed set of globals and
+ * locals as the use/def *)
+ Usedef.getUseDefFunctionRef :=
+ (fun f args ->
+ match f with
+ Lval (Var fv, NoOffset) ->
+ let varDefs = ref VS.empty in
+ let varUsed = ref VS.empty in
+ (try
+ let gw = IH.find globalsWrittenTransitive fv.vid in
+ IH.iter
+ (fun _ g -> varDefs := VS.add g !varDefs) gw
+ with Not_found -> (* Do not have a definition for it *)
+ ());
+ (* Now look for globals read *)
+ (try
+ let gr = IH.find globalsReadTransitive fv.vid in
+ IH.iter
+ (fun _ g -> varUsed := VS.add g !varUsed) gr
+ with Not_found -> ());
+
+ !varUsed, !varDefs, args
+
+ | _ -> VS.empty, VS.empty, args);
+
+
+ Usedef.considerVariableUse :=
+ (fun v -> considerVariable v);
+ Usedef.considerVariableDef :=
+ (fun v -> considerVariable v);
+ Usedef.considerVariableAddrOfAsUse :=
+ (fun v -> treatAddressOfAsRead);
+
+ (* Filter out the variables we do not care about *)
+ let vsToRegList (vs: VS.t) : int list =
+ VS.fold (fun v acc -> (varToReg v) :: acc) vs []
+ in
+ List.iter
+ (fun s ->
+ ci.S.successors.(s.sid) <- List.map (fun s' -> s'.sid) s.succs;
+ ci.S.predecessors.(s.sid) <- List.map (fun s' -> s'.sid) s.preds;
+ ci.S.blocks.(s.sid) <- begin
+ let instrs: (S.reg list * S.reg list) list =
+ match s.skind with
+ Instr il ->
+ (* Each instruction is transformed independently *)
+ List.map (fun i ->
+ let vused, vdefs = Usedef.computeUseDefInstr i in
+ (vsToRegList vdefs, vsToRegList vused)) il
+
+ | Return (Some e, _)
+ | If (e, _, _, _)
+ | Switch (e, _, _, _) ->
+ let vused = Usedef.computeUseExp e in
+ [ ([], vsToRegList vused) ]
+
+ | Break _ | Continue _ | Goto _ | Block _ | Loop _ | Return _ -> [ ]
+ | TryExcept _ | TryFinally _ -> assert false
+ in
+ { S.bstmt = s;
+ S.instrlist = instrs;
+ S.livevars = []; (* Will be filled in later *)
+ S.reachable = true; (* Will be set later *)
+ }
+ end
+ ) fdec.sallstmts;
+
+ (* Set the mapping from registers to variables *)
+ ci.S.regToVarinfo <-
+ Array.make ci.S.nrRegs dummyFunDec.svar;
+ IH.iter (fun rid v ->
+ ci.S.regToVarinfo.(rid) <- v) regToVarMap;
+
+ ci
+(* ***************************************************** *)
+
+(* ***************************************************** *)
+(* Compute strongly-connected components *)
+let stronglyConnectedComponents (cfg: S.cfgInfo) : bool -> S.sccInfo =
+ S.stronglyConnectedComponents cfg
+
+
+let globalsDumped = IH.create 13
+(* ***************************************************** *)
+
+
+(* ***************************************************** *)
+(** We print variable names in a special way *)
+let variableName (v: varinfo) (freshId: int) =
+ (if v.vaddrof then begin
+ assert treatAddressOfAsRead;
+ "addrof_"
+ end else "") ^
+ (if v.vglob then "glob_" else "") ^
+ (if freshId = 0 then
+ v.vname
+ else
+ v.vname ^ "____" ^ string_of_int freshId)
+(* ***************************************************** *)
+
+(* ***************************************************** *)
+(** Use a hash table indexed by varinfo *)
+module VH = Hashtbl.Make(struct
+ type t = varinfo
+ let hash (v: varinfo) = v.vid
+ let equal v1 v2 = v1.vid = v2.vid
+ end)
+
+let vhToList (vh: 'a VH.t) : (varinfo * 'a) list =
+ VH.fold (fun v id acc -> (v, id) :: acc) vh []
+
+let debugRename = false
+(* ***************************************************** *)
+
+(* ***************************************************** *)
+(** We define a new printer *)
+class absPrinterClass (callgraph: CG.callgraph) : cilPrinter =
+
+ let lastFreshId= ref 0 in
+
+ (* freshVarId returns at least 1 *)
+ let freshVarId () = incr lastFreshId; !lastFreshId in
+
+
+ object (self)
+ inherit defaultCilPrinterClass as super
+
+ val mutable idomData: stmt option IH.t = IH.create 13
+
+ val mutable cfgInfo: S.cfgInfo option = None
+
+
+ val mutable sccInfo: S.sccInfo option = None
+
+ val mutable currentFundec = dummyFunDec
+
+ (** For each block end, a mapping from IDs of variables to their ID
+ * at the end of the block *)
+ val mutable blockEndData: int VH.t array =
+ Array.make 0 (VH.create 13)
+
+ (** For each block start, remember the starting newFreshId as we
+ * start the block *)
+ val mutable blockStartData: int array =
+ Array.make 0 (-1)
+
+
+ val mutable varRenameState: int VH.t = VH.create 13
+
+ (* All the fresh variables *)
+ val mutable freshVars: string list = []
+
+ (* The uninitialized variables are those that are live on input but
+ * not globals or formals. *)
+ val mutable uninitVars: string list = []
+
+ (* ************************************************* *)
+ method private initVarRenameState (b: S.cfgBlock) =
+ VH.clear varRenameState;
+
+ let cfgi =
+ match cfgInfo with
+ None -> assert false
+ | Some cfgi -> cfgi
+ in
+
+ (* Initialize it based on the livevars info in the block *)
+ List.iter
+ (fun (rid, defblk) ->
+ let v = cfgi.S.regToVarinfo.(rid) in
+ if defblk = b.S.bstmt.sid then
+ (* Is a phi variable or a live variable at start *)
+ if defblk = cfgi.S.start then begin
+ (* For the start block, use ID=0 for all variables, except the
+ * locals that are not function formals. Those are fresh
+ * variables. *)
+ let isUninitializedLocal =
+ not v.vglob &&
+ (not (List.exists (fun v' -> v'.vid = v.vid)
+ currentFundec.sformals)) in
+ VH.add varRenameState v 0;
+ let vn = self#variableUse varRenameState v in
+ if isUninitializedLocal then
+ uninitVars <- vn :: uninitVars;
+ end else begin
+ VH.add varRenameState v (freshVarId ());
+ let vn = self#variableUse varRenameState v in
+ freshVars <- vn :: freshVars
+ end
+ else begin
+ let fid =
+ try VH.find blockEndData.(defblk) v
+ with Not_found ->
+ E.s (E.bug "In block %d: Cannot find data for variable %s in block %d"
+ b.S.bstmt.sid v.vname defblk)
+ in
+ VH.add varRenameState v fid
+ end)
+ b.S.livevars;
+
+ if debugRename then
+ ignore (E.log "At start of block %d:\n @[%a@]\n"
+ b.S.bstmt.sid
+ (docList ~sep:line
+ (fun (v, id) ->
+ dprintf "%s: %d" v.vname id))
+ (vhToList varRenameState));
+ ()
+ (* ************************************************* *)
+
+ (* ************************************************* *)
+ (** This is called for reading from a variable we consider (meaning that
+ * its address is not taken and has the right type) *)
+ method private variableUse ?(print=true)
+ (state: int VH.t) (v: varinfo) : string =
+ let freshId =
+ try VH.find state v
+ with Not_found ->
+ E.s (E.bug "%a: varUse: varRenameState does not know anything about %s"
+ d_loc !currentLoc v.vname )
+ in
+ if debugRename && print then
+ ignore (E.log "At %a: variableUse(%s) : %d\n"
+ d_loc !currentLoc v.vname freshId);
+ variableName v freshId
+ (* ************************************************* *)
+
+ (* ************************************************* *)
+ method private variableDef (state: int VH.t) (v: varinfo) : string =
+ assert (not v.vaddrof);
+ let newid = freshVarId () in
+ VH.replace state v newid;
+ if debugRename then
+ ignore (E.log "At %a: variableDef(%s) : %d\n"
+ d_loc !currentLoc v.vname newid);
+ let n = self#variableUse ~print:false state v in
+ freshVars <- n :: freshVars;
+ n
+ (* ************************************************* *)
+
+ (* ************************************************* *)
+ method pExp () = function
+ | Const (CInt64(i, _, _)) -> text (Int64.to_string i)
+ | Const (CStr _) -> text "(@rand)"
+ | BinOp (bop, e1, e2, _) ->
+ dprintf "(%a @[%a@?%a@])"
+ d_binop bop
+ self#pExp e1 self#pExp e2
+ | UnOp (uop, e1, _) ->
+ dprintf "(%a @[%a@])"
+ d_unop uop self#pExp e1
+ | CastE (t, e) -> self#pExp () e (* Ignore casts *)
+
+ | Lval (Var v, NoOffset) when considerVariable v ->
+ text (self#variableUse varRenameState v)
+
+ (* ASHISH: Trying ... *)
+ | Lval (Mem e, NoOffset) ->
+ dprintf "(deref %a)" self#pExp e
+ (* ASHISH: End ... some error here *)
+
+ (* We ignore all other Lval *)
+ | Lval _ -> text "(@rand)"
+
+
+ | AddrOf (Var v, NoOffset)
+ | StartOf (Var v, NoOffset) ->
+ if treatAddressOfAsRead then
+ text (self#variableUse varRenameState v)
+ else
+ text "(@rand)"
+
+
+ | e -> super#pExp () e
+ (* ************************************************* *)
+
+ (* ************************************************* *)
+ method pInstr () (i: instr) =
+ (* Print a call *)
+ let printCall (dest: varinfo option)
+ (f: varinfo) (args: exp list) (l: location) =
+ currentLoc := l;
+ let gwt: varinfo list = getGlobalsWrittenTransitive f in
+ let grt: varinfo list = getGlobalsReadTransitive f in
+
+ let gwt' =
+ match dest with
+ Some dest -> gwt @ [dest]
+ | _ -> gwt
+
+ in
+ (* Prepare the arguments first *)
+ let argdoc: doc =
+ (docList ~sep:break (self#pExp ()))
+ ()
+ (args @ (List.map (fun v -> Lval (Var v, NoOffset)) grt))
+ in
+ dprintf "%a = (%s @[%a@]);"
+ (docList
+ (fun v ->
+ text (self#variableDef varRenameState v)))
+ gwt'
+ f.vname
+ insert argdoc
+ in
+ match i with
+ | Set ((Var v, NoOffset), e, l) when considerVariable v ->
+ (* ignore (p "/* ASHISH: printing instr Set v:= e, l=%d */@!" l.line); *)
+ currentLoc := l;
+ (* We must do the use first *)
+ let use = self#pExp () e in
+ text (self#variableDef varRenameState v)
+ ++ text "=" ++ use ++ text ";"
+
+ | Call (Some (Var v, NoOffset),
+ Lval (Var f, NoOffset), args, l) when considerVariable v ->
+ printCall (Some v)
+ f args l
+
+ (* Ignore the result if not a variable we are considering *)
+ | Call (_, Lval (Var f, NoOffset), args, l) ->
+ printCall None f args l
+
+ (* ASHISH: ADDING ... *)
+ | Set ((Mem e, NoOffset), e2, l) ->
+ (* ignore (p "/* Ashish: Lval is mem */@!") ; *)
+ currentLoc := l;
+ let use1 = self#pExp () e in
+ let use2 = self#pExp () e2 in
+ text "(deref " ++ use1 ++ text ") =" ++ use2 ++ text ";"
+ (* ASHISH: End ... *)
+
+ | _ -> nil (* Ignore the other instructions *)
+ (* ************************************************* *)
+
+
+ (* ************************************************* *)
+ (* ASHISH: Iterate over the statements in the block *)
+ method dBlock (out: out_channel) (ind: int) (b: block) : unit =
+ ignore (p ~ind:ind "%sblock\n" prologue);
+ List.iter (self#dStmt out (ind+ 2)) b.bstmts;
+ ignore (p ~ind:ind "%s\n" epilogue)
+ (* ************************************************* *)
+
+ (* ************************************************* *)
+ method dStmt (out: out_channel) (ind: int) (s: stmt) : unit =
+ currentLoc := get_stmtLoc s.skind;
+ (* Initialize the renamer for this statement *)
+ lastFreshId := blockStartData.(s.sid);
+ if debugRename then
+ ignore (E.log "Initialize the renamer for block %d to %d\n"
+ s.sid !lastFreshId);
+ assert (!lastFreshId >= 0);
+
+ (* ASHISH: Get CFG info: this is required to
+ Compute succs, preds info for this stmt
+ Note cfgInfo is computed once when processing the
+ enclosing dGlobal call *)
+ let cfgi =
+ match cfgInfo with
+ Some cfgi -> cfgi
+ | None -> assert false
+ in
+ let blk: S.cfgBlock = cfgi.S.blocks.(s.sid) in
+ assert (blk.S.bstmt == s);
+
+ self#initVarRenameState blk;
+
+ (* ASHISH: compute phivars: for stmts that have
+ 2 preds, we need to print nonphi vars *)
+ let phivars: varinfo list =
+ List.fold_left
+ (fun acc (i, defblk) ->
+ if defblk = s.sid then
+ cfgi.S.regToVarinfo.(i) :: acc
+ else
+ acc)
+ []
+ blk.S.livevars
+ in
+ (* do not emit phi for start block *)
+ let phivars: varinfo list =
+ if s.sid = cfgi.S.start then
+ []
+ else
+ phivars
+ in
+
+ (* Get the predecessors information *)
+ (* ASHISH: Get the phi assignments for this stmt;
+ they will go before any other stuff from stmt-kind *)
+ let getPhiAssignment (v: varinfo) : (string * string list) =
+ (* initVarRenameState has already set the state for the phi register *)
+ let lhs: string = self#variableUse varRenameState v in
+ let rhs: string list =
+ List.map
+ (fun p ->
+ self#variableUse blockEndData.(p) v)
+ cfgi.S.predecessors.(s.sid)
+ in
+ (lhs, rhs)
+ in
+
+ pd (self#pLineDirective (get_stmtLoc s.skind));
+ (* Lookup its dominator *)
+ (* ASHISH: the idom info: similar to preds *)
+ let idom: doc =
+ match Dominators.getIdom idomData s with
+ Some dom -> num dom.sid
+ | None -> nil
+ in
+
+ (* ASHISH: If this block is a header, then
+ insert information on nonphi variables *)
+ let headerstuff =
+ (* See if this block is a header *)
+ let scc =
+ match sccInfo with Some x -> x
+ | _ -> E.s (E.bug "sccInfo is not set")
+ in
+ if List.exists (fun sci -> List.mem s.sid sci.S.headers) scc then begin
+ (* We get the variables at the end of any predecessor. *)
+ let p: int =
+ match cfgi.S.predecessors.(s.sid) with
+ p :: _ -> p
+ | [] -> E.s (E.bug "Header block %d has no predecessors" s.sid)
+ in
+ let pend: int VH.t = blockEndData.(p) in
+ let allvars: (varinfo * int) list = vhToList pend in
+
+ (* ASHISH: get and print nonphi vars *)
+ let nonphi: (varinfo * int) list =
+ List.filter
+ (fun (v, _) ->
+ not (List.exists (fun v' -> v'.vid = v.vid) phivars)) allvars
+ in
+
+ dprintf "%snonphi %a%s\n"
+ prologue
+ (docList
+ (fun (v, vvariant) ->
+ text (variableName v vvariant)))
+ nonphi
+ epilogue
+ end else
+ nil
+ in
+
+ (* ASHISH: Compute succs, preds for stmt *)
+ let succs = List.filter (fun s' -> cfgi.S.blocks.(s'.sid).S.reachable) s.succs in
+ let preds = List.filter (fun s' -> cfgi.S.blocks.(s'.sid).S.reachable) s.preds in
+ (* ASHISH: Print generic stuff about stmt:
+ its id, succs, preds, idom *)
+ ignore (p ~ind:ind
+ "%sstmt %d %a %ssuccs %a%s %spreds %a%s %sidom %a%s\n @[%a@]\n"
+ prologue s.sid (** Statement id *)
+ insert headerstuff
+ prologue (d_list "," (fun _ s' -> num s'.sid)) succs epilogue
+ prologue (d_list "," (fun _ s' -> num s'.sid)) preds epilogue
+ prologue insert idom epilogue
+ (docList ~sep:line
+ (fun pv ->
+ let (lhs, rhs) = getPhiAssignment pv in
+ dprintf "%s = (@@phi %a);"
+ lhs (docList ~sep:break text) rhs))
+ phivars
+ );
+ (* ASHISH: End of printing stuff generic to all stmts *)
+
+ (* ASHISH: Output based on kind of statement *)
+ (* Now the statement kind *)
+ let ind = ind + 2 in
+ (match s.skind with
+ | Instr il ->
+ (* ignore (p "/* ASHISH: Printing Instr instr list */@!") ; *)
+ if (cfgi.S.blocks.(s.sid).S.reachable) then begin
+ List.iter
+ (fun i ->
+ pd ~ind:ind (self#pInstr () i ++ line))
+ il
+ end
+ | Block b ->
+ (* ignore (p "/* ASHISH: Iterating over Stmts in a Block */@!") ; *)
+ List.iter (self#dStmt out ind) b.bstmts
+ | Goto (s, _) -> ignore (p ~ind:ind "%sgoto %d%s\n" prologue !s.sid epilogue)
+ | Return (what, _) -> begin
+
+ let gwt: varinfo list =
+ getGlobalsWrittenTransitive currentFundec.svar
+ in
+ let res: varinfo list =
+ match what with
+ None -> gwt
+ | Some (Lval (Var v, NoOffset)) when v.vname = "__retres" ->
+ if considerType v.vtype then
+ gwt @ [ v ]
+ else
+ gwt
+ | Some e ->
+ E.s (E.bug "Return with no __retres: %a" d_exp e)
+ in
+ ignore (p ~ind:ind
+ "return %a;"
+ (docList
+ (fun v ->
+ text (self#variableUse varRenameState v)))
+ res);
+ end
+
+ | If(e, b1, b2, _) ->
+ ignore (p ~ind:ind "%sif %a\n" prologue self#pExp e);
+ self#dBlock out (ind + 2) b1;
+ self#dBlock out (ind + 2) b2;
+ ignore (p ~ind:ind "%s\n" epilogue)
+
+ | Loop (b, _, Some co, Some br) ->
+ ignore (p ~ind:ind "%sloop %scont %d%s %sbreak %d%s\n"
+ prologue
+ prologue co.sid epilogue
+ prologue br.sid epilogue);
+ List.iter (self#dStmt out (ind+ 2)) b.bstmts;
+ ignore (p ~ind:ind "%s\n" epilogue)
+
+ (* The other cases should have been removed already *)
+ | _ -> E.s (E.unimp "try except"));
+
+ (* The termination *)
+ let ind = ind - 2 in
+ ignore (p ~ind:ind "%s\n" epilogue)
+ (* ************************************************* *)
+
+
+ (* ************************************************* *)
+ method dGlobal (out: out_channel) (g: global) : unit =
+ match g with
+ GFun (fdec, l) ->
+ (* ignore (p "/* ASHISH: GFun global */@!") ; *)
+ currentFundec <- fdec;
+ if debugRename then
+ ignore (E.log "Renaming for function %s\n" fdec.svar.vname);
+
+ (* Make sure we use one return at most *)
+ Oneret.oneret fdec;
+
+ (* Now compute the immediate dominators. This will fill in the CFG
+ * info as well *)
+ idomData <- Dominators.computeIDom fdec;
+
+ (** Get the callgraph node for this function *)
+ let cg_node: CG.callnode =
+ try H.find callgraph fdec.svar.vname
+ with Not_found -> E.s (E.bug "Cannot find call graph info for %s"
+ fdec.svar.vname)
+ in
+
+ (** Get the globals read and written *)
+ let glob_read =
+ (try IH.find globalsRead fdec.svar.vid
+ with Not_found -> assert false) in
+ let glob_read_trans =
+ (try IH.find globalsReadTransitive fdec.svar.vid
+ with Not_found -> assert false) in
+
+
+ let glob_written =
+ (try IH.find globalsWritten fdec.svar.vid
+ with Not_found -> assert false) in
+ let glob_written_trans =
+ (try IH.find globalsWrittenTransitive fdec.svar.vid
+ with Not_found -> assert false) in
+
+ (* Compute the control flow graph info, for SSA computation *)
+ let cfgi = S.prune_cfg (fundecToCFGInfo fdec) in
+ cfgInfo <- Some cfgi;
+ (* Call here the SSA function to fill-in the cfgInfo *)
+ S.add_ssa_info cfgi;
+
+ (* Compute strongly connected components *)
+ let scc: S.sccInfo =
+ stronglyConnectedComponents cfgi false in
+ sccInfo <- Some scc;
+
+ (* Now do the SSA renaming. *)
+
+ blockStartData <- Array.make cfgi.S.size (-1);
+ blockEndData <- Array.make cfgi.S.size (VH.create 13);
+
+ lastFreshId := 0;
+
+ freshVars <- [];
+ uninitVars <- [];
+
+ (* ************************************************ *)
+ if debugRename then
+ ignore (E.log "Starting renaming phase I for %s\n"
+ fdec.svar.vname);
+ Array.iteri (fun i (b: S.cfgBlock) ->
+ (* compute the initial state *)
+ blockStartData.(i) <- !lastFreshId;
+ if debugRename then
+ ignore (E.log "Save the rename state for block %d to %d\n"
+ i !lastFreshId);
+
+ (* Initialize the renaming state *)
+ self#initVarRenameState b;
+
+ (* Now scan the block and keep track of the definitions. This is
+ * a huge hack. We try to rename the variables in the same order
+ * in which we will rename them during actual printing of the
+ * block. It would have been cleaner to print the names of the
+ * variables after printing the function. *)
+ (match b.S.bstmt.skind with
+ Instr il -> begin
+ List.iter
+ (fun i ->
+ let doCall (dest: varinfo option) (f: varinfo) : unit =
+ let gwt: varinfo list =
+ getGlobalsWrittenTransitive f in
+ let gwt' =
+ match dest with
+ Some v ->
+ gwt @ [ v ]
+ | _ -> gwt
+ in
+ List.iter (fun v ->
+ ignore (self#variableDef varRenameState v))
+ gwt'
+ in
+ match i with
+ Set ((Var v, NoOffset), _, l)
+ when considerVariable v ->
+ currentLoc := l;
+ ignore (self#variableDef varRenameState v)
+ | Call (Some (Var v, NoOffset),
+ Lval (Var f, NoOffset), _, l)
+ when considerVariable v ->
+ currentLoc := l;
+ doCall (Some v) f
+
+
+ | Call (_,
+ Lval (Var f, NoOffset), _, l) ->
+ currentLoc := l;
+ doCall None f
+
+ | _ -> ())
+ il
+ end
+
+ | _ -> (* No definitions *)
+ ()
+ );
+
+ if debugRename then
+ ignore (E.log "At end of block %d:\n @[%a@]\n"
+ i
+ (docList ~sep:line
+ (fun (v, id) ->
+ dprintf "%s: %d" v.vname id))
+ (vhToList varRenameState));
+
+ blockEndData.(i) <- VH.copy varRenameState;
+ )
+ cfgi.S.blocks;
+
+ if debugRename then
+ ignore (E.log "Starting renaming phase II (printing) for %s\n"
+ fdec.svar.vname);
+ (* ************************************************ *)
+
+
+ (** For each basic block *)
+
+
+ (* The header *)
+ pd (self#pLineDirective ~forcefile:true l);
+
+ ignore (p "%sfunction %s\n %sformals %a%s\n %sglobalsreadtransitive %a%s\n %sglobalswrittentransitive %a%s\n %slocals %a%s\n %suninitlocals %a%s\n %sglobalsread %a%s\n %sglobalswritten %a%s\n %scalls %a%s\n %scalledby %a%s\n %a"
+ prologue fdec.svar.vname
+ prologue (docList (fun v -> text (variableName v 0)))
+ fdec.sformals epilogue
+ prologue (d_list "," (fun () v -> text (variableName v 0)))
+ (getGlobalsReadTransitive fdec.svar) epilogue
+ prologue (d_list "," (fun () v -> text (variableName v 0)))
+ (getGlobalsWrittenTransitive fdec.svar) epilogue
+ prologue (docList text) freshVars epilogue
+ prologue (docList text) uninitVars epilogue
+ prologue (d_list "," (fun () (_, v) -> text (variableName v 0))) (IH.tolist glob_read) epilogue
+ prologue (d_list "," (fun () (_, v) -> text (variableName v 0))) (IH.tolist glob_written) epilogue
+ prologue (U.docHash (fun k _ -> text k)) cg_node.CG.cnCallees epilogue
+ prologue (U.docHash (fun k _ -> text k)) cg_node.CG.cnCallers epilogue
+ (docList ~sep:line
+ (fun oneScc ->
+ dprintf "%sSCC %sheaders %a%s %snodes %a%s%s\n"
+ prologue
+ prologue (docList num) oneScc.S.headers epilogue
+ prologue (docList num) oneScc.S.nodes epilogue
+ epilogue))
+ scc);
+
+
+ (* The block *)
+ self#dBlock out 2 fdec.sbody;
+
+ (* The end *)
+ ignore (p "\n%s\n\n" epilogue)
+
+ (* Emit the globals whose address is not taken *)
+ | GVarDecl (vi, l) | GVar (vi, _, l) when
+ not vi.vaddrof && isIntegralType vi.vtype
+ && not (IH.mem globalsDumped vi.vid)
+ ->
+ (* ignore (p "/* ASHISH: GVarDecl or GVar global */@!") ; *)
+ IH.add globalsDumped vi.vid ();
+ pd (self#pLineDirective ~forcefile:true l);
+ ignore (p "%sglobal %s%s\n" prologue vi.vname epilogue)
+
+ | _ ->
+ (* ignore (p "/* ASHISH: GVarDecl or GVar global */@!") ; *)
+ ()
+ (* ************************************************* *)
+
+end
+
+
+(* ASHISH: cil:dumpGlobal calls absPrinter#dGlobal *)
+let arithAbs (absPrinter: cilPrinter) (g: global) =
+ dumpGlobal absPrinter !ufsArithAbsOut g
+
+let feature : featureDescr =
+ { fd_name = "arithabs";
+ fd_enabled = ref false;
+ fd_description = "generation of an UFS+arithmetic abstraction";
+ fd_extraopt = [
+ ("--arithabs_file", Arg.String setUFSArithAbsFile,
+ "the name of the file to dump the UFS+arithmetic abstraction to") ];
+ fd_doit =
+ (function (f : file) ->
+
+ (* Call the simplify *)
+ Simplify.onlyVariableBasics := true;
+ Simplify.feature.fd_doit f;
+ (* Compute the call graph *)
+ let graph = CG.computeGraph f in
+
+ (* Compute the globals written by each function *)
+ IH.clear globalsWritten;
+ IH.clear globalsWrittenTransitive;
+ IH.clear globalsRead;
+
+ IH.clear allFunctions;
+
+
+ (* Compute the globals read and written *)
+ iterGlobals
+ f
+ (function
+ GFun(fdec, _) ->
+ IH.replace allFunctions fdec.svar.vid (Def fdec);
+ currentGlobalsRead := IH.create 13;
+ IH.add globalsRead fdec.svar.vid !currentGlobalsRead;
+ currentGlobalsWritten := IH.create 13;
+ IH.add globalsWritten fdec.svar.vid !currentGlobalsWritten;
+ ignore (visitCilBlock gwVisitor fdec.sbody)
+
+ | GVarDecl (vd, _) when isFunctionType vd.vtype &&
+ not (IH.mem allFunctions vd.vid)
+ ->
+ IH.add allFunctions vd.vid (Decl vd)
+ | _ -> ());
+
+ (* Now do transitive closure of the globals written by each function *)
+ (* Initialize each function with the globals it writes itself *)
+ IH.iter
+ (fun fid gw ->
+ IH.add globalsWrittenTransitive fid (IH.copy gw))
+ globalsWritten;
+
+ IH.iter
+ (fun fid gr ->
+ IH.add globalsReadTransitive fid (IH.copy gr))
+ globalsRead;
+
+ (* A work list initialized with all functions, that are defined *)
+ let worklist: int Queue.t = Queue.create () in
+ IH.iter (fun fid finfo ->
+ match finfo with
+ Def _ -> Queue.add fid worklist
+ | _ -> ())
+
+ allFunctions;
+
+ (* Now run until we reach a fixed point *)
+ let rec fixedpoint () =
+ try
+ let next = Queue.take worklist in
+ (* Get the function info for this one *)
+ let finfo =
+ try IH.find allFunctions next
+ with Not_found ->
+ E.s (E.bug "Function id=%d not in allFunctions" next)
+ in
+ (* If this is just a declaration, we ignore *)
+ (match finfo with
+ Decl _ -> ()
+ | Def fdec -> begin
+ (* Find the callnode for it *)
+ let cnode: CG.callnode =
+ try H.find graph fdec.svar.vname
+ with Not_found ->
+ E.s (E.bug "Function %s does not have a call node"
+ fdec.svar.vname)
+ in
+ (* Union in all the variables modified by the functions this
+ * calls. Remember if we made a change. If we do, we add to the
+ * worklist the callers of this one. *)
+ let changeMade = ref false in
+
+ (* Our written *)
+ let ourWritten =
+ try IH.find globalsWrittenTransitive fdec.svar.vid
+ with Not_found ->
+ E.s (E.bug "Function %s not in globalsWrittenTransitive"
+ fdec.svar.vname)
+ in
+
+ (* Our read *)
+ let ourRead =
+ try IH.find globalsReadTransitive fdec.svar.vid
+ with Not_found ->
+ E.s (E.bug "Function %s not in globalsReadTransitive"
+ fdec.svar.vname)
+ in
+(*
+ ignore (E.log "fixedpoint: doing %s\n read so far: %a\n written so far: %a\n"
+ fdec.svar.vname
+ (docList (fun (_, v) -> text v.vname))
+ (IH.tolist ourRead)
+ (docList (fun (_, v) -> text v.vname))
+ (IH.tolist ourRead));
+*)
+ H.iter
+ (fun n cn ->
+ (* Get the callee's written *)
+ (try
+ let callee_written =
+ IH.find globalsWrittenTransitive cn.CG.cnInfo.vid in
+ IH.iter
+ (fun gwid gw ->
+ if not (IH.mem ourWritten gwid) then begin
+ IH.add ourWritten gwid gw;
+ changeMade := true
+ end)
+ callee_written;
+ with Not_found -> (* Callee not defined here *)
+ ());
+
+ (* Get the callee's read *)
+ (try
+ let callee_read =
+ IH.find globalsReadTransitive cn.CG.cnInfo.vid in
+ IH.iter
+ (fun grid gr ->
+ if not (IH.mem ourRead grid) then begin
+ IH.add ourRead grid gr;
+ changeMade := true
+ end)
+ callee_read;
+ with Not_found -> (* Callee not defined here *)
+ ());
+
+
+ )
+ cnode.CG.cnCallees;
+
+ if !changeMade then begin
+ H.iter
+ (fun _ caller -> Queue.add caller.CG.cnInfo.vid worklist)
+ cnode.CG.cnCallers
+ end
+ end);
+
+ fixedpoint ();
+
+ with Queue.Empty -> ()
+ in
+ fixedpoint ();
+
+
+ let absPrinter: cilPrinter = new absPrinterClass graph in
+ IH.clear globalsDumped;
+ iterGlobals f
+ (arithAbs absPrinter);
+
+ (* compute SCC for the call-graph *)
+ let nodeIdToNode: CG.callnode IH.t = IH.create 13 in
+ let funidToNodeId: int IH.t = IH.create 13 in
+ let nrNodes = ref 0 in
+ let mainNode = ref 0 in
+ H.iter
+ (fun vn cn ->
+ if vn= "main" then mainNode := !nrNodes;
+ IH.add nodeIdToNode !nrNodes cn;
+ IH.add funidToNodeId cn.CG.cnInfo.vid !nrNodes;
+ incr nrNodes) graph;
+
+ let ci: S.cfgInfo =
+ { S.name = "call-graph";
+ S.start = !mainNode;
+ S.size = !nrNodes;
+ S.successors = Array.make !nrNodes [];
+ S.predecessors = Array.make !nrNodes [];
+ S.blocks = Array.make !nrNodes { S.bstmt = mkEmptyStmt ();
+ S.instrlist = [];
+ S.livevars = [];
+ S.reachable = true };
+ S.nrRegs = 0;
+ S.regToVarinfo = Array.create 0 dummyFunDec.svar;
+ }
+ in
+ let ci = ci in
+ nrNodes := 0;
+ IH.iter (fun idx cn ->
+ let cnlistToNodeList (cnl: (string, CG.callnode) H.t) : int list =
+ List.map
+ (fun (_, sn) ->
+ try IH.find funidToNodeId sn.CG.cnInfo.vid
+ with Not_found -> assert false
+ )
+ (U.hash_to_list cnl)
+ in
+ (* we want to construct the callee graph not the caller graph *)
+ ci.S.successors.(idx) <- cnlistToNodeList cn.CG.cnCallers;
+ ci.S.predecessors.(idx) <- cnlistToNodeList cn.CG.cnCallees;
+
+ ) nodeIdToNode;
+
+ let scc: S.sccInfo =
+ stronglyConnectedComponents ci false in
+ List.iter
+ (fun oneScc ->
+ ignore (p "%sSCC %sheaders %a%s %snodes %a%s%s\n"
+ prologue
+ prologue (docList
+ (fun h ->
+ (try
+ text (IH.find nodeIdToNode h).CG.cnInfo.vname
+ with Not_found -> assert false)))
+ oneScc.S.headers epilogue
+ prologue (docList
+ (fun n ->
+ (try text (IH.find nodeIdToNode n).CG.cnInfo.vname
+ with Not_found -> assert false)))
+ oneScc.S.nodes epilogue
+ epilogue))
+ scc;
+
+
+ );
+
+
+
+
+ fd_post_check = false;
+ }
--- /dev/null
+
+open Cil
+open Pretty
+
+module E = Errormsg
+
+(** compute use/def information *)
+
+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
+ end)
+
+(** Set this global to how you want to handle function calls.
+ This also returns a modified argument list which will be used for the
+ purpose of Use analysis, in case you have a function that needs special
+ treatment of its args. *)
+let getUseDefFunctionRef: (exp -> exp list -> VS.t * VS.t * exp list) ref =
+ ref (fun func args -> (VS.empty, VS.empty, args))
+
+(** Say if you want to consider a variable use. This applies to
+ variable reads only; see also considerVariableAddrOfAsUse *)
+let considerVariableUse: (varinfo -> bool) ref =
+ ref (fun _ -> true)
+
+
+(** Say if you want to consider a variable def *)
+let considerVariableDef: (varinfo -> bool) ref =
+ ref (fun _ -> true)
+
+(** Say if you want to consider a variable addrof as a use *)
+let considerVariableAddrOfAsUse: (varinfo -> bool) ref =
+ ref (fun _ -> true)
+
+(** Return any vars that should be considered "used" by an expression,
+ other than the ones it refers to directly. Deputy uses this for
+ variables in Cast annotations. *)
+let extraUsesOfExpr: (exp -> VS.t) ref =
+ ref (fun _ -> VS.empty)
+
+(* When this is true, only definitions of a variable without
+ an offset are counted as definitions. So:
+ a = 5; would be a definition, but
+ a[1] = 5; would not.
+ Exception: writing to a union field is considered to be a definition of
+ the union even if this is set to true.*)
+let onlyNoOffsetsAreDefs: bool ref = ref false
+
+(** Should we ignore the contents of sizeof and alignof? *)
+let ignoreSizeof: bool ref = ref true
+
+let varUsed: VS.t ref = ref VS.empty
+let varDefs: VS.t ref = ref VS.empty
+
+class useDefVisitorClass : cilVisitor = object (self)
+ inherit nopCilVisitor
+
+ (** this will be invoked on variable definitions only because we intercept
+ * all uses of variables in expressions ! *)
+ method vvrbl (v: varinfo) =
+ if (!considerVariableDef) v &&
+ not(!onlyNoOffsetsAreDefs) then
+ varDefs := VS.add v !varDefs;
+ if (!considerVariableDef) v &&
+ !onlyNoOffsetsAreDefs then
+ varUsed := VS.add v !varUsed;
+ SkipChildren
+
+ (** 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) =
+ if !onlyNoOffsetsAreDefs then
+ match l with
+ (Var vi, NoOffset) ->
+ if (!considerVariableDef) vi then
+ varDefs := VS.add vi !varDefs;
+ SkipChildren
+ | (Var vi, Field(fi, NoOffset)) when not fi.fcomp.cstruct ->
+ (* If we are writing to a union field, treat that the same
+ as a write to a union. *)
+ if (!considerVariableDef) vi then
+ varDefs := VS.add vi !varDefs;
+ SkipChildren
+ | _ -> DoChildren
+ else DoChildren
+
+ method vexpr (e:exp) =
+ let extra = (!extraUsesOfExpr) e in
+ if not (VS.is_empty extra) then
+ varUsed := VS.union extra !varUsed;
+ match e with
+ 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) ->
+ ignore (visitCilOffset (self :> cilVisitor) off);
+ if (!considerVariableAddrOfAsUse) v then
+ varUsed := VS.add v !varUsed;
+ SkipChildren
+
+ | SizeOfE _
+ | AlignOfE _ when !ignoreSizeof -> SkipChildren
+
+ | _ -> DoChildren
+
+ (* For function calls, do the transitive variable read/defs *)
+ method vinst 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
+ * 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 -> ()
+ | Some lv -> ignore (visitCilLval self lv));
+ ignore (visitCilExpr self f);
+ List.iter (fun arg -> ignore (visitCilExpr self arg)) args';
+ SkipChildren
+ in
+ match i with
+ 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" ->
+ let dest' = match stripCasts adest with
+ AddrOf lv -> lv
+ | _ -> E.s (bug "bad call to %s" vi.vname)
+ in
+ doCall f (Some dest') [valist; SizeOf t]
+ | Call (_, Lval(Var vi, _), _, _)
+ when vi.vname = "__builtin_va_arg" ->
+ E.s (bug "bad call to %s" vi.vname)
+ | Call (lvo, f, args, _) ->
+ doCall f lvo args
+ | Asm(_,_,slvl,_,_,_) -> List.iter (fun (_,s,lv) ->
+ match lv with (Var v, off) ->
+ if s.[0] = '+' then
+ varUsed := VS.add v !varUsed;
+ | _ -> ()) slvl;
+ DoChildren
+ | _ -> DoChildren
+
+end
+
+let useDefVisitor = new useDefVisitorClass
+
+(** Compute the use information for an expression (accumulate to an existing
+ * set) *)
+let computeUseExp ?(acc=VS.empty) (e: exp) : VS.t =
+ varUsed := acc;
+ ignore (visitCilExpr useDefVisitor e);
+ !varUsed
+
+
+(** Compute the use/def information for an instruction *)
+let computeUseDefInstr ?(acc_used=VS.empty)
+ ?(acc_defs=VS.empty)
+ (i: instr) : VS.t * VS.t =
+ varUsed := acc_used;
+ varDefs := acc_defs;
+ ignore (visitCilInstr useDefVisitor i);
+ !varUsed, !varDefs
+
+
+(** Compute the use/def information for a statement kind. Do not descend into
+ * the nested blocks. *)
+let computeUseDefStmtKind ?(acc_used=VS.empty)
+ ?(acc_defs=VS.empty)
+ (sk: stmtkind) : VS.t * VS.t =
+ varUsed := acc_used;
+ varDefs := acc_defs;
+ let ve e = ignore (visitCilExpr useDefVisitor e) in
+ let _ =
+ match sk with
+ Return (None, _) -> ()
+ | Return (Some e, _) -> ve e
+ | If (e, _, _, _) -> ve e
+ | Break _ | Goto _ | Continue _ -> ()
+ | Loop (_, _, _, _) -> ()
+ | Switch (e, _, _, _) -> ve e
+ | Instr il ->
+ List.iter (fun i -> ignore (visitCilInstr useDefVisitor i)) il
+ | TryExcept _ | TryFinally _ -> ()
+ | Block _ -> ()
+ in
+ !varUsed, !varDefs
+
+(* Compute the use/def information for a statement kind.
+ DO descend into nested blocks *)
+let rec computeDeepUseDefStmtKind ?(acc_used=VS.empty)
+ ?(acc_defs=VS.empty)
+ (sk: stmtkind) : VS.t * VS.t =
+ let handle_block b =
+ List.fold_left (fun (u,d) s ->
+ let u',d' = computeDeepUseDefStmtKind s.skind in
+ (VS.union u u', VS.union d d')) (VS.empty, VS.empty)
+ b.bstmts
+ in
+ varUsed := acc_used;
+ varDefs := acc_defs;
+ let ve e = ignore (visitCilExpr useDefVisitor e) in
+ match sk with
+ Return (None, _) -> !varUsed, !varDefs
+ | Return (Some e, _) ->
+ let _ = ve e in
+ !varUsed, !varDefs
+ | If (e, tb, fb, _) ->
+ let _ = ve e in
+ let u, d = !varUsed, !varDefs in
+ let u', d' = handle_block tb in
+ let u'', d'' = handle_block fb in
+ (VS.union (VS.union u u') u'', VS.union (VS.union d d') d'')
+ | Break _ | Goto _ | Continue _ -> !varUsed, !varDefs
+ | Loop (b, _, _, _) -> handle_block b
+ | Switch (e, b, _, _) ->
+ let _ = ve e in
+ let u, d = !varUsed, !varDefs in
+ let u', d' = handle_block b in
+ (VS.union u u', VS.union d d')
+ | Instr il ->
+ List.iter (fun i -> ignore (visitCilInstr useDefVisitor i)) il;
+ !varUsed, !varDefs
+ | TryExcept _ | TryFinally _ -> !varUsed, !varDefs
+ | Block b -> handle_block b
+
+let computeUseLocalTypes ?(acc_used=VS.empty)
+ (fd : fundec)
+ =
+ List.fold_left (fun u vi ->
+ ignore(visitCilType useDefVisitor vi.vtype);
+ VS.union u (!varUsed)) acc_used fd.slocals
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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 Pretty
+open Trace (* sm: 'trace' function *)
+module E = Errormsg
+module H = Hashtbl
+
+let noMemoize = ref false
+
+let expMemoTable :
+ (string, (((string * formatArg) list -> exp) *
+ (exp -> formatArg list option))) H.t = H.create 23
+
+let typeMemoTable :
+ (string, (((string * formatArg) list -> typ) *
+ (typ -> formatArg list option))) H.t = H.create 23
+
+let lvalMemoTable :
+ (string, (((string * formatArg) list -> lval) *
+ (lval -> formatArg list option))) H.t = H.create 23
+
+let instrMemoTable :
+ (string, ((location -> (string * formatArg) list -> instr) *
+ (instr -> formatArg list option))) H.t = H.create 23
+
+let stmtMemoTable :
+ (string, ((string -> typ -> varinfo) ->
+ location ->
+ (string * formatArg) list -> stmt)) H.t = H.create 23
+
+let stmtsMemoTable :
+ (string, ((string -> typ -> varinfo) ->
+ location ->
+ (string * formatArg) list -> stmt list)) H.t = H.create 23
+
+
+let doParse (prog: string)
+ (theParser: (Lexing.lexbuf -> Formatparse.token)
+ -> Lexing.lexbuf -> '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
+ try
+ Formatparse.initialize Formatlex.initial lexbuf;
+ let res = theParser Formatlex.initial lexbuf in
+ H.add memoTable prog res;
+ Formatlex.finish ();
+ res
+ with Parsing.Parse_error -> begin
+ Formatlex.finish ();
+ E.s (E.error "Parsing error: %s" prog)
+ end
+ | e -> begin
+ ignore (E.log "Caught %s while parsing\n" (Printexc.to_string e));
+ Formatlex.finish ();
+ raise e
+ end
+ end
+
+
+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 cf = doParse prog Formatparse.lval lvalMemoTable in
+ (fst cf)
+
+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 cf = doParse prog Formatparse.instr instrMemoTable in
+ (fst cf)
+
+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 cf = doParse prog Formatparse.stmt_list stmtsMemoTable in
+ cf
+
+
+
+(* Match an expression *)
+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 df = doParse prog Formatparse.lval lvalMemoTable in
+ (snd df)
+
+
+(* Match a type *)
+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 df = doParse prog Formatparse.instr instrMemoTable in
+ (snd df)
+
+
+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"
+ (TPtr(TFun(intType, None, false, []), [])) in
+ (* Construct an instruction *)
+ 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))),
+ NoOffset),
+ [ ], 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)
+ ();
+ (* Now make the instruction interpreted *)
+ noMemoize := true;
+ Stats.time "make instruction interpreted"
+ (fun _ -> for i = 0 to times do
+ let _ =
+ cInstr "%v:res = (* ((int * (*)(int, int * a2, int * * a3))%v:fptr))();"
+ locUnknown [ ("res", Fv res);
+ ("fptr", Fv fptr) ]
+ in
+ ()
+ done)
+ ();
+ (* Now make the instruction interpreted with memoization *)
+ noMemoize := false;
+ Stats.time "make instruction interpreted memoized"
+ (fun _ -> for i = 0 to times do
+ let _ =
+ cInstr "%v:res = (* ((int * (*)(int, int * a2, int * * a3))%v:fptr))();"
+ locUnknown [ ("res", Fv res); ("fptr", Fv fptr) ]
+ in
+ ()
+ done)
+ ();
+ (* Now make the instruction interpreted with partial application *)
+ 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 _ =
+ partInstr
+ locUnknown [ ("res", Fv res); ("fptr", Fv fptr) ]
+ in
+ ()
+ done)
+ ();
+
+ ()
+
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+
+(** An Interpreter for constructing CIL constructs *)
+
+
+(** Constructs an expression based on the program and the list of arguments.
+ * Each argument consists of a name followed by the actual data. This
+ * argument will be placed instead of occurrences of "%v:name" in the pattern
+ * (where the "v" is dependent on the type of the data). The parsing of the
+ * string is memoized. * Only the first expression is parsed. *)
+val cExp: string -> (string * Cil.formatArg) list -> Cil.exp
+
+(** Constructs an lval based on the program and the list of arguments.
+ * Only the first lvalue is parsed.
+ * The parsing of the string is memoized. *)
+val cLval: string -> (string * Cil.formatArg) list -> Cil.lval
+
+(** Constructs a type based on the program and the list of arguments.
+ * Only the first type is parsed.
+ * The parsing of the string is memoized. *)
+val cType: string -> (string * Cil.formatArg) list -> Cil.typ
+
+
+(** Constructs an instruction based on the program and the list of arguments.
+ * Only the first instruction is parsed.
+ * The parsing of the string is memoized. *)
+val cInstr: string -> Cil.location ->
+ (string * Cil.formatArg) list -> Cil.instr
+
+(* Constructs a statement based on the program and the list of arguments. We
+ * also pass a function that can be used to make new varinfo's for the
+ * declared variables, and a location to be used for the statements. Only the
+ * first statement is parsed. The parsing of the string is memoized. *)
+val cStmt: string ->
+ (string -> Cil.typ -> Cil.varinfo) ->
+ Cil.location -> (string * Cil.formatArg) list -> Cil.stmt
+
+(** Constructs a list of statements *)
+val cStmts: string ->
+ (string -> Cil.typ -> Cil.varinfo) ->
+ Cil.location -> (string * Cil.formatArg) list ->
+ Cil.stmt list
+
+(** Deconstructs an expression based on the program. Produces an optional
+ * list of format arguments. The parsing of the string is memoized. *)
+val dExp: string -> Cil.exp -> Cil.formatArg list option
+
+(** Deconstructs an lval based on the program. Produces an optional
+ * list of format arguments. The parsing of the string is memoized. *)
+val dLval: string -> Cil.lval -> Cil.formatArg list option
+
+
+(** Deconstructs a type based on the program. Produces an optional list of
+ * format arguments. The parsing of the string is memoized. *)
+val dType: string -> Cil.typ -> Cil.formatArg list option
+
+
+(** Deconstructs an instruction based on the program. Produces an optional
+ * list of format arguments. The parsing of the string is memoized. *)
+val dInstr: string -> Cil.instr -> Cil.formatArg list option
+
+
+(** If set then will not memoize the parsed patterns *)
+val noMemoize: bool ref
+
+(** Just a testing function *)
+val test: unit -> unit
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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 lexical analyzer for constructing CIL based on format strings *)
+{
+open Formatparse
+exception Eof
+exception InternalError of string
+module H = Hashtbl
+module E = Errormsg
+(*
+** Keyword hashtable
+*)
+let keywords = H.create 211
+
+(*
+** Useful primitives
+*)
+let scan_ident id =
+ try H.find keywords id
+ with Not_found -> IDENT id (* default to variable name *)
+
+(*
+** Buffer processor
+*)
+
+
+let init ~(prog: string) : Lexing.lexbuf =
+ H.clear keywords;
+ Lexerhack.currentPattern := prog;
+ List.iter
+ (fun (key, token) -> H.add keywords key token)
+ [ ("const", CONST); ("__const", CONST); ("__const__", CONST);
+ ("static", STATIC);
+ ("extern", EXTERN);
+ ("long", LONG);
+ ("short", SHORT);
+ ("signed", SIGNED);
+ ("unsigned", UNSIGNED);
+ ("volatile", VOLATILE);
+ ("char", CHAR);
+ ("int", INT);
+ ("float", FLOAT);
+ ("double", DOUBLE);
+ ("void", VOID);
+ ("enum", ENUM);
+ ("struct", STRUCT);
+ ("typedef", TYPEDEF);
+ ("union", UNION);
+ ("break", BREAK);
+ ("continue", CONTINUE);
+ ("goto", GOTO);
+ ("return", RETURN);
+ ("switch", SWITCH);
+ ("case", CASE);
+ ("default", DEFAULT);
+ ("while", WHILE);
+ ("do", DO);
+ ("for", FOR);
+ ("if", IF);
+ ("else", ELSE);
+ ("__attribute__", ATTRIBUTE); ("__attribute", ATTRIBUTE);
+ ("__int64", INT64);
+ ("__builtin_va_arg", BUILTIN_VA_ARG);
+ ];
+ E.startParsingFromString prog
+
+let finish () =
+ E.finishParsing ()
+
+(*** Error handling ***)
+let error msg =
+ E.parse_error msg
+
+
+(*** escape character management ***)
+let scan_escape str =
+ match str with
+ "n" -> "\n"
+ | "r" -> "\r"
+ | "t" -> "\t"
+ | "b" -> "\b"
+ | "f" -> "\012" (* ASCII code 12 *)
+ | "v" -> "\011" (* ASCII code 11 *)
+ | "a" -> "\007" (* ASCII code 7 *)
+ | "e" -> "\027" (* ASCII code 27. This is a GCC extension *)
+ | _ -> str
+
+let get_value chr =
+ match chr with
+ '0'..'9' -> (Char.code chr) - (Char.code '0')
+ | 'a'..'z' -> (Char.code chr) - (Char.code 'a') + 10
+ | 'A'..'Z' -> (Char.code chr) - (Char.code 'A') + 10
+ | _ -> 0
+let scan_hex_escape str =
+ String.make 1 (Char.chr (
+ (get_value (String.get str 0)) * 16
+ + (get_value (String.get str 1))
+ ))
+let scan_oct_escape str =
+ (* weimer: wide-character constants like L'\400' may be bigger than
+ * 256 (in fact, may be up to 511), so Char.chr cannot be used directly *)
+ let the_value = (get_value (String.get str 0)) * 64
+ + (get_value (String.get str 1)) * 8
+ + (get_value (String.get str 2)) in
+ if the_value < 256 then String.make 1 (Char.chr the_value )
+ else (String.make 1 (Char.chr (the_value / 256))) ^
+ (String.make 1 (Char.chr (the_value mod 256)))
+
+(* 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" *)
+let wbtowc wstr =
+ let len = String.length wstr in
+ let dest = String.make (len * 2) '\000' in
+ for i = 0 to len-1 do
+ dest.[i*2] <- wstr.[i] ;
+ done ;
+ dest
+
+(* This function converst the "Hi" in L"Hi" to { L'H', L'i', L'\0' } *)
+let wstr_to_warray wstr =
+ let len = String.length wstr in
+ let res = ref "{ " in
+ for i = 0 to len-1 do
+ res := !res ^ (Printf.sprintf "L'%c', " wstr.[i])
+ done ;
+ res := !res ^ "}" ;
+ !res
+
+let getArgName (l: Lexing.lexbuf) (prefixlen: int) =
+ let lexeme = Lexing.lexeme l in
+ let ll = String.length lexeme in
+ if ll > prefixlen then
+ String.sub lexeme (prefixlen + 1) (ll - prefixlen - 1)
+ else
+ ""
+}
+
+let decdigit = ['0'-'9']
+let octdigit = ['0'-'7']
+let hexdigit = ['0'-'9' 'a'-'f' 'A'-'F']
+let letter = ['a'- 'z' 'A'-'Z']
+
+let floatsuffix = ['f' 'F' 'l' 'L']
+
+let usuffix = ['u' 'U']
+let lsuffix = "l"|"L"|"ll"|"LL"
+let intsuffix = lsuffix | usuffix | usuffix lsuffix | lsuffix usuffix
+
+let intnum = decdigit+ intsuffix?
+let octnum = '0' octdigit+ intsuffix?
+let hexnum = '0' ['x' 'X'] hexdigit+ intsuffix?
+
+let exponent = ['e' 'E']['+' '-']? decdigit+
+let fraction = '.' decdigit+
+let floatraw = (intnum? fraction)
+ |(intnum exponent)
+ |(intnum? fraction exponent)
+ |(intnum '.')
+ |(intnum '.' exponent)
+let floatnum = floatraw floatsuffix?
+
+let ident = (letter|'_')(letter|decdigit|'_')*
+let attribident = (letter|'_')(letter|decdigit|'_'|':')
+let blank = [' ' '\t' '\012' '\r']
+let escape = '\\' _
+let hex_escape = '\\' ['x' 'X'] hexdigit hexdigit
+let oct_escape = '\\' octdigit octdigit octdigit
+
+
+(* The arguments are of the form %l:foo *)
+let argname = ':' ident
+
+rule initial =
+ parse blank { initial lexbuf}
+| "/*" { let _ = comment lexbuf in
+ initial lexbuf}
+| "//" { endline lexbuf }
+| "\n" { E.newline (); initial lexbuf}
+| floatnum {CST_FLOAT (Lexing.lexeme lexbuf)}
+| hexnum {CST_INT (Lexing.lexeme lexbuf)}
+| octnum {CST_INT (Lexing.lexeme lexbuf)}
+| intnum {CST_INT (Lexing.lexeme lexbuf)}
+
+| "<<=" {INF_INF_EQ}
+| ">>=" {SUP_SUP_EQ}
+| "*=" {STAR_EQ}
+| "/=" {SLASH_EQ}
+| "&=" {AND_EQ}
+| "|=" {PIPE_EQ}
+| "^=" {CIRC_EQ}
+| "%=" {PERCENT_EQ}
+
+
+| "..." {ELLIPSIS}
+| "-=" {MINUS_EQ}
+| "+=" {PLUS_EQ}
+| "*=" {STAR_EQ}
+| "<<" {INF_INF}
+| ">>" {SUP_SUP}
+| "==" {EQ_EQ}
+| "!=" {EXCLAM_EQ}
+| "<=" {INF_EQ}
+| ">=" {SUP_EQ}
+| "=" {EQ}
+| "<" {INF}
+| ">" {SUP}
+| "++" {PLUS_PLUS}
+| "--" {MINUS_MINUS}
+| "->" {ARROW}
+| '+' {PLUS}
+| '-' {MINUS}
+| '*' {STAR}
+| '/' {SLASH}
+| '!' {EXCLAM}
+| '&' {AND}
+| '|' {PIPE}
+| '^' {CIRC}
+| '~' {TILDE}
+| '[' {LBRACKET}
+| ']' {RBRACKET}
+| '{' {LBRACE}
+| '}' {RBRACE}
+| '(' {LPAREN}
+| ')' {RPAREN}
+| ';' {SEMICOLON}
+| ',' {COMMA}
+| '.' {DOT}
+| ':' {COLON}
+| '?' {QUEST}
+| "sizeof" {SIZEOF}
+
+| "%eo" argname {ARG_eo (getArgName lexbuf 3) }
+| "%e" argname {ARG_e (getArgName lexbuf 2) }
+| "%E" argname {ARG_E (getArgName lexbuf 2) }
+| "%u" argname {ARG_u (getArgName lexbuf 2) }
+| "%b" argname {ARG_b (getArgName lexbuf 2) }
+| "%t" argname {ARG_t (getArgName lexbuf 2) }
+| "%d" argname {ARG_d (getArgName lexbuf 2) }
+| "%lo" argname {ARG_lo (getArgName lexbuf 3) }
+| "%l" argname {ARG_l (getArgName lexbuf 2) }
+| "%i" argname {ARG_i (getArgName lexbuf 2) }
+| "%I" argname {ARG_I (getArgName lexbuf 2) }
+| "%o" argname {ARG_o (getArgName lexbuf 2) }
+| "%va" argname {ARG_va (getArgName lexbuf 3) }
+| "%v" argname {ARG_v (getArgName lexbuf 2) }
+| "%k" argname {ARG_k (getArgName lexbuf 2) }
+| "%f" argname {ARG_f (getArgName lexbuf 2) }
+| "%F" argname {ARG_F (getArgName lexbuf 2) }
+| "%p" argname {ARG_p (getArgName lexbuf 2) }
+| "%P" argname {ARG_P (getArgName lexbuf 2) }
+| "%s" argname {ARG_s (getArgName lexbuf 2) }
+| "%S" argname {ARG_S (getArgName lexbuf 2) }
+| "%g" argname {ARG_g (getArgName lexbuf 2) }
+| "%A" argname {ARG_A (getArgName lexbuf 2) }
+| "%c" argname {ARG_c (getArgName lexbuf 2) }
+
+| '%' {PERCENT}
+| ident {scan_ident (Lexing.lexeme lexbuf)}
+| eof {EOF}
+| _ {E.parse_error
+ "Formatlex: Invalid symbol"
+ }
+
+and comment =
+ parse
+ "*/" { () }
+| '\n' { E.newline (); comment lexbuf }
+| _ { comment lexbuf }
+
+
+and endline = parse
+ '\n' { E.newline (); initial lexbuf}
+| _ { endline lexbuf}
--- /dev/null
+/*(* Parser for constructing CIL from format strings *)
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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 Pretty
+module E = Errormsg
+
+let parse_error msg : 'a = (* sm: c++-mode highlight hack: -> ' <- *)
+ E.hadErrors := true;
+ E.parse_error
+ msg
+
+
+let getArg (argname: string) (args: (string * formatArg) list) =
+ try
+ snd (List.find (fun (n, a) -> n = argname) args)
+ with _ ->
+ E.s (error "Pattern string %s does not have argument with name %s\n"
+ !Lexerhack.currentPattern argname)
+
+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 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))
+
+let buildPlus e1 e2 : exp =
+ let t1 = typeOf e1 in
+ if isPointerType t1 then
+ BinOp(PlusPI, e1, e2, t1)
+ else
+ BinOp(PlusA, e1, e2, t1)
+
+let buildMinus e1 e2 : exp =
+ let t1 = typeOf e1 in
+ let t2 = typeOf e2 in
+ if isPointerType t1 then
+ if isPointerType t2 then
+ BinOp(MinusPP, e1, e2, intType)
+ else
+ BinOp(MinusPI, e1, e2, t1)
+ 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 t1 = typeOf e1 in
+ BinOp(bop, e1, e2, t1)),
+
+ (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)
+ | _, _ -> None
+ end
+ | _ -> None))
+
+(* Check the equivalence of two format lists *)
+let rec checkSameFormat (fl1: formatArg list) (fl2: formatArg list) =
+ match fl1, fl2 with
+ [], [] -> true
+ | h1::t1, h2::t2 -> begin
+ let rec checkOffsetEq o1 o2 =
+ match o1, o2 with
+ NoOffset, NoOffset -> true
+ | Field(f1, o1'), Field(f2, o2') ->
+ f1.fname = f2.fname && checkOffsetEq o1' o2'
+ | Index(e1, o1'), Index(e2, o2') ->
+ checkOffsetEq o1' o2' && checkExpEq e1 e2
+ | _, _ -> false
+
+ 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, _) ->
+ uo1 = uo2 && checkExpEq e1 e2
+ | 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 =
+ match l1, l2 with
+ (Var v1, o1), (Var v2, o2) -> v1 == v2 && checkOffsetEq o1 o2
+ | (Mem e1, o1), (Mem e2, o2) ->
+ checkOffsetEq o1 o2 && checkExpEq e1 e2
+ | _, _ -> false
+ in
+ 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
+ | Fi i1, Fi i2 -> ignore (E.warn "checkSameFormat for Fi"); false
+ | Ft t1, Ft t2 -> typeSig t1 = typeSig t2
+ | Fl l1, Fl l2 -> checkLvalEq l1 l2
+ | Fo o1, Fo o2 -> checkOffsetEq o1 o2
+ | Fc c1, Fc c2 -> c1 == c2
+ | _, _ -> false
+ in
+ hdeq || checkSameFormat t1 t2
+ end
+ | _, _ -> false
+
+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 ->
+ (* Must check that m1 and m2 are the same *)
+ if checkSameFormat m1 m1' then
+ Some (m1 @ m2)
+ else
+ None
+ | _, _, _ -> None
+ end
+ | _ -> None)
+
+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
+ TComp(ci, _) -> begin
+ try
+ List.find (fun f -> fname = f.fname) ci.cfields
+ 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)
+
+
+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
+ TFloat(fk', _) when fk = fk' -> Some []
+ | _ -> None
+
+let doAttr (id: string)
+ (aargs: (((string * formatArg) list -> attrparam list) *
+ (attrparam list -> formatArg list option)) option)
+ =
+ let t = match aargs with
+ Some t -> t
+ | None -> (fun _ -> []),
+ (function [] -> Some [] | _ -> None)
+ in
+ ((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
+ Some _, _ -> acc (* We found one already *)
+ | None, Attr(id', args) when id = id' ->
+ (* Now match the arguments *)
+ (snd t) args
+ | None, _ -> acc)
+ None
+ attrs))
+
+
+type falist = formatArg list
+
+type maybeInit =
+ NoInit
+ | InitExp of exp
+ | InitCall of lval * exp list
+
+%}
+
+%token <string> IDENT
+%token <string> CST_CHAR
+%token <string> CST_INT
+%token <string> CST_FLOAT
+%token <string> CST_STRING
+%token <string> CST_WSTRING
+%token <string> NAMED_TYPE
+
+%token EOF
+%token CHAR INT DOUBLE FLOAT VOID INT64 INT32
+%token ENUM STRUCT TYPEDEF UNION
+%token SIGNED UNSIGNED LONG SHORT
+%token VOLATILE EXTERN STATIC CONST RESTRICT AUTO REGISTER
+
+%token <string> ARG_e ARG_eo ARG_E ARG_u ARG_b ARG_t ARG_d ARG_lo ARG_l ARG_i
+%token <string> ARG_o ARG_va ARG_f ARG_F ARG_A ARG_v ARG_k ARG_c ARG_d
+%token <string> ARG_s ARG_p ARG_P ARG_I ARG_S ARG_g
+
+%token SIZEOF ALIGNOF
+
+%token EQ
+%token ARROW DOT
+
+%token EQ_EQ EXCLAM_EQ INF SUP INF_EQ SUP_EQ
+%token MINUS_EQ PLUS_EQ STAR_EQ
+%token PLUS MINUS STAR SLASH PERCENT
+%token TILDE AND PIPE CIRC
+%token EXCLAM AND_AND PIPE_PIPE
+%token INF_INF SUP_SUP
+%token PLUS_PLUS MINUS_MINUS
+
+%token RPAREN LPAREN RBRACE LBRACE LBRACKET RBRACKET
+%token COLON SEMICOLON COMMA ELLIPSIS QUEST
+
+%token BREAK CONTINUE GOTO RETURN
+%token SWITCH CASE DEFAULT
+%token WHILE DO FOR
+%token IF THEN ELSE
+
+%token PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ
+%token AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ
+
+%token ATTRIBUTE INLINE ASM TYPEOF FUNCTION__ PRETTY_FUNCTION__ LABEL__
+%token BUILTIN_VA_ARG BUILTIN_VA_LIST
+%token BLOCKATTRIBUTE
+%token DECLSPEC
+%token <string> MSASM MSATTR
+%token PRAGMA
+
+
+/* operator precedence */
+%nonassoc IF
+%nonassoc ELSE
+
+
+%left COMMA
+
+ /*(* Set the following precedences higer than COMMA *)*/
+%nonassoc ARG_e ARG_d ARG_lo ARG_l ARG_i ARG_v ARG_I ARG_g
+%right EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ
+ AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ
+%right COLON
+%left PIPE_PIPE
+%left AND_AND
+%left ARG_b
+%left PIPE
+%left CIRC
+%left AND
+%left EQ_EQ EXCLAM_EQ
+%left INF SUP INF_EQ SUP_EQ
+%left INF_INF SUP_SUP
+%left PLUS MINUS
+%left STAR SLASH PERCENT CONST RESTRICT VOLATILE
+%right ARG_u EXCLAM TILDE PLUS_PLUS MINUS_MINUS CAST RPAREN ADDROF SIZEOF ALIGNOF
+%left LBRACKET
+%left DOT ARROW LPAREN LBRACE
+%nonassoc IDENT QUEST CST_INT
+
+%start initialize expression typename offset lval instr stmt stmt_list
+
+
+%type <unit> initialize
+%type <((string -> Cil.typ -> Cil.varinfo) -> Cil.location -> (string * Cil.formatArg) list -> Cil.stmt)> stmt
+%type <((string -> Cil.typ -> Cil.varinfo) -> Cil.location -> (string * Cil.formatArg) list -> Cil.stmt list)> stmt_list
+
+%type <((string * Cil.formatArg) list -> Cil.exp) * (Cil.exp -> Cil.formatArg list option)> expression
+
+%type <((string * Cil.formatArg) list -> Cil.exp) * (Cil.exp -> Cil.formatArg list option)> constant
+
+%type <((string * Cil.formatArg) list -> Cil.lval) * (Cil.lval -> Cil.formatArg list option)> lval
+
+%type <((string * Cil.formatArg) list -> Cil.typ) * (Cil.typ -> Cil.formatArg list option)> typename
+
+%type <(Cil.attributes -> (string * Cil.formatArg) list -> Cil.typ) * (Cil.typ -> Cil.formatArg list option)> type_spec
+
+%type <((string * Cil.formatArg) list -> (string * Cil.typ * Cil.attributes) list option * bool) * ((string * Cil.typ * Cil.attributes) list option * bool -> Cil.formatArg list option)> parameters
+
+
+%type <(Cil.location -> (string * Cil.formatArg) list -> Cil.instr) * (Cil.instr -> Cil.formatArg list option)> instr
+
+%type <(Cil.typ -> (string * Cil.formatArg) list -> Cil.offset) * (Cil.offset -> Cil.formatArg list option)> offset
+
+
+%%
+
+
+initialize:
+ /* empty */ { }
+;
+
+/* (*** Expressions ***) */
+
+
+expression:
+| ARG_e { (* Count arguments eagerly *)
+ let currentArg = $1 in
+ ((fun args ->
+ match getArg currentArg args with
+ Fe e -> e
+ | 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
+ | _ -> None))
+ }
+
+| SIZEOF expression
+ { ((fun args -> SizeOfE ((fst $2) args)),
+
+ 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
+ SizeOf t -> (snd $3) t
+ | _ -> None))
+ }
+
+| ALIGNOF expression
+ { ((fun args -> AlignOfE ((fst $2) args)),
+
+ (fun e -> match e with
+ AlignOfE e' -> (snd $2) e' | _ -> None))
+ }
+
+| ALIGNOF LPAREN typename RPAREN
+ { ((fun args -> AlignOf ((fst $3) args)),
+
+ (fun e -> match e with
+ AlignOf t' -> (snd $3) t' | _ -> None))
+ }
+
+| PLUS expression
+ { $2 }
+| MINUS expression
+ { doUnop Neg $2 }
+
+| EXCLAM expression
+ { doUnop LNot $2 }
+
+| TILDE expression
+ { doUnop BNot $2 }
+
+| argu expression %prec ARG_u
+ { ((fun args ->
+ let e = (fst $2) args in
+ UnOp((fst $1) args, e, typeOf e)),
+
+ (fun e -> match e with
+ UnOp(uo, e', _) -> begin
+ match (snd $1) uo, (snd $2) e' with
+ Some m1, Some m2 -> Some (m1 @ m2)
+ | _ -> None
+ end
+ | _ -> None))
+ }
+
+
+| AND expression %prec ADDROF
+ { ((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
+ AddrOf l -> (snd $2) (Lval l)
+ | e -> (snd $2) (Lval (mkMem e NoOffset))))
+ }
+
+| LPAREN expression RPAREN
+ { $2 }
+
+| expression PLUS expression
+ { ((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, _) ->
+ 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
+ let bop = (fst $2) args in
+ let e2 = (fst $3) args in
+ let t1 = typeOf e1 in
+ BinOp(bop, e1, e2, t1)),
+
+ (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 @ m2 @ m3)
+ | _, _, _ -> None
+ end
+ | _ -> None))
+ }
+
+| expression STAR expression
+ { doBinop Mult $1 $3 }
+| expression SLASH expression
+ { doBinop Div $1 $3 }
+| expression PERCENT expression
+ { doBinop Mod $1 $3 }
+| expression INF_INF expression
+ { doBinop Shiftlt $1 $3 }
+| expression SUP_SUP expression
+ { doBinop Shiftrt $1 $3 }
+| expression AND expression
+ { doBinop BAnd $1 $3 }
+| expression PIPE expression
+ { doBinop BOr $1 $3 }
+| expression CIRC expression
+ { doBinop BXor $1 $3 }
+| expression EQ_EQ expression
+ { doBinop Eq $1 $3 }
+| expression EXCLAM_EQ expression
+ { doBinop Ne $1 $3 }
+| expression INF expression
+ { doBinop Lt $1 $3 }
+| expression SUP expression
+ { doBinop Gt $1 $3 }
+| expression INF_EQ expression
+ { doBinop Le $1 $3 }
+| expression SUP_EQ expression
+ { doBinop Ge $1 $3 }
+
+| LPAREN typename RPAREN expression
+ { ((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
+ 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 *)*/
+argu :
+| ARG_u { let currentArg = $1 in
+ ((fun args ->
+ match getArg currentArg args with
+ Fu uo -> uo
+ | a -> wrongArgType currentArg "unnop" a),
+
+ fun uo -> Some [ Fu uo ])
+ }
+;
+
+argb :
+| ARG_b { let currentArg = $1 in
+ ((fun args ->
+ match getArg currentArg args with
+ Fb bo -> bo
+ | a -> wrongArgType currentArg "binop" a),
+
+ fun bo -> Some [ Fb bo ])
+ }
+;
+
+constant:
+| ARG_d { let currentArg = $1 in
+ ((fun args ->
+ match getArg currentArg args with
+ Fd n -> integer n
+ | a -> wrongArgType currentArg "integer" a),
+
+ fun e -> match e with
+ Const(CInt64(n, _, _)) ->
+ Some [ Fd (Int64.to_int n) ]
+ | _ -> None)
+ }
+
+| ARG_g { let currentArg = $1 in
+ ((fun args ->
+ match getArg currentArg args with
+ Fg s -> Const(CStr s)
+ | a -> wrongArgType currentArg "string" a),
+
+ fun e -> match e with
+ Const(CStr s) ->
+ Some [ Fg s ]
+ | _ -> None)
+ }
+| CST_INT { let n = parseInt $1 in
+ ((fun args -> n),
+
+ (fun e -> match e, n with
+ Const(CInt64(e', _, _)),
+ Const(CInt64(n', _, _)) when e' = n' -> Some []
+ | _ -> None))
+ }
+;
+
+
+/*(***************** LVALUES *******************)*/
+lval:
+| ARG_l { let currentArg = $1 in
+ ((fun args ->
+ match getArg currentArg args with
+ Fl l -> l
+ | Fv v -> Var v, NoOffset
+ | a -> wrongArgType currentArg "lval" a),
+
+ fun l -> Some [ Fl l ])
+ }
+
+| argv offset %prec ARG_v
+ { ((fun args ->
+ let v = (fst $1) args in
+ (Var v, (fst $2) v.vtype args)),
+
+ (fun l -> match l with
+ Var vi, off -> begin
+ 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),
+
+ (fun l -> match l with
+ Mem e, NoOffset -> (snd $2) e
+ | _, _ -> None))
+ }
+
+| expression ARROW IDENT offset
+ { ((fun args ->
+ let e = (fst $1) args in
+ 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))),
+
+ (fun l -> match l with
+ Mem e, Field(fi, off) when fi.fname = $3 -> begin
+ match (snd $1) e, (snd $4) off with
+ Some m1, Some m2 -> Some (m1 @ m2)
+ | _, _ -> None
+ end
+ | _, _ -> None))
+ }
+
+| LPAREN STAR expression RPAREN offset
+ { ((fun args ->
+ let e = (fst $3) args in
+ let baset =
+ match unrollTypeDeep (typeOf e) with
+ TPtr (t, _) -> t
+ | _ -> E.s (bug "Expecting a pointer\n")
+ in
+ mkMem e ((fst $5) baset args)),
+
+ (fun l -> match l with
+ Mem e, off -> begin
+ match (snd $3) e, (snd $5 off) with
+ Some m1, Some m2 -> Some (m1 @ m2)
+ | _, _ -> None
+ end
+ | _, _ -> None))
+ }
+ ;
+
+argv :
+| ARG_v { let currentArg = $1 in
+ ((fun args ->
+ match getArg currentArg args with
+ Fv v -> v
+ | a -> wrongArgType currentArg "varinfo" a),
+
+ fun v -> Some [ Fv v ])
+ }
+| IDENT { let currentArg = $1 in
+ ((fun args ->
+ match getArg currentArg args with
+ Fv v -> v
+ | a -> wrongArgType currentArg "varinfo" a),
+ (fun v ->
+ E.s (bug "identifiers (%s) are not supported for deconstruction" currentArg)))
+ }
+;
+
+
+/*(********** OFFSETS *************)*/
+offset:
+| ARG_o { let currentArg = $1 in
+ ((fun t args ->
+ match getArg currentArg args with
+ Fo o -> o
+ | a -> wrongArgType currentArg "offset" a),
+
+ (fun off -> Some [ Fo off ]))
+ }
+
+| /* empty */ { ((fun t args -> NoOffset),
+
+ (fun off -> match off with
+ NoOffset -> Some []
+ | _ -> None))
+ }
+
+| 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 ->
+ (snd $3) off'
+ | _ -> None))
+ }
+
+| LBRACKET expression RBRACKET offset
+ { ((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
+ Index(e, (fst $4) bt args)),
+
+ (fun off -> match off with
+ Index (e, off') -> begin
+ match (snd $2) e, (snd $4) off with
+ Some m1, Some m2 -> Some (m1 @ m2)
+ | _, _ -> None
+ end
+ | _ -> None))
+ }
+;
+
+
+/*(************ TYPES **************)*/
+typename: one_formal { ((fun args ->
+ let (_, ft, _) = (fst $1) args in
+ ft),
+
+ (fun t -> (snd $1) ("", t, [])))
+ }
+;
+
+one_formal:
+/*(* Do not allow attributes for the name *)*/
+| type_spec attributes decl
+ { ((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
+ Some (restt, m3) -> begin
+ match (snd $1) restt,
+ (snd $2) (typeAttrs restt)with
+ Some m1, Some m2 ->
+ Some (m1 @ m2 @ m3)
+ | _, _ -> None
+ end
+ | _ -> None))
+ }
+
+| ARG_f
+ { let currentArg = $1 in
+ ((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:
+| ARG_t { let currentArg = $1 in
+ ((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
+ TVoid _ -> Some []
+ | _ -> None)) }
+
+| ARG_k { let currentArg = $1 in
+ ((fun al args ->
+ match getArg currentArg args with
+ Fk ik -> TInt(ik, al)
+ | a -> wrongArgType currentArg "ikind" a),
+
+ (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)),
+ matchIntType IUChar) }
+
+| SHORT { ((fun al args -> TInt(IShort, al)),
+ matchIntType IShort) }
+| UNSIGNED SHORT { ((fun al args -> TInt(IUShort, al)),
+ matchIntType IUShort) }
+
+| 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)),
+ matchIntType ILong) }
+| UNSIGNED LONG { ((fun al args -> TInt(IULong, al)),
+ matchIntType IULong) }
+
+| LONG LONG { ((fun al args -> TInt(ILongLong, al)),
+
+ matchIntType ILongLong)
+ }
+| UNSIGNED LONG LONG { ((fun al args -> TInt(IULongLong, al)),
+
+ matchIntType IULongLong)
+ }
+
+| FLOAT { ((fun al args -> TFloat(FFloat, al)),
+ 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
+ Fc ci -> TComp(ci, al)
+ | a -> wrongArgType currentArg "compinfo" a),
+
+ (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
+ Fc ci -> TComp(ci, al)
+ | a -> wrongArgType currentArg "compinfo" a),
+
+ (fun t -> match unrollType t with
+ TComp(ci, _) -> Some [ Fc ci ]
+ | _ -> None))
+
+ }
+
+| 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 ->
+ let al = (fst $2) args in
+ (fst $3) (TPtr(ts, al)) args),
+
+ (fun (fn, ft) ->
+ match (snd $3) (fn, ft) with
+ Some (TPtr(bt, al), m2) -> begin
+ match (snd $2) al with
+ Some m1 -> Some (bt, m1 @ m2)
+ | _ -> None
+ end
+ | _ -> None))
+ }
+
+| direct_decl { $1 }
+;
+
+direct_decl:
+| /* empty */ { ((fun ts args -> ("", ts, [])),
+
+ (* Match any name in this case *)
+ (fun (fn, ft) ->
+ Some (unrollType ft, [])))
+ }
+
+| IDENT { ((fun ts args -> ($1, ts, [])),
+
+ (fun (fn, ft) ->
+ if fn = "" || fn = $1 then
+ Some (unrollType ft, [])
+ else
+ None))
+ }
+
+| 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
+ Some m1 -> Some (restt, m1 @ m2)
+ | _ -> None
+ end
+ | _ -> None
+ end))
+ }
+
+| direct_decl LBRACKET exp_opt RBRACKET
+ { ((fun ts args ->
+ (fst $1) (TArray(ts, (fst $3) args, [])) args),
+
+ (fun (fn, ft) ->
+ match (snd $1) (fn, ft) with
+ Some (TArray(bt, lo, _), m1) -> begin
+ match (snd $3) lo with
+ Some m2 -> Some (unrollType bt, m1 @ m2)
+ | _ -> None
+ end
+ | _ -> None))
+ }
+
+
+/*(* We use parentheses around the function to avoid conflicts *)*/
+| 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
+ Some (TFun(rt, args, isva, al), m1) -> begin
+ match (snd $2) al, (snd $6) (args, isva) with
+ Some m2, Some m6
+ -> Some (unrollType rt, m1 @ m2 @ m6)
+ | _ -> None
+ end
+ | _ -> None))
+ }
+;
+
+parameters:
+| /* empty */ { ((fun args -> (None, false)),
+
+ (* Match any formals *)
+ (fun (pars, isva) ->
+ match pars, isva with
+ (_, false) -> Some []
+ | _ -> None))
+ }
+
+| parameters_ne { ((fun args ->
+ let (pars : (string * typ * attributes) list),
+ (isva : bool) = (fst $1) args in
+ (Some pars), isva),
+
+ (function
+ ((Some pars), isva) -> (snd $1) (pars, isva)
+ | _ -> None))
+ }
+;
+parameters_ne:
+| ELLIPSIS
+ { ((fun args -> ([], true)),
+
+ (function
+ ([], true) -> Some []
+ | _ -> None))
+ }
+
+| ARG_va { let currentArg = $1 in
+ ((fun args ->
+ match getArg currentArg args with
+ Fva isva -> ([], isva)
+ | a -> wrongArgType currentArg "vararg" a),
+
+ (function
+ ([], isva) -> Some [ Fva isva ]
+ | _ -> None))
+ }
+
+| ARG_F { let currentArg = $1 in
+ ((fun args ->
+ match getArg currentArg args with
+ FF fl -> ( fl, false)
+ | a -> wrongArgType currentArg "formals" a),
+
+ (function
+ (pars, false) -> Some [ FF pars ]
+ | _ -> None))
+ }
+
+| one_formal { ((fun args -> ([(fst $1) args], false)),
+
+ (function
+ ([ f ], false) -> (snd $1) f
+ | _ -> None))
+ }
+
+
+| one_formal COMMA parameters_ne
+ { ((fun args ->
+ let this = (fst $1) args in
+ let (rest, isva) = (fst $3) args in
+ (this :: rest, isva)),
+
+ (function
+ ((f::rest, isva)) -> begin
+ match (snd $1) f, (snd $3) (rest, isva) with
+ Some m1, Some m2 -> Some (m1 @ m2)
+ | _, _ -> None
+ end
+ | _ -> None))
+ }
+;
+
+
+
+
+
+exp_opt:
+ /* empty */ { ((fun args -> None),
+ (* Match anything if the pattern does not have a len *)
+ (fun _ -> Some [])) }
+
+| expression { ((fun args -> Some ((fst $1) args)),
+
+ (fun lo -> match lo with
+ Some e -> (snd $1) e
+ | _ -> None))
+ }
+| ARG_eo { let currentArg = $1 in
+ ((fun args ->
+ match getArg currentArg args with
+ Feo lo -> lo
+ | a -> wrongArgType currentArg "exp_opt" a),
+
+ fun lo -> Some [ Feo lo ])
+ }
+;
+
+
+
+attributes:
+ /*(* Ignore other attributes *)*/
+ /* empty */ { ((fun args -> []),
+ (fun attrs -> Some [])) }
+
+| ARG_A { let currentArg = $1 in
+ ((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)),
+ (* Pass all the attributes down *)
+ (fun attrs ->
+ 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
+ { $4 }
+
+;
+
+
+attr:
+| IDENT
+ { doAttr $1 None }
+
+| IDENT LPAREN attr_args_ne RPAREN
+ { doAttr $1 (Some $3) }
+;
+
+attr_args_ne:
+ attr_arg { ((fun args -> [ (fst $1) args ]),
+
+ (fun aargs -> match aargs with
+ [ arg ] -> (snd $1) arg
+ | _ -> None))
+ }
+| attr_arg COMMA attr_args_ne { ((fun args ->
+ let this = (fst $1) args in
+ this :: ((fst $3) args)),
+
+ (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 ->
+ match getArg currentArg args with
+ FP al -> al
+ | a -> wrongArgType currentArg "attrparams" a),
+
+ (fun al -> Some [ FP al ]))
+ }
+;
+
+attr_arg:
+| IDENT { ((fun args -> ACons($1, [])),
+
+ (fun aarg -> match aarg with
+ ACons(id, []) when id = $1 -> Some []
+ | _ -> None))
+ }
+| IDENT LPAREN attr_args_ne RPAREN
+ { ((fun args -> ACons($1, (fst $3) args)),
+
+ (fun aarg -> match aarg with
+ ACons(id, args) when id = $1 ->
+ (snd $3) args
+ | _ -> None))
+ }
+| ARG_p { let currentArg = $1 in
+ ((fun args ->
+ match getArg currentArg args with
+ Fp p -> p
+ | a -> wrongArgType currentArg "attrparam" a),
+
+ (fun ap -> Some [ Fp ap]))
+ }
+
+;
+
+/* (********** INSTRUCTIONS ***********) */
+instr:
+| ARG_i SEMICOLON
+ { let currentArg = $1 in
+ ((fun loc args ->
+ match getArg currentArg args with
+ Fi i -> i
+ | a -> wrongArgType currentArg "instr" a),
+
+ (fun i -> Some [ Fi i]))
+ }
+
+| lval EQ expression SEMICOLON
+ { ((fun loc args ->
+ Set((fst $1) args, (fst $3) args, loc)),
+
+ (fun i -> match i with
+ Set (lv, e, l) -> begin
+ match (snd $1) lv, (snd $3) e with
+ Some m1, Some m2 -> Some (m1 @ m2)
+ | _, _ -> None
+ end
+ | _ -> None))
+ }
+
+| lval PLUS_EQ expression SEMICOLON
+ { ((fun loc args ->
+ let l = (fst $1) args in
+ Set(l, buildPlus (Lval l) ((fst $3) args), loc)),
+
+ matchBinopEq
+ (fun bop -> bop = PlusPI || bop = PlusA)
+ (snd $1) (snd $3))
+ }
+
+| lval MINUS_EQ expression SEMICOLON
+ { ((fun loc args ->
+ let l = (fst $1) args in
+ Set(l,
+ buildMinus (Lval l) ((fst $3) args), loc)),
+
+ matchBinopEq (fun bop -> bop = MinusA
+ || bop = MinusPP
+ || bop = MinusPI)
+ (snd $1) (snd $3))
+ }
+| lval STAR_EQ expression SEMICOLON
+ { doBinopEq Mult $1 $3 }
+
+| lval SLASH_EQ expression SEMICOLON
+ { doBinopEq Div $1 $3 }
+
+| lval PERCENT_EQ expression SEMICOLON
+ { doBinopEq Mod $1 $3 }
+
+| lval AND_EQ expression SEMICOLON
+ { doBinopEq BAnd $1 $3 }
+
+| lval PIPE_EQ expression SEMICOLON
+ { doBinopEq BOr $1 $3 }
+
+| lval CIRC_EQ expression SEMICOLON
+ { doBinopEq BXor $1 $3 }
+
+| lval INF_INF_EQ expression SEMICOLON
+ { doBinopEq Shiftlt $1 $3 }
+
+| 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
+ * into conflicts *)*/
+| lval EQ lval LPAREN arguments RPAREN SEMICOLON
+ { ((fun loc args ->
+ Call(Some ((fst $1) args), Lval ((fst $3) args),
+ (fst $5) args, loc)),
+
+ (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 @ m2 @ m3)
+ | _, _, _ -> None
+ end
+ | _ -> None))
+ }
+
+| lval LPAREN arguments RPAREN SEMICOLON
+ { ((fun loc args ->
+ Call(None, Lval ((fst $1) args),
+ (fst $3) args, loc)),
+
+ (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)
+ | _, _ -> None
+ end
+ | _ -> None))
+ }
+
+| 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
+ 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 @ m2 @ m3)
+ | _, _, _ -> None
+ end
+ | _ -> None))
+ }
+;
+
+/* (* Separate this out to ensure that the counting or arguments is right *)*/
+arglo:
+ ARG_lo { let currentArg = $1 in
+ ((fun args ->
+ let res =
+ match getArg currentArg args with
+ Flo x -> x
+ | a -> wrongArgType currentArg "lval option" a
+ in
+ res),
+
+ (fun lo -> Some [ Flo lo ]))
+ }
+;
+arguments:
+ /* empty */ { ((fun args -> []),
+
+ (fun actuals -> match actuals with
+ [] -> Some []
+ | _ -> None))
+ }
+
+| arguments_ne { $1 }
+;
+
+arguments_ne:
+ expression { ((fun args -> [ (fst $1) args ]),
+
+ (fun actuals -> match actuals with
+ [ h ] -> (snd $1) h
+ | _ -> None))
+ }
+
+| ARG_E { let currentArg = $1 in
+ ((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
+ h :: rest -> begin
+ match (snd $1) h, (snd $3) rest with
+ Some m1, Some m2 -> Some (m1 @ m2)
+ | _, _ -> None
+ end
+ | _ -> None))
+ }
+;
+
+
+/*(******** STATEMENTS *********)*/
+stmt:
+ IF LPAREN expression RPAREN stmt %prec IF
+ { (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,
+ 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)))
+ }
+| BREAK SEMICOLON
+ { (fun mkTemp loc args ->
+ mkStmt (Break loc))
+ }
+| CONTINUE SEMICOLON
+ { (fun mkTemp loc args ->
+ mkStmt (Continue loc))
+ }
+| 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 ->
+ let e = (fst $3) args in
+ let e =
+ if isPointerType(typeOf e) then
+ mkCast e !upointType
+ else e
+ in
+ mkStmt
+ (Loop (mkBlock [ mkStmt
+ (If(e,
+ mkBlock [],
+ mkBlock [ mkStmt
+ (Break loc) ],
+ loc));
+ $5 mkTemp loc args ],
+ loc, None, None)))
+ }
+| instr_list { (fun mkTemp loc args ->
+ mkStmt (Instr ($1 loc args)))
+ }
+| ARG_s { let currentArg = $1 in
+ (fun mkTemp loc args ->
+ match getArg currentArg args with
+ Fs s -> s
+ | a -> wrongArgType currentArg "stmt" a) }
+;
+
+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
+ | a -> wrongArgType currentArg "stmts" a)
+ }
+| 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 ->
+ let tal = (fst $2) args in
+ let ts = (fst $1) tal args in
+ let (n, t, _) = (fst $3) ts args in
+ let init = $4 args in
+ (* Before we proceed we must create the variable *)
+ 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
+ * front *)
+ match init with
+ NoInit -> rest
+ | InitExp e ->
+ mkStmtOneInstr (Set((Var v, NoOffset), e, loc))
+ :: rest
+ | InitCall (f, args) ->
+ 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
+ many instructions as possible *)*/
+ 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
+ | a -> wrongArgType currentArg "instrs" a)
+ }
+| instr instr_list
+ { (fun loc args ->
+ let this = (fst $1) loc args in
+ this :: ($2 loc args))
+ }
+;
+
+
+maybe_init:
+| { (fun args -> NoInit) }
+| EQ expression { (fun args -> InitExp ((fst $2) args)) }
+| EQ lval LPAREN arguments RPAREN
+ { (fun args ->
+ InitCall((fst $2) args, (fst $4) args)) }
+;
+%%
+
+
+
+
+
+
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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 file was originally part of Hugues Casee's frontc 2.0, and has been
+ * extensively changed since.
+**
+** 1.0 3.22.99 Hugues Cassé First version.
+** 2.0 George Necula 12/12/00: Many extensions
+ **)
+
+(*
+** Types
+*)
+
+type cabsloc = {
+ lineno : int;
+ filename: string;
+ byteno: int;
+ ident : int;
+}
+
+type typeSpecifier = (* Merge all specifiers into one type *)
+ Tvoid (* Type specifier ISO 6.7.2 *)
+ | Tchar
+ | Tshort
+ | Tint
+ | Tlong
+ | Tint64
+ | Tfloat
+ | Tdouble
+ | Tsigned
+ | Tunsigned
+ | Tnamed of string
+ (* each of the following three kinds of specifiers contains a field
+ * or item list iff it corresponds to a definition (as opposed to
+ * a forward declaration or simple reference to the type); they
+ * also have a list of __attribute__s that appeared between the
+ * keyword and the type name (definitions only) *)
+ | Tstruct of string * field_group list option * attribute list
+ | Tunion of string * field_group list option * attribute list
+ | Tenum of string * enum_item list option * attribute list
+ | TtypeofE of expression (* GCC __typeof__ *)
+ | TtypeofT of specifier * decl_type (* GCC __typeof__ *)
+
+and storage =
+ NO_STORAGE | AUTO | STATIC | EXTERN | REGISTER
+
+and funspec =
+ INLINE | VIRTUAL | EXPLICIT
+
+and cvspec =
+ CV_CONST | CV_VOLATILE | CV_RESTRICT
+
+(* Type specifier elements. These appear at the start of a declaration *)
+(* Everywhere they appear in this file, they appear as a 'spec_elem list', *)
+(* which is not interpreted by cabs -- rather, this "word soup" is passed *)
+(* on to the compiler. Thus, we can represent e.g. 'int long float x' even *)
+(* though the compiler will of course choke. *)
+and spec_elem =
+ SpecTypedef
+ | SpecCV of cvspec (* const/volatile *)
+ | SpecAttr of attribute (* __attribute__ *)
+ | SpecStorage of storage
+ | SpecInline
+ | SpecType of typeSpecifier
+ | SpecPattern of string (* specifier pattern variable *)
+
+(* decided to go ahead and replace 'spec_elem list' with specifier *)
+and specifier = spec_elem list
+
+
+(* Declarator type. They modify the base type given in the specifier. Keep
+ * them in the order as they are printed (this means that the top level
+ * constructor for ARRAY and PTR is the inner-level in the meaning of the
+ * declared type) *)
+and decl_type =
+ | JUSTBASE (* Prints the declared name *)
+ | PARENTYPE of attribute list * decl_type * attribute list
+ (* Prints "(attrs1 decl attrs2)".
+ * attrs2 are attributes of the
+ * declared identifier and it is as
+ * if they appeared at the very end
+ * of the declarator. attrs1 can
+ * contain attributes for the
+ * identifier or attributes for the
+ * enclosing type. *)
+ | ARRAY of decl_type * attribute list * expression
+ (* Prints "decl [ attrs exp ]".
+ * decl is never a PTR. *)
+ | PTR of attribute list * decl_type (* Prints "* attrs decl" *)
+ | PROTO of decl_type * single_name list * bool
+ (* Prints "decl (args[, ...])".
+ * decl is never a PTR.*)
+
+(* The base type and the storage are common to all names. Each name might
+ * contain type or storage modifiers *)
+(* e.g.: int x, y; *)
+and name_group = specifier * name list
+
+(* The optional expression is the bitfield *)
+and field_group = specifier * (name * expression option) list
+
+(* like name_group, except the declared variables are allowed to have initializers *)
+(* e.g.: int x=1, y=2; *)
+and init_name_group = specifier * init_name list
+
+(* The decl_type is in the order in which they are printed. Only the name of
+ * the declared identifier is pulled out. The attributes are those that are
+ * printed after the declarator *)
+(* e.g: in "int *x", "*x" is the declarator; "x" will be pulled out as *)
+(* the string, and decl_type will be PTR([], JUSTBASE) *)
+and name = string * decl_type * attribute list * cabsloc
+
+(* A variable declarator ("name") with an initializer *)
+and init_name = name * init_expression
+
+(* Single names are for declarations that cannot come in groups, like
+ * function parameters and functions *)
+and single_name = specifier * name
+
+
+and enum_item = string * expression * cabsloc
+
+(*
+** Declaration definition (at toplevel)
+*)
+and definition =
+ FUNDEF of single_name * block * cabsloc * cabsloc
+ | DECDEF of init_name_group * cabsloc (* global variable(s), or function prototype *)
+ | TYPEDEF of name_group * cabsloc
+ | ONLYTYPEDEF of specifier * cabsloc
+ | GLOBASM of string * cabsloc
+ | PRAGMA of expression * cabsloc
+ | LINKAGE of string * cabsloc * definition list (* extern "C" { ... } *)
+ (* toplevel form transformer, from the first definition to the *)
+ (* second group of definitions *)
+ | TRANSFORMER of definition * definition list * cabsloc
+ (* expression transformer: source and destination *)
+ | EXPRTRANSFORMER of expression * expression * cabsloc
+
+
+(* the string is a file name, and then the list of toplevel forms *)
+and file = string * definition list
+
+
+(*
+** statements
+*)
+
+(* A block contains a list of local label declarations ( GCC's ({ __label__
+ * l1, l2; ... }) ) , a list of definitions and a list of statements *)
+and block =
+ { blabels: string list;
+ battrs: attribute list;
+ bstmts: statement list
+ }
+
+(* GCC asm directives have lots of extra information to guide the optimizer *)
+and asm_details =
+ { aoutputs: (string option * string * expression) list; (* optional name, constraints and expressions for outputs *)
+ ainputs: (string option * string * expression) list; (* optional name, constraints and expressions for inputs *)
+ aclobbers: string list (* clobbered registers *)
+ }
+
+and statement =
+ NOP of cabsloc
+ | COMPUTATION of expression * cabsloc
+ | BLOCK of block * cabsloc
+ | SEQUENCE of statement * statement * cabsloc
+ | IF of expression * statement * statement * cabsloc
+ | WHILE of expression * statement * cabsloc
+ | DOWHILE of expression * statement * cabsloc
+ | FOR of for_clause * expression * expression * statement * cabsloc
+ | BREAK of cabsloc
+ | CONTINUE of cabsloc
+ | RETURN of expression * cabsloc
+ | SWITCH of expression * statement * cabsloc
+ | CASE of expression * statement * cabsloc
+ | CASERANGE of expression * expression * statement * cabsloc
+ | DEFAULT of statement * cabsloc
+ | LABEL of string * statement * cabsloc
+ | GOTO of string * cabsloc
+ | COMPGOTO of expression * cabsloc (* GCC's "goto *exp" *)
+ | DEFINITION of definition (*definition or declaration of a variable or type*)
+
+ | ASM of attribute list * (* typically only volatile and const *)
+ string list * (* template *)
+ asm_details option * (* extra details to guide GCC's optimizer *)
+ cabsloc
+
+ (** MS SEH *)
+ | TRY_EXCEPT of block * expression * block * cabsloc
+ | TRY_FINALLY of block * block * cabsloc
+
+and for_clause =
+ FC_EXP of expression
+ | FC_DECL of definition
+
+(*
+** Expressions
+*)
+and binary_operator =
+ ADD | SUB | MUL | DIV | MOD
+ | AND | OR
+ | BAND | BOR | XOR | SHL | SHR
+ | EQ | NE | LT | GT | LE | GE
+ | ASSIGN
+ | ADD_ASSIGN | SUB_ASSIGN | MUL_ASSIGN | DIV_ASSIGN | MOD_ASSIGN
+ | BAND_ASSIGN | BOR_ASSIGN | XOR_ASSIGN | SHL_ASSIGN | SHR_ASSIGN
+
+and unary_operator =
+ MINUS | PLUS | NOT | BNOT | MEMOF | ADDROF
+ | PREINCR | PREDECR | POSINCR | POSDECR
+
+and expression =
+ NOTHING
+ | UNARY of unary_operator * expression
+ | LABELADDR of string (* GCC's && Label *)
+ | BINARY of binary_operator * expression * expression
+ | QUESTION of expression * expression * expression
+
+ (* A CAST can actually be a constructor expression *)
+ | CAST of (specifier * decl_type) * init_expression
+
+ (* There is a special form of CALL in which the function called is
+ __builtin_va_arg and the second argument is sizeof(T). This
+ should be printed as just T *)
+ | CALL of expression * expression list
+ | COMMA of expression list
+ | CONSTANT of constant
+ | PAREN of expression
+ | VARIABLE of string
+ | EXPR_SIZEOF of expression
+ | TYPE_SIZEOF of specifier * decl_type
+ | EXPR_ALIGNOF of expression
+ | TYPE_ALIGNOF of specifier * decl_type
+ | INDEX of expression * expression
+ | MEMBEROF of expression * string
+ | MEMBEROFPTR of expression * string
+ | GNU_BODY of block
+ | EXPR_PATTERN of string (* pattern variable, and name *)
+
+and constant =
+ | CONST_INT of string (* the textual representation *)
+ | CONST_FLOAT of string (* the textual representaton *)
+ | CONST_CHAR of int64 list
+ | CONST_WCHAR of int64 list
+ | CONST_STRING of string
+ | CONST_WSTRING of int64 list
+ (* ww: wstrings are stored as an int64 list at this point because
+ * we might need to feed the wide characters piece-wise into an
+ * array initializer (e.g., wchar_t foo[] = L"E\xabcd";). If that
+ * doesn't happen we will convert it to an (escaped) string before
+ * passing it to Cil. *)
+
+and init_expression =
+ | NO_INIT
+ | SINGLE_INIT of expression
+ | COMPOUND_INIT of (initwhat * init_expression) list
+
+and initwhat =
+ NEXT_INIT
+ | INFIELD_INIT of string * initwhat
+ | ATINDEX_INIT of expression * initwhat
+ | ATINDEXRANGE_INIT of expression * expression
+
+
+ (* Each attribute has a name and some
+ * optional arguments *)
+and attribute = string * expression list
+
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(* Type check and elaborate ABS to CIL *)
+
+(* The references to ISO means ANSI/ISO 9899-1999 *)
+module A = Cabs
+module C = Cabshelper
+module V = Cabsvisit
+module E = Errormsg
+module H = Hashtbl
+module IH = Inthash
+module AL = Alpha
+
+open Cabs
+open Cabshelper
+open Pretty
+open Cil
+open Trace
+
+
+let mydebugfunction () =
+ E.s (error "mydebugfunction")
+
+let debugGlobal = false
+
+let continueOnError = true
+
+(** Turn on tranformation that forces correct parameter evaluation order *)
+let forceRLArgEval = ref false
+
+(** Leave a certain global alone. Use a negative number to disable. *)
+let nocil: int ref = ref (-1)
+
+(** Indicates whether we're allowed to duplicate small chunks. *)
+let allowDuplication: bool ref = ref true
+
+(** If false, the destination of a Call instruction should always have the
+ same type as the function's return type. Where needed, CIL will insert
+ a temporary to make this happen.
+
+ If true, the destination type may differ from the return type, so there
+ is an implicit cast. This is useful for analyses involving [malloc],
+ because the instruction "T* x = malloc(...);" won't be broken into
+ two instructions, so it's easy to find the allocation type.
+
+ This is false by default. Set to true to replicate the behavior
+ of CIL 1.3.5 and earlier.
+*)
+let doCollapseCallCast: bool ref = ref false
+
+(** Disables caching of globals during parsing. This is handy when we want
+ * to parse additional source files without hearing about confclits. *)
+let cacheGlobals: bool ref = ref true
+
+(** A hook into the code for processing typeof. *)
+let typeForTypeof: (Cil.typ -> Cil.typ) ref = ref (fun t -> t)
+
+(** A hook into the code that creates temporary local vars. By default this
+ is the identity function, but you can overwrite it if you need to change the
+ types of cabs2cil-introduced temp variables. *)
+let typeForInsertedVar: (Cil.typ -> Cil.typ) ref = ref (fun t -> t)
+
+(** 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)
+
+(** A hook into the code that remaps argument names in the appropriate
+ * attributes. *)
+let typeForCombinedArg: ((string, string) H.t -> typ -> typ) ref =
+ ref (fun _ t -> t)
+
+(** A hook into the code that remaps argument names in the appropriate
+ * attributes. *)
+let attrsForCombinedArg: ((string, string) H.t ->
+ attributes -> attributes) ref =
+ ref (fun _ t -> t)
+
+(* ---------- source error message handling ------------- *)
+let lu = locUnknown
+let cabslu = {lineno = -10;
+ filename = "cabs lu";
+ byteno = -10;
+ ident = 0;}
+
+
+(** Interface to the Cprint printer *)
+let withCprint (f: 'a -> unit) (x: 'a) : unit =
+ Cprint.commit (); Cprint.flush ();
+ let old = !Cprint.out in
+ Cprint.out := !E.logChannel;
+ f x;
+ Cprint.commit (); Cprint.flush ();
+ flush !Cprint.out;
+ Cprint.out := old
+
+
+(** Keep a list of the variable ID for the variables that were created to
+ * hold the result of function calls *)
+let callTempVars: unit IH.t = IH.create 13
+
+(* Keep a list of functions that were called without a prototype. *)
+let noProtoFunctions : bool IH.t = IH.create 13
+
+(* Check that s starts with the prefix p *)
+let prefix p s =
+ let lp = String.length p in
+ let ls = String.length s in
+ lp <= ls && String.sub s 0 lp = p
+
+(***** COMPUTED GOTO ************)
+
+(* The address of labels are small integers (starting from 0). A computed
+ * goto is replaced with a switch on the address of the label. We generate
+ * only one such switch and we'll jump to it from all computed gotos. To
+ * accomplish this we'll add a local variable to store the target of the
+ * goto. *)
+
+(* The local variable in which to put the detination of the goto and the
+ * statement where to jump *)
+let gotoTargetData: (varinfo * stmt) option ref = ref None
+
+(* The "addresses" of labels *)
+let gotoTargetHash: (string, int) H.t = H.create 13
+let gotoTargetNextAddr: int ref = ref 0
+
+
+(********** TRANSPARENT UNION ******)
+(* Check if a type is a transparent union, and return the first field if it
+ * is *)
+let isTransparentUnion (t: typ) : fieldinfo option =
+ match unrollType t with
+ TComp (comp, _) when not comp.cstruct ->
+ (* Turn transparent unions into the type of their first field *)
+ if hasAttribute "transparent_union" (typeAttrs t) then begin
+ match comp.cfields with
+ f :: _ -> Some f
+ | _ -> E.s (unimp "Empty transparent union: %s" (compFullName comp))
+ end else
+ None
+ | _ -> None
+
+(* When we process an argument list, remember the argument index which has a
+ * transparent union type, along with the original type. We need this to
+ * process function definitions *)
+let transparentUnionArgs : (int * typ) list ref = ref []
+
+let debugLoc = false
+let convLoc (l : cabsloc) =
+ if debugLoc then
+ ignore (E.log "convLoc at %s: line %d, btye %d\n" l.filename l.lineno l.byteno);
+ {line = l.lineno; file = l.filename; byte = l.byteno;}
+
+
+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"
+ else n = "__builtin_va_alist_t"
+
+let isVariadicListType t =
+ match unrollType t with
+ | TBuiltin_va_list _ -> true
+ | _ -> false
+
+(* Weimer
+ * multi-character character constants
+ * In MSCV, this code works:
+ *
+ * long l1 = 'abcd'; // note single quotes
+ * char * s = "dcba";
+ * long * lptr = ( long * )s;
+ * long l2 = *lptr;
+ * assert(l1 == l2);
+ *
+ * We need to change a multi-character character literal into the
+ * appropriate integer constant. However, the plot sickens: we
+ * must also be able to handle things like 'ab\nd' (value = * "d\nba")
+ * and 'abc' (vale = *"cba").
+ *
+ * First we convert 'AB\nD' into the list [ 65 ; 66 ; 10 ; 68 ], then we
+ * multiply and add to get the desired value.
+ *)
+
+(* Given a character constant (like 'a' or 'abc') as a list of 64-bit
+ * values, turn it into a CIL constant. Multi-character constants are
+ * treated as multi-digit numbers with radix given by the bit width of
+ * the specified type (either char or wchar_t). *)
+let reduce_multichar typ : int64 list -> int64 =
+ let radix = bitsSizeOf typ in
+ List.fold_left
+ (fun acc -> Int64.add (Int64.shift_left acc radix))
+ Int64.zero
+
+let interpret_character_constant char_list =
+ let value = reduce_multichar charType char_list in
+ if value < (Int64.of_int 256) then
+ (* ISO C 6.4.4.4.10: single-character constants have type int *)
+ (CChr(Char.chr (Int64.to_int value))), intType
+ else begin
+ let orig_rep = None (* Some("'" ^ (String.escaped str) ^ "'") *) in
+ if value <= (Int64.of_int32 Int32.max_int) then
+ (CInt64(value,IULong,orig_rep)),(TInt(IULong,[]))
+ else
+ (CInt64(value,IULongLong,orig_rep)),(TInt(IULongLong,[]))
+ end
+
+(*** EXPRESSIONS *************)
+
+ (* We collect here the program *)
+let theFile : global list ref = ref []
+let theFileTypes : global list ref = ref []
+
+let initGlobals () = theFile := []; theFileTypes := []
+
+
+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
+ * initializer *)
+let mustTurnIntoDef: bool IH.t = IH.create 117
+
+(* Globals that have already been defined. Indexed by the variable name. *)
+let alreadyDefined: (string, location) H.t = H.create 117
+
+(* Globals that were created due to static local variables. We chose their
+ * names to be distinct from any global encountered at the time. But we might
+ * see a global with conflicting name later in the file. *)
+let staticLocals: (string, varinfo) H.t = H.create 13
+
+
+(* Typedefs. We chose their names to be distinct from any global encounterd
+ * at the time. But we might see a global with conflicting name later in the
+ * file *)
+let typedefs: (string, typeinfo) H.t = H.create 13
+
+let popGlobals () =
+ let rec revonto (tail: global list) = function
+ [] -> tail
+
+ | GVarDecl (vi, l) :: rest
+ when vi.vstorage != Extern && IH.mem mustTurnIntoDef vi.vid ->
+ IH.remove mustTurnIntoDef vi.vid;
+ revonto (GVar (vi, {init = None}, l) :: tail) rest
+
+ | x :: rest -> revonto (x :: tail) rest
+ in
+ revonto (revonto [] !theFile) !theFileTypes
+
+
+(********* ENVIRONMENTS ***************)
+
+(* The environment is kept in two distinct data structures. A hash table maps
+ * each original variable name into a varinfo (for variables, or an
+ * enumeration tag, or a type). (Note that the varinfo might contain an
+ * alpha-converted name different from that of the lookup name.) The Ocaml
+ * hash tables can keep multiple mappings for a single key. Each time the
+ * last mapping is returned and upon deletion the old mapping is restored. To
+ * keep track of local scopes we also maintain a list of scopes (represented
+ * as lists). *)
+type envdata =
+ EnvVar of varinfo (* The name refers to a variable
+ * (which could also be a function) *)
+ | EnvEnum of exp * typ (* The name refers to an enumeration
+ * tag for which we know the value
+ * and the host type *)
+ | EnvTyp of typ (* The name is of the form "struct
+ * foo", or "union foo" or "enum foo"
+ * and refers to a type. Note that
+ * the name of the actual type might
+ * be different from foo due to alpha
+ * conversion *)
+ | EnvLabel of string (* The name refers to a label. This
+ * is useful for GCC's locally
+ * declared labels. The lookup name
+ * for this category is "label foo" *)
+
+let env : (string, envdata * location) H.t = H.create 307
+(* We also keep a global environment. This is always a subset of the env *)
+let genv : (string, envdata * location) H.t = H.create 307
+
+ (* In the scope we keep the original name, so we can remove them from the
+ * hash table easily *)
+type undoScope =
+ UndoRemoveFromEnv of string
+ | UndoResetAlphaCounter of location AL.alphaTableData ref *
+ location AL.alphaTableData
+ | UndoRemoveFromAlphaTable of string
+
+let scopes : undoScope list ref list ref = ref []
+
+let isAtTopLevel () =
+ !scopes = []
+
+
+(* When you add to env, you also add it to the current scope *)
+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
+ * name to the scope *)
+ (match !scopes with
+ [] -> begin
+ match d with
+ EnvVar _ ->
+ E.s (E.bug "addLocalToEnv: not in a scope when adding %s!" n)
+ | _ -> () (* We might add types *)
+ end
+ | s :: _ ->
+ s := (UndoRemoveFromEnv n) :: !s)
+
+
+let addGlobalToEnv (k: string) (d: envdata) : unit =
+(* ignore (E.log "%a: adding global %s to env\n" d_loc !currentLoc k); *)
+ H.add env k (d, !currentLoc);
+ (* 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
+ * version without suffix has been used. *)
+let alphaTable : (string, location AL.alphaTableData ref) H.t = H.create 307
+ (* vars and enum tags. For composite types we have names like "struct
+ * foo" or "union bar" *)
+
+(* To keep different name scopes different, we add prefixes to names
+ * specifying the kind of name: the kind can be one of "" for variables or
+ * enum tags, "struct" for structures and unions (they share the name space),
+ * "enum" for enumerations, or "type" for types *)
+let kindPlusName (kind: string)
+ (origname: string) : string =
+ if kind = "" then origname else
+ kind ^ " " ^ origname
+
+
+let stripKind (kind: string) (kindplusname: string) : string =
+ let l = 1 + String.length kind in
+ if l > 1 then
+ String.sub kindplusname l (String.length kindplusname - l)
+ else
+ kindplusname
+
+let newAlphaName (globalscope: bool) (* The name should have global scope *)
+ (kind: string)
+ (origname: string) : string * location =
+ let lookupname = kindPlusName kind origname in
+ (* If we are in a scope then it means that we are alpha-converting a local
+ * name. Go and add stuff to reset the state of the alpha table but only to
+ * the top-most scope (that of the enclosing function) *)
+ let rec findEnclosingFun = function
+ [] -> (* At global scope *)()
+ | [s] -> begin
+ let prefix = AL.getAlphaPrefix lookupname in
+ try
+ let countref = H.find alphaTable prefix in
+ s := (UndoResetAlphaCounter (countref, !countref)) :: !s
+ with Not_found ->
+ s := (UndoRemoveFromAlphaTable prefix) :: !s
+ end
+ | _ :: rest -> findEnclosingFun rest
+ in
+ if not globalscope then
+ findEnclosingFun !scopes;
+ let newname, oldloc =
+ AL.newAlphaName alphaTable None lookupname !currentLoc in
+ stripKind kind newname, oldloc
+
+
+
+
+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)
+ (if nullterm then [Char.chr 0] else [])
+
+(*** In order to process GNU_BODY expressions we must record that a given
+ *** COMPUTATION is interesting *)
+let gnu_body_result : (A.statement * ((exp * typ) option ref)) ref
+ = ref (A.NOP cabslu, ref None)
+
+(*** When we do statements we need to know the current return type *)
+let currentReturnType : typ ref = ref (TVoid([]))
+let currentFunctionFDEC: fundec ref = ref dummyFunDec
+
+
+let lastStructId = ref 0
+let anonStructName (k: string) (suggested: string) =
+ incr lastStructId;
+ "__anon" ^ k ^ (if suggested <> "" then "_" ^ suggested else "")
+ ^ "_" ^ (string_of_int (!lastStructId))
+
+
+let constrExprId = ref 0
+
+
+let startFile () =
+ H.clear env;
+ H.clear genv;
+ H.clear alphaTable;
+ lastStructId := 0
+
+
+
+let enterScope () =
+ scopes := (ref []) :: !scopes
+
+ (* Exit a scope and clean the environment. We do not yet delete from
+ * the name table *)
+let exitScope () =
+ let this, rest =
+ match !scopes with
+ car :: cdr -> car, cdr
+ | [] -> E.s (error "Not in a scope")
+ in
+ scopes := rest;
+ let rec loop = function
+ [] -> ()
+ | UndoRemoveFromEnv n :: t ->
+ H.remove env n; loop t
+ | UndoRemoveFromAlphaTable n :: t -> H.remove alphaTable n; loop t
+ | UndoResetAlphaCounter (vref, oldv) :: t ->
+ vref := oldv;
+ loop t
+ in
+ loop !this
+
+(* Lookup a variable name. Return also the location of the definition. Might
+ * raise Not_found *)
+let lookupVar (n: string) : varinfo * location =
+ match H.find env n with
+ (EnvVar vi), loc -> vi, loc
+ | _ -> raise Not_found
+
+
+let lookupGlobalVar (n: string) : varinfo * location =
+ match H.find genv n with
+ (EnvVar vi), loc -> vi, loc
+ | _ -> raise Not_found
+
+let docEnv () =
+ let acc : (string * (envdata * location)) list ref = ref [] in
+ let doone () = function
+ 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"
+ | EnvLabel l, _ -> text ("label " ^ l)
+ in
+ H.iter (fun k d -> acc := (k, d) :: !acc) env;
+ docList ~sep:line (fun (k, d) -> dprintf " %s -> %a" k doone d) () !acc
+
+
+
+(* Add a new variable. Do alpha-conversion if necessary *)
+let alphaConvertVarAndAddToEnv (addtoenv: bool) (vi: varinfo) : varinfo =
+(*
+ ignore (E.log "%t: alphaConvert(addtoenv=%b) %s" d_thisloc addtoenv vi.vname);
+*)
+ (* Announce the name to the alpha conversion table *)
+ let newname, oldloc = newAlphaName (addtoenv && vi.vglob) "" vi.vname in
+ (* Make a copy of the vi if the name has changed. Never change the name for
+ * global variables *)
+ let newvi =
+ if vi.vname = newname then
+ vi
+ else begin
+ if vi.vglob then begin
+ (* Perhaps this is because we have seen a static local which happened
+ * to get the name that we later want to use for a global. *)
+ try
+ let static_local_vi = H.find staticLocals vi.vname in
+ H.remove staticLocals vi.vname;
+ (* Use the new name for the static local *)
+ static_local_vi.vname <- newname;
+ (* And continue using the last one *)
+ vi
+ with Not_found -> begin
+ (* Or perhaps we have seen a typedef which stole our name. This is
+ possible because typedefs use the same name space *)
+ try
+ let typedef_ti = H.find typedefs vi.vname in
+ H.remove typedefs vi.vname;
+ (* Use the new name for the typedef instead *)
+ typedef_ti.tname <- newname;
+ (* And continue using the last name *)
+ vi
+ with Not_found ->
+ 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
+ * now. *)
+ copyVarinfo vi newname
+ end
+ end
+ in
+ (* Store all locals in the slocals (in reversed order). We'll reverse them
+ * and take out the formals at the end of the function *)
+ if not vi.vglob then
+ !currentFunctionFDEC.slocals <- newvi :: !currentFunctionFDEC.slocals;
+
+ (if addtoenv then
+ if vi.vglob then
+ addGlobalToEnv vi.vname (EnvVar newvi)
+ else
+ addLocalToEnv vi.vname (EnvVar newvi));
+(*
+ ignore (E.log " new=%s\n" newvi.vname);
+*)
+(* ignore (E.log "After adding %s alpha table is: %a\n"
+ newvi.vname docAlphaTable alphaTable); *)
+ newvi
+
+
+(* Strip the "const" from the type. It is unfortunate that const variables
+ * can only be set in initialization. Once we decided to move all
+ * declarations to the top of the functions, we have no way of setting a
+ * "const" variable. Furthermore, if the type of the variable is an array or
+ * a struct we must recursively strip the "const" from fields and array
+ * elements. *)
+let rec stripConstLocalType (t: typ) : typ =
+ let dc a =
+ if hasAttribute "const" a then
+ dropAttribute "const" a
+ else a
+ in
+ match t with
+ | TPtr (bt, a) ->
+ (* We want to be able to detect by pointer equality if the type has
+ * changed. So, don't realloc the type unless necessary. *)
+ let a' = dc a in if a != a' then TPtr(bt, a') else t
+ | TInt (ik, a) ->
+ let a' = dc a in if a != a' then TInt(ik, a') else t
+ | TFloat(fk, a) ->
+ let a' = dc a in if a != a' then TFloat(fk, a') else t
+ | TNamed (ti, a) ->
+ (* We must go and drop the consts from the typeinfo as well ! *)
+ let t' = stripConstLocalType ti.ttype in
+ if t != t' then begin
+ (* ignore (warn "Stripping \"const\" from typedef %s\n" ti.tname); *)
+ ti.ttype <- t'
+ end;
+ let a' = dc a in if a != a' then TNamed(ti, a') else t
+
+ | TEnum (ei, a) ->
+ let a' = dc a in if a != a' then TEnum(ei, a') else t
+
+ | TArray(bt, leno, a) ->
+ (* We never assign to the array. So, no need to change the const. But
+ * we must change it on the base type *)
+ let bt' = stripConstLocalType bt in
+ if bt' != bt then TArray(bt', leno, a) else t
+
+ | TComp(ci, a) ->
+ (* Must change both this structure as well as its fields *)
+ List.iter
+ (fun f ->
+ let t' = stripConstLocalType f.ftype in
+ if t' != f.ftype then begin
+ ignore (warnOpt "Stripping \"const\" from field %s of %s\n"
+ f.fname (compFullName ci));
+ f.ftype <- t'
+ end)
+ ci.cfields;
+ let a' = dc a in if a != a' then TComp(ci, a') else t
+
+ (* We never assign functions either *)
+ | TFun(rt, args, va, a) -> t
+ | TVoid a ->
+ let a' = dc a in if a != a' then TVoid a' else t
+ | 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 =
+ match t with
+ TArray(bt, Some len, a) ->
+ let len' = constFold true len in
+ ChangeDoChildrenPost (
+ TArray(bt, Some len', a),
+ (fun x -> x)
+ )
+ | _ -> DoChildren
+end
+
+(* Const-fold any expressions that appear as array lengths in this type *)
+let constFoldType (t:typ) : typ =
+ visitCilType constFoldTypeVisitor t
+
+let typeSigNoAttrs: typ -> typsig = typeSigWithAttrs (fun _ -> [])
+
+(* Create a new temporary variable *)
+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
+ (* Start with the name "tmp". The alpha converter will fix it *)
+ let vi = makeVarinfo false "tmp" t' in
+ vi.vdescr <- descr;
+ vi.vdescrpure <- descrpure;
+ alphaConvertVarAndAddToEnv false vi (* Do not add to the environment *)
+(*
+ { vname = "tmp"; (* addNewVar will make the name fresh *)
+ vid = newVarId "tmp" false;
+ vglob = false;
+ vtype = t';
+ vdecl = locUnknown;
+ vinline = false;
+ vattr = [];
+ vaddrof = false;
+ vreferenced = false; (* sm *)
+ vstorage = NoStorage;
+ }
+*)
+
+let mkAddrOfAndMark ((b, off) as lval) : exp =
+ (* Mark the vaddrof flag if b is a variable *)
+ (match b with
+ Var vi -> vi.vaddrof <- true
+ | _ -> ());
+ mkAddrOf lval
+
+(* Call only on arrays *)
+let mkStartOfAndMark ((b, off) as lval) : exp =
+ (* Mark the vaddrof flag if b is a variable *)
+ (match b with
+ Var vi -> vi.vaddrof <- true
+ | _ -> ());
+ let res = StartOf lval in
+ res
+
+
+
+ (* Keep a set of self compinfo for composite types *)
+let compInfoNameEnv : (string, compinfo) H.t = H.create 113
+let enumInfoNameEnv : (string, enuminfo) H.t = H.create 113
+
+
+let lookupTypeNoError (kind: string)
+ (n: string) : typ * location =
+ let kn = kindPlusName kind n in
+ match H.find env kn with
+ EnvTyp t, l -> t, l
+ | _ -> raise Not_found
+
+let lookupType (kind: string)
+ (n: string) : typ * location =
+ try
+ lookupTypeNoError kind n
+ with Not_found ->
+ E.s (error "Cannot find type %s (kind:%s)\n" n kind)
+
+(* Create the self ref cell and add it to the map. Return also an indication
+ * if this is a new one. *)
+let createCompInfo (iss: bool) (n: string) : compinfo * bool =
+ (* Add to the self cell set *)
+ let key = (if iss then "struct " else "union ") ^ n in
+ try
+ H.find compInfoNameEnv key, false (* Only if not already in *)
+ with Not_found -> begin
+ (* Create a compinfo. This will have "cdefined" false. *)
+ let res = mkCompInfo iss n (fun _ -> []) [] in
+ H.add compInfoNameEnv key res;
+ res, true
+ end
+
+(* Create the self ref cell and add it to the map. Return an indication
+ * whether this is a new one. *)
+let createEnumInfo (n: string) : 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 = [];
+ eattr = []; ereferenced = false; } in
+ H.add enumInfoNameEnv n enum;
+ enum, true
+ end
+
+
+ (* kind is either "struct" or "union" or "enum" and n is a name *)
+let findCompType (kind: string) (n: string) (a: attributes) =
+ let makeForward () =
+ (* This is a forward reference, either because we have not seen this
+ * struct already or because we want to create a version with different
+ * attributes *)
+ if kind = "enum" then
+ let enum, isnew = createEnumInfo n in
+ if isnew then
+ cabsPushGlobal (GEnumTagDecl (enum, !currentLoc));
+ TEnum (enum, a)
+ else
+ let iss = if kind = "struct" then true else false in
+ let self, isnew = createCompInfo iss n in
+ if isnew then
+ cabsPushGlobal (GCompTagDecl (self, !currentLoc));
+ TComp (self, a)
+ in
+ try
+ let old, _ = lookupTypeNoError kind n in (* already defined *)
+ 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
+ (pRes := false; SkipChildren)
+ else
+ if !pRes then DoChildren else SkipChildren
+
+ method vinst _ = SkipChildren
+ method vexpr _ = SkipChildren
+
+end
+let canDropStatement (s: stmt) : bool =
+ let pRes = ref true in
+ let vis = new canDropStmtClass pRes in
+ ignore (visitCilStmt vis s);
+ !pRes
+
+(**** Occasionally we see structs with no name and no fields *)
+
+
+module BlockChunk =
+ struct
+ type chunk = {
+ stmts: stmt list;
+ 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)
+ * visible at the outer level *)
+ }
+
+ 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 =
+ { stmts = []; postins = []; cases = []; }
+
+ let isEmpty (c: chunk) =
+ c.postins == [] && c.stmts == []
+
+ let isNotEmpty (c: chunk) = not (isEmpty c)
+
+ let i2c (i: instr) =
+ { empty with postins = [i] }
+
+ (* Occasionally, we'll have to push postins into the statements *)
+ let pushPostIns (c: chunk) : stmt list =
+ if c.postins = [] then c.stmts
+ else
+ let rec toLast = function
+ [{skind=Instr il} as s] as stmts ->
+ s.skind <- Instr (il @ (List.rev c.postins));
+ stmts
+
+ | [] -> [mkStmt (Instr (List.rev c.postins))]
+
+ | a :: rest -> a :: toLast rest
+ in
+ compactStmts (toLast c.stmts)
+
+
+ let c2block (c: chunk) : block =
+ { battrs = [];
+ bstmts = pushPostIns c;
+ }
+
+ (* 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
+ * this. And especially never share c2 with somebody else *)
+ 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 =
+ { stmts = [ mkStmt (Return(e, l)) ];
+ postins = [];
+ cases = []
+ }
+
+ 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
+ * it does not have cases *)
+ 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 =
+ List.map
+ (fun s ->
+ if s.labels != [] then
+ raise (Failure "cannot duplicate: has labels");
+ (match s.skind with
+ If _ | Switch _ | Loop _ | Block _ ->
+ raise (Failure "cannot duplicate: complex stmt")
+ | 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
+ * 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) =
+ 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 =
+ (* 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 =
+ { stmts = [ mkStmt (Break l) ];
+ postins = [];
+ cases = [];
+ }
+
+ 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 =
+ try
+ H.find backPatchGotos lname
+ with Not_found -> begin
+ let gotos = ref [] in
+ H.add backPatchGotos lname gotos;
+ gotos
+ end
+ in
+ gotos := bref :: !gotos
+
+ (* Keep track of the labels *)
+ let labelStmt : (string, stmt) H.t = H.create 17
+ let initLabels () =
+ H.clear backPatchGotos;
+ H.clear labelStmt
+
+ let resolveGotos () =
+ H.iter
+ (fun lname gotos ->
+ try
+ let dest = H.find labelStmt lname in
+ List.iter (fun gref -> gref := dest) !gotos
+ with Not_found -> begin
+ E.s (error "Label %s not found\n" lname)
+ end)
+ backPatchGotos
+
+ (* Get the first statement in a chunk. Might need to change the
+ * statements in the chunk *)
+ 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 =
+ (* 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;
+ H.add labelStmt l labstmt;
+ if c.stmts == stmts' then c else {c with stmts = stmts'}
+
+ let s2c (s:stmt) : chunk =
+ { stmts = [ s ];
+ postins = [];
+ cases = [];
+ }
+
+ let gotoChunk (ln: string) (l: location) : chunk =
+ let gref = ref dummyStmt in
+ addGoto ln gref;
+ { stmts = [ mkStmt (Goto (gref, l)) ];
+ postins = [];
+ cases = [];
+ }
+
+ let caseRangeChunk (el: exp list) (l: location) (next: chunk) =
+ let fst, stmts' = getFirstInChunk next in
+ let labels = List.map (fun e -> Case (e, l)) el in
+ fst.labels <- labels @ fst.labels;
+ { next with stmts = stmts'; cases = fst :: next.cases}
+
+ 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
+ let checkForDefault lb : unit =
+ match lb with
+ Default _ -> if !defaultSeen then
+ E.s (error "Switch statement at %a has duplicate default entries."
+ d_loc l);
+ defaultSeen := true
+ | _ -> ()
+ in
+ let cases = (* eliminate duplicate entries from body.cases.
+ A statement is added to body.cases for each case label
+ it has. *)
+ List.fold_right (fun s acc ->
+ if List.memq s acc then acc
+ else begin
+ List.iter checkForDefault s.labels;
+ s::acc
+ end)
+ body.cases
+ []
+ in
+ let switch = mkStmt (Switch (e, c2block body,
+ cases,
+ l)) in
+ { stmts = [ switch (* ; n *) ];
+ postins = [];
+ cases = [];
+ }
+
+ let mkFunctionBody (c: chunk) : block =
+ resolveGotos (); initLabels ();
+ if c.cases <> [] then
+ E.s (error "Switch cases not inside a switch statement\n");
+ c2block c
+
+ end
+
+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
+ * for a Non-while loop we must generate a label for the continue *)
+type loopstate =
+ While
+ | NotWhile of string ref
+
+let continues : loopstate list ref = ref []
+
+let startLoop iswhile =
+ continues := (if iswhile then While else NotWhile (ref "")) :: !continues
+
+(* Sometimes we need to create new label names *)
+let newLabelName (base: string) = fst (newAlphaName false "label" base)
+
+let continueOrLabelChunk (l: location) : chunk =
+ match !continues with
+ [] -> E.s (error "continue not in a loop")
+ | While :: _ -> continueChunk l
+ | NotWhile lr :: _ ->
+ if !lr = "" then begin
+ lr := newLabelName "__Cont"
+ end;
+ gotoChunk !lr l
+
+let consLabContinue (c: chunk) =
+ match !continues with
+ [] -> E.s (error "labContinue not in a loop")
+ | While :: rest -> c
+ | NotWhile lr :: rest -> if !lr = "" then c else consLabel !lr c !currentLoc false
+
+let exitLoop () =
+ 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
+ * table. *)
+ let l' = newLabelName l in
+ (* Add it to the environment *)
+ addLocalToEnv (kindPlusName "label" l) (EnvLabel l');
+ l'
+
+let lookupLabel (l: string) =
+ try
+ match H.find env (kindPlusName "label" l) with
+ EnvLabel l', _ -> l'
+ | _ -> raise Not_found
+ with Not_found ->
+ l
+
+
+(** ALLOCA ***)
+let allocaFun () =
+ if !msvcMode then begin
+ let name = "alloca" in
+ let fdec = emptyFunction name in
+ fdec.svar.vtype <-
+ TFun(voidPtrType, Some [ ("len", !typeOfSizeOf, []) ], false, []);
+ fdec.svar
+ end
+ else
+ (* Use __builtin_alloca where possible, because this can be used
+ even when gcc is invoked with -fno-builtin *)
+ let alloca, _ = lookupGlobalVar "__builtin_alloca" in
+ alloca
+
+(* Maps local variables that are variable sized arrays to the expression that
+ * denotes their length *)
+let varSizeArrays : exp IH.t = IH.create 17
+
+(**** EXP actions ***)
+type expAction =
+ ADrop (* Drop the result. Only the
+ * side-effect is interesting *)
+ | AType (* Only the type of the result
+ is interesting. *)
+ | ASet of 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
+ * sure. *)
+ | AExpLeaveArrayFun (* Do it like an expression, but do
+ * not convert arrays of functions
+ * into pointers *)
+
+
+(*** Result of compiling conditional expressions *)
+type condExpRes =
+ CEExp of chunk * exp (* Do a chunk and then an expression *)
+ | CEAnd of condExpRes * condExpRes
+ | CEOr of condExpRes * condExpRes
+ | CENot of condExpRes
+
+(******** CASTS *********)
+let integralPromotion (t : typ) : typ = (* c.f. ISO 6.3.1.1 *)
+ match unrollType t with
+ TInt ((IShort|IUShort|IChar|ISChar|IUChar), a) ->
+ if bitsSizeOf t < bitsSizeOf (TInt (IInt, [])) then
+ TInt(IInt, a)
+ else
+ TInt(IUInt, a)
+ | TInt _ -> t
+ | TEnum (_, a) -> TInt(IInt, a)
+ | t -> E.s (error "integralPromotion: not expecting %a" d_type t)
+
+
+let arithmeticConversion (* c.f. ISO 6.3.1.8 *)
+ (t1: typ)
+ (t2: typ) : typ =
+ let checkToInt _ = () in (* dummies for now *)
+ let checkToFloat _ = () in
+ match unrollType t1, unrollType t2 with
+ TFloat(FLongDouble, _), _ -> checkToFloat t2; t1
+ | _, TFloat(FLongDouble, _) -> checkToFloat t1; t2
+ | TFloat(FDouble, _), _ -> checkToFloat t2; t1
+ | _, TFloat (FDouble, _) -> checkToFloat t1; t2
+ | TFloat(FFloat, _), _ -> checkToFloat t2; t1
+ | _, TFloat (FFloat, _) -> checkToFloat t1; t2
+ | _, _ -> begin
+ let t1' = integralPromotion t1 in
+ let t2' = integralPromotion t2 in
+ match unrollType t1', unrollType t2' with
+ TInt(IULongLong, _), _ -> checkToInt t2'; t1'
+ | _, TInt(IULongLong, _) -> checkToInt t1'; t2'
+
+ (* We assume a long long is always larger than a long *)
+ | TInt(ILongLong, _), _ -> checkToInt t2'; t1'
+ | _, TInt(ILongLong, _) -> checkToInt t1'; t2'
+
+ | TInt(IULong, _), _ -> checkToInt t2'; t1'
+ | _, TInt(IULong, _) -> checkToInt t1'; t2'
+
+
+ | TInt(ILong,_), TInt(IUInt,_)
+ when bitsSizeOf t1' <= bitsSizeOf t2' -> TInt(IULong,[])
+ | TInt(IUInt,_), TInt(ILong,_)
+ when bitsSizeOf t2' <= bitsSizeOf t1' -> TInt(IULong,[])
+
+ | TInt(ILong, _), _ -> checkToInt t2'; t1'
+ | _, TInt(ILong, _) -> checkToInt t1'; t2'
+
+ | TInt(IUInt, _), _ -> checkToInt t2'; t1'
+ | _, TInt(IUInt, _) -> checkToInt t1'; t2'
+
+ | TInt(IInt, _), TInt (IInt, _) -> t1'
+
+ | _, _ -> E.s (error "arithmeticConversion")
+ 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
+ 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
+ * source. *)
+ (ot, e)
+ else begin
+ let nt' = unrollType nt in
+ 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
+
+ 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, nt' with
+ TNamed _, _
+ | _, TNamed _ -> E.s (bug "unrollType failed in castTo")
+ | TInt(ikindo,_), TInt(ikindn,_) ->
+ (* We used to ignore attributes on integer-integer casts. Not anymore *)
+ (* if ikindo = ikindn then (nt, e) else *)
+ result
+
+ | TPtr (told, _), TPtr(tnew, _) -> 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
+ | TFloat _, TFloat _ -> result
+ | TInt _, TEnum _ -> result
+ | TEnum _, TEnum _ -> result
+
+ | TEnum _, TPtr _ -> result
+ | 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 _ ->
+ ignore (warnOpt "Casting a pointer into an enumeration type");
+ result
+
+ (* The expression is evaluated for its side-effects *)
+ | (TInt _ | TEnum _ | TPtr _ ), TVoid _ ->
+ (ot, e)
+
+ (* Even casts between structs are allowed when we are only
+ * modifying some attributes *)
+ | 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
+ * that into a field access *)
+ | TComp(tunion, a1), nt -> begin
+ 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 ->
+ Lval (addOffsetLval (Field(fstfield, NoOffset)) lv)
+ | _ -> E.s (unimp "castTo: transparent union expression is not an lval: %a\n" d_exp e)
+ in
+ (* Continue casting *)
+ 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@!"
+ d_type ot'' d_type nt'')
+ end
+
+(* Like Cil.mkCastT, but it calls typeForInsertedCast *)
+let makeCastT ~(e: exp) ~(oldt: typ) ~(newt: typ) =
+ Cil.mkCastT e oldt (!typeForInsertedCast newt)
+
+let makeCast ~(e: exp) ~(newt: typ) =
+ makeCastT e (typeOf e) newt
+
+(* A cast that is used for conditional expressions. Pointers are Ok *)
+let checkBool (ot : typ) (e : exp) : bool =
+ match unrollType ot with
+ TInt _ -> true
+ | TPtr _ -> true
+ | TEnum _ -> true
+ | TFloat _ -> true
+ | _ -> E.s (error "castToBool %a" d_type ot)
+
+(* Given an expression that is being coerced to bool,
+ is it a nonzero constant? *)
+let rec isConstTrue (e:exp): bool =
+ match e with
+ | Const(CInt64 (n,_,_)) -> n <> Int64.zero
+ | Const(CChr c) -> 0 <> Char.code c
+ | Const(CStr _ | CWStr _) -> true
+ | Const(CReal(f, _, _)) -> f <> 0.0;
+ | CastE(_, e) -> isConstTrue e
+ | _ -> false
+
+(* Given an expression that is being coerced to bool, is it zero?
+ This is a more general version of Cil.isZero, which only handles integers.
+ On constant expressions, either isConstTrue or isConstFalse will hold. *)
+let rec isConstFalse (e:exp): bool =
+ match e with
+ | Const(CInt64 (n,_,_)) -> n = Int64.zero
+ | Const(CChr c) -> 0 = Char.code c
+ | Const(CReal(f, _, _)) -> f = 0.0;
+ | CastE(_, e) -> isConstFalse e
+ | _ -> false
+
+
+
+(* We have our own version of addAttributes that does not allow duplicates *)
+let cabsAddAttributes al0 (al: attributes) : attributes =
+ if al0 == [] then al else
+ List.fold_left
+ (fun acc (Attr(an, _) 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
+ acc (* Already in *)
+ else begin
+ addAttribute a acc (* Keep both attributes *)
+ end)
+ al
+ al0
+
+
+
+let cabsTypeAddAttributes a0 t =
+ begin
+ match a0 with
+ | [] ->
+ (* no attributes, keep same type *)
+ t
+ | _ ->
+ (* anything else: add a0 to existing attributes *)
+ let add (a: attributes) = cabsAddAttributes a0 a in
+ match t with
+ TVoid a -> TVoid (add a)
+ | TInt (ik, a) ->
+ (* Here we have to watch for the mode attribute *)
+(* sm: This stuff is to handle a GCC extension where you can request integers*)
+(* of specific widths using the "mode" attribute syntax; for example: *)
+(* typedef int int8_t __attribute__ ((__mode__ ( __QI__ ))) ; *)
+(* The cryptic "__QI__" defines int8_t to be 8 bits wide, instead of the *)
+(* 32 bits you'd guess if you didn't know about "mode". The relevant *)
+(* testcase is test/small2/mode_sizes.c, and it was inspired by my *)
+(* /usr/include/sys/types.h. *)
+(* *)
+(* A consequence of this handling is that we throw away the mode *)
+(* attribute, which we used to go out of our way to avoid printing anyway.*)
+(* DG: Use machine model to pick correct type *)
+ let ik', a0' =
+ (* Go over the list of new attributes and come back with a
+ * filtered list and a new integer kind *)
+ List.fold_left
+ (fun (ik', a0') a0one ->
+ match a0one with
+ Attr("mode", [ACons(mode,[])]) -> begin
+ (trace "gccwidth" (dprintf "I see mode %s applied to an int type\n"
+ mode (* #$@!#@ ML! d_type t *) ));
+ (* assuming int is the word size *)
+ try
+ let size = match stripUnderscores mode with
+ "byte" -> 1
+ | "word" -> !Machdep.theMachine.Machdep.sizeof_int
+ | "pointer" -> !Machdep.theMachine.Machdep.sizeof_ptr
+ | "QI" -> 1
+ | "HI" -> 2
+ | "SI" -> 4
+ | "DI" -> 8
+ | "TI" -> 16
+ | "OI" -> 32
+ | _ -> raise Not_found in
+ let nk = intKindForSize size in
+ ((if isSigned ik' then nk else unsignedVersionOf nk), a0')
+ with Not_found ->
+ (ignore (error "GCC width mode %s applied to unexpected type, or unexpected mode"
+ mode));
+ (ik', a0one :: a0')
+ end
+ | _ -> (ik', a0one :: a0'))
+ (ik, [])
+ a0
+ in
+ TInt (ik', cabsAddAttributes a0' a)
+
+ | TFloat (fk, a) -> TFloat (fk, add a)
+ | TEnum (enum, a) -> TEnum (enum, add a)
+ | TPtr (t, a) -> TPtr (t, add a)
+ | 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)
+ end
+
+
+(* Do types *)
+ (* Combine the types. Raises the Failure exception with an error message.
+ * isdef says whether the new type is for a definition *)
+type combineWhat =
+ CombineFundef (* The new definition is for a function definition. The old
+ * is for a prototype *)
+ | CombineFunarg (* Comparing a function argument type with an old prototype
+ * arg *)
+ | CombineFunret (* Comparing the return of a function with that from an old
+ * prototype *)
+ | CombineOther
+
+(* We sometimes want to succeed in combining two structure types that are
+ * identical except for the names of the structs. We keep a list of types
+ * that are known to be equal *)
+let isomorphicStructs : (string * string, bool) H.t = H.create 15
+
+let rec combineTypes (what: combineWhat) (oldt: typ) (t: typ) : typ =
+ match oldt, t with
+ | TVoid olda, TVoid a -> TVoid (cabsAddAttributes olda a)
+ | TInt (oldik, olda), TInt (ik, a) ->
+ let combineIK oldk k =
+ if oldk = k then oldk else
+ (* 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
+ 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 =
+ if oldk = k then oldk else
+ (* GCC allows a function definition to have a more precise integer
+ * type than a prototype that says "double" *)
+ if not !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 (ei, cabsAddAttributes olda a)
+
+ (* Strange one. But seems to be handled by GCC *)
+ | TEnum (oldei, olda) , TInt(IInt, a) -> TEnum(oldei,
+ cabsAddAttributes olda a)
+ (* Strange one. But seems to be handled by GCC *)
+ | TInt(IInt, olda), TEnum (ei, a) -> TEnum(ei, cabsAddAttributes olda a)
+
+
+ | TComp (oldci, olda) , TComp (ci, a) ->
+ if oldci.cstruct <> ci.cstruct then
+ raise (Failure "different struct/union types");
+ let comb_a = cabsAddAttributes olda a in
+ if oldci.cname = ci.cname then
+ TComp (oldci, comb_a)
+ else
+ (* Now maybe they are actually the same *)
+ if H.mem isomorphicStructs (oldci.cname, ci.cname) then
+ (* We know they are the same *)
+ TComp (oldci, comb_a)
+ else begin
+ (* If one has 0 fields (undefined) while the other has some fields
+ * we accept it *)
+ let oldci_nrfields = List.length oldci.cfields in
+ let ci_nrfields = List.length ci.cfields in
+ if oldci_nrfields = 0 then
+ TComp (ci, comb_a)
+ else if ci_nrfields = 0 then
+ 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
+(*
+ ignore (E.log "different number of fields: %s had %d and %s had %d\n"
+ oldci.cname oldci_nrfields
+ ci.cname ci_nrfields);
+*)
+ raise (Failure "different structs(number of fields)");
+ end;
+ (* Assume they are the same *)
+ H.add isomorphicStructs (oldci.cname, ci.cname) true;
+ H.add isomorphicStructs (ci.cname, oldci.cname) true;
+ (* Check that the fields are isomorphic and watch for Failure *)
+ (try
+ List.iter2 (fun oldf f ->
+ if oldf.fbitfield <> f.fbitfield then
+ raise (Failure "different structs(bitfield info)");
+ if oldf.fattr <> f.fattr then
+ raise (Failure "different structs(field attributes)");
+ (* Make sure the types are compatible *)
+ ignore (combineTypes CombineOther oldf.ftype f.ftype);
+ ) oldci.cfields ci.cfields
+ with Failure _ as e -> begin
+ (* Our assumption was wrong. Forget the isomorphism *)
+ ignore (E.log "\tFailed in our assumption that %s and %s are isomorphic\n"
+ oldci.cname ci.cname);
+ H.remove isomorphicStructs (oldci.cname, ci.cname);
+ H.remove isomorphicStructs (ci.cname, oldci.cname);
+ raise e
+ end);
+ (* We get here if we succeeded *)
+ TComp (oldci, comb_a)
+ end
+ end
+
+ | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) ->
+ let newbt = combineTypes CombineOther oldbt bt in
+ let newsz =
+ match oldsz, sz with
+ None, Some _ -> sz
+ | Some _, None -> oldsz
+ | None, None -> sz
+ | Some oldsz', Some sz' ->
+ (* They are not structurally equal. But perhaps they are equal if
+ * we evaluate them. Check first machine independent comparison *)
+ let checkEqualSize (machdep: bool) =
+ 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
+ else
+ oldsz', sz'
+ in
+ Util.equals (constFold machdep oldsz'')
+ (constFold machdep sz'')
+ in
+ 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\n"
+ 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)
+
+ | 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)
+ oldrt rt in
+ (* If one does not have arguments, believe the one with the
+ * arguments *)
+ 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
+ raise (Failure "different number of arguments")
+ else begin
+ (* Construct a mapping between old and new argument names. *)
+ let map = H.create 5 in
+ List.iter2
+ (fun (on, _, _) (an, _, _) -> H.replace map on an)
+ oldargslist argslist;
+ (* Go over the arguments and update the old ones with the
+ * adjusted types *)
+ 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)
+ 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)
+ 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 (cabsAddAttributes olda a)
+
+ (* Unroll first the new type *)
+ | _, TNamed (t, a) ->
+ let res = combineTypes what oldt t.ttype in
+ cabsTypeAddAttributes a res
+
+ (* And unroll the old type as well if necessary *)
+ | TNamed (oldt, a), _ ->
+ let res = combineTypes what oldt.ttype t in
+ cabsTypeAddAttributes a res
+
+ | _ -> raise (Failure "different type constructors")
+
+
+let extInlineSuffRe = Str.regexp "\\(.+\\)__extinline"
+
+(* Create and cache varinfo's for globals. Starts with a varinfo but if the
+ * global has been declared already it might come back with another varinfo.
+ * Returns the varinfo to use (might be the old one), and an indication
+ * whether the variable exists already in the environment *)
+let makeGlobalVarinfo (isadef: bool) (vi: varinfo) : varinfo * bool =
+ 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
+ * global scope but we are in a local scope. *)
+
+ (* We lookup in the environement. If this is extern inline then the name
+ * was already changed to foo__extinline. We lookup with the old name *)
+ let lookupname =
+ if vi.vstorage = Static then
+ if Str.string_match extInlineSuffRe vi.vname 0 then
+ Str.matched_group 1 vi.vname
+ else
+ vi.vname
+ else
+ vi.vname
+ in
+ 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"
+ vi.vname d_loc oldloc);
+ (* It was already defined. We must reuse the varinfo. But clean up the
+ * storage. *)
+ let newstorage = (** See 6.2.2 *)
+ match oldvi.vstorage, vi.vstorage with
+ (* Extern and something else is that thing *)
+ | Extern, other
+ | other, Extern -> other
+
+ | NoStorage, other
+ | other, NoStorage -> other
+
+
+ | _ ->
+ if vi.vstorage != oldvi.vstorage then
+ ignore (warn
+ "Inconsistent storage specification for %s. Previous declaration: %a"
+ vi.vname d_loc oldloc);
+ vi.vstorage
+ in
+ oldvi.vinline <- oldvi.vinline || vi.vinline;
+ oldvi.vstorage <- newstorage;
+ (* If the new declaration has a section attribute, remove any
+ * preexisting section attribute. This mimics behavior of gcc that is
+ * required to compile the Linux kernel properly. *)
+ if hasAttribute "section" vi.vattr then
+ oldvi.vattr <- dropAttribute "section" oldvi.vattr;
+ (* Union the attributes *)
+ oldvi.vattr <- cabsAddAttributes oldvi.vattr vi.vattr;
+ begin
+ try
+ oldvi.vtype <-
+ combineTypes
+ (if isadef then CombineFundef else CombineOther)
+ oldvi.vtype vi.vtype;
+ 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)."
+ vi.vname d_loc oldloc reason)
+ end;
+
+ (* Found an old one. Keep the location always from the definition *)
+ 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
+ * alphaConvertVarAndAddToEnv *)
+ alphaConvertVarAndAddToEnv true vi, false
+ end
+
+let conditionalConversion (t2: typ) (t3: typ) : typ =
+ let tresult = (* ISO 6.5.15 *)
+ match unrollType t2, unrollType t3 with
+ (TInt _ | TEnum _ | TFloat _),
+ (TInt _ | TEnum _ | TFloat _) ->
+ arithmeticConversion t2 t3
+ | TComp (comp2,_), TComp (comp3,_)
+ when comp2.ckey = comp3.ckey -> t2
+ | TPtr(_, _), TPtr(TVoid _, _) -> t2
+ | TPtr(TVoid _, _), TPtr(_, _) -> t3
+ | TPtr _, TPtr _ when 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
+ * a global *)
+ | (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")
+ in
+ tresult
+
+(* Some utilitites for doing initializers *)
+
+let debugInit = false
+
+type preInit =
+ | NoInitPre
+ | 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 =
+ | Handle (* Handle them yourself *)
+ | DoNotHandle (* Do not handle them your self *)
+ | 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
+ NoOffset -> SinglePre e
+ | _ ->
+ let idx, (* Index in the current comp *)
+ restoff (* Rest offset *) =
+ match o with
+ | Index(Const(CInt64(i,_,_)), off) -> i64_to_int i, 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)
+ | f' :: _ when f'.fname = f.fname -> idx
+ | _ :: restf -> loop (idx + 1) restf
+ in
+ loop 0 f.fcomp.cfields, off
+ | _ -> E.s (bug "setOneInit: non-constant index")
+ in
+ let pMaxIdx, pArray =
+ match this with
+ NoInitPre -> (* No initializer so far here *)
+ ref idx, ref (Array.create (max 32 (idx + 1)) NoInitPre)
+
+ | CompoundPre (pMaxIdx, pArray) ->
+ if !pMaxIdx < idx then begin
+ pMaxIdx := idx;
+ (* Maybe we also need to grow the array *)
+ let l = Array.length !pArray in
+ if l <= idx then begin
+ let growBy = max (max 32 (idx + 1 - l)) (l / 2) in
+ let newarray = Array.make (growBy + idx) NoInitPre in
+ Array.blit !pArray 0 newarray 0 l;
+ pArray := newarray
+ end
+ end;
+ pMaxIdx, pArray
+ | SinglePre e ->
+ E.s (unimp "Index %d is already initialized" idx)
+ in
+ assert (idx >= 0 && idx < Array.length !pArray);
+ let this' = setOneInit !pArray.(idx) restoff e in
+ !pArray.(idx) <- this';
+ CompoundPre (pMaxIdx, pArray)
+
+
+(* collect a CIL initializer, given the original syntactic initializer
+ * 'preInit'; this returns a type too, since initialization of an array
+ * with unspecified size actually changes the array's type
+ * (ANSI C, 6.7.8, para 22) *)
+let rec collectInitializer
+ (this: preInit)
+ (thistype: typ) : (init * typ) =
+ if this = NoInitPre then (makeZeroInit thistype), thistype
+ else
+ match unrollType thistype, this with
+ | _ , SinglePre e -> SingleInit e, thistype
+ | TArray (bt, leno, at), CompoundPre (pMaxIdx, pArray) ->
+ let (len: int), newtype =
+ (* normal case: use array's declared length, newtype=thistype *)
+ match leno with
+ Some len -> begin
+ 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 *)
+ (!pMaxIdx + 1,
+ TArray (bt, Some (integer (!pMaxIdx + 1)), at))
+ in
+ if !pMaxIdx >= len then
+ E.s (E.bug "collectInitializer: too many initializers(%d >= %d)\n"
+ !pMaxIdx len);
+ (* len could be extremely big. So omit the last initializers, if they
+ * are many (more than 16) *)
+(*
+ ignore (E.log "collectInitializer: len = %d, pMaxIdx= %d\n"
+ len !pMaxIdx); *)
+ let endAt =
+ if len - 1 > !pMaxIdx + 16 then
+ !pMaxIdx
+ else
+ len - 1
+ in
+ (* Make one zero initializer to be used next *)
+ let oneZeroInit = makeZeroInit bt in
+ let rec collect (acc: (offset * init) list) (idx: int) =
+ if idx = -1 then acc
+ else
+ let thisi =
+ if idx > !pMaxIdx then oneZeroInit
+ else (fst (collectInitializer !pArray.(idx) bt))
+ in
+ collect ((Index(integer idx, NoOffset), thisi) :: acc) (idx - 1)
+ in
+
+ CompoundInit (newtype, collect [] endAt), newtype
+
+ | TComp (comp, _), CompoundPre (pMaxIdx, pArray) when comp.cstruct ->
+ let rec collect (idx: int) = function
+ [] -> []
+ | f :: restf ->
+ if f.fname = missingFieldName then
+ collect (idx + 1) restf
+ else
+ let thisi =
+ if idx > !pMaxIdx then
+ makeZeroInit f.ftype
+ else
+ collectFieldInitializer !pArray.(idx) f
+ in
+ (Field(f, NoOffset), thisi) :: collect (idx + 1) restf
+ in
+ CompoundInit (thistype, collect 0 comp.cfields), thistype
+
+ | TComp (comp, _), CompoundPre (pMaxIdx, pArray) when not comp.cstruct ->
+ (* Find the field to initialize *)
+ let rec findField (idx: int) = function
+ [] -> E.s (bug "collectInitializer: union")
+ | _ :: rest when idx < !pMaxIdx && !pArray.(idx) = NoInitPre ->
+ findField (idx + 1) rest
+ | f :: _ when idx = !pMaxIdx ->
+ Field(f, NoOffset),
+ collectFieldInitializer !pArray.(idx) f
+ | _ -> E.s (error "Can initialize only one field for union")
+ in
+ 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
+ (this: preInit)
+ (f: fieldinfo) : init =
+ (* collect, and rewrite type *)
+ let init,newtype = (collectInitializer this f.ftype) in
+ f.ftype <- newtype;
+ init
+
+
+type stackElem =
+ InArray of offset * typ * int * int ref (* offset of parent, base type,
+ * length, current index. If the
+ * array length is unspecified we
+ * use Int.max_int *)
+ | InComp of offset * compinfo * fieldinfo list (* offset of parent,
+ base comp, current fields *)
+
+
+(* A subobject is given by its address. The address is read from the end of
+ * the list (the bottom of the stack), starting with the current object *)
+type subobj = { mutable stack: stackElem list; (* With each stack element we
+ * store the offset of its
+ * PARENT *)
+ mutable eof: bool; (* The stack is empty and we reached the
+ * end *)
+ mutable soTyp: typ; (* The type of the subobject. Set using
+ * normalSubobj after setting stack. *)
+ mutable soOff: offset; (* The offset of the subobject. Set
+ * using normalSubobj after setting
+ * stack. *)
+ curTyp: typ; (* Type of current object. See ISO for
+ * the definition of the current object *)
+ curOff: offset; (* The offset of the current obj *)
+ host: varinfo; (* The host that we are initializing.
+ * For error messages *)
+ }
+
+
+(* Make a subobject iterator *)
+let rec makeSubobj
+ (host: varinfo)
+ (curTyp: typ)
+ (curOff: offset) =
+ let so =
+ { host = host; curTyp = curTyp; curOff = curOff;
+ stack = []; eof = false;
+ (* The next are fixed by normalSubobj *)
+ soTyp = voidType; soOff = NoOffset } in
+ normalSubobj so;
+ so
+
+ (* Normalize a stack so the we always point to a valid subobject. Do not
+ * descend into type *)
+and normalSubobj (so: subobj) : unit =
+ match so.stack with
+ [] -> so.soOff <- so.curOff; so.soTyp <- so.curTyp
+ (* The array is over *)
+ | InArray (parOff, bt, leno, current) :: rest ->
+ if leno = !current then begin (* The array is over *)
+ if debugInit then ignore (E.log "Past the end of array\n");
+ so.stack <- rest;
+ advanceSubobj so
+ end else begin
+ so.soTyp <- bt;
+ so.soOff <- addOffset (Index(integer !current, NoOffset)) parOff
+ end
+
+ (* The fields are over *)
+ | 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;
+ advanceSubobj so
+ end else begin
+ let fst = List.hd nextflds in
+ so.soTyp <- fst.ftype;
+ so.soOff <- addOffset (Field(fst, NoOffset)) parOff
+ end
+
+ (* Advance to the next subobject. Always apply to a normalized object *)
+and advanceSubobj (so: subobj) : unit =
+ if so.eof then 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 " 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
+ 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 =
+ (* Never look at anonymous fields *)
+ let flds1 =
+ List.filter (fun f -> f.fname <> missingFieldName) comp.cfields in
+ let flds2 =
+ match designator with
+ None -> flds1
+ | Some fn ->
+ let rec loop = function
+ [] -> E.s (error "Cannot find designated field %s" fn)
+ | (f :: _) as nextflds when f.fname = fn -> nextflds
+ | _ :: rest -> loop rest
+ in
+ loop flds1
+ in
+ (* If it is a union we only initialize one field *)
+ match flds2 with
+ [] -> []
+ | (f :: rest) as toinit ->
+ if comp.cstruct then toinit else [f]
+
+
+let integerArrayLength (leno: exp option) : int =
+ match leno with
+ None -> max_int
+ | Some len -> begin
+ try lenOfArray leno
+ with LenOfArray ->
+ E.s (error "Initializing non-constant-length array\n length=%a\n"
+ d_exp len)
+ end
+
+(* sm: I'm sure something like this already exists, but ... *)
+let isNone (o : 'a option) : bool =
+ match o with
+ | None -> true
+ | Some _ -> false
+
+
+let annonCompFieldNameId = ref 0
+let annonCompFieldName = "__annonCompField"
+
+
+
+(* Utility ***)
+let rec replaceLastInList
+ (lst: A.expression list)
+ (how: A.expression -> A.expression) : A.expression list=
+ match lst with
+ [] -> []
+ | [e] -> [how e]
+ | h :: t -> h :: replaceLastInList t how
+
+
+
+
+
+let convBinOp (bop: A.binary_operator) : binop =
+ match bop with
+ A.ADD -> PlusA
+ | A.SUB -> MinusA
+ | A.MUL -> Mult
+ | A.DIV -> Div
+ | A.MOD -> Mod
+ | A.BAND -> BAnd
+ | A.BOR -> BOr
+ | A.XOR -> BXor
+ | A.SHL -> Shiftlt
+ | A.SHR -> Shiftrt
+ | A.EQ -> Eq
+ | A.NE -> Ne
+ | A.LT -> Lt
+ | A.LE -> Le
+ | A.GT -> Gt
+ | A.GE -> Ge
+ | _ -> E.s (error "convBinOp")
+
+(**** PEEP-HOLE optimizations ***)
+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
+ * 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 &&
+ String.length vi.vname >= 3 &&
+ (* Watch out for the possibility that we have an implied cast in
+ * the call *)
+ (let tcallres =
+ match unrollType (typeOf f) with
+ TFun (rt, _, _, _) -> rt
+ | _ -> E.s (E.bug "Function call to a non-function")
+ in
+ Util.equals (typeSig tcallres) (typeSig vi.vtype) &&
+ Util.equals (typeSig newt) (typeSig (typeOfLval destlv))) &&
+ IH.mem callTempVars vi.vid &&
+ vi' == vi)
+ -> Some [Call(Some destlv, f, args, l)]
+ | i1,i2 -> None
+ in
+ (* First add in the postins *)
+ let sl = pushPostIns c in
+ if !doCollapseCallCast then
+ peepHole2 collapseCallCast sl;
+ { c with stmts = sl; postins = [] }
+
+(***** Try to suggest a name for the anonymous structures *)
+let suggestAnonName (nl: A.name list) =
+ match nl with
+ [] -> ""
+ | (n, _, _, _) :: _ -> n
+
+
+(** Optional constant folding of binary operations *)
+let optConstFoldBinOp (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
+ * structures and enums *)
+ (specs: A.spec_elem list)
+ (* Returns the base type, the storage, whether it is inline and the
+ * (unprocessed) attributes *)
+ : typ * storage * bool * A.attribute list =
+ (* Do one element and collect the type specifiers *)
+ let isinline = ref false in (* If inline appears *)
+ (* The storage is placed here *)
+ let storage : storage ref = ref NoStorage in
+
+ (* Collect the attributes. Unfortunately, we cannot treat GCC
+ * __attributes__ and ANSI C const/volatile the same way, since they
+ * associate with structures differently. Specifically, ANSI
+ * qualifiers never apply to structures (ISO 6.7.3), whereas GCC
+ * attributes always do (GCC manual 4.30). Therefore, they are
+ * collected and processed separately. *)
+ let attrs : A.attribute list ref = ref [] in (* __attribute__, etc. *)
+ let cvattrs : A.cvspec list ref = ref [] in (* const/volatile *)
+
+ let doSpecElem (se: A.spec_elem)
+ (acc: A.typeSpecifier list)
+ : A.typeSpecifier list =
+ match se with
+ A.SpecTypedef -> acc
+ | A.SpecInline -> isinline := true; acc
+ | A.SpecStorage st ->
+ if !storage <> NoStorage then
+ E.s (error "Multiple storage specifiers");
+ let sto' =
+ match st with
+ A.NO_STORAGE -> NoStorage
+ | A.AUTO -> NoStorage
+ | A.REGISTER -> Register
+ | A.STATIC -> Static
+ | A.EXTERN -> Extern
+ in
+ storage := sto';
+ acc
+
+ | A.SpecCV cv -> cvattrs := cv :: !cvattrs; acc
+ | A.SpecAttr a -> attrs := a :: !attrs; acc
+ | A.SpecType ts -> ts :: acc
+ | A.SpecPattern _ -> E.s (E.bug "SpecPattern in cabs2cil input")
+ in
+ (* Now scan the list and collect the type specifiers. Preserve the order *)
+ let tspecs = List.fold_right doSpecElem specs [] in
+
+ let tspecs' =
+ (* GCC allows a named type that appears first to be followed by things
+ * like "short", "signed", "unsigned" or "long". *)
+ match tspecs with
+ A.Tnamed n :: (_ :: _ as rest) when not !msvcMode ->
+ (* If rest contains "short" or "long" then drop the Tnamed *)
+ if List.exists (function A.Tshort -> true
+ | A.Tlong -> true | _ -> false) rest then
+ rest
+ else
+ tspecs
+
+ | _ -> tspecs
+ in
+ (* Sort the type specifiers *)
+ let sortedspecs =
+ let order = function (* Don't change this *)
+ | A.Tvoid -> 0
+ | A.Tsigned -> 1
+ | A.Tunsigned -> 2
+ | A.Tchar -> 3
+ | A.Tshort -> 4
+ | A.Tlong -> 5
+ | A.Tint -> 6
+ | A.Tint64 -> 7
+ | A.Tfloat -> 8
+ | A.Tdouble -> 9
+ | _ -> 10 (* There should be at most one of the others *)
+ in
+ List.stable_sort (fun ts1 ts2 -> compare (order ts1) (order ts2)) tspecs'
+ in
+ let getTypeAttrs () : A.attribute list =
+ (* Partitions the attributes in !attrs.
+ Type attributes are removed from attrs and returned, so that they
+ can go into the type definition. Name attributes are left in attrs,
+ so they will be returned by doSpecAttr and used in the variable
+ declaration.
+ Testcase: small1/attr9.c *)
+ let an, af, at = cabsPartitionAttributes ~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
+
+ (* And now try to make sense of it. See ISO 6.7.2 *)
+ let bt =
+ match sortedspecs with
+ [A.Tvoid] -> TVoid []
+ | [A.Tchar] -> TInt(IChar, [])
+ | [A.Tsigned; A.Tchar] -> TInt(ISChar, [])
+ | [A.Tunsigned; A.Tchar] -> TInt(IUChar, [])
+
+ | [A.Tshort] -> TInt(IShort, [])
+ | [A.Tsigned; A.Tshort] -> TInt(IShort, [])
+ | [A.Tshort; A.Tint] -> TInt(IShort, [])
+ | [A.Tsigned; A.Tshort; A.Tint] -> TInt(IShort, [])
+
+ | [A.Tunsigned; A.Tshort] -> TInt(IUShort, [])
+ | [A.Tunsigned; A.Tshort; A.Tint] -> TInt(IUShort, [])
+
+ | [] -> TInt(IInt, [])
+ | [A.Tint] -> TInt(IInt, [])
+ | [A.Tsigned] -> TInt(IInt, [])
+ | [A.Tsigned; A.Tint] -> TInt(IInt, [])
+
+ | [A.Tunsigned] -> TInt(IUInt, [])
+ | [A.Tunsigned; A.Tint] -> TInt(IUInt, [])
+
+ | [A.Tlong] -> TInt(ILong, [])
+ | [A.Tsigned; A.Tlong] -> TInt(ILong, [])
+ | [A.Tlong; A.Tint] -> TInt(ILong, [])
+ | [A.Tsigned; A.Tlong; A.Tint] -> TInt(ILong, [])
+
+ | [A.Tunsigned; A.Tlong] -> TInt(IULong, [])
+ | [A.Tunsigned; A.Tlong; A.Tint] -> TInt(IULong, [])
+
+ | [A.Tlong; A.Tlong] -> TInt(ILongLong, [])
+ | [A.Tsigned; A.Tlong; A.Tlong] -> TInt(ILongLong, [])
+ | [A.Tlong; A.Tlong; A.Tint] -> TInt(ILongLong, [])
+ | [A.Tsigned; A.Tlong; A.Tlong; A.Tint] -> TInt(ILongLong, [])
+
+ | [A.Tunsigned; A.Tlong; A.Tlong] -> TInt(IULongLong, [])
+ | [A.Tunsigned; A.Tlong; A.Tlong; A.Tint] -> TInt(IULongLong, [])
+
+ (* int64 is to support MSVC *)
+ | [A.Tint64] -> TInt(ILongLong, [])
+ | [A.Tsigned; A.Tint64] -> TInt(ILongLong, [])
+
+ | [A.Tunsigned; A.Tint64] -> TInt(IULongLong, [])
+
+ | [A.Tfloat] -> TFloat(FFloat, [])
+ | [A.Tdouble] -> TFloat(FDouble, [])
+
+ | [A.Tlong; A.Tdouble] -> TFloat(FLongDouble, [])
+
+ (* Now the other type specifiers *)
+ | [A.Tnamed n] -> begin
+ 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
+ (TNamed _) as x, _ -> x
+ | typ -> E.s (error "Named type %s is not mapped correctly\n" n)
+ in
+ t
+ end
+
+ | [A.Tstruct (n, None, _)] -> (* A reference to a struct *)
+ if n = "" then E.s (error "Missing struct tag on incomplete struct");
+ findCompType "struct" n []
+ | [A.Tstruct (n, Some nglist, extraAttrs)] -> (* A definition of a struct *)
+ let n' =
+ if n <> "" then n else anonStructName "struct" suggestedAnonName in
+ (* Use the (non-cv, non-name) attributes in !attrs now *)
+ let a = extraAttrs @ (getTypeAttrs ()) in
+ makeCompType true n' nglist (doAttributes a)
+
+ | [A.Tunion (n, None, _)] -> (* A reference to a union *)
+ if n = "" then E.s (error "Missing union tag on incomplete union");
+ findCompType "union" n []
+ | [A.Tunion (n, Some nglist, extraAttrs)] -> (* A definition of a union *)
+ let n' =
+ if n <> "" then n else anonStructName "union" suggestedAnonName in
+ (* Use the attributes now *)
+ let a = extraAttrs @ (getTypeAttrs ()) in
+ makeCompType false n' nglist (doAttributes a)
+
+ | [A.Tenum (n, None, _)] -> (* Just a reference to an enum *)
+ if n = "" then E.s (error "Missing enum tag on incomplete enum");
+ findCompType "enum" n []
+
+ | [A.Tenum (n, Some eil, extraAttrs)] -> (* A definition of an enum *)
+ let n' =
+ if n <> "" then n else anonStructName "enum" suggestedAnonName in
+ (* make a new name for this enumeration *)
+ let n'', _ = newAlphaName true "enum" n' in
+
+ (* Create the enuminfo, or use one that was created already for a
+ * forward reference *)
+ let enum, _ = createEnumInfo n'' in
+ let a = extraAttrs @ (getTypeAttrs ()) in
+ enum.eattr <- doAttributes a;
+ let res = TEnum (enum, []) in
+
+ (* sm: start a scope for the enum tag values, since they *
+ * can refer to earlier tags *)
+ enterScope ();
+
+ (* as each name,value pair is determined, this is called *)
+ let rec processName kname (i: exp) loc rest = begin
+ (* add the name to the environment, but with a faked 'typ' field;
+ * we don't know the full type yet (since that includes all of the
+ * tag values), but we won't need them in here *)
+ addLocalToEnv kname (EnvEnum (i, res));
+
+ (* 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
+
+ and loop i = function
+ [] -> []
+ | (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 isInteger (constFold true e') with
+ Some i -> if !lowerConstants then kinteger64 IInt i else e'
+ | _ -> E.s (error "Constant initializer %a not an integer" d_exp e')
+ in
+ processName kname e' (convLoc cloc) rest
+ in
+
+ (* sm: now throw away the environment we built for eval'ing the enum
+ * tags, so we can add to the new one properly *)
+ exitScope ();
+
+ let fields = loop zero eil in
+ (* Now set the right set of items *)
+ enum.eitems <- List.map (fun (_, x) -> x) fields;
+ (* Record the enum name in the environment *)
+ addLocalToEnv (kindPlusName "enum" n'') (EnvTyp res);
+ (* And define the tag *)
+ cabsPushGlobal (GEnumTag (enum, !currentLoc));
+ res
+
+
+ | [A.TtypeofE e] ->
+ let (c, e', t) = doExp false e AType in
+ 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
+ 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")
+ end
+ | _ -> t
+ in
+(*
+ ignore (E.log "typeof(%a) = %a\n" d_exp e' d_plaintype t');
+*)
+ !typeForTypeof t'
+
+ | [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 =
+ match src with
+ | [] -> []
+ | CV_CONST :: tl -> ("const",[]) :: (convertCVtoAttr tl)
+ | CV_VOLATILE :: tl -> ("volatile",[]) :: (convertCVtoAttr tl)
+ | CV_RESTRICT :: tl -> ("restrict",[]) :: (convertCVtoAttr tl)
+
+
+and makeVarInfoCabs
+ ~(isformal: 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 *)
+ bt (A.PARENTYPE(attrs, ndt, a)) in
+ if inline && not (isFunctionType vtype) then
+ ignore (error "inline for a non-function: %s" n);
+ let t =
+ if not isglobal && not isformal then begin
+ (* Sometimes we call this on the formal argument of a function with no
+ * arguments. Don't call stripConstLocalType in that case *)
+(* ignore (E.log "stripConstLocalType(%a) for %s\n" d_type vtype n); *)
+ stripConstLocalType vtype
+ end else
+ vtype
+ in
+ let vi = makeVarinfo isglobal n t in
+ vi.vstorage <- sto;
+ vi.vattr <- nattr;
+ vi.vdecl <- ldecl;
+
+ if false then
+ ignore (E.log "Created varinfo %s : %a\n" vi.vname d_type vi.vtype);
+
+ vi
+
+(* Process a local variable declaration and allow variable-sized arrays *)
+and makeVarSizeVarInfo (ldecl : location)
+ spec_res
+ (n,ndt,a)
+ : varinfo * chunk * exp * bool =
+ 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
+ else
+ makeVarInfoCabs ~isformal:false
+ ~isglobal:false
+ ldecl spec_res (n,ndt,a), empty, zero, false
+
+and doAttr (a: A.attribute) : attribute list =
+ (* Strip the leading and trailing underscore *)
+ let stripUnderscore (n: string) : string =
+ let l = String.length n in
+ let rec start i =
+ if i >= l then
+ 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 =
+ (* We know that we will stop at >= st >= 0 *)
+ if String.get n i = '_' then finish (i - 1) else i
+ in
+ let fin = finish (l - 1) in
+ String.sub n st (fin - st + 1)
+ in
+ match a with
+ | ("__attribute__", []) -> [] (* An empty list of gcc attributes *)
+ | (s, []) -> [Attr (stripUnderscore s, [])]
+ | (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 *)
+ try
+ if not foldenum then raise Not_found;
+
+ match H.find env n' with
+ EnvEnum (tag, _), _ -> begin
+ match isInteger (constFold true tag) with
+ Some i64 when !lowerConstants -> AInt (i64_to_int i64)
+ | _ -> ACons(n', [])
+ end
+ | _ -> ACons (n', [])
+ with Not_found -> ACons(n', [])
+ end
+ | A.CONSTANT (A.CONST_STRING s) -> AStr s
+ | A.CONSTANT (A.CONST_INT str) -> begin
+ match parseInt str with
+ Const (CInt64 (v64,_,_)) ->
+ AInt (i64_to_int v64)
+ | _ ->
+ E.s (error "Invalid attribute constant: %s")
+ end
+ | A.CALL(A.VARIABLE n, args) -> begin
+ let n' = if strip then stripUnderscore n else n in
+ let ae' = List.map ae args in
+ ACons(n', ae')
+ end
+ | A.EXPR_SIZEOF e -> ASizeOfE (ae e)
+ | A.TYPE_SIZEOF (bt, dt) -> ASizeOf (doOnlyType bt dt)
+ | A.EXPR_ALIGNOF e -> AAlignOfE (ae e)
+ | A.TYPE_ALIGNOF (bt, dt) -> AAlignOf (doOnlyType bt dt)
+ | A.BINARY(A.AND, aa1, aa2) ->
+ ABinOp(LAnd, ae aa1, ae aa2)
+ | A.BINARY(A.OR, aa1, aa2) ->
+ ABinOp(LOr, ae aa1, ae aa2)
+ | A.BINARY(abop, aa1, aa2) ->
+ ABinOp (convBinOp abop, ae aa1, ae aa2)
+ | A.UNARY(A.PLUS, aa) -> ae aa
+ | A.UNARY(A.MINUS, aa) -> AUnOp (Neg, ae aa)
+ | A.UNARY(A.BNOT, aa) -> AUnOp(BNot, ae aa)
+ | A.UNARY(A.NOT, aa) -> AUnOp(LNot, ae aa)
+ | A.MEMBEROF (e, s) -> ADot (ae e, s)
+ | A.PAREN(e) -> attrOfExp strip ~foldenum:foldenum e
+ | A.UNARY(A.MEMOF, aa) -> AStar (ae aa)
+ | A.UNARY(A.ADDROF, aa) -> AAddrOf (ae aa)
+ | A.MEMBEROFPTR (aa1, s) -> ADot(AStar(ae aa1), s)
+ | A.INDEX(aa1, aa2) -> AIndex(ae aa1, ae aa2)
+ | A.QUESTION(aa1, aa2, aa3) -> AQuestion(ae aa1, ae aa2, ae aa3)
+ | _ ->
+ ignore (E.log "Invalid expression in attribute: ");
+ withCprint Cprint.print_expression a;
+ E.s (error "cabs2cil: invalid expression")
+
+ and ae (e: A.expression) = attrOfExp false e in
+
+ (* Sometimes we need to convert attrarg into attr *)
+ let arg2attr = function
+ | ACons (s, args) -> Attr (s, args)
+ | a ->
+ E.s (error "Invalid form of attribute: %a"
+ d_attrparam a);
+ in
+ if s = "__attribute__" then (* Just a wrapper for many attributes*)
+ List.map (fun e -> arg2attr (attrOfExp true ~foldenum:false e)) el
+ else if s = "__blockattribute__" then (* Another wrapper *)
+ List.map (fun e -> arg2attr (attrOfExp true ~foldenum:false e)) el
+ else if s = "__declspec" then
+ List.map (fun e -> arg2attr (attrOfExp false ~foldenum:false e)) el
+ else
+ [Attr(stripUnderscore s, List.map (attrOfExp ~foldenum:false false) el)]
+
+and doAttributes (al: A.attribute list) : attribute list =
+ List.fold_left (fun acc a -> cabsAddAttributes (doAttr a) acc) [] al
+
+(* A version of Cil.partitionAttributes that works on CABS attributes.
+ It would be better to use Cil.partitionAttributes instead to avoid
+ the extra doAttr conversions here, but that's hard to do in doSpecList.*)
+and cabsPartitionAttributes
+ ~(default:attributeClass)
+ (attrs: A.attribute list) :
+ A.attribute list * A.attribute list * A.attribute list =
+ let rec loop (n,f,t) = function
+ [] -> n, f, t
+ | a :: rest ->
+ let kind = match doAttr a with
+ [] -> default
+ | Attr(an, _)::_ ->
+ (try H.find attributeHash an with Not_found -> default)
+ in
+ match kind with
+ AttrName _ -> loop (a::n, f, t) rest
+ | AttrFunType _ ->
+ loop (n, a::f, t) rest
+ | AttrType -> loop (n, f, a::t) rest
+ in
+ loop ([], [], []) attrs
+
+
+
+and doType (nameortype: attributeClass) (* This is AttrName if we are doing
+ * the type for a name, or AttrType
+ * if we are doing this type in a
+ * typedef *)
+ ?(allowVarSizeArrays=false)
+ (bt: typ) (* The base type *)
+ (dt: A.decl_type)
+ (* Returns the new type and the accumulated name (or type attribute
+ if nameoftype = AttrType) attributes *)
+ : typ * attribute list =
+
+ (* Now do the declarator type. But remember that the structure of the
+ * declarator type is as printed, meaning that it is the reverse of the
+ * right one *)
+ let rec doDeclType (bt: typ) (acc: attribute list) = function
+ A.JUSTBASE -> bt, acc
+ | A.PARENTYPE (a1, d, a2) ->
+ let a1' = doAttributes a1 in
+ let a1n, a1f, a1t = partitionAttributes AttrType a1' in
+ let a2' = doAttributes a2 in
+ let a2n, a2f, a2t = partitionAttributes 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);
+*)
+ let bt' = cabsTypeAddAttributes a1t bt in
+(*
+ ignore (E.log "bt' = %a\n" d_type bt');
+*)
+ let bt'', a1fadded =
+ match unrollType bt with
+ TFun _ -> cabsTypeAddAttributes a1f bt', true
+ | _ -> bt', false
+ in
+ (* Now recurse *)
+ let restyp, nattr = doDeclType bt'' acc d in
+ (* Add some more type attributes *)
+ let restyp = cabsTypeAddAttributes a2t restyp in
+ (* See if we can add some more type attributes *)
+ let restyp' =
+ match unrollType restyp with
+ TFun _ ->
+ if a1fadded then
+ cabsTypeAddAttributes a2f restyp
+ else
+ cabsTypeAddAttributes a2f
+ (cabsTypeAddAttributes a1f restyp)
+ | TPtr ((TFun _ as tf), ap) when not !msvcMode ->
+ if a1fadded then
+ TPtr(cabsTypeAddAttributes a2f tf, ap)
+ else
+ TPtr(cabsTypeAddAttributes a2f
+ (cabsTypeAddAttributes a1f tf), ap)
+ | _ ->
+ if a1f <> [] && not a1fadded then
+ 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"
+ d_attrlist a2f);
+ restyp
+ in
+(*
+ ignore (E.log "restyp' = %a\n" d_type restyp');
+*)
+ (* Now add the name attributes and return *)
+ restyp', cabsAddAttributes a1n (cabsAddAttributes a2n nattr)
+
+ | A.PTR (al, d) ->
+ let al' = doAttributes al in
+ let an, af, at = partitionAttributes AttrType al' in
+ (* Now recurse *)
+ let restyp, nattr = doDeclType (TPtr(bt, at)) acc d in
+ (* See if we can do anything with function type attributes *)
+ let restyp' =
+ match unrollType restyp with
+ TFun _ -> cabsTypeAddAttributes af restyp
+ | TPtr((TFun _ as tf), ap) ->
+ TPtr(cabsTypeAddAttributes af tf, ap)
+ | _ ->
+ if af <> [] then
+ E.s (error "Invalid position for function type attributes:%a"
+ d_attrlist af);
+ restyp
+ 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
+ | _ ->
+ (* 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 *)
+ let elsz =
+ try (bitsSizeOf bt + 7) / 8
+ with _ -> 1 (** We get this if we cannot compute the size of
+ * one element. This can happen, when we define
+ * an extern, for example. We use 1 for now *)
+ in
+ (match constFold true len' with
+ Const(CInt64(i, _, _)) ->
+ if i < 0L then
+ E.s (error "Length of array is negative\n");
+ if Int64.mul i (Int64.of_int elsz) >= 0x80000000L then
+ E.s (error "Length of array is too large\n")
+
+ | 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\n"
+ d_exp l))
+ end;
+ Some len'
+ in
+ let al' = doAttributes al in
+ doDeclType (TArray(bt, lo, al')) acc d
+
+ | A.PROTO (d, args, isva) ->
+ (* Start a scope for the parameter names *)
+ enterScope ();
+ (* Intercept the old-style use of varargs.h. On GCC this means that
+ * we have ellipsis and a last argument "builtin_va_alist:
+ * builtin_va_alist_t". On MSVC we do not have the ellipsis and we
+ * have a last argument "va_alist: va_list" *)
+ let args', isva' =
+ if args != [] && !msvcMode = not isva then begin
+ let newisva = ref isva in
+ let rec doLast = function
+ [([A.SpecType (A.Tnamed atn)], (an, A.JUSTBASE, [], _))]
+ when isOldStyleVarArgTypeName atn &&
+ isOldStyleVarArgName an -> begin
+ (* Turn it into a vararg *)
+ newisva := true;
+ (* And forget about this argument *)
+ []
+ end
+
+ | a :: rest -> a :: doLast rest
+ | [] -> []
+ in
+ let args' = doLast args in
+ (args', !newisva)
+ end else (args, isva)
+ in
+ (* Make the argument as for a formal *)
+ let doOneArg (s, (n, ndt, a, cloc)) : varinfo =
+ let s' = doSpecList n s in
+ 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). *)
+ addLocalToEnv vi.vname (EnvVar vi);
+ vi
+ in
+ let targs : varinfo list option =
+ match List.map doOneArg args' with
+ | [] -> None (* No argument list *)
+ | [t] when isVoidType t.vtype ->
+ Some []
+ | l -> Some l
+ in
+ exitScope ();
+ (* Turn [] types into pointers in the arguments and the result type.
+ * Turn function types into pointers to respective. This simplifies
+ * our life a lot, and is what the standard requires. *)
+ let turnArrayIntoPointer (bt: typ)
+ (lo: exp option) (a: attributes) : typ =
+ let a' : attributes =
+ match lo with
+ None -> a
+ | Some l -> begin
+ (* Transform the length into an attribute expression *)
+ 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
+ in
+ TPtr(bt, a')
+ in
+ let rec fixupArgumentTypes (argidx: int) (args: varinfo list) : unit =
+ match args with
+ [] -> ()
+ | a :: args' ->
+ (match unrollType a.vtype with
+ TArray(bt,lo,attr) ->
+ (* Note that for multi-dimensional arrays we strip off only
+ the first TArray and leave bt alone. *)
+ a.vtype <- turnArrayIntoPointer bt lo attr
+ | TFun _ -> a.vtype <- TPtr(a.vtype, [])
+ | TComp (comp, _) -> begin
+ match isTransparentUnion a.vtype with
+ None -> ()
+ | Some fstfield ->
+ transparentUnionArgs :=
+ (argidx, a.vtype) :: !transparentUnionArgs;
+ a.vtype <- fstfield.ftype;
+ end
+ | _ -> ());
+ fixupArgumentTypes (argidx + 1) args'
+ in
+ let args =
+ match targs with
+ None -> None
+ | Some argl ->
+ fixupArgumentTypes 0 argl;
+ Some (List.map (fun a -> (a.vname, a.vtype, a.vattr)) argl)
+ in
+ let tres =
+ match unrollType bt with
+ TArray(t,lo,attr) -> turnArrayIntoPointer t lo attr
+ | _ -> bt
+ in
+ doDeclType (TFun (tres, args, isva', [])) acc d
+
+ in
+ doDeclType bt [] dt
+
+(* If this is a declarator for a variable size array then turn it into a
+ pointer type and a length *)
+and isVariableSizedArray (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 ->
+ (* 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)
+ in
+ let dt' = findArray dt in
+ match !res with
+ None -> None
+ | Some (se, e) -> Some (dt', se, e)
+
+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");
+ let tres, nattr = doType AttrType bt' (A.PARENTYPE(attrs, dt, [])) in
+ if nattr <> [] then
+ E.s (error "Name attributes in only_type: %a"
+ d_attrlist nattr);
+ tres
+
+
+and makeCompType (isstruct: bool)
+ (n: string)
+ (nglist: A.field_group list)
+ (a: attribute list) =
+ (* Make a new name for the structure *)
+ let kind = if isstruct then "struct" else "union" in
+ let n', _ = newAlphaName true kind n in
+ (* Create the self cell for use in fields and forward references. Or maybe
+ * one exists already from a forward reference *)
+ let comp, _ = createCompInfo isstruct n' in
+ 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
+ [] -> ""
+ | ((n, _, _, _), _) :: _ -> n
+ in
+ let bt, sto, inl, attrs = doSpecList sugg s in
+ (* Do the fields *)
+ let makeFieldInfo
+ (((n,ndt,a,cloc) : A.name), (widtho : A.expression option))
+ : 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
+ (* check for fields whose type is an undefined struct. This rules
+ out circularity:
+ struct C1 { struct C2 c2; }; //This line is now an error.
+ struct C2 { struct C1 c1; int dummy; };
+ *)
+ (match unrollType ftype with
+ TComp (ci',_) when not ci'.cdefined ->
+ E.s (error "Type of field %s is an undefined struct.\n" n)
+ | _ -> ());
+ let width =
+ match widtho with
+ None -> None
+ | Some w -> begin
+ (match unrollType ftype with
+ TInt (ikind, a) -> ()
+ | TEnum _ -> ()
+ | _ -> E.s (error "Base type for bitfield is not an integer type"));
+ match isIntegerConstant w with
+ Some n -> Some n
+ | 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
+ * then give it a distinguished name *)
+ let n' =
+ if n = missingFieldName then begin
+ match unrollType ftype with
+ TComp _ -> begin
+ incr annonCompFieldNameId;
+ annonCompFieldName ^ (string_of_int !annonCompFieldNameId)
+ end
+ | _ -> n
+ end else
+ n
+ in
+ { fcomp = comp;
+ fname = n';
+ ftype = ftype;
+ fbitfield = width;
+ fattr = nattr;
+ floc = convLoc cloc
+ }
+ in
+ List.map makeFieldInfo nl
+ in
+
+
+ let flds = List.concat (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
+ * for A *)
+ let fieldsSig fs = 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
+ comp.cfields <- flds;
+
+(* ignore (E.log "makeComp: %s: %a\n" comp.cname d_attrlist a); *)
+ comp.cattr <- a;
+ let res = TComp (comp, []) in
+ (* This compinfo is defined, even if there are no fields *)
+ comp.cdefined <- true;
+ (* Create a typedef for this one *)
+ cabsPushGlobal (GCompTag (comp, !currentLoc));
+
+ (* There must be a self cell created for this already *)
+ addLocalToEnv (kindPlusName kind n) (EnvTyp res);
+ (* Now create a typedef with just this type *)
+ res
+
+and preprocessCast (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
+ * cast from a type of a field to the type of the union *)
+ let ie' =
+ match unrollType typ, ie with
+ TComp (c, _), A.SINGLE_INIT _ when not c.cstruct ->
+ A.COMPOUND_INIT [(A.INFIELD_INIT ("___matching_field",
+ A.NEXT_INIT),
+ ie)]
+ | _, _ -> ie
+ in
+ (* Maybe specs contains an unnamed composite. Replace with the name so that
+ * when we do again the specs we get the right name *)
+ let specs1 =
+ match typ with
+ TComp (ci, _) ->
+ List.map
+ (function
+ A.SpecType (A.Tstruct ("", 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'
+
+and getIntConstExp (aexp) : exp =
+ 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
+ (* first, filter for those Const exps that are integers *)
+ | Const (CInt64 _ ) -> e
+ | Const (CEnum _) -> e
+ | Const (CChr i) -> Const(charConstToInt i)
+
+ (* 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 *)
+ | _ -> e
+
+and isIntegerConstant (aexp) : int option =
+ match doExp true aexp (AExp None) with
+ (c, e, _) when isEmpty c -> begin
+ match isInteger (constFold true e) with
+ Some i64 -> Some (i64_to_int i64)
+ | _ -> 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
+ * essentially doExp should never return things of type TFun or TArray *)
+ let processArrayFun e t =
+ match e, unrollType t with
+ (Lval(lv) | CastE(_, Lval lv)), TArray(tbase, _, a) ->
+ mkStartOfAndMark lv, TPtr(tbase, a)
+ | (Lval(lv) | CastE(_, Lval lv)), TFun _ ->
+ mkAddrOfAndMark lv, TPtr(t, [])
+ | _, (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
+ | 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
+ * construct *)
+ | AExp _ ->
+ let (e', t') = processArrayFun e t in
+(*
+ 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' ->
+ (se, e, t)
+ | _ ->
+ let (e', t') = processArrayFun e t in
+ let (t'', e'') = castTo t' lvt e' in
+(*
+ ignore (E.log "finishExp: e = %a\n e'' = %a\n" d_plainexp e d_plainexp e'');
+*)
+ (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
+ * 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, _) ->
+ let off = search ci.cfields in
+ if off = NoOffset then
+ search rest (* Continue searching *)
+ else
+ Field (fid, off)
+ | _ -> E.s (bug "unnamed field type is not a struct/union")
+ end
+ | _ :: rest -> search rest
+ in
+ let off = search fidlist in
+ if off = NoOffset then
+ E.s (error "Cannot find field %s" n);
+ off
+ in
+ try
+ match e with
+ | A.PAREN e -> E.s (bug "stripParen")
+ | A.NOTHING when what = ADrop -> finishExp empty (integer 0) intType
+ | A.NOTHING ->
+ let res = Const(CStr "exp_nothing") in
+ finishExp empty res (typeOf res)
+
+ (* Do the potential lvalues first *)
+ | A.VARIABLE n -> begin
+ (* Look up in the environment *)
+ try
+ let envdata = H.find env n in
+ match envdata with
+ EnvVar vi, _ ->
+ (* 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
+ finishExp empty tag typ
+ else begin
+ let ei =
+ match unrollType typ with
+ TEnum(ei, _) -> ei
+ | _ -> assert false
+ in
+ finishExp empty (Const (CEnum(tag, n, ei))) typ
+ end
+
+ | _ -> raise Not_found
+ with Not_found -> begin
+ 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" n)
+ else
+ E.s (error "Cannot resolve variable %s.\n" n)
+ end
+ end
+ | A.INDEX (e1, e2) -> begin
+ (* Recall that doExp turns arrays into StartOf pointers *)
+ let (se1, e1', t1) = doExp false e1 (AExp None) in
+ let (se2, e2', t2) = doExp false e2 (AExp None) in
+ let se = se1 @@ se2 in
+ let (e1'', t1, e2'', tresult) =
+ (* Either e1 or e2 can be the pointer *)
+ match unrollType t1, unrollType t2 with
+ TPtr(t1e,_), (TInt _|TEnum _) -> e1', t1, e2', t1e
+ | (TInt _|TEnum _), TPtr(t2e,_) -> e2', t2, e1', t2e
+ | _ ->
+ 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
+ StartOf array -> (* A real array indexing operation *)
+ addOffsetLval (Index(e2'', NoOffset)) array
+ | _ -> (* Turn into *(e1 + e2) *)
+ mkMem (BinOp(IndexPI, e1'', e2'', t1)) NoOffset
+ in
+ (* Do some optimization of StartOf *)
+ finishExp se (Lval res) tresult
+
+ 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 =
+ 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))
+ tresult
+
+ (* e.str = (& e + off(str)). If e = (be + beoff) then e.str = (be
+ * + beoff + off(str)) *)
+ | A.MEMBEROF (e, str) ->
+ (* member of is actually allowed if we only take the address *)
+ (* if isconst then
+ E.s (error "MEMBEROF in constant"); *)
+ let (se, e', t') = doExp false e (AExp None) in
+ 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 =
+ match unrollType t' with
+ TComp (comp, _) -> findField str comp.cfields
+ | _ -> E.s (error "expecting a struct with field %s" str)
+ in
+ 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) ->
+ if asconst then
+ ignore (warn "MEMBEROFPTR in constant");
+ let (se, e', t') = doExp false e (AExp None) in
+ 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
+ TComp (comp, _) -> findField str comp.cfields
+ | 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 field_type = typeOf lv' in
+ finishExp se lv' field_type
+
+ | A.CONSTANT ct -> begin
+ let hasSuffix str =
+ let l = String.length str in
+ fun s ->
+ let ls = String.length s in
+ l >= ls && s = String.uppercase (String.sub str (l - ls) ls)
+ in
+ match ct with
+ A.CONST_INT str -> begin
+ let res = parseInt str in
+ finishExp empty res (typeOf res)
+ end
+
+(*
+ | A.CONST_WSTRING wstr ->
+ let len = List.length wstr in
+ let wchar_t = !wcharType in
+ (* 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 =
+ 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) =
+ match s with
+ [] -> []
+ | wc::rest ->
+ let wc_cilexp = Const (CInt64(wc, IInt, None)) in
+ (Index(integer idx, NoOffset),
+ SingleInit (makeCast wc_cilexp wchar_t))
+ :: loop (idx + 1) rest
+ in
+ (* Add the definition for the array *)
+ cabsPushGlobal (GVar(ws,
+ {init = Some (CompoundInit(ws_t,
+ loop 0 wstr))},
+ !currentLoc));
+ finishExp empty (StartOf(Var ws, NoOffset))
+ (TPtr(wchar_t, []))
+ *)
+
+ | A.CONST_WSTRING (ws: int64 list) ->
+ let res = Const(CWStr ((* intlist_to_wstring *) ws)) in
+ finishExp empty res (typeOf res)
+
+ | A.CONST_STRING s ->
+ (* Maybe we burried __FUNCTION__ in there *)
+ let s' =
+ try
+ let start = String.index s (Char.chr 0) in
+ let l = String.length s in
+ let tofind = (String.make 1 (Char.chr 0)) ^ "__FUNCTION__" in
+ let past = start + String.length tofind in
+ if past <= l &&
+ String.sub s start (String.length tofind) = tofind then
+ (if start > 0 then String.sub s 0 start else "") ^
+ !currentFunctionFDEC.svar.vname ^
+ (if past < l then String.sub s past (l - past) else "")
+ else
+ s
+ with Not_found -> s
+ in
+ let res = 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
+
+ | A.CONST_WCHAR char_list ->
+ (* matth: I can't see a reason for a list of more than one char
+ * here, since the kinteger64 below will take only the lower 16
+ * bits of value. ('abc' makes sense, because CHAR constants have
+ * type int, and so more than one char may be needed to represent
+ * the value. But L'abc' has type wchar, and so is equivalent to
+ * L'c'). But gcc allows L'abc', so I'll leave this here in case
+ * I'm missing some architecture dependent behavior. *)
+ let value = reduce_multichar !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
+ String.sub str 0 (l - 1), FLongDouble
+ else if hasSuffix "F" then
+ String.sub str 0 (l - 1), FFloat
+ else if hasSuffix "D" then
+ String.sub str 0 (l - 1), FDouble
+ else
+ str, FDouble
+ in
+ 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 %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.TYPE_SIZEOF (bt, dt) ->
+ let typ = doOnlyType bt dt in
+ finishExp empty (SizeOf(typ)) !typeOfSizeOf
+
+ (* 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), _ ->
+ finishExp empty (SizeOfStr s) !typeOfSizeOf
+ | _ -> E.s (bug "cabs2cil: sizeOfStr")
+ end
+
+ | A.EXPR_SIZEOF e ->
+ (* Allow non-constants in sizeof *)
+ (* Do not convert arrays and functions into pointers. *)
+ let (se, e', t) = doExp false e AExpLeaveArrayFun in
+(*
+ ignore (E.log "sizeof: %a e'=%a, t=%a\n"
+ 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
+ if isNotEmpty se then
+ ignore (warn "Warning: Dropping side-effect in EXPR_SIZEOF\n");
+*)
+ let size =
+ match e' with (* If we are taking the sizeof an
+ * array we must drop the StartOf *)
+ StartOf(lv) -> SizeOfE (Lval(lv))
+
+ (* 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'
+ end
+ | _ -> SizeOfE e'
+ in
+ finishExp empty size !typeOfSizeOf
+
+ | A.TYPE_ALIGNOF (bt, dt) ->
+ let typ = doOnlyType bt dt in
+ finishExp empty (AlignOf(typ)) !typeOfSizeOf
+
+ | 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
+ if isNotEmpty se then
+ ignore (warn "Warning: Dropping side-effect in EXPR_ALIGNOF\n");
+*)
+ let e'' =
+ match e' with (* If we are taking the alignof an
+ * array we must drop the StartOf *)
+ StartOf(lv) -> Lval(lv)
+
+ | _ -> e'
+ in
+ finishExp empty (AlignOfE(e'')) !typeOfSizeOf
+
+ | A.CAST ((specs, dt), ie) ->
+ let s', dt', ie' = preprocessCast specs dt ie in
+ (* We know now that we can do s' and dt' many times *)
+ let typ = doOnlyType s' dt' in
+ let what' =
+ match what with
+ 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
+ * continue with a Set *)
+ 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) =
+ 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
+ * variable *)
+ let newvar = "__constr_expr_" ^ string_of_int (!constrExprId) in
+ incr constrExprId;
+ let spec_res = doSpecList "" s' in
+ let se1 =
+ if !scopes == [] then begin
+ (* This is a global. Mark the new vars as static *)
+ let spec_res' =
+ let t, sto, inl, attrs = spec_res in
+ t, Static, inl, attrs
+ in
+ ignore (createGlobal spec_res'
+ ((newvar, dt', [], cabslu), ie'));
+ empty
+ end else
+ createLocal spec_res ((newvar, dt', [], cabslu), ie')
+ in
+ (* 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
+ * the finishExp at the end of this case *)
+ 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
+ * between arrays or structures. *)
+ (se1 @@ se, e2, t2), false
+ end
+ in
+ let (t'', e'') =
+ match typ with
+ TVoid _ when what' = ADrop -> (t', e') (* strange GNU thing *)
+ | _ ->
+ (* Do this to check the cast, unless we are sure that we do not
+ * need the check. *)
+ let newtyp, newexp =
+ if needcast then
+ castTo ~fromsource:true t' typ e'
+ else
+ t', e'
+ in
+ newtyp, newexp
+ in
+ finishExp se e'' t''
+
+ | 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'' =
+ match e' with
+ | Const(CInt64(i, ik, _)) -> kinteger64 ik (Int64.neg i)
+ | _ -> UnOp(Neg, makeCastT e' t tres, tres)
+ in
+ finishExp se e'' tres
+ else
+ if isArithmeticType t then
+ finishExp se (UnOp(Neg,e',t)) t
+ else
+ E.s (error "Unary - on a non-arithmetic type")
+
+ | 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
+ 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.ADDROF, e) -> begin
+ match e with
+ A.COMMA el -> (* GCC extension *)
+ doExp false
+ (A.COMMA (replaceLastInList el (fun e -> A.UNARY(A.ADDROF, e))))
+ what
+ | A.QUESTION (e1, e2, e3) -> (* GCC extension *)
+ 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
+ TFun(_, _, true, _) -> true | _ -> false) ->
+ (* We are in an old-style variable argument function and we are
+ * taking the address of the argument that was removed while
+ * processing the function type. We compute the address based on
+ * the address of the last real argument *)
+ if !msvcMode then begin
+ let rec getLast = function
+ [] -> E.s (unimp "old-style variable argument function without real arguments")
+ | [a] -> a
+ | _ :: 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
+ * argument. Round up to a multiple of 4 *)
+ let sizeOfLast =
+ (((bitsSizeOf last.vtype) + 31) / 32) * 4
+ in
+ 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
+ * of the local ! *)
+
+ doExp asconst
+ (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.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)) ->
+ finishExp se (mkAddrOfAndMark x) (TPtr(t, []))
+
+ | StartOf (lv) ->
+ let tres = TPtr(typeOfLval lv, []) in (* pointer to array *)
+ finishExp se (mkAddrOfAndMark lv) tres
+
+ (* 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
+
+ | _ -> E.s (error "Expected lval for ADDROF. Got %a@!"
+ d_plainexp e')
+ end
+ | _ -> E.s (error "Unexpected operand for addrof")
+ end
+ | A.UNARY((A.PREINCR|A.PREDECR) as uop, e) -> begin
+ match e with
+ A.COMMA el -> (* GCC extension *)
+ 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),
+ 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.CAST _ (* A GCC extension *)) -> begin
+ let uop' = if uop = A.PREINCR then PlusA else MinusA in
+ 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
+ Lval x -> x
+ | 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,
+ !currentLoc)))
+ e'
+ tresult (* Should this be t instead ??? *)
+ end
+ | _ -> E.s (error "Unexpected operand for prefix -- or ++")
+ end
+
+ | A.UNARY((A.POSINCR|A.POSDECR) as uop, e) -> begin
+ match e with
+ A.COMMA el -> (* GCC extension *)
+ 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), 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.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
+ 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
+ * 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')
+ ++ (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),
+ !currentLoc)))
+ result
+ tresult (* Should this be t instead ??? *)
+ end
+ | _ -> E.s (error "Unexpected operand for suffix ++ or --")
+ end
+
+ | A.BINARY(A.ASSIGN, e1, e2) -> begin
+ match e1 with
+ A.COMMA el -> (* GCC extension *)
+ 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),
+ 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 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
+ Lval x -> x
+ | _ -> E.s (error "Expected lval for assignment. Got %a\n"
+ d_plainexp e1')
+ in
+ (* Catch the case of an lval that might depend on itself,
+ e.g. p[p[0]] when p[0] == 0. We need to use a temporary
+ here if the result of the expression will be used:
+ tmp := e2; lv := tmp; use tmp as the result
+ Test: small1/assign.c *)
+ let needsTemp = match what, lv with
+ (ADrop|AType), _ -> false
+ | _, (Mem e, off) -> not (isConstant e)
+ || not (isConstantOffset off)
+ | _, (Var _, off) -> not (isConstantOffset off)
+ in
+ let tmplv, se3 =
+ if needsTemp then
+ let descr = (dd_lval () lv) in
+ let tmp = newTempVar descr true lvt in
+ var tmp, i2c (Set(lv, Lval(var tmp), !currentLoc))
+ else
+ lv, empty
+ in
+ let (se2, e'', t'') = doExp false e2 (ASet(tmplv, lvt)) in
+ finishExp (se1 @@ se2 @@ se3) (Lval tmplv) lvt
+ 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) ->
+ 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
+ A.COMMA el -> (* GCC extension *)
+ 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),
+ A.BINARY(bop, e3q, e2)))
+ what
+ | A.PAREN e1 -> doExp asconst (A.BINARY(bop,e1,e2)) what
+ | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *)
+ A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ |
+ A.CAST _ (* GCC extension *) ) -> begin
+ if asconst then
+ ignore (warn "op_ASSIGN in constant");
+ let bop' = match bop with
+ A.ADD_ASSIGN -> PlusA
+ | A.SUB_ASSIGN -> MinusA
+ | A.MUL_ASSIGN -> Mult
+ | A.DIV_ASSIGN -> Div
+ | A.MOD_ASSIGN -> Mod
+ | A.BAND_ASSIGN -> BAnd
+ | A.BOR_ASSIGN -> BOr
+ | A.XOR_ASSIGN -> BXor
+ | A.SHL_ASSIGN -> Shiftlt
+ | A.SHR_ASSIGN -> Shiftrt
+ | _ -> E.s (error "binary +=")
+ in
+ let (se1, e1', t1) = doExp false e1 (AExp None) in
+ let lv1 =
+ match e1' with
+ Lval x -> x
+ | 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
+ * different than t1 if lv1 was a Cast *)
+ let _, result' = castTo tresult (typeOfLval lv1) result in
+ (* The type of the result is the type of the left-hand side *)
+ finishExp (se1 @@ se2 +++
+ (Set(lv1, result', !currentLoc)))
+ e1'
+ 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)) ->
+ finishExp se (if isConstTrue c then one else zero) intType
+ | CEExp (se, (UnOp(LNot, _, _) as e)) ->
+ (* already normalized to 0 or 1 *)
+ finishExp se e intType
+ | CEExp (se, e) ->
+ let e' =
+ let te = typeOf e in
+ let _, zte = castTo intType te zero in
+ BinOp(Ne, e, zte, te)
+ in
+ finishExp se e' intType
+ | _ ->
+ let tmp =
+ var (newTempVar (text "<boolean expression>") true intType)
+ in
+ finishExp (compileCondExp ce
+ (empty +++ (Set(tmp, integer 1,
+ !currentLoc)))
+ (empty +++ (Set(tmp, integer 0,
+ !currentLoc))))
+ (Lval tmp)
+ intType
+ end
+
+ | 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
+ * 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 =
+ * AExp None *)
+ with Not_found -> begin
+ ignore (warnOpt "Calling function %s without prototype." n);
+ let ftype = TFun(intType, None, false,
+ [Attr("missingproto",[])]) in
+ (* Add a prototype to the environment *)
+ let proto, _ =
+ makeGlobalVarinfo false (makeGlobalVar n ftype) in
+ (* Make it EXTERN *)
+ proto.vstorage <- Extern;
+ IH.add noProtoFunctions proto.vid true;
+ (* Add it to the file as well *)
+ cabsPushGlobal (GVarDecl (proto, !currentLoc));
+ (empty, Lval(var proto), ftype)
+ end
+ end
+ | _ -> doExp false f (AExp None)
+ in
+ (* Get the result type and the argument types *)
+ 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
+ * explicit *)
+ let f'' =
+ match f' with
+ AddrOf lv -> Lval(lv)
+ | _ -> Lval(mkMem f' NoOffset)
+ in
+ (rt,at,isvar, f'')
+ | 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"
+ d_exp f' d_type x)
+ in
+ let argTypesList = argsToList argTypes in
+ (* Drop certain qualifiers from the result type *)
+ let resType' = typeRemoveAttributes ["warn_unused_result"] resType in
+ (* Before we do the arguments we try to intercept a few builtins. For
+ * these we have defined then with a different type, so we do not
+ * want to give warnings. We'll just leave the arguments of these
+ * functions alone*)
+ let isSpecialBuiltin =
+ match f'' 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"
+ | _ -> false
+ in
+
+ (** 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
+ (* 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
+ (* add the instruction to the chunk *)
+ (* change the expression to be the temporary *)
+ (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
+ -> (chunk * exp list) = function
+ | ([], []) -> (empty, [])
+
+ | args, [] ->
+ if not isSpecialBuiltin then
+ ignore (warnOpt
+ "Too few arguments in call to %a."
+ d_exp f');
+ (empty, [])
+
+ | ((_, at, _) :: atypes, a :: args) ->
+ let (ss, args') = loopArgs (atypes, args) in
+ (* Do not cast as part of translating the argument. We let
+ * the castTo do this work. This was necessary for
+ * test/small1/union5, in which a transparent union is passed
+ * as an argument *)
+ let (sa, a', att) = force_right_to_left_evaluation
+ (doExp false a (AExp None)) in
+ let (_, a'') = castTo att at a' in
+ (ss @@ sa, a'' :: args')
+
+ | ([], args) -> (* No more types *)
+ 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
+ [] -> (empty, [])
+ | a :: args ->
+ let (ss, args') = loop args in
+ let (sa, a', at) = force_right_to_left_evaluation
+ (doExp false a (AExp None)) in
+ (ss @@ sa, a' :: args')
+ in
+ loop args
+ in
+ let (sargs, args') = loopArgs (argTypesList, args) in
+ (* Setup some pointer to the elements of the call. We may change
+ * these below *)
+ let prechunk: chunk ref = ref (sf @@ sargs) in (* comes before *)
+
+ (* Do we actually have a call, or an expression? *)
+ let piscall: bool ref = ref true in
+
+ let pf: exp ref = ref f'' in (* function to call *)
+ let pargs: exp list ref = ref args' in (* arguments *)
+ let pis__builtin_va_arg: bool ref = ref false in
+ let pwhat: expAction ref = ref what in (* what to do with result *)
+
+ let 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 =
+ match !currentFunctionFDEC.svar.vtype with
+ TFun(_, Some args, true, _) -> begin
+ match List.rev args with
+ (last_par_name, _, _) :: _ -> last_par_name
+ | _ -> ""
+ end
+ | _ -> ""
+ in
+
+ (* Try to intercept some builtins *)
+ (match !pf with
+ Lval(Var fv, NoOffset) -> begin
+ if fv.vname = "__builtin_va_arg" then begin
+ match !pargs with
+ marker :: SizeOf resTyp :: _ -> begin
+ (* Make a variable of the desired type *)
+ let destlv, destlvtyp =
+ match !pwhat with
+ ASet (lv, lvt) -> lv, lvt
+ | _ -> var (newTempVar nil true resTyp), resTyp
+ in
+ pwhat := (ASet (destlv, destlvtyp));
+ pargs := [marker; SizeOf resTyp;
+ CastE(voidPtrType, AddrOf destlv)];
+ pis__builtin_va_arg := true;
+ end
+ | _ ->
+ ignore (warn "Invalid call to %s\n" fv.vname);
+ end else if fv.vname = "__builtin_stdarg_start" ||
+ fv.vname = "__builtin_va_start" then begin
+ match !pargs with
+ marker :: last :: [] -> begin
+ let isOk =
+ match dropCasts last with
+ Lval (Var lastv, NoOffset) ->
+ lastv.vname = getNameLastFormal ()
+ | _ -> false
+ in
+ if not isOk then
+ ignore (warn "The second argument in call to %s should be the last formal argument\n" fv.vname);
+
+ (* Check that "lastv" is indeed the last variable in the
+ * prototype and then drop it *)
+ pargs := [ marker ]
+ end
+ | _ ->
+ ignore (warn "Invalid call to %s\n" fv.vname);
+
+ (* We have to turn uses of __builtin_varargs_start into uses
+ * of __builtin_stdarg_start (because we have dropped the
+ * __builtin_va_alist argument from this function) *)
+
+ end else if fv.vname = "__builtin_varargs_start" then begin
+ (* Lookup the prototype for the replacement *)
+ let v, _ =
+ try lookupGlobalVar "__builtin_stdarg_start"
+ with Not_found -> 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
+ last :: [] -> begin
+ let isOk =
+ match dropCasts last with
+ Lval (Var lastv, NoOffset) ->
+ lastv.vname = getNameLastFormal ()
+ | _ -> false
+ in
+ if not isOk then
+ ignore (warn "The argument in call to %s should be the last formal argument\n" fv.vname);
+
+ pargs := [ ]
+ end
+ | _ ->
+ ignore (warn "Invalid call to %s\n" fv.vname);
+ end else if fv.vname = "__builtin_constant_p" then begin
+ (* Drop the side-effects *)
+ prechunk := empty;
+
+ (* Constant-fold the argument and see if it is a constant *)
+ (match !pargs with
+ [ arg ] -> begin
+ match constFold true arg with
+ Const _ -> piscall := false;
+ pres := integer 1;
+ prestype := intType
+
+ | _ -> piscall := false;
+ pres := integer 0;
+ prestype := intType
+ end
+ | _ ->
+ ignore (warn "Invalid call to builtin_constant_p"));
+ end
+ end
+ | _ -> ());
+
+
+ (* Now we must finish the call *)
+ if !piscall then begin
+ let addCall (calldest: lval option) (res: exp) (t: typ) =
+ prechunk := !prechunk +++
+ (Call(calldest, !pf, !pargs, !currentLoc));
+ pres := res;
+ prestype := t
+ in
+ match !pwhat with
+ ADrop -> addCall None zero intType
+
+ | AType -> prestype := resType'
+
+ | ASet(lv, vtype) when !pis__builtin_va_arg ->
+ (* Make an exception here for __builtin_va_arg *)
+ addCall None (Lval(lv)) vtype
+
+ | 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'' =
+ match !pwhat with
+ AExp (Some t) when !doCollapseCallCast -> t
+ | _ -> resType'
+ in
+ 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
+ * specific call. We will use this in collapseCallCast. *)
+ IH.add callTempVars tmp.vid ();
+ addCall (Some (var tmp)) (Lval(var tmp)) restype''
+ end
+ end;
+
+ finishExp !prechunk !pres !prestype
+
+
+ | A.COMMA el ->
+ if asconst then
+ ignore (warn "COMMA in constant");
+ let rec loop sofar = function
+ [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.
+ * GN: it seems it does *)
+*)
+ | 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 ->
+ if asconst then
+ ignore (warn "QUESTION with ADrop in constant");
+ let (se3,_,_) = doExp false e3 ADrop in
+ 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
+ * the type of the result *)
+ let se2, e2'o (* is an option. None means use e1 *), 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
+ to bool *)
+ | _ -> empty, None, intType
+ end
+ | _ ->
+ let se2, e2', t2 = doExp asconst e2 (AExp None) in
+ se2, 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
+ match ce1 with
+ 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 ->
+ begin
+ match e2'o with
+ None -> (* use e1' *)
+ finishExp (se1 @@ se2) (snd (castTo t2 tresult e1')) tresult
+ | Some e2' ->
+ finishExp (se1 @@ se2) (snd (castTo t2 tresult e2')) tresult
+ end
+
+ | _ -> (* Use a conditional *) begin
+ 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))
+ se3 e3' t3 in
+ finishExp (se1 @@ ifChunk (Lval(tmp)) !currentLoc
+ skipChunk se3)
+ (Lval(tmp))
+ tresult
+ | 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))
+ se2 e2' t2 in
+ 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 *)
+ doExp isconst e1 (AExp None)
+ | _ -> 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
+ * 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
+ else makeCastT e2' t2' tresult (* We know se2 is empty *)
+ in
+ let e3'' = makeCastT e3' t3' tresult in
+ let resexp =
+ match e1' with
+ Const(CInt64(i, _, _)) when i <> Int64.zero -> e2''
+ | Const(CInt64(z, _, _)) when z = Int64.zero -> e3''
+ | _ -> Question(e1', e2'', e3'')
+ in
+ finishExp se1 resexp tresult
+ end else begin (* Now use a conditional *)
+ 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
+ finishExp (se1 @@ ifChunk (Lval(tmp)) lu
+ skipChunk se3)
+ (Lval(tmp))
+ tresult
+ | _ ->
+ let lv, lvt =
+ match what with
+ | ASet (lv, lvt) -> lv, lvt
+ | _ ->
+ let tmp = newTempVar tresult in
+ var tmp, tresult
+ in
+ (* Now do e2 and e3 for real *)
+ let (se2, _, _) = doExp isconst e2 (ASet(lv, lvt)) in
+ let (se3, _, _) = doExp isconst e3 (ASet(lv, lvt)) in
+ finishExp (doCondition isconst e1 se2 se3) (Lval(lv)) tresult
+ end
+*)
+ end
+
+ | A.GNU_BODY b -> begin
+ (* Find the last A.COMPUTATION and remember it. This one is invoked
+ * on the reversed list of statements. *)
+ let rec findLastComputation = function
+ s :: _ ->
+ let rec findLast = function
+ A.SEQUENCE (_, s, loc) -> findLast s
+ | CASE (_, s, _) -> findLast s
+ | CASERANGE (_, _, s, _) -> findLast s
+ | LABEL (_, s, _) -> findLast s
+ | (A.COMPUTATION _) as s -> s
+ | _ -> raise Not_found
+ in
+ findLast s
+ | [] -> raise Not_found
+ in
+ (* Save the previous data *)
+ let old_gnu = ! gnu_body_result in
+ let lastComp, isvoidbody =
+ match what with
+ ADrop -> (* We are dropping the result *)
+ A.NOP cabslu, true
+ | _ ->
+ 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
+ (* Prepare some data to be filled by doExp *)
+ let data : (exp * typ) option ref = ref None in
+ gnu_body_result := (lastComp, data);
+
+ let se = doBody b in
+
+ gnu_body_result := old_gnu;
+ match !data with
+ None when isvoidbody -> finishExp se zero voidType
+ | None -> E.s (bug "Cannot find COMPUTATION in GNU.body")
+ | Some (e, t) -> finishExp se e t
+ end
+
+ | A.LABELADDR l -> begin (* GCC's taking the address of a label *)
+ let l = lookupLabel l in (* To support locallly declared labels *)
+ let addrval =
+ try H.find gotoTargetHash l
+ with Not_found -> begin
+ let res = !gotoTargetNextAddr in
+ incr gotoTargetNextAddr;
+ H.add gotoTargetHash l res;
+ res
+ end
+ in
+ finishExp empty (makeCast (integer addrval) voidPtrType) voidPtrType
+ end
+
+ | A.EXPR_PATTERN _ -> E.s (E.bug "EXPR_PATTERN in cabs2cil input")
+
+ with e when continueOnError -> begin
+ ignore (E.log "error in doExp (%s)@!" (Printexc.to_string e));
+ E.hadErrors := true;
+ (i2c (dInstr (dprintf "booo_exp(%t)" d_thisloc) !currentLoc),
+ integer 0, intType)
+ end
+
+(* 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 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
+ in
+ 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
+ in
+ let doIntegralArithmetic () =
+ let tres = unrollType (arithmeticConversion t1 t2) in
+ match tres with
+ TInt _ ->
+ tres,
+ optConstFoldBinOp false bop
+ (makeCastT e1 t1 tres) (makeCastT e2 t2 tres) tres
+ | _ -> E.s (error "%a operator on a non-integer type" d_binop bop)
+ in
+ 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
+ in
+
+ match bop with
+ (Mult|Div) -> doArithmetic ()
+ | (Mod|BAnd|BOr|BXor) -> doIntegralArithmetic ()
+ | (Shiftlt|Shiftrt) -> (* ISO 6.5.7. Only integral promotions. The result
+ * has the same type as the left hand side *)
+ if !msvcMode then
+ (* MSVC has a bug. We duplicate it here *)
+ doIntegralArithmetic ()
+ else
+ let t1' = integralPromotion t1 in
+ let t2' = integralPromotion t2 in
+ t1',
+ optConstFoldBinOp false bop (makeCastT e1 t1 t1') (makeCastT e2 t2 t2') t1'
+
+ | (PlusA|MinusA)
+ when isArithmeticType t1 && isArithmeticType t2 -> doArithmetic ()
+ | (Eq|Ne|Lt|Le|Ge|Gt)
+ when isArithmeticType t1 && isArithmeticType t2 ->
+ doArithmeticComp ()
+ | PlusA when isPointerType t1 && isIntegralType t2 ->
+ t1,
+ 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
+ | MinusA when isPointerType t1 && isPointerType t2 ->
+ let commontype = t1 in
+ intType,
+ optConstFoldBinOp false MinusPP (makeCastT e1 t1 commontype)
+ (makeCastT e2 t2 commontype) intType
+ | (Le|Lt|Ge|Gt|Eq|Ne) when isPointerType t1 && isPointerType t2 ->
+ pointerComparison e1 t1 e2 t2
+ | (Eq|Ne) when isPointerType t1 && isZero e2 ->
+ pointerComparison e1 t1 (makeCastT zero !upointType t1) t1
+ | (Eq|Ne) when isPointerType t2 && isZero e1 ->
+ pointerComparison (makeCastT zero !upointType t2) t2 e2 t2
+
+ | (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 ->
+ ignore (warnOpt "Comparison of zero and va_list");
+ pointerComparison (makeCastT zero !upointType 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
+ | (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
+
+ | _ -> E.s (error "Invalid operands to binary operator: %a\n" 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
+ * new statements. *)
+and doCondExp (asconst: bool) (** Try to evaluate the conditional expression
+ * to TRUE or FALSE, because it occurs in a
+ * constant *)
+ (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)
+ | CEOr (ce1, ce2) -> CEOr (addChunkBeforeCE c0 ce1, ce2)
+ | CENot ce1 -> CENot (addChunkBeforeCE c0 ce1)
+ in
+ let rec canDropCE = function
+ CEExp (c, e) -> canDrop c
+ | CEAnd (ce1, ce2) | CEOr (ce1, ce2) -> canDropCE ce1 && canDropCE ce2
+ | CENot (ce1) -> canDropCE ce1
+ in
+ 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
+ addChunkBeforeCE se1 ce2
+ else
+ (* se2 might contain labels so we cannot always drop it *)
+ if canDropCE ce2 then
+ ce1
+ else
+ CEAnd (ce1, ce2)
+ | CEExp(se1, e1'), CEExp (se2, e2') when
+ !useLogicalOperators && isEmpty se1 && isEmpty se2 ->
+ CEExp (empty, BinOp(LAnd,
+ makeCast e1' intType,
+ makeCast e2' intType, intType))
+ | _ -> CEAnd (ce1, ce2)
+ end
+
+ | A.BINARY (A.OR, e1, e2) -> begin
+ 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
+ addChunkBeforeCE se1 ce2
+ else
+ (* se2 might contain labels so we cannot drop it *)
+ if canDropCE ce2 then
+ ce1
+ else
+ CEOr (ce1, ce2)
+
+ | CEExp (se1, e1'), CEExp (se2, e2') when
+ !useLogicalOperators && isEmpty se1 && isEmpty se2 ->
+ CEExp (empty, BinOp(LOr, makeCast e1' intType,
+ makeCast e2' intType, 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)
+ else
+ CEExp (se1, zero)
+ | CEExp (se1, e) when isEmpty se1 ->
+ let t = typeOf e in
+ if not ((isPointerType t) || (isArithmeticType t))then
+ E.s (error "Bad operand to !");
+ CEExp (empty, UnOp(LNot, e, intType))
+
+ | 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
+ | CEAnd (ce1, ce2) ->
+ let (sf1, sf2) =
+ (* If sf is small then will copy it *)
+ try (sf, duplicateChunk sf)
+ with Failure _ ->
+ let lab = newLabelName "_L" in
+ (gotoChunk lab lu, 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) =
+ (* If st is small then will copy it *)
+ try (st, duplicateChunk st)
+ with Failure _ ->
+ let lab = newLabelName "_L" in
+ (gotoChunk lab lu, 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
+ 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
+ * eliminate the conditional *)
+ (e: A.expression)
+ (st: chunk)
+ (sf: chunk) : chunk =
+ compileCondExp (doCondExp isconst e) st sf
+
+
+and doPureExp (e : A.expression) : exp =
+ let (se, e', _) = doExp true e (AExp None) in
+ if isNotEmpty se then
+ E.s (error "doPureExp: not pure");
+ e'
+
+and doInitializer
+ (vi: varinfo)
+ (inite: A.init_expression)
+ (* Return the accumulated chunk, the initializer and the new type (might be
+ * different for arrays) *)
+ : chunk * init * typ =
+
+ (* Setup the pre-initializer *)
+ let topPreInit = ref NoInitPre in
+ if debugInit then
+ 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
+ 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 so = makeSubobj vi vi.vtype NoOffset in
+ doInit vi.vglob topSetupInit so empty [ (A.NEXT_INIT, inite) ]
+ in
+ 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
+ ignore (E.log "Collecting the initializer for %s\n" vi.vname);
+ let (init, typ'') = collectInitializer !topPreInit typ' in
+ if debugInit then
+ 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
+ * tail-recursion because these things can be big. *)
+and doInit
+ (isconst: bool)
+ (setone: offset -> exp -> unit) (* Use to announce an intializer *)
+ (so: subobj)
+ (acc: chunk)
+ (initl: (A.initwhat * A.init_expression) list)
+
+ (* Return the resulting chunk along with some unused initializers *)
+ : chunk * (A.initwhat * A.init_expression) list =
+
+ let whoami () = d_lval () (Var so.host, so.soOff) in
+
+ let initl1 =
+ match initl with
+ | (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
+ * appears as a single initializer. Ignore the cast *)
+ let initl2 =
+ match initl1 with
+ (what,
+ A.SINGLE_INIT (A.CAST ((specs, dt), A.COMPOUND_INIT ci))) :: rest ->
+ let s', dt', ie' = preprocessCast specs dt (A.COMPOUND_INIT ci) in
+ let typ = doOnlyType s' dt' in
+ if (typeSigNoAttrs typ) = (typeSigNoAttrs so.soTyp) then
+ (* Drop the cast *)
+ (what, A.COMPOUND_INIT ci) :: rest
+ else
+ (* Keep the cast. A new var will be created to hold
+ the intermediate value. *)
+ initl1
+ | _ -> initl1
+ in
+ let allinitl = initl2 in
+
+ if debugInit then begin
+ 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
+ [] -> ignore (E.log "[]")
+ | (what, ie) :: _ ->
+ withCprint
+ Cprint.print_init_expression (A.COMPOUND_INIT [(what, ie)]));
+ ignore (E.log "\n");
+ end;
+ match unrollType so.soTyp, allinitl with
+ _, [] -> acc, [] (* No more initializers return *)
+
+ (* No more subobjects *)
+ | _, (A.NEXT_INIT, _) :: _ when so.eof -> acc, allinitl
+
+
+ (* If we are at an array of characters and the initializer is a
+ * string literal (optionally enclosed in braces) then explode the
+ * string into characters *)
+ | TArray(bt, leno, _),
+ (A.NEXT_INIT,
+ (A.SINGLE_INIT(A.CONSTANT (A.CONST_STRING s))|
+ 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
+ | TInt _ ->
+ (*Base type is a scalar other than char. Maybe a wchar_t?*)
+ E.s (error "Using a string literal to initialize something other than a character array.\n")
+ | _ -> false (* OK, this is probably an array of strings. Handle *)
+ ) (* it with the other arrays below.*)
+ ->
+ let charinits =
+ let init c = A.NEXT_INIT, A.SINGLE_INIT(A.CONSTANT (A.CONST_CHAR [c]))
+ in
+ let collector =
+ (* ISO 6.7.8 para 14: final NUL added only if no size specified, or
+ * if there is room for it; btw, we can't rely on zero-init of
+ * globals, since this array might be a local variable *)
+ if ((isNone leno) or ((String.length s) < (integerArrayLength leno)))
+ then ref [init Int64.zero]
+ else ref []
+ in
+ for pos = String.length s - 1 downto 0 do
+ collector := init (Int64.of_int (Char.code (s.[pos]))) :: !collector
+ done;
+ !collector
+ in
+ (* Create a separate object for the array *)
+ let so' = makeSubobj so.host so.soTyp so.soOff in
+ (* Go inside the array *)
+ let leno = integerArrayLength leno in
+ so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)];
+ normalSubobj so';
+ let acc', initl' = doInit isconst setone so' acc charinits in
+ if initl' <> [] then
+ ignore (warn "Too many initializers for character array %t" whoami);
+ (* Advance past the array *)
+ advanceSubobj so;
+ (* Continue *)
+ let res = doInit isconst setone so acc' restil in
+ res
+
+ (* If we are at an array of WIDE characters and the initializer is a
+ * WIDE string literal (optionally enclosed in braces) then explore
+ * the WIDE string into characters *)
+ (* [weimer] Wed Jan 30 15:38:05 PST 2002
+ * Despite what the compiler says, this match case is used and it is
+ * important. *)
+ | TArray(bt, leno, _),
+ (A.NEXT_INIT,
+ (A.SINGLE_INIT(A.CONSTANT (A.CONST_WSTRING s)) |
+ 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
+ (* compare bt to wchar_t, ignoring signed vs. unsigned *)
+ TInt _ when (bitsSizeOf bt') = (bitsSizeOf !wcharType) -> true
+ | TInt _ ->
+ (*Base type is a scalar other than wchar_t. Maybe a char?*)
+ E.s (error "Using a wide string literal to initialize something other than a wchar_t array.\n")
+ | _ -> 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.one in
+ 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.SINGLE_INIT(A.CONSTANT (A.CONST_INT (Int64.to_string c)))
+ in
+ (List.map init s) @
+ (
+ (* ISO 6.7.8 para 14: final NUL added only if no size specified, or
+ * if there is room for it; btw, we can't rely on zero-init of
+ * globals, since this array might be a local variable *)
+ if ((isNone leno) or ((List.length s) < (integerArrayLength leno)))
+ then [init Int64.zero]
+ else [])
+(*
+ 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.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
+ (* 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
+ (* 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 (!) *)
+ ignore (warn "Too many initializers for wchar_t array %t" whoami);
+ (* Advance past the array *)
+ advanceSubobj so;
+ (* Continue *)
+ doInit isconst setone so acc' restil
+
+ (* If we are at an array and we see a single initializer then it must
+ * be one for the first element *)
+ | TArray(bt, leno, 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;
+ 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
+ * then we must go on and try to initialize the fields *)
+ | 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)
+ then begin
+ (* Initialize the whole struct *)
+ setone so.soOff oneinit';
+ (* Advance to the next subobject *)
+ advanceSubobj so;
+ doInit isconst setone so (acc @@ se) restil
+ end else begin (* Try to initialize fields *)
+ let toinit = fieldsToInit comp None in
+ so.stack <- InComp(so.soOff, comp, toinit) :: so.stack;
+ normalSubobj so;
+ doInit isconst setone so acc allinitl
+ end
+
+ (* A scalar with a single initializer *)
+ | _, (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"
+ d_exp oneinit' d_type t' d_type so.soTyp);
+*)
+ setone so.soOff (if !insertImplicitCasts then
+ makeCastT oneinit' t' so.soTyp
+ else oneinit');
+ (* Move on *)
+ advanceSubobj so;
+ doInit isconst setone so (acc @@ se) restil
+
+
+ (* An array with a compound initializer. The initializer is for the
+ * array elements *)
+ | TArray (bt, leno, _), (A.NEXT_INIT, A.COMPOUND_INIT initl) :: restil ->
+ (* Create a separate object for the array *)
+ let so' = makeSubobj so.host so.soTyp so.soOff in
+ (* Go inside the array *)
+ let leno = integerArrayLength leno in
+ so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)];
+ normalSubobj so';
+ let acc', initl' = doInit isconst setone so' acc initl in
+ if initl' <> [] then
+ ignore (warn "Too many initializers for array %t" whoami);
+ (* Advance past the array *)
+ advanceSubobj so;
+ (* Continue *)
+ let res = doInit isconst setone so acc' restil in
+ res
+
+ (* We have a designator that tells us to select the matching union field.
+ * This is to support a GCC extension *)
+ | TComp(ci, _), [(A.NEXT_INIT,
+ A.COMPOUND_INIT [(A.INFIELD_INIT ("___matching_field",
+ A.NEXT_INIT),
+ A.SINGLE_INIT oneinit)])]
+ when not ci.cstruct ->
+ (* Do the expression to find its type *)
+ let _, _, t' = doExp 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 -> findField rest
+ in
+ let fi = findField ci.cfields in
+ (* 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 ->
+ (* Create a separate subobject iterator *)
+ let so' = makeSubobj so.host so.soTyp so.soOff in
+ (* Go inside the comp *)
+ so'.stack <- [InComp(so'.curOff, comp, fieldsToInit comp None)];
+ normalSubobj so';
+ let acc', initl' = doInit isconst setone so' acc initl in
+ if initl' <> [] then
+ ignore (warn "Too many initializers for structure");
+ (* Advance past the structure *)
+ advanceSubobj so;
+ (* Continue *)
+ doInit isconst setone so acc' restil
+
+ (* A scalar with a initializer surrounded by braces *)
+ | _, (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);
+ (* Move on *)
+ advanceSubobj so;
+ doInit isconst setone so (acc @@ se) restil
+
+ | 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 ->
+ (* Process a designator and position to the designated subobject *)
+ let rec addressSubobj
+ (so: subobj)
+ (what: A.initwhat)
+ (acc: chunk) : chunk =
+ (* Always start from the current element *)
+ so.stack <- []; so.eof <- false;
+ normalSubobj so;
+ let rec address (what: A.initwhat) (acc: chunk) : chunk =
+ match what with
+ A.NEXT_INIT -> acc
+ | A.INFIELD_INIT (fn, whatnext) -> begin
+ match unrollType so.soTyp with
+ TComp (comp, _) ->
+ let toinit = fieldsToInit comp (Some fn) in
+ so.stack <- InComp(so.soOff, comp, toinit) :: so.stack;
+ normalSubobj so;
+ address whatnext acc
+
+ | _ -> 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, _) ->
+ let ilen = integerArrayLength leno in
+ 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
+ "INDEX initialization designator is not a constant")
+ in
+ if nextidx' < 0 || nextidx' >= ilen then
+ E.s (error "INDEX designator is outside bounds");
+ 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 _ ->
+ 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) ->
+ 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', _) =
+ doExp true idxs (AExp(Some intType)) in
+ let (doidxe, idxe', _) =
+ doExp true idxe (AExp(Some intType)) in
+ if isNotEmpty doidxs || isNotEmpty doidxe then
+ E.s (error "Range designators are not constants\n");
+ let first, last =
+ match constFold true idxs', constFold true idxe' with
+ Const(CInt64(s, _, _)),
+ Const(CInt64(e, _, _)) ->
+ i64_to_int s, i64_to_int e
+ | _ -> E.s (error
+ "INDEX_RANGE initialization designator is not a constant")
+ in
+ if first < 0 || first > last then
+ E.s (error
+ "start index larger than end index in range initializer");
+ let rec loop (i: int) =
+ if i > last then restil
+ else
+ (top (A.ATINDEX_INIT(A.CONSTANT(A.CONST_INT(string_of_int i)),
+ A.NEXT_INIT)), ie)
+ :: loop (i + 1)
+ in
+ doInit isconst setone so acc (loop first)
+
+ | 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)
+
+
+(* 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 =
+ try
+ if debugGlobal then
+ ignore (E.log "createGlobal: %s\n" n);
+ (* Make a first version of the varinfo *)
+ let vi = makeVarInfoCabs ~isformal:false
+ ~isglobal:true (convLoc cloc) specs (n,ndt,a) in
+ (* Add the variable to the environment before doing the initializer
+ * because it might refer to the variable itself *)
+ if isFunctionType vi.vtype then begin
+ if inite != A.NO_INIT then
+ E.s (error "Function declaration with initializer (%s)\n"
+ vi.vname);
+ (* sm: if it's a function prototype, and the storage class *)
+ (* isn't specified, make it 'extern'; this fixes a problem *)
+ (* with no-storage prototype and static definition *)
+ if vi.vstorage = NoStorage then
+ (*(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"
+ 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
+ None
+ 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
+ E.s (error "global initializer");
+ Some ie'
+ in
+
+ try
+ let oldloc = H.find alreadyDefined vi.vname in
+ if init != None then begin
+ E.s (error "Global %s was already defined at %a\n"
+ vi.vname d_loc oldloc);
+ end;
+ 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
+ ignore (E.log " first definition for %s\n" vi.vname);
+ if init != None then begin
+ (* weimer: Sat Dec 8 17:43:34 2001
+ * MSVC NT Kernel headers include this lovely line:
+ * extern const GUID __declspec(selectany) \
+ * MOUNTDEV_MOUNTED_DEVICE_GUID = { 0x53f5630d, 0xb6bf, 0x11d0, { \
+ * 0x94, 0xf2, 0x00, 0xa0, 0xc9, 0x1e, 0xfb, 0x8b } };
+ * So we allow "extern" + "initializer" if "const" is
+ * around. *)
+ (* sm: As I read the ISO spec, in particular 6.9.2 and 6.7.8,
+ * "extern int foo = 3" is exactly equivalent to "int foo = 3";
+ * that is, if you put an initializer, then it is a definition,
+ * and "extern" is redundantly giving the name external linkage.
+ * gcc emits a warning, I guess because it is contrary to
+ * usual practice, but I think CIL warnings should be about
+ * semantic rather than stylistic issues, so I see no reason to
+ * even emit a warning. *)
+ if vi.vstorage = Extern then
+ vi.vstorage <- NoStorage; (* equivalent and canonical *)
+
+ H.add alreadyDefined vi.vname !currentLoc;
+ IH.remove mustTurnIntoDef vi.vid;
+ cabsPushGlobal (GVar(vi, {init = init}, !currentLoc));
+ vi
+ end else begin
+ if not (isFunctionType vi.vtype)
+ && not (IH.mem mustTurnIntoDef vi.vid) then
+ begin
+ IH.add mustTurnIntoDef vi.vid true
+ end;
+ if not alreadyInEnv then begin (* Only one declaration *)
+ (* If it has function type it is a prototype *)
+ cabsPushGlobal (GVarDecl (vi, !currentLoc));
+ vi
+ end else begin
+ if debugGlobal then
+ ignore (E.log " already in env %s\n" vi.vname);
+ vi
+ end
+ end
+ end
+ with e when continueOnError -> begin
+ ignore (E.log "error in createGlobal(%s: %a): %s\n" n
+ d_loc !currentLoc
+ (Printexc.to_string e));
+ 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@!"
+ n docEnv);
+ 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)
+ : chunk =
+ let loc = convLoc cloc in
+ (* Check if we are declaring a function *)
+ let rec isProto (dt: decl_type) : bool =
+ match dt with
+ | PROTO (JUSTBASE, _, _) -> true
+ | PROTO (x, _, _) -> isProto x
+ | PARENTYPE (_, x, _) -> isProto x
+ | ARRAY (x, _, _) -> isProto x
+ | PTR (_, x) -> isProto x
+ | _ -> false
+ in
+ match ndt with
+ (* Maybe we have a function prototype in local scope. Make it global. We
+ * do this even if the storage is Static *)
+ | _ when isProto ndt ->
+ let vi = createGlobal specs init_name in
+ (* Add it to the environment to shadow previous decls *)
+ addLocalToEnv n (EnvVar vi);
+ empty
+
+ | _ when sto = Static ->
+ 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
+ * existing globals or locals from this function. *)
+ let newname, _ = newAlphaName true "" n in
+ (* Make it global *)
+ let vi = makeVarInfoCabs ~isformal:false
+ ~isglobal:true
+ loc specs (newname, ndt, a) in
+ (* However, we have a problem if a real global appears later with the
+ * name that we have happened to choose for this one. Remember these names
+ * for later. *)
+ H.add staticLocals vi.vname vi;
+ (* Add it to the environment as a local so that the name goes out of
+ * scope properly *)
+ addLocalToEnv n (EnvVar vi);
+
+ (* Maybe this is an array whose length depends on something with local
+ scope, e.g. "static char device[ sizeof(local) ]".
+ Const-fold the type to fix this. *)
+ vi.vtype <- constFoldType vi.vtype;
+
+ let init : init option =
+ if inite = A.NO_INIT then
+ None
+ else begin
+ let se, ie', et = doInitializer 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
+ E.s (error "global static initializer");
+ (* 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));
+ Some ie'
+ end
+ in
+ cabsPushGlobal (GVar(vi, {init = init}, !currentLoc));
+ empty
+
+ (* 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
+ * local variables *)
+ addLocalToEnv n (EnvVar vi);
+ empty
+
+ | _ ->
+ (* Make a variable of potentially variable size. If se0 <> empty then
+ * it is a variable size variable *)
+ let vi,se0,len,isvarsize =
+ makeVarSizeVarInfo 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
+ in
+ 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
+ (* 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,
+ Some (integer (String.length s + 1)),
+ a)
+ | _, _, _ -> ());
+
+ (* Now create assignments instead of the initialization *)
+ se1 @@ se4 @@ (assignInit (Var vi, NoOffset) ie' et empty)
+ end
+
+and doAliasFun vtype (thisname:string) (othername:string)
+ (sname:single_name) (loc: cabsloc) : unit =
+ (* This prototype declares that name is an alias for
+ othername, which must be defined in this file *)
+(* E.log "%s is alias for %s at %a\n" thisname othername *)
+(* 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 = List.map
+ (fun (n,_,_) -> A.VARIABLE n)
+ (argsToList formals) in
+ let call = A.CALL (A.VARIABLE othername, args) in
+ let stmt = if isVoidType rt then A.COMPUTATION(call, loc)
+ else A.RETURN(call, loc)
+ in
+ let body = { A.blabels = []; A.battrs = []; A.bstmts = [stmt] } in
+ let fdef = A.FUNDEF (sname, body, loc, loc) in
+ ignore (doDecl true fdef);
+ (* get the new function *)
+ let v,_ = try lookupGlobalVar thisname
+ 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
+ [] -> ""
+ | ((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 (n,ndt,a,l),_ = name in
+ if isglobal then begin
+ let bt,_,_,attrs = spec_res in
+ let vtype, nattr =
+ doType (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in
+ (match filterAttributes "alias" nattr with
+ [] -> (* ordinary prototype. *)
+ ignore (createGlobal spec_res name)
+ (* E.log "%s is not aliased\n" name *)
+ | [Attr("alias", [AStr othername])] ->
+ if not (isFunctionType vtype) then begin
+ ignore (warn
+ "%a: CIL only supports attribute((alias)) for functions.\n"
+ d_loc !currentLoc);
+ ignore (createGlobal spec_res name)
+ end else
+ doAliasFun vtype n othername (s, (n,ndt,a,l)) loc
+ | _ -> E.s (error "Bad alias attribute at %a" d_loc !currentLoc));
+ acc
+ 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"
+ d_loc !currentLoc d_chunk res);
+*)
+ res
+
+
+
+ | A.TYPEDEF (ng, loc) ->
+ currentLoc := convLoc(loc);
+ doTypedef ng; empty
+
+ | A.ONLYTYPEDEF (s, loc) ->
+ currentLoc := convLoc(loc);
+ doOnlyTypedef s; empty
+
+ | A.GLOBASM (s,loc) when isglobal ->
+ currentLoc := convLoc(loc);
+ cabsPushGlobal (GAsm (s, !currentLoc));
+ empty
+
+ | A.PRAGMA (a, loc) when isglobal -> begin
+ currentLoc := convLoc(loc);
+ match doAttr ("dummy", [a]) with
+ [Attr("dummy", [a'])] ->
+ let a'' =
+ match a' with
+ | ACons (s, args) -> Attr (s, args)
+ | _ -> E.s (error "Unexpected attribute in #pragma")
+ in
+ cabsPushGlobal (GPragma (a'', !currentLoc));
+ empty
+
+ | _ -> E.s (error "Too many attributes in pragma")
+ end
+ | A.TRANSFORMER (_, _, _) -> E.s (E.bug "TRANSFORMER in cabs2cil input")
+ | A.EXPRTRANSFORMER (_, _, _) ->
+ E.s (E.bug "EXPRTRANSFORMER in cabs2cil input")
+
+ (* 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")) ->
+ currentLoc := convLoc(loc);
+ let othervi, _ = lookupVar (n ^ "__extinline") in
+ if othervi.vname = n then
+ (* The previous entry in the env is also an extern inline version
+ of n. *)
+ 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. *)
+ 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)
+ end;
+ (* Treat it as a prototype *)
+ doDecl isglobal (A.DECDEF ((specs, [((n,dt,a,loc'), A.NO_INIT)]), loc))
+
+ | A.FUNDEF (((specs,(n,dt,a, _)) : A.single_name),
+ (body : A.block), loc1, loc2) when isglobal ->
+ begin
+ let funloc = convLoc loc1 in
+ let endloc = convLoc loc2 in
+(* ignore (E.log "Definition of %s at %a\n" n d_loc funloc); *)
+ currentLoc := funloc;
+ E.withContext
+ (fun _ -> dprintf "2cil: %s" n)
+ (fun _ ->
+ try
+ IH.clear callTempVars;
+
+ (* Make the fundec right away, and we'll populate it later. We
+ * need this throughout the code to create temporaries. *)
+ currentFunctionFDEC :=
+ { svar = makeGlobalVar "@tempname@" voidType;
+ slocals = []; (* For now we'll put here both the locals and
+ * the formals. Then "endFunction" will
+ * separate them *)
+ sformals = []; (* Not final yet *)
+ smaxid = 0;
+ sbody = dummyFunDec.sbody; (* Not final yet *)
+ smaxstmtid = None;
+ sallstmts = [];
+ };
+ !currentFunctionFDEC.svar.vdecl <- funloc;
+
+ constrExprId := 0;
+ (* Setup the environment. Add the formals to the locals. Maybe
+ * they need alpha-conv *)
+ enterScope (); (* Start the scope *)
+
+ IH.clear varSizeArrays;
+
+ (* Do not process transparent unions in function definitions.
+ * We'll do it later *)
+ transparentUnionArgs := [];
+
+ (* Fix the NAME and the STORAGE *)
+ let _ =
+ let bt,sto,inl,attrs = doSpecList n specs in
+ !currentFunctionFDEC.svar.vinline <- inl;
+
+ 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
+ * static *)
+ let n', sto' =
+ let n' = n ^ "__extinline" in
+ if inl && sto = Extern then begin
+ n', Static
+ end else begin
+ (* Maybe this is the body of a previous extern inline. Then
+ * we must take that one out of the environment because it
+ * is not used from here on. This will also ensure that
+ * then we make this functions' varinfo we will not think
+ * it is a duplicate definition *)
+ (try
+ ignore (lookupVar n'); (* if this succeeds, n' is defined*)
+ let oldvi, _ = lookupVar n in
+ if oldvi.vname = n' then begin
+ (* oldvi is an extern inline function that has been
+ renamed to n ^ "__extinline". Remove it from the
+ environment. *)
+ H.remove env n; H.remove genv n;
+ H.remove env n'; H.remove genv n'
+ end
+ else
+ (* oldvi is not a renamed extern inline function, and
+ we should do nothing. The reason the lookup
+ of n' succeeded is probably because there's
+ an ordinary function that happens to be named,
+ n ^ "__extinline", probably as a result of a previous
+ pass through CIL. See small2/extinline.c*)
+ ()
+ with Not_found -> ());
+ n, sto
+ end
+ in
+ (* Now we have the name and the storage *)
+ !currentFunctionFDEC.svar.vname <- n';
+ !currentFunctionFDEC.svar.vstorage <- sto'
+ in
+
+ (* 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 <-
+ 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
+ * function *)
+ addGlobalToEnv n (EnvVar !currentFunctionFDEC.svar);
+
+ if H.mem alreadyDefined !currentFunctionFDEC.svar.vname then
+ E.s (error "There is a definition already for %s" n);
+
+ H.add alreadyDefined !currentFunctionFDEC.svar.vname funloc;
+
+
+(*
+ ignore (E.log "makefunvar:%s@! type=%a@! vattr=%a@!"
+ 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
+ * type only now. *)
+
+ (**** Process the TYPE and the FORMALS ***)
+ let _ =
+ let (returnType, formals_t, isvararg, funta) =
+ splitFunctionTypeVI !currentFunctionFDEC.svar
+ in
+ (* Record the returnType for doStatement *)
+ currentReturnType := returnType;
+
+
+ (* Create the formals and add them to the environment. *)
+ (* sfg: extract locations for the formals from dt *)
+ let doFormal (loc : location) (fn, ft, fa) =
+ let f = makeVarinfo false fn ft in
+ (f.vdecl <- loc;
+ f.vattr <- fa;
+ alphaConvertVarAndAddToEnv true f)
+ in
+ let rec doFormals fl' ll' =
+ begin
+ match (fl', ll') with
+ | [], _ -> []
+
+ | fl, [] -> (* no more locs available *)
+ List.map (doFormal !currentLoc) fl
+
+ | f::fl, (_,(_,_,_,l))::ll ->
+ (* sfg: these lets seem to be necessary to
+ * force the right order of evaluation *)
+ let f' = doFormal (convLoc l) f in
+ let fl' = doFormals fl ll in
+ f' :: fl'
+ end
+ in
+ let fmlocs = (match dt with PROTO(_, fml, _) -> fml | _ -> []) in
+ let formals = doFormals (argsToList formals_t) fmlocs in
+
+ (* Recreate the type based on the formals. *)
+ let ftype = TFun(returnType,
+ Some (List.map (fun f -> (f.vname,
+ f.vtype,
+ f.vattr)) formals),
+ isvararg, funta) in
+ (*
+ 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
+ * 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
+ * the function a type containing transparent unions *)
+ let _ =
+ let rec fixbackFormals (idx: int) (args: varinfo list) : unit=
+ match args with
+ [] -> ()
+ | a :: args' ->
+ (* Fix the type back to a transparent union type *)
+ (try
+ let origtype = List.assq idx !transparentUnionArgs in
+ a.vtype <- origtype;
+ with Not_found -> ());
+ fixbackFormals (idx + 1) args'
+ in
+ fixbackFormals 0 !currentFunctionFDEC.sformals;
+ transparentUnionArgs := [];
+ in
+
+ (********** Now do the BODY *************)
+ let _ =
+ let stmts = doBody body in
+ (* Finish everything *)
+ exitScope ();
+
+ (* Now fill in the computed goto statement with cases. Do this
+ * before mkFunctionbody which resolves the gotos *)
+ (match !gotoTargetData with
+ Some (switchv, switch) ->
+ let switche, l =
+ match switch.skind with
+ Switch (switche, _, _, l) -> switche, l
+ | _ -> E.s(bug "the computed goto statement not a switch")
+ in
+ (* Build a default chunk that segfaults *)
+ let default =
+ defaultChunk
+ l
+ (i2c (Set ((Mem (makeCast (integer 0) intPtrType),
+ NoOffset),
+ integer 0, l)))
+ in
+ let bodychunk = ref default in
+ H.iter (fun lname laddr ->
+ bodychunk :=
+ caseRangeChunk
+ [integer laddr] l
+ (gotoChunk lname l @@ !bodychunk))
+ gotoTargetHash;
+ (* Now recreate the switch *)
+ let newswitch = switchChunk switche !bodychunk l in
+ (* We must still share the old switch statement since we
+ * have already inserted the goto's *)
+ let newswitchkind =
+ match newswitch.stmts with
+ [ s]
+ when newswitch.postins == [] && newswitch.cases == []->
+ s.skind
+ | _ -> E.s (bug "Unexpected result from switchChunk")
+ in
+ switch.skind <- newswitchkind
+
+ | None -> ());
+ (* Now finish the body and store it *)
+ !currentFunctionFDEC.sbody <- mkFunctionBody stmts;
+ (* Reset the global parameters *)
+ gotoTargetData := None;
+ 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))
+ !currentFunctionFDEC.sformals
+ (docList ~sep:(chr ',') (fun v -> text v.vname))
+ !currentFunctionFDEC.slocals);
+*)
+
+ 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.vname l.vname);
+ dropFormals formals locals
+ | _ -> E.s (bug "Too few locals")
+ in
+ !currentFunctionFDEC.slocals
+ <- dropFormals !currentFunctionFDEC.sformals
+ (List.rev !currentFunctionFDEC.slocals);
+ setMaxId !currentFunctionFDEC;
+
+ (* Now go over the types of the formals and pull out the formals
+ * with transparent union type. Replace them with some shadow
+ * parameters and then add assignments *)
+ let _ =
+ let newformals, newbody =
+ List.fold_right (* So that the formals come out in order *)
+ (fun f (accform, accbody) ->
+ match isTransparentUnion f.vtype with
+ None -> (f :: accform, accbody)
+ | Some fstfield ->
+ (* A new shadow to be placed in the formals. Use
+ * makeTempVar to update smaxid and all others. *)
+ 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
+ * one. *)
+ !currentFunctionFDEC.slocals <-
+ f ::
+ (List.filter (fun x -> x.vid <> shadow.vid)
+ !currentFunctionFDEC.slocals);
+ (shadow :: accform,
+ mkStmt (Instr [Set ((Var f, Field(fstfield,
+ NoOffset)),
+ Lval (var shadow),
+ !currentLoc)]) :: accbody))
+ !currentFunctionFDEC.sformals
+ ([], !currentFunctionFDEC.sbody.bstmts)
+ in
+ !currentFunctionFDEC.sbody.bstmts <- newbody;
+ (* To make sure sharing with the type is proper *)
+ setFormals !currentFunctionFDEC newformals;
+ in
+
+ (* Now see whether we can fall through to the end of the function
+ * *)
+ (* weimer: Sat Dec 8 17:30:47 2001 MSVC NT kernel headers include
+ * functions like long convert(x) { __asm { mov eax, x \n cdq } }
+ * That set a return value via an ASM statement. As a result, I
+ * am changing this so a final ASM statement does not count as
+ * "fall through" for the purposes of this warning. *)
+ (* matth: But it's better to assume assembly will fall through,
+ * since most such blocks do. It's probably better to print an
+ * unnecessary warning than to break CIL's invariant that
+ * return statements are inserted properly. *)
+ let instrFallsThrough (i : instr) = match i with
+ Set _ -> true
+ | Call (None, Lval (Var e, NoOffset), _, _) ->
+ (* See if this is exit, or if it has the noreturn attribute *)
+ if e.vname = "exit" then false
+ else if hasAttribute "noreturn" e.vattr then false
+ else true
+ | Call _ -> true
+ | Asm _ -> true
+ in
+ let rec stmtFallsThrough (s: stmt) : bool =
+ match s.skind with
+ Instr(il) ->
+ List.fold_left (fun acc elt ->
+ acc && instrFallsThrough elt) true il
+ | Return _ | Break _ | Continue _ -> false
+ | Goto _ -> false
+ | If (_, b1, b2, _) ->
+ blockFallsThrough b1 || blockFallsThrough b2
+ | Switch (e, b, targets, _) ->
+ (* See if there is a "default" case *)
+ if not
+ (List.exists (fun s ->
+ List.exists (function Default _ -> true | _ -> false)
+ s.labels)
+ targets) then begin
+(*
+ ignore (E.log "Switch falls through because no default");
+
+*) true (* We fall through because there is no default *)
+ end else begin
+ (* We must examine all cases. If any falls through,
+ * then the switch falls through. *)
+ blockFallsThrough b || blockCanBreak b
+ end
+ | Loop (b, _, _, _) ->
+ (* A loop falls through if it can break. *)
+ blockCanBreak b
+ | Block b -> blockFallsThrough b
+ | TryFinally (b, h, _) -> blockFallsThrough h
+ | TryExcept (b, _, h, _) -> true (* Conservative *)
+ and blockFallsThrough b =
+ let rec fall = function
+ [] -> true
+ | s :: rest ->
+ if stmtFallsThrough s then begin
+(*
+ ignore (E.log "Stmt %a falls through\n" d_stmt s);
+*)
+ fall rest
+ end else begin
+(*
+ ignore (E.log "Stmt %a DOES NOT fall through\n"
+ d_stmt s);
+*)
+ (* 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 <> [] ->
+(*
+ ignore (E.log "invoking fall %a: %a\n"
+ d_loc !currentLoc d_stmt s);
+*)
+ fall (s :: rest)
+ | _ :: rest -> labels rest
+ in
+ let res = fall b.bstmts in
+(*
+ ignore (E.log "blockFallsThrough=%b %a\n" res d_block b);
+*)
+ res
+ (* will we leave this statement or block with a break command? *)
+ and stmtCanBreak (s: stmt) : bool =
+ match s.skind with
+ Instr _ | Return _ | Continue _ | Goto _ -> false
+ | Break _ -> true
+ | If (_, b1, b2, _) ->
+ blockCanBreak b1 || blockCanBreak b2
+ | Switch _ | Loop _ ->
+ (* switches and loops catch any breaks in their bodies *)
+ false
+ | Block b -> blockCanBreak b
+ | TryFinally (b, h, _) -> blockCanBreak b || blockCanBreak h
+ | TryExcept (b, _, h, _) -> blockCanBreak b || blockCanBreak h
+ and blockCanBreak b =
+ List.exists stmtCanBreak b.bstmts
+ in
+ if blockFallsThrough !currentFunctionFDEC.sbody then begin
+ 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\n" !currentFunctionFDEC.svar.vname);
+ Some (makeCastT zero intType rt)
+ | _ ->
+ ignore (warn "Body of function %s falls-through and cannot find an appropriate return value\n" !currentFunctionFDEC.svar.vname);
+ None
+ in
+ 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));
+ empty
+ with e when continueOnError -> begin
+ ignore (E.log "error in collectFunction %s: %s\n"
+ n (Printexc.to_string e));
+ cabsPushGlobal (GAsm("error in function " ^ n, !currentLoc));
+ empty
+ end)
+ () (* argument of E.withContext *)
+ end (* FUNDEF *)
+
+ | LINKAGE (n, loc, dl) ->
+ currentLoc := convLoc loc;
+ if n <> "C" then
+ ignore (warn "Encountered linkage specification \"%s\"" n);
+ 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 ->
+ let s = doDecl isglobal d in
+ 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) =
+ try
+ (* Do the specifiers exactly once *)
+ let bt, sto, inl, attrs = doSpecList (suggestAnonName nl) specs in
+ if sto <> NoStorage || inl then
+ E.s (error "Storage or inline specifier not allowed in typedef");
+ let createTypedef ((n,ndt,a,loc) : A.name) =
+ (* E.s (error "doTypeDef") *)
+ try
+ 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
+ * 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;
+ let namedTyp = TNamed(ti, []) in
+ (* Register the type. register it as local because we might be in a
+ * local context *)
+ addLocalToEnv (kindPlusName "type" n) (EnvTyp namedTyp);
+ cabsPushGlobal (GType (ti, !currentLoc))
+ with e -> begin
+ ignore (E.log "Error on A.TYPEDEF (%s)\n"
+ (Printexc.to_string e));
+ cabsPushGlobal (GAsm ("booo_typedef:" ^ n, !currentLoc))
+ end
+ in
+ List.iter createTypedef nl
+ with e -> begin
+ ignore (E.log "Error on A.TYPEDEF (%s)\n"
+ (Printexc.to_string e));
+ let fstname =
+ match nl with
+ [] -> "<missing name>"
+ | (n, _, _, _) :: _ -> n
+ in
+ cabsPushGlobal (GAsm ("booo_typedef: " ^ fstname, !currentLoc))
+ end
+
+and doOnlyTypedef (specs: A.spec_elem list) : unit =
+ try
+ let bt, sto, inl, attrs = doSpecList "" specs in
+ 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,
+ A.JUSTBASE, [])) in
+ if nattr <> [] then
+ ignore (warn "Ignoring identifier attribute");
+ (* doSpec will register the type. *)
+ (* See if we are defining a composite or enumeration type, and in that
+ * case move the attributes from the defined type into the composite type
+ * *)
+ let isadef =
+ List.exists
+ (function
+ A.SpecType(A.Tstruct(_, Some _, _)) -> true
+ | A.SpecType(A.Tunion(_, Some _, _)) -> true
+ | A.SpecType(A.Tenum(_, Some _, _)) -> true
+ | _ -> false) specs
+ in
+ match restyp with
+ TComp(ci, al) ->
+ if isadef then begin
+ ci.cattr <- cabsAddAttributes ci.cattr al;
+ (* The GCompTag was already added *)
+ end else (* Add a GCompTagDecl *)
+ cabsPushGlobal (GCompTagDecl(ci, !currentLoc))
+ | TEnum(ei, al) ->
+ if isadef then begin
+ ei.eattr <- cabsAddAttributes ei.eattr al;
+ end else
+ cabsPushGlobal (GEnumTagDecl(ei, !currentLoc))
+ | _ ->
+ ignore (warn "Ignoring un-named typedef that does not introduce a struct or enumeration type\n")
+
+ 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 =
+ match ie with
+ SingleInit e ->
+ let (_, e'') = castTo iet (typeOfLval lv) e in
+ acc +++ (Set(lv, e'', !currentLoc))
+ | CompoundInit (t, initl) ->
+ foldLeftCompound
+ ~implicit:false
+ ~doinit:(fun off i it acc ->
+ assignInit (addOffsetLval off lv) i it acc)
+ ~ct:t
+ ~initl:initl
+ ~acc:acc
+
+ (* Now define the processors for body and statement *)
+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 =
+ afterConversion
+ (List.fold_left (* !!! @ evaluates its arguments backwards *)
+ (fun prev s -> let res = doStatement s in
+ prev @@ res)
+ empty
+ blk.A.bstmts)
+ in
+ exitScope ();
+
+
+ if battrs == [] then
+ bodychunk
+ else begin
+ let b = c2block bodychunk in
+ b.battrs <- battrs;
+ s2c (mkStmt (Block b))
+ end
+
+and doStatement (s : A.statement) : chunk =
+ try
+ match s with
+ A.NOP _ -> skipChunk
+ | A.COMPUTATION (e, loc) ->
+ currentLoc := convLoc loc;
+ let (lasts, data) = !gnu_body_result in
+ if lasts == s then begin (* This is the last in a GNU_BODY *)
+ let (s', e', t') = doExp false e (AExp None) in
+ data := Some (e', t'); (* Record the result *)
+ s'
+ end else
+ let (s', _, _) = doExp false e ADrop in
+ (* drop the side-effect free expression *)
+ (* And now do some peep-hole optimizations *)
+ s'
+
+ | A.BLOCK (b, loc) ->
+ currentLoc := convLoc loc;
+ doBody b
+
+ | A.SEQUENCE (s1, s2, loc) ->
+ (doStatement s1) @@ (doStatement s2)
+
+ | A.IF(e,st,sf,loc) ->
+ let st' = doStatement st in
+ let sf' = doStatement sf in
+ currentLoc := convLoc loc;
+ doCondition false e st' sf'
+
+ | A.WHILE(e,s,loc) ->
+ startLoop true;
+ let s' = doStatement s in
+ exitLoop ();
+ let loc' = convLoc loc in
+ currentLoc := loc';
+ loopChunk ((doCondition false e skipChunk
+ (breakChunk loc'))
+ @@ s')
+
+ | A.DOWHILE(e,s,loc) ->
+ startLoop false;
+ let s' = doStatement s in
+ let loc' = convLoc loc in
+ currentLoc := loc';
+ 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
+ | FC_DECL d1 -> (doDecl false d1, zero, voidType)
+ in
+ let (se3, _, _) = doExp false e3 ADrop in
+ startLoop false;
+ let s' = doStatement s in
+ currentLoc := loc';
+ let s'' = consLabContinue se3 in
+ exitLoop ();
+ let res =
+ match e2 with
+ A.NOTHING -> (* This means true *)
+ se1 @@ loopChunk (s' @@ s'')
+ | _ ->
+ se1 @@ loopChunk ((doCondition false e2 skipChunk (breakChunk loc'))
+ @@ s' @@ s'')
+ in
+ exitScope ();
+ res
+ end
+ | A.BREAK loc ->
+ let loc' = convLoc loc in
+ currentLoc := loc';
+ breakChunk loc'
+
+ | A.CONTINUE loc ->
+ let loc' = convLoc loc in
+ currentLoc := loc';
+ continueOrLabelChunk loc'
+
+ | A.RETURN (A.NOTHING, loc) ->
+ let loc' = convLoc loc in
+ currentLoc := loc';
+ if not (isVoidType !currentReturnType) then
+ ignore (warn "Return statement without a value in function returning %a\n" d_type !currentReturnType);
+ returnChunk None loc'
+
+ | A.RETURN (e, loc) ->
+ let loc' = convLoc loc in
+ 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");
+ let (se, _, _) = doExp false e ADrop in
+ se @@ returnChunk None loc'
+ end else begin
+ let rt =
+ typeRemoveAttributes ["warn_unused_result"] !currentReturnType
+ in
+ let (se, e', et) = doExp false e (AExp (Some rt)) in
+ let (et'', e'') = castTo et rt e' in
+ se @@ (returnChunk (Some e'') loc')
+ end
+
+ | A.SWITCH (e, s, loc) ->
+ let loc' = convLoc loc in
+ currentLoc := loc';
+ let (se, e', et) = doExp false e (AExp (Some intType)) in
+ let (et'', e'') = castTo et intType e' in
+ let s' = doStatement s in
+ se @@ (switchChunk 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
+ if isNotEmpty se then
+ E.s (error "Case statement with a non-constant");
+ caseRangeChunk [if !lowerConstants then constFold false e' else e']
+ loc' (doStatement s)
+
+ | A.CASERANGE (el, eh, s, loc) ->
+ let loc' = convLoc loc in
+ currentLoc := loc';
+ let (sel, el', etl) = doExp false el (AExp None) in
+ let (seh, eh', etl) = doExp false eh (AExp None) in
+ if isNotEmpty sel || isNotEmpty seh then
+ E.s (error "Case statement with a non-constant");
+ let il, ih =
+ match constFold true el', constFold true eh' with
+ Const(CInt64(il, _, _)), Const(CInt64(ih, _, _)) ->
+ i64_to_int il, i64_to_int ih
+ | _ -> E.s (unimp "Cannot understand the constants in case range")
+ in
+ if il > ih then
+ E.s (error "Empty case range");
+ let rec mkAll (i: int) =
+ if i > ih then [] else integer i :: mkAll (i + 1)
+ in
+ caseRangeChunk (mkAll il) loc' (doStatement s)
+
+
+ | A.DEFAULT (s, loc) ->
+ let loc' = convLoc loc in
+ currentLoc := loc';
+ defaultChunk loc' (doStatement s)
+
+ | 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) ->
+ let loc' = convLoc loc in
+ currentLoc := loc';
+ (* Maybe we need to rename this label *)
+ gotoChunk (lookupLabel l) loc'
+
+ | A.COMPGOTO (e, loc) -> begin
+ let loc' = convLoc loc in
+ currentLoc := loc';
+ (* Do the expression *)
+ 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' intType, loc'))
+ @@ s2c(mkStmt(Goto (ref switch, loc')))
+
+ | None -> begin
+ (* Make a temporary variable *)
+ let vchunk = createLocal
+ (intType, NoStorage, false, [])
+ (("__compgoto", A.JUSTBASE, [], loc), A.NO_INIT)
+ in
+ if not (isEmpty vchunk) then
+ E.s (unimp "Non-empty chunk in creating temporary for goto *");
+ 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
+ * end of the function *)
+ 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' intType, loc')) @@
+ s2c switch
+ end
+ end
+
+ | A.DEFINITION d ->
+ let s = doDecl false d in
+(*
+ ignore (E.log "Def at %a: %a\n" d_loc !currentLoc d_chunk s);
+*)
+ s
+
+
+
+ | A.ASM (asmattr, tmpls, details, loc) ->
+ (* Make sure all the outs are variables *)
+ let loc' = convLoc loc in
+ let attr' = doAttributes asmattr in
+ currentLoc := loc';
+ let stmts : chunk ref = ref empty in
+ let (tmpls', outs', ins', clobs') =
+ match details with
+ | None ->
+ let tmpls' =
+ if !msvcMode then
+ tmpls
+ else
+ let pattern = Str.regexp "%" in
+ let escape = Str.global_replace pattern "%%" in
+ List.map escape tmpls
+ in
+ (tmpls', [], [], [])
+ | Some { aoutputs = outs; ainputs = ins; aclobbers = clobs } ->
+ let outs' =
+ List.map
+ (fun (id, c, e) ->
+ let (se, e', t) = doExp false e (AExp None) in
+ let lv =
+ match e' with
+ | Lval lval
+ | StartOf lval -> lval
+ | _ -> E.s (error "Expected lval for ASM outputs")
+ in
+ stmts := !stmts @@ se;
+ (id, c, lv)) outs
+ in
+ (* Get the side-effects out of expressions *)
+ let ins' =
+ List.map
+ (fun (id, c, e) ->
+ let (se, e', et) = doExp false e (AExp None) in
+ stmts := !stmts @@ se;
+ (id, c, e'))
+ ins
+ in
+ (tmpls, outs', ins', clobs)
+ in
+ !stmts @@
+ (i2c (Asm(attr', tmpls', outs', ins', clobs', 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
+ E.s (error "Try statements cannot contain switch cases");
+
+ s2c (mkStmt (TryFinally (c2block b', c2block 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
+ E.s (error "Try statements cannot contain switch cases");
+ (* Now take se and try to convert it to a list of instructions. This
+ * might not be always possible *)
+ let il' =
+ match compactStmts se.stmts with
+ [] -> se.postins
+ | [ s ] -> begin
+ match s.skind with
+ Instr il -> il @ se.postins
+ | _ -> E.s (error "Except expression contains unexpected statement")
+ end
+ | _ -> E.s (error "Except expression contains too many statements")
+ in
+ s2c (mkStmt (TryExcept (c2block b', (il', e'), c2block h', loc')))
+
+ with e when continueOnError -> begin
+ (ignore (E.log "Error in doStatement (%s)\n" (Printexc.to_string e)));
+ E.hadErrors := true;
+ consLabel "booo_statement" empty (convLoc (C.get_statementloc s)) false
+ end
+
+
+let rec stripParenLocal e = match e with
+ | A.PAREN e2 -> stripParenLocal e2
+ | _ -> e
+
+class stripParenClass : V.cabsVisitor = object (self)
+ inherit V.nopCabsVisitor as super
+
+ method vexpr e = match e with
+ | A.PAREN e2 ->
+ V.ChangeDoChildrenPost (stripParenLocal e2,stripParenLocal)
+ | _ -> V.DoChildren
+end
+
+let stripParenFile file = V.visitCabsFile (new stripParenClass) file
+
+
+(* Translate a file *)
+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
+
+ (* Clean up the global types *)
+ initGlobals();
+ startFile ();
+ IH.clear noProtoFunctions;
+ H.clear compInfoNameEnv;
+ H.clear enumInfoNameEnv;
+ IH.clear mustTurnIntoDef;
+ H.clear alreadyDefined;
+ H.clear staticLocals;
+ H.clear typedefs;
+ H.clear isomorphicStructs;
+ annonCompFieldNameId := 0;
+ 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 (List.map (fun at -> ("", at, []))
+ argTypes),
+ isva, [])) in
+ ignore (alphaConvertVarAndAddToEnv true v);
+ (* Add it to the file as well *)
+ cabsPushGlobal (GVarDecl (v, Cil.builtinLoc))
+ in
+ H.iter setupBuiltin Cil.builtinFunctions;
+
+ let globalidx = ref 0 in
+ let doOneGlobal (d: A.definition) =
+ let s = doDecl true d in
+ 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
+ * globalidx and see if we must leave this alone. *)
+ if
+ (match d with
+ A.DECDEF _ -> true
+ | A.FUNDEF _ -> true
+ | _ -> false) && (incr globalidx; !globalidx = !nocil) then begin
+ (* Create a file where we put the CABS output *)
+ let temp_cabs_name = "__temp_cabs" in
+ let temp_cabs = open_out temp_cabs_name in
+ (* Now print the CABS in there *)
+ Cprint.commit (); Cprint.flush ();
+ let old = !Cprint.out in (* Save the old output channel *)
+ Cprint.out := temp_cabs;
+ Cprint.print_def d;
+ Cprint.commit (); Cprint.flush ();
+ flush !Cprint.out;
+ Cprint.out := old;
+ close_out temp_cabs;
+ (* Now read everythign 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";
+ Buffer.add_channel buff temp_cabs (in_channel_length temp_cabs);
+ 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
+ _ :: rest -> theFile := rest
+ | _ -> ());
+ (* Insert in the file a GText *)
+ cabsPushGlobal (GText(Buffer.contents buff))
+ end
+ in
+ List.iter doOneGlobal dl;
+ let globals = ref (popGlobals ()) in
+
+ IH.clear noProtoFunctions;
+ IH.clear mustTurnIntoDef;
+ H.clear alreadyDefined;
+ H.clear compInfoNameEnv;
+ H.clear enumInfoNameEnv;
+ H.clear isomorphicStructs;
+ H.clear staticLocals;
+ H.clear typedefs;
+ H.clear env;
+ H.clear genv;
+ IH.clear callTempVars;
+
+ if false then ignore (E.log "Cabs2cil converted %d globals\n" !globalidx);
+ (* We are done *)
+ { fileName = fname;
+ globals = !globals;
+ globinit = None;
+ globinitcalled = false;
+ }
+
+
+
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(** The main entry point *)
+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
+ * -1 to disable *)
+val nocil: int ref
+
+(** Indicates whether we're allowed to duplicate small chunks of code. *)
+val allowDuplication: bool ref
+
+(** If false, the destination of a Call instruction should always have the
+ same type as the function's return type. Where needed, CIL will insert
+ a temporary to make this happen.
+
+ If true, the destination type may differ from the return type, so there
+ is an implicit cast. This is useful for analyses involving [malloc],
+ because the instruction "T* x = malloc(...);" won't be broken into
+ two instructions, so it's easy to find the allocation type.
+
+ This is false by default. Set to true to replicate the behavior
+ of CIL 1.3.5 and earlier.
+*)
+val doCollapseCallCast: bool ref
+
+(** Disables caching of globals during parsing. This is handy when we want
+ * to parse additional source files without hearing about confclits. *)
+val cacheGlobals: bool ref
+
+(** A hook into the code for processing typeof. *)
+val typeForTypeof: (Cil.typ -> Cil.typ) ref
+
+(** A hook into the code that creates temporary local vars. By default this
+ is the identity function, but you can overwrite it if you need to change the
+ types of cabs2cil-introduced temp variables. *)
+val typeForInsertedVar: (Cil.typ -> Cil.typ) ref
+
+(** Like [typeForInsertedVar], but for casts.
+ * Casts in the source code are exempt from this hook. *)
+val typeForInsertedCast: (Cil.typ -> Cil.typ) ref
+
+(** A hook into the code that merges arguments in function types. *)
+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
--- /dev/null
+
+open Cabs
+
+let nextident = ref 0
+let getident () =
+ nextident := !nextident + 1;
+ !nextident
+
+let currentLoc () =
+ let l, f, c = Errormsg.getPosition () in
+ { lineno = l;
+ filename = f;
+ byteno = c;
+ ident = getident ();}
+
+let cabslu = {lineno = -10;
+ filename = "cabs loc unknown";
+ byteno = -10;
+ ident = 0}
+
+(* clexer puts comments here *)
+let commentsGA = GrowArray.make 100 (GrowArray.Elem(cabslu,"",false))
+
+
+(*********** HELPER FUNCTIONS **********)
+
+let missingFieldDecl = ("___missing_field_name", JUSTBASE, [], cabslu)
+
+let rec isStatic = function
+ [] -> false
+ | (SpecStorage STATIC) :: _ -> true
+ | _ :: rest -> isStatic rest
+
+let rec isExtern = function
+ [] -> false
+ | (SpecStorage EXTERN) :: _ -> true
+ | _ :: rest -> isExtern rest
+
+let rec isInline = function
+ [] -> false
+ | SpecInline :: _ -> true
+ | _ :: rest -> isInline rest
+
+let rec isTypedef = function
+ [] -> false
+ | SpecTypedef :: _ -> true
+ | _ :: rest -> isTypedef rest
+
+
+let get_definitionloc (d : definition) : cabsloc =
+ match d with
+ | FUNDEF(_, _, l, _) -> l
+ | DECDEF(_, l) -> l
+ | TYPEDEF(_, l) -> l
+ | ONLYTYPEDEF(_, l) -> l
+ | GLOBASM(_, l) -> l
+ | PRAGMA(_, l) -> l
+ | TRANSFORMER(_, _, l) -> l
+ | EXPRTRANSFORMER(_, _, l) -> l
+ | LINKAGE (_, l, _) -> l
+
+let get_statementloc (s : statement) : cabsloc =
+begin
+ match s with
+ | NOP(loc) -> loc
+ | COMPUTATION(_,loc) -> loc
+ | BLOCK(_,loc) -> loc
+ | SEQUENCE(_,_,loc) -> loc
+ | IF(_,_,_,loc) -> loc
+ | WHILE(_,_,loc) -> loc
+ | DOWHILE(_,_,loc) -> loc
+ | FOR(_,_,_,_,loc) -> loc
+ | BREAK(loc) -> loc
+ | CONTINUE(loc) -> loc
+ | RETURN(_,loc) -> loc
+ | SWITCH(_,_,loc) -> loc
+ | CASE(_,_,loc) -> loc
+ | CASERANGE(_,_,_,loc) -> loc
+ | DEFAULT(_,loc) -> loc
+ | LABEL(_,_,loc) -> loc
+ | GOTO(_,loc) -> loc
+ | COMPGOTO (_, loc) -> loc
+ | DEFINITION d -> get_definitionloc d
+ | ASM(_,_,_,loc) -> loc
+ | TRY_EXCEPT(_, _, _, loc) -> loc
+ | TRY_FINALLY(_, _, loc) -> loc
+end
+
+
+let explodeStringToInts (s: string) : int64 list =
+ let rec allChars i acc =
+ if i < 0 then acc
+ else allChars (i - 1) (Int64.of_int (Char.code (String.get s i)) :: acc)
+ in
+ allChars (-1 + String.length s) []
+
+let valueOfDigit chr =
+ let int_value =
+ match chr with
+ '0'..'9' -> (Char.code chr) - (Char.code '0')
+ | 'a'..'z' -> (Char.code chr) - (Char.code 'a') + 10
+ | 'A'..'Z' -> (Char.code chr) - (Char.code 'A') + 10
+ | _ -> Errormsg.s (Errormsg.bug "not a digit") in
+ Int64.of_int int_value
+
+
+open Pretty
+let d_cabsloc () cl =
+ text cl.filename ++ text ":" ++ num cl.lineno
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(* cabsvisit.ml *)
+(* tree visitor and rewriter for cabs *)
+
+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
+ * the node as it is *)
+ | 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
+ * (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
+ * function on the node *)
+
+type nameKind =
+ NVar (* Variable or function prototype
+ name *)
+ | NFun (* A function definition name *)
+ | NField (* The name of a field *)
+ | NType (* The name of a type *)
+
+(* All visit methods are called in preorder! (but you can use
+ * ChangeDoChildrenPost to change the order) *)
+class type cabsVisitor = object
+ method vexpr: expression -> expression visitAction (* expressions *)
+ method vinitexpr: init_expression -> init_expression visitAction
+ method vstmt: statement -> statement list visitAction
+ method vblock: block -> block visitAction
+ method vvar: string -> string (* use of a variable
+ * names *)
+ method vdef: definition -> definition list visitAction
+ method vtypespec: typeSpecifier -> typeSpecifier visitAction
+ method vdecltype: decl_type -> decl_type visitAction
+
+ (* For each declaration we call vname *)
+ method vname: nameKind -> specifier -> name -> name visitAction
+ method vspec: specifier -> specifier visitAction (* specifier *)
+ method vattr: attribute -> attribute list visitAction
+
+ method vEnterScope: unit -> unit
+ method vExitScope: unit -> unit
+end
+
+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) =
+ visitorLocation := get_statementloc s;
+ DoChildren
+ method vblock (b: block) = DoChildren
+ method vvar (s: string) = s
+ method vdef (d: definition) =
+ visitorLocation := get_definitionloc d;
+ DoChildren
+ method vtypespec (ts: typeSpecifier) = DoChildren
+ method vdecltype (dt: decl_type) = DoChildren
+ method vname k (s:specifier) (n: name) = DoChildren
+ method vspec (s:specifier) = DoChildren
+ method vattr (a: attribute) = DoChildren
+
+ method vEnterScope () = ()
+ method vExitScope () = ()
+end
+
+ (* Map but try not to copy the list unless necessary *)
+let rec mapNoCopy (f: 'a -> 'a) = function
+ [] -> []
+ | (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
+
+let rec mapNoCopyList (f: 'a -> 'a list) = function
+ [] -> []
+ | (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 =
+ let action = startvisit node in
+ match action with
+ SkipChildren -> node
+ | ChangeTo node' -> node'
+ | _ ->
+ let nodepre = match action with
+ ChangeDoChildrenPost (node', _) -> node'
+ | _ -> node
+ in
+ let nodepost = children vis nodepre in
+ 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 =
+ let action = startvisit node in
+ match action with
+ SkipChildren -> [node]
+ | ChangeTo nodes' -> nodes'
+ | _ ->
+ let nodespre = match action with
+ ChangeDoChildrenPost (nodespre, _) -> nodespre
+ | _ -> [node]
+ in
+ let nodespost = mapNoCopy (children vis) nodespre in
+ match action with
+ ChangeDoChildrenPost (_, f) -> f nodespost
+ | _ -> nodespost
+
+
+let rec visitCabsTypeSpecifier (vis: cabsVisitor) (ts: typeSpecifier) =
+ doVisit vis vis#vtypespec childrenTypeSpecifier ts
+
+and childrenTypeSpecifier vis ts =
+ let childrenFieldGroup ((s, nel) as input) =
+ let s' = visitCabsSpecifier vis s in
+ let doOneField ((n, eo) as input) =
+ let n' = visitCabsName vis NField s' n in
+ let eo' =
+ match eo with
+ None -> None
+ | Some e -> let e' = visitCabsExpression vis e in
+ if e' != e then Some e' else eo
+ in
+ if n' != n || eo' != eo then (n', eo') else input
+ in
+ let nel' = mapNoCopy doOneField nel in
+ if s' != s || nel' != nel then (s', nel') else input
+ in
+ match ts with
+ Tstruct (n, Some fg, extraAttrs) ->
+ (*(trace "sm" (dprintf "visiting struct %s\n" n));*)
+ let fg' = mapNoCopy childrenFieldGroup fg in
+ if fg' != fg then Tstruct( n, Some fg', extraAttrs) else ts
+ | Tunion (n, Some fg, extraAttrs) ->
+ let fg' = mapNoCopy childrenFieldGroup fg in
+ if fg' != fg then Tunion( n, Some fg', extraAttrs) else ts
+ | Tenum (n, Some ei, extraAttrs) ->
+ let doOneEnumItem ((s, e, loc) as ei) =
+ let e' = visitCabsExpression vis e in
+ if e' != e then (s, e', loc) else ei
+ in
+ vis#vEnterScope ();
+ let ei' = mapNoCopy doOneEnumItem ei in
+ vis#vExitScope();
+ if ei' != ei then Tenum( n, Some ei', extraAttrs) else ts
+ | TtypeofE e ->
+ let e' = visitCabsExpression vis e in
+ if e' != e then TtypeofE e' else ts
+ | TtypeofT (s, dt) ->
+ let s' = visitCabsSpecifier vis s in
+ let dt' = visitCabsDeclType vis false dt in
+ if s != s' || dt != dt' then TtypeofT (s', dt') else ts
+ | ts -> ts
+
+and childrenSpecElem (vis: cabsVisitor) (se: spec_elem) : spec_elem =
+ match se with
+ SpecTypedef | SpecInline | SpecStorage _ | SpecPattern _ -> se
+ | SpecCV _ -> se (* cop out *)
+ | SpecAttr a -> begin
+ let al' = visitCabsAttribute vis a in
+ match al' with
+ [a''] when a'' == a -> se
+ | [a''] -> SpecAttr a''
+ | _ -> E.s (E.unimp "childrenSpecElem: visitCabsAttribute returned a list")
+ end
+ | SpecType ts ->
+ let ts' = visitCabsTypeSpecifier vis ts in
+ if ts' != ts then SpecType ts' else se
+
+and visitCabsSpecifier (vis: cabsVisitor) (s: specifier) : specifier =
+ doVisit vis vis#vspec childrenSpec s
+and childrenSpec vis s = mapNoCopy (childrenSpecElem vis) s
+
+
+and visitCabsDeclType vis (isfundef: bool) (dt: decl_type) : decl_type =
+ doVisit vis vis#vdecltype (childrenDeclType isfundef) dt
+and childrenDeclType isfundef vis dt =
+ match dt with
+ JUSTBASE -> dt
+ | PARENTYPE (prea, dt1, posta) ->
+ let prea' = mapNoCopyList (visitCabsAttribute vis) prea in
+ let dt1' = visitCabsDeclType vis isfundef dt1 in
+ let posta'= mapNoCopyList (visitCabsAttribute vis) posta in
+ if prea' != prea || dt1' != dt1 || posta' != posta then
+ PARENTYPE (prea', dt1', posta') else dt
+ | ARRAY (dt1, al, e) ->
+ let dt1' = visitCabsDeclType vis isfundef dt1 in
+ let al' = mapNoCopy (childrenAttribute vis) al in
+ let e'= visitCabsExpression vis e in
+ if dt1' != dt1 || al' != al || e' != e then ARRAY(dt1', al', e') else dt
+ | PTR (al, dt1) ->
+ let al' = mapNoCopy (childrenAttribute vis) al in
+ let dt1' = visitCabsDeclType vis isfundef dt1 in
+ if al' != al || dt1' != dt1 then PTR(al', dt1') else dt
+ | PROTO (dt1, snl, b) ->
+ (* Do not propagate isfundef further *)
+ let dt1' = visitCabsDeclType vis false dt1 in
+ let _ = vis#vEnterScope () in
+ let snl' = mapNoCopy (childrenSingleName vis NVar) snl in
+ (* Exit the scope only if not in a function definition *)
+ let _ = if not isfundef then vis#vExitScope () in
+ if dt1' != dt1 || snl' != snl then PROTO(dt1', snl', b) else dt
+
+
+and childrenNameGroup vis (kind: nameKind) ((s, nl) as input) =
+ let s' = visitCabsSpecifier vis s in
+ let nl' = mapNoCopy (visitCabsName vis kind s') nl in
+ if s' != s || nl' != nl then (s', nl') else input
+
+
+and 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 =
+ doVisit vis (vis#vname k s) (childrenName s k) n
+and childrenName (s: specifier) (k: nameKind) vis (n: name) : name =
+ let (sn, dt, al, loc) = n in
+ let dt' = visitCabsDeclType vis (k = NFun) dt in
+ let al' = mapNoCopy (childrenAttribute vis) al in
+ if dt' != dt || al' != al then (sn, dt', al', loc) else n
+
+and childrenInitName vis (s: specifier) (inn: init_name) : init_name =
+ let (n, ie) = inn in
+ let n' = visitCabsName vis NVar s n in
+ let ie' = visitCabsInitExpression vis ie in
+ if n' != n || ie' != ie then (n', ie') else inn
+
+and childrenSingleName vis (k: nameKind) (sn: single_name) : single_name =
+ let s, n = sn in
+ let s' = visitCabsSpecifier vis s in
+ let n' = visitCabsName vis k s' n in
+ if s' != s || n' != n then (s', n') else sn
+
+and visitCabsDefinition vis (d: definition) : definition list =
+ doVisitList vis vis#vdef childrenDefinition d
+and childrenDefinition vis d =
+ match d with
+ FUNDEF (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) ->
+ 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) ->
+ let ng' = childrenNameGroup vis NType ng in
+ if ng' != ng then TYPEDEF (ng', l) else d
+ | ONLYTYPEDEF (s, l) ->
+ let s' = visitCabsSpecifier vis s in
+ if s' != s then ONLYTYPEDEF (s', l) else d
+ | GLOBASM _ -> d
+ | PRAGMA (e, l) ->
+ let e' = visitCabsExpression vis e in
+ if e' != e then PRAGMA (e', l) else d
+ | LINKAGE (n, l, dl) ->
+ let dl' = mapNoCopyList (visitCabsDefinition vis) dl in
+ if dl' != dl then LINKAGE (n, l, dl') else d
+
+ | TRANSFORMER _ -> d
+ | EXPRTRANSFORMER _ -> d
+
+and visitCabsBlock vis (b: block) : block =
+ doVisit vis vis#vblock childrenBlock b
+
+and childrenBlock vis (b: block) : block =
+ let _ = vis#vEnterScope () in
+ let battrs' = mapNoCopyList (visitCabsAttribute vis) b.battrs in
+ let bstmts' = mapNoCopyList (visitCabsStatement vis) b.bstmts in
+ let _ = vis#vExitScope () in
+ if battrs' != b.battrs || bstmts' != b.bstmts then
+ { blabels = b.blabels; battrs = battrs'; bstmts = bstmts' }
+ else
+ b
+
+and visitCabsStatement vis (s: statement) : statement list =
+ doVisitList vis vis#vstmt childrenStatement s
+and childrenStatement vis s =
+ let ve e = visitCabsExpression vis e in
+ let vs l s =
+ match visitCabsStatement vis s with
+ [s'] -> s'
+ | sl -> BLOCK ({blabels = []; battrs = []; bstmts = sl }, l)
+ in
+ match s with
+ NOP _ -> s
+ | COMPUTATION (e, l) ->
+ let e' = ve e in
+ if e' != e then COMPUTATION (e', l) else s
+ | BLOCK (b, l) ->
+ let b' = visitCabsBlock vis b in
+ if b' != b then BLOCK (b', l) else s
+ | SEQUENCE (s1, s2, l) ->
+ let s1' = vs l s1 in
+ let s2' = vs l s2 in
+ if s1' != s1 || s2' != s2 then SEQUENCE (s1', s2', l) else s
+ | IF (e, s1, s2, l) ->
+ let e' = ve e in
+ let s1' = vs l s1 in
+ let s2' = vs l s2 in
+ if e' != e || s1' != s1 || s2' != s2 then IF (e', s1', s2', l) else s
+ | 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) ->
+ 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) ->
+ let _ = vis#vEnterScope () in
+ let fc1' =
+ match fc1 with
+ FC_EXP e1 ->
+ let e1' = ve e1 in
+ if e1' != e1 then FC_EXP e1' else fc1
+ | FC_DECL d1 ->
+ let d1' =
+ match visitCabsDefinition vis d1 with
+ [d1'] -> d1'
+ | _ -> E.s (E.unimp "visitCabs: for can have only one definition")
+ in
+ if d1' != d1 then FC_DECL d1' else fc1
+ in
+ let e2' = ve e2 in
+ let e3' = ve e3 in
+ let s4' = vs l s4 in
+ let _ = vis#vExitScope () in
+ if fc1' != fc1 || e2' != e2 || e3' != e3 || s4' != s4
+ then 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) ->
+ 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) ->
+ 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) ->
+ let e1' = ve e1 in
+ let e2' = ve e2 in
+ let s3' = vs l s3 in
+ if e1' != e1 || e2' != e2 || s3' != s3 then
+ CASERANGE (e1', e2', s3', l) else s
+ | DEFAULT (s1, l) ->
+ let s1' = vs l s1 in
+ if s1' != s1 then DEFAULT (s1', l) else s
+ | LABEL (n, s1, l) ->
+ let s1' = vs l s1 in
+ if s1' != s1 then LABEL (n, s1', l) else s
+ | COMPGOTO (e, l) ->
+ let e' = ve e in
+ if e' != e then COMPGOTO (e', l) else s
+ | DEFINITION d -> begin
+ match visitCabsDefinition vis d with
+ [d'] when d' == d -> s
+ | [d'] -> DEFINITION d'
+ | dl -> let l = get_definitionloc d in
+ let dl' = 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) =
+ let e' = ve e in
+ if e' != e then (i,s, e') else input
+ in
+ let details' = match details with
+ | None -> details
+ | Some { aoutputs = outl; ainputs = inl; aclobbers = clobs } ->
+ let outl' = mapNoCopy childrenIdentStringExp outl in
+ let inl' = mapNoCopy childrenIdentStringExp inl in
+ if outl' == outl && inl' == inl then
+ details
+ else
+ Some { aoutputs = outl'; ainputs = inl'; aclobbers = clobs }
+ in
+ if details' != details then
+ ASM (sl, b, details', l) else s
+ | TRY_FINALLY (b1, b2, l) ->
+ let b1' = visitCabsBlock vis b1 in
+ let b2' = visitCabsBlock vis b2 in
+ if b1' != b1 || b2' != b2 then TRY_FINALLY(b1', b2', l) else s
+ | TRY_EXCEPT (b1, e, b2, l) ->
+ let b1' = visitCabsBlock vis b1 in
+ let e' = visitCabsExpression vis e in
+ let b2' = visitCabsBlock vis b2 in
+ if b1' != b1 || e' != e || b2' != b2 then TRY_EXCEPT(b1', e', b2', l) else s
+
+
+and visitCabsExpression vis (e: expression) : expression =
+ doVisit vis vis#vexpr childrenExpression e
+and childrenExpression vis e =
+ let ve e = visitCabsExpression vis e in
+ match e with
+ NOTHING | LABELADDR _ -> e
+ | UNARY (uo, e1) ->
+ let e1' = ve e1 in
+ if e1' != e1 then UNARY (uo, e1') else e
+ | BINARY (bo, e1, e2) ->
+ let e1' = ve e1 in
+ let e2' = ve e2 in
+ if e1' != e1 || e2' != e2 then BINARY (bo, e1', e2') else e
+ | QUESTION (e1, e2, e3) ->
+ let e1' = ve e1 in
+ let e2' = ve e2 in
+ let e3' = ve e3 in
+ if e1' != e1 || e2' != e2 || e3' != e3 then
+ QUESTION (e1', e2', e3') else e
+ | CAST ((s, dt), ie) ->
+ let s' = visitCabsSpecifier vis s in
+ let dt' = visitCabsDeclType vis false dt in
+ let ie' = visitCabsInitExpression vis ie in
+ if s' != s || dt' != dt || ie' != ie then CAST ((s', dt'), ie') else e
+ | CALL (f, el) ->
+ let f' = ve f in
+ let el' = mapNoCopy ve el in
+ if f' != f || el' != el then CALL (f', el') else e
+ | COMMA el ->
+ let el' = mapNoCopy ve el in
+ if el' != el then COMMA (el') else e
+ | CONSTANT _ -> e
+ | PAREN e1 ->
+ let e1' = ve e1 in
+ 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) ->
+ let e1' = ve e1 in
+ if e1' != e1 then EXPR_SIZEOF (e1') else e
+ | TYPE_SIZEOF (s, dt) ->
+ let s' = visitCabsSpecifier vis s in
+ let dt' = visitCabsDeclType vis false dt in
+ if s' != s || dt' != dt then TYPE_SIZEOF (s' ,dt') else e
+ | EXPR_ALIGNOF (e1) ->
+ let e1' = ve e1 in
+ if e1' != e1 then EXPR_ALIGNOF (e1') else e
+ | TYPE_ALIGNOF (s, dt) ->
+ let s' = visitCabsSpecifier vis s in
+ let dt' = visitCabsDeclType vis false dt in
+ if s' != s || dt' != dt then TYPE_ALIGNOF (s' ,dt') else e
+ | INDEX (e1, e2) ->
+ let e1' = ve e1 in
+ let e2' = ve e2 in
+ if e1' != e1 || e2' != e2 then INDEX (e1', e2') else e
+ | MEMBEROF (e1, n) ->
+ let e1' = ve e1 in
+ if e1' != e1 then MEMBEROF (e1', n) else e
+ | MEMBEROFPTR (e1, n) ->
+ let e1' = ve e1 in
+ if e1' != e1 then MEMBEROFPTR (e1', n) else e
+ | 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 =
+ doVisit vis vis#vinitexpr childrenInitExpression ie
+and childrenInitExpression vis ie =
+ let rec childrenInitWhat iw =
+ match iw with
+ NEXT_INIT -> iw
+ | INFIELD_INIT (n, iw1) ->
+ let iw1' = childrenInitWhat iw1 in
+ if iw1' != iw1 then INFIELD_INIT (n, iw1') else iw
+ | ATINDEX_INIT (e, iw1) ->
+ let e' = visitCabsExpression vis e in
+ let iw1' = childrenInitWhat iw1 in
+ if e' != e || iw1' != iw1 then ATINDEX_INIT (e', iw1') else iw
+ | ATINDEXRANGE_INIT (e1, e2) ->
+ let e1' = visitCabsExpression vis e1 in
+ let e2' = visitCabsExpression vis e2 in
+ if e1' != e1 || e2' != e2 then ATINDEXRANGE_INIT (e1', e2') else iw
+ in
+ match ie with
+ NO_INIT -> ie
+ | SINGLE_INIT e ->
+ let e' = visitCabsExpression vis e in
+ if e' != e then SINGLE_INIT e' else ie
+ | COMPOUND_INIT il ->
+ let childrenOne ((iw, ie) as input) =
+ let iw' = childrenInitWhat iw in
+ let ie' = visitCabsInitExpression vis ie in
+ if iw' != iw || ie' != ie then (iw', ie') else input
+ in
+ let il' = mapNoCopy childrenOne il in
+ if il' != il then COMPOUND_INIT il' else ie
+
+
+and visitCabsAttribute vis (a: attribute) : attribute list =
+ doVisitList vis vis#vattr childrenAttribute a
+
+and childrenAttribute vis ((n, el) as input) =
+ let el' = mapNoCopy (visitCabsExpression vis) el in
+ if el' != el then (n, el') else input
+
+and visitCabsAttributes vis (al: attribute list) : attribute list =
+ mapNoCopyList (visitCabsAttribute vis) al
+
+let visitCabsFile (vis: cabsVisitor) ((fname, f): file) : file =
+ (fname, mapNoCopyList (visitCabsDefinition vis) f)
+
+ (* end of file *)
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(* cabsvisit.mli *)
+(* 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
+ * the node as it is *)
+ | 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
+ * (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
+ * function on the node *)
+
+type nameKind =
+ NVar (** Variable or function prototype
+ name *)
+ | NFun (** Function definition name *)
+ | NField (** The name of a field *)
+ | NType (** The name of a type *)
+
+
+(* All visit methods are called in preorder! (but you can use
+ * ChangeDoChildrenPost to change the order) *)
+class type cabsVisitor = object
+ method vexpr: Cabs.expression -> Cabs.expression visitAction (* expressions *)
+ method vinitexpr: Cabs.init_expression -> Cabs.init_expression visitAction
+ method vstmt: Cabs.statement -> Cabs.statement list visitAction
+ method vblock: Cabs.block -> Cabs.block visitAction
+ method vvar: string -> string (* use of a variable
+ * names *)
+ method vdef: Cabs.definition -> Cabs.definition list visitAction
+ method vtypespec: Cabs.typeSpecifier -> Cabs.typeSpecifier visitAction
+ method vdecltype: Cabs.decl_type -> Cabs.decl_type visitAction
+
+ (* For each declaration we call vname *)
+ method vname: nameKind -> Cabs.specifier -> Cabs.name -> Cabs.name visitAction
+ method vspec: Cabs.specifier -> Cabs.specifier visitAction (* specifier *)
+ method vattr: Cabs.attribute -> Cabs.attribute list visitAction
+
+
+ method vEnterScope: unit -> unit
+ method vExitScope: unit -> unit
+end
+
+
+class nopCabsVisitor: cabsVisitor
+
+
+val visitCabsTypeSpecifier: cabsVisitor ->
+ Cabs.typeSpecifier -> Cabs.typeSpecifier
+val visitCabsSpecifier: cabsVisitor -> Cabs.specifier -> Cabs.specifier
+
+(** Visits a decl_type. The bool argument is saying whether we are ina
+ * function definition and thus the scope in a PROTO should extend until the
+ * end of the function *)
+val visitCabsDeclType: cabsVisitor -> bool -> Cabs.decl_type -> Cabs.decl_type
+val visitCabsDefinition: cabsVisitor -> Cabs.definition -> Cabs.definition list
+val visitCabsBlock: cabsVisitor -> Cabs.block -> Cabs.block
+val visitCabsStatement: cabsVisitor -> Cabs.statement -> Cabs.statement list
+val visitCabsExpression: cabsVisitor -> Cabs.expression -> Cabs.expression
+val visitCabsAttributes: cabsVisitor -> Cabs.attribute list
+ -> Cabs.attribute list
+val visitCabsName: cabsVisitor -> nameKind
+ -> Cabs.specifier -> Cabs.name -> Cabs.name
+val visitCabsFile: cabsVisitor -> Cabs.file -> Cabs.file
+
+
+
+(** Set by the visitor to the current location *)
+val visitorLocation: Cabs.cabsloc ref
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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 interface is generated manually. The corresponding .ml file is
+ * generated automatically and is placed in ../obj/clexer.ml. The reason we
+ * want this interface is to avoid confusing make with freshly generated
+ * interface files *)
+
+
+val init: filename:string -> Lexing.lexbuf
+val finish: unit -> unit
+
+(* This is the main parser function *)
+val initial: Lexing.lexbuf -> Cparser.token
+
+
+val push_context: unit -> unit (* Start a context *)
+val add_type: string -> unit (* Add a new string as a type name *)
+val add_identifier: string -> unit (* Add a new string as a variable name *)
+val pop_context: unit -> unit (* Remove all names added in this context *)
+
+val get_white: unit -> string
+val get_extra_lexeme: unit -> string
+val clear_white: unit -> unit
+val clear_lexeme: unit -> unit
+val currentLoc : unit -> Cabs.cabsloc
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2003,
+ * 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.
+ *
+ * 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.
+ *
+ *)
+(* FrontC -- lexical analyzer
+**
+** 1.0 3.22.99 Hugues Cassé First version.
+** 2.0 George Necula 12/12/00: Many extensions
+*)
+{
+open Cparser
+open Pretty
+exception Eof
+exception InternalError of string
+module E = Errormsg
+module H = Hashtbl
+
+let matchingParsOpen = ref 0
+
+let currentLoc () = Cabshelper.currentLoc ()
+
+(* string -> unit *)
+let addComment c =
+ let l = currentLoc() in
+ let i = GrowArray.max_init_index Cabshelper.commentsGA in
+ GrowArray.setg Cabshelper.commentsGA (i+1) (l,c,false)
+
+(* track whitespace for the current token *)
+let white = ref ""
+let addWhite lexbuf = if not !Whitetrack.enabled then
+ let w = Lexing.lexeme lexbuf in
+ white := !white ^ w
+let clear_white () = white := ""
+let get_white () = !white
+
+let lexeme = ref ""
+let addLexeme lexbuf =
+ let l = Lexing.lexeme lexbuf in
+ lexeme := !lexeme ^ l
+let clear_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
+ begin
+ let msg = Printf.sprintf "clexer:intlist_to_string: character 0x%Lx too big" value in
+ E.parse_error msg;
+ end
+ else
+ Char.chr (Int64.to_int value)
+
+(* takes a not-nul-terminated list, and converts it to a string. *)
+let rec intlist_to_string (str: int64 list):string =
+ match str with
+ [] -> "" (* add nul-termination *)
+ | value::rest ->
+ let this_char = int64_to_char value in
+ (String.make 1 this_char) ^ (intlist_to_string rest)
+
+(* Some debugging support for line numbers *)
+let dbgToken (t: token) =
+ if false then begin
+ ignore (E.log "%a" insert
+ (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
+ | IF l -> dprintf "IF(%d)\n" l.Cabs.lineno
+ | SWITCH l -> dprintf "SWITCH(%d)\n" l.Cabs.lineno
+ | RETURN l -> dprintf "RETURN(%d)\n" l.Cabs.lineno
+ | _ -> nil));
+ t
+ end else
+ t
+
+
+(*
+** Keyword hashtable
+*)
+let lexicon = H.create 211
+let init_lexicon _ =
+ H.clear lexicon;
+ List.iter
+ (fun (key, builder) -> H.add lexicon key builder)
+ [ ("auto", fun loc -> AUTO loc);
+ ("const", fun loc -> CONST loc);
+ ("__const", fun loc -> CONST loc);
+ ("__const__", fun loc -> CONST loc);
+ ("static", fun loc -> STATIC loc);
+ ("extern", fun loc -> EXTERN loc);
+ ("long", fun loc -> LONG loc);
+ ("short", fun loc -> SHORT loc);
+ ("register", fun loc -> REGISTER loc);
+ ("signed", fun loc -> SIGNED loc);
+ ("__signed", fun loc -> SIGNED loc);
+ ("unsigned", fun loc -> UNSIGNED loc);
+ ("volatile", fun loc -> VOLATILE loc);
+ ("__volatile", fun loc -> VOLATILE loc);
+ (* WW: see /usr/include/sys/cdefs.h for why __signed and __volatile
+ * are accepted GCC-isms *)
+ ("char", fun loc -> CHAR loc);
+ ("int", fun loc -> INT loc);
+ ("float", fun loc -> FLOAT loc);
+ ("double", fun loc -> DOUBLE loc);
+ ("void", fun loc -> VOID loc);
+ ("enum", fun loc -> ENUM loc);
+ ("struct", fun loc -> STRUCT loc);
+ ("typedef", fun loc -> TYPEDEF loc);
+ ("union", fun loc -> UNION loc);
+ ("break", fun loc -> BREAK loc);
+ ("continue", fun loc -> CONTINUE loc);
+ ("goto", fun loc -> GOTO loc);
+ ("return", fun loc -> dbgToken (RETURN loc));
+ ("switch", fun loc -> dbgToken (SWITCH loc));
+ ("case", fun loc -> CASE loc);
+ ("default", fun loc -> DEFAULT loc);
+ ("while", fun loc -> WHILE loc);
+ ("do", fun loc -> DO loc);
+ ("for", fun loc -> FOR loc);
+ ("if", fun loc -> dbgToken (IF loc));
+ ("else", fun _ -> ELSE);
+ (*** Implementation specific keywords ***)
+ ("__signed__", fun loc -> SIGNED loc);
+ ("__inline__", fun loc -> INLINE loc);
+ ("inline", fun loc -> INLINE loc);
+ ("__inline", fun loc -> INLINE loc);
+ ("_inline", fun loc ->
+ if !Cprint.msvcMode then
+ INLINE loc
+ else
+ IDENT ("_inline", loc));
+ ("__attribute__", fun loc -> ATTRIBUTE loc);
+ ("__attribute", fun loc -> ATTRIBUTE loc);
+(*
+ ("__attribute_used__", fun loc -> ATTRIBUTE_USED loc);
+*)
+ ("__blockattribute__", fun _ -> BLOCKATTRIBUTE);
+ ("__blockattribute", fun _ -> BLOCKATTRIBUTE);
+ ("__asm__", fun loc -> ASM loc);
+ ("asm", fun loc -> ASM loc);
+ ("__typeof__", fun loc -> TYPEOF loc);
+ ("__typeof", fun loc -> TYPEOF loc);
+ ("typeof", fun loc -> TYPEOF loc);
+ ("__alignof", fun loc -> ALIGNOF loc);
+ ("__alignof__", fun loc -> ALIGNOF loc);
+ ("__volatile__", fun loc -> VOLATILE loc);
+ ("__volatile", fun loc -> VOLATILE loc);
+
+ ("__FUNCTION__", fun loc -> FUNCTION__ loc);
+ ("__func__", fun loc -> FUNCTION__ loc); (* ISO 6.4.2.2 *)
+ ("__PRETTY_FUNCTION__", fun loc -> PRETTY_FUNCTION__ loc);
+ ("__label__", fun _ -> LABEL__);
+ (*** weimer: GCC arcana ***)
+ ("__restrict", fun loc -> RESTRICT loc);
+ ("__restrict__", fun loc -> RESTRICT loc);
+ ("restrict", fun loc -> RESTRICT loc);
+(* ("__extension__", EXTENSION); *)
+ (**** MS VC ***)
+ ("__int64", fun _ -> INT64 (currentLoc ()));
+ ("__int32", fun loc -> INT loc);
+ ("_cdecl", fun _ -> MSATTR ("_cdecl", currentLoc ()));
+ ("__cdecl", fun _ -> MSATTR ("__cdecl", currentLoc ()));
+ ("_stdcall", fun _ -> MSATTR ("_stdcall", currentLoc ()));
+ ("__stdcall", fun _ -> MSATTR ("__stdcall", currentLoc ()));
+ ("_fastcall", fun _ -> MSATTR ("_fastcall", currentLoc ()));
+ ("__fastcall", fun _ -> MSATTR ("__fastcall", currentLoc ()));
+ ("__w64", fun _ -> MSATTR("__w64", currentLoc ()));
+ ("__declspec", fun loc -> DECLSPEC loc);
+ ("__forceinline", fun loc -> INLINE loc); (* !! we turn forceinline
+ * into inline *)
+ ("__try", fun loc -> TRY loc);
+ ("__except", fun loc -> EXCEPT loc);
+ ("__finally", fun loc -> FINALLY loc);
+ (* weimer: some files produced by 'GCC -E' expect this type to be
+ * defined *)
+ ("__builtin_va_list",
+ fun _ -> NAMED_TYPE ("__builtin_va_list", 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 loc
+ else
+ IDENT ("__thread", loc));
+ ]
+
+(* Mark an identifier as a type name. The old mapping is preserved and will
+ * be reinstated when we exit this context *)
+let add_type name =
+ (* ignore (print_string ("adding type name " ^ name ^ "\n")); *)
+ H.add lexicon name (fun loc -> NAMED_TYPE (name, loc))
+
+let context : string list list ref = ref []
+
+let push_context _ = context := []::!context
+
+let pop_context _ =
+ match !context with
+ [] -> raise (InternalError "Empty context stack")
+ | con::sub ->
+ (context := sub;
+ 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
+ * will be reinstated when we exit this context *)
+let add_identifier name =
+ match !context with
+ [] -> () (* Just ignore raise (InternalError "Empty context stack") *)
+ | con::sub ->
+ (context := (name::con)::sub;
+ (* print_string ("adding IDENT for " ^ name ^ "\n"); *)
+ H.add lexicon name (fun loc ->
+ dbgToken (IDENT (name, loc))))
+
+
+(*
+** Useful primitives
+*)
+let scan_ident id =
+ let here = currentLoc () in
+ try (H.find lexicon id) here
+ (* default to variable name, as opposed to type *)
+ with Not_found ->
+ if id.[0] = '$' then QUALIFIER(id,here) else
+ dbgToken (IDENT (id, here))
+
+
+(*
+** Buffer processor
+*)
+
+
+let init ~(filename: string) : Lexing.lexbuf =
+ init_lexicon ();
+ (* Inititialize the pointer in Errormsg *)
+ Lexerhack.add_type := add_type;
+ Lexerhack.push_context := push_context;
+ Lexerhack.pop_context := pop_context;
+ Lexerhack.add_identifier := add_identifier;
+ E.startParsing filename
+
+
+let finish () =
+ E.finishParsing ()
+
+(*** Error handling ***)
+let error msg =
+ E.parse_error msg
+
+
+(*** escape character management ***)
+let scan_escape (char: char) : int64 =
+ let result = match char with
+ 'n' -> '\n'
+ | 'r' -> '\r'
+ | 't' -> '\t'
+ | 'b' -> '\b'
+ | 'f' -> '\012' (* ASCII code 12 *)
+ | 'v' -> '\011' (* ASCII code 11 *)
+ | 'a' -> '\007' (* ASCII code 7 *)
+ | 'e' | 'E' -> '\027' (* ASCII code 27. This is a GCC extension *)
+ | '\'' -> '\''
+ | '"'-> '"' (* '"' *)
+ | '?' -> '?'
+ | '(' when not !Cprint.msvcMode -> '('
+ | '{' when not !Cprint.msvcMode -> '{'
+ | '[' when not !Cprint.msvcMode -> '['
+ | '%' when not !Cprint.msvcMode -> '%'
+ | '\\' -> '\\'
+ | other -> error ("Unrecognized escape sequence: \\" ^ (String.make 1 other))
+ in
+ Int64.of_int (Char.code result)
+
+let scan_hex_escape str =
+ let radix = Int64.of_int 16 in
+ let the_value = ref Int64.zero in
+ (* start at character 2 to skip the \x *)
+ for i = 2 to (String.length str) - 1 do
+ let thisDigit = Cabshelper.valueOfDigit (String.get str i) in
+ (* the_value := !the_value * 16 + thisDigit *)
+ the_value := Int64.add (Int64.mul !the_value radix) thisDigit
+ done;
+ !the_value
+
+let scan_oct_escape str =
+ let radix = Int64.of_int 8 in
+ let the_value = ref Int64.zero in
+ (* start at character 1 to skip the \x *)
+ for i = 1 to (String.length str) - 1 do
+ let thisDigit = Cabshelper.valueOfDigit (String.get str i) in
+ (* the_value := !the_value * 8 + thisDigit *)
+ the_value := Int64.add (Int64.mul !the_value radix) thisDigit
+ done;
+ !the_value
+
+let lex_hex_escape remainder lexbuf =
+ let prefix = scan_hex_escape (Lexing.lexeme lexbuf) in
+ prefix :: remainder lexbuf
+
+let lex_oct_escape remainder lexbuf =
+ let prefix = scan_oct_escape (Lexing.lexeme lexbuf) in
+ prefix :: remainder lexbuf
+
+let lex_simple_escape remainder lexbuf =
+ let lexchar = Lexing.lexeme_char lexbuf 1 in
+ let prefix = scan_escape lexchar in
+ prefix :: remainder lexbuf
+
+let lex_unescaped remainder lexbuf =
+ let prefix = Int64.of_int (Char.code (Lexing.lexeme_char lexbuf 0)) in
+ prefix :: remainder lexbuf
+
+let lex_comment remainder lexbuf =
+ let ch = Lexing.lexeme_char lexbuf 0 in
+ let prefix = Int64.of_int (Char.code ch) in
+ if ch = '\n' then E.newline();
+ prefix :: remainder lexbuf
+
+let make_char (i:int64):char =
+ let min_val = Int64.zero in
+ let max_val = Int64.of_int 255 in
+ (* if i < 0 || i > 255 then error*)
+ if compare i min_val < 0 || compare i max_val > 0 then begin
+ let msg = Printf.sprintf "clexer:make_char: character 0x%Lx too big" i in
+ error msg
+ end;
+ Char.chr (Int64.to_int i)
+
+
+(* ISO standard locale-specific function to convert a wide character
+ * into a sequence of normal characters. Here we work on strings.
+ * We convert L"Hi" to "H\000i\000"
+ matth: this seems unused.
+let wbtowc wstr =
+ let len = String.length wstr in
+ let dest = String.make (len * 2) '\000' in
+ for i = 0 to len-1 do
+ dest.[i*2] <- wstr.[i] ;
+ done ;
+ dest
+*)
+
+(* This function converst the "Hi" in L"Hi" to { L'H', L'i', L'\0' }
+ matth: this seems unused.
+let wstr_to_warray wstr =
+ let len = String.length wstr in
+ let res = ref "{ " in
+ for i = 0 to len-1 do
+ res := !res ^ (Printf.sprintf "L'%c', " wstr.[i])
+ done ;
+ res := !res ^ "}" ;
+ !res
+*)
+
+(* Pragmas get explicit end-of-line tokens.
+ * Elsewhere they are silently discarded as whitespace. *)
+let pragmaLine = ref false
+
+}
+
+let decdigit = ['0'-'9']
+let octdigit = ['0'-'7']
+let hexdigit = ['0'-'9' 'a'-'f' 'A'-'F']
+let letter = ['a'- 'z' 'A'-'Z']
+
+
+let usuffix = ['u' 'U']
+let lsuffix = "l"|"L"|"ll"|"LL"
+let intsuffix = lsuffix | usuffix | usuffix lsuffix | lsuffix usuffix
+ | usuffix ? "i64"
+
+
+let hexprefix = '0' ['x' 'X']
+
+let intnum = decdigit+ intsuffix?
+let octnum = '0' octdigit+ intsuffix?
+let hexnum = hexprefix hexdigit+ intsuffix?
+
+let exponent = ['e' 'E']['+' '-']? decdigit+
+let fraction = '.' decdigit+
+let decfloat = (intnum? fraction)
+ |(intnum exponent)
+ |(intnum? fraction exponent)
+ | (intnum '.')
+ | (intnum '.' exponent)
+
+let hexfraction = hexdigit* '.' hexdigit+ | hexdigit+
+let binexponent = ['p' 'P'] ['+' '-']? decdigit+
+let hexfloat = hexprefix hexfraction binexponent
+ | hexprefix hexdigit+ binexponent
+
+let floatsuffix = ['f' 'F' 'l' 'L']
+let floatnum = (decfloat | hexfloat) floatsuffix?
+
+let ident = (letter|'_'|'$')(letter|decdigit|'_'|'$')*
+let blank = [' ' '\t' '\012' '\r']+
+let escape = '\\' _
+let hex_escape = '\\' ['x' 'X'] hexdigit+
+let oct_escape = '\\' octdigit octdigit? octdigit?
+
+(* Pragmas that are not parsed by CIL. We lex them as PRAGMA_LINE tokens *)
+let no_parse_pragma =
+ "warning" | "GCC"
+ (* Solaris-style pragmas: *)
+ | "ident" | "section" | "option" | "asm" | "use_section" | "weak"
+ | "redefine_extname"
+ | "TCS_align"
+
+
+rule initial =
+ parse "/*" { let il = comment lexbuf in
+ let sl = intlist_to_string il in
+ addComment sl;
+ addWhite lexbuf;
+ initial lexbuf}
+| "//" { let il = onelinecomment lexbuf in
+ let sl = intlist_to_string il in
+ addComment sl;
+ E.newline();
+ addWhite lexbuf;
+ initial lexbuf
+ }
+| blank { addWhite lexbuf; initial lexbuf}
+| '\n' { E.newline ();
+ if !pragmaLine then
+ begin
+ pragmaLine := false;
+ PRAGMA_EOL
+ end
+ else begin
+ addWhite lexbuf;
+ initial lexbuf
+ end}
+| '\\' '\r' * '\n' { addWhite lexbuf;
+ E.newline ();
+ initial lexbuf
+ }
+| '#' { addWhite lexbuf; hash lexbuf}
+| "_Pragma" { PRAGMA (currentLoc ()) }
+| '\'' { CST_CHAR (chr lexbuf, currentLoc ())}
+| "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
+ * L"Hello, " "world"
+ * then it should be treated as wide even though there's no L immediately
+ * preceding it. See test/small1/wchar5.c for a failure case. *)
+ try CST_STRING (str lexbuf, currentLoc ())
+ with e ->
+ raise (InternalError
+ ("str: " ^
+ Printexc.to_string e))}
+| "L\"" { (* weimer: wchar_t string literal *)
+ try CST_WSTRING(str lexbuf, currentLoc ())
+ with e ->
+ raise (InternalError
+ ("wide string: " ^
+ Printexc.to_string e))}
+| floatnum {CST_FLOAT (Lexing.lexeme lexbuf, currentLoc ())}
+| hexnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())}
+| octnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())}
+| intnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())}
+| "!quit!" {EOF}
+| "..." {ELLIPSIS}
+| "+=" {PLUS_EQ}
+| "-=" {MINUS_EQ}
+| "*=" {STAR_EQ}
+| "/=" {SLASH_EQ}
+| "%=" {PERCENT_EQ}
+| "|=" {PIPE_EQ}
+| "&=" {AND_EQ}
+| "^=" {CIRC_EQ}
+| "<<=" {INF_INF_EQ}
+| ">>=" {SUP_SUP_EQ}
+| "<<" {INF_INF}
+| ">>" {SUP_SUP}
+| "==" {EQ_EQ}
+| "!=" {EXCLAM_EQ}
+| "<=" {INF_EQ}
+| ">=" {SUP_EQ}
+| "=" {EQ}
+| "<" {INF}
+| ">" {SUP}
+| "++" {PLUS_PLUS (currentLoc ())}
+| "--" {MINUS_MINUS (currentLoc ())}
+| "->" {ARROW}
+| '+' {PLUS (currentLoc ())}
+| '-' {MINUS (currentLoc ())}
+| '*' {STAR (currentLoc ())}
+| '/' {SLASH}
+| '%' {PERCENT}
+| '!' {EXCLAM (currentLoc ())}
+| "&&" {AND_AND (currentLoc ())}
+| "||" {PIPE_PIPE}
+| '&' {AND (currentLoc ())}
+| '|' {PIPE}
+| '^' {CIRC}
+| '?' {QUEST}
+| ':' {COLON}
+| '~' {TILDE (currentLoc ())}
+
+| '{' {dbgToken (LBRACE (currentLoc ()))}
+| '}' {dbgToken (RBRACE (currentLoc ()))}
+| '[' {LBRACKET}
+| ']' {RBRACKET}
+| '(' {dbgToken (LPAREN (currentLoc ())) }
+| ')' {RPAREN}
+| ';' {dbgToken (SEMICOLON (currentLoc ())) }
+| ',' {COMMA}
+| '.' {DOT}
+| "sizeof" {SIZEOF (currentLoc ())}
+| "__asm" { if !Cprint.msvcMode then
+ MSASM (msasm lexbuf, currentLoc ())
+ else (ASM (currentLoc ())) }
+
+(* If we see __pragma we eat it and the matching parentheses as well *)
+| "__pragma" { matchingParsOpen := 0;
+ let _ = matchingpars lexbuf in
+ addWhite lexbuf;
+ initial lexbuf
+ }
+
+(* sm: tree transformation keywords *)
+| "@transform" {AT_TRANSFORM (currentLoc ())}
+| "@transformExpr" {AT_TRANSFORMEXPR (currentLoc ())}
+| "@specifier" {AT_SPECIFIER (currentLoc ())}
+| "@expr" {AT_EXPR (currentLoc ())}
+| "@name" {AT_NAME}
+
+(* __extension__ is a black. The parser runs into some conflicts if we let it
+ * pass *)
+| "__extension__" {addWhite lexbuf; initial lexbuf }
+| ident {scan_ident (Lexing.lexeme lexbuf)}
+| eof {EOF}
+| _ {E.parse_error "Invalid symbol"}
+and comment =
+ parse
+ "*/" { addWhite lexbuf; [] }
+(*| '\n' { E.newline (); lex_unescaped comment lexbuf }*)
+| _ { addWhite lexbuf; lex_comment comment lexbuf }
+
+
+and onelinecomment = parse
+ '\n'|eof {addWhite lexbuf; []}
+| _ {addWhite lexbuf; lex_comment onelinecomment lexbuf }
+
+and matchingpars = parse
+ '\n' { addWhite lexbuf; E.newline (); matchingpars lexbuf }
+| blank { addWhite lexbuf; matchingpars lexbuf }
+| '(' { addWhite lexbuf; incr matchingParsOpen; matchingpars lexbuf }
+| ')' { addWhite lexbuf; decr matchingParsOpen;
+ if !matchingParsOpen = 0 then
+ ()
+ else
+ matchingpars lexbuf
+ }
+| "/*" { addWhite lexbuf; let il = comment lexbuf in
+ let sl = intlist_to_string il in
+ addComment sl;
+ matchingpars lexbuf}
+| '"' { addWhite lexbuf; (* '"' *)
+ let _ = str lexbuf in
+ matchingpars lexbuf
+ }
+| _ { addWhite lexbuf; matchingpars lexbuf }
+
+(* # <line number> <file name> ... *)
+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
+ * next line *)
+ let s = Lexing.lexeme lexbuf in
+ let lineno = try
+ int_of_string s
+ with Failure ("int_of_string") ->
+ (* the int is too big. *)
+ E.warn "Bad line number in preprocessed file: %s" s;
+ (-1)
+ in
+ E.setCurrentLine (lineno - 1);
+ (* A file name may follow *)
+ file lexbuf }
+| "line" { addWhite lexbuf; hash lexbuf } (* MSVC line number info *)
+ (* For pragmas with irregular syntax, like #pragma warning,
+ * we parse them as a whole line. *)
+| "pragma" blank (no_parse_pragma as pragmaName)
+ { let here = currentLoc () in
+ PRAGMA_LINE (pragmaName ^ pragma lexbuf, here)
+ }
+| "pragma" { pragmaLine := true; PRAGMA (currentLoc ()) }
+| _ { addWhite lexbuf; endline lexbuf}
+
+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
+ ((String.length n) - 2) in
+ E.setCurrentFile n1;
+ endline lexbuf}
+
+| _ {addWhite lexbuf; endline lexbuf}
+
+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) }
+
+and str = parse
+ '"' {[]} (* no nul terminiation in CST_STRING '"' *)
+| hex_escape {addLexeme lexbuf; lex_hex_escape str lexbuf}
+| oct_escape {addLexeme lexbuf; lex_oct_escape str lexbuf}
+| escape {addLexeme lexbuf; lex_simple_escape str lexbuf}
+| _ {addLexeme lexbuf; lex_unescaped str lexbuf}
+
+and chr = parse
+ '\'' {[]}
+| hex_escape {lex_hex_escape chr lexbuf}
+| oct_escape {lex_oct_escape chr lexbuf}
+| escape {lex_simple_escape chr lexbuf}
+| _ {lex_unescaped chr lexbuf}
+
+and msasm = parse
+ blank { msasm lexbuf }
+| '{' { msasminbrace lexbuf }
+| _ { let cur = Lexing.lexeme lexbuf in
+ cur ^ (msasmnobrace lexbuf) }
+
+and msasminbrace = parse
+ '}' { "" }
+| _ { let cur = Lexing.lexeme lexbuf in
+ cur ^ (msasminbrace lexbuf) }
+and msasmnobrace = parse
+ ['}' ';' '\n'] { lexbuf.Lexing.lex_curr_pos <-
+ lexbuf.Lexing.lex_curr_pos - 1;
+ "" }
+| "__asm" { lexbuf.Lexing.lex_curr_pos <-
+ lexbuf.Lexing.lex_curr_pos - 5;
+ "" }
+| _ { let cur = Lexing.lexeme lexbuf in
+
+ cur ^ (msasmnobrace lexbuf) }
+
+{
+
+}
--- /dev/null
+/*(*
+ *
+ * Copyright (c) 2001-2003,
+ * 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.
+ *
+ * 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.
+ *
+ **)
+(**
+** 1.0 3.22.99 Hugues Cassé First version.
+** 2.0 George Necula 12/12/00: Practically complete rewrite.
+*)
+*/
+%{
+open Cabs
+open Cabshelper
+module E = Errormsg
+
+let parse_error msg : unit = (* sm: c++-mode highlight hack: -> ' <- *)
+ E.parse_error msg
+
+let print = print_string
+
+(* unit -> string option *)
+(*
+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";
+ byteno = -10;
+ ident = 0;}
+
+(* cabsloc -> cabsloc *)
+(*
+let handleLoc l =
+ l.clcomment <- getComments();
+ l
+*)
+
+(*
+** Expression building
+*)
+let smooth_expression lst =
+ match lst with
+ [] -> NOTHING
+ | [expr] -> expr
+ | _ -> COMMA (lst)
+
+
+let currentFunctionName = ref "<outside any function>"
+
+let announceFunctionName ((n, decl, _, _):name) =
+ !Lexerhack.add_identifier n;
+ (* Start a context that includes the parameter names and the whole body.
+ * Will pop when we finish parsing the function body *)
+ !Lexerhack.push_context ();
+ (* Go through all the parameter names and mark them as identifiers *)
+ let rec findProto = function
+ PROTO (d, args, _) when isJUSTBASE d ->
+ List.iter (fun (_, (an, _, _, _)) -> !Lexerhack.add_identifier an) args
+
+ | PROTO (d, _, _) -> findProto d
+ | PARENTYPE (_, d, _) -> findProto d
+ | PTR (_, d) -> findProto d
+ | ARRAY (d, _, _) -> findProto d
+ | _ -> parse_error "Cannot find the prototype in a function definition";
+ raise Parsing.Parse_error
+
+ and isJUSTBASE = function
+ JUSTBASE -> true
+ | PARENTYPE (_, d, _) -> isJUSTBASE d
+ | _ -> false
+ in
+ findProto decl;
+ currentFunctionName := n
+
+
+
+let applyPointer (ptspecs: attribute list list) (dt: decl_type)
+ : decl_type =
+ (* Outer specification first *)
+ let rec loop = function
+ [] -> dt
+ | attrs :: rest -> PTR(attrs, loop rest)
+ in
+ loop ptspecs
+
+let doDeclaration (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;
+ TYPEDEF ((specs, List.map (fun (n, _) -> n) nl), loc)
+ end else
+ if nl = [] then
+ ONLYTYPEDEF (specs, loc)
+ else begin
+ (* Tell the lexer about the new variable names *)
+ List.iter (fun ((n, _, _, _), _) -> !Lexerhack.add_identifier n) nl;
+ DECDEF ((specs, nl), loc)
+ end
+
+
+let doFunctionDef (loc: cabsloc)
+ (lend: cabsloc)
+ (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))
+ : single_name list * bool =
+ let findOneName n =
+ (* Search in pardefs for the definition for this parameter *)
+ let rec loopGroups = function
+ [] -> ([SpecType Tint], (n, JUSTBASE, [], cabslu))
+ | (specs, names) :: restgroups ->
+ let rec loopNames = function
+ [] -> loopGroups restgroups
+ | ((n',_, _, _) as sn) :: _ when n' = n -> (specs, sn)
+ | _ :: restnames -> loopNames restnames
+ in
+ loopNames names
+ in
+ loopGroups pardefs
+ in
+ let args = List.map findOneName names in
+ (args, isva)
+
+let checkConnective (s : string) : unit =
+begin
+ (* checking this means I could possibly have more connectives, with *)
+ (* different meaning *)
+ if (s <> "to") then (
+ parse_error "transformer connective must be 'to'";
+ raise Parsing.Parse_error
+ )
+ else ()
+end
+
+let int64_to_char value =
+ if (compare value (Int64.of_int 255) > 0) || (compare value Int64.zero < 0) then
+ begin
+ let msg = Printf.sprintf "cparser:intlist_to_string: character 0x%Lx too big" value in
+ parse_error msg;
+ raise Parsing.Parse_error
+ end
+ else
+ Char.chr (Int64.to_int value)
+
+(* takes a not-nul-terminated list, and converts it to a string. *)
+let rec intlist_to_string (str: int64 list):string =
+ match str with
+ [] -> "" (* add nul-termination *)
+ | value::rest ->
+ let this_char = int64_to_char value in
+ (String.make 1 this_char) ^ (intlist_to_string rest)
+
+let fst3 (result, _, _) = result
+let snd3 (_, result, _) = result
+let trd3 (_, _, result) = result
+
+
+(*
+ transform: __builtin_offsetof(type, member)
+ into : (size_t) (&(type * ) 0)->member
+ *)
+
+let transformOffsetOf (speclist, dtype) member =
+ let rec addPointer = function
+ | JUSTBASE ->
+ PTR([], JUSTBASE)
+ | PARENTYPE (attrs1, dtype, attrs2) ->
+ PARENTYPE (attrs1, addPointer dtype, attrs2)
+ | ARRAY (dtype, attrs, expr) ->
+ ARRAY (addPointer dtype, attrs, expr)
+ | PTR (attrs, dtype) ->
+ PTR (attrs, addPointer dtype)
+ | PROTO (dtype, names, variadic) ->
+ PROTO (addPointer dtype, names, variadic)
+ in
+ let nullType = (speclist, addPointer dtype) in
+ let nullExpr = CONSTANT (CONST_INT "0") in
+ let castExpr = CAST (nullType, SINGLE_INIT nullExpr) in
+
+ let rec replaceBase = function
+ | VARIABLE field ->
+ MEMBEROFPTR (castExpr, field)
+ | MEMBEROF (base, field) ->
+ MEMBEROF (replaceBase base, field)
+ | INDEX (base, index) ->
+ INDEX (replaceBase base, index)
+ | _ ->
+ parse_error "malformed offset expression in __builtin_offsetof";
+ raise Parsing.Parse_error
+ in
+ let memberExpr = replaceBase member in
+ let addrExpr = UNARY (ADDROF, memberExpr) in
+ (* slight cheat: hard-coded assumption that size_t == unsigned int *)
+ let sizeofType = [SpecType Tunsigned], JUSTBASE in
+ let resultExpr = CAST (sizeofType, SINGLE_INIT addrExpr) in
+ resultExpr
+
+%}
+
+%token <string * Cabs.cabsloc> IDENT
+%token <string * Cabs.cabsloc> QUALIFIER
+%token <int64 list * Cabs.cabsloc> CST_CHAR
+%token <int64 list * Cabs.cabsloc> CST_WCHAR
+%token <string * Cabs.cabsloc> CST_INT
+%token <string * Cabs.cabsloc> CST_FLOAT
+%token <string * Cabs.cabsloc> NAMED_TYPE
+
+/* Each character is its own list element, and the terminating nul is not
+ included in this list. */
+%token <int64 list * Cabs.cabsloc> CST_STRING
+%token <int64 list * Cabs.cabsloc> CST_WSTRING
+
+%token EOF
+%token<Cabs.cabsloc> CHAR INT DOUBLE FLOAT VOID INT64 INT32
+%token<Cabs.cabsloc> ENUM STRUCT TYPEDEF UNION
+%token<Cabs.cabsloc> SIGNED UNSIGNED LONG SHORT
+%token<Cabs.cabsloc> VOLATILE EXTERN STATIC CONST RESTRICT AUTO REGISTER
+%token<Cabs.cabsloc> THREAD
+
+%token<Cabs.cabsloc> SIZEOF ALIGNOF
+
+%token EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ
+%token AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ
+%token ARROW DOT
+
+%token EQ_EQ EXCLAM_EQ INF SUP INF_EQ SUP_EQ
+%token<Cabs.cabsloc> PLUS MINUS STAR
+%token SLASH PERCENT
+%token<Cabs.cabsloc> TILDE AND
+%token PIPE CIRC
+%token<Cabs.cabsloc> EXCLAM AND_AND
+%token PIPE_PIPE
+%token INF_INF SUP_SUP
+%token<Cabs.cabsloc> PLUS_PLUS MINUS_MINUS
+
+%token RPAREN
+%token<Cabs.cabsloc> LPAREN RBRACE
+%token<Cabs.cabsloc> LBRACE
+%token LBRACKET RBRACKET
+%token COLON
+%token<Cabs.cabsloc> SEMICOLON
+%token COMMA ELLIPSIS QUEST
+
+%token<Cabs.cabsloc> BREAK CONTINUE GOTO RETURN
+%token<Cabs.cabsloc> SWITCH CASE DEFAULT
+%token<Cabs.cabsloc> WHILE DO FOR
+%token<Cabs.cabsloc> IF TRY EXCEPT FINALLY
+%token ELSE
+
+%token<Cabs.cabsloc> ATTRIBUTE INLINE ASM TYPEOF FUNCTION__ PRETTY_FUNCTION__
+%token LABEL__
+%token<Cabs.cabsloc> BUILTIN_VA_ARG ATTRIBUTE_USED
+%token BUILTIN_VA_LIST
+%token BLOCKATTRIBUTE
+%token<Cabs.cabsloc> BUILTIN_TYPES_COMPAT BUILTIN_OFFSETOF
+%token<Cabs.cabsloc> DECLSPEC
+%token<string * Cabs.cabsloc> MSASM MSATTR
+%token<string * Cabs.cabsloc> PRAGMA_LINE
+%token<Cabs.cabsloc> PRAGMA
+%token PRAGMA_EOL
+
+/* sm: cabs tree transformation specification keywords */
+%token<Cabs.cabsloc> AT_TRANSFORM AT_TRANSFORMEXPR AT_SPECIFIER AT_EXPR
+%token AT_NAME
+
+/* operator precedence */
+%nonassoc IF
+%nonassoc ELSE
+
+
+%left COMMA
+%right EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ
+ AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ
+%right QUEST COLON
+%left PIPE_PIPE
+%left AND_AND
+%left PIPE
+%left CIRC
+%left AND
+%left EQ_EQ EXCLAM_EQ
+%left INF SUP INF_EQ SUP_EQ
+%left INF_INF SUP_SUP
+%left PLUS MINUS
+%left STAR SLASH PERCENT CONST RESTRICT VOLATILE
+%right EXCLAM TILDE PLUS_PLUS MINUS_MINUS CAST RPAREN ADDROF SIZEOF ALIGNOF
+%left LBRACKET
+%left DOT ARROW LPAREN LBRACE
+%right NAMED_TYPE /* We'll use this to handle redefinitions of
+ * NAMED_TYPE as variables */
+%left IDENT
+
+/* Non-terminals informations */
+%start interpret file
+%type <Cabs.definition list> file interpret globals
+
+%type <Cabs.definition> global
+
+
+%type <Cabs.attribute list> attributes attributes_with_asm asmattr
+%type <Cabs.statement> statement
+%type <Cabs.constant * cabsloc> constant
+%type <string * cabsloc> string_constant
+%type <Cabs.expression * cabsloc> expression
+%type <Cabs.expression> opt_expression
+%type <Cabs.init_expression> init_expression
+%type <Cabs.expression list * cabsloc> comma_expression
+%type <Cabs.expression list * cabsloc> paren_comma_expression
+%type <Cabs.expression list> arguments
+%type <Cabs.expression list> bracket_comma_expression
+%type <int64 list Queue.t * cabsloc> string_list
+%type <int64 list * cabsloc> wstring_list
+
+%type <Cabs.initwhat * Cabs.init_expression> initializer
+%type <(Cabs.initwhat * Cabs.init_expression) list> initializer_list
+%type <Cabs.initwhat> init_designators init_designators_opt
+
+%type <spec_elem list * cabsloc> decl_spec_list
+%type <typeSpecifier * cabsloc> type_spec
+%type <Cabs.field_group list> struct_decl_list
+
+
+%type <Cabs.name> old_proto_decl
+%type <Cabs.single_name> parameter_decl
+%type <Cabs.enum_item> enumerator
+%type <Cabs.enum_item list> enum_list
+%type <Cabs.definition> declaration function_def
+%type <cabsloc * spec_elem list * name> function_def_start
+%type <Cabs.spec_elem list * Cabs.decl_type> type_name
+%type <Cabs.block * cabsloc * cabsloc> block
+%type <Cabs.statement list> block_element_list
+%type <string list> local_labels local_label_names
+%type <string list> old_parameter_list_ne
+
+%type <Cabs.init_name> init_declarator
+%type <Cabs.init_name list> init_declarator_list
+%type <Cabs.name> declarator
+%type <Cabs.name * expression option> field_decl
+%type <(Cabs.name * expression option) list> field_decl_list
+%type <string * Cabs.decl_type> direct_decl
+%type <Cabs.decl_type> abs_direct_decl abs_direct_decl_opt
+%type <Cabs.decl_type * Cabs.attribute list> abstract_decl
+
+ /* (* Each element is a "* <type_quals_opt>". *) */
+%type <attribute list list * cabsloc> pointer pointer_opt
+%type <Cabs.cabsloc> location
+%type <Cabs.spec_elem * cabsloc> cvspec
+%%
+
+interpret:
+ file EOF {$1}
+;
+file: globals {$1}
+;
+globals:
+ /* empty */ { [] }
+| global globals { $1 :: $2 }
+| SEMICOLON globals { $2 }
+;
+
+location:
+ /* empty */ { currentLoc () } %prec IDENT
+
+
+/*** Global Definition ***/
+global:
+| declaration { $1 }
+| 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
+ { LINKAGE (fst $2, (*handleLoc*) (snd $2), $4) }
+| ASM LPAREN string_constant RPAREN SEMICOLON
+ { GLOBASM (fst $3, (*handleLoc*) $1) }
+| pragma { $1 }
+/* (* Old-style function prototype. This should be somewhere else, like in
+ * "declaration". For now we keep it at global scope only because in local
+ * scope it looks too much like a function call *) */
+| IDENT LPAREN old_parameter_list_ne RPAREN old_pardef_list SEMICOLON
+ { (* Convert pardecl to new style *)
+ let pardecl, isva = doOldParDecl $3 $5 in
+ (* Make the function declarator *)
+ doDeclaration ((*handleLoc*) (snd $1)) []
+ [((fst $1, PROTO(JUSTBASE, pardecl,isva), [], cabslu),
+ NO_INIT)]
+ }
+/* (* Old style function prototype, but without any arguments *) */
+| IDENT LPAREN RPAREN SEMICOLON
+ { (* Make the function declarator *)
+ doDeclaration ((*handleLoc*)(snd $1)) []
+ [((fst $1, PROTO(JUSTBASE,[],false), [], cabslu),
+ NO_INIT)]
+ }
+/* transformer for a toplevel construct */
+| AT_TRANSFORM LBRACE global RBRACE IDENT/*to*/ LBRACE globals RBRACE {
+ checkConnective(fst $5);
+ TRANSFORMER($3, $7, $1)
+ }
+/* transformer for an expression */
+| AT_TRANSFORMEXPR LBRACE expression RBRACE IDENT/*to*/ LBRACE expression RBRACE {
+ checkConnective(fst $5);
+ EXPRTRANSFORMER(fst $3, fst $7, $1)
+ }
+| location error SEMICOLON { PRAGMA (VARIABLE "parse_error", $1) }
+;
+
+id_or_typename:
+ IDENT {fst $1}
+| NAMED_TYPE {fst $1}
+| AT_NAME LPAREN IDENT RPAREN { "@name(" ^ fst $3 ^ ")" } /* pattern variable name */
+;
+
+maybecomma:
+ /* empty */ { () }
+| COMMA { () }
+;
+
+/* *** Expressions *** */
+
+primary_expression: /*(* 6.5.1. *)*/
+| IDENT
+ {VARIABLE (fst $1), snd $1}
+| constant
+ {CONSTANT (fst $1), snd $1}
+| paren_comma_expression
+ {PAREN (smooth_expression (fst $1)), snd $1}
+| LPAREN block RPAREN
+ { GNU_BODY (fst3 $2), $1 }
+
+ /*(* Next is Scott's transformer *)*/
+| AT_EXPR LPAREN IDENT RPAREN /* expression pattern variable */
+ { EXPR_PATTERN(fst $3), $1 }
+;
+
+postfix_expression: /*(* 6.5.2 *)*/
+| primary_expression
+ { $1 }
+| postfix_expression bracket_comma_expression
+ {INDEX (fst $1, smooth_expression $2), snd $1}
+| postfix_expression LPAREN arguments RPAREN
+ {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",
+ [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",
+ [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
+ {MEMBEROFPTR (fst $1, $3), snd $1}
+| postfix_expression PLUS_PLUS
+ {UNARY (POSINCR, fst $1), snd $1}
+| postfix_expression MINUS_MINUS
+ {UNARY (POSDECR, fst $1), snd $1}
+/* (* We handle GCC constructor expressions *) */
+| LPAREN type_name RPAREN LBRACE initializer_list_opt RBRACE
+ { CAST($2, COMPOUND_INIT $5), $1 }
+;
+
+offsetof_member_designator: /* GCC extension for __builtin_offsetof */
+| id_or_typename
+ { VARIABLE ($1) }
+| offsetof_member_designator DOT IDENT
+ { MEMBEROF ($1, fst $3) }
+| offsetof_member_designator bracket_comma_expression
+ { INDEX ($1, smooth_expression $2) }
+;
+
+unary_expression: /*(* 6.5.3 *)*/
+| postfix_expression
+ { $1 }
+| PLUS_PLUS unary_expression
+ {UNARY (PREINCR, fst $2), $1}
+| MINUS_MINUS unary_expression
+ {UNARY (PREDECR, fst $2), $1}
+| SIZEOF unary_expression
+ {EXPR_SIZEOF (fst $2), $1}
+| SIZEOF LPAREN type_name RPAREN
+ {let b, d = $3 in TYPE_SIZEOF (b, d), $1}
+| ALIGNOF unary_expression
+ {EXPR_ALIGNOF (fst $2), $1}
+| ALIGNOF LPAREN type_name RPAREN
+ {let b, d = $3 in TYPE_ALIGNOF (b, d), $1}
+| PLUS cast_expression
+ {UNARY (PLUS, fst $2), $1}
+| MINUS cast_expression
+ {UNARY (MINUS, fst $2), $1}
+| STAR cast_expression
+ {UNARY (MEMOF, fst $2), $1}
+| AND cast_expression
+ {UNARY (ADDROF, fst $2), $1}
+| EXCLAM cast_expression
+ {UNARY (NOT, fst $2), $1}
+| TILDE cast_expression
+ {UNARY (BNOT, fst $2), $1}
+| AND_AND IDENT { LABELADDR (fst $2), $1 }
+;
+
+cast_expression: /*(* 6.5.4 *)*/
+| unary_expression
+ { $1 }
+| LPAREN type_name RPAREN cast_expression
+ { CAST($2, SINGLE_INIT (fst $4)), $1 }
+;
+
+multiplicative_expression: /*(* 6.5.5 *)*/
+| cast_expression
+ { $1 }
+| multiplicative_expression STAR cast_expression
+ {BINARY(MUL, fst $1, fst $3), snd $1}
+| multiplicative_expression SLASH cast_expression
+ {BINARY(DIV, fst $1, fst $3), snd $1}
+| multiplicative_expression PERCENT cast_expression
+ {BINARY(MOD, fst $1, fst $3), snd $1}
+;
+
+additive_expression: /*(* 6.5.6 *)*/
+| multiplicative_expression
+ { $1 }
+| additive_expression PLUS multiplicative_expression
+ {BINARY(ADD, fst $1, fst $3), snd $1}
+| additive_expression MINUS multiplicative_expression
+ {BINARY(SUB, fst $1, fst $3), snd $1}
+;
+
+shift_expression: /*(* 6.5.7 *)*/
+| additive_expression
+ { $1 }
+| shift_expression INF_INF additive_expression
+ {BINARY(SHL, fst $1, fst $3), snd $1}
+| shift_expression SUP_SUP additive_expression
+ {BINARY(SHR, fst $1, fst $3), snd $1}
+;
+
+
+relational_expression: /*(* 6.5.8 *)*/
+| shift_expression
+ { $1 }
+| relational_expression INF shift_expression
+ {BINARY(LT, fst $1, fst $3), snd $1}
+| relational_expression SUP shift_expression
+ {BINARY(GT, fst $1, fst $3), snd $1}
+| relational_expression INF_EQ shift_expression
+ {BINARY(LE, fst $1, fst $3), snd $1}
+| relational_expression SUP_EQ shift_expression
+ {BINARY(GE, fst $1, fst $3), snd $1}
+;
+
+equality_expression: /*(* 6.5.9 *)*/
+| relational_expression
+ { $1 }
+| equality_expression EQ_EQ relational_expression
+ {BINARY(EQ, fst $1, fst $3), snd $1}
+| equality_expression EXCLAM_EQ relational_expression
+ {BINARY(NE, fst $1, fst $3), snd $1}
+;
+
+
+bitwise_and_expression: /*(* 6.5.10 *)*/
+| equality_expression
+ { $1 }
+| bitwise_and_expression AND equality_expression
+ {BINARY(BAND, fst $1, fst $3), snd $1}
+;
+
+bitwise_xor_expression: /*(* 6.5.11 *)*/
+| bitwise_and_expression
+ { $1 }
+| bitwise_xor_expression CIRC bitwise_and_expression
+ {BINARY(XOR, fst $1, fst $3), snd $1}
+;
+
+bitwise_or_expression: /*(* 6.5.12 *)*/
+| bitwise_xor_expression
+ { $1 }
+| bitwise_or_expression PIPE bitwise_xor_expression
+ {BINARY(BOR, fst $1, fst $3), snd $1}
+;
+
+logical_and_expression: /*(* 6.5.13 *)*/
+| bitwise_or_expression
+ { $1 }
+| logical_and_expression AND_AND bitwise_or_expression
+ {BINARY(AND, fst $1, fst $3), snd $1}
+;
+
+logical_or_expression: /*(* 6.5.14 *)*/
+| logical_and_expression
+ { $1 }
+| logical_or_expression PIPE_PIPE logical_and_expression
+ {BINARY(OR, fst $1, fst $3), snd $1}
+;
+
+conditional_expression: /*(* 6.5.15 *)*/
+| logical_or_expression
+ { $1 }
+| logical_or_expression QUEST opt_expression COLON conditional_expression
+ {QUESTION (fst $1, $3, fst $5), snd $1}
+;
+
+/*(* The C spec says that left-hand sides of assignment expressions are unary
+ * expressions. GCC allows cast expressions in there ! *)*/
+
+assignment_expression: /*(* 6.5.16 *)*/
+| conditional_expression
+ { $1 }
+| cast_expression EQ assignment_expression
+ {BINARY(ASSIGN, fst $1, fst $3), snd $1}
+| cast_expression PLUS_EQ assignment_expression
+ {BINARY(ADD_ASSIGN, fst $1, fst $3), snd $1}
+| cast_expression MINUS_EQ assignment_expression
+ {BINARY(SUB_ASSIGN, fst $1, fst $3), snd $1}
+| cast_expression STAR_EQ assignment_expression
+ {BINARY(MUL_ASSIGN, fst $1, fst $3), snd $1}
+| cast_expression SLASH_EQ assignment_expression
+ {BINARY(DIV_ASSIGN, fst $1, fst $3), snd $1}
+| cast_expression PERCENT_EQ assignment_expression
+ {BINARY(MOD_ASSIGN, fst $1, fst $3), snd $1}
+| cast_expression AND_EQ assignment_expression
+ {BINARY(BAND_ASSIGN, fst $1, fst $3), snd $1}
+| cast_expression PIPE_EQ assignment_expression
+ {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
+ {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}
+;
+
+expression: /*(* 6.5.17 *)*/
+ assignment_expression
+ { $1 }
+;
+
+
+constant:
+ CST_INT {CONST_INT (fst $1), snd $1}
+| CST_FLOAT {CONST_FLOAT (fst $1), snd $1}
+| CST_CHAR {CONST_CHAR (fst $1), snd $1}
+| CST_WCHAR {CONST_WCHAR (fst $1), snd $1}
+| string_constant {CONST_STRING (fst $1), snd $1}
+| wstring_list {CONST_WSTRING (fst $1), snd $1}
+;
+
+string_constant:
+/* Now that we know this constant isn't part of a wstring, convert it
+ back to a string for easy viewing. */
+ string_list {
+ let queue, location = $1 in
+ let buffer = Buffer.create (Queue.length queue) in
+ Queue.iter
+ (List.iter
+ (fun value ->
+ let char = int64_to_char value in
+ Buffer.add_char buffer char))
+ queue;
+ Buffer.contents buffer, location
+ }
+;
+one_string_constant:
+/* Don't concat multiple strings. For asm templates. */
+ CST_STRING {intlist_to_string (fst $1) }
+;
+string_list:
+ one_string {
+ let queue = Queue.create () in
+ Queue.add (fst $1) queue;
+ queue, snd $1
+ }
+| string_list one_string {
+ Queue.add (fst $2) (fst $1);
+ $1
+ }
+;
+
+wstring_list:
+ CST_WSTRING { $1 }
+| wstring_list one_string { (fst $1) @ (fst $2), snd $1 }
+| wstring_list CST_WSTRING { (fst $1) @ (fst $2), snd $1 }
+/* Only the first string in the list needs an L, so L"a" "b" is the same
+ * as L"ab" or L"a" L"b". */
+
+one_string:
+ CST_STRING {$1}
+| FUNCTION__ {(Cabshelper.explodeStringToInts
+ !currentFunctionName), $1}
+| PRETTY_FUNCTION__ {(Cabshelper.explodeStringToInts
+ !currentFunctionName), $1}
+;
+
+init_expression:
+ expression { SINGLE_INIT (fst $1) }
+| LBRACE initializer_list_opt RBRACE
+ { COMPOUND_INIT $2}
+
+initializer_list: /* ISO 6.7.8. Allow a trailing COMMA */
+ initializer { [$1] }
+| initializer COMMA initializer_list_opt { $1 :: $3 }
+;
+initializer_list_opt:
+ /* empty */ { [] }
+| initializer_list { $1 }
+;
+initializer:
+ init_designators eq_opt init_expression { ($1, $3) }
+| gcc_init_designators init_expression { ($1, $2) }
+| init_expression { (NEXT_INIT, $1) }
+;
+eq_opt:
+ EQ { () }
+ /*(* GCC allows missing = *)*/
+| /*(* empty *)*/ { () }
+;
+init_designators:
+ DOT id_or_typename init_designators_opt { INFIELD_INIT($2, $3) }
+| LBRACKET expression RBRACKET init_designators_opt
+ { ATINDEX_INIT(fst $2, $4) }
+| LBRACKET expression ELLIPSIS expression RBRACKET
+ { ATINDEXRANGE_INIT(fst $2, fst $4) }
+;
+init_designators_opt:
+ /* empty */ { NEXT_INIT }
+| init_designators { $1 }
+;
+
+gcc_init_designators: /*(* GCC supports these strange things *)*/
+ id_or_typename COLON { INFIELD_INIT($1, NEXT_INIT) }
+;
+
+arguments:
+ /* empty */ { [] }
+| comma_expression { fst $1 }
+;
+
+opt_expression:
+ /* empty */
+ {NOTHING}
+| comma_expression
+ {smooth_expression (fst $1)}
+;
+
+comma_expression:
+ expression {[fst $1], snd $1}
+| expression COMMA comma_expression { fst $1 :: fst $3, snd $1 }
+| error COMMA comma_expression { $3 }
+;
+
+comma_expression_opt:
+ /* empty */ { NOTHING }
+| comma_expression { smooth_expression (fst $1) }
+;
+
+paren_comma_expression:
+ LPAREN comma_expression RPAREN { $2 }
+| LPAREN error RPAREN { [], $1 }
+;
+
+bracket_comma_expression:
+ LBRACKET comma_expression RBRACKET { fst $2 }
+| LBRACKET error RBRACKET { [] }
+;
+
+
+/*** statements ***/
+block: /* ISO 6.8.2 */
+ block_begin local_labels block_attrs block_element_list RBRACE
+ {!Lexerhack.pop_context();
+ { blabels = $2;
+ battrs = $3;
+ bstmts = $4 },
+ $1, $5
+ }
+| error location RBRACE { { blabels = [];
+ battrs = [];
+ bstmts = [] },
+ $2, $3
+ }
+;
+block_begin:
+ LBRACE {!Lexerhack.push_context (); $1}
+;
+
+block_attrs:
+ /* empty */ { [] }
+| BLOCKATTRIBUTE paren_attr_list_ne
+ { [("__blockattribute__", $2)] }
+;
+
+/* statements and declarations in a block, in any order (for C99 support) */
+block_element_list:
+ /* empty */ { [] }
+| 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),
+ snd $1)] }
+| pragma block_element_list { $2 }
+;
+
+local_labels:
+ /* empty */ { [] }
+| LABEL__ local_label_names SEMICOLON local_labels { $2 @ $4 }
+;
+local_label_names:
+ IDENT { [ fst $1 ] }
+| IDENT COMMA local_label_names { fst $1 :: $3 }
+;
+
+
+
+statement:
+ SEMICOLON {NOP ((*handleLoc*) $1) }
+| comma_expression SEMICOLON
+ {COMPUTATION (smooth_expression (fst $1), (*handleLoc*)(snd $1))}
+| block {BLOCK (fst3 $1, (*handleLoc*)(snd3 $1))}
+| IF paren_comma_expression statement %prec IF
+ {IF (smooth_expression (fst $2), $3, NOP $1, $1)}
+| IF paren_comma_expression statement ELSE statement
+ {IF (smooth_expression (fst $2), $3, $5, (*handleLoc*) $1)}
+| SWITCH paren_comma_expression statement
+ {SWITCH (smooth_expression (fst $2), $3, (*handleLoc*) $1)}
+| WHILE paren_comma_expression statement
+ {WHILE (smooth_expression (fst $2), $3, (*handleLoc*) $1)}
+| DO statement WHILE paren_comma_expression SEMICOLON
+ {DOWHILE (smooth_expression (fst $4), $2, (*handleLoc*) $1)}
+| FOR LPAREN for_clause opt_expression
+ SEMICOLON opt_expression RPAREN statement
+ {FOR ($3, $4, $6, $8, (*handleLoc*) $1)}
+| IDENT COLON attribute_nocv_list statement
+ {(* The only attribute that should appear here
+ is "unused". For now, we drop this on the
+ floor, since unused labels are usually
+ removed anyways by Rmtmps. *)
+ LABEL (fst $1, $4, (snd $1))}
+| CASE expression COLON statement
+ {CASE (fst $2, $4, (*handleLoc*) $1)}
+| CASE expression ELLIPSIS expression COLON statement
+ {CASERANGE (fst $2, fst $4, $6, (*handleLoc*) $1)}
+| DEFAULT COLON
+ {DEFAULT (NOP $1, (*handleLoc*) $1)}
+| RETURN SEMICOLON {RETURN (NOTHING, (*handleLoc*) $1)}
+| RETURN comma_expression SEMICOLON
+ {RETURN (smooth_expression (fst $2), (*handleLoc*) $1)}
+| BREAK SEMICOLON {BREAK ((*handleLoc*) $1)}
+| CONTINUE SEMICOLON {CONTINUE ((*handleLoc*) $1)}
+| GOTO IDENT SEMICOLON
+ {GOTO (fst $2, (*handleLoc*) $1)}
+| 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) }
+| MSASM { ASM ([], [fst $1], None, (*handleLoc*)(snd $1))}
+| TRY block EXCEPT paren_comma_expression block
+ { let b, _, _ = $2 in
+ let h, _, _ = $5 in
+ 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
+ { let b, _, _ = $2 in
+ let h, _, _ = $4 in
+ if not !Cprint.msvcMode then
+ parse_error "try/finally in GCC code";
+ TRY_FINALLY (b, h, (*handleLoc*) $1) }
+
+| error location SEMICOLON { (NOP $2)}
+;
+
+
+for_clause:
+ opt_expression SEMICOLON { FC_EXP $1 }
+| declaration { FC_DECL $1 }
+;
+
+declaration: /* ISO 6.7.*/
+ decl_spec_list init_declarator_list SEMICOLON
+ { doDeclaration ((*handleLoc*)(snd $1)) (fst $1) $2 }
+| decl_spec_list SEMICOLON
+ { doDeclaration ((*handleLoc*)(snd $1)) (fst $1) [] }
+;
+init_declarator_list: /* ISO 6.7 */
+ init_declarator { [$1] }
+| init_declarator COMMA init_declarator_list { $1 :: $3 }
+
+;
+init_declarator: /* ISO 6.7 */
+ declarator { ($1, NO_INIT) }
+| declarator EQ init_expression
+ { ($1, $3) }
+;
+
+decl_spec_list: /* ISO 6.7 */
+ /* ISO 6.7.1 */
+| TYPEDEF decl_spec_list_opt { SpecTypedef :: $2, $1 }
+| EXTERN decl_spec_list_opt { SpecStorage EXTERN :: $2, $1 }
+| STATIC decl_spec_list_opt { SpecStorage STATIC :: $2, $1 }
+| AUTO decl_spec_list_opt { SpecStorage AUTO :: $2, $1 }
+| REGISTER decl_spec_list_opt { SpecStorage REGISTER :: $2, $1}
+ /* ISO 6.7.2 */
+| type_spec decl_spec_list_opt_no_named { SpecType (fst $1) :: $2, snd $1 }
+ /* ISO 6.7.4 */
+| INLINE decl_spec_list_opt { SpecInline :: $2, $1 }
+| cvspec decl_spec_list_opt { (fst $1) :: $2, snd $1 }
+| attribute_nocv decl_spec_list_opt { SpecAttr (fst $1) :: $2, snd $1 }
+/* 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
+ * NAMED_TYPE to have right associativity *) */
+decl_spec_list_opt:
+ /* empty */ { [] } %prec NAMED_TYPE
+| decl_spec_list { fst $1 }
+;
+/* (* We add this separate rule to handle the special case when an appearance
+ * of NAMED_TYPE should not be considered as part of the specifiers but as
+ * part of the declarator. IDENT has higher precedence than NAMED_TYPE *)
+ */
+decl_spec_list_opt_no_named:
+ /* empty */ { [] } %prec IDENT
+| decl_spec_list { fst $1 }
+;
+type_spec: /* ISO 6.7.2 */
+ VOID { Tvoid, $1}
+| CHAR { Tchar, $1 }
+| SHORT { Tshort, $1 }
+| INT { Tint, $1 }
+| LONG { Tlong, $1 }
+| INT64 { Tint64, $1 }
+| FLOAT { Tfloat, $1 }
+| DOUBLE { Tdouble, $1 }
+| SIGNED { Tsigned, $1 }
+| UNSIGNED { Tunsigned, $1 }
+| STRUCT id_or_typename
+ { Tstruct ($2, None, []), $1 }
+| STRUCT just_attributes id_or_typename
+ { Tstruct ($3, None, $2), $1 }
+| STRUCT id_or_typename LBRACE struct_decl_list RBRACE
+ { Tstruct ($2, Some $4, []), $1 }
+| STRUCT LBRACE struct_decl_list RBRACE
+ { Tstruct ("", Some $3, []), $1 }
+| STRUCT just_attributes id_or_typename LBRACE struct_decl_list RBRACE
+ { Tstruct ($3, Some $5, $2), $1 }
+| STRUCT just_attributes LBRACE struct_decl_list RBRACE
+ { Tstruct ("", Some $4, $2), $1 }
+| UNION id_or_typename
+ { Tunion ($2, None, []), $1 }
+| UNION id_or_typename LBRACE struct_decl_list RBRACE
+ { Tunion ($2, Some $4, []), $1 }
+| UNION LBRACE struct_decl_list RBRACE
+ { Tunion ("", Some $3, []), $1 }
+| UNION just_attributes id_or_typename LBRACE struct_decl_list RBRACE
+ { Tunion ($3, Some $5, $2), $1 }
+| UNION just_attributes LBRACE struct_decl_list RBRACE
+ { Tunion ("", Some $4, $2), $1 }
+| ENUM id_or_typename
+ { Tenum ($2, None, []), $1 }
+| ENUM id_or_typename LBRACE enum_list maybecomma RBRACE
+ { Tenum ($2, Some $4, []), $1 }
+| ENUM LBRACE enum_list maybecomma RBRACE
+ { Tenum ("", Some $3, []), $1 }
+| ENUM just_attributes id_or_typename LBRACE enum_list maybecomma RBRACE
+ { Tenum ($3, Some $5, $2), $1 }
+| ENUM just_attributes LBRACE enum_list maybecomma RBRACE
+ { Tenum ("", Some $4, $2), $1 }
+| NAMED_TYPE { Tnamed (fst $1), snd $1 }
+| TYPEOF LPAREN expression RPAREN { TtypeofE (fst $3), $1 }
+| TYPEOF LPAREN type_name RPAREN { let s, d = $3 in
+ TtypeofT (s, d), $1 }
+;
+struct_decl_list: /* (* ISO 6.7.2. Except that we allow empty structs. We
+ * also allow missing field names. *)
+ */
+ /* empty */ { [] }
+| decl_spec_list SEMICOLON struct_decl_list
+ { (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)
+ :: $4 }
+/*(* MSVC allows pragmas in strange places *)*/
+| pragma struct_decl_list { $2 }
+
+| error SEMICOLON struct_decl_list
+ { $3 }
+;
+field_decl_list: /* (* ISO 6.7.2 *) */
+ field_decl { [$1] }
+| field_decl COMMA field_decl_list { $1 :: $3 }
+;
+field_decl: /* (* ISO 6.7.2. Except that we allow unnamed fields. *) */
+| declarator { ($1, None) }
+| declarator COLON expression attributes
+ { let (n,decl,al,loc) = $1 in
+ let al' = al @ $4 in
+ ((n,decl,al',loc), Some (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 }
+;
+enumerator:
+ IDENT {(fst $1, NOTHING, snd $1)}
+| IDENT EQ expression {(fst $1, fst $3, snd $1)}
+;
+
+
+declarator: /* (* ISO 6.7.5. Plus Microsoft declarators.*) */
+ pointer_opt direct_decl attributes_with_asm
+ { let (n, decl) = $2 in
+ (n, applyPointer (fst $1) decl, $3, (snd $1)) }
+;
+
+
+direct_decl: /* (* ISO 6.7.5 *) */
+ /* (* We want to be able to redefine named
+ * types as variable names *) */
+| id_or_typename { ($1, JUSTBASE) }
+
+| LPAREN attributes declarator RPAREN
+ { let (n,decl,al,loc) = $3 in
+ (n, PARENTYPE($2,decl,al)) }
+
+| direct_decl LBRACKET attributes comma_expression_opt RBRACKET
+ { let (n, decl) = $1 in
+ (n, ARRAY(decl, $3, $4)) }
+| direct_decl LBRACKET attributes error RBRACKET
+ { let (n, decl) = $1 in
+ (n, ARRAY(decl, $3, NOTHING)) }
+| direct_decl parameter_list_startscope rest_par_list RPAREN
+ { let (n, decl) = $1 in
+ let (params, isva) = $3 in
+ !Lexerhack.pop_context ();
+ (n, PROTO(decl, params, isva))
+ }
+;
+parameter_list_startscope:
+ LPAREN { !Lexerhack.push_context () }
+;
+rest_par_list:
+| /* empty */ { ([], false) }
+| parameter_decl rest_par_list1 { let (params, isva) = $2 in
+ ($1 :: params, isva)
+ }
+;
+rest_par_list1:
+ /* empty */ { ([], false) }
+| COMMA ELLIPSIS { ([], true) }
+| COMMA parameter_decl rest_par_list1 { let (params, isva) = $3 in
+ ($2 :: params, isva)
+ }
+;
+
+
+parameter_decl: /* (* ISO 6.7.5 *) */
+ decl_spec_list declarator { (fst $1, $2) }
+| decl_spec_list abstract_decl { let d, a = $2 in
+ (fst $1, ("", d, a, cabslu)) }
+| decl_spec_list { (fst $1, ("", JUSTBASE, [], cabslu)) }
+| LPAREN parameter_decl RPAREN { $2 }
+;
+
+/* (* Old style prototypes. Like a declarator *) */
+old_proto_decl:
+ pointer_opt direct_old_proto_decl { let (n, decl, a) = $2 in
+ (n, applyPointer (fst $1) decl,
+ a, snd $1)
+ }
+
+;
+
+direct_old_proto_decl:
+ direct_decl LPAREN old_parameter_list_ne RPAREN old_pardef_list
+ { let par_decl, isva = doOldParDecl $3 $5 in
+ let n, decl = $1 in
+ (n, PROTO(decl, par_decl, isva), [])
+ }
+| direct_decl LPAREN RPAREN
+ { let n, decl = $1 in
+ (n, PROTO(decl, [], false), [])
+ }
+
+/* (* appears sometimesm but generates a shift-reduce conflict. *)
+| LPAREN STAR direct_decl LPAREN old_parameter_list_ne RPAREN RPAREN LPAREN RPAREN old_pardef_list
+ { let par_decl, isva
+ = doOldParDecl $5 $10 in
+ let n, decl = $3 in
+ (n, PROTO(decl, par_decl, isva), [])
+ }
+*/
+;
+
+old_parameter_list_ne:
+| IDENT { [fst $1] }
+| IDENT COMMA old_parameter_list_ne { let rest = $3 in
+ (fst $1 :: rest) }
+;
+
+old_pardef_list:
+ /* empty */ { ([], false) }
+| decl_spec_list old_pardef SEMICOLON ELLIPSIS
+ { ([(fst $1, $2)], true) }
+| decl_spec_list old_pardef SEMICOLON old_pardef_list
+ { let rest, isva = $4 in
+ ((fst $1, $2) :: rest, isva)
+ }
+;
+
+old_pardef:
+ declarator { [$1] }
+| declarator COMMA old_pardef { $1 :: $3 }
+| error { [] }
+;
+
+
+pointer: /* (* ISO 6.7.5 *) */
+ STAR attributes pointer_opt { $2 :: fst $3, $1 }
+;
+pointer_opt:
+ /**/ { let l = currentLoc () in
+ ([], l) }
+| pointer { $1 }
+;
+
+type_name: /* (* ISO 6.7.6 *) */
+ decl_spec_list abstract_decl { let d, a = $2 in
+ if a <> [] then begin
+ parse_error "attributes in type name";
+ raise Parsing.Parse_error
+ end;
+ (fst $1, d)
+ }
+| decl_spec_list { (fst $1, JUSTBASE) }
+;
+abstract_decl: /* (* ISO 6.7.6. *) */
+ pointer_opt abs_direct_decl attributes { applyPointer (fst $1) $2, $3 }
+| pointer { applyPointer (fst $1) JUSTBASE, [] }
+;
+
+abs_direct_decl: /* (* ISO 6.7.6. We do not support optional declarator for
+ * functions. Plus Microsoft attributes. See the
+ * discussion for declarator. *) */
+| LPAREN attributes abstract_decl RPAREN
+ { let d, a = $3 in
+ PARENTYPE ($2, d, a)
+ }
+
+| LPAREN error RPAREN
+ { JUSTBASE }
+
+| abs_direct_decl_opt LBRACKET comma_expression_opt RBRACKET
+ { ARRAY($1, [], $3) }
+/*(* The next should be abs_direct_decl_opt but we get conflicts *)*/
+| abs_direct_decl parameter_list_startscope rest_par_list RPAREN
+ { let (params, isva) = $3 in
+ !Lexerhack.pop_context ();
+ PROTO ($1, params, isva)
+ }
+;
+abs_direct_decl_opt:
+ abs_direct_decl { $1 }
+| /* empty */ { JUSTBASE }
+;
+function_def: /* (* ISO 6.9.1 *) */
+ function_def_start block
+ { let (loc, specs, decl) = $1 in
+ currentFunctionName := "<__FUNCTION__ used outside any functions>";
+ !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
+ { announceFunctionName $2;
+ (snd $1, fst $1, $2)
+ }
+
+/* (* Old-style function prototype *) */
+| decl_spec_list old_proto_decl
+ { announceFunctionName $2;
+ (snd $1, fst $1, $2)
+ }
+/* (* New-style function that does not have a return type *) */
+| IDENT parameter_list_startscope rest_par_list RPAREN
+ { let (params, isva) = $3 in
+ let fdec =
+ (fst $1, PROTO(JUSTBASE, params, isva), [], snd $1) in
+ announceFunctionName fdec;
+ (* Default is int type *)
+ let defSpec = [SpecType Tint] in
+ (snd $1, defSpec, fdec)
+ }
+
+/* (* No return type and old-style parameter list *) */
+| IDENT LPAREN old_parameter_list_ne RPAREN old_pardef_list
+ { (* Convert pardecl to new style *)
+ let pardecl, isva = doOldParDecl $3 $5 in
+ (* Make the function declarator *)
+ let fdec = (fst $1,
+ PROTO(JUSTBASE, pardecl,isva),
+ [], snd $1) in
+ announceFunctionName fdec;
+ (* Default is int type *)
+ let defSpec = [SpecType Tint] in
+ (snd $1, defSpec, fdec)
+ }
+/* (* No return type and no parameters *) */
+| IDENT LPAREN RPAREN
+ { (* Make the function declarator *)
+ let fdec = (fst $1,
+ PROTO(JUSTBASE, [], false),
+ [], snd $1) in
+ announceFunctionName fdec;
+ (* Default is int type *)
+ let defSpec = [SpecType Tint] in
+ (snd $1, defSpec, fdec)
+ }
+;
+
+/* const/volatile as type specifier elements */
+cvspec:
+ CONST { SpecCV(CV_CONST), $1 }
+| VOLATILE { SpecCV(CV_VOLATILE), $1 }
+| RESTRICT { SpecCV(CV_RESTRICT), $1 }
+;
+
+/*** GCC attributes ***/
+attributes:
+ /* empty */ { []}
+| attribute attributes { fst $1 :: $2 }
+;
+
+/* (* In some contexts we can have an inline assembly to specify the name to
+ * be used for a global. We treat this as a name attribute *) */
+attributes_with_asm:
+ /* empty */ { [] }
+| attribute attributes_with_asm { fst $1 :: $2 }
+| ASM LPAREN string_constant RPAREN attributes
+ { ("__asm__",
+ [CONSTANT(CONST_STRING (fst $3))]) :: $5 }
+;
+
+/* things like __attribute__, but no const/volatile */
+attribute_nocv:
+ ATTRIBUTE LPAREN paren_attr_list RPAREN
+ { ("__attribute__", $3), $1 }
+/*(*
+| ATTRIBUTE_USED { ("__attribute__",
+ [ VARIABLE "used" ]), $1 }
+*)*/
+| DECLSPEC paren_attr_list_ne { ("__declspec", $2), $1 }
+| MSATTR { (fst $1, []), snd $1 }
+ /* ISO 6.7.3 */
+| THREAD { ("__thread",[]), $1 }
+| QUALIFIER {("__attribute__",[VARIABLE(fst $1)]),snd $1}
+;
+
+attribute_nocv_list:
+ /* empty */ { []}
+| attribute_nocv attribute_nocv_list { fst $1 :: $2 }
+;
+
+/* __attribute__ plus const/volatile */
+attribute:
+ attribute_nocv { $1 }
+| CONST { ("const", []), $1 }
+| RESTRICT { ("restrict",[]), $1 }
+| VOLATILE { ("volatile",[]), $1 }
+;
+
+/* (* sm: I need something that just includes __attribute__ and nothing more,
+ * to support them appearing between the 'struct' keyword and the type name.
+ * Actually, a declspec can appear there as well (on MSVC) *) */
+just_attribute:
+ ATTRIBUTE LPAREN paren_attr_list RPAREN
+ { ("__attribute__", $3) }
+| DECLSPEC paren_attr_list_ne { ("__declspec", $2) }
+;
+
+/* this can't be empty, b/c I folded that possibility into the calling
+ * productions to avoid some S/R conflicts */
+just_attributes:
+ just_attribute { [$1] }
+| just_attribute just_attributes { $1 :: $2 }
+;
+
+/** (* PRAGMAS and ATTRIBUTES *) ***/
+pragma:
+| PRAGMA attr PRAGMA_EOL { PRAGMA ($2, $1) }
+| PRAGMA attr SEMICOLON PRAGMA_EOL { PRAGMA ($2, $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:
+ IDENT { VARIABLE (fst $1) }
+ /*(* The NAMED_TYPE here creates conflicts with IDENT *)*/
+| 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
+ * 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
+ * low priority *)*/
+| 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,
+ * synonim for noreturn **)*/
+| VOLATILE { VARIABLE ("__noreturn__") }
+;
+
+postfix_attr:
+ primary_attr { $1 }
+ /* (* 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 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
+ * that their arguments be expressions, not attributes *)*/
+unary_attr:
+ postfix_attr { $1 }
+| SIZEOF unary_expression {EXPR_SIZEOF (fst $2) }
+| SIZEOF LPAREN type_name RPAREN
+ {let b, d = $3 in TYPE_SIZEOF (b, d)}
+
+| ALIGNOF unary_expression {EXPR_ALIGNOF (fst $2) }
+| ALIGNOF LPAREN type_name RPAREN {let b, d = $3 in TYPE_ALIGNOF (b, d)}
+| PLUS cast_attr {UNARY (PLUS, $2)}
+| MINUS cast_attr {UNARY (MINUS, $2)}
+| STAR cast_attr {UNARY (MEMOF, $2)}
+| AND cast_attr
+ {UNARY (ADDROF, $2)}
+| EXCLAM cast_attr {UNARY (NOT, $2)}
+| TILDE cast_attr {UNARY (BNOT, $2)}
+;
+
+cast_attr:
+ unary_attr { $1 }
+;
+
+multiplicative_attr:
+ cast_attr { $1 }
+| multiplicative_attr STAR cast_attr {BINARY(MUL ,$1 , $3)}
+| multiplicative_attr SLASH cast_attr {BINARY(DIV ,$1 , $3)}
+| multiplicative_attr PERCENT cast_attr {BINARY(MOD ,$1 , $3)}
+;
+
+
+additive_attr:
+ multiplicative_attr { $1 }
+| additive_attr PLUS multiplicative_attr {BINARY(ADD ,$1 , $3)}
+| additive_attr MINUS multiplicative_attr {BINARY(SUB ,$1 , $3)}
+;
+
+shift_attr:
+ additive_attr { $1 }
+| shift_attr INF_INF additive_attr {BINARY(SHL ,$1 , $3)}
+| shift_attr SUP_SUP additive_attr {BINARY(SHR ,$1 , $3)}
+;
+
+relational_attr:
+ shift_attr { $1 }
+| relational_attr INF shift_attr {BINARY(LT ,$1 , $3)}
+| relational_attr SUP shift_attr {BINARY(GT ,$1 , $3)}
+| relational_attr INF_EQ shift_attr {BINARY(LE ,$1 , $3)}
+| relational_attr SUP_EQ shift_attr {BINARY(GE ,$1 , $3)}
+;
+
+equality_attr:
+ relational_attr { $1 }
+| equality_attr EQ_EQ relational_attr {BINARY(EQ ,$1 , $3)}
+| equality_attr EXCLAM_EQ relational_attr {BINARY(NE ,$1 , $3)}
+;
+
+
+bitwise_and_attr:
+ equality_attr { $1 }
+| bitwise_and_attr AND equality_attr {BINARY(BAND ,$1 , $3)}
+;
+
+bitwise_xor_attr:
+ bitwise_and_attr { $1 }
+| bitwise_xor_attr CIRC bitwise_and_attr {BINARY(XOR ,$1 , $3)}
+;
+
+bitwise_or_attr:
+ bitwise_xor_attr { $1 }
+| bitwise_or_attr PIPE bitwise_xor_attr {BINARY(BOR ,$1 , $3)}
+;
+
+logical_and_attr:
+ bitwise_or_attr { $1 }
+| logical_and_attr AND_AND bitwise_or_attr {BINARY(AND ,$1 , $3)}
+;
+
+logical_or_attr:
+ logical_and_attr { $1 }
+| logical_or_attr PIPE_PIPE logical_and_attr {BINARY(OR ,$1 , $3)}
+;
+
+conditional_attr:
+ logical_or_attr { $1 }
+/* This is in conflict for now */
+| logical_or_attr QUEST conditional_attr COLON conditional_attr
+ { QUESTION($1, $3, $5) }
+
+
+attr: conditional_attr { $1 }
+;
+
+attr_list_ne:
+| attr { [$1] }
+| attr COMMA attr_list_ne { $1 :: $3 }
+| error COMMA attr_list_ne { $3 }
+;
+attr_list:
+ /* empty */ { [] }
+| attr_list_ne { $1 }
+;
+paren_attr_list_ne:
+ LPAREN attr_list_ne RPAREN { $2 }
+| LPAREN error RPAREN { [] }
+;
+paren_attr_list:
+ LPAREN attr_list RPAREN { $2 }
+| LPAREN error RPAREN { [] }
+;
+/*** GCC ASM instructions ***/
+asmattr:
+ /* empty */ { [] }
+| VOLATILE asmattr { ("volatile", []) :: $2 }
+| CONST asmattr { ("const", []) :: $2 }
+;
+asmtemplate:
+ one_string_constant { [$1] }
+| one_string_constant asmtemplate { $1 :: $2 }
+;
+asmoutputs:
+ /* empty */ { None }
+| COLON asmoperands asminputs
+ { let (ins, clobs) = $3 in
+ Some {aoutputs = $2; ainputs = ins; aclobbers = clobs} }
+;
+asmoperands:
+ /* empty */ { [] }
+| asmoperandsne { List.rev $1 }
+;
+asmoperandsne:
+ asmoperand { [$1] }
+| asmoperandsne COMMA asmoperand { $3 :: $1 }
+;
+asmoperand:
+ asmopname string_constant LPAREN expression RPAREN { ($1, fst $2, fst $4) }
+| asmopname string_constant LPAREN error RPAREN { ($1, fst $2, NOTHING ) }
+;
+asminputs:
+ /* empty */ { ([], []) }
+| COLON asmoperands asmclobber
+ { ($2, $3) }
+;
+asmopname:
+ /* empty */ { None }
+| LBRACKET IDENT RBRACKET { Some (fst $2) }
+;
+
+asmclobber:
+ /* empty */ { [] }
+| COLON asmcloberlst_ne { $2 }
+;
+asmcloberlst_ne:
+ one_string_constant { [$1] }
+| one_string_constant COMMA asmcloberlst_ne { $1 :: $3 }
+;
+
+%%
+
+
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2003,
+ * 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.
+ *
+ * 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.
+ *
+ *)
+(* cprint -- pretty printer of C program from abstract syntax
+**
+** Project: FrontC
+** File: cprint.ml
+** Version: 2.1e
+** Date: 9.1.99
+** Author: Hugues Cassé
+**
+** 1.0 2.22.99 Hugues Cassé First version.
+** 2.0 3.18.99 Hugues Cassé Compatible with Frontc 2.1, use of CAML
+** pretty printer.
+** 2.1 3.22.99 Hugues Cassé More efficient custom pretty printer used.
+** 2.1a 4.12.99 Hugues Cassé Correctly handle:
+** char *m, *m, *p; m + (n - p)
+** 2.1b 4.15.99 Hugues Cassé x + (y + z) stays x + (y + z) for
+** keeping computation order.
+** 2.1c 7.23.99 Hugues Cassé Improvement of case and default display.
+** 2.1d 8.25.99 Hugues Cassé Rebuild escape sequences in string and
+** characters.
+** 2.1e 9.1.99 Hugues Cassé Fix, recognize and correctly display '\0'.
+*)
+
+(* George Necula: I changed this pretty dramatically since CABS changed *)
+open Cabs
+open Escape
+open Whitetrack
+
+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";
+ byteno = -10;
+ ident = 0;}
+
+let curLoc = ref cabslu
+
+let msvcMode = ref false
+
+let printLn = ref true
+let printLnComment = ref false
+
+let printCounters = ref false
+let printComments = ref false
+
+(*
+** FrontC Pretty printer
+*)
+let out = ref stdout
+let width = ref 80
+let tab = ref 2
+let max_indent = ref 60
+
+let line = ref ""
+let line_len = ref 0
+let current = ref ""
+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 *)
+(* we may implement some of these later *)
+let new_line () = ()
+let space () = ()
+let indent () = ()
+let unindent () = ()
+let force_new_line () = ()
+let flush () = ()
+let commit () = ()
+
+(* sm: for some reason I couldn't just call print from frontc.... ? *)
+let print_unescaped_string str = print str
+
+
+(*
+** Useful primitives
+*)
+let print_list print_sep print_elt lst =
+ let _ = List.fold_left
+ (fun com elt ->
+ if com then print_sep ();
+ print_elt elt;
+ true)
+ false
+ lst in
+ ()
+
+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 ^ "\"")
+
+let print_wstring (s: int64 list ) =
+ print ("L\"" ^ escape_wstring s ^ "\"")
+
+(*
+** Base Type Printing
+*)
+
+let rec print_specifiers (specs: spec_elem list) =
+ comprint "specifier(";
+ let print_spec_elem = function
+ SpecTypedef -> print "typedef"
+ | SpecInline -> printu "inline"
+ | SpecStorage sto ->
+ printu (match sto with
+ NO_STORAGE -> (comstring "/*no storage*/")
+ | AUTO -> "auto"
+ | STATIC -> "static"
+ | EXTERN -> "extern"
+ | REGISTER -> "register")
+ | SpecCV cv ->
+ printu (match cv with
+ | CV_CONST -> "const"
+ | CV_VOLATILE -> "volatile"
+ | CV_RESTRICT -> "restrict")
+ | SpecAttr al -> print_attribute al; space ()
+ | SpecType bt -> print_type_spec bt
+ | SpecPattern name -> printl ["@specifier";"(";name;")"]
+ in
+ List.iter print_spec_elem specs
+ ;comprint ")"
+
+
+and print_type_spec = function
+ Tvoid -> print "void "
+ | Tchar -> print "char "
+ | Tshort -> print "short "
+ | Tint -> print "int "
+ | Tlong -> print "long "
+ | Tint64 -> print "__int64 "
+ | Tfloat -> print "float "
+ | Tdouble -> print "double "
+ | Tsigned -> printu "signed"
+ | Tunsigned -> print "unsigned "
+ | Tnamed s -> comprint "tnamed"; print s; space ();
+ | Tstruct (n, None, _) -> printl ["struct";n]
+ | Tstruct (n, Some flds, extraAttrs) ->
+ (print_struct_name_attr "struct" n extraAttrs);
+ (print_fields flds)
+ | Tunion (n, None, _) -> printl ["union";n;" "]
+ | Tunion (n, Some flds, extraAttrs) ->
+ (print_struct_name_attr "union" n extraAttrs);
+ (print_fields flds)
+ | Tenum (n, None, _) -> printl ["enum";n]
+ | Tenum (n, Some enum_items, extraAttrs) ->
+ (print_struct_name_attr "enum" n extraAttrs);
+ (print_enum_items enum_items)
+ | TtypeofE e -> printl ["__typeof__";"("]; print_expression e; print ") "
+ | TtypeofT (s,d) -> printl ["__typeof__";"("]; print_onlytype (s, d); print ") "
+
+
+(* print "struct foo", but with specified keyword and a list of
+ * attributes to put between keyword and name *)
+and print_struct_name_attr (keyword: string) (name: string) (extraAttrs: attribute list) =
+begin
+ if extraAttrs = [] then
+ printl [keyword;name]
+ else begin
+ print keyword;
+ print_attributes extraAttrs; (* prints a final space *)
+ print name;
+ end
+end
+
+
+(* This is the main printer for declarations. It is easy bacause the
+ * declarations are laid out as they need to be printed. *)
+and print_decl (n: string) = function
+ JUSTBASE -> if n <> "___missing_field_name" then
+ print n
+ else
+ comprint "missing field name"
+ | PARENTYPE (al1, d, al2) ->
+ print "(";
+ print_attributes al1; space ();
+ print_decl n d; space ();
+ print_attributes al2; print ")"
+ | PTR (al, d) ->
+ print "* ";
+ print_attributes al; space ();
+ print_decl n d
+ | ARRAY (d, al, e) ->
+ print_decl n d;
+ print "[";
+ print_attributes al;
+ if e <> NOTHING then print_expression e;
+ print "]"
+ | PROTO(d, args, isva) ->
+ comprint "proto(";
+ print_decl n d;
+ print "(";
+ print_params args isva;
+ print ")";
+ comprint ")"
+
+
+and print_fields (flds : field_group list) =
+ if flds = [] then print " { } "
+ else begin
+ print " {";
+ indent ();
+ List.iter
+ (fun fld -> print_field_group fld; print ";"; new_line ())
+ flds;
+ unindent ();
+ print "} "
+ end
+
+and print_enum_items items =
+ if items = [] then print " { } "
+ else begin
+ print " {";
+ indent ();
+ print_commas
+ true
+ (fun (id, exp, loc) -> print id;
+ if exp = NOTHING then ()
+ else begin
+ space ();
+ print "= ";
+ print_expression exp
+ end)
+ items;
+ unindent ();
+ 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 ();
+ print_attributes attrs
+
+and print_init_name ((n, i) : init_name) =
+ print_name n;
+ if i <> NO_INIT then begin
+ space ();
+ 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) =
+ print_name name;
+ (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
+
+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
+** Priorities
+** 16 variables
+** 15 . -> [] call()
+** 14 ++, -- (post)
+** 13 ++ -- (pre) ~ ! - + & *(cast)
+** 12 * / %
+** 11 + -
+** 10 << >>
+** 9 < <= > >=
+** 8 == !=
+** 7 &
+** 6 ^
+** 5 |
+** 4 &&
+** 3 ||
+** 2 ? :
+** 1 = ?=
+** 0 ,
+*)
+and get_operator exp =
+ match exp with
+ NOTHING -> ("", 16)
+ | PAREN exp -> ("", 16)
+ | UNARY (op, _) ->
+ (match op with
+ MINUS -> ("-", 13)
+ | PLUS -> ("+", 13)
+ | NOT -> ("!", 13)
+ | BNOT -> ("~", 13)
+ | MEMOF -> ("*", 13)
+ | ADDROF -> ("&", 13)
+ | PREINCR -> ("++", 13)
+ | PREDECR -> ("--", 13)
+ | POSINCR -> ("++", 14)
+ | POSDECR -> ("--", 14))
+ | LABELADDR s -> ("", 16) (* Like a constant *)
+ | BINARY (op, _, _) ->
+ (match op with
+ MUL -> ("*", 12)
+ | DIV -> ("/", 12)
+ | MOD -> ("%", 12)
+ | ADD -> ("+", 11)
+ | SUB -> ("-", 11)
+ | SHL -> ("<<", 10)
+ | SHR -> (">>", 10)
+ | LT -> ("<", 9)
+ | LE -> ("<=", 9)
+ | GT -> (">", 9)
+ | GE -> (">=", 9)
+ | EQ -> ("==", 8)
+ | NE -> ("!=", 8)
+ | BAND -> ("&", 7)
+ | XOR -> ("^", 6)
+ | BOR -> ("|", 5)
+ | AND -> ("&&", 4)
+ | OR -> ("||", 3)
+ | ASSIGN -> ("=", 1)
+ | ADD_ASSIGN -> ("+=", 1)
+ | SUB_ASSIGN -> ("-=", 1)
+ | MUL_ASSIGN -> ("*=", 1)
+ | DIV_ASSIGN -> ("/=", 1)
+ | MOD_ASSIGN -> ("%=", 1)
+ | BAND_ASSIGN -> ("&=", 1)
+ | BOR_ASSIGN -> ("|=", 1)
+ | XOR_ASSIGN -> ("^=", 1)
+ | SHL_ASSIGN -> ("<<=", 1)
+ | SHR_ASSIGN -> (">>=", 1))
+ | QUESTION _ -> ("", 2)
+ | CAST _ -> ("", 13)
+ | CALL _ -> ("", 15)
+ | COMMA _ -> ("", 0)
+ | CONSTANT _ -> ("", 16)
+ | VARIABLE name -> ("", 16)
+ | EXPR_SIZEOF exp -> ("", 16)
+ | TYPE_SIZEOF _ -> ("", 16)
+ | EXPR_ALIGNOF exp -> ("", 16)
+ | TYPE_ALIGNOF _ -> ("", 16)
+ | INDEX (exp, idx) -> ("", 15)
+ | MEMBEROF (exp, fld) -> ("", 15)
+ | MEMBEROFPTR (exp, fld) -> ("", 15)
+ | GNU_BODY _ -> ("", 17)
+ | EXPR_PATTERN _ -> ("", 16) (* sm: not sure about this *)
+
+and print_comma_exps exps =
+ print_commas false print_expression exps
+
+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 ->
+ let rec doinit = function
+ NEXT_INIT -> ()
+ | INFIELD_INIT (fn, i) -> printl [".";fn]; doinit i
+ | ATINDEX_INIT (e, i) ->
+ print "[";
+ print_expression e;
+ print "]";
+ doinit i
+ | ATINDEXRANGE_INIT (s, e) ->
+ print "[";
+ print_expression s;
+ print " ... ";
+ print_expression e;
+ print "]"
+ in
+ doinit i; print " = ";
+ print_init_expression e
+ in
+ print "{";
+ print_commas false doinitexp initexps;
+ print "}"
+
+and print_expression (exp: expression) = print_expression_level 1 exp
+
+and print_expression_level (lvl: int) (exp : expression) =
+ let (txt, lvl') = get_operator exp in
+ let _ = match exp with
+ NOTHING -> ()
+ | PAREN exp -> print "("; print_expression exp; print ")"
+ | UNARY (op, exp') ->
+ (match op with
+ POSINCR | POSDECR ->
+ print_expression_level lvl' exp';
+ print txt
+ | _ ->
+ print txt; space (); (* Print the space to avoid --5 *)
+ print_expression_level lvl' exp')
+ | LABELADDR l -> printl ["&&";l]
+ | BINARY (op, exp1, exp2) ->
+ (*if (op = SUB) && (lvl <= lvl') then print "(";*)
+ print_expression_level lvl' exp1;
+ space ();
+ print txt;
+ space ();
+ (*print_expression exp2 (if op = SUB then (lvl' + 1) else lvl');*)
+ print_expression_level (lvl' + 1) exp2
+ (*if (op = SUB) && (lvl <= lvl') then print ")"*)
+ | QUESTION (exp1, exp2, exp3) ->
+ print_expression_level 2 exp1;
+ space ();
+ print "? ";
+ print_expression_level 2 exp2;
+ space ();
+ print ": ";
+ print_expression_level 2 exp3;
+ | CAST (typ, iexp) ->
+ print "(";
+ print_onlytype typ;
+ 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
+ (* ; print ")" *)
+ | NO_INIT -> print "<NO_INIT in cast. Should never arise>")
+
+ | CALL (VARIABLE "__builtin_va_arg", [arg; TYPE_SIZEOF (bt, dt)]) ->
+ comprint "variable";
+ print "__builtin_va_arg";
+ print "(";
+ print_expression_level 1 arg;
+ print ",";
+ print_onlytype (bt, dt);
+ print ")"
+ | CALL (exp, args) ->
+ print_expression_level 16 exp;
+ print "(";
+ print_comma_exps args;
+ print ")"
+ | COMMA exps ->
+ print_comma_exps exps
+ | CONSTANT cst ->
+ (match cst with
+ CONST_INT i -> print i
+ | CONST_FLOAT r -> print r
+ | CONST_CHAR c -> print ("'" ^ escape_wstring c ^ "'")
+ | CONST_WCHAR c -> print ("L'" ^ escape_wstring c ^ "'")
+ | CONST_STRING s -> print_string s
+ | CONST_WSTRING ws -> print_wstring ws)
+ | VARIABLE name ->
+ comprint "variable";
+ print name
+ | EXPR_SIZEOF exp ->
+ print "sizeof";
+ print_expression_level 0 exp
+ | TYPE_SIZEOF (bt,dt) ->
+ printl ["sizeof";"("];
+ print_onlytype (bt, dt);
+ print ")"
+ | EXPR_ALIGNOF exp ->
+ printl ["__alignof__";"("];
+ print_expression_level 0 exp;
+ print ")"
+ | TYPE_ALIGNOF (bt,dt) ->
+ printl ["__alignof__";"("];
+ print_onlytype (bt, dt);
+ print ")"
+ | INDEX (exp, idx) ->
+ print_expression_level 16 exp;
+ print "[";
+ print_expression_level 0 idx;
+ print "]"
+ | MEMBEROF (exp, fld) ->
+ print_expression_level 16 exp;
+ printl [".";fld]
+ | MEMBEROFPTR (exp, fld) ->
+ print_expression_level 16 exp;
+ printl ["->";fld]
+ | GNU_BODY (blk) ->
+ print "(";
+ print_block blk;
+ print ")"
+ | EXPR_PATTERN (name) ->
+ printl ["@expr";"(";name;")"]
+ in
+ ()
+
+
+(*
+** Statement printing
+*)
+and print_statement stat =
+ match stat with
+ NOP (loc) ->
+ setLoc(loc);
+ print ";";
+ new_line ()
+ | COMPUTATION (exp, loc) ->
+ setLoc(loc);
+ print_expression exp;
+ print ";";
+ new_line ()
+ | BLOCK (blk, loc) -> print_block blk
+
+ | SEQUENCE (s1, s2, loc) ->
+ setLoc(loc);
+ print_statement s1;
+ print_statement s2;
+ | IF (exp, s1, s2, loc) ->
+ setLoc(loc);
+ printl ["if";"("];
+ print_expression_level 0 exp;
+ print ")";
+ print_substatement s1;
+ (match s2 with
+ | NOP(_) -> ()
+ | _ -> begin
+ print "else";
+ print_substatement s2;
+ end)
+ | WHILE (exp, stat, loc) ->
+ setLoc(loc);
+ printl ["while";"("];
+ print_expression_level 0 exp;
+ print ")";
+ print_substatement stat
+ | DOWHILE (exp, stat, loc) ->
+ setLoc(loc);
+ print "do";
+ print_substatement stat;
+ printl ["while";"("];
+ print_expression_level 0 exp;
+ print ");";
+ new_line ();
+ | FOR (fc1, exp2, exp3, stat, loc) ->
+ setLoc(loc);
+ printl ["for";"("];
+ (match fc1 with
+ FC_EXP exp1 -> print_expression_level 0 exp1; print ";"
+ | FC_DECL dec1 -> print_def dec1);
+ space ();
+ print_expression_level 0 exp2;
+ print ";";
+ space ();
+ print_expression_level 0 exp3;
+ print ")";
+ print_substatement stat
+ | BREAK (loc)->
+ setLoc(loc);
+ print "break;"; new_line ()
+ | CONTINUE (loc) ->
+ setLoc(loc);
+ print "continue;"; new_line ()
+ | RETURN (exp, loc) ->
+ setLoc(loc);
+ print "return";
+ if exp = NOTHING
+ then ()
+ else begin
+ print " ";
+ print_expression_level 1 exp
+ end;
+ print ";";
+ new_line ()
+ | SWITCH (exp, stat, loc) ->
+ setLoc(loc);
+ printl ["switch";"("];
+ print_expression_level 0 exp;
+ print ")";
+ print_substatement stat
+ | CASE (exp, stat, loc) ->
+ setLoc(loc);
+ unindent ();
+ print "case ";
+ print_expression_level 1 exp;
+ print ":";
+ indent ();
+ print_substatement stat
+ | CASERANGE (expl, exph, stat, loc) ->
+ setLoc(loc);
+ unindent ();
+ print "case ";
+ print_expression expl;
+ print " ... ";
+ print_expression exph;
+ print ":";
+ indent ();
+ print_substatement stat
+ | DEFAULT (stat, loc) ->
+ setLoc(loc);
+ unindent ();
+ print "default :";
+ indent ();
+ print_substatement stat
+ | LABEL (name, stat, loc) ->
+ setLoc(loc);
+ printl [name;":"];
+ space ();
+ print_substatement stat
+ | GOTO (name, loc) ->
+ setLoc(loc);
+ printl ["goto";name;";"];
+ new_line ()
+ | COMPGOTO (exp, loc) ->
+ setLoc(loc);
+ print ("goto *"); print_expression exp; print ";"; new_line ()
+ | DEFINITION d ->
+ print_def d
+ | ASM (attrs, tlist, details, loc) ->
+ setLoc(loc);
+ let print_asm_operand (identop,cnstr, e) =
+ print_string cnstr; space (); print_expression_level 100 e
+ in
+ if !msvcMode then begin
+ print "__asm {";
+ print_list (fun () -> new_line()) print tlist; (* templates *)
+ print "};"
+ end else begin
+ print "__asm__ ";
+ print_attributes attrs;
+ print "(";
+ print_list (fun () -> new_line()) print_string tlist; (* templates *)
+ begin
+ match details with
+ | None -> ()
+ | Some { aoutputs = outs; ainputs = ins; aclobbers = clobs } ->
+ print ":"; space ();
+ print_commas false print_asm_operand outs;
+ if ins <> [] || clobs <> [] then begin
+ print ":"; space ();
+ print_commas false print_asm_operand ins;
+ if clobs <> [] then begin
+ print ":"; space ();
+ print_commas false print_string clobs
+ end;
+ end
+ end;
+ print ");"
+ end;
+ new_line ()
+ | TRY_FINALLY (b, h, loc) ->
+ setLoc loc;
+ print "__try ";
+ print_block b;
+ print "__finally ";
+ print_block h
+
+ | 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 =
+ new_line();
+ print "{";
+ indent ();
+ if blk.blabels <> [] then begin
+ print "__label__ ";
+ print_commas false print blk.blabels;
+ print ";";
+ new_line ();
+ end;
+ if blk.battrs <> [] then begin
+ List.iter print_attribute blk.battrs;
+ new_line ();
+ end;
+ List.iter print_statement blk.bstmts;
+ unindent ();
+ print "}";
+ new_line ()
+
+and print_substatement stat =
+ match stat with
+ IF _
+ | SEQUENCE _
+ | DOWHILE _ ->
+ new_line ();
+ print "{";
+ indent ();
+ print_statement stat;
+ unindent ();
+ print "}";
+ new_line ();
+ | BLOCK _ ->
+ print_statement stat
+ | _ ->
+ indent ();
+ print_statement stat;
+ unindent ()
+
+
+(*
+** GCC Attributes
+*)
+and print_attribute (name,args) =
+ if args = [] then printu name
+ else begin
+ print name;
+ print "("; if name = "__attribute__" then print "(";
+ (match args with
+ [VARIABLE "aconst"] -> printu "const"
+ | [VARIABLE "restrict"] -> printu "restrict"
+ | _ -> print_commas false (fun e -> print_expression e) args);
+ print ")"; if name = "__attribute__" then print ")"
+ end
+
+(* Print attributes. *)
+and print_attributes attrs =
+ List.iter (fun a -> print_attribute a; space ()) attrs
+
+(*
+** Declaration printing
+*)
+and print_defs defs =
+ let prev = ref false in
+ List.iter
+ (fun def ->
+ (match def with
+ DECDEF _ -> prev := false
+ | _ ->
+ if not !prev then force_new_line ();
+ prev := true);
+ print_def def)
+ defs
+
+and print_def def =
+ match def with
+ FUNDEF (proto, body, loc, _) ->
+ comprint "fundef";
+ if !printCounters then begin
+ try
+ let fname =
+ match proto with
+ (_, (n, _, _, _)) -> n
+ in
+ print_def (DECDEF (([SpecType Tint],
+ [(fname ^ "__counter", JUSTBASE, [], cabslu),
+ NO_INIT]), loc));
+ with Not_found -> print "/* can't print the counter */"
+ end;
+ setLoc(loc);
+ print_single_name proto;
+ print_block body;
+ force_new_line ();
+
+ | DECDEF (names, loc) ->
+ comprint "decdef";
+ setLoc(loc);
+ print_init_name_group names;
+ print ";";
+ new_line ()
+
+ | TYPEDEF (names, loc) ->
+ comprint "typedef";
+ setLoc(loc);
+ print_name_group names;
+ print ";";
+ new_line ();
+ force_new_line ()
+
+ | ONLYTYPEDEF (specs, loc) ->
+ comprint "onlytypedef";
+ setLoc(loc);
+ print_specifiers specs;
+ print ";";
+ new_line ();
+ force_new_line ()
+
+ | GLOBASM (asm, loc) ->
+ setLoc(loc);
+ printl ["__asm__";"("]; print_string asm; print ");";
+ new_line ();
+ force_new_line ()
+
+ | PRAGMA (a,loc) ->
+ setLoc(loc);
+ force_new_line ();
+ print "#pragma ";
+ let oldwidth = !width in
+ width := 1000000; (* Do not wrap pragmas *)
+ print_expression a;
+ width := oldwidth;
+ force_new_line ()
+
+ | LINKAGE (n, loc, dl) ->
+ setLoc (loc);
+ force_new_line ();
+ print "extern "; print_string n; print_string " {";
+ List.iter print_def dl;
+ print_string "}";
+ force_new_line ()
+
+ | TRANSFORMER(srcdef, destdeflist, loc) ->
+ setLoc(loc);
+ print "@transform {";
+ force_new_line();
+ print "{";
+ force_new_line();
+ indent ();
+ print_def srcdef;
+ unindent();
+ print "}";
+ force_new_line();
+ print "to {";
+ force_new_line();
+ indent();
+ List.iter print_def destdeflist;
+ unindent();
+ print "}";
+ force_new_line()
+
+ | EXPRTRANSFORMER(srcexpr, destexpr, loc) ->
+ setLoc(loc);
+ print "@transformExpr { ";
+ print_expression srcexpr;
+ print " } to { ";
+ print_expression destexpr;
+ print " }";
+ force_new_line()
+
+
+(* sm: print a comment if the printComments flag is set *)
+and comprint (str : string) : unit =
+begin
+ if (!printComments) then (
+ print "/*";
+ print str;
+ print "*/ "
+ )
+ else
+ ()
+end
+
+(* sm: yield either the given string, or "", depending on printComments *)
+and comstring (str : string) : string =
+begin
+ if (!printComments) then
+ str
+ else
+ ""
+end
+
+
+(* print abstrac_syntax -> ()
+** Pretty printing the given abstract syntax program.
+*)
+let printFile (result : out_channel) ((fname, defs) : file) =
+ out := result;
+ Whitetrack.setOutput result;
+ print_defs defs;
+ Whitetrack.printEOF ();
+ flush () (* sm: should do this here *)
+
+let set_tab t = tab := t
+let set_width w = width := w
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+
+module E = Errormsg
+open Trace
+open Pretty
+
+(* Output management *)
+let out : out_channel option ref = ref None
+let close_me = ref false
+
+let close_output _ =
+ match !out with
+ None -> ()
+ | Some o -> begin
+ flush o;
+ if !close_me then close_out o else ();
+ close_me := false
+ end
+
+let set_output filename =
+ close_output ();
+ 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;
+ close_me := true
+
+ (* Signal that we are in MS VC mode *)
+let setMSVCMode () =
+ Cprint.msvcMode := true
+
+(* filename for patching *)
+let patchFileName : string ref = ref "" (* by default do no patching *)
+
+(* patching file contents *)
+let patchFile : Cabs.file option ref = ref None
+
+(* whether to print the patched CABS files *)
+let printPatchedFiles : bool ref = ref false
+
+(* whether to print a file of prototypes after parsing *)
+let doPrintProtos : bool ref = ref false
+
+(* this seems like something that should be built-in.. *)
+let isNone (o : 'a option) : bool =
+begin
+ match o with
+ | Some _ -> false
+ | None -> true
+end
+
+let printNotice = ref false
+
+(*
+** Argument definition
+*)
+let args : (string * Arg.spec * string) list =
+[
+ "--cabsonly", Arg.String set_output, "<fname> CABS output file name";
+ "--printComments", Arg.Unit (fun _ -> Cprint.printComments := true),
+ " print cabs tree structure in comments in cabs output";
+ "--patchFile", Arg.String (fun pf -> patchFileName := pf),
+ "<fname> name the file containing patching transformations";
+ "--printPatched", Arg.Unit (fun _ -> printPatchedFiles := true),
+ " print patched CABS files after patching, to *.patched";
+ "--printProtos", Arg.Unit (fun _ -> doPrintProtos := true),
+ " print prototypes to safec.proto.h after parsing";
+ "--printNotice", Arg.Set printNotice,
+ " include a comment saying printed by FrontC";
+]
+
+exception ParseError of string
+exception CabsOnly
+
+(* parse, and apply patching *)
+let rec parse_to_cabs fname =
+begin
+ (* parse the patch file if it isn't parsed already *)
+ if ((!patchFileName <> "") && (isNone !patchFile)) then (
+ (* parse the patch file *)
+ patchFile := Some(parse_to_cabs_inner !patchFileName);
+ if !E.hadErrors then
+ (failwith "There were parsing errors in the patch file")
+ );
+
+ (* now parse the file we came here to parse *)
+ let cabs = parse_to_cabs_inner fname in
+ if !E.hadErrors then
+ E.s (E.error "There were parsing errors in %s\n" fname);
+
+ (* and apply the patch file, return transformed file *)
+ let patched = match !patchFile with
+
+ | Some(pf) -> (
+ (* save old value of out so I can use it for debugging during patching *)
+ let oldOut = !out in
+
+ (* reset out so we don't try to print the patch file to it *)
+ out := None;
+
+ (trace "patch" (dprintf "newpatching %s\n" fname));
+ let result = (Stats.time "newpatch" (Patch.applyPatch pf) cabs) in
+
+ if (!printPatchedFiles) then begin
+ let outFname:string = fname ^ ".patched" in
+ (trace "patch" (dprintf "printing patched version of %s to %s\n"
+ fname outFname));
+ let o = (open_out outFname) in
+ (Cprint.printFile o result);
+ (close_out o)
+ end;
+
+ (* restore out *)
+ Cprint.flush ();
+ out := oldOut;
+
+ result
+ )
+ | None -> cabs
+ in
+
+ (* print it ... *)
+ (match !out with
+ Some o -> begin
+ (trace "sm" (dprintf "writing the cabs output\n"));
+ if !printNotice then output_string o ("/* Generated by Frontc */\n");
+ Stats.time "printCABS" (Cprint.printFile o) patched;
+ close_output ();
+ raise CabsOnly
+ end
+ | None -> ());
+ if !E.hadErrors then
+ raise Parsing.Parse_error;
+
+ (* and return the patched source *)
+ patched
+end
+
+and clexer lexbuf =
+ Clexer.clear_white ();
+ Clexer.clear_lexeme ();
+ let token = Clexer.initial lexbuf in
+ let white = Clexer.get_white () in
+ let cabsloc = Clexer.currentLoc () in
+ let lexeme = Clexer.get_extra_lexeme () ^ Lexing.lexeme lexbuf in
+ white,lexeme,token,cabsloc
+
+(* just parse *)
+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 cabs = Stats.time "parse" (Cparser.interpret (Whitetrack.wraplexer clexer)) lexbuf in
+ Whitetrack.setFinalWhite (Clexer.get_white ());
+ Clexer.finish ();
+ (fname, cabs)
+ with (Sys_error msg) -> begin
+ ignore (E.log "Cannot open %s : %s\n" fname msg);
+ Clexer.finish ();
+ close_output ();
+ raise (ParseError("Cannot open " ^ fname ^ ": " ^ msg ^ "\n"))
+ end
+ | Parsing.Parse_error -> begin
+ ignore (E.log "Parsing error\n");
+ Clexer.finish ();
+ close_output ();
+ raise (ParseError("Parse error"))
+ end
+ | e -> begin
+ ignore (E.log "Caught %s while parsing\n" (Printexc.to_string e));
+ Clexer.finish ();
+ raise e
+ end
+
+
+(* print to safec.proto.h the prototypes of all functions that are defined *)
+let printPrototypes ((fname, file) : Cabs.file) : unit =
+begin
+ (*ignore (E.log "file has %d defns\n" (List.length file));*)
+
+ let chan = open_out "safec.proto.h" in
+ ignore (fprintf chan "/* generated prototypes file, %d defs */\n" (List.length file));
+ Cprint.out := chan;
+
+ let counter : int ref = ref 0 in
+
+ let rec loop (d : Cabs.definition) = begin
+ match d with
+ | Cabs.FUNDEF(name, _, loc, _) -> (
+ match name with
+ | (_, (funcname, Cabs.PROTO(_,_,_), _, _)) -> (
+ incr counter;
+ ignore (fprintf chan "\n/* %s from %s:%d */\n"
+ funcname loc.Cabs.filename loc.Cabs.lineno);
+ flush chan;
+ Cprint.print_single_name name;
+ Cprint.print_unescaped_string ";";
+ Cprint.force_new_line ();
+ Cprint.flush ()
+ )
+ | _ -> ()
+ )
+
+ | _ -> ()
+ end in
+ (List.iter loop file);
+
+ ignore (fprintf chan "\n/* wrote %d prototypes */\n" !counter);
+ close_out chan;
+ ignore (E.log "printed %d prototypes from %d defns to safec.proto.h\n"
+ !counter (List.length file))
+end
+
+
+
+let parse_helper fname =
+ (trace "sm" (dprintf "parsing %s to Cabs\n" fname));
+ let cabs = parse_to_cabs fname in
+ (* Now (return a function that will) convert to CIL *)
+ fun _ ->
+ (trace "sm" (dprintf "converting %s from Cabs to CIL\n" fname));
+ let cil = Stats.time "convert to CIL" Cabs2cil.convFile cabs in
+ if !doPrintProtos then (printPrototypes cabs);
+ cabs, cil
+
+let parse fname = (fun () -> snd(parse_helper fname ()))
+
+let parse_with_cabs fname = (fun () -> parse_helper fname ())
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+
+ (* Signal that we are in MS VC mode *)
+val setMSVCMode: unit -> unit
+
+
+ (* Parse a file in *)
+exception ParseError of string
+
+ (* Raised when the front-end is requested to print the CABS and return *)
+exception CabsOnly
+
+ (* additional command line arguments *)
+val args: (string * Arg.spec * string) list
+
+ (* the main command to parse a file. Return a thunk that can be used to
+ * convert the AST to CIL. *)
+val parse: string -> (unit -> Cil.file)
+
+val parse_with_cabs: string -> (unit -> Cabs.file * Cil.file)
--- /dev/null
+
+module E = Errormsg
+
+(* We provide here a pointer to a function. It will be set by the lexer and
+ * used by the parser. In Ocaml lexers depend on parsers, so we we have put
+ * such functions in a separate module. *)
+let add_identifier: (string -> unit) ref =
+ ref (fun _ -> E.s (E.bug "You called an uninitialized add_identifier"))
+
+let add_type: (string -> unit) ref =
+ ref (fun _ -> E.s (E.bug "You called an uninitialized add_type"))
+
+let push_context: (unit -> unit) ref =
+ ref (fun _ -> E.s (E.bug "You called an uninitialized push_context"))
+
+let pop_context: (unit -> unit) ref =
+ ref (fun _ -> E.s (E.bug "You called an uninitialized pop_context"))
+
+
+(* Keep here the current pattern for formatparse *)
+let currentPattern = ref ""
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+
+(* patch.ml *)
+(* CABS file patching *)
+
+open Cabs
+open Cabshelper
+open Trace
+open Pretty
+open Cabsvisit
+
+(* binding of a unification variable to a syntactic construct *)
+type binding =
+ | BSpecifier of string * spec_elem list
+ | BName of string * string
+ | BExpr of string * expression
+
+(* thrown when unification fails *)
+exception NoMatch
+
+(* thrown when an attempt to find the associated binding fails *)
+exception BadBind of string
+
+(* trying to isolate performance problems; will hide all the *)
+(* potentially expensive debugging output behind "if verbose .." *)
+let verbose : bool = true
+
+
+(* raise NoMatch if x and y are not equal *)
+let mustEq (x : 'a) (y : 'a) : unit =
+begin
+ if (x <> y) then (
+ if verbose then
+ (trace "patchDebug" (dprintf "mismatch by structural disequality\n"));
+ raise NoMatch
+ )
+end
+
+(* why isn't this in the core Ocaml library? *)
+let identity x = x
+
+
+let isPatternVar (s : string) : bool =
+begin
+ ((String.length s) >= 1) && ((String.get s 0) = '@')
+end
+
+(* 's' is actually "@name(blah)"; extract the 'blah' *)
+let extractPatternVar (s : string) : string =
+ (*(trace "patch" (dprintf "extractPatternVar %s\n" s));*)
+ (String.sub s 6 ((String.length s) - 7))
+
+
+(* a few debugging printers.. *)
+let printExpr (e : expression) =
+begin
+ if (verbose && traceActive "patchDebug") then (
+ Cprint.print_expression e; Cprint.force_new_line ();
+ Cprint.flush ()
+ )
+end
+
+let printSpec (spec: spec_elem list) =
+begin
+ if (verbose && traceActive "patchDebug") then (
+ Cprint.print_specifiers spec; Cprint.force_new_line ();
+ Cprint.flush ()
+ )
+end
+
+let printSpecs (pat : spec_elem list) (tgt : spec_elem list) =
+begin
+ (printSpec pat);
+ (printSpec tgt)
+end
+
+let printDecl (pat : name) (tgt : name) =
+begin
+ if (verbose && traceActive "patchDebug") then (
+ Cprint.print_name pat; Cprint.force_new_line ();
+ Cprint.print_name tgt; Cprint.force_new_line ();
+ Cprint.flush ()
+ )
+end
+
+let printDeclType (pat : decl_type) (tgt : decl_type) =
+begin
+ if (verbose && traceActive "patchDebug") then (
+ Cprint.print_decl "__missing_field_name" pat; Cprint.force_new_line ();
+ Cprint.print_decl "__missing_field_name" tgt; Cprint.force_new_line ();
+ Cprint.flush ()
+ )
+end
+
+let printDefn (d : definition) =
+begin
+ if (verbose && traceActive "patchDebug") then (
+ Cprint.print_def d;
+ Cprint.flush ()
+ )
+end
+
+
+(* class to describe how to modify the tree for subtitution *)
+class substitutor (bindings : binding list) = object(self)
+ inherit nopCabsVisitor as super
+
+ (* look in the binding list for a given name *)
+ method findBinding (name : string) : binding =
+ begin
+ try
+ (List.find
+ (fun b ->
+ match b with
+ | BSpecifier(n, _) -> n=name
+ | BName(n, _) -> n=name
+ | BExpr(n, _) -> n=name)
+ bindings)
+ with
+ Not_found -> raise (BadBind ("name not found: " ^ name))
+ end
+
+ method vexpr (e:expression) : expression visitAction =
+ begin
+ match e with
+ | EXPR_PATTERN(name) -> (
+ match (self#findBinding name) with
+ | BExpr(_, expr) -> ChangeTo(expr) (* substitute bound expression *)
+ | _ -> raise (BadBind ("wrong type: " ^ name))
+ )
+ | _ -> DoChildren
+ end
+
+ (* use of a name *)
+ method vvar (s:string) : string =
+ begin
+ if (isPatternVar s) then (
+ let nameString = (extractPatternVar s) in
+ match (self#findBinding nameString) with
+ | BName(_, str) -> str (* substitute *)
+ | _ -> raise (BadBind ("wrong type: " ^ nameString))
+ )
+ else
+ s
+ end
+
+ (* binding introduction of a name *)
+ 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 *)
+ if (s <> replacement) then
+ ChangeTo(replacement, dtype, attrs, loc)
+ else
+ DoChildren (* no replacement *)
+ )
+ end
+
+ method vspec (specList: specifier) : specifier visitAction =
+ begin
+ if verbose then (trace "patchDebug" (dprintf "substitutor: vspec\n"));
+ (printSpec specList);
+
+ (* are any of the specifiers SpecPatterns? we have to check the entire *)
+ (* list, not just the head, because e.g. "typedef @specifier(foo)" has *)
+ (* "typedef" as the head of the specifier list *)
+ if (List.exists (fun elt -> match elt with
+ | SpecPattern(_) -> true
+ | _ -> false)
+ specList) then begin
+ (* yes, replace the existing list with one got by *)
+ (* replacing all occurrences of SpecPatterns *)
+ (trace "patchDebug" (dprintf "at least one spec pattern\n"));
+ ChangeTo
+ (List.flatten
+ (List.map
+ (* for each specifier element, yield the specifier list *)
+ (* to which it maps; then we'll flatten the final result *)
+ (fun elt ->
+ match elt with
+ | SpecPattern(name) -> (
+ match (self#findBinding name) with
+ | BSpecifier(_, replacement) -> (
+ (trace "patchDebug" (dprintf "replacing pattern %s\n" name));
+ replacement
+ )
+ | _ -> raise (BadBind ("wrong type: " ^ name))
+ )
+ | _ -> [elt] (* leave this one alone *)
+ )
+ specList
+ )
+ )
+ end
+ else
+ (* none of the specifiers in specList are patterns *)
+ DoChildren
+ end
+
+ method vtypespec (tspec: typeSpecifier) : typeSpecifier visitAction =
+ begin
+ match tspec with
+ | Tnamed(str) when (isPatternVar str) ->
+ ChangeTo(Tnamed(self#vvar str))
+ | Tstruct(str, fields, extraAttrs) when (isPatternVar str) -> (
+ (trace "patchDebug" (dprintf "substituting %s\n" str));
+ ChangeDoChildrenPost(Tstruct((self#vvar str), fields, extraAttrs), identity)
+ )
+ | Tunion(str, fields, extraAttrs) when (isPatternVar str) ->
+ (trace "patchDebug" (dprintf "substituting %s\n" str));
+ ChangeDoChildrenPost(Tunion((self#vvar str), fields, extraAttrs), identity)
+ | _ -> DoChildren
+ end
+
+end
+
+
+(* why can't I have forward declarations in the language?!! *)
+let unifyExprFwd : (expression -> expression -> binding list) ref
+ = ref (fun e e -> [])
+
+
+(* substitution for expressions *)
+let substExpr (bindings : binding list) (expr : expression) : expression =
+begin
+ if verbose then
+ (trace "patchDebug" (dprintf "substExpr with %d bindings\n" (List.length bindings)));
+ (printExpr expr);
+
+ (* apply the transformation *)
+ let result = (visitCabsExpression (new substitutor bindings :> cabsVisitor) expr) in
+ (printExpr result);
+
+ result
+end
+
+let d_loc (_:unit) (loc: cabsloc) : doc =
+ text loc.filename ++ chr ':' ++ num loc.lineno
+
+
+(* class to describe how to modify the tree when looking for places *)
+(* to apply expression transformers *)
+class exprTransformer (srcpattern : expression) (destpattern : expression)
+ (patchline : int) (srcloc : cabsloc) = object(self)
+ inherit nopCabsVisitor as super
+
+ method vexpr (e:expression) : expression visitAction =
+ begin
+ (* see if the source pattern matches this subexpression *)
+ try (
+ let bindings = (!unifyExprFwd srcpattern e) in
+
+ (* match! *)
+ (trace "patch" (dprintf "expr match: patch line %d, src %a\n"
+ patchline d_loc srcloc));
+ ChangeTo(substExpr bindings destpattern)
+ )
+
+ with NoMatch -> (
+ (* doesn't apply *)
+ DoChildren
+ )
+ end
+
+ (* other constructs left unchanged *)
+end
+
+
+let unifyList (pat : 'a list) (tgt : 'a list)
+ (unifyElement : 'a -> 'a -> binding list) : binding list =
+begin
+ if verbose then
+ (trace "patchDebug" (dprintf "unifyList (pat len %d, tgt len %d)\n"
+ (List.length pat) (List.length tgt)));
+
+ (* walk down the lists *)
+ let rec loop pat tgt : binding list =
+ match pat, tgt with
+ | [], [] -> []
+ | (pelt :: prest), (telt :: trest) ->
+ (unifyElement pelt telt) @
+ (loop prest trest)
+ | _,_ -> (
+ (* no match *)
+ if verbose then (
+ (trace "patchDebug" (dprintf "mismatching list length\n"));
+ );
+ raise NoMatch
+ )
+ in
+ (loop pat tgt)
+end
+
+
+let gettime () : float =
+ (Unix.times ()).Unix.tms_utime
+
+let rec applyPatch (patchFile : file) (srcFile : file) : file =
+begin
+ let patch : definition list = (snd patchFile) in
+ let srcFname : string = (fst srcFile) in
+ let src : definition list = (snd srcFile) in
+
+ (trace "patchTime" (dprintf "applyPatch start: %f\n" (gettime ())));
+ if (traceActive "patchDebug") then
+ Cprint.out := stdout (* hack *)
+ else ();
+
+ (* more hackery *)
+ unifyExprFwd := unifyExpr;
+
+ (* patch a single source definition, yield transformed *)
+ let rec patchDefn (patch : definition list) (d : definition) : definition list =
+ begin
+ match patch with
+ | TRANSFORMER(srcpattern, destpattern, loc) :: rest -> (
+ if verbose then
+ (trace "patchDebug"
+ (dprintf "considering applying defn pattern at line %d to src at %a\n"
+ loc.lineno d_loc (get_definitionloc d)));
+
+ (* see if the source pattern matches the definition 'd' we have *)
+ try (
+ let bindings = (unifyDefn srcpattern d) in
+
+ (* we have a match! apply the substitutions *)
+ (trace "patch" (dprintf "defn match: patch line %d, src %a\n"
+ loc.lineno d_loc (get_definitionloc d)));
+
+ (List.map (fun destElt -> (substDefn bindings destElt)) destpattern)
+ )
+
+ with NoMatch -> (
+ (* no match, continue down list *)
+ (*(trace "patch" (dprintf "no match\n"));*)
+ (patchDefn rest d)
+ )
+ )
+
+ | EXPRTRANSFORMER(srcpattern, destpattern, loc) :: rest -> (
+ if verbose then
+ (trace "patchDebug"
+ (dprintf "considering applying expr pattern at line %d to src at %a\n"
+ loc.lineno d_loc (get_definitionloc d)));
+
+ (* walk around in 'd' looking for expressions to modify *)
+ let dList = (visitCabsDefinition
+ ((new exprTransformer srcpattern destpattern
+ loc.lineno (get_definitionloc d))
+ :> cabsVisitor)
+ d
+ ) in
+
+ (* 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 *)
+ (* all of them into a single list *)
+ (List.flatten (List.map (fun d -> (patchDefn rest d)) dList))
+ )
+
+ | _ :: rest -> (
+ (* not a transformer; just keep going *)
+ (patchDefn rest d)
+ )
+ | [] -> (
+ (* reached the end of the patch file with no match *)
+ [d] (* have to wrap it in a list ... *)
+ )
+ end in
+
+ (* transform all the definitions *)
+ let result : definition list =
+ (List.flatten (List.map (fun d -> (patchDefn patch d)) src)) in
+
+ (*Cprint.print_defs result;*)
+
+ if (traceActive "patchDebug") then (
+ (* avoid flush bug? yes *)
+ Cprint.force_new_line ();
+ Cprint.flush ()
+ );
+
+ (trace "patchTime" (dprintf "applyPatch finish: %f\n" (gettime ())));
+ (srcFname, result)
+end
+
+
+(* given a definition pattern 'pat', and a target concrete defintion 'tgt', *)
+(* determine if they can be unified; if so, return the list of bindings of *)
+(* unification variables in pat; otherwise raise NoMatch *)
+and unifyDefn (pat : definition) (tgt : definition) : binding list =
+begin
+ match pat, tgt with
+ | DECDEF((pspecifiers, pdeclarators), _),
+ DECDEF((tspecifiers, tdeclarators), _) -> (
+ if verbose then
+ (trace "patchDebug" (dprintf "unifyDefn of DECDEFs\n"));
+ (unifySpecifiers pspecifiers tspecifiers) @
+ (unifyInitDeclarators pdeclarators tdeclarators)
+ )
+
+ | TYPEDEF((pspec, pdecl), _),
+ TYPEDEF((tspec, tdecl), _) -> (
+ if verbose then
+ (trace "patchDebug" (dprintf "unifyDefn of TYPEDEFs\n"));
+ (unifySpecifiers pspec tspec) @
+ (unifyDeclarators pdecl tdecl)
+ )
+
+ | ONLYTYPEDEF(pspec, _),
+ ONLYTYPEDEF(tspec, _) -> (
+ if verbose then
+ (trace "patchDebug" (dprintf "unifyDefn of ONLYTYPEDEFs\n"));
+ (unifySpecifiers pspec tspec)
+ )
+
+ | _, _ -> (
+ if verbose then
+ (trace "patchDebug" (dprintf "mismatching definitions\n"));
+ raise NoMatch
+ )
+end
+
+and unifySpecifier (pat : spec_elem) (tgt : spec_elem) : binding list =
+begin
+ if verbose then
+ (trace "patchDebug" (dprintf "unifySpecifier\n"));
+ (printSpecs [pat] [tgt]);
+
+ if (pat = tgt) then [] else
+
+ match pat, tgt with
+ | SpecType(tspec1), SpecType(tspec2) ->
+ (unifyTypeSpecifier tspec1 tspec2)
+ | SpecPattern(name), _ ->
+ (* record that future occurrances of @specifier(name) will yield this specifier *)
+ if verbose then
+ (trace "patchDebug" (dprintf "found specifier match for %s\n" name));
+ [BSpecifier(name, [tgt])]
+ | _,_ -> (
+ (* no match *)
+ if verbose then (
+ (trace "patchDebug" (dprintf "mismatching specifiers\n"));
+ );
+ raise NoMatch
+ )
+end
+
+and unifySpecifiers (pat : spec_elem list) (tgt : spec_elem list) : binding list =
+begin
+ if verbose then
+ (trace "patchDebug" (dprintf "unifySpecifiers\n"));
+ (printSpecs pat tgt);
+
+ (* canonicalize the specifiers by sorting them *)
+ let pat' = (List.stable_sort compare pat) in
+ let tgt' = (List.stable_sort compare tgt) in
+
+ (* if they are equal, they match with no further checking *)
+ if (pat' = tgt') then [] else
+
+ (* walk down the lists; don't walk the sorted lists because the *)
+ (* pattern must always be last, if it occurs *)
+ let rec loop pat tgt : binding list =
+ match pat, tgt with
+ | [], [] -> []
+ | [SpecPattern(name)], _ ->
+ (* final SpecPattern matches anything which comes after *)
+ (* 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)]
+ | (pspec :: prest), (tspec :: trest) ->
+ (unifySpecifier pspec tspec) @
+ (loop prest trest)
+ | _,_ -> (
+ (* no match *)
+ if verbose then (
+ (trace "patchDebug" (dprintf "mismatching specifier list length\n"));
+ );
+ raise NoMatch
+ )
+ in
+ (loop pat tgt)
+end
+
+and unifyTypeSpecifier (pat: typeSpecifier) (tgt: typeSpecifier) : binding list =
+begin
+ if verbose then
+ (trace "patchDebug" (dprintf "unifyTypeSpecifier\n"));
+
+ if (pat = tgt) then [] else
+
+ match pat, tgt with
+ | Tnamed(s1), Tnamed(s2) -> (unifyString s1 s2)
+ | Tstruct(name1, None, _), Tstruct(name2, None, _) ->
+ (unifyString name1 name2)
+ | Tstruct(name1, Some(fields1), _), Tstruct(name2, Some(fields2), _) ->
+ (* ignoring extraAttrs b/c we're just trying to come up with a list
+ * of substitutions, and there's no unify_attributes function, and
+ * I don't care at this time about checking that they are equal .. *)
+ (unifyString name1 name2) @
+ (unifyList fields1 fields2 unifyField)
+ | Tunion(name1, None, _), Tstruct(name2, None, _) ->
+ (unifyString name1 name2)
+ | Tunion(name1, Some(fields1), _), Tunion(name2, Some(fields2), _) ->
+ (unifyString name1 name2) @
+ (unifyList fields1 fields2 unifyField)
+ | Tenum(name1, None, _), Tenum(name2, None, _) ->
+ (unifyString name1 name2)
+ | Tenum(name1, Some(items1), _), Tenum(name2, Some(items2), _) ->
+ (mustEq items1 items2); (* enum items *)
+ (unifyString name1 name2)
+ | TtypeofE(exp1), TtypeofE(exp2) ->
+ (unifyExpr exp1 exp2)
+ | TtypeofT(spec1, dtype1), TtypeofT(spec2, dtype2) ->
+ (unifySpecifiers spec1 spec2) @
+ (unifyDeclType dtype1 dtype2)
+ | _ -> (
+ if verbose then (trace "patchDebug" (dprintf "mismatching typeSpecifiers\n"));
+ raise NoMatch
+ )
+end
+
+and unifyField (pat : field_group) (tgt : field_group) : binding list =
+begin
+ match pat,tgt with (spec1, list1), (spec2, list2) -> (
+ (unifySpecifiers spec1 spec2) @
+ (unifyList list1 list2 unifyNameExprOpt)
+ )
+end
+
+and unifyNameExprOpt (pat : name * expression option)
+ (tgt : name * expression option) : binding list =
+begin
+ match pat,tgt with
+ | (name1, None), (name2, None) -> (unifyName name1 name2)
+ | (name1, Some(exp1)), (name2, Some(exp2)) ->
+ (unifyName name1 name2) @
+ (unifyExpr exp1 exp2)
+ | _,_ -> []
+end
+
+and unifyName (pat : name) (tgt : name) : binding list =
+begin
+ match pat,tgt with (pstr, pdtype, pattrs, ploc), (tstr, tdtype, tattrs, tloc) ->
+ (mustEq pattrs tattrs);
+ (unifyString pstr tstr) @
+ (unifyDeclType pdtype tdtype)
+end
+
+and unifyInitDeclarators (pat : init_name list) (tgt : init_name list) : binding list =
+begin
+ (*
+ if verbose then
+ (trace "patchDebug" (dprintf "unifyInitDeclarators, pat %d, tgt %d\n"
+ (List.length pat) (List.length tgt)));
+ *)
+
+ match pat, tgt with
+ | ((pdecl, piexpr) :: prest),
+ ((tdecl, tiexpr) :: trest) ->
+ (unifyDeclarator pdecl tdecl) @
+ (unifyInitExpr piexpr tiexpr) @
+ (unifyInitDeclarators prest trest)
+ | [], [] -> []
+ | _, _ -> (
+ if verbose then
+ (trace "patchDebug" (dprintf "mismatching init declarators\n"));
+ raise NoMatch
+ )
+end
+
+and unifyDeclarators (pat : name list) (tgt : name list) : binding list =
+ (unifyList pat tgt unifyDeclarator)
+
+and unifyDeclarator (pat : name) (tgt : name) : binding list =
+begin
+ if verbose then
+ (trace "patchDebug" (dprintf "unifyDeclarator\n"));
+ (printDecl pat tgt);
+
+ match pat, tgt with
+ | (pname, pdtype, pattr, ploc),
+ (tname, tdtype, tattr, tloc) ->
+ (mustEq pattr tattr);
+ (unifyDeclType pdtype tdtype) @
+ (unifyString pname tname)
+end
+
+and unifyDeclType (pat : decl_type) (tgt : decl_type) : binding list =
+begin
+ if verbose then
+ (trace "patchDebug" (dprintf "unifyDeclType\n"));
+ (printDeclType pat tgt);
+
+ match pat, tgt with
+ | JUSTBASE, JUSTBASE -> []
+ | PARENTYPE(pattr1, ptype, pattr2),
+ PARENTYPE(tattr1, ttype, tattr2) ->
+ (mustEq pattr1 tattr1);
+ (mustEq pattr2 tattr2);
+ (unifyDeclType ptype ttype)
+ | ARRAY(ptype, pattr, psz),
+ ARRAY(ttype, tattr, tsz) ->
+ (mustEq pattr tattr);
+ (unifyDeclType ptype ttype) @
+ (unifyExpr psz tsz)
+ | PTR(pattr, ptype),
+ PTR(tattr, ttype) ->
+ (mustEq pattr tattr);
+ (unifyDeclType ptype ttype)
+ | PROTO(ptype, pformals, pva),
+ PROTO(ttype, tformals, tva) ->
+ (mustEq pva tva);
+ (unifyDeclType ptype ttype) @
+ (unifySingleNames pformals tformals)
+ | _ -> (
+ if verbose then
+ (trace "patchDebug" (dprintf "mismatching decl_types\n"));
+ raise NoMatch
+ )
+end
+
+and unifySingleNames (pat : single_name list) (tgt : single_name list) : binding list =
+begin
+ if verbose then
+ (trace "patchDebug" (dprintf "unifySingleNames, pat %d, tgt %d\n"
+ (List.length pat) (List.length tgt)));
+
+ match pat, tgt with
+ | [], [] -> []
+ | (pspec, pdecl) :: prest,
+ (tspec, tdecl) :: trest ->
+ (unifySpecifiers pspec tspec) @
+ (unifyDeclarator pdecl tdecl) @
+ (unifySingleNames prest trest)
+ | _, _ -> (
+ if verbose then
+ (trace "patchDebug" (dprintf "mismatching single_name lists\n"));
+ raise NoMatch
+ )
+end
+
+and unifyString (pat : string) (tgt : string) : binding list =
+begin
+ (* equal? match with no further ado *)
+ if (pat = tgt) then [] else
+
+ (* is the pattern a variable? *)
+ if (isPatternVar pat) then
+ (* pat is actually "@name(blah)"; extract the 'blah' *)
+ let varname = (extractPatternVar pat) in
+
+ (* when substituted, this name becomes 'tgt' *)
+ if verbose then
+ (trace "patchDebug" (dprintf "found name match for %s\n" varname));
+ [BName(varname, tgt)]
+
+ else (
+ if verbose then
+ (trace "patchDebug" (dprintf "mismatching names: %s and %s\n" pat tgt));
+ raise NoMatch
+ )
+end
+
+and unifyExpr (pat : expression) (tgt : expression) : binding list =
+begin
+ (* if they're equal, that's good enough *)
+ if (pat = tgt) then [] else
+
+ (* shorter name *)
+ let ue = unifyExpr in
+
+ (* because of the equality check above, I can omit some cases *)
+ match pat, tgt with
+ | UNARY(pop, pexpr),
+ UNARY(top, texpr) ->
+ (mustEq pop top);
+ (ue pexpr texpr)
+ | BINARY(pop, pexp1, pexp2),
+ BINARY(top, texp1, texp2) ->
+ (mustEq pop top);
+ (ue pexp1 texp1) @
+ (ue pexp2 texp2)
+ | QUESTION(p1, p2, p3),
+ QUESTION(t1, t2, t3) ->
+ (ue p1 t1) @
+ (ue p2 t2) @
+ (ue p3 t3)
+ | CAST((pspec, ptype), piexpr),
+ CAST((tspec, ttype), tiexpr) ->
+ (mustEq ptype ttype);
+ (unifySpecifiers pspec tspec) @
+ (unifyInitExpr piexpr tiexpr)
+ | CALL(pfunc, pargs),
+ CALL(tfunc, targs) ->
+ (ue pfunc tfunc) @
+ (unifyExprs pargs targs)
+ | COMMA(pexprs),
+ COMMA(texprs) ->
+ (unifyExprs pexprs texprs)
+ | EXPR_SIZEOF(pexpr),
+ EXPR_SIZEOF(texpr) ->
+ (ue pexpr texpr)
+ | TYPE_SIZEOF(pspec, ptype),
+ TYPE_SIZEOF(tspec, ttype) ->
+ (mustEq ptype ttype);
+ (unifySpecifiers pspec tspec)
+ | EXPR_ALIGNOF(pexpr),
+ EXPR_ALIGNOF(texpr) ->
+ (ue pexpr texpr)
+ | TYPE_ALIGNOF(pspec, ptype),
+ TYPE_ALIGNOF(tspec, ttype) ->
+ (mustEq ptype ttype);
+ (unifySpecifiers pspec tspec)
+ | INDEX(parr, pindex),
+ INDEX(tarr, tindex) ->
+ (ue parr tarr) @
+ (ue pindex tindex)
+ | MEMBEROF(pexpr, pfield),
+ MEMBEROF(texpr, tfield) ->
+ (mustEq pfield tfield);
+ (ue pexpr texpr)
+ | MEMBEROFPTR(pexpr, pfield),
+ MEMBEROFPTR(texpr, tfield) ->
+ (mustEq pfield tfield);
+ (ue pexpr texpr)
+ | GNU_BODY(pblock),
+ GNU_BODY(tblock) ->
+ (mustEq pblock tblock);
+ []
+ | EXPR_PATTERN(name), _ ->
+ (* match, and contribute binding *)
+ if verbose then
+ (trace "patchDebug" (dprintf "found expr match for %s\n" name));
+ [BExpr(name, tgt)]
+ | a, b ->
+ if (verbose && traceActive "patchDebug") then (
+ (trace "patchDebug" (dprintf "mismatching expression\n"));
+ (printExpr a);
+ (printExpr b)
+ );
+ raise NoMatch
+end
+
+and unifyInitExpr (pat : init_expression) (tgt : init_expression) : binding list =
+begin
+ (*
+ Cprint.print_init_expression pat; Cprint.force_new_line ();
+ Cprint.print_init_expression tgt; Cprint.force_new_line ();
+ Cprint.flush ();
+ *)
+
+ match pat, tgt with
+ | NO_INIT, NO_INIT -> []
+ | SINGLE_INIT(pe), SINGLE_INIT(te) ->
+ (unifyExpr pe te)
+ | COMPOUND_INIT(plist),
+ COMPOUND_INIT(tlist) -> (
+ let rec loop plist tlist =
+ match plist, tlist with
+ | ((pwhat, piexpr) :: prest),
+ ((twhat, tiexpr) :: trest) ->
+ (mustEq pwhat twhat);
+ (unifyInitExpr piexpr tiexpr) @
+ (loop prest trest)
+ | [], [] -> []
+ | _, _ -> (
+ if verbose then
+ (trace "patchDebug" (dprintf "mismatching compound init exprs\n"));
+ raise NoMatch
+ )
+ in
+ (loop plist tlist)
+ )
+ | _,_ -> (
+ if verbose then
+ (trace "patchDebug" (dprintf "mismatching init exprs\n"));
+ raise NoMatch
+ )
+end
+
+and unifyExprs (pat : expression list) (tgt : expression list) : binding list =
+ (unifyList pat tgt unifyExpr)
+
+
+(* given the list of bindings 'b', substitute them into 'd' to yield a new definition *)
+and substDefn (bindings : binding list) (defn : definition) : definition =
+begin
+ if verbose then
+ (trace "patchDebug" (dprintf "substDefn with %d bindings\n" (List.length bindings)));
+ (printDefn defn);
+
+ (* apply the transformation *)
+ match (visitCabsDefinition (new substitutor bindings :> cabsVisitor) defn) with
+ | [d] -> d (* expect a singleton list *)
+ | _ -> (failwith "didn't get a singleton list where I expected one")
+end
+
+
+(* end of file *)
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+
+(* patch.mli *)
+(* interface for patch.ml *)
+
+val applyPatch : Cabs.file -> Cabs.file -> Cabs.file
--- /dev/null
+
+open Cabs
+open Cabshelper
+
+(* This isn't the most efficient way to do things.
+ * It would probably be better to not reparse rather
+ * than keep the tokens in memory *)
+
+(* In particular, most of the tokens we hold will be
+ header files that we don't need *)
+
+(* map cabslocs to token indexes *)
+
+(* TODO: gather until end of line, then decide where to split *)
+
+(* NOTE: If you find yourself getting lots of nomatch errors with
+ * parens in them, then that may mean you are printing
+ * a cabs file that has had it's parens removed *)
+
+let tokenmap : ((string * int),int) Hashtbl.t = Hashtbl.create 1000
+let nextidx = ref 0
+
+let gonebad = ref false
+
+(* array of tokens and whitespace *)
+let tokens = GrowArray.make 0 (GrowArray.Elem ("",""))
+
+let cabsloc_to_str cabsloc =
+ cabsloc.filename ^ ":" ^ string_of_int cabsloc.lineno ^ ":" ^
+ string_of_int cabsloc.byteno ^ ":" ^
+ string_of_int cabsloc.ident
+
+let lastline = ref 0
+
+let wraplexer_enabled lexer lexbuf =
+ let white,lexeme,token,cabsloc = lexer lexbuf in
+ GrowArray.setg tokens !nextidx (white,lexeme);
+ Hashtbl.add tokenmap (cabsloc.filename,cabsloc.byteno) !nextidx;
+ nextidx := !nextidx + 1;
+ token
+
+let wraplexer_disabled lexer lexbuf =
+ let white,lexeme,token,cabsloc = lexer lexbuf in
+ token
+
+let enabled = ref false
+
+let wraplexer lexer =
+ if !enabled then wraplexer_enabled lexer
+ else wraplexer_disabled lexer
+
+let finalwhite = ref "\n"
+
+let setFinalWhite w = finalwhite := w
+
+let curidx = ref 0
+let noidx = -1
+let out = ref stdout
+
+let setLoc cabsloc =
+ if cabsloc != cabslu && !enabled then begin
+ try
+ curidx := Hashtbl.find tokenmap (cabsloc.filename,cabsloc.byteno)
+ with
+ Not_found -> Errormsg.s
+ (Errormsg.error "setLoc with location for non-lexed token: %s"
+ (cabsloc_to_str cabsloc))
+ end else begin curidx := noidx; () end
+
+let setOutput out_chan =
+ out := out_chan
+
+(* TODO: do this properly *)
+let invent_white () = " "
+
+let rec chopwhite str =
+ if String.length str = 0 then str
+ else if String.get str (String.length str - 1) = ' ' then
+ chopwhite (String.sub str 0 (String.length str - 1))
+ else if String.get str 0 = ' ' then
+ chopwhite (String.sub str 1 (String.length str - 1))
+ else str
+
+let last_was_maybe = ref false
+let last_str = ref ""
+
+let print str =
+ let str = chopwhite str in
+ if str = "" then ()
+ else if !curidx == noidx || not !enabled then
+ output_string !out (invent_white() ^ str)
+ else begin
+ let srcwhite,srctok = GrowArray.getg tokens !curidx in
+ let white = if str = srctok
+ then srcwhite
+ else if !gonebad then invent_white ()
+ else begin
+ ignore (Errormsg.warnOpt "%s" ("nomatch:["^String.escaped str^"] expected:["^String.escaped srctok ^
+ "] - NOTE: cpp not supported"));
+ gonebad := true;
+ invent_white ()
+ end in
+ if !last_was_maybe && str = !last_str then () else begin
+ output_string !out (white ^ str);
+ curidx := !curidx + 1
+ end
+ end;
+ last_was_maybe := false
+
+let printl strs =
+ List.iter print strs
+
+let printu str =
+ if not !enabled then print str
+ else
+ let srcwhite,srctok = GrowArray.getg tokens !curidx in
+ if chopwhite str = "" then ()
+ else if srctok = str
+ || srctok = str ^ "__"
+ || srctok = "__" ^ str
+ || srctok = "__" ^ str ^ "__"
+ then
+ print srctok
+ else (print_endline ("u-nomatch:["^str^"]"); print str)
+
+let print_maybe str =
+ if not !enabled then print str
+ else
+ let srcwhite,srctok = GrowArray.getg tokens !curidx in
+ if str = srctok then begin
+ print str;
+ last_was_maybe := true;
+ last_str := str
+ end else ()
+
+
+let printEOF () = output_string !out !finalwhite
+
+
--- /dev/null
+
+(* wrapped version of the lexer that remembers all its tokens *)
+val wraplexer : (Lexing.lexbuf -> (string * string * 'a * Cabs.cabsloc))
+ -> Lexing.lexbuf -> 'a
+val setFinalWhite : string -> unit
+
+(* print a string, with correct whitespace *)
+val print : string -> unit
+val printl : string list -> unit
+val printu : string -> unit
+val print_maybe : string -> unit
+
+val printEOF : unit -> unit
+
+(* look for whitespace around here *)
+val setLoc : Cabs.cabsloc -> unit
+
+(* where we write the file to *)
+val setOutput : out_channel -> unit
+
+(* is whitespace tracking enabled *)
+val enabled : bool ref
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(* libmaincil *)
+(* this is a replacement for maincil.ml, for the case when we're
+ * creating a C-callable library (libcil.a); all it does is register
+ * a couple of functions and initialize CIL *)
+
+
+module E = Errormsg
+
+open Cil
+
+
+(* print a Cil 'file' to stdout *)
+let unparseToStdout (cil : file) : unit =
+begin
+ dumpFile defaultCilPrinter stdout cil
+end;;
+
+(* a visitor to unroll all types - may need to do some magic to keep attributes *)
+class unrollVisitorClass = object (self)
+ inherit nopCilVisitor
+
+ (* variable declaration *)
+ 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 =
+ begin
+ match g with
+ GCompTag(ci, loc) as g ->
+ let doFieldinfo (fi : fieldinfo) : unit =
+ fi.ftype <- unrollTypeDeep fi.ftype
+ in begin
+ ignore(List.map doFieldinfo ci.cfields);
+ (*ChangeTo [g]*)
+ SkipChildren
+ end
+ | _ -> DoChildren
+ end
+end;;
+
+
+let unrollVisitor = new unrollVisitorClass;;
+
+(* open and parse a C file into a Cil 'file', unroll all typedefs *)
+let parseOneFile (fname: string) : file =
+ let ast : file = Frontc.parse fname () in
+ begin
+ visitCilFile unrollVisitor ast;
+ ast
+ end
+;;
+
+let getDummyTypes () : typ * typ =
+ ( TPtr(TVoid [], []), TInt(IInt, []) )
+;;
+
+(* register some functions - these may be called from C code *)
+Callback.register "cil_parse" parseOneFile;
+Callback.register "cil_unparse" unparseToStdout;
+(* Callback.register "unroll_type_deep" unrollTypeDeep; *)
+Callback.register "get_dummy_types" getDummyTypes;
+
+(* initalize CIL *)
+initCIL ();
+
+
--- /dev/null
+/*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ */
+
+#include "../config.h"
+
+#include <stdio.h>
+
+#ifdef HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+
+#ifdef HAVE_WCHAR_H
+#include <wchar.h>
+#endif
+
+#ifdef _GNUCC
+#define LONGLONG long long
+#define CONST_STRING_LITERALS "true"
+#define VERSION __VERSION__
+#define VERSION_MAJOR __GNUC__
+#define VERSION_MINOR __GNUC_MINOR__
+#endif
+
+#ifdef _MSVC
+#define LONGLONG __int64
+#define CONST_STRING_LITERALS "false"
+#define VERSION "Microsoft C"
+#define VERSION_MAJOR (_MSC_VER / 100)
+#define VERSION_MINOR (_MSC_VER % 100)
+#endif
+
+/* The type for the machine dependency structure is generated from the
+ Makefile */
+int main() {
+ fprintf(stderr, "Generating machine dependency information for CIL\n");
+
+ printf("(* Generated by code in %s *)\n", __FILE__);
+ printf("\t version_major = %d;\n", VERSION_MAJOR);
+ printf("\t version_minor = %d;\n", VERSION_MINOR);
+ printf("\t version = \"%s\";\n", VERSION);
+ // Size of certain types
+ printf("\t sizeof_short = %d;\n", sizeof(short));
+ printf("\t sizeof_int = %d;\n", sizeof(int));
+ printf("\t sizeof_long = %d;\n", sizeof(long));
+ printf("\t sizeof_longlong = %d;\n", sizeof(LONGLONG));
+ printf("\t sizeof_ptr = %d;\n", sizeof(int *));
+ printf("\t sizeof_enum = %d;\n", sizeof(enum e { ONE, TWO }));
+ printf("\t sizeof_float = %d;\n", sizeof(float));
+ printf("\t sizeof_double = %d;\n", sizeof(double));
+ printf("\t sizeof_longdouble = %d;\n", sizeof(long double));
+ printf("\t sizeof_void = %d;\n", sizeof(void));
+ printf("\t sizeof_fun = %d;\n",
+#ifdef __GNUC__
+ sizeof(main)
+#else
+ 0
+#endif
+ );
+
+ // definition of size_t
+ {
+ printf("\t size_t = \"%s\";\n", TYPE_SIZE_T);
+ printf("\t wchar_t = \"%s\";\n", TYPE_WCHAR_T);
+ }
+
+ // The alignment of a short
+ {
+ struct shortstruct {
+ char c;
+ short s;
+ };
+ printf("\t alignof_short = %d;\n",
+ (int)(&((struct shortstruct*)0)->s));
+ }
+
+ // The alignment of an int
+ {
+ struct intstruct {
+ char c;
+ int i;
+ };
+ printf("\t alignof_int = %d;\n",
+ (int)(&((struct intstruct*)0)->i));
+ }
+
+ // The alignment of a long
+ {
+ struct longstruct {
+ char c;
+ long l;
+ };
+ printf("\t alignof_long = %d;\n",
+ (int)(&((struct longstruct*)0)->l));
+ }
+
+ // The alignment of long long
+ {
+ struct longlong {
+ char c;
+ LONGLONG ll;
+ };
+ printf("\t alignof_longlong = %d;\n",
+ (int)(&((struct longlong*)0)->ll));
+ }
+
+ // The alignment of a ptr
+ {
+ struct ptrstruct {
+ char c;
+ int * p;
+ };
+ printf("\t alignof_ptr = %d;\n",
+ (int)(&((struct ptrstruct*)0)->p));
+ }
+
+ // The alignment of an enum
+ {
+ struct enumstruct {
+ char c;
+ enum e2 { THREE, FOUR, FIVE } e;
+ };
+ printf("\t alignof_enum = %d;\n",
+ (int)(&((struct enumstruct*)0)->e));
+ }
+
+ // The alignment of a float
+ {
+ struct floatstruct {
+ char c;
+ float f;
+ };
+ printf("\t alignof_float = %d;\n",
+ (int)(&((struct floatstruct*)0)->f));
+ }
+
+ // The alignment of double
+ {
+ struct s1 {
+ char c;
+ double d;
+ };
+ printf("\t alignof_double = %d;\n",
+ (int)(&((struct s1*)0)->d));
+ }
+
+ // The alignment of long double
+ {
+ struct s1 {
+ char c;
+ long double ld;
+ };
+ printf("\t alignof_longdouble = %d;\n",
+ (int)(&((struct s1*)0)->ld));
+ }
+
+ printf("\t alignof_str = %d;\n",
+#ifdef __GNUC__
+ __alignof("a string")
+#else
+ 0
+#endif
+ );
+
+ printf("\t alignof_fun = %d;\n",
+#ifdef __GNUC__
+ __alignof(main)
+#else
+ 0
+#endif
+ );
+
+// The alignment of anything with __attribute__((aligned))
+#ifdef __GNUC__
+ {
+ char __attribute__((aligned)) c;
+ long double __attribute__((aligned)) ld;
+ if (__alignof(c) != __alignof(ld)) {
+ fprintf(stderr, "__attribute__((aligned)) has a different effect on different types. alignments may be computed incorrectly.\n");
+ }
+ printf("\t alignof_aligned = %d;\n", __alignof(c));
+ }
+#else
+ printf("\t alignof_aligned = 0;\n");
+#endif
+
+
+ // Whether char is unsigned
+ printf("\t char_is_unsigned = %s;\n",
+ ((char)0xff) > 0 ? "true" : "false");
+
+
+ // Whether string literals contain constant characters
+ puts("\t const_string_literals = " CONST_STRING_LITERALS ";");
+
+
+ // endianity
+ {
+ int e = 0x11223344;
+ printf("\t little_endian = %s;\n",
+ (0x44 == *(char*)&e) ? "true" :
+ ((0x11 == *(char*)&e) ? "false" : (exit(1), "false")));
+ }
+
+ exit(0);
+}
--- /dev/null
+open Machdep
+module R = Str
+module L = List
+module H = Hashtbl
+
+let preparse (s:string) : (string, string list) H.t =
+ let specTable = H.create 32 in
+ let commaRegexp = R.regexp "," in
+ let spaceRegexp = R.regexp "[ \t]+" in
+ let specRegexp = R.regexp "^\\([a-zA-Z_0-9]+\\)[ \t]*=\\(.*\\)$" in
+ let specs = R.split spaceRegexp s in
+ let addSpec spec =
+ if R.string_match specRegexp spec 0 then begin
+ let name = R.matched_group 1 spec in
+ let value = R.matched_group 2 spec in
+ H.add specTable name (R.split commaRegexp value)
+ end
+ else
+ raise (Failure ("invalid specification string " ^ spec))
+ in
+ L.iter addSpec specs;
+ specTable
+
+let errorWrap name f =
+ try
+ f name
+ with Not_found -> raise (Failure (name ^ " not specified"))
+ | _ -> raise (Failure ("invalid format for " ^ name))
+
+let getNthString n specTable name =
+ let l = H.find specTable name in
+ L.nth l n
+
+let getNthInt n specTable name =
+ errorWrap name (fun name -> int_of_string (getNthString n specTable name))
+
+let getNthBool n specTable name =
+ errorWrap name (fun name -> bool_of_string (getNthString n specTable name))
+
+let getBool = getNthBool 0
+let getInt = getNthInt 0
+let getSizeof = getNthInt 0
+let getAlignof = getNthInt 1
+
+let typeLookup (model:mach) (size:int) : string =
+ if size = 1 then
+ "char"
+ else if size = model.sizeof_short then
+ "short"
+ else if size = model.sizeof_int then
+ "int"
+ else if size = model.sizeof_long then
+ "long"
+ else if size = model.sizeof_longlong then
+ "long long"
+ else
+ raise (Failure "invalid type size")
+
+let modelParse (s:string) : mach =
+ let entries =
+ try
+ preparse s
+ with Failure msg -> raise (Failure msg)
+ | _ -> raise (Failure "invalid machine specification")
+ in
+ let premodel = {
+ version_major = 0;
+ version_minor = 0;
+ version = "machine model " ^ s;
+ underscore_name = getBool entries "underscore_name";
+ sizeof_short = getSizeof entries "short";
+ alignof_short = getAlignof entries "short";
+ sizeof_int = getSizeof entries "int";
+ alignof_int = getAlignof entries "int";
+ sizeof_long = getSizeof entries "long";
+ alignof_long = getAlignof entries "long";
+ sizeof_longlong = getSizeof entries "long_long";
+ alignof_longlong = getAlignof entries "long_long";
+ sizeof_ptr = getSizeof entries "pointer";
+ alignof_ptr = getAlignof entries "pointer";
+ sizeof_enum = getSizeof entries "enum";
+ alignof_enum = getAlignof entries "enum";
+ sizeof_float = getSizeof entries "float";
+ alignof_float = getAlignof entries "float";
+ sizeof_double = getSizeof entries "double";
+ alignof_double = getAlignof entries "double";
+ sizeof_longdouble = getSizeof entries "long_double";
+ alignof_longdouble = getAlignof entries "long_double";
+ sizeof_void = getSizeof entries "void";
+ sizeof_fun = getSizeof entries "fun";
+ alignof_fun = getAlignof entries "fun";
+ alignof_str = getInt entries "alignof_string";
+ alignof_aligned = getInt entries "max_alignment";
+ size_t = "";
+ wchar_t = "";
+ char_is_unsigned = getNthBool 0 entries "char_wchar_signed";
+ const_string_literals = getBool entries "const_string_literals";
+ little_endian = not (getBool entries "big_endian");
+ __thread_is_keyword = getBool entries "__thread_is_keyword";
+ __builtin_va_list = getBool entries "__builtin_va_list";
+ } in
+ let size_t_name = typeLookup premodel (getNthInt 1 entries "wchar_size_size") in
+ let wchar_t_name = typeLookup premodel (getNthInt 0 entries "wchar_size_size") in
+ let wchar_t_unsigned =
+ if getNthBool 1 entries "char_wchar_signed" then "" else "unsigned "
+ in {
+ premodel with
+ size_t = size_t_name;
+ wchar_t = wchar_t_unsigned ^ wchar_t_name }
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+
+(* main.ml *)
+(* this module is the program entry point for the 'cilly' program, *)
+(* which reads a C program file, parses it, translates it to the CIL *)
+(* intermediate language, and then renders that back into C *)
+
+module F = Frontc
+module C = Cil
+module CK = Check
+module E = Errormsg
+open Pretty
+
+type outfile =
+ { fname: string;
+ fchan: out_channel }
+let outChannel : outfile option ref = ref None
+let mergedChannel : outfile option ref = ref None
+
+
+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 !Epicenter.doEpicenter) then (
+ (* sm: remove unused temps to cut down on gcc warnings *)
+ (* (Stats.time "usedVar" Rmtmps.removeUnusedTemps cil); *)
+ (* (trace "sm" (dprintf "removing unused temporaries\n")); *)
+ (Rmtmps.removeUnusedTemps cil)
+ );
+ cil
+
+(** These are the statically-configured features. To these we append the
+ * features defined in Feature_config.ml (from Makefile) *)
+
+let makeCFGFeature : C.featureDescr =
+ { C.fd_name = "makeCFG";
+ C.fd_enabled = Cilutil.makeCFG;
+ C.fd_description = "make the program look more like a CFG" ;
+ C.fd_extraopt = [];
+ C.fd_doit = (fun f ->
+ ignore (Partial.calls_end_basic_blocks f) ;
+ ignore (Partial.globally_unique_vids f) ;
+ Cil.iterGlobals f (fun glob -> match glob with
+ Cil.GFun(fd,_) -> Cil.prepareCFG fd ;
+ (* jc: blockinggraph depends on this "true" arg *)
+ ignore (Cil.computeCFGInfo fd true)
+ | _ -> ())
+ );
+ C.fd_post_check = true;
+ }
+
+let features : C.featureDescr list =
+ [ Epicenter.feature;
+ Simplify.feature;
+ Canonicalize.feature;
+ Callgraph.feature;
+ Logwrites.feature;
+ Heapify.feature1;
+ Heapify.feature2;
+ Oneret.feature;
+ makeCFGFeature; (* ww: make CFG *must* come before Partial *)
+ Partial.feature;
+ Simplemem.feature;
+ Sfi.feature;
+ Dataslicing.feature;
+ Logcalls.feature;
+ Ptranal.feature;
+ Liveness.feature;
+ ]
+ @ Feature_config.features
+
+let rec processOneFile (cil: C.file) =
+ begin
+
+ if !Cilutil.doCheck then begin
+ ignore (E.log "First CIL check\n");
+ if not (CK.checkFile [] cil) && !Cilutil.strictChecking then begin
+ E.bug ("CIL's internal data structures are inconsistent "
+ ^^"(see the warnings above). This may be a bug "
+ ^^"in CIL.\n")
+ end
+ end;
+
+ (* Scan all the features configured from the Makefile and, if they are
+ * enabled then run them on the current file *)
+ List.iter
+ (fun fdesc ->
+ if ! (fdesc.C.fd_enabled) then begin
+ if !E.verboseFlag then
+ ignore (E.log "Running CIL feature %s (%s)\n"
+ fdesc.C.fd_name fdesc.C.fd_description);
+ (* Run the feature, and see how long it takes. *)
+ Stats.time fdesc.C.fd_name
+ fdesc.C.fd_doit cil;
+ (* See if we need to do some checking *)
+ if !Cilutil.doCheck && fdesc.C.fd_post_check then begin
+ ignore (E.log "CIL check after %s\n" fdesc.C.fd_name);
+ if not (CK.checkFile [] cil) && !Cilutil.strictChecking then begin
+ E.error ("Feature \"%s\" left CIL's internal data "
+ ^^"structures in an inconsistent state. "
+ ^^"(See the warnings above)\n") fdesc.C.fd_name
+ end
+ end
+ end)
+ features;
+
+
+ (match !outChannel with
+ None -> ()
+ | 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 *****)
+let theMain () =
+ let usageMsg = "Usage: cilly [options] source-files" in
+ (* Processign of output file arguments *)
+ 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)))
+ in
+ let outName = ref "" in
+ (* sm: enabling this by default, since I think usually we
+ * want 'cilly' transformations to preserve annotations; I
+ * can easily add a command-line flag if someone sometimes
+ * wants these suppressed *)
+ C.print_CIL_Input := true;
+
+ (*********** COMMAND LINE ARGUMENTS *****************)
+ (* Construct the arguments for the features configured from the Makefile *)
+ let blankLine = ("", Arg.Unit (fun _ -> ()), "") in
+ let featureArgs =
+ List.fold_right
+ (fun fdesc acc ->
+ if !(fdesc.C.fd_enabled) then
+ (* The feature is enabled by default *)
+ blankLine ::
+ ("--dont" ^ fdesc.C.fd_name, Arg.Clear(fdesc.C.fd_enabled),
+ " Disable " ^ fdesc.C.fd_description) ::
+ fdesc.C.fd_extraopt @ acc
+ else
+ (* Disabled by default *)
+ blankLine ::
+ ("--do" ^ fdesc.C.fd_name, Arg.Set(fdesc.C.fd_enabled),
+ " Enable " ^ fdesc.C.fd_description) ::
+ fdesc.C.fd_extraopt @ acc
+ )
+ features
+ [blankLine]
+ in
+ let featureArgs =
+ ("", Arg.Unit (fun () -> ()), " \n\t\tCIL Features") :: featureArgs
+ in
+
+ 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"
+ (fun oc -> mergedChannel := Some oc)),
+ " specify the name of the merged file";
+ ]
+ @ F.args @ featureArgs in
+ begin
+ (* this point in the code is the program entry point *)
+
+ Stats.reset Stats.HardwareIfAvail;
+
+ (* parse the command-line arguments *)
+ Arg.parse (Arg.align argDescr) Ciloptions.recordFile usageMsg;
+ Cil.initCIL ();
+
+ Ciloptions.fileNames := List.rev !Ciloptions.fileNames;
+
+ if !Cilutil.testcil <> "" then begin
+ Testcil.doit !Cilutil.testcil
+ end else
+ (* parse each of the files named on the command line, to CIL *)
+ let files = List.map parseOneFile !Ciloptions.fileNames in
+
+ (* if there's more than one source file, merge them together; *)
+ (* now we have just one CIL "file" to deal with *)
+ let one =
+ match files with
+ [one] -> one
+ | [] -> E.s (E.error "No arguments for CIL\n")
+ | _ ->
+ let merged =
+ Stats.time "merge" (Mergecil.merge files)
+ (if !outName = "" then "stdout" else !outName) in
+ if !E.hadErrors then
+ E.s (E.error "There were errors during merging\n");
+ (* See if we must save the merged file *)
+ (match !mergedChannel with
+ None -> ()
+ | Some mc -> begin
+ let oldpci = !C.print_CIL_Input in
+ C.print_CIL_Input := true;
+ Stats.time "printMerged"
+ (C.dumpFile !C.printerForMaincil mc.fchan mc.fname) merged;
+ C.print_CIL_Input := oldpci
+ end);
+ merged
+ in
+
+ if !E.hadErrors then
+ E.s (E.error "Cabs2cil had some errors");
+
+ (* process the CIL file (merged if necessary) *)
+ processOneFile one
+ end
+;;
+ (* Define a wrapper for main to
+ * intercept the exit *)
+let failed = ref false
+
+let cleanup () =
+ if !E.verboseFlag || !Cilutil.printStats then
+ Stats.print stderr "Timings:\n";
+ if !E.logChannel != stderr then
+ close_out (! E.logChannel);
+ (match ! outChannel with Some c -> close_out c.fchan | _ -> ())
+
+
+(* Without this handler, cilly.asm.exe will quit silently with return code 0
+ when a segfault happens. *)
+let handleSEGV code =
+ if !Cil.currentLoc == Cil.locUnknown then
+ E.log "**** Segmentation fault (possibly a stack overflow)\n"
+ else begin
+ E.log ("**** Segmentation fault (possibly a stack overflow) "^^
+ "while processing %a\n")
+ Cil.d_loc !Cil.currentLoc
+ end;
+ exit code
+
+let _ = Sys.set_signal Sys.sigsegv (Sys.Signal_handle handleSEGV);
+
+;;
+
+begin
+ try
+ theMain ();
+ with F.CabsOnly -> (* this is OK *) ()
+end;
+cleanup ();
+exit (if !failed then 1 else 0)
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(* mergecil.ml *)
+(* This module is responsible for merging multiple CIL source trees into
+ * a single, coherent CIL tree which contains the union of all the
+ * definitions in the source files. It effectively acts like a linker,
+ * but at the source code level instead of the object code level. *)
+
+
+module P = Pretty
+open Cil
+module E = Errormsg
+module H = Hashtbl
+module A = Alpha
+open Trace
+
+let debugMerge = false
+let debugInlines = false
+
+let ignore_merge_conflicts = ref false
+
+(* Try to merge structure with the same name. However, do not complain if
+ * they are not the same *)
+let mergeSynonyms = true
+
+
+(** Whether to use path compression *)
+let usePathCompression = 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
+ * merger an order of magnitude !!! *)
+let mergeInlines = true
+
+let mergeInlinesRepeat = mergeInlines && true
+
+let mergeInlinesWithAlphaConvert = mergeInlines && true
+
+(* when true, merge duplicate definitions of externally-visible functions;
+ * this uses a mechanism which is faster than the one for inline functions,
+ * but only probabilistically accurate *)
+let mergeGlobals = true
+
+
+(* Return true if 's' starts with the prefix 'p' *)
+let prefix p s =
+ let lp = String.length p in
+ let ls = String.length s in
+ lp <= ls && String.sub s 0 lp = p
+
+
+
+(* 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 =
+ { 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.
+ * 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
+ * representative. *)
+ 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
+ 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) =
+ let res = { nname = name; nfidx = fidx; ndata = data; nloc = l;
+ nrep = Obj.magic 1; nmergedSyns = false; } in
+ res.nrep <- res; (* Make the self cycle *)
+ H.add eq (fidx, name) res; (* Add it to the proper table *)
+ 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) =
+ if debugFind then
+ ignore (E.log " find %s(%d)\n" nd.nname nd.nfidx);
+ if nd.nrep == nd then begin
+ if debugFind then
+ ignore (E.log " = %s(%d)\n" nd.nname nd.nfidx);
+ nd
+ end else begin
+ let res = find pathcomp nd.nrep in
+ if usePathCompression && pathcomp && nd.nrep != res then
+ nd.nrep <- res; (* Compress the paths *)
+ res
+ end
+
+
+(* Union two nodes and return the new representative. We prefer as the
+ * representative a node defined earlier. We try not to use as
+ * representatives nodes that are not defined in their files. We return a
+ * function for undoing the union. Make sure that between the union and the
+ * undo you do not do path compression *)
+let union (nd1: '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
+ if nd1 == nd2 then begin
+ (* It can happen that we are trying to union two nodes that are already
+ * equivalent. This is because between the time we check that two nodes
+ * are not already equivalent and the time we invoke the union operation
+ * we check type isomorphism which might change the equivalence classes *)
+(*
+ ignore (warn "unioning already equivalent nodes for %s(%d)"
+ nd1.nname nd1.nfidx);
+*)
+ nd1, fun x -> x
+ end else begin
+ let rep, norep = (* Choose the representative *)
+ if (nd1.nloc != None) = (nd2.nloc != None) then
+ (* They have the same defined status. Choose the earliest *)
+ if nd1.nfidx < nd2.nfidx then nd1, nd2
+ else if nd1.nfidx > nd2.nfidx then nd2, nd1
+ else (* In the same file. Choose the one with the earliest index *) begin
+ match nd1.nloc, nd2.nloc with
+ Some (_, didx1), Some (_, didx2) ->
+ if didx1 < didx2 then nd1, nd2 else
+ if didx1 > didx2 then nd2, nd1
+ else begin
+ 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
+ * not happen though. *)
+ (* sm: it does happen quite a bit when, e.g. merging STLport with
+ * some client source; I'm disabling the warning since it supposedly
+ * is harmless anyway, so is useless noise *)
+ (* sm: re-enabling on claim it now will probably not happen *)
+ ignore (warn "Merging two undefined elements in the same file: %s and %s\n" nd1.nname nd2.nname);
+ nd1, nd2
+ end
+ else (* One is defined, the other is not. Choose the defined one *)
+ if nd1.nloc != None then nd1, nd2 else nd2, nd1
+ in
+ let oldrep = norep.nrep in
+ norep.nrep <- rep;
+ rep, (fun () -> norep.nrep <- oldrep)
+ end
+(*
+let 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)"
+ nd1.nname nd1.nfidx);
+ nd1, fun x -> x
+ end else
+ union nd1 nd2
+*)
+(* Find the representative for a node and compress the paths in the process *)
+let findReplacement
+ (pathcomp: bool)
+ (eq: (int * string, 'a node) H.t)
+ (fidx: int)
+ (name: string) : ('a * int) option =
+ 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
+ ignore (E.log " is a representative\n");
+ None (* No replacement if this is the representative of its class *)
+ end else
+ let rep = find pathcomp nd in
+ if rep != rep.nrep then
+ E.s (bug "find does not return the representative\n");
+ 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
+ ignore (E.log " not found in the map\n");
+ None
+ end
+
+(* 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) =
+ let debugGetNode = false in
+ 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
+ (* 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
+ 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
+ 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
+ ignore (E.log " made a new one\n");
+ res
+ end
+
+
+
+(* Dump a graph *)
+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-> "
+ name fidx (if nd.nloc = None then "(undef)" else ""));
+ if nd.nrep == nd then
+ ignore (E.log "*\n")
+ else
+ ignore (E.log " %s(%d)\n" nd.nrep.nname nd.nrep.nfidx ))
+ eq
+
+
+
+
+(* For each name space we define a set of equivalence classes *)
+let vEq: (int * string, varinfo node) H.t = H.create 111 (* Vars *)
+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.
+ * 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 *)
+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
+ * variables, indexed by their name. *)
+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
+ * variables and types. *)
+let vtAlpha : (string, location A.alphaTableData ref) H.t
+ = H.create 57 (* Variables and
+ * types *)
+let sAlpha : (string, location A.alphaTableData ref) H.t
+ = H.create 57 (* Structures and
+ * unions have
+ * the same name
+ * space *)
+let eAlpha : (string, location A.alphaTableData ref) H.t
+ = H.create 57 (* Enumerations *)
+
+
+(** Keep track, for all global function definitions, of the names of the formal
+ * arguments. They might change during merging of function types if the
+ * prototype occurs after the function definition and uses different names.
+ * We'll restore the names at the end *)
+let formalNames: (int * string, string list) H.t = H.create 111
+
+
+(* Accumulate here the globals in the merged file *)
+let theFileTypes = ref []
+let theFile = ref []
+
+(* add 'g' to the merged file *)
+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
+ * sure you count the same things in both passes. *)
+(* Keep here the file names *)
+let fileNames : (int, string) H.t = H.create 113
+
+
+
+(* Remember the composite types that we have already declared *)
+let emittedCompDecls: (string, bool) H.t = H.create 113
+(* Remember the variables also *)
+let emittedVarDecls: (string, bool) H.t = H.create 113
+
+(* also keep track of externally-visible function definitions;
+ * name maps to declaration, location, and semantic checksum *)
+let emittedFunDefn: (string, fundec * location * int) H.t = H.create 113
+(* and same for variable definitions; name maps to GVar fields *)
+let emittedVarDefn: (string, varinfo * init option * location) H.t = H.create 113
+
+(** A mapping from the new names to the original names. Used in PASS2 when we
+ * rename variables. *)
+let originalVarNames: (string, string) H.t = H.create 113
+
+(* Initialize the module *)
+let init () =
+ H.clear sAlpha;
+ H.clear eAlpha;
+ H.clear vtAlpha;
+
+ H.clear vEnv;
+
+ H.clear vEq;
+ H.clear sEq;
+ H.clear eEq;
+ H.clear tEq;
+ H.clear iEq;
+
+ H.clear vSyn;
+ H.clear sSyn;
+ H.clear eSyn;
+ H.clear tSyn;
+ H.clear iSyn;
+
+ theFile := [];
+ theFileTypes := [];
+
+ H.clear formalNames;
+ H.clear inlineBodies;
+
+ currentFidx := 0;
+ currentDeclIdx := 0;
+ H.clear fileNames;
+
+ H.clear emittedVarDecls;
+ H.clear emittedCompDecls;
+
+ H.clear emittedFunDefn;
+ H.clear emittedVarDefn;
+
+ H.clear originalVarNames
+
+
+(* Some enumerations have to be turned into an integer. We implement this by
+ * introducing a special enumeration type which we'll recognize later to be
+ * an integer *)
+let intEnumInfo =
+ { ename = "!!!intEnumInfo!!!"; (* This is otherwise invalid *)
+ eitems = [];
+ eattr = [];
+ ereferenced = false;
+ }
+(* And add it to the equivalence graph *)
+let intEnumInfoNode =
+ getNode eEq eSyn 0 intEnumInfo.ename intEnumInfo
+ (Some (locUnknown, 0))
+
+ (* Combine the types. Raises the Failure exception with an error message.
+ * isdef says whether the new type is for a definition *)
+type combineWhat =
+ CombineFundef (* The new definition is for a function definition. The old
+ * is for a prototype *)
+ | CombineFunarg (* Comparing a function argument type with an old prototype
+ * arg *)
+ | CombineFunret (* Comparing the return of a function with that from an old
+ * prototype *)
+ | CombineOther
+
+
+let rec combineTypes (what: combineWhat)
+ (oldfidx: int) (oldt: typ)
+ (fidx: int) (t: typ) : typ =
+ match oldt, t with
+ | TVoid olda, TVoid a -> TVoid (addAttributes olda a)
+ | TInt (oldik, olda), TInt (ik, a) ->
+ let combineIK oldk k =
+ if oldk == k then oldk else
+ (* 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
+ k
+ else (
+ let msg =
+ P.sprint ~width:80
+ (P.dprintf
+ "(different integer types %a and %a)"
+ d_type oldt d_type t) in
+ raise (Failure msg)
+ )
+ in
+ TInt (combineIK oldik ik, addAttributes olda a)
+
+ | 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
+ * type than a prototype that says "double" *)
+ 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, addAttributes olda a)
+
+ | TEnum (oldei, olda), TEnum (ei, a) ->
+ (* Matching enumerations always succeeds. But sometimes it maps both
+ * enumerations to integers *)
+ matchEnumInfo oldfidx oldei fidx ei;
+ TEnum (oldei, addAttributes olda a)
+
+
+ (* Strange one. But seems to be handled by GCC *)
+ | TEnum (oldei, olda) , TInt(IInt, a) -> TEnum(oldei,
+ addAttributes olda a)
+
+ (* Strange one. But seems to be handled by GCC. Warning. Here we are
+ * leaking types from new to old *)
+ | TInt(IInt, olda), TEnum (ei, a) -> TEnum(ei, addAttributes olda a)
+
+ | TComp (oldci, olda) , TComp (ci, a) ->
+ matchCompInfo oldfidx oldci fidx ci;
+ (* If we get here we were successful *)
+ TComp (oldci, addAttributes olda a)
+
+ | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) ->
+ let combbt = combineTypes CombineOther oldfidx oldbt fidx bt in
+ let combinesz =
+ match oldsz, sz with
+ None, Some _ -> sz
+ | Some _, None -> oldsz
+ | None, None -> oldsz
+ | Some oldsz', Some sz' ->
+ let samesz =
+ match constFold true oldsz', constFold true sz' with
+ Const(CInt64(oldi, _, _)), Const(CInt64(i, _, _)) -> oldi = i
+ | _, _ -> false
+ in
+ if samesz then oldsz else
+ 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,
+ addAttributes olda a)
+
+ (* WARNING: In this case we are leaking types from new to old !! *)
+ | TFun (_, _, _, [Attr("missingproto",_)]), TFun _ -> t
+
+
+ | 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
+ in
+ if oldva != va then
+ raise (Failure "(diferent vararg specifiers)");
+ (* If one does not have arguments, believe the one with the
+ * arguments *)
+ let newargs =
+ if oldargs = None then args else
+ if args = None then oldargs else
+ let oldargslist = argsToList oldargs in
+ let argslist = argsToList args in
+ if List.length oldargslist <> List.length argslist then
+ raise (Failure "(different number of arguments)")
+ else begin
+ (* Go over the arguments and update the old ones with the
+ * adjusted types *)
+ Some
+ (List.map2
+ (fun (on, ot, oa) (an, at, aa) ->
+ let n = if an <> "" then an else on in
+ let t =
+ combineTypes
+ (if what = CombineFundef then
+ CombineFunarg else CombineOther)
+ oldfidx ot fidx at
+ in
+ let a = addAttributes oa aa in
+ (n, t, a))
+ oldargslist argslist)
+ end
+ in
+ TFun (newrt, newargs, oldva, addAttributes olda a)
+
+ | TBuiltin_va_list olda, TBuiltin_va_list a ->
+ TBuiltin_va_list (addAttributes olda a)
+
+ | TNamed (oldt, olda), TNamed (t, a) ->
+ matchTypeInfo oldfidx oldt fidx t;
+ (* If we get here we were able to match *)
+ TNamed(oldt, addAttributes olda a)
+
+ (* Unroll first the new type *)
+ | _, TNamed (t, a) ->
+ let res = combineTypes what oldfidx oldt fidx t.ttype in
+ typeAddAttributes a res
+
+ (* And unroll the old type as well if necessary *)
+ | TNamed (oldt, a), _ ->
+ let res = combineTypes what oldfidx oldt.ttype fidx t in
+ typeAddAttributes a res
+
+ | _ -> (
+ (* raise (Failure "(different type constructors)") *)
+ let msg:string = (P.sprint 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
+ raise (Failure "(different struct/union types)");
+ (* See if we have a mapping already *)
+ (* Make the nodes if not already made. Actually return the
+ * representatives *)
+ let oldcinode = getNode sEq sSyn oldfidx oldci.cname oldci 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
+ (* Replace with the representative data *)
+ let oldci = oldcinode.ndata in
+ let oldfidx = oldcinode.nfidx in
+ let ci = cinode.ndata in
+ let fidx = cinode.nfidx in
+
+ let old_len = List.length oldci.cfields in
+ let len = List.length ci.cfields in
+ (* It is easy to catch here the case when the new structure is undefined
+ * and the old one was defined. We just reuse the old *)
+ (* More complicated is the case when the old one is not defined but the
+ * new one is. We still reuse the old one and we'll take care of defining
+ * it later with the new fields.
+ * GN: 7/10/04, I could not find when is "later", so I added it below *)
+ if len <> 0 && old_len <> 0 && old_len <> len then (
+ 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.)"
+ 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
+ * loop. So we add the assumption that they are equal *)
+ let newrep, undo = union oldcinode cinode in
+ (* We check the fields but watch for Failure. We only do the check when
+ * the lengths are the same. Due to the code above this the other
+ * possibility is that one of the length is 0, in which case we reuse the
+ * old compinfo. *)
+ (* But what if the old one is the empty one ? *)
+ if old_len = len then begin
+ (try
+ List.iter2
+ (fun oldf f ->
+ if oldf.fbitfield <> f.fbitfield then
+ raise (Failure "(different bitfield info)");
+ if oldf.fattr <> f.fattr then
+ raise (Failure "(different field attributes)");
+ (* Make sure the types are compatible *)
+ let newtype =
+ combineTypes CombineOther oldfidx oldf.ftype fidx f.ftype
+ in
+ (* Change the type in the representative *)
+ oldf.ftype <- newtype;
+ )
+ oldci.cfields ci.cfields
+ with Failure reason -> begin
+ (* Our assumption was wrong. Forget the isomorphism *)
+ undo ();
+ 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
+ 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
+ * all sorts of undefined types??? *)
+ if old_len = 0 then
+ oldci.cfields <- ci.cfields;
+ end;
+ (* We get here when we succeeded checking that they are equal, or one of
+ * them was empty *)
+ newrep.ndata.cattr <- addAttributes oldci.cattr ci.cattr;
+ ()
+ end
+
+(* Match two enuminfos and throw a Failure if they do not match *)
+and matchEnumInfo (oldfidx: int) (oldei: enuminfo)
+ (fidx: int) (ei: enuminfo) : unit =
+ (* Find the node for this enum, no path compression. *)
+ let oldeinode = getNode eEq eSyn oldfidx oldei.ename oldei None in
+ let einode = getNode eEq eSyn fidx ei.ename ei None in
+ if oldeinode == einode then (* We already know they are the same *)
+ ()
+ else begin
+ (* Replace with the representative data *)
+ let oldei = oldeinode.ndata in
+ let ei = einode.ndata in
+ (* Try to match them. But if you cannot just make them both integers *)
+ try
+ (* We do not have a mapping. They better be defined in the same way *)
+ if List.length oldei.eitems <> List.length ei.eitems then
+ raise (Failure "(different number of enumeration elements)");
+ (* We check that they are defined in the same way. This is a fairly
+ * conservative check. *)
+ List.iter2
+ (fun (old_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
+ Const(CInt64(oldi, _, _)), Const(CInt64(i, _, _)) -> oldi = i
+ | _ -> false
+ in
+ if not samev then
+ raise (Failure "(different values for enumeration items)"))
+ oldei.eitems ei.eitems;
+ (* Set the representative *)
+ let newrep, _ = union oldeinode einode in
+ (* We get here if the enumerations match *)
+ newrep.ndata.eattr <- addAttributes oldei.eattr ei.eattr;
+ ()
+ with Failure msg -> begin
+ (* Get here if you cannot merge two enumeration nodes *)
+ if oldeinode != intEnumInfoNode then begin
+ let _ = union oldeinode intEnumInfoNode in ()
+ end;
+ if einode != intEnumInfoNode then begin
+ let _ = union einode intEnumInfoNode in ()
+ end;
+ end
+ end
+
+
+(* Match two typeinfos and throw a Failure if they do not match *)
+and matchTypeInfo (oldfidx: int) (oldti: typeinfo)
+ (fidx: int) (ti: typeinfo) : unit =
+ if oldti.tname = "" || ti.tname = "" then
+ 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
+ let tnode = getNode tEq tSyn fidx ti.tname ti None in
+ if oldtnode == tnode then (* We already know they are the same *)
+ ()
+ else begin
+ (* Replace with the representative data *)
+ let oldti = oldtnode.ndata in
+ let oldfidx = oldtnode.nfidx in
+ let ti = tnode.ndata in
+ let fidx = tnode.nfidx in
+ (* Check that they are the same *)
+ (try
+ ignore (combineTypes CombineOther oldfidx oldti.ttype fidx ti.ttype);
+ with Failure reason -> begin
+ let msg =
+ P.sprint ~width:80
+ (P.dprintf
+ "\n\tFailed assumption that %s and %s are isomorphic %s"
+ oldti.tname ti.tname reason) in
+ raise (Failure msg)
+ end);
+ let _ = union oldtnode tnode in
+ ()
+ end
+
+(* Scan all files and do two things *)
+(* 1. Initialize the alpha renaming tables with the names of the globals so
+ * that when we come in the second pass to generate new names, we do not run
+ * into conflicts. *)
+(* 2. For all declarations of globals unify their types. In the process
+ * construct a set of equivalence classes on type names, structure and
+ * enumeration tags *)
+(* 3. We clean the referenced flags *)
+
+let rec oneFilePass1 (f:file) : unit =
+ H.add fileNames !currentFidx f.fileName;
+ 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
+ * *)
+ let matchVarinfo (vi: varinfo) (l: location * int) =
+ ignore (Alpha.registerAlphaName vtAlpha None vi.vname !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, _ =
+ 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
+ * because it might fail *)
+ let newtype =
+ try
+ 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 "
+ vi.vname (H.find fileNames !currentFidx) !currentFidx
+ 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
+ * others declare it as "const". *)
+ if hasAttribute "const" (typeAttrs vi.vtype) !=
+ hasAttribute "const" (typeAttrs oldvi.vtype) then begin
+ newrep.ndata.vtype <- typeRemoveAttributes ["const"] newtype;
+ end else 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
+ * functions *)
+ 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
+ d_loc oldloc);
+ vi.vstorage
+ end
+ in
+ newrep.ndata.vstorage <- newstorage;
+ newrep.ndata.vattr <- addAttributes oldvi.vattr vi.vattr;
+ ()
+ with Not_found -> (* Not present in the previous files. Remember it for
+ * later *)
+ H.add vEnv vi.vname vinode
+
+ in
+ List.iter
+ (function
+ | GVarDecl (vi, l) | GVar (vi, _, l) ->
+ currentLoc := l;
+ incr currentDeclIdx;
+ vi.vreferenced <- false;
+ if vi.vstorage <> Static then begin
+ matchVarinfo vi (l, !currentDeclIdx);
+ end
+
+ | 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)
+ (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,
+ * unless specified to be static. *)
+ (*
+ if fdec.svar.vinline && fdec.svar.vstorage = NoStorage then
+ fdec.svar.vstorage <- Static;
+ *)
+ if fdec.svar.vstorage <> Static then begin
+ matchVarinfo fdec.svar (l, !currentDeclIdx)
+ end else begin
+ if fdec.svar.vinline && mergeInlines then
+ (* Just create the nodes for inline functions *)
+ ignore (getNode iEq iSyn !currentFidx
+ fdec.svar.vname fdec.svar (Some (l, !currentDeclIdx)))
+ end
+ (* Make nodes for the defined type and structure tags *)
+ | GType (t, l) ->
+ incr currentDeclIdx;
+ t.treferenced <- false;
+ if t.tname <> "" then (* The empty names are just for introducing
+ * undefined comp tags *)
+ ignore (getNode tEq tSyn !currentFidx t.tname t
+ (Some (l, !currentDeclIdx)))
+ else begin (* Go inside and clean the referenced flag for the
+ * declared tags *)
+ match t.ttype with
+ TComp (ci, _) ->
+ ci.creferenced <- false;
+ (* Create a node for it *)
+ ignore (getNode sEq sSyn !currentFidx ci.cname ci None)
+
+ | 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) ->
+ incr currentDeclIdx;
+ ci.creferenced <- false;
+ ignore (getNode sEq sSyn !currentFidx ci.cname ci
+ (Some (l, !currentDeclIdx)))
+ | GEnumTag (ei, l) ->
+ incr currentDeclIdx;
+ ei.ereferenced <- false;
+ ignore (getNode eEq eSyn !currentFidx ei.ename ei
+ (Some (l, !currentDeclIdx)))
+
+ | _ -> ())
+ f.globals
+
+
+(* Try to merge synonyms. Do not give an error if they fail to merge *)
+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
+ * throws Failure if no match *)
+ : 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
+ * for this name *)
+ (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 ->
+ try
+ compare c.nfidx c.ndata nd.nfidx nd.ndata;
+ (* Success. Stop here the comparison *)
+ c :: restc
+ with Failure _ -> (* Failed. Try next class *)
+ c :: (compareWithClasses restc)
+ in
+ compareWithClasses classes
+ in
+ (* Start with an empty set of classes for this name *)
+ let _ = List.fold_left tryone [] all in
+ ()
+ end)
+ syn
+
+
+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
+ ()
+ 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
+ * because it might fail *)
+ oldi.vtype <-
+ combineTypes CombineOther
+ oldfidx oldi.vtype fidx i.vtype;
+ (* We get here if we have success *)
+ (* Combine the attributes as well *)
+ oldi.vattr <- addAttributes oldi.vattr i.vattr;
+ (* Do not union them yet because we do not know that they are the same.
+ * We have checked only the types so far *)
+ ()
+ end
+
+(************************************************************
+ *
+ * PASS 2
+ *
+ *
+ ************************************************************)
+
+(** Keep track of the functions we have used already in the file. We need
+ * this to avoid removing an inline function that has been used already.
+ * This can only occur if the inline function is defined after it is used
+ * already; a bad style anyway *)
+let varUsedAlready: (string, unit) H.t = H.create 111
+
+(** 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
+ * variable. Must do its type and attributes. *)
+ method vvdec (vi: varinfo) = DoChildren
+
+ (* This is a variable use. See if we must change it *)
+ method vvrbl (vi: varinfo) : varinfo visitAction =
+ if not vi.vglob then DoChildren else
+ if vi.vreferenced then begin
+ H.add varUsedAlready vi.vname ();
+ DoChildren
+ end else begin
+ match findReplacement true vEq !currentFidx vi.vname with
+ None -> DoChildren
+ | 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;
+ H.add varUsedAlready vi'.vname ();
+ ChangeTo vi'
+ end
+
+
+ (* The use of a type. Change only those types whose underlying info
+ * is not a root. *)
+ method vtype (t: typ) =
+ match t with
+ TComp (ci, a) when not ci.creferenced -> begin
+ match findReplacement true sEq !currentFidx ci.cname with
+ None -> DoChildren
+ | 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))
+ end
+ | TEnum (ei, a) when not ei.ereferenced -> begin
+ match findReplacement true eEq !currentFidx ei.ename with
+ None -> DoChildren
+ | Some (ei', _) ->
+ if ei' == intEnumInfo then
+ (* This is actually our friend intEnumInfo *)
+ ChangeTo (TInt(IInt, visitCilAttributes (self :> cilVisitor) a))
+ else
+ ChangeTo (TEnum (ei', visitCilAttributes (self :> cilVisitor) a))
+ end
+
+ | TNamed (ti, a) when not ti.treferenced -> begin
+ match findReplacement true tEq !currentFidx ti.tname with
+ None -> DoChildren
+ | 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
+ Field (f, o) -> begin
+ (* See if the compinfo was changed *)
+ if f.fcomp.creferenced then
+ DoChildren
+ else begin
+ match findReplacement true sEq !currentFidx f.fcomp.cname with
+ None -> DoChildren (* We did not replace it *)
+ | Some (ci', oldfidx) -> begin
+ (* First, find out the index of the original field *)
+ let rec indexOf (i: int) = function
+ [] ->
+ 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
+ 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
+ ChangeDoChildrenPost (Field (f', o), fun x -> x)
+ end
+ end
+ end
+ | _ -> DoChildren
+
+ method vinitoffs o =
+ (self#voffs o) (* treat initializer offsets same as lvalue offsets *)
+
+end
+
+let renameVisitor = new renameVisitorClass
+
+
+(** A visitor that renames uses of inline functions that were discovered in
+ * pass 2 to be used before they are defined. This is like the renameVisitor
+ * except it only looks at the variables (thus it is a bit more efficient)
+ * and it also renames forward declarations of the inlines to be removed. *)
+
+class renameInlineVisitorClass = object (self)
+ inherit nopCilVisitor
+
+ (* This is a variable use. See if we must change it *)
+ method vvrbl (vi: varinfo) : varinfo visitAction =
+ if not vi.vglob then DoChildren else
+ if vi.vreferenced then begin (* Already renamed *)
+ DoChildren
+ end else begin
+ match findReplacement true vEq !currentFidx vi.vname with
+ None -> DoChildren
+ | 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;
+ ChangeTo vi'
+ end
+
+ (* And rename some declarations of inlines to remove. We cannot drop this
+ * declaration (see small1/combineinline6) *)
+ method vglob = function
+ GVarDecl(vi, l) when vi.vinline -> begin
+ (* Get the original name *)
+ let origname =
+ try H.find originalVarNames vi.vname
+ with Not_found -> vi.vname
+ in
+ (* Now see if this must be replaced *)
+ match findReplacement true vEq !currentFidx origname with
+ None -> DoChildren
+ | Some (vi', _) -> ChangeTo [GVarDecl (vi', l)]
+ end
+ | _ -> DoChildren
+
+end
+let renameInlinesVisitor = new renameInlineVisitorClass
+
+
+(* sm: First attempt at a semantic checksum for function bodies.
+ * Ideally, two function's checksums would be equal only when their
+ * bodies were provably equivalent; but I'm using a much simpler and
+ * less accurate heuristic here. It should be good enough for the
+ * purpose I have in mind, which is doing duplicate removal of
+ * multiply-instantiated template functions. *)
+let functionChecksum (dec: fundec) : int =
+begin
+ (* checksum the structure of the statements (only) *)
+ let rec stmtListSum (lst : stmt list) : int =
+ (List.fold_left (fun acc s -> acc + (stmtSum s)) 0 lst)
+ and stmtSum (s: stmt) : int =
+ (* strategy is to just throw a lot of prime numbers into the
+ * computation in hopes of avoiding accidental collision.. *)
+ match s.skind with
+ | Instr(l) -> 13 + 67*(List.length l)
+ | Return(_) -> 17
+ | Goto(_) -> 19
+ | Break(_) -> 23
+ | Continue(_) -> 29
+ | If(_,b1,b2,_) -> 31 + 37*(stmtListSum b1.bstmts)
+ + 41*(stmtListSum b2.bstmts)
+ | Switch(_,b,_,_) -> 43 + 47*(stmtListSum b.bstmts)
+ (* don't look at stmt list b/c is not part of tree *)
+ | Loop(b,_,_,_) -> 49 + 53*(stmtListSum b.bstmts)
+ | Block(b) -> 59 + 61*(stmtListSum b.bstmts)
+ | TryExcept (b, (il, e), h, _) ->
+ 67 + 83*(stmtListSum b.bstmts) + 97*(stmtListSum h.bstmts)
+ | TryFinally (b, h, _) ->
+ 103 + 113*(stmtListSum b.bstmts) + 119*(stmtListSum h.bstmts)
+ in
+
+ (* disabled 2nd and 3rd measure because they appear to get different
+ * values, for the same code, depending on whether the code was just
+ * parsed into CIL or had previously been parsed into CIL, printed
+ * out, then re-parsed into CIL *)
+ let a,b,c,d,e =
+ (List.length dec.sformals), (* # formals *)
+ 0 (*(List.length dec.slocals)*), (* # locals *)
+ 0 (*dec.smaxid*), (* estimate of internal statement count *)
+ (List.length dec.sbody.bstmts), (* number of statements at outer level *)
+ (stmtListSum dec.sbody.bstmts) in (* checksum of statement structure *)
+ (*(trace "sm" (P.dprintf "sum: %s is %d %d %d %d %d\n"*)
+ (* dec.svar.vname a b c d e));*)
+ 2*a + 3*b + 5*c + 7*d + 11*e
+end
+
+
+(* sm: equality for initializers, etc.; this is like '=', except
+ * when we reach shared pieces (like references into the type
+ * structure), we use '==', to prevent circularity *)
+(* update: that's no good; I'm using this to find things which
+ * are equal but from different CIL trees, so nothing will ever
+ * be '=='.. as a hack I'll just change those places to 'true',
+ * so these functions are not now checking proper equality..
+ * places where equality is not complete are marked "INC" *)
+let rec equalInits (x: init) (y: init) : bool =
+begin
+ match x,y with
+ | SingleInit(xe), SingleInit(ye) -> (equalExps xe ye)
+ | CompoundInit(xt, xoil), CompoundInit(yt, yoil) ->
+ (*(xt == yt) &&*) (* INC *) (* types need to be identically equal *)
+ let rec equalLists xoil yoil : bool =
+ match xoil,yoil with
+ | ((xo,xi) :: xrest), ((yo,yi) :: yrest) ->
+ (equalOffsets xo yo) &&
+ (equalInits xi yi) &&
+ (equalLists xrest yrest)
+ | [], [] -> true
+ | _, _ -> false
+ in
+ (equalLists xoil yoil)
+ | _, _ -> false
+end
+
+and equalOffsets (x: offset) (y: offset) : bool =
+begin
+ match x,y with
+ | NoOffset, NoOffset -> true
+ | Field(xfi,xo), Field(yfi,yo) ->
+ (xfi.fname = yfi.fname) && (* INC: same fieldinfo name.. *)
+ (equalOffsets xo yo)
+ | Index(xe,xo), Index(ye,yo) ->
+ (equalExps xe ye) &&
+ (equalOffsets xo yo)
+ | _,_ -> false
+end
+
+and equalExps (x: exp) (y: exp) : bool =
+begin
+ match x,y with
+ | Const(xc), Const(yc) -> xc = yc || (* safe to use '=' on literals *)
+ (
+ (* CIL changes (unsigned)0 into 0U during printing.. *)
+ match xc,yc with
+ | CInt64(0L,_,_),CInt64(0L,_,_) -> true (* ok if they're both 0 *)
+ | _,_ -> false
+ )
+ | Lval(xl), Lval(yl) -> (equalLvals xl yl)
+ | SizeOf(xt), SizeOf(yt) -> true (*INC: xt == yt*) (* identical types *)
+ | SizeOfE(xe), SizeOfE(ye) -> (equalExps xe ye)
+ | AlignOf(xt), AlignOf(yt) -> true (*INC: xt == yt*)
+ | AlignOfE(xe), AlignOfE(ye) -> (equalExps xe ye)
+ | UnOp(xop,xe,xt), UnOp(yop,ye,yt) ->
+ xop = yop &&
+ (equalExps xe ye) &&
+ true (*INC: xt == yt*)
+ | BinOp(xop,xe1,xe2,xt), BinOp(yop,ye1,ye2,yt) ->
+ xop = yop &&
+ (equalExps xe1 ye1) &&
+ (equalExps xe2 ye2) &&
+ true (*INC: xt == yt*)
+ | CastE(xt,xe), CastE(yt,ye) ->
+ (*INC: xt == yt &&*)
+ (equalExps xe ye)
+ | AddrOf(xl), AddrOf(yl) -> (equalLvals xl yl)
+ | StartOf(xl), StartOf(yl) -> (equalLvals xl yl)
+
+ (* initializers that go through CIL multiple times sometimes lose casts they
+ * had the first time; so allow a different of a cast *)
+ | CastE(xt,xe), ye ->
+ (equalExps xe ye)
+ | xe, CastE(yt,ye) ->
+ (equalExps xe ye)
+
+ | _,_ -> false
+end
+
+and equalLvals (x: lval) (y: lval) : bool =
+begin
+ match x,y with
+ | (Var(xv),xo), (Var(yv),yo) ->
+ (* I tried, I really did.. the problem is I see these names
+ * before merging collapses them, so __T123 != __T456,
+ * so whatever *)
+ (*(xv.vname = vy.vname) && (* INC: same varinfo names.. *)*)
+ (equalOffsets xo yo)
+
+ | (Mem(xe),xo), (Mem(ye),yo) ->
+ (equalExps xe ye) &&
+ (equalOffsets xo yo)
+ | _,_ -> false
+end
+
+let equalInitOpts (x: init option) (y: init option) : bool =
+begin
+ match x,y with
+ | None,None -> true
+ | Some(xi), Some(yi) -> (equalInits xi yi)
+ | _,_ -> false
+end
+
+
+ (* Now we go once more through the file and we rename the globals that we
+ * keep. We also scan the entire body and we replace references to the
+ * representative types or variables. We set the referenced flags once we
+ * have replaced the names. *)
+let oneFilePass2 (f: file) =
+ 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
+ * 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 =
+ (* Process a varinfo. Reuse an old one, or rename it if necessary *)
+ let processVarinfo (vi: varinfo) (vloc: location) : varinfo =
+ if vi.vreferenced then
+ vi (* Already done *)
+ else begin
+ (* Maybe it is static. Rename it then *)
+ if vi.vstorage = Static then begin
+ let newName, _ = A.newAlphaName vtAlpha None vi.vname !currentLoc in
+ (* Remember the original name *)
+ H.add originalVarNames newName vi.vname;
+ if debugMerge then ignore (E.log "renaming %s at %a to %s\n"
+ vi.vname d_loc vloc newName);
+ vi.vname <- newName;
+ vi.vid <- newVID ();
+ vi.vreferenced <- true;
+ vi
+ end else begin
+ (* Find the representative *)
+ match findReplacement true vEq !currentFidx vi.vname with
+ None -> vi (* This is the representative *)
+ | Some (vi', _) -> (* Reuse some previous one *)
+ vi'.vreferenced <- true; (* Mark it as done already *)
+ vi'.vaddrof <- vi.vaddrof || vi'.vaddrof;
+ vi'
+ end
+ end
+ in
+ try
+ match g with
+ | GVarDecl (vi, l) as g ->
+ currentLoc := l;
+ incr currentDeclIdx;
+ let vi' = processVarinfo vi l in
+ if vi != vi' then (* Drop this declaration *) ()
+ else if H.mem emittedVarDecls vi'.vname then (* No need to keep it *)
+ ()
+ else begin
+ H.add emittedVarDecls vi'.vname true; (* Remember that we emitted
+ * it *)
+ mergePushGlobals (visitCilGlobal renameVisitor g)
+ end
+
+ | GVar (vi, init, l) ->
+ currentLoc := l;
+ incr currentDeclIdx;
+ let vi' = processVarinfo vi l in
+ (* We must keep this definition even if we reuse this varinfo,
+ * because maybe the previous one was a declaration *)
+ H.add emittedVarDecls vi.vname true; (* Remember that we emitted it*)
+
+ let emitIt:bool = (not mergeGlobals) ||
+ try
+ let prevVar, prevInitOpt, prevLoc =
+ (H.find emittedVarDefn vi'.vname) in
+ (* previously defined; same initializer? *)
+ if (equalInitOpts prevInitOpt init.init)
+ || (init.init = None) then (
+ (trace "mergeGlob"
+ (P.dprintf "dropping global var %s at %a in favor of the one at %a\n"
+ vi'.vname d_loc l d_loc prevLoc));
+ false (* do not emit *)
+ )
+ else if prevInitOpt = None then (
+ (* We have an initializer, but the previous one didn't.
+ We should really convert the previous global from GVar
+ to GVarDecl, but that's not convenient to do here. *)
+ true
+ )
+ else (
+ (* Both GVars have initializers. *)
+ (E.s (error "global var %s at %a has different initializer than %a\n"
+ vi'.vname d_loc l d_loc prevLoc));
+ )
+ with Not_found -> (
+ (* no previous definition *)
+ (H.add emittedVarDefn vi'.vname (vi', init.init, l));
+ true (* emit it *)
+ )
+ in
+
+ if emitIt then
+ mergePushGlobals (visitCilGlobal renameVisitor (GVar(vi', init, l)))
+
+ | 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
+ 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'
+ | _ -> 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 =
+ try H.find formalNames (!currentFidx, origname), true
+ with Not_found -> begin
+ ignore (warnOpt "Cannot find %s in formalNames" origname);
+ [], false
+ end
+ in
+ if foundthem then begin
+ let argl = argsToList args in
+ 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)
+ oldnames fdec.sformals;
+ (* Reflect them in the type *)
+ setFormals fdec fdec.sformals
+ end;
+ (** See if we can remove this inline function *)
+ if fdec'.svar.vinline && mergeInlines then begin
+ let printout =
+ (* Temporarily turn of printing of lines *)
+ let oldprintln = !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
+ * names of the local variables and formals in a standard way *)
+ let nameId = ref 0 in
+ let oldNames : string list ref = ref [] in
+ let renameOne (v: varinfo) =
+ oldNames := v.vname :: !oldNames;
+ incr nameId;
+ v.vname <- "___alpha" ^ string_of_int !nameId
+ in
+ let undoRenameOne (v: varinfo) =
+ match !oldNames with
+ n :: rest ->
+ oldNames := rest;
+ v.vname <- n
+ | _ -> E.s (bug "undoRenameOne")
+ in
+ (* Remember the original type *)
+ let origType = fdec'.svar.vtype in
+ if mergeInlinesWithAlphaConvert then begin
+ (* Rename the formals *)
+ List.iter renameOne fdec'.sformals;
+ (* Reflect in the type *)
+ setFormals fdec' fdec'.sformals;
+ (* Now do the locals *)
+ List.iter renameOne fdec'.slocals
+ end;
+ (* Now print it *)
+ let res = d_global () g' in
+ lineDirectiveStyle := oldprintln;
+ fdec'.svar.vname <- newname;
+ if mergeInlinesWithAlphaConvert then begin
+ (* Do the locals in reverse order *)
+ List.iter undoRenameOne (List.rev fdec'.slocals);
+ (* Do the formals in reverse order *)
+ List.iter undoRenameOne (List.rev fdec'.sformals);
+ (* Restore the type *)
+ fdec'.svar.vtype <- origType;
+ end;
+ res
+ in
+ (* Make a node for this inline function using the original name. *)
+ let inode =
+ getNode vEq vSyn !currentFidx origname fdec'.svar
+ (Some (l, !currentDeclIdx))
+ in
+ if debugInlines then begin
+ ignore (E.log "getNode %s(%d) with loc=%a. declidx=%d\n"
+ inode.nname inode.nfidx
+ d_nloc inode.nloc
+ !currentDeclIdx);
+ ignore (E.log
+ "Looking for previous definition of inline %s(%d)\n"
+ origname !currentFidx);
+ end;
+ try
+ let oldinode = H.find inlineBodies printout in
+ if debugInlines then
+ 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
+ * 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
+ end
+ end;
+ let _ = union oldinode inode in
+ (* Clean up the vreferenced bit in the new inline, so that we
+ * can rename it. Reset the name to the original one so that
+ * we can find the replacement name. *)
+ fdec'.svar.vreferenced <- false;
+ fdec'.svar.vname <- origname;
+ () (* Drop this definition *)
+ with Not_found -> begin
+ if debugInlines then ignore (E.log " Not found\n");
+ H.add inlineBodies printout inode;
+ mergePushGlobal g'
+ end
+ end else begin
+ (* either the function is not inline, or we're not attempting to
+ * merge inlines *)
+ if (mergeGlobals &&
+ not fdec'.svar.vinline &&
+ fdec'.svar.vstorage <> Static) then
+ begin
+ (* sm: this is a non-inline, non-static function. I want to
+ * consider dropping it if a same-named function has already
+ * been put into the merged file *)
+ let curSum = (functionChecksum fdec') in
+ (*(trace "mergeGlob" (P.dprintf "I see extern function %s, sum is %d\n"*)
+ (* fdec'.svar.vname curSum));*)
+ try
+ let prevFun, prevLoc, prevSum =
+ (H.find emittedFunDefn fdec'.svar.vname) in
+ (* previous was found *)
+ if (curSum = prevSum) then
+ (trace "mergeGlob"
+ (P.dprintf "dropping duplicate def'n of func %s at %a in favor of that at %a\n"
+ 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
+ * 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.\n"
+ fdec'.svar.vname d_loc l curSum d_loc prevLoc
+ prevSum d_loc prevLoc))
+ end
+ with Not_found -> begin
+ (* there was no previous definition *)
+ (mergePushGlobal g');
+ (H.add emittedFunDefn fdec'.svar.vname (fdec', l, curSum))
+ end
+ end else begin
+ (* not attempting to merge global functions, or it was static
+ * or inline *)
+ mergePushGlobal g'
+ end
+ end
+
+ | GCompTag (ci, l) as g -> begin
+ currentLoc := l;
+ incr currentDeclIdx;
+ if ci.creferenced then
+ ()
+ else begin
+ match findReplacement true sEq !currentFidx ci.cname with
+ None ->
+ (* A new one, we must rename it and keep the definition *)
+ (* Make sure this is root *)
+ (try
+ let nd = H.find sEq (!currentFidx, ci.cname) in
+ 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
+ ci.cname <- newname;
+ 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
+ * emitted it *)
+ mergePushGlobals (visitCilGlobal renameVisitor g)
+ | Some (oldci, oldfidx) -> begin
+ (* We are not the representative. Drop this declaration
+ * because we'll not be using it. *)
+ ()
+ end
+ end
+ end
+ | GEnumTag (ei, l) as g -> begin
+ currentLoc := l;
+ incr currentDeclIdx;
+ if ei.ereferenced then
+ ()
+ else begin
+ match findReplacement true eEq !currentFidx ei.ename with
+ None -> (* We must rename it *)
+ let newname, _ =
+ A.newAlphaName eAlpha None ei.ename !currentLoc in
+ ei.ename <- newname;
+ ei.ereferenced <- true;
+ (* And we must rename the items to using the same name space
+ * as the variables *)
+ ei.eitems <-
+ List.map
+ (fun (n, i, loc) ->
+ let newname, _ =
+ A.newAlphaName vtAlpha None n !currentLoc in
+ newname, i, loc)
+ ei.eitems;
+ mergePushGlobals (visitCilGlobal renameVisitor g);
+ | 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
+ * already. *)
+ (* Do not increment currentDeclIdx because it is not incremented in
+ * pass 1*)
+ if H.mem emittedCompDecls ci.cname then
+ () (* It was already declared *)
+ else begin
+ H.add emittedCompDecls ci.cname true;
+ (* Keep it as a declaration *)
+ mergePushGlobal g;
+ end
+ end
+
+ | GEnumTagDecl (ei, l) ->
+ currentLoc := l;
+ (* Do not increment currentDeclIdx because it is not incremented in
+ * pass 1*)
+ (* Keep it as a declaration *)
+ mergePushGlobal g
+
+
+ | GType (ti, l) as g -> begin
+ currentLoc := l;
+ incr currentDeclIdx;
+ if ti.treferenced then
+ ()
+ else begin
+ 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
+ ti.tname <- newname;
+ ti.treferenced <- true;
+ mergePushGlobals (visitCilGlobal renameVisitor g);
+ | 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
+ "error when merging global %a: %s"
+ d_global g (Printexc.to_string e))) in
+ ignore (E.log "%s\n" globStr);
+ (*"error when merging global: %s\n" (Printexc.to_string e);*)
+ mergePushGlobal (GText (P.sprint 80
+ (P.dprintf "/* error at %t:" d_thisloc)));
+ mergePushGlobal g;
+ mergePushGlobal (GText ("*************** end of error*/"));
+ 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
+ * remove it *)
+ if mergeInlinesRepeat && !repeatPass2 then begin
+ 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
+ * file. *)
+ let theseGlobals : global list ref = ref [] in
+ (* Scan a list of globals until we hit a given tail *)
+ let rec scanUntil (tail: 'a list) (l: 'a list) =
+ if tail == l then ()
+ else
+ match l with
+ | [] -> E.s (bug "mergecil: scanUntil could not find the marker\n")
+ | g :: rest ->
+ theseGlobals := g :: !theseGlobals;
+ scanUntil tail rest
+ in
+ (* Collect in theseGlobals all the globals from this file *)
+ theseGlobals := [];
+ scanUntil savedTheFile !theFile;
+ (* Now reprocess them *)
+ theFile := savedTheFile;
+ List.iter (fun g ->
+ theFile := (visitCilGlobal renameInlinesVisitor g) @ !theFile)
+ !theseGlobals;
+ (* Now check if we have inlines that we could not remove
+ H.iter (fun name _ ->
+ if not (H.mem inlinesRemoved name) then
+ ignore (warn "Could not remove inline %s. I have no idea why!\n"
+ name))
+ inlinesToRemove *)
+ end
+
+
+let merge (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;
+
+ (* Now maybe try to force synonyms to be equal *)
+ if mergeSynonyms then begin
+ 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
+ * because vEq will be used for variable renaming *)
+ H.iter (fun k n -> H.add vEq k n) iEq;
+ doMergeSynonyms iSyn iEq matchInlines;
+ end
+ end;
+
+ (* Now maybe dump the graph *)
+ if debugMerge then begin
+ dumpGraph "type" tEq;
+ dumpGraph "struct and union" sEq;
+ dumpGraph "enum" eEq;
+ dumpGraph "variable" vEq;
+ if mergeInlines then dumpGraph "inline" iEq;
+ end;
+ (* Make the second pass over the files. This is when we start rewriting the
+ * file *)
+ currentFidx := 0;
+ List.iter (fun f -> oneFilePass2 f; incr currentFidx) files;
+
+ (* Now reverse the result and return the resulting file *)
+ let rec revonto acc = function
+ [] -> acc
+ | x :: t -> revonto (x :: acc) t
+ in
+ let res =
+ { fileName = newname;
+ globals = revonto (revonto [] !theFile) !theFileTypes;
+ globinit = None;
+ globinitcalled = false;} in
+ init (); (* Make the GC happy *)
+ (* 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;
+ res
+
+
+
+
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(** Set this to true to ignore the merge conflicts *)
+val ignore_merge_conflicts: bool ref
+
+(** Merge a number of CIL files *)
+val merge: Cil.file list -> string -> Cil.file
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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;;
+(*
+let a = Pretty.dprintf "Aman"
+let b = Pretty.dprintf "%d" 3
+let c = (Pretty.dprintf "%d%a" 4 (fun a b -> b) a)
+
+
+let rec deepDoc depth =
+ if (depth == 0) then (Pretty.dprintf "")
+ else begin (Pretty.dprintf
+ "@[Aman?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?@?%d @? %a @?@]"
+ depth
+ (fun a b -> b)
+ (deepDoc (depth - 1))) end
+
+let dotest () =
+ Pretty.noBreaks := false;
+ Pretty.noAligns := false;
+ for i=1 to 50 do
+ Pretty.fprint stdout 20 (deepDoc 50)
+ done;;
+*)
+(* dotest ()*)
+
+let strings = [| "some" ; "dummy" ; "strings" ; "that" ; "are" ; "statically" ; "allocated" ; "." |]
+
+type stringTree = TNode of stringTree * stringTree | TLeaf of string
+
+let rec makeStringTree (levels : int) : stringTree =
+ if levels = 0 then TLeaf strings.(Random.int (Array.length strings))
+ else TNode (makeStringTree (levels - Random.int 2) ,
+ makeStringTree (levels - 1))
+
+
+let rec boo = function
+ TLeaf s -> 1
+ | TNode (a,b) -> (boo a) + (boo b)
+
+let rec treeMap leafFun nodeFun = function
+ TLeaf s -> leafFun s
+ | TNode (a,b) -> nodeFun (treeMap leafFun nodeFun a) (treeMap leafFun nodeFun b)
+
+let countLeaves = treeMap (function _ -> 1) (+)
+
+let tree2doc = (treeMap
+ (fun s -> dprintf "%s" s)
+ (fun d1 d2 -> dprintf "(@[%a@?+@?%a@])" insert d1 insert d2))
+
+let treeTest n colWidth =
+
+ Pretty.noBreaks := false;
+ Pretty.noAligns := false;
+ Random.init 10;
+
+ ignore (Pretty.fprintf stderr "prettytest: Depth = %d " n);
+ ignore (flush stderr);
+ let mode = try Sys.getenv "MODE" with Not_found -> "" in
+ let t = makeStringTree n in
+ ignore (Printf.fprintf stderr "Mode = %s Tree size = %d \t ColWidth = %d\n" mode (countLeaves t) colWidth);
+ ignore (flush stderr);
+ if mode <> "SkipPrint" then
+ let start = Sys.time () in
+ Pretty.fprint stdout colWidth (tree2doc t);
+ let finish = Sys.time () in
+ Printf.fprintf stderr"Print time: %f\n" (finish -. start)
+
+
+let doTest () =
+ let width = try (int_of_string (Sys.getenv "WIDTH")) with Not_found -> 80 in
+ let depth = try (int_of_string (Sys.getenv "DEPTH")) with Not_found -> 9 in
+ let marshalFilename =
+ try Sys.getenv "MARSHALREAD"
+ with Not_found -> (treeTest depth width) ; exit 0
+ in
+ Printf.fprintf stderr "Marshalling in %s\n" marshalFilename;
+ let chn = open_in_bin marshalFilename in
+ let fcount = ref 0 in
+ try
+ while true do
+ Pretty.fprint stdout width (Obj.magic (Marshal.from_channel chn) : doc);
+ fcount := !fcount + 1
+ done
+ with End_of_file -> begin
+ Printf.fprintf stderr "%d documents printed from marshaled file\n" !fcount;
+ ()
+ end
+;;
+
+doTest ();;
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * 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.
+ *
+ * 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.
+ *
+ *)
+
+(* rmtmps.ml *)
+(* implementation for rmtmps.mli *)
+
+open Pretty
+open Cil
+module H = Hashtbl
+module E = Errormsg
+module U = Util
+
+(* Set on the command-line: *)
+let keepUnused = ref false
+let rmUnusedInlines = ref false
+
+
+let trace = Trace.trace "rmtmps"
+
+
+
+(***********************************************************************
+ *
+ * Clearing of "referenced" bits
+ *
+ *)
+
+
+let clearReferencedBits file =
+ let considerGlobal global =
+ match global with
+ | GType (info, _) ->
+ trace (dprintf "clearing mark: %a\n" d_shortglobal global);
+ info.treferenced <- false
+
+ | GEnumTag (info, _)
+ | GEnumTagDecl (info, _) ->
+ trace (dprintf "clearing mark: %a\n" d_shortglobal global);
+ info.ereferenced <- false
+
+ | GCompTag (info, _)
+ | GCompTagDecl (info, _) ->
+ trace (dprintf "clearing mark: %a\n" d_shortglobal global);
+ info.creferenced <- false
+
+ | GVar ({vname = name} as info, _, _)
+ | GVarDecl ({vname = name} as info, _) ->
+ trace (dprintf "clearing mark: %a\n" d_shortglobal global);
+ info.vreferenced <- false
+
+ | GFun ({svar = info} as func, _) ->
+ trace (dprintf "clearing mark: %a\n" d_shortglobal global);
+ info.vreferenced <- false;
+ let clearMark local =
+ trace (dprintf "clearing mark: local %s\n" local.vname);
+ local.vreferenced <- false
+ in
+ List.iter clearMark func.slocals
+
+ | _ ->
+ ()
+ in
+ iterGlobals file considerGlobal
+
+
+(***********************************************************************
+ *
+ * Scanning and categorization of pragmas
+ *
+ *)
+
+
+(* collections of names of things to keep *)
+type collection = (string, unit) H.t
+type keepers = {
+ typedefs : collection;
+ enums : collection;
+ structs : collection;
+ unions : collection;
+ defines : collection;
+ }
+
+
+(* rapid transfer of control when we find a malformed pragma *)
+exception Bad_pragma
+
+let ccureddeepcopystring = "ccureddeepcopy"
+(* Save this length so we don't recompute it each time. *)
+let ccureddeepcopystring_length = String.length ccureddeepcopystring
+
+(* CIL and CCured define several pragmas which prevent removal of
+ * various global symbols. Here we scan for those pragmas and build
+ * up collections of the corresponding symbols' names.
+ *)
+
+let categorizePragmas file =
+
+ (* names of things which should be retained *)
+ let keepers = {
+ typedefs = H.create 0;
+ enums = H.create 0;
+ structs = H.create 0;
+ 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,
+ * structs, unions, or globals (functions or variables) *)
+ begin
+ let processArg arg =
+ try
+ match arg with
+ | AStr specifier ->
+ (* isolate and categorize one symbol name *)
+ let collection, name =
+ (* Two words denotes a typedef, enum, struct, or
+ * union, as in "type foo" or "enum bar". A
+ * single word denotes a global function or
+ * variable. *)
+ let whitespace = Str.regexp "[ \t]+" in
+ let words = Str.split whitespace specifier in
+ match words with
+ | ["type"; name] ->
+ keepers.typedefs, name
+ | ["enum"; name] ->
+ keepers.enums, name
+ | ["struct"; name] ->
+ keepers.structs, name
+ | ["union"; name] ->
+ keepers.unions, name
+ | [name] ->
+ keepers.defines, name
+ | _ ->
+ raise Bad_pragma
+ in
+ H.add collection name ()
+ | _ ->
+ raise Bad_pragma
+ with Bad_pragma ->
+ badPragma location directive
+ in
+ List.iter processArg args
+ end
+ | GVarDecl (v, _) -> begin
+ (* Look for alias attributes, e.g. Linux modules *)
+ match filterAttributes "alias" v.vattr with
+ [] -> () (* ordinary prototype. *)
+ | [Attr("alias", [AStr othername])] ->
+ H.add keepers.defines othername ()
+ | _ -> E.s (error "Bad alias attribute at %a" d_loc !currentLoc)
+ end
+
+ (*** Begin CCured-specific checks: ***)
+ (* these pragmas indirectly require that we keep the function named in
+ -- the first arguments of boxmodelof and ccuredwrapperof, and
+ -- the third argument of ccureddeepcopy*. *)
+ | GPragma (Attr("ccuredwrapper" as directive, attribute :: _), location) ->
+ begin
+ match attribute with
+ | AStr name ->
+ H.add keepers.defines name ()
+ | _ ->
+ badPragma location directive
+ end
+ | GPragma (Attr("ccuredvararg", funcname :: (ASizeOf t) :: _), location) ->
+ begin
+ match t with
+ | TComp(c,_) when c.cstruct -> (* struct *)
+ H.add keepers.structs c.cname ()
+ | TComp(c,_) -> (* union *)
+ H.add keepers.unions c.cname ()
+ | TNamed(ti,_) ->
+ H.add keepers.typedefs ti.tname ()
+ | TEnum(ei, _) ->
+ H.add keepers.enums ei.ename ()
+ | _ ->
+ ()
+ end
+ | GPragma (Attr(directive, _ :: _ :: attribute :: _), location)
+ when String.length directive > ccureddeepcopystring_length
+ && (Str.first_chars directive ccureddeepcopystring_length)
+ = ccureddeepcopystring ->
+ begin
+ match attribute with
+ | AStr name ->
+ H.add keepers.defines name ()
+ | _ ->
+ badPragma location directive
+ end
+ (** end CCured-specific stuff **)
+ | _ ->
+ ()
+ in
+ iterGlobals file considerPragma;
+ keepers
+
+
+
+(***********************************************************************
+ *
+ * Function body elimination from pragmas
+ *
+ *)
+
+
+(* When performing global slicing, any functions not explicitly marked
+ * as pragma roots are reduced to mere declarations. This leaves one
+ * with a reduced source file that still compiles to object code, but
+ * which contains the bodies of only explicitly retained functions.
+ *)
+
+let amputateFunctionBodies keptGlobals file =
+ let considerGlobal = function
+ | 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)
+ | other ->
+ other
+ in
+ mapGlobals file considerGlobal
+
+
+
+(***********************************************************************
+ *
+ * Root collection from pragmas
+ *
+ *)
+
+
+let isPragmaRoot keepers = function
+ | GType ({tname = name}, _) ->
+ H.mem keepers.typedefs name
+ | GEnumTag ({ename = name}, _)
+ | GEnumTagDecl ({ename = name}, _) ->
+ H.mem keepers.enums name
+ | GCompTag ({cname = name; cstruct = structure}, _)
+ | GCompTagDecl ({cname = name; cstruct = structure}, _) ->
+ let collection = if structure then keepers.structs else keepers.unions in
+ H.mem collection name
+ | GVar ({vname = name; vattr = attrs}, _, _)
+ | GVarDecl ({vname = name; vattr = attrs}, _)
+ | GFun ({svar = {vname = name; vattr = attrs}}, _) ->
+ H.mem keepers.defines name ||
+ hasAttribute "used" attrs
+ | _ ->
+ false
+
+
+
+(***********************************************************************
+ *
+ * Common root collecting utilities
+ *
+ *)
+
+
+let traceRoot reason global =
+ trace (dprintf "root (%s): %a@!" reason d_shortglobal global);
+ true
+
+
+let traceNonRoot reason global =
+ trace (dprintf "non-root (%s): %a@!" reason d_shortglobal global);
+ false
+
+
+let hasExportingAttribute funvar =
+ let rec isExportingAttribute = function
+ | Attr ("constructor", []) -> true
+ | Attr ("destructor", []) -> true
+ | _ -> false
+ in
+ List.exists isExportingAttribute funvar.vattr
+
+
+
+(***********************************************************************
+ *
+ * Root collection from external linkage
+ *
+ *)
+
+
+(* Exported roots are those global symbols which are visible to the
+ * linker and dynamic loader. For variables, this consists of
+ * anything that is not "static". For functions, this consists of:
+ *
+ * - functions bearing a "constructor" or "destructor" attribute
+ * - functions declared extern but not inline
+ * - functions declared neither inline nor static
+ *
+ * gcc incorrectly (according to C99) makes inline functions visible to
+ * the linker. So we can only remove inline functions on MSVC.
+ *)
+
+let isExportedRoot global =
+ let result, reason = match global with
+ | GVar ({vstorage = Static}, _, _) ->
+ false, "static variable"
+ | GVar _ ->
+ true, "non-static variable"
+ | GFun ({svar = v}, _) -> begin
+ if hasExportingAttribute v then
+ true, "constructor or destructor function"
+ else if v.vstorage = Static then
+ false, "static function"
+ else if v.vinline && v.vstorage != Extern
+ && (!msvcMode || !rmUnusedInlines) then
+ false, "inline function"
+ else
+ true, "other function"
+ end
+ | GVarDecl(v,_) when hasAttribute "alias" v.vattr ->
+ true, "has GCC alias attribute"
+ | _ ->
+ false, "neither function nor variable"
+ in
+ trace (dprintf "isExportedRoot %a -> %b, %s@!"
+ d_shortglobal global result reason);
+ result
+
+
+
+(***********************************************************************
+ *
+ * Root collection for complete programs
+ *
+ *)
+
+
+(* Exported roots are "main()" and functions bearing a "constructor"
+ * or "destructor" attribute. These are the only things which must be
+ * retained in a complete program.
+ *)
+
+let isCompleteProgramRoot global =
+ let result = match global with
+ | GFun ({svar = {vname = "main"; vstorage = vstorage}}, _) ->
+ vstorage <> Static
+ | GFun (fundec, _)
+ when hasExportingAttribute fundec.svar ->
+ true
+ | _ ->
+ false
+ in
+ trace (dprintf "complete program root -> %b for %a@!" result d_shortglobal global);
+ result
+
+
+(***********************************************************************
+ *
+ * Transitive reachability closure from roots
+ *
+ *)
+
+
+(* This visitor recursively marks all reachable types and variables as used. *)
+class markReachableVisitor
+ ((globalMap: (string, Cil.global) H.t),
+ (currentFunc: fundec option ref)) = object (self)
+ inherit nopCilVisitor
+
+ method vglob = function
+ | GType (typeinfo, _) ->
+ typeinfo.treferenced <- true;
+ DoChildren
+ | GCompTag (compinfo, _)
+ | GCompTagDecl (compinfo, _) ->
+ compinfo.creferenced <- true;
+ DoChildren
+ | GEnumTag (enuminfo, _)
+ | GEnumTagDecl (enuminfo, _) ->
+ enuminfo.ereferenced <- true;
+ DoChildren
+ | GVar (varinfo, _, _)
+ | GVarDecl (varinfo, _)
+ | GFun ({svar = varinfo}, _) ->
+ varinfo.vreferenced <- true;
+ DoChildren
+ | _ ->
+ SkipChildren
+
+ 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 ->
+ try ignore (Str.search_forward vre tmp 0); true
+ with Not_found -> false)
+ tmpls
+ then
+ v.vreferenced <- true) fd.slocals
+ | _ -> assert false);
+ DoChildren
+ | _ -> DoChildren
+
+ method vvrbl v =
+ if not v.vreferenced then
+ begin
+ let name = v.vname in
+ if v.vglob then
+ 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
+ begin
+ trace (dprintf "descending: global %s\n" name);
+ let descend global =
+ ignore (visitCilGlobal (self :> cilVisitor) global)
+ in
+ let globals = Hashtbl.find_all globalMap name in
+ List.iter descend globals
+ end
+ else
+ v.vreferenced <- true;
+ end;
+ SkipChildren
+
+ method vexpr (e: exp) =
+ match e with
+ Const (CEnum (_, _, ei)) -> ei.ereferenced <- true;
+ DoChildren
+ | _ -> DoChildren
+
+ method vtype typ =
+ let old : bool =
+ let visitAttrs attrs =
+ ignore (visitCilAttributes (self :> cilVisitor) attrs)
+ in
+ let visitType typ =
+ ignore (visitCilType (self :> cilVisitor) typ)
+ in
+ match typ with
+ | TEnum(e, attrs) ->
+ let old = e.ereferenced in
+ if not old then
+ begin
+ trace (dprintf "marking transitive use: enum %s\n" e.ename);
+ e.ereferenced <- true;
+ visitAttrs attrs;
+ visitAttrs e.eattr
+ end;
+ old
+
+ | TComp(c, attrs) ->
+ let old = c.creferenced in
+ if not old then
+ begin
+ trace (dprintf "marking transitive use: compound %s\n" c.cname);
+ c.creferenced <- true;
+
+ (* to recurse, we must ask explicitly *)
+ let recurse f = visitType f.ftype in
+ List.iter recurse c.cfields;
+ visitAttrs attrs;
+ visitAttrs c.cattr
+ end;
+ old
+
+ | TNamed(ti, attrs) ->
+ let old = ti.treferenced in
+ if not old then
+ 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;
+ visitAttrs attrs
+ end;
+ old
+
+ | _ ->
+ (* for anything else, just look inside it *)
+ false
+ in
+ if old then
+ SkipChildren
+ else
+ DoChildren
+end
+
+
+let markReachable file isRoot =
+ (* build a mapping from global names back to their definitions &
+ * declarations *)
+ let globalMap = Hashtbl.create 137 in
+ let considerGlobal global =
+ match global with
+ | GFun ({svar = info}, _)
+ | GVar (info, _, _)
+ | GVarDecl (info, _) ->
+ Hashtbl.add globalMap info.vname global
+ | _ ->
+ ()
+ in
+ iterGlobals file considerGlobal;
+
+ let currentFunc = ref None in
+
+ (* mark everything reachable from the global roots *)
+ let visitor = new markReachableVisitor (globalMap, currentFunc) in
+ let visitIfRoot global =
+ if isRoot global then
+ begin
+ trace (dprintf "traversing root global: %a\n" d_shortglobal global);
+ (match global with
+ GFun(fd, _) -> currentFunc := Some fd
+ | _ -> currentFunc := None);
+ ignore (visitCilGlobal visitor global)
+ end
+ else
+ trace (dprintf "skipping non-root global: %a\n" d_shortglobal global)
+ in
+ iterGlobals file visitIfRoot
+
+
+(**********************************************************************
+ *
+ * Marking and removing of unused labels
+ *
+ **********************************************************************)
+
+(* We keep only one label, preferably one that was not introduced by CIL.
+ * Scan a list of labels and return the data for the label that should be
+ * kept, and the remaining filtered list of labels *)
+let labelsToKeep (ll: label list) : (string * location * bool) * label list =
+ let rec loop (sofar: string * location * bool) = function
+ [] -> sofar, []
+ | l :: rest ->
+ let newlabel, keepl =
+ match l with
+ | Case _ | Default _ -> sofar, true
+ | Label (ln, lloc, isorig) -> begin
+ 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
+ * missing labels *)
+ (ln, lloc, isorig), false
+ | true, _ -> sofar, false
+ end
+ in
+ let newlabel', rest' = loop newlabel rest in
+ newlabel', (if keepl then l :: rest' else rest')
+ in
+ loop ("", locUnknown, false) ll
+
+class markUsedLabels (labelMap: (string, unit) H.t) = object
+ inherit nopCilVisitor
+
+ method vstmt (s: stmt) =
+ match s.skind with
+ Goto (dest, _) ->
+ let (ln, _, _), _ = labelsToKeep !dest.labels in
+ if ln = "" then
+ E.s (E.bug "rmtmps: destination of statement does not have labels");
+ (* Mark it as used *)
+ H.replace labelMap ln ();
+ DoChildren
+
+ | _ -> DoChildren
+
+ (* No need to go into expressions or instructions *)
+ method vexpr _ = SkipChildren
+ method vinst _ = SkipChildren
+ method vtype _ = SkipChildren
+end
+
+class removeUnusedLabels (labelMap: (string, unit) H.t) = object
+ inherit nopCilVisitor
+
+ method vstmt (s: stmt) =
+ let (ln, lloc, lorig), lrest = labelsToKeep s.labels in
+ s.labels <-
+ (if ln <> "" && H.mem labelMap ln then (* We had labels *)
+ (Label(ln, lloc, lorig) :: lrest)
+ else
+ lrest);
+ DoChildren
+
+ (* No need to go into expressions or instructions *)
+ method vexpr _ = SkipChildren
+ method vinst _ = SkipChildren
+ method vtype _ = SkipChildren
+end
+
+(***********************************************************************
+ *
+ * Removal of unused symbols
+ *
+ *)
+
+
+(* regular expression matching names of uninteresting locals *)
+let uninteresting =
+ let names = [
+ (* Cil.makeTempVar *)
+ "__cil_tmp";
+
+ (* sm: I don't know where it comes from but these show up all over. *)
+ (* this doesn't seem to do what I wanted.. *)
+ "iter";
+
+ (* various macros in glibc's <bits/string2.h> *)
+ "__result";
+ "__s"; "__s1"; "__s2";
+ "__s1_len"; "__s2_len";
+ "__retval"; "__len";
+
+ (* various macros in glibc's <ctype.h> *)
+ "__c"; "__res";
+
+ (* We remove the __malloc variables *)
+ ] in
+
+ (* optional alpha renaming *)
+ let alpha = "\\(___[0-9]+\\)?" in
+
+ let pattern = "\\(" ^ (String.concat "\\|" names) ^ "\\)" ^ alpha ^ "$" in
+ Str.regexp pattern
+
+
+let 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}}, _) ->
+ 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 =
+ if not local.vreferenced then
+ begin
+ (* along the way, record the interesting locals that were removed *)
+ let name = local.vname in
+ trace (dprintf "removing local: %s\n" name);
+ if not (Str.string_match uninteresting name 0) then
+ removedLocals := (func.svar.vname ^ "::" ^ name) :: !removedLocals;
+ end;
+ local.vreferenced
+ in
+ func.slocals <- List.filter filterLocal func.slocals;
+ (* We also want to remove unused labels. We do it all here, including
+ * marking the used labels *)
+ let usedLabels:(string, unit) H.t = H.create 13 in
+ ignore (visitCilBlock (new markUsedLabels usedLabels) func.sbody);
+ (* And now we scan again and we remove them *)
+ ignore (visitCilBlock (new removeUnusedLabels usedLabels) func.sbody);
+ true
+
+ (* all other globals are retained *)
+ | _ ->
+ trace (dprintf "keeping global: %a\n" d_shortglobal global);
+ true
+ in
+ file.globals <- List.filter filterGlobal file.globals;
+ !removedLocals
+
+
+(***********************************************************************
+ *
+ * Exported interface
+ *
+ *)
+
+
+type rootsFilter = global -> bool
+
+let isDefaultRoot = isExportedRoot
+
+let rec 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
+ ignore (E.log "Removing unused temporaries\n" );
+
+ if Trace.traceActive "printCilTree" then
+ dumpFile defaultCilPrinter stdout "stdout" file;
+
+ (* digest any pragmas that would create additional roots *)
+ let keepers = categorizePragmas file in
+
+ (* if slicing, remove the bodies of non-kept functions *)
+ if !Cilutil.sliceGlobal then
+ amputateFunctionBodies keepers.defines file;
+
+ (* build up the root set *)
+ let isRoot global =
+ isPragmaRoot keepers global ||
+ isRoot global
+ in
+
+ (* mark everything reachable from the global roots *)
+ clearReferencedBits file;
+ markReachable file isRoot;
+
+ (* take out the trash *)
+ let removedLocals = removeUnmarked file in
+
+ (* print which original source variables were removed *)
+ if false && removedLocals != [] then
+ let count = List.length removedLocals in
+ if count > 2000 then
+ ignore (E.warn "%d unused local variables removed" count)
+ else
+ ignore (E.warn "%d unused local variables removed:@!%a"
+ count (docList ~sep:(chr ',' ++ break) text) removedLocals)
+ end
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * 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.
+ *
+ * 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.
+ *
+ *)
+
+(* rmtmps.mli *)
+(* remove unused things from cil files: *)
+(* - local temporaries introduced but not used *)
+(* - global declarations that are not used *)
+(* - types that are not used *)
+(* - labels that are not used (gn) *)
+
+
+(* Some clients may wish to augment or replace the standard strategy
+ * for finding the initially reachable roots. The optional
+ * "isRoot" argument to Rmtmps.removeUnusedTemps grants this
+ * flexibility. If given, it should name a function which will return
+ * true if a given global should be treated as a retained root.
+ *
+ * Function Rmtmps.isDefaultRoot encapsulates the default root
+ * collection, which consists of those global variables and functions
+ * which are visible to the linker and runtime loader. A client's
+ * root filter can use this if the goal is to augment rather than
+ * replace the standard logic. Function Rmtmps.isExportedRoot is an
+ * alternate name for this same function.
+ *
+ * Function Rmtmps.isCompleteProgramRoot is an example of an alternate
+ * root collection. This function assumes that it is operating on a
+ * complete program rather than just one object file. It treats
+ * "main()" as a root, as well as any function carrying the
+ * "constructor" or "destructor" attribute. All other globals are
+ * candidates for removal, regardless of their linkage.
+ *
+ * Note that certain CIL- and CCured-specific pragmas induce
+ * additional global roots. This functionality is always present, and
+ * is not subject to replacement by "filterRoots".
+ *)
+
+type rootsFilter = Cil.global -> bool
+val isDefaultRoot : rootsFilter
+val isExportedRoot : rootsFilter
+val isCompleteProgramRoot : rootsFilter
+
+(* process a complete Cil file *)
+val removeUnusedTemps: ?isRoot:rootsFilter -> Cil.file -> unit
+
+
+val keepUnused: bool ref (* Set this to true to turn off this module *)
+val rmUnusedInlines: bool ref (* Delete unused inline funcs in gcc mode? *)
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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 test for CIL *)
+open Pretty
+open Cil
+module E = Errormsg
+
+let lu = locUnknown
+
+(* If you have trouble try to reproduce the problem on a smaller type. Try
+ * limiting the maxNesting and integerKinds *)
+let integerKinds = [ IChar; ISChar; IUChar; IInt; IUInt; IShort; IUShort;
+ ILong; IULong; ILongLong; IULongLong ]
+let floatKinds = [ FFloat; FDouble ]
+
+let baseTypes =
+ (List.map (fun ik -> (1, fun _ -> TInt(ik, []))) integerKinds)
+ @ (List.map (fun fk -> (1, fun _ -> TFloat(fk, []))) floatKinds)
+
+
+(* Make a random struct *)
+let maxNesting = ref 3 (* Maximum number of levels for struct nesting *)
+let maxFields = ref 8 (* The maximum number of fields in a struct *)
+let useBitfields = ref false
+let useZeroBitfields = ref true
+
+
+
+(* Collect here the globals *)
+let globals: global list ref = ref []
+let addGlobal (g:global) = globals := g :: !globals
+let getGlobals () = List.rev !globals
+
+(* Collect here the statements for main *)
+let statements: stmt list ref = ref []
+let addStatement (s: stmt) = statements := s :: !statements
+let getStatements () = List.rev !statements
+
+(* Keep here the main function *)
+let main: fundec ref = ref dummyFunDec
+let mainRetVal: varinfo ref = ref dummyFunDec.svar
+
+let assertId = ref 0
+let addAssert (b: exp) (extra: stmt list) : unit =
+ incr assertId;
+ addStatement (mkStmt (If(UnOp(LNot, b, intType),
+ mkBlock (extra @
+ [mkStmt (Return (Some (integer !assertId),
+ lu))]),
+ mkBlock [], lu)))
+
+let addSetRetVal (b: exp) (extra: stmt list) : unit =
+ addStatement
+ (mkStmt (If(UnOp(LNot, b, intType),
+ mkBlock (extra @
+ [mkStmtOneInstr (Set(var !mainRetVal, one, lu))]),
+ mkBlock [], lu)))
+
+
+let printfFun: fundec =
+ let fdec = emptyFunction "printf" in
+ fdec.svar.vtype <-
+ TFun(intType, Some [ ("format", charPtrType, [])], true, []);
+ fdec
+
+
+let memsetFun: fundec =
+ let fdec = emptyFunction "memset" in
+ fdec.svar.vtype <-
+ TFun(voidPtrType, Some [ ("start", voidPtrType, []);
+ ("v", intType, []);
+ ("len", uintType, [])], false, []);
+ fdec
+
+let checkOffsetFun: fundec =
+ let fdec = emptyFunction "checkOffset" in
+ fdec.svar.vtype <-
+ TFun(voidType, Some [ ("start", voidPtrType, []);
+ ("len", uintType, []);
+ ("expected_start", intType, []);
+ ("expected_width", intType, []);
+ ("name", charPtrType, []) ], false, []);
+ fdec
+
+let checkSizeOfFun: fundec =
+ let fdec = emptyFunction "checkSizeOf" in
+ fdec.svar.vtype <-
+ TFun(voidType, Some [ ("len", uintType, []);
+ ("expected", intType, []);
+ ("name", charPtrType, []) ], false, []);
+ fdec
+
+
+let doPrintf format args =
+ mkStmtOneInstr (Call(None, Lval(var printfFun.svar),
+ (Const(CStr format)) :: args, lu))
+
+
+(* Select among the choices, each with a given weight *)
+type 'a selection = int * (unit -> 'a)
+let select (choices: 'a selection list) : 'a =
+ (* Find the total weight *)
+ let total = List.fold_left (fun sum (w, _) -> sum + w) 0 choices in
+ if total = 0 then E.s (E.bug "Total for choices = 0\n");
+ (* Pick a random number *)
+ let thechoice = Random.int total in
+ (* Now get the choice *)
+ let rec loop thechoice = function
+ [] -> E.s (E.bug "Ran out of choices\n")
+ | (w, c) :: rest ->
+ if thechoice < w then c () else loop (thechoice - w) rest
+ in
+ loop thechoice choices
+
+
+(* Generate a new name *)
+let nameId = ref 0
+let newName (base: string) =
+ incr nameId;
+ base ^ (string_of_int !nameId)
+
+
+(********** Testing of SIZEOF ***********)
+
+(* The current selection of types *)
+let typeChoices : typ selection list ref = ref []
+
+let baseTypeChoices : typ selection list ref = ref []
+
+
+let currentNesting = ref 0
+let mkCompType (iss: bool) =
+ if !currentNesting >= !maxNesting then (* Replace it with an int *)
+ select !baseTypeChoices
+ else begin
+ incr currentNesting;
+ let ci =
+ mkCompInfo iss (newName "comp")
+ (fun _ ->
+ let nrFields = 1 + (Random.int !maxFields) in
+ let rec mkFields (i: int) =
+ if i = nrFields then [] else begin
+ let ft = select !typeChoices in
+ let fname = "f" ^ string_of_int i in
+ let fname', width =
+ if not !useBitfields || not (isIntegralType ft)
+ || (Random.int 8 >= 6) then
+ fname, None
+ else begin
+ let tw = bitsSizeOf ft in (* Assume this works for TInt *)
+ let w = (if !useZeroBitfields then 0 else 1) +
+ Random.int (3 * tw / 4) in
+ (if w = 0 then "___missing_field_name" else fname), Some w
+ end
+ in
+ (fname', ft, width, [], lu) :: mkFields (i + 1)
+ end
+ in
+ mkFields 0)
+ []
+ in
+ decr currentNesting;
+ (* Register it with the file *)
+ addGlobal (GCompTag(ci, lu));
+ TComp(ci, [])
+ end
+
+(* Make a pointer type. They are all equal so make one to void *)
+let mkPtrType () = TPtr(TVoid([]), [])
+
+(* Make an array type. *)
+let mkArrayType () =
+ if !currentNesting >= !maxNesting then
+ select !baseTypeChoices
+ else begin
+ incr currentNesting;
+ let at = TArray(select !typeChoices, Some (integer (1 + (Random.int 32))),
+ []) in
+ decr currentNesting;
+ at
+ end
+
+
+let testSizeOf () =
+ let doOne (i: int) =
+(* ignore (E.log "doOne %d\n" i); *)
+ (* Make a random type *)
+ let t = select !typeChoices in
+ (* Create a global with that type *)
+ let g = makeGlobalVar (newName "g") t in
+ addGlobal (GVar(g, {init=None}, lu));
+ addStatement (mkStmtOneInstr(Call(None, Lval(var memsetFun.svar),
+ [ mkAddrOrStartOf (var g); zero;
+ SizeOfE(Lval(var g))], lu)));
+ try
+(* if i = 0 then ignore (E.log "0: %a\n" d_plaintype t); *)
+ let bsz =
+ try bitsSizeOf t (* This is what we are testing *)
+ with e -> begin
+ ignore (E.log "Exception %s caught while computing bitsSizeOf(%a)\n"
+ (Printexc.to_string e) d_type t);
+ raise (Failure "")
+ end
+ in
+(* ignore (E.log "1 "); *)
+ if bsz mod 8 <> 0 then begin
+ ignore (E.log "bitsSizeOf did not return a multiple of 8\n");
+ raise (Failure "");
+ end;
+(* ignore (E.log "2 "); *)
+ (* Check the offset of all fields in there *)
+ let rec checkOffsets (lv: lval) (lvt: typ) =
+ match lvt with
+ TComp(c, _) ->
+ List.iter
+ (fun f ->
+ if f.fname <> "___missing_field_name" then
+ checkOffsets (addOffsetLval (Field(f, NoOffset)) lv) f.ftype)
+ c.cfields
+ | TArray (bt, Some len, _) ->
+ let leni =
+ match isInteger len with
+ Some i64 -> i64_to_int i64
+ | None -> E.s (E.bug "Array length is not a constant")
+ in
+ let i = Random.int leni in
+ checkOffsets (addOffsetLval (Index(integer i, NoOffset)) lv) bt
+
+ | _ -> (* Now a base type *)
+ let _, off = lv in
+ let start, width = bitsOffset t off in
+ let setLv (v: exp) =
+ match lvt with
+ TFloat (FFloat, _) ->
+ Set((Mem (mkCast (AddrOf lv) intPtrType), NoOffset),
+ v, lu)
+ | TFloat (FDouble, _) ->
+ Set((Mem (mkCast (AddrOf lv)
+ (TPtr(TInt(IULongLong, []), []))), NoOffset),
+ mkCast v (TInt(IULongLong, [])), lu)
+
+ | (TPtr _ | TInt((IULongLong|ILongLong), _)) ->
+ Set(lv, mkCast v lvt, lu)
+ | _ -> Set(lv, v, lu)
+ in
+ let ucharPtrType = TPtr(TInt(IUChar, []), []) in
+ let s =
+ mkStmt (Instr ([ setLv mone;
+ Call(None, Lval(var checkOffsetFun.svar),
+ [ mkCast (mkAddrOrStartOf (var g))
+ ucharPtrType;
+ SizeOfE (Lval(var g));
+ integer start;
+ integer width;
+ (Const(CStr(sprint 80
+ (d_lval () lv))))],lu);
+ setLv zero])) in
+ addStatement s
+ in
+ checkOffsets (var g) t;
+(* ignore (E.log "3 ");*)
+ (* Now check the size of *)
+ let s = mkStmtOneInstr (Call(None, Lval(var checkSizeOfFun.svar),
+ [ SizeOfE (Lval (var g));
+ integer (bitsSizeOf t);
+ mkString g.vname ], lu)) in
+ addStatement s;
+(* ignore (E.log "10\n"); *)
+ with _ -> ()
+ in
+
+ (* Make the composite choices more likely *)
+ typeChoices :=
+ [ (1, mkPtrType);
+ (5, mkArrayType);
+ (5, fun _ -> mkCompType true);
+ (5, fun _ -> mkCompType false); ]
+ @ baseTypes;
+ baseTypeChoices := baseTypes;
+ useBitfields := false;
+ maxFields := 4;
+ for i = 0 to 100 do
+ doOne i
+ done;
+
+ (* Now test the bitfields. *)
+ typeChoices := [ (1, fun _ -> mkCompType true) ];
+ baseTypeChoices := [(1, fun _ -> TInt(IInt, []))];
+ useBitfields := true;
+
+ for i = 0 to 100 do
+ doOne i
+ done;
+
+ (* Now make it a bit more complicated *)
+ baseTypeChoices :=
+ List.map (fun ik -> (1, fun _ -> TInt(ik, [])))
+ [IInt; ILong; IUInt; IULong ];
+ useBitfields := true;
+ for i = 0 to 100 do
+ doOne i
+ done;
+
+ (* An really complicated now *)
+ baseTypeChoices := baseTypes;
+ useBitfields := true;
+ for i = 0 to 100 do
+ doOne i
+ done;
+
+ ()
+
+
+(* Now the main tester. Pass to it the name of a command "cmd" that when
+ * invoked will compile "testingcil.c" and run the result *)
+let createFile () =
+
+ assertId := 0;
+ nameId := 0;
+
+ (* Start a new file *)
+ globals := [];
+ statements := [];
+
+ (* Now make a main function *)
+ main := emptyFunction "main";
+ !main.svar.vtype <- TFun(intType, None, false, []);
+ mainRetVal := makeGlobalVar "retval" intType;
+
+ addGlobal (GVar(!mainRetVal, {init=None}, lu));
+ addGlobal (GText("#include \"testcil.h\"\n"));
+ addStatement (mkStmtOneInstr(Set(var !mainRetVal, zero, lu)));
+
+ (* Add prototype for printf *)
+ addGlobal (GVar(printfFun.svar, {init=None}, lu));
+ addGlobal (GVar(memsetFun.svar, {init=None}, lu));
+
+ (* now fill in the composites and the code of main. For simplicity we add
+ * the statements of main in reverse order *)
+
+ testSizeOf ();
+
+
+ (* Now add a return 0 at the end *)
+ addStatement (mkStmt (Return(Some (Lval(var !mainRetVal)), lu)));
+
+
+ (* Add main at the end *)
+ addGlobal (GFun(!main, lu));
+ !main.sbody.bstmts <- getStatements ();
+
+ (* Now build the CIL.file *)
+ let file =
+ { fileName = "testingcil.c";
+ globals = getGlobals ();
+ globinit = None;
+ globinitcalled = false;
+ }
+ in
+ (* Print the file *)
+ let oc = open_out "testingcil.c" in
+ dumpFile defaultCilPrinter oc "testingcil.c" file;
+ close_out oc
+
+
+
+
+
+(* initialization code for the tester *)
+let randomStateFile = "testcil.random" (* The name of a file where we store
+ * the state of the random number
+ * generator last time *)
+let doit (command: string) =
+ while true do
+ (* Initialize the random no generator *)
+ begin
+ try
+ let randomFile = open_in randomStateFile in
+ (* The file exists so restore the Random state *)
+ Random.set_state (Marshal.from_channel randomFile);
+ ignore (E.log "!! Restoring Random state from %s\n" randomStateFile);
+ close_in randomFile;
+ (* Leave the file there until we succeed *)
+ with _ -> begin
+ (* The file does not exist *)
+ Random.self_init ();
+ (* Save the state of the generator *)
+ let randomFile = open_out randomStateFile in
+ Marshal.to_channel randomFile (Random.get_state()) [] ;
+ close_out randomFile;
+ end
+ end;
+ createFile ();
+ (* Now compile and run the file *)
+ ignore (E.log "Running %s\n" command);
+ let err = Sys.command command in
+ if err <> 0 then
+ E.s (E.bug "Failed to run the command: %s (errcode=%d)" command err)
+ else begin
+ ignore (E.log "Successfully ran one more round. Press CTRL-C to stop\n");
+ (* Delete the file *)
+ Sys.remove randomStateFile
+ end
+ done
+
--- /dev/null
+
+open Escape
+open Pretty
+open Trace
+open Cil
+
+module E = Errormsg
+module H = Hashtbl
+module IH = Inthash
+module M = Machdep
+module U = Util
+module RD = Reachingdefs
+module UD = Usedef
+module A = Cabs
+module CH = Cabshelper
+module GA = GrowArray
+module RCT = Rmciltmps
+module DCE = Deadcodeelim
+module EC = Expcompare
+
+let doElimTemps = ref false
+let debug = ref false
+let printComments = ref false
+let envWarnings = ref false
+
+(* Stuff for Deputy support *)
+let deputyAttrs = ref false
+
+let thisKeyword = "__this"
+
+type paramkind =
+| PKNone
+| PKThis
+| PKOffset of attrparam
+
+let rec checkParam (ap: attrparam) : paramkind =
+ match ap with
+ | ACons (name, []) when name = thisKeyword -> PKThis
+ | ABinOp (PlusA, a1, a2) when checkParam a1 = PKThis ->
+ if a2 = AInt 0 then PKThis else PKOffset a2
+ | _ -> PKNone
+
+(* End stuff for Deputy support *)
+
+(* Some(-1) => l1 < l2
+ Some(0) => l1 = l2
+ Some(1) => l1 > l2
+ None => different files *)
+let loc_comp l1 l2 =
+ if String.compare l1.A.filename l2.A.filename != 0
+ then None
+ else if l1.A.lineno > l2.A.lineno
+ then Some(1)
+ else if l2.A.lineno > l1.A.lineno
+ then Some(-1)
+ else if l1.A.byteno > l2.A.byteno
+ then Some(1)
+ else if l2.A.byteno > l1.A.byteno
+ then Some(-1)
+ else Some(0)
+
+let simpleGaSearch l =
+ let hi = GA.max_init_index CH.commentsGA in
+ let rec loop i =
+ if i < 0 then -1 else
+ let (l',_,_) = GA.get CH.commentsGA i in
+ match loc_comp l l' with
+ None -> loop (i-1)
+ | Some(0) -> i
+ | Some(-1) -> loop (i-1)
+ | Some(1) -> i
+ | _ -> E.s (E.error "simpleGaSearch: unexpected return from loc_comp\n")
+ in
+ loop hi
+
+(* location -> string list *)
+let get_comments l =
+ let cabsl = {A.lineno = l.line;
+ A.filename = l.file;
+ A.byteno = l.byte;
+ A.ident = 0;} in
+ let s = simpleGaSearch cabsl in
+
+ let rec loop i cl =
+ if i < 0 then cl else
+ let (l',c,b) = GA.get CH.commentsGA i in
+ if String.compare cabsl.A.filename l'.A.filename != 0
+ then loop (i - 1) cl
+ else if b then cl
+ else let _ = GA.set CH.commentsGA i (l',c,true) in
+ loop (i - 1) (c::cl)
+ in
+ List.rev (loop s [])
+
+(* clean up some of the mess made below *)
+let rec simpl_cond e =
+ match e with
+ | UnOp(LNot,BinOp(LAnd,e1,e2,t1),t2) ->
+ let e1 = simpl_cond (UnOp(LNot,e1,t1)) in
+ let e2 = simpl_cond (UnOp(LNot,e2,t1)) in
+ BinOp(LOr,e1,e2,t2)
+ | UnOp(LNot,BinOp(LOr,e1,e2,t1),t2) ->
+ let e1 = simpl_cond (UnOp(LNot,e1,t1)) in
+ let e2 = simpl_cond (UnOp(LNot,e2,t1)) in
+ BinOp(LAnd,e1,e2,t2)
+ | UnOp(LNot,UnOp(LNot,e,_),_) -> simpl_cond e
+ | _ -> e
+
+(* the argument b is the body of a Loop *)
+(* returns the loop termination condition *)
+(* block -> exp option *)
+let get_loop_condition b =
+
+ (* returns the first non-empty
+ * statement of a statement list *)
+ (* stm list -> stm list *)
+ let rec skipEmpty = function
+ | [] -> []
+ | {skind = Instr []; labels = []}::rest ->
+ skipEmpty rest
+ | x -> x
+ in
+ (* stm -> exp option * instr list *)
+ let rec get_cond_from_if if_stm =
+ match if_stm.skind with
+ If(e,tb,fb,_) ->
+ let e = EC.stripNopCasts e in
+ RCT.fold_blocks tb;
+ RCT.fold_blocks fb;
+ let tsl = skipEmpty tb.bstmts in
+ let fsl = skipEmpty fb.bstmts in
+ (match tsl, fsl with
+ {skind = Break _} :: _, [] -> Some e
+ | [], {skind = Break _} :: _ ->
+ Some(UnOp(LNot, e, intType))
+ | ({skind = If(_,_,_,_)} as s) :: _, [] ->
+ let teo = get_cond_from_if s in
+ (match teo with
+ None -> None
+ | Some te ->
+ Some(BinOp(LAnd,e,EC.stripNopCasts te,intType)))
+ | [], ({skind = If(_,_,_,_)} as s) :: _ ->
+ let feo = get_cond_from_if s in
+ (match feo with
+ None -> None
+ | Some fe ->
+ Some(BinOp(LAnd,UnOp(LNot,e,intType),
+ EC.stripNopCasts fe,intType)))
+ | {skind = Break _} :: _, ({skind = If(_,_,_,_)} as s):: _ ->
+ let feo = get_cond_from_if s in
+ (match feo with
+ None -> None
+ | Some fe ->
+ Some(BinOp(LOr,e,EC.stripNopCasts fe,intType)))
+ | ({skind = If(_,_,_,_)} as s) :: _, {skind = Break _} :: _ ->
+ let teo = get_cond_from_if s in
+ (match teo with
+ None -> None
+ | Some te ->
+ Some(BinOp(LOr,UnOp(LNot,e,intType),
+ EC.stripNopCasts te,intType)))
+ | ({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
+ Some te, Some fe ->
+ Some(BinOp(LOr,BinOp(LAnd,e,EC.stripNopCasts te,intType),
+ BinOp(LAnd,UnOp(LNot,e,intType),
+ EC.stripNopCasts fe,intType),intType))
+ | _,_ -> None)
+ | _, _ -> (if !debug then ignore(E.log "cond_finder: branches of %a not good\n"
+ d_stmt if_stm);
+ None))
+ | _ -> (if !debug then ignore(E.log "cond_finder: %a not an if\n" d_stmt if_stm);
+ None)
+ in
+ let sl = skipEmpty b.bstmts in
+ match sl with
+ ({skind = If(_,_,_,_); labels=[]} as s) :: rest ->
+ get_cond_from_if s, rest
+ | s :: _ ->
+ (if !debug then ignore(E.log "checkMover: %a is first, not an if\n"
+ d_stmt s);
+ None, sl)
+ | [] ->
+ (if !debug then ignore(E.log "checkMover: no statements in loop block?\n");
+ None, sl)
+
+
+class zraCilPrinterClass : cilPrinter = object (self)
+ inherit defaultCilPrinterClass as super
+
+ val genvHtbl : (string, varinfo) H.t = H.create 128
+ val lenvHtbl : (string, varinfo) H.t = H.create 128
+
+ (*** VARIABLES ***)
+
+ (* 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
+ * isn't in the environment *)
+ method private getEnvVi (v:varinfo) : varinfo =
+ try
+ if H.mem lenvHtbl v.vname
+ then H.find lenvHtbl v.vname
+ else H.find genvHtbl v.vname
+ with Not_found ->
+ if !envWarnings then ignore (warn "variable %s not in pp environment" v.vname);
+ v
+
+ (* True when v agrees with the entry in the environment for the name of v.
+ False otherwise *)
+ method private checkVi (v:varinfo) : bool =
+ let v' = self#getEnvVi v in
+ v.vid = v'.vid
+
+ method private checkViAndWarn (v:varinfo) =
+ if not (self#checkVi v) then
+ ignore (warn "mentioned variable %s and its entry in the current environment have different varinfo."
+ v.vname)
+
+
+ (** Get the comment out of a location if there is one *)
+ method pLineDirective ?(forcefile=false) l =
+ let ld = super#pLineDirective l in
+ if !printComments then
+ let c = String.concat "\n" (get_comments l) in
+ match c with
+ "" -> ld
+ | _ -> ld ++ line ++ text "/*" ++ text c ++ text "*/" ++ line
+ else ld
+
+ (* variable use *)
+ 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
+ match rhso with
+ Some(Call(_,e,el,l)) ->
+ (* print a call instead of a temp variable *)
+ let oldpit = super#getPrintInstrTerminator() in
+ let _ = super#setPrintInstrTerminator "" in
+ let opc = !printComments in
+ let _ = printComments := false in
+ let c = match unrollType (typeOf e) with
+ TFun(rt,_,_,_) when not (Util.equals (typeSig rt) (typeSig v.vtype)) ->
+ text "(" ++ self#pType None () v.vtype ++ text ")"
+ | _ -> nil in
+ let d = self#pInstr () (Call(None,e,el,l)) in
+ 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
+ match b with
+ PlusA | PlusPI | IndexPI ->
+ text rhsvi.vname ++ text "++"
+ | MinusA | MinusPI ->
+ text rhsvi.vname ++ text "--"
+ | _ -> E.s (E.error "zraCilPrinterClass.pVar: unexpected op for inc/dec\n")
+ else (self#checkViAndWarn v;
+ text v.vname)
+ else 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
+ match b with
+ PlusA | PlusPI | IndexPI ->
+ text rhsvi.vname ++ text "++"
+ | MinusA | MinusPI ->
+ text rhsvi.vname ++ text "--"
+ | _ -> E.s (E.error "zraCilPrinterClass.pVar: unexpected op for inc/dec\n")
+ else (self#checkViAndWarn v;
+ text v.vname)
+
+ (* variable declaration *)
+ 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
+ ignore( warn "name %s has already been declared locally with different varinfo\n" v.vname)
+ else if (H.mem genvHtbl v.vname) && not(self#checkVi v) then
+ ignore( warn "name %s has already been declared globally with different varinfo\n" v.vname)
+ else if not v.vglob then
+ (if !debug then ignore(E.log "zrapp: adding %s to local pp environment\n" v.vname);
+ H.add lenvHtbl v.vname v)
+ else
+ (if !debug then ignore(E.log "zrapp: adding %s to global pp envirnoment\n" v.vname);
+ H.add genvHtbl v.vname v) in
+ let stom, rest = separateStorageModifiers v.vattr in
+ (* First the storage modifiers *)
+ self#pLineDirective v.vdecl ++
+ text (if v.vinline then "__inline " else "")
+ ++ d_storage () v.vstorage
+ ++ (self#pAttrs () stom)
+ ++ (self#pType (Some (text v.vname)) () v.vtype)
+ ++ text " "
+ ++ self#pAttrs () rest
+
+ (* For printing deputy annotations *)
+ method pAttr (Attr (an, args) : attribute) : doc * bool =
+ if not (!deputyAttrs) then super#pAttr (Attr(an,args)) else
+ match an, args with
+ | "fancybounds", [AInt i1; AInt i2] -> nil, false
+ (*if !showBounds then
+ dprintf "BND(%a, %a)" self#pExp (getBoundsExp i1)
+ self#pExp (getBoundsExp i2), false
+ else
+ text "BND(...)", false*)
+ | "bounds", [a1; a2] ->
+ begin
+ match checkParam a1, checkParam a2 with
+ | PKThis, PKThis ->
+ text "COUNT(0)", false
+ | PKThis, PKOffset (AInt 1) ->
+ text "SAFE", false
+ | PKThis, PKOffset a -> nil, false
+ (*if !showBounds then
+ dprintf "COUNT(%a)" self#pAttrParam a, false
+ else
+ text "COUNT(...)", false*)
+ | _ -> nil, false
+ (* if !showBounds then
+ dprintf "BND(%a, %a)" self#pAttrParam a1
+ self#pAttrParam a2, false
+ else
+ text "BND(...)", false*)
+ end
+ | "fancysize", [AInt i] -> nil, false
+ (*dprintf "SIZE(%a)" self#pExp (getBoundsExp i), false*)
+ | "size", [a] ->
+ dprintf "SIZE(%a)" self#pAttrParam a, false
+ | "fancywhen", [AInt i] -> nil, false
+ (*dprintf "WHEN(%a)" self#pExp (getBoundsExp i), false*)
+ | "when", [a] ->
+ dprintf "WHEN(%a)" self#pAttrParam a, false
+ | "nullterm", [] ->
+ text "NT", false
+ | "assumeconst", [] ->
+ text "ASSUMECONST", false
+ | "trusted", [] ->
+ text "TRUSTED", false
+ | "poly", [a] ->
+ dprintf "POLY(%a)" self#pAttrParam a, false
+ | "poly", [] ->
+ text "POLY", false
+ | "sentinel", [] ->
+ text "SNT", false
+ | "nonnull", [] ->
+ text "NONNULL", false
+ | "_ptrnode", [AInt n] -> nil, false
+ (*if !Doptions.emitGraphDetailLevel >= 3 then
+ dprintf "NODE(%d)" n, false
+ else
+ nil, false*)
+ | "missing_annot", _-> (* Don't bother printing thess *)
+ nil, false
+ | _ ->
+ super#pAttr (Attr (an, args))
+
+
+ (*** GLOBALS ***)
+ 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
+ * 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
+ else nil in
+ (* Temporarily remove the function attributes *)
+ fundec.svar.vattr <- [];
+ 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 "
+ ++ (self#pType (Some (text typ.tname)) () typ.ttype)
+ ++ text ";\n"
+
+ | GEnumTag (enum, l) ->
+ self#pLineDirective l ++
+ text "enum" ++ align ++ text (" " ^ enum.ename) ++
+ self#pAttrs () enum.eattr ++ text " {" ++ line
+ ++ (docList ~sep:(chr ',' ++ line)
+ (fun (n,i, loc) ->
+ text (n ^ " = ")
+ ++ self#pExp () i)
+ () enum.eitems)
+ ++ unalign ++ line ++ text "};\n"
+
+ | GEnumTagDecl (enum, l) -> (* This is a declaration of a tag *)
+ self#pLineDirective l ++
+ text ("enum " ^ enum.ename ^ ";\n")
+
+ | GCompTag (comp, l) -> (* This is a definition of a tag *)
+ let n = comp.cname in
+ let su, su1, su2 =
+ if comp.cstruct then "struct", "str", "uct"
+ else "union", "uni", "on"
+ in
+ let sto_mod, rest_attr = separateStorageModifiers comp.cattr in
+ self#pLineDirective ~forcefile:true l ++
+ text su1 ++ (align ++ text su2 ++ chr ' ' ++ (self#pAttrs () sto_mod)
+ ++ text n
+ ++ text " {" ++ line
+ ++ ((docList ~sep:line (self#pFieldDecl ())) ()
+ comp.cfields)
+ ++ unalign)
+ ++ line ++ text "}" ++
+ (self#pAttrs () rest_attr) ++ text ";\n"
+
+ | GCompTagDecl (comp, l) -> (* This is a declaration of a tag *)
+ self#pLineDirective l ++
+ text (compFullName comp) ++ text ";\n"
+
+ | GVar (vi, io, l) ->
+ self#pLineDirective ~forcefile:true l ++
+ self#pVDecl () vi
+ ++ chr ' '
+ ++ (match io.init with
+ None -> nil
+ | Some i -> text " = " ++
+ (let islong =
+ match i with
+ CompoundInit (_, il) when List.length il >= 8 -> true
+ | _ -> false
+ in
+ 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
+ if not !printCilAsIs && H.mem builtins vi.vname then begin
+ (* Compiler builtins need no prototypes. Just print them in
+ comments. *)
+ text "/* compiler builtin: \n " ++
+ (self#pVDecl () vi)
+ ++ text "; */\n"
+
+ end else
+ self#pLineDirective l ++
+ (self#pVDecl () vi)
+ ++ text ";\n"
+
+ | GAsm (s, l) ->
+ self#pLineDirective l ++
+ text ("__asm__(\"" ^ escape_string s ^ "\");\n")
+
+ | GPragma (Attr(an, args), l) ->
+ (* sm: suppress printing pragmas that gcc does not understand *)
+ (* assume anything starting with "ccured" is ours *)
+ (* also don't print the 'combiner' pragma *)
+ (* nor 'cilnoremove' *)
+ let suppress =
+ not !print_CIL_Input &&
+ not !msvcMode &&
+ ((startsWith "box" an) ||
+ (startsWith "ccured" an) ||
+ (an = "merger") ||
+ (an = "cilnoremove")) in
+ let d =
+ match an, args with
+ | _, [] ->
+ text an
+ | "weak", [ACons (symbol, [])] ->
+ text "weak " ++ text symbol
+ | _ ->
+ text (an ^ "(")
+ ++ docList ~sep:(chr ',') (self#pAttrParam ()) () args
+ ++ text ")"
+ in
+ 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
+ text s ++ text "\n"
+ else
+ nil
+
+
+ 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
+ * 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)
+ ++ chr ';' ++ line
+ else nil in
+ fprint out 80 (proto ++ (self#pLineDirective ~forcefile:true l));
+ (* Temporarily remove the function attributes *)
+ fdec.svar.vattr <- [];
+ fprint out 80 (self#pFunDecl () fdec);
+ fdec.svar.vattr <- oldattr;
+ output_string out "\n"
+
+ | GVar (vi, {init = Some i}, l) -> begin
+ fprint out 80
+ (self#pLineDirective ~forcefile:true l ++
+ self#pVDecl () vi
+ ++ text " = "
+ ++ (let islong =
+ match i with
+ CompoundInit (_, il) when List.length il >= 8 -> true
+ | _ -> false
+ in
+ 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)
+
+ 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
+ | Some i -> text ": " ++ num i ++ text " ")
+ ++ self#pAttrs () fi.fattr
+ ++ text ";"
+
+ method private pFunDecl () f =
+ H.add genvHtbl f.svar.vname f.svar;(* add function to global env *)
+ 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 =
+ if !doElimTemps
+ then RCT.eliminate_temps f
+ else f in
+ let decls = docList ~sep:line (fun vi -> self#pVDecl () vi ++ text ";")
+ () nf.slocals in
+ self#pVDecl () nf.svar
+ ++ line
+ ++ text "{ "
+ ++ (align
+ (* locals. *)
+ ++ decls
+ ++ line ++ line
+ (* the body *)
+ ++ ((* 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) =
+ match sk with
+ | Loop(b,l,_,_) -> begin
+ (* See if we can turn this into a while(e) {} *)
+ (* TODO: See if we can turn this into a do { } while(e); *)
+ let co, bodystmts = get_loop_condition b in
+ match co with
+ | None -> super#pStmtKind next () sk
+ | Some c -> begin
+ self#pLineDirective l
+ ++ text "wh"
+ ++ (align
+ ++ text "ile ("
+ ++ self#pExp () (simpl_cond (UnOp(LNot,c,intType)))
+ ++ text ") "
+ ++ self#pBlock () {bstmts=bodystmts; battrs=b.battrs})
+ end
+ end
+ | _ -> super#pStmtKind next () sk
+
+end (* class zraCilPrinterClass *)
+
+let zraCilPrinter = new zraCilPrinterClass
+
+(* pretty print an expression *)
+let pp_exp (fd : fundec) () (e : exp) =
+ deputyAttrs := true;
+ ignore(RCT.eliminateTempsForExpPrinting fd);
+ let d = zraCilPrinter#pExp () e in
+ deputyAttrs := false;
+ d
+
+type outfile =
+ { fname : string;
+ fchan : out_channel }
+let outChannel : outfile option ref = ref None
+
+(* Processign of output file arguments *)
+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 : featureDescr =
+ { fd_name = "zrapp";
+ fd_enabled = ref false;
+ fd_description = "pretty printing with checks for name conflicts and\n\t\t\t\ttemp variable elimination";
+ fd_extraopt = [
+ "--zrapp_elim_temps",
+ Arg.Unit (fun n -> doElimTemps := true),
+ "Try to eliminate temporary variables during pretty printing";
+ "--zrapp_debug",
+ Arg.Unit (fun n -> debug := true; RD.debug := true),
+ "Lots of debugging info for pretty printing and reaching definitions";
+ "--zrapp_debug_fn",
+ Arg.String (fun s -> RD.debug_fn := s),
+ "Only output debugging info for one function";
+ "--zrapp_comments",
+ Arg.Unit (fun _ -> printComments := true),
+ "Print comments from source file in output";];
+ fd_doit =
+ (function (f: file) ->
+ lineDirectiveStyle := None;
+ printerForMaincil := zraCilPrinter);
+ fd_post_check = false
+ }
+
--- /dev/null
+val debug : bool ref
+
+val doElimTemps : bool ref
+
+val deputyAttrs : bool ref
+
+class zraCilPrinterClass : Cil.cilPrinter
+
+val zraCilPrinter : Cil.cilPrinter
+
+val pp_exp : Cil.fundec -> unit -> Cil.exp -> Pretty.doc
+
+val feature : Cil.featureDescr
--- /dev/null
+PCC
+linux
+
+optstats.results
+optstats.results.?
+optstats.log
+*.report
+
+*.o
+*.obj
+*.exe
+*.pdb
+*.ilk
+*.cpp
+*.i
+*.s
+*.asm
+*cil.c
+*.rtl
+*box.c
+*cabs.c
+*infer.c
+*_ppp.c
+*.origi
+*.stackdump
+*_all.c
+testingcil.c
+testcil.random
+__log*
+testsafec.smlog
+Makefile
+__scalar2pointer.txt
+cil.log*
+make.out
--- /dev/null
+# -*- Mode: makefile -*-
+# Makefile.in for running the test cases for the CIL compiler
+# Use from the test directory !!!
+# author: George Necula
+# hacks here and there by Wes and Scott
+
+# this Makefile makes use of several GNU Make extensions; see
+# http://www.gnu.org/manual/make/html_chapter/make_toc.html
+
+# pull in definitions from ./configure
+include ../config.mk
+
+TESTDIR := .
+
+ifneq ($(ARCHOS), x86_WIN32)
+ifneq ($(ARCHOS), x86_LINUX)
+ifneq ($(ARCHOS), sparc_SOLARIS)
+ $(error You must set the ARCHOS variable to x86_WIN32, x86_LINUX, or sparc_SOLARIS)
+endif
+endif
+endif
+
+ifndef BIG_EXAMPLES
+ BIG_EXAMPLES := ../../big-examples/
+endif
+
+defaulttarget:
+ @echo "This Makefile is intended to be run with an explicit target."
+
+
+# sm: find and remove all the intermediate files from translation
+# sm: removed *box.c from those removed since $(TESTDIR)/PCC/src/pccbox.c should be kept
+clean:
+ -find . \( \
+ -name '*~' -o \
+ -name '*.cil.c' -o \
+ -name '*.s' -o \
+ -name '*.a' -o \
+ -name '*.stackdump' -o \
+ -name '*.exe' -o \
+ -name '*.i' -o \
+ -name '*_ppp.c' -o \
+ -name '*.origi' -o \
+ -name '*.o' -o \
+ -name '*.obj' -o \
+ -name '*.cabs.c' -o \
+ -name "*-tmp.c" -o \
+ -name '*_comb*.c' -o \
+ -name 'libmerge.a*' \
+ \) -exec rm -f {} \;
+ -find . -name '*.browser' -exec rm -rf {} \;
+
+
+# sm: infer CILHOME when not set, to ease having multiple trees
+ifndef CILHOME
+ ifeq ($(ARCHOS), x86_WIN32)
+ $(error You have not defined the CILHOME variable)
+ else
+ export CILHOME := $(shell pwd)/..
+ endif
+endif
+
+CILLY := $(CILHOME)/bin/cilly
+PATCHER := $(CILHOME)/bin/patcher
+
+# Now do the user-specific customization
+# It is Ok if this file does not exist
+-include $(CILHOME)/.cilrc
+
+# as a convenience, let RELEASE=1 on the command line imply
+# all options designed to make things fast (at least when not in
+# the middle of development)
+ifdef RELEASE
+ # use native code tools
+ export NATIVECAML := 1
+ export CILLY += -O2
+endif
+
+# By default we are on Linux
+ifndef ARCHOS
+ ARCHOS := x86_WIN32
+endif
+
+# By default use the old patcher
+ifndef NEWPATCH
+ OLDPATCH := 1
+endif
+
+
+# Now include the compiler specific stuff
+ifdef _MSVC
+ include ../Makefile.msvc
+else
+ ifdef _GNUCC
+ include ../Makefile.gcc
+ endif
+endif
+
+
+CILLY += --mode=$(COMPILERNAME)
+
+export EXTRAARGS
+
+
+# CILLY contains arguments that are passed to cil
+# Pass such arguments in the command line as EXTRAARGS="..."
+# NOTE: you should *never* set EXTRAARGS within this Makefile,
+# because *any* such settings will be overridden if someone
+# specified EXTRAARGS on the command line
+CILLY+= --save-temps $(EXTRAARGS)
+
+ifndef NOCHECK
+ CILLY += --strictcheck
+endif
+
+ifdef OCAMLDEBUG
+ CILLY+= --ocamldebug
+endif
+
+ifdef NOLINES
+ CILLY+= --noPrintLn
+endif
+ifdef COMMLINES
+ CILLY+= --commPrintLn
+endif
+
+ifdef USECABS
+ CILLY+= --usecabs
+endif
+ifndef NATIVECAML
+ CILLY+= --bytecode
+endif
+ifdef VERBOSE
+ CILLY+= --verbose --warnall
+endif
+ifdef KEEPMERGED
+ CILLY+= --keepmerged
+endif
+ifdef MERGEONLY
+ CILLY+= --keepmerged --onlyMerge --mergeKeepAnnotations
+endif
+ifdef CABSONLY
+ CILLY+= --cabsonly
+endif
+
+
+# This is a way to enable the stats, allowing the command line to override it
+# Do STATS= to disable the stats.
+STATS := 1
+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
+endif
+
+# sm: this will make gcc warnings into errors; it's almost never
+# what we want, but for a particular testcase (combine_copyptrs)
+# I need it to show the difference between something which works
+# and something which will cause inference problems later
+ifdef WARNINGS_ARE_ERRORS
+ CFLAGS += -Werror
+endif
+
+
+# Enable profiling
+ifdef PROFILE
+ CILLY+= -pg
+endif
+
+# sm: use this instead of "sh ./testit" for those self-tests which can't
+# be made to work on windows; it does nothing, and has no output
+UNIXTESTIT := sh ./testit
+
+
+# ----------- below here are rules for building benchmarks --------
+
+CC_OPTIMVARIANT:= $(CC) $(DEF)_$(COMPILERNAME) \
+ $(DEF)CIL \
+ $(INC)$(CILHOME)/include \
+ $(OPT_O2)
+
+# use this dependency for those targets that must be built with GCC
+mustbegcc :
+ifndef _GNUCC
+ @echo This test case works only with _GNUCC=1; exit 3
+endif
+
+mustbelinux:
+ifneq ($(ARCHOS), x86_LINUX)
+ @echo This test case works only on Linux; exit 3
+endif
+
+
+############ Small tests
+SMALL1 := $(TESTDIR)/small1
+
+test/% : $(SMALL1)/%.c
+ cd $(SMALL1); $(CILLY) --nomerge --commPrintLn \
+ $(CONLY) $(CFLAGS) $(ASMONLY)$*.s $*.c
+ echo SUCCESS
+
+testobj/% : $(SMALL1)/%.c
+ cd $(SMALL1); $(CILLY) --nomerge --commPrintLn \
+ $(CONLY) $(CFLAGS) $(OBJOUT)$*.o $*.c
+
+testrun/% : $(SMALL1)/%.c
+ cd $(SMALL1); $(CILLY) --nomerge --commPrintLn \
+ $(CFLAGS) $(EXEOUT)$*.exe $*.c
+ cd $(SMALL1); ./$*.exe
+ echo SUCCESS
+
+#preprocessed files:
+test_i/% : $(SMALL1)/%.i
+ cd $(SMALL1); $(CILLY) --nomerge --commPrintLn \
+ $(CONLY) $(CFLAGS) $(ASMONLY)$*.s $*.i
+ echo SUCCESS
+
+
+# sm: some project members don't want the testing targets to depend
+# on quickbuild (which rebuilds translator components whose dependencies
+# have changed), and others do..
+ifdef TARGETS_DEP_QUICKBUILD
+ # with switch to test/Makefile, doesn't do what I want, so no-op
+ #TARGET_DEP := quickbuild
+ TARGET_DEP :=
+endif
+
+ifndef NOPRINTLN
+ NOPRINTLN := --commPrintLn
+endif
+
+# sm: attempt at a single rule for my testing purposes
+# gn: I added .exe so that I can delete the executables
+scott/%: $(TESTDIR)/small2/%.c $(TARGET_DEP)
+ rm -f $(TESTDIR)/small2/$*.exe
+ cd $(TESTDIR)/small2; $(CC) $(CONLY) $(CFLAGS) $(WARNALL) $*.c
+ cd $(TESTDIR)/small2; $(CILLY) --nomerge --save-temps=. \
+ $(CFLAGS) $(NOPRINTLN) \
+ $*.c \
+ $(EXEOUT)$*.exe
+ bash -c "time $(TESTDIR)/small2/$*.exe"
+
+
+# There are a few tests that CIL supports but recent versions of gcc don't.
+# So don't try calling gcc on these.
+scott-nogcc/%: $(TESTDIR)/small2/%.c $(TARGET_DEP)
+ rm -f $(TESTDIR)/small2/$*.exe
+ cd $(TESTDIR)/small2; $(CILLY) --nomerge --save-temps=. \
+ $(CFLAGS) $(NOPRINTLN) \
+ $*.c \
+ $(EXEOUT)$*.exe
+ bash -c "time $(TESTDIR)/small2/$*.exe"
+
+scott-nolink/%: $(TESTDIR)/small2/%.c $(TARGET_DEP)
+ rm -f $(TESTDIR)/small2/$*.exe
+ cd $(TESTDIR)/small2; $(CC) $(CONLY) $(WARNALL) $*.c
+ cd $(TESTDIR)/small2; $(CILLY) --nomerge $(CONLY) --save-temps=. \
+ $(CFLAGS) $(WARNALL) $(NOPRINTLN) \
+ $*.c \
+ $(EXEOUT)$*.exe
+
+
+
+ARCHOS := $(ARCHOS)
+OBJDIR := $(CILHOME)/obj/$(ARCHOS)
+ifdef NATIVECAML
+ CMXA := cmxa
+ CAMLC := ocamlopt
+else
+ CMXA := cma
+ CAMLC := ocamlc
+endif
+
+testrun/% : $(SMALL1)/%.ml
+ $(CAMLC) -noautolink -I $(OBJDIR) unix.$(CMXA) str.$(CMXA) \
+ -cclib -lunix -cclib -lstr cil.$(CMXA) \
+ $(EXEOUT) $(basename $<).exe $<
+ $(basename $<).exe
+ echo SUCCESS
+
+
+combine%: $(SMALL1)/combine%_1.c
+ cd $(SMALL1); \
+ $(CILLY) $(CFLAGS) \
+ $(notdir $(wildcard $(SMALL1)/combine$*_[1-9].c)) \
+ $(EXEOUT)combine$*.exe
+ cd $(SMALL1); ./combine$*.exe
+
+arcombine: mustbegcc
+ cd $(SMALL1); $(CILLY) -c array1.c array2.c
+ cd $(SMALL1); $(CILHOME)/bin/cilly \
+ --mode=AR --merge --verbose crv array.a array1.o array2.o
+ cd $(SMALL1); $(CILLY) -o matrix.exe array.a matrix.c
+ cd $(SMALL1); ./matrix.exe
+
+
+# ww: Scott's structs-edg-stl.c example
+structs : mustbemanju
+ cd /usr/src/big-examples/; $(CILLY) --nomerge \
+ $(CONLY) $(CFLAGS) structs-edg-stl.c
+ echo SUCCESS
+
+
+
+# sm: yet another failure-test target, this time utilizing a nomerge
+# script capable of testing multiple failures per file
+test-bad/%: $(TESTDIR)/small2/%.c $(TARGET_DEP)
+ifdef _MSVC
+ifndef RELEASE
+ @echo ">>>>> Set RELEASE=1 when using MSVC to avoid those\
+ pesky dialog boxes. <<<<<"
+endif
+endif
+ cd $(TESTDIR)/small2; \
+ CILHOME="$(CILHOME)" \
+ CILLY="$(CILLY) --nomerge --commPrintLn" \
+ CFLAGS="$(CFLAGS) $(WARNALL)" \
+ TESTBADONCE="$(TESTBADONCE)" \
+ _MSVC="$(_MSVC)" \
+ bash ../../bin/test-bad $*.c
+
+test-bad1/%: $(TESTDIR)/small1/%.c $(TARGET_DEP)
+ cd $(TESTDIR)/small1; \
+ CILHOME="$(CILHOME)" \
+ CILLY="$(CILLY) --nomerge --commPrintLn" \
+ CFLAGS=" $(CFLAGS) $(WARNALL)" \
+ TESTBADONCE="$(TESTBADONCE)" \
+ _MSVC="$(_MSVC)" \
+ bash ../../bin/test-bad $*.c
+
+
+#CCURED_NO_SIGABRT prevents cygwin from doing a memory dump on every failure
+# case.
+runall/%: $(TESTDIR)/small2/%.c $(TARGET_DEP)
+ cd $(TESTDIR)/small2; \
+ CCURED_NO_SIGABRT=1 \
+ COMMAND="$(CILLY) \
+ $(CFLAGS) $(WARNALL) __FILE__ $(EXEOUT)__BASENAME__.exe \
+ && ./__BASENAME__.exe" \
+ COMMENT="//" \
+ perl ../../ocamlutil/runall.pl $*.c
+
+
+runall_syntax/%: $(TESTDIR)/small2/%.c $(TARGET_DEP)
+ cd $(TESTDIR)/small2; \
+ CCURED_NO_SIGABRT=1 \
+ COMMAND="$(CILLY) \
+ $(CFLAGS) $(WARNALL) __FILE__ $(EXEOUT)__BASENAME__.exe \
+ && ./__BASENAME__.exe && cat __BASENAME__.cured.c" \
+ COMMENT="//" \
+ perl ../../ocamlutil/runall.pl $*.c
+
+# sm: trivial test of combiner
+MYSAFECC := $(CILLY)
+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; \
+ $(MYSAFECC) comb2.c $(CONLY) $(OBJOUT) comb2.o; \
+ $(MYSAFECC) comb3.c $(CONLY) $(OBJOUT) comb3.o; \
+ $(MYSAFECC) comb4.c $(CONLY) $(OBJOUT) comb4.o; \
+ $(MYSAFECC) comb1.o comb2.o comb3.o comb4.o $(EXEOUT)comb.exe
+ $(TESTDIR)/small2/comb.exe
+
+#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
+ rm -f $(TESTDIR)/small2/comb.exe
+ cd $(TESTDIR)/small2; \
+ gcc -E -o comb2.i comb2.c; \
+ gcc -S -o comb3.s comb3.c; \
+ gcc -c -o comb4.o comb4.c; \
+ $(MYSAFECC) comb1.c comb2.i comb3.s comb4.o $(EXEOUT)comb.exe
+ $(TESTDIR)/small2/comb.exe
+
+# sm: another merger test
+mergestruct: $(TESTDIR)/small2/mergestruct1.c $(TESTDIR)/small2/mergestruct2.c
+ cd $(TESTDIR)/small2; \
+ $(CILLY) mergestruct1.c mergestruct2.c -o mergestruct.exe
+ $(TESTDIR)/small2/mergestruct.exe
+
+# sm: yet another merger test (I know there's a target somewhere)
+mergeinline: $(TESTDIR)/small2/mergeinline1.c $(TESTDIR)/small2/mergeinline2.c
+ cd $(TESTDIR)/small2; \
+ $(CILLY) mergeinline1.c mergeinline2.c -o mergeinline.exe
+ $(TESTDIR)/small2/mergeinline.exe
+
+# sm: test of combiner's ability to report inconsistencies
+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
+ cd $(TESTDIR)/small2; \
+ $(MYSAFECC) baddef1.c $(CONLY) $(OBJOUT) baddef1.o; \
+ $(MYSAFECC) baddef2.c $(CONLY) $(OBJOUT) baddef2.o; \
+ $(MYSAFECC) baddef1.o baddef2.o $(EXEOUT)baddef.exe
+ $(TESTDIR)/small2/baddef.exe
+
+
+
+
+### Generic test
+testfile/% :
+ $(CILLY) /TC $*
+
+testdir/% :
+ make -C CC="ccured" $*
+
+
+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
+
+
+
--- /dev/null
+p*.cil
+*.cabs
+*.box
+*cured.c
+*_comb.c
+*optimcured.c
+*.o
+*.obj
+*.exe
+*.pdb
+*.ilk
+*.cpp
+*.i
+*.s
+*.asm
+*cil.c
+*box.c
+t.c
+hashtestbox
+*.rtl
+*box.c
+*infer.c
+*cil.c
+*.i
+*_ppp.c
+*.origi
+*cabs.c
+*_all.c
+ope.m
+*cured.c
+__scalar2pointer.txt
+sscanf.out
+*.stackdump
+a.out
+vararg.out
+array.a.files
+*.browser
+*.cmi
+*.cmo
+
+test-bad.err test-bad.out
+*optimcured*.c
+
+longBlock.cmx
+polystruct-tmp.c
+sscanf_string
+wchar-bad-tmp.c
+*-tmp.c
\ No newline at end of file
--- /dev/null
+# .gdbinit
+
+file vararg1.exe
+break main
+run
--- /dev/null
+int g;
+
+void F() {
+ int a;
+ if (a>5) { g = 3; }
+}
+
+int main() {
+ g = 4;
+ F();
+}
--- /dev/null
+clean:
+ rm -f *.o *.obj *.exe *.i *_ppp.c *.origi *~ *.s *.asm
+ rm -f *cured.c *cil.c *infer.c *_comb.c *cabs.c *cured.optim.c
+ rm -f *.pdb *.ilk *.stackdump a.out __scalar2pointer.txt
+ rm -f *.html *.gif *.css
+ rm -rf *.browser
\ No newline at end of file
--- /dev/null
+#include "testharness.h"
+
+int main() {
+
+ int a[10];
+
+ int (* pa)[10]; // pointer to array
+
+ int m[4][7];
+
+ // (&a) is a pointer to an array of 10 integers,
+ // a is a pointer to integer
+ if ((int)((&a)+1) != (int)(a+10)) E(1);
+
+ pa = & a;
+ if(& (pa[0][5]) != & a[5]) E(2);
+
+ if((char*)(&m + 1) != ((char*)m) + 4 * 7 * sizeof(int)) E(3);
+
+ if((char*)(&(m[2])) != (char*)(m + 2)) E(4);
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+struct qstr {
+ const unsigned char * name;
+ unsigned int len;
+ unsigned int hash;
+};
+
+struct qstr *foo(const struct qstr *p) {
+ return p;
+}
+
+int main() {
+
+ struct qstr *x = foo(&(const struct qstr) { "socket:", 7, 0 });
+ if(x->name[1] != 'o') E(1);
+
+ if(x->len != 7) E(2);
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+
+struct testalign {
+ int f1;
+} __attribute__((__aligned__(16)));
+
+struct t1 {
+ int f0;
+ struct testalign a;
+};
+
+int main() {
+ int offset;
+
+ offset = &((struct t1*)0)->a.f1;
+ printf("Offset is: %d\n", offset);
+
+ if ((int)&(( struct t1 *)0)->a.f1 & 15) {
+ E(1);
+ }
+
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+typedef unsigned int __kernel_size_t;
+
+typedef __kernel_size_t size_t;
+
+typedef unsigned int __u32;
+typedef __u32 kernel_cap_t;
+
+typedef int pid_t;
+
+typedef unsigned int __kernel_uid32_t;
+typedef unsigned int __kernel_gid32_t;
+
+typedef __kernel_uid32_t uid_t;
+
+typedef __kernel_gid32_t gid_t;
+
+typedef struct {
+ unsigned long seg;
+} mm_segment_t;
+
+struct list_head {
+ struct list_head *next, *prev;
+};
+
+typedef struct { int gcc_is_buggy; } spinlock_t;
+
+struct __wait_queue_head {
+ spinlock_t lock;
+ struct list_head task_list;
+
+};
+typedef struct __wait_queue_head wait_queue_head_t;
+
+struct timer_list {
+ struct list_head list;
+ unsigned long expires;
+ unsigned long data;
+ void (*function)(unsigned long);
+};
+
+typedef long clock_t;
+struct tms {
+ clock_t tms_utime;
+ clock_t tms_stime;
+ clock_t tms_cutime;
+ clock_t tms_cstime;
+};
+
+
+typedef struct {
+ unsigned long sig[(64 / 32 ) ];
+} sigset_t;
+
+
+struct i387_fsave_struct {
+ long cwd;
+ long swd;
+ long twd;
+ long fip;
+ long fcs;
+ long foo;
+ long fos;
+ long st_space[20];
+ long status;
+};
+
+struct i387_fxsave_struct {
+ unsigned short cwd;
+ unsigned short swd;
+ unsigned short twd;
+ unsigned short fop;
+ long fip;
+ long fcs;
+ long foo;
+ long fos;
+ long mxcsr;
+ long reserved;
+ long st_space[32];
+ long xmm_space[32];
+ long padding[56];
+} __attribute__ ((aligned (16)));
+
+struct i387_soft_struct {
+ long cwd;
+ long swd;
+ long twd;
+ long fip;
+ long fcs;
+ long foo;
+ long fos;
+ long st_space[20];
+ unsigned char ftop, changed, lookahead, no_update, rm, alimit;
+ struct info *info;
+ unsigned long entry_eip;
+};
+
+union i387_union {
+ struct i387_fsave_struct fsave;
+ struct i387_fxsave_struct fxsave;
+ struct i387_soft_struct soft;
+};
+
+struct thread_struct {
+ unsigned long esp0;
+ unsigned long eip;
+ unsigned long esp;
+ unsigned long fs;
+ unsigned long gs;
+
+ unsigned long debugreg[8];
+
+ unsigned long cr2, trap_no, error_code;
+
+ union i387_union i387;
+
+ struct vm86_struct * vm86_info;
+ unsigned long screen_bitmap;
+ unsigned long v86flags, v86mask, v86mode, saved_esp0;
+
+ int ioperm;
+ unsigned long io_bitmap[32 +1];
+};
+
+struct rlimit {
+ unsigned long rlim_cur;
+ unsigned long rlim_max;
+};
+
+
+
+
+typedef union sigval {
+ int sival_int;
+ void *sival_ptr;
+} sigval_t;
+
+
+
+typedef struct siginfo {
+ int si_signo;
+ int si_errno;
+ int si_code;
+
+ union {
+ int _pad[((128 /sizeof(int)) - 3) ];
+
+
+ struct {
+ pid_t _pid;
+ uid_t _uid;
+ } _kill;
+
+
+ struct {
+ unsigned int _timer1;
+ unsigned int _timer2;
+ } _timer;
+
+
+ struct {
+ pid_t _pid;
+ uid_t _uid;
+ sigval_t _sigval;
+ } _rt;
+
+
+ struct {
+ pid_t _pid;
+ uid_t _uid;
+ int _status;
+ clock_t _utime;
+ clock_t _stime;
+ } _sigchld;
+
+
+ struct {
+ void *_addr;
+ } _sigfault;
+
+
+ struct {
+ int _band;
+ int _fd;
+ } _sigpoll;
+ } _sifields;
+} siginfo_t;
+
+struct sigpending {
+ struct sigqueue *head, **tail;
+ sigset_t signal;
+};
+
+struct sigqueue {
+ struct sigqueue *next;
+ siginfo_t info;
+};
+
+
+
+struct task_struct {
+
+
+
+ volatile long state;
+ unsigned long flags;
+ int sigpending;
+ mm_segment_t addr_limit;
+
+
+
+ int /*struct exec_domain*/ *exec_domain;
+ volatile long need_resched;
+ unsigned long ptrace;
+
+ int lock_depth;
+
+ long counter;
+ long nice;
+ unsigned long policy;
+ int /*struct mm_struct */ *mm;
+ int has_cpu, processor;
+ unsigned long cpus_allowed;
+
+ struct list_head run_list;
+ unsigned long sleep_time;
+
+ struct task_struct *next_task, *prev_task;
+ int /*struct mm_struct */ *active_mm;
+
+
+ int /* struct linux_binfmt */ *binfmt;
+ int exit_code, exit_signal;
+ int pdeath_signal;
+
+ unsigned long personality;
+ int dumpable:1;
+ int did_exec:1;
+ pid_t pid;
+ pid_t pgrp;
+ pid_t tty_old_pgrp;
+ pid_t session;
+ pid_t tgid;
+
+ int leader;
+
+ struct task_struct *p_opptr, *p_pptr, *p_cptr, *p_ysptr, *p_osptr;
+ struct list_head thread_group;
+
+
+ struct task_struct *pidhash_next;
+ struct task_struct **pidhash_pprev;
+
+ wait_queue_head_t wait_chldexit;
+ int /* struct semaphore */ *vfork_sem;
+ unsigned long rt_priority;
+ unsigned long it_real_value, it_prof_value, it_virt_value;
+ unsigned long it_real_incr, it_prof_incr, it_virt_incr;
+ struct timer_list real_timer;
+ struct tms times;
+ unsigned long start_time;
+ long per_cpu_utime[1 ], per_cpu_stime[1 ];
+
+ unsigned long min_flt, maj_flt, nswap, cmin_flt, cmaj_flt, cnswap;
+ int swappable:1;
+
+ uid_t uid,euid,suid,fsuid;
+ gid_t gid,egid,sgid,fsgid;
+ int ngroups;
+ gid_t groups[32 ];
+ kernel_cap_t cap_effective, cap_inheritable, cap_permitted;
+ int keep_capabilities:1;
+ int /*struct user_struct */ *user;
+
+ struct rlimit rlim[11 ];
+ unsigned short used_math;
+ char comm[16];
+
+ int link_count;
+ int /*struct tty_struct */ *tty;
+ unsigned int locks;
+
+ int /*struct sem_undo */ *semundo;
+ int /*struct sem_queue */ *semsleeping;
+
+ struct thread_struct thread;
+
+ int /* struct fs_struct */ *fs;
+
+ int /* struct files_struct */ *files;
+
+ spinlock_t sigmask_lock;
+ int /* struct signal_struct */ *sig;
+
+ sigset_t blocked;
+ struct sigpending pending;
+
+ unsigned long sas_ss_sp;
+ size_t sas_ss_size;
+ int (*notifier)(void *priv);
+ void *notifier_data;
+ sigset_t *notifier_mask;
+
+
+ __u32 parent_exec_id;
+ __u32 self_exec_id;
+
+ spinlock_t alloc_lock;
+};
+
+
+static void __attribute__ ((__section__ (".text.init"))) check_fpu(void)
+{
+ if (((size_t) &(( struct task_struct *)0)-> thread.i387.fxsave ) & 15) {
+ extern void __buggy_fxsr_alignment(void);
+ __buggy_fxsr_alignment();
+ }
+
+}
+
+
+int main() {
+ int offset;
+
+
+ offset = &(( struct task_struct *)0)-> thread.i387.fxsave;
+ printf("Offset is: %d\n", offset);
+ if (((size_t) &(( struct task_struct *)0)-> thread.i387.fxsave ) & 15) {
+ check_fpu();
+ E(1);
+ }
+
+ SUCCESS;
+}
--- /dev/null
+
+//Tests for CIL's constant folding of the alignment attribute
+
+//Duplicate array declarations force CIL (and gcc) to constant-fold and
+//ensure e.g. __alignof(struct s1) equals 2:
+extern int size1[1];
+extern int size2[2];
+extern int size3[3];
+extern int size4[4];
+extern int size5[5];
+extern int size6[6];
+extern int size8[8];
+extern int size16[16];
+extern int size128[128];
+
+//has size 6, alignment 2
+struct s1 {
+ short a;
+ char b;
+ short c;
+};
+
+struct s1 __attribute__((__aligned__(1))) s1_1; //alignment 1
+struct s1 s1_2; //alignment 2
+struct s1 __attribute__((__aligned__(4))) s1_4; //alignment 4
+struct s1 __attribute__((__aligned__(4))) s1_4; //alignment 4
+struct s1 __attribute__((__aligned__(1 << 7)))
+ s1_128;//alignment 128
+extern int size1[__alignof(s1_1)];
+extern int size2[__alignof(s1_2)];
+extern int size4[__alignof(s1_4)];
+extern int size128[__alignof(s1_128)];
+
+//has size 8, alignment 4
+struct s2 {
+ short a;
+ char __attribute__((__aligned__(4))) b;
+};
+extern int size8[sizeof(struct s2)];
+extern int size4[__alignof(struct s2)];
+
+//has size 3, alignment 1
+struct s3 {
+ short a;
+ char b;
+} __attribute__((packed));
+extern int size3[sizeof(struct s3)];
+extern int size1[__alignof(struct s3)];
+
+
+struct s4 {
+ short a;
+ char b;
+};
+//The alignment is the result of rounding the size up to some system-defined
+// power of two (16)
+struct s4 __attribute__((aligned)) s4_4; //alignment 16
+extern int size4[sizeof(struct s4)];
+extern int size2[__alignof(struct s4)];
+extern int size4[sizeof(s4_4)];
+extern int size16[__alignof(s4_4)];
+
+struct s4 __attribute__((aligned(sizeof(double)/2))) s4_int;
+extern int size4[__alignof(s4_int)];
+struct s4 __attribute__((aligned(__alignof(int)))) s4_db;
+extern int size4[__alignof(s4_db)];
+
+struct s5 {
+ short a;
+ char b;
+} __attribute__((aligned)) foo;
+struct s5 s5_4; //alignment 16
+extern int size16[sizeof(s5_4)];
+extern int size16[__alignof(s5_4)];
+
+int i;
+int __attribute__((__aligned__(1)))i_1;
+
+int main() {
+ printf("%d, %d\n", sizeof(i), __alignof(i));
+ printf("%d, %d\n", sizeof(i_1), __alignof(i_1));
+ printf("%d, %d\n", sizeof(s4_4), __alignof(s4_4));
+ return 0;
+}
--- /dev/null
+#include <stdio.h>
+#include <stddef.h>
+#include <sys/stat.h>
+
+typedef struct uri_components {
+ /*
+ char * scheme ;
+ char * hostinfo ;
+ char * user ;
+ char * password ;
+ char * hostname ;
+ char * port_str ;
+ char * path ;
+ char * query ;
+ char * fragment ;
+ */
+ void * hostent ;
+ unsigned short port ;
+ unsigned int is_initialized : 1 ;
+ unsigned int dns_looked_up : 1 ;
+ unsigned int dns_resolved : 1 ;
+} uri_components;
+
+/*
+enum proxyreqtype {
+ NOT_PROXY = 0,
+ STD_PROXY = 1,
+ PROXY_PASS = 2,
+};
+*/
+
+typedef struct request_rec {
+ /*
+ void * pool ;
+ void * connection ;
+ void * server ;
+ void * next ;
+ void * prev ;
+ void * main ;
+ char * the_request ;
+ int assbackwards ;
+ enum proxyreqtype proxyreq ;
+ int header_only ;
+ char * protocol ;
+ int proto_num ;
+ char * hostname ;
+ long request_time ;
+ char * status_line ;
+ int status ;
+ char * method ;
+ int method_number ;
+ int allowed ;
+ int sent_bodyct ;
+ long bytes_sent ;
+ long mtime ;
+ int chunked ;
+ int byterange ;
+ char * boundary ;
+ char * range ;
+ long clength ;
+ long remaining ;
+ long read_length ;
+ int read_body ;
+ int read_chunked ;
+ unsigned int expecting_100 ;
+ void * headers_in ;
+ void * headers_out ;
+ void * err_headers_out ;
+ void * subprocess_env ;
+ void * notes ;
+ char * content_type ;
+ char * handler ;
+ char * content_encoding ;
+ char * content_language ;
+ void * content_languages ;
+ char * vlist_validator ;
+ int no_cache ;
+ int no_local_copy ;
+ char * unparsed_uri ;
+ char * uri ;
+ char * filename ;
+ char * path_info ;
+ char * args ;
+ struct stat finfo ;
+ */
+ uri_components parsed_uri ;
+ void * per_dir_config ;
+ /*
+ void * request_config ;
+ void * htaccess ;
+ char * case_preserved_filename ;
+ */
+} request_rec;
+
+int main() {
+ request_rec r;
+ void **offset;
+ long diff;
+
+ offset = &(r.per_dir_config);
+
+ diff = ((long) offset) - ((long)&r);
+
+ printf("offset is %ld (and should be 8 with gcc version 2.95.3 19991030 (prerelease))\n", diff);
+ return 0;
+}
--- /dev/null
+#include <stdio.h>
+#include "testharness.h"
+
+unsigned short window[65536];
+
+int set(char *buf, int value, int len) {
+ int i;
+ for (i=0;i<len;i++) buf[i] = value;
+ return i;
+}
+
+int (*fun_ptr)(char *arg1, int arg2, int arg3);
+
+int main() {
+
+ set((char *) window, 1, 10);
+
+ /*
+ if (* ((char *) window) != 1)
+ E(1);
+ */
+
+ fun_ptr = set;
+
+ fun_ptr((char *) window, 2, 10);
+
+ /*
+ if (* ((char *) window) != 2)
+ E(2);
+ */
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+int (*read_buf)(void *arg1, char *arg2, int arg3);
+
+int file_read(void *gz1, char *buf, int size) {
+ int total = 0, i;
+ for (i=0;i<size;i++)
+ total += buf[i];
+ return total;
+}
+
+int main() {
+ char mybuffer[5] = { 1, 2, 3, 4, 5}, sum = 0;
+ void *foo = 0;
+
+ read_buf = file_read;
+
+ sum = read_buf(foo, mybuffer, 5);
+
+ if (sum == 15) { SUCCESS; }
+ else { E(1); }
+}
--- /dev/null
+int main() {
+ static unsigned char buf[16];
+ unsigned char * bp = buf;
+ walk(buf,9);
+ return 0;
+}
+
+int walk(char * a, int l) {
+ int i;
+
+ for (i=0; i<l; i++) {
+ a[i] = a[i] + 1;
+ }
+ return i;
+}
+
--- /dev/null
+extern void print(char name[8]);
+
+
+void show()
+{
+ char name[8];
+ print(name);
+}
--- /dev/null
+/* name: array-size-trick.c
+ * synopsis: Check agreement of macro expansion and actual array
+ * size at compile time
+ * author: Dr. Christoph L. Spiel, Software&Systems GmbH
+ * last revision: Do Okt 14 06:03:43 UTC 2004 */
+
+
+#include <stdio.h>
+#include <stdlib.h>
+
+// This should be allowed !
+extern struct foo udp_stats_in6[2 * 2];
+
+
+
+/* Answer the number of elements in an array. */
+#define numberof(m_array) (sizeof(m_array) / sizeof(m_array[0]))
+
+
+#define ARRAY_LENGTH 3U
+
+
+/* Define an array that *must* be exactly ARRAY_LENGTH elements
+ * long. In reality this lives in file "bar.h". */
+int array[] = {9, 11, 13};
+
+
+/* Here comes the "trick": declare a constant (that never will be
+ * instantiated) twice. The two declaration will be identical, if and
+ * only if ARRAY_LENGTH == numberof(array), otherwise we get an error
+ * at compile time. In reality this also lives in file "bar.h". */
+extern const int _guard[ARRAY_LENGTH - numberof(array)];
+extern const int _guard[numberof(array) - ARRAY_LENGTH];
+
+extern int test1[3 + 5];
+extern int test1[4 + 4];
+
+int
+main(void)
+{
+ unsigned i;
+
+ for(i = 0; i < ARRAY_LENGTH; i++)
+ {
+ printf("a[%u]: %d\n", i, array[i]);
+ }
+
+ return EXIT_SUCCESS;
+}
+
--- /dev/null
+// Some problems with open arrays
+
+typedef struct bitmap {
+ unsigned long resident[13];
+ int words ;
+ int allocated_rest ;
+ unsigned long * rest; // Allocated on the heap
+} BITMAP ;
+
+typedef struct ornode {
+ int * or_const; /* A hash for the constants. For simplicity
+ * we use HASH, although something simpler
+ * might also do since the hashes are small */
+ BITMAP any; /* This corresponds to a unification variable */
+ BITMAP all; /* All of the bits in this subtree */
+} ORNODE;
+
+typedef struct andnode {
+ int count; /* How many clauses in this subtree */
+ int arity; /* The arity of the constant this belongs to */
+ union {
+ BITMAP nullary; /* If arity is 0, then a bitmap of the clauses
+ that match up till here */
+ struct ornode args[0]; /* Allocated at the end of this structure, one
+ for each argument */
+ } u;
+} ANDNODE;
+
+
+static ORNODE root; /* The root of the tree */
+int main_o(ANDNODE *a) {
+ ORNODE b = a->u.args[1];
+ return 0;
+}
--- /dev/null
+typedef double real, *realptr;
+typedef real vector[3], matrix1[3][4];
+
+
+static void testdata(void )
+{
+ vector cmr;
+ {
+ int _i;
+ for(_i = 0; _i < 3; _i++)
+ cmr[_i] = 0.0;
+ }
+}
+
+
+void radiatepiece(int s,int gral,int c, int (*rtval)[26]) {
+
+ s = rtval[2][3];
+
+}
--- /dev/null
+#include "testharness.h"
+
+//Test for arrays as function parameters.
+
+int foo(int n, int ra[2*n]) {
+ printf("sizeof(ra) = %d. sizeof(*ra) = %d\n", sizeof(ra), sizeof(*ra));
+ if (sizeof(ra) != sizeof(int*)) E(1);
+ if (sizeof(*ra) != sizeof(int)) E(2);
+ return n;
+}
+
+// Here, ra has type int (*)[100]. (Pointer to int[100])
+int test(int n, int ra[5][100]) {
+ printf("sizeof(ra) = %d. sizeof(*ra) = %d\n", sizeof(ra), sizeof(*ra));
+ if (sizeof(ra) != sizeof(int*)) E(11);
+ if (sizeof(*ra) != 100*sizeof(int)) E(12);
+ return n;
+}
+
+// Again, ra has type int (*)[100].
+int test2(int n, int ra[n][100]) {
+ printf("sizeof(ra) = %d. sizeof(*ra) = %d\n", sizeof(ra), sizeof(*ra));
+ if (sizeof(ra) != sizeof(int*)) E(21);
+ if (sizeof(*ra) != 100*sizeof(int)) E(22);
+ return n;
+}
+
+// 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);
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+// Variable-sized arrays
+void foo(int n, int a[n]);
+
+int main(void)
+{
+ int a[40];
+ foo(40, a);
+ SUCCESS;
+}
+
+//Two variable-sized arrays
+//In CIL, a is changed to a pointer, and b uses alloca
+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);
+}
+
--- /dev/null
+// arrayinitsize.c
+// from sac at stevechamberlain dot com
+//
+// an initializer of an array with unknown size implicitly
+// specifies the size (ANSI C, 6.7.8, para 22)
+//
+// NOTE: gcc-2.x does not support this, so the test harness
+// does not try to pass it through gcc before CIL
+
+void abort();
+
+struct X
+{
+ int a;
+ int b;
+ int z[];
+};
+
+struct X x = { .b = 40, .z = {3,4} };
+
+int main ()
+{
+ if (x.b != 40)
+ abort ();
+
+ // sm: my reading of the spec says this should work, but gcc-3.3
+ // does not like it (it *does* work in CIL)
+ #if 0
+ if (sizeof(x.z) / sizeof(x.z[0]) != 2)
+ abort ();
+ #endif // 0
+
+ return 0;
+}
--- /dev/null
+#include "testharness.h"
+#include <string.h>
+char a[10];
+
+__inline static char * __wes_memset_generic(char *s, char c, unsigned int count)
+{
+ int d0;
+ int d1;
+
+ __asm__ __volatile__("rep\n\t"
+ "stosb": "=&c" (d0), "=&D" (d1): "a" (c), "1" (s),
+ "0" (count): "memory");
+ return s;
+}
+
+int main() {
+ char *res;
+ int i;
+ for (i=8;i>0;i--)
+ a[i] = '!'; // force SEQ pointer
+ res = __wes_memset_generic(a, 'g', 1);
+ res = __wes_memset_generic(a+1, 'o', 2);
+ res = __wes_memset_generic(a+3, 'd', 1);
+ if (strncmp(a,"good!!!!!",10)) {
+ E(1);
+ }
+ SUCCESS;
+}
+
+
+
+
+
+
--- /dev/null
+extern __inline double atan ( double __x) {
+ register double __result;
+ __asm __volatile__ ( "fld1; fpatan"
+ : "=t" (__result) :
+ "0" (__x)
+ : "st(1)" );
+ return __result;
+}
--- /dev/null
+extern __inline double floor ( double __x ) { register long double __value; __volatile unsigned short int __cw; __volatile unsigned short int __cwtmp; __asm __volatile ("fnstcw %0" : "=m" (__cw)); __cwtmp = (__cw & 0xf3ff) | 0x0400; __asm __volatile ("fldcw %0" : : "m" (__cwtmp)); __asm __volatile ("frndint" : "=t" (__value) : "0" (__x)); __asm __volatile ("fldcw %0" : : "m" (__cw)); return __value ; }
+
+extern __inline float floorf ( float __x ) { register long double __value; __volatile unsigned short int __cw; __volatile unsigned short int __cwtmp; __asm __volatile ("fnstcw %0" : "=m" (__cw)); __cwtmp = (__cw & 0xf3ff) | 0x0400; __asm __volatile ("fldcw %0" : : "m" (__cwtmp)); __asm __volatile ("frndint" : "=t" (__value) : "0" (__x)); __asm __volatile ("fldcw %0" : : "m" (__cw)); return __value ; } extern __inline long double floorl ( long double __x ) { register long double __value; __volatile unsigned short int __cw; __volatile unsigned short int __cwtmp; __asm __volatile ("fnstcw %0" : "=m" (__cw)); __cwtmp = (__cw & 0xf3ff) | 0x0400; __asm __volatile ("fldcw %0" : : "m" (__cwtmp)); __asm __volatile ("frndint" : "=t" (__value) : "0" (__x)); __asm __volatile ("fldcw %0" : : "m" (__cw)); return __value ; }
+
--- /dev/null
+// #define __INCLUDE_ALL
+#ifdef __INCLUDE_ALL
+#else
+
+typedef signed char gint8;
+typedef unsigned char guint8;
+typedef signed short gint16;
+typedef unsigned short guint16;
+typedef signed int gint32;
+typedef unsigned int guint32;
+
+__extension__ typedef signed long long gint64;
+__extension__ typedef unsigned long long guint64;
+
+typedef char gchar;
+
+// sm: I think the intent here was just to use printf in an ordinary way,
+// not test macros; egcs doens't like this one
+//#define g_log(domain, level, format, ...) printf(format, __VA_ARGS__)
+
+// it prefers no comma, and no __VA_ARGS__
+#define g_log(domain, level, format, args...) printf(format, ## args)
+
+#endif
+
+int
+main (int argc,
+ char *argv[])
+{
+ guint16 gu16t1 = 0x44afU, gu16t2 = 0xaf44U;
+ guint32 gu32t1 = 0x02a7f109U, gu32t2 = 0x09f1a702U;
+
+ guint64 gu64t1 = (__extension__ ( 0x1d636b02300a7aa7ULL)) ,
+ 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"); }) ;
+
+ (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"); }) ;
+
+
+ (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__ ({ 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"); }) ;
+
+ return 0;
+}
+
+
--- /dev/null
+void code()
+{
+#if defined(__GNUC__) && defined(__i386__)
+ asm("pxor %%mm6, %%mm6":);
+ asm("pxor %mm6, %mm6" );
+#endif
+}
--- /dev/null
+#include "testharness.h"
+
+int x;
+
+
+//static void exit(int unused) { }
+
+int main() {
+ char p[3];
+
+ //here, p[0] is changed by the assignment. So don't reevaluate p+p[0]
+ //afterwards
+ p[0] = 0;
+ p[1] = 2;
+ p[2] = 0;
+ if (*(p + p[0]) = p[1]) {
+ x = 1;
+ } else {
+ E(1)
+ }
+
+ p[0] = 0;
+ p[1] = 2;
+ p[2] = 5;
+ if ((*(p + p[0]) = p[1]) != 2) { E(2)}
+
+ p[0] = 0;
+ p[1] = 2;
+ p[2] = 5;
+ if ((p[p[0]] = p[1]) != 2) { E(5) }
+
+ p[0] = 1;
+ p[1] = 2;
+ p[2] = 5;
+ if ((p[0] = p[p[0]]) != 2) { E(8) }
+
+ SUCCESS;
+ return 0;
+}
+
+
--- /dev/null
+struct tm {
+ int x;
+};
+
+/* Various ways to place attributes */
+char * __cdecl asctime1(const struct tm *);
+char * __stdcall asctime2(const struct tm *);
+unsigned long __cdecl _exception_code(void);
+
+__declspec(dllimport)
+unsigned long
+__stdcall
+Int64ShllMod32 (void (__stdcall *)());
+
+__inline unsigned long
+__stdcall
+Int64ShlrMod32 ( int Value);
+
+typedef struct {
+ int (__stdcall *foo)();
+} T1;
+
+typedef int (__cdecl *BAR)();
+
+int * (__stdcall * x1[8])(void); // Array of function pointers
+
+void __stdcall foo(int x) {
+ return;
+}
+
+void main() {
+ struct tm thetime;
+ BAR bar;
+ char *t1 = asctime1(& thetime);
+ char *t2 = asctime2(& thetime);
+ unsigned long l = Int64ShllMod32( & foo );
+}
+
+
--- /dev/null
+
+#pragma warning(foo:2)
+
+// Various attributes
+int array[32];
+
+int foo, bar, c;
+
+int * __attribute__((array)) p1;
+#ifdef CIL
+ int * __attribute__((test(foo ? bar : c))) p4;
+
+ // The following is about a grammar conflict with 5:6 in pragmas
+ // Too bad we have to parenthesize the (0) like that
+ int * __attribute__((test(foo ? (0) : 1))) p5;
+
+ int * __attribute__((test(foo ? bar : 1))) p6;
+
+
+ int * __attribute__((test(&array))) p2;
+ int * __attribute__((test(&array[0]))) p3;
+#endif
+
+int main() {
+ return 0;
+}
--- /dev/null
+//Make sure we parse 1UL in attributs
+
+//from linux-2.6.17.1/kernel/power/power.h.
+struct swsusp_info {
+ unsigned int version_code;
+ unsigned long num_physpages;
+ int cpus;
+ unsigned long image_pages;
+ unsigned long pages;
+ unsigned long size;
+} __attribute__((aligned((1UL << 12))));
+
+struct swsusp_info global;
+
--- /dev/null
+
+//Openssh 4.3p2 uses an empty attribute:
+int strnvis(char *, const char *, unsigned int, int) __attribute__ (());
+
+int main() {
+ strnvis(0,0,0,0);
+}
--- /dev/null
+//The following code occurs in linux-2.6.17.1 in drivers/char/ip2/i2pack.h:
+typedef struct _i2DataHeader
+{
+ // For incoming data, indicates whether this is an ordinary packet or a
+ // special one (e.g., hot key hit).
+ unsigned i2sId : 2 __attribute__ ((__packed__));
+};
--- /dev/null
+
+__attribute__ ((regparm(0)))
+ int printk (const char * fmt, ...)
+ __attribute__ ((format (printf, 1, 2)));
+
+
+ void do_exit(long error_code)
+ __attribute__((noreturn)) ;
+
+ __attribute__((noreturn)) void do_exit1(long error_code) ;
+
+
+const char __module_parm_vidmem [] __attribute__((section(".modinfo"))) = "parm_" "vidmem" "=" "i" ;
+
+__attribute__((section(".t1sec"))) char t1[5], t2[6];
+
+
+/* A pointer toa function that does not return */
+void ( * pexit)(int err) __attribute__((noreturn)) ;
+
+
+
+extern int * functional(void) __attribute__((__const__));
+
+int (*ptr_printk) (const char * fmt, ...)
+ __attribute__ ((format (printf, 1, 2)));
+
+struct s{
+ int (*printfun) (const char * fmt, ...)
+ __attribute__ ((format (printf, 1, 2)));
+};
+
+int main() {
+ struct s printstruct = {&printk};
+ printk("fooo %s", "bau");
+ ptr_printk = &printk;
+ ptr_printk("fooo %s", "bau");
+ printstruct.printfun("fooo %s", "bau");
+
+ { int k = __module_parm_vidmem[3]; }
+ functional();
+ do_exit(5);
+}
--- /dev/null
+/* Test the parsing of types */
+#define NORET __attribute__((noreturn))
+#define SECTION __attribute__((section("foo")))
+#define A(n) __attribute__((a(n)))
+#define A1 A(1)
+#define A2 A(2)
+#define A3 A(3)
+#define A4 A(4)
+#define A5 A(5)
+#define A6 A(6)
+#define A7 A(7)
+#define A8 A(8)
+#define A9 A(9)
+#define N __attribute__((name))
+
+
+
+/* Array (A1) of pointers (A2) to functions (A3) that take an int (A4) and
+ * return a pointer (A5) to int (A6) */
+int A6 * A5 (A3 * A2 (A1 x1)[5])(int A4) N;
+
+
+/* A function (A4) that takes a float (A5) and returns a pointer (A6) to an
+ * int (A7) */
+extern int A7 * A6 (A4 x2)(float A5 x) N;
+
+/* A function (A1) that takes a int (A2) and that returns a pointer (A3) to
+ * a function (A4) that takes a float (A5) and returns a pointer (A6) to an
+ * int (A7) */
+int A7 * A6 (A4 * A3 (A1 x3)(int A2 x))(float A5) {
+ return & x2;
+}
--- /dev/null
+#include "testharness.h"
+
+typedef struct {
+ int f1;
+ char f1pad;
+ int f2 __attribute__((packed)), f3 __attribute__((packed));
+ char f2pad;
+ int f4, f5 __attribute__((packed)); // Only f5 is packed
+ char f3pad;
+ int __attribute__((packed)) f6, f7; // Both f6 and f7 are packed
+} STR;
+
+
+#define offsetof(f,t) ((int)(&((t*)(0))->f))
+
+
+int main() {
+ printf("Offset 1 = %d\n", offsetof(f1, STR));
+ printf("Offset 2 = %d\n", offsetof(f2, STR));
+ printf("Offset 3 = %d\n", offsetof(f3, STR));
+ printf("Offset 4 = %d\n", offsetof(f4, STR));
+ printf("Offset 5 = %d\n", offsetof(f5, STR));
+ printf("Offset 6 = %d\n", offsetof(f6, STR));
+ printf("Offset 7 = %d\n", offsetof(f7, STR));
+
+ if(offsetof(f1, STR) != 0 ||
+ offsetof(f2, STR) != 5 ||
+ offsetof(f3, STR) != 9 ||
+ offsetof(f4, STR) != 16 ||
+ offsetof(f5, STR) != 20 ||
+ offsetof(f6, STR) != 25 ||
+ offsetof(f7, STR) != 29) {
+ return 1;
+ }
+
+ return 0;
+}
--- /dev/null
+#include "testharness.h"
+
+int x;
+int * myfunc(void) __attribute__((section(".modinfo"))) {
+ return &x;
+}
+
+int main() {
+ if(&x != myfunc()) E(1);
+
+ SUCCESS;
+}
--- /dev/null
+// From emacs
+typedef int md5_uint32;
+
+struct md5_ctx
+{
+ md5_uint32 A;
+ md5_uint32 B;
+ md5_uint32 C;
+ md5_uint32 D;
+
+ md5_uint32 total[2];
+ md5_uint32 buflen;
+ char buffer[128] __attribute__ ((__aligned__ (__alignof__ (md5_uint32))));
+};
--- /dev/null
+typedef enum {
+ unused, mode, motion, report
+} command_types;
+
+
+// The attribute unused is shadowed by an enumeration
+
+int * foo __attribute__ ((unused)) = 0;
--- /dev/null
+void foo(char * x) __attribute__((__volatile__));
+void foo(char * x) {
+ while(1) { ; }
+}
+
+int main(int argc, char **argv) {
+ foo(0);
+ return 0;
+}
+
--- /dev/null
+//Some uses of attributes in initramfs.c in the 2.6 linux kernel:
+
+//The attribute should go on the variables, not the enum type.
+static __attribute__ ((__section__ (".init.data"))) enum state {
+ Start,
+ Collect,
+ GotHeader,
+ SkipIt,
+ GotName,
+ CopyFile,
+ GotSymlink,
+ Reset
+} state, next_state;
+
+
+
+
+//This attribute belongs to the function, not the return type:
+int __attribute__((noinline)) inflate_fixed(void){
+ return 0;
+}
+
+
+int main() {
+ state = Reset;
+ return 0;
+}
+
+///////////////////////////////////////////////////////////////////////////
+
+//More tests of the section attribute: (not in initramfs.c)
+__attribute__ ((__section__ (".init.data"))) enum state state2;
+enum state __attribute__ ((__section__ (".init.data"))) state3;
+
+__attribute__ ((__section__ (".init.data"))) struct foo {
+ int field;
+} mystruct;
+
+static __attribute__ ((__section__ (".init.data"))) union {
+ int field;
+} myunion;
+
+
+int test() {
+ state2 = state3 = Reset;
+ myunion.field = 15;
+ return 0;
+}
+
--- /dev/null
+struct conn_rec {
+ void * first_field;
+ /*
+ unsigned aborted : 1;
+ signed int keepalive : 2;
+ unsigned keptalive : 1;
+ */
+ signed int double_reverse : 2;
+ int last_field ;
+} ;
+
+int main(int argc, char *argv[]) {
+ struct conn_rec c;
+
+ printf("%d\n",c.last_field);
+ return 0;
+}
--- /dev/null
+/* Weimer: bind-based testcase for "Bug: handleFormatString"
+ * Look for:
+ * input.c:222: Bug: handleFormatString
+ * Markptr: instruction error (Errormsg.Error) at bind-formatstring.c:227
+ * run: ccured.asm.exe --curetype infer --assumePrintf input.c
+ */
+typedef enum __anonenum_isc_boolean_t_16 isc_boolean_t;
+typedef enum __anonenum_isc_assertiontype_t_17 isc_assertiontype_t;
+typedef struct isc_log isc_log_t;
+typedef struct isc_mem isc_mem_t;
+typedef struct isc_netaddr isc_netaddr_t;
+typedef unsigned int isc_result_t;
+typedef struct dns_acl dns_acl_t;
+typedef struct dns_aclelement dns_aclelement_t;
+typedef struct dns_name dns_name_t;
+typedef enum __anonenum_dns_aclelemettype_t_53 dns_aclelemettype_t;
+typedef struct dns_aclipprefix dns_aclipprefix_t;
+struct dns_aclipprefix
+{
+ isc_netaddr_t address;
+ unsigned int prefixlen;
+};
+union __anonunion_u_54
+{
+ dns_aclipprefix_t ip_prefix;
+ dns_name_t keyname;
+ dns_acl_t *nestedacl;
+};
+struct dns_aclelement
+{
+ dns_aclelemettype_t type;
+ isc_boolean_t negative;
+ union __anonunion_u_54 u;
+};
+struct dns_acl
+{
+ dns_aclelement_t *elements;
+ unsigned int length;
+};
+typedef struct cfg_type cfg_type_t;
+typedef struct cfg_obj cfg_obj_t;
+typedef struct cfg_listelt cfg_listelt_t;
+typedef struct ns_aclconfctx ns_aclconfctx_t;
+void (*isc_assertion_failed) (char const *, int, isc_assertiontype_t,
+ char const *);
+
+isc_log_t *dns_lctx;
+void (cfg_obj_log) (cfg_obj_t * obj, isc_log_t * lctx, int level,
+ char const *fmt, ...);
+cfg_type_t cfg_type_keyref;
+isc_result_t
+ns_acl_fromconfig (cfg_obj_t * caml, cfg_obj_t * cctx, ns_aclconfctx_t * ctx,
+ isc_mem_t * mctx, dns_acl_t ** target)
+{
+ isc_result_t result;
+ unsigned int count;
+ dns_acl_t *dacl;
+ dns_aclelement_t *de;
+ cfg_listelt_t *elt;
+ int tmp;
+ cfg_obj_t *ce;
+ cfg_obj_t *tmp___0;
+ isc_boolean_t tmp___1;
+ char *name;
+ char *tmp___2;
+ int tmp___3;
+ int tmp___4;
+ int tmp___5;
+ int tmp___6;
+ isc_boolean_t tmp___7;
+ isc_boolean_t tmp___8;
+ isc_boolean_t tmp___9;
+ isc_boolean_t tmp___10;
+ {
+ dacl = (dns_acl_t *) ((void *) 0);
+ if ((unsigned long) target != (unsigned long) ((void *) 0))
+ {
+ if ((unsigned long) (*target) == (unsigned long) ((void *) 0))
+ {
+ tmp = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "aclconf.c", 148, 0,
+ (char const *)
+ "target != ((void *)0) && *target == ((void *)0)");
+ tmp = 0;
+ }
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "aclconf.c", 148, 0,
+ (char const *)
+ "target != ((void *)0) && *target == ((void *)0)");
+ tmp = 0;
+ }
+ count = 0U;
+ elt = cfg_list_first (caml);
+ while ((unsigned long) elt != (unsigned long) ((void *) 0))
+ {
+ count++;
+ elt = cfg_list_next (elt);
+ }
+ result = dns_acl_create (mctx, (int) count, &dacl);
+ if (result != 0U)
+ {
+ return (result);
+ }
+ de = dacl->elements;
+ elt = cfg_list_first (caml);
+ while ((unsigned long) elt != (unsigned long) ((void *) 0))
+ {
+ tmp___0 = cfg_listelt_value (elt);
+ ce = tmp___0;
+ tmp___1 = cfg_obj_istuple (ce);
+ if (tmp___1)
+ {
+ ce = cfg_tuple_get (ce, (char const *) "value");
+ de->negative = 1;
+ }
+ else
+ {
+ de->negative = 0;
+ }
+ tmp___10 = cfg_obj_isnetprefix (ce);
+ if (tmp___10)
+ {
+ de->type = 0;
+ cfg_obj_asnetprefix (ce, &de->u.ip_prefix.address,
+ &de->u.ip_prefix.prefixlen);
+ }
+ else
+ {
+ tmp___9 =
+ cfg_obj_istype (ce, (cfg_type_t const *) (&cfg_type_keyref));
+ if (tmp___9)
+ {
+ de->type = 1;
+ dns_name_init (&de->u.keyname,
+ (unsigned char *) ((void *) 0));
+ result = convert_keyname (ce, mctx, &de->u.keyname);
+ if (result != 0U)
+ {
+ goto cleanup;
+ }
+ }
+ else
+ {
+ tmp___8 = cfg_obj_islist (ce);
+ if (tmp___8)
+ {
+ de->type = 2;
+ result =
+ ns_acl_fromconfig (ce, cctx, ctx, mctx,
+ &de->u.nestedacl);
+ if (result != 0U)
+ {
+ goto cleanup;
+ }
+ }
+ else
+ {
+ tmp___7 = cfg_obj_isstring (ce);
+ if (tmp___7)
+ {
+ tmp___2 = cfg_obj_asstring (ce);
+ name = tmp___2;
+ tmp___6 =
+ strcasecmp ((char const *) name,
+ (char const *) "localhost");
+ if (tmp___6 == 0)
+ {
+ de->type = 3;
+ }
+ else
+ {
+ tmp___5 =
+ strcasecmp ((char const *) name,
+ (char const *) "localnets");
+ if (tmp___5 == 0)
+ {
+ de->type = 4;
+ }
+ else
+ {
+ tmp___4 =
+ strcasecmp ((char const *) name,
+ (char const *) "any");
+ if (tmp___4 == 0)
+ {
+ de->type = 5;
+ }
+ else
+ {
+ tmp___3 =
+ strcasecmp ((char const *) name,
+ (char const *) "none");
+ if (tmp___3 == 0)
+ {
+ de->type = 5;
+ if (de->negative)
+ {
+ de->negative = 0;
+ }
+ else
+ {
+ de->negative = 1;
+ }
+ }
+ else
+ {
+ de->type = 2;
+ result =
+ convert_named_acl (ce, cctx, ctx,
+ mctx,
+ &de->u.
+ nestedacl);
+ if (result != 0U)
+ {
+ goto cleanup;
+ }
+ }
+ }
+ }
+ }
+ }
+ else
+ {
+ cfg_obj_log (ce, dns_lctx, -3,
+ (char const *)
+ "address match list contains unsupported element type");
+ result = 25U;
+ goto cleanup;
+ }
+ }
+ }
+ }
+ de++;
+ dacl->length++;
+ elt = cfg_list_next (elt);
+ }
+ (*target) = dacl;
+ return (0U);
+ cleanup:dns_acl_detach (&dacl);
+ return (result);
+ }
+}
--- /dev/null
+// bind-used-not-defined.c:1316: label `cleanup' used but not defined
+typedef unsigned short isc_uint16_t;
+typedef unsigned int isc_uint32_t;
+typedef enum __anonenum_isc_boolean_t_16 isc_boolean_t;
+typedef enum __anonenum_isc_assertiontype_t_17 isc_assertiontype_t;
+typedef struct isc_buffer isc_buffer_t;
+typedef struct isc_event isc_event_t;
+typedef unsigned int isc_eventtype_t;
+typedef struct isc_interval isc_interval_t;
+typedef struct isc_log isc_log_t;
+typedef struct isc_logcategory isc_logcategory_t;
+typedef struct isc_logmodule isc_logmodule_t;
+typedef struct isc_mem isc_mem_t;
+typedef struct isc_netaddr isc_netaddr_t;
+typedef struct isc_quota isc_quota_t;
+typedef struct isc_region isc_region_t;
+typedef unsigned int isc_result_t;
+typedef struct isc_sockaddr isc_sockaddr_t;
+typedef struct isc_socket isc_socket_t;
+typedef struct isc_socketevent isc_socketevent_t;
+typedef struct isc_task isc_task_t;
+typedef struct isc_time isc_time_t;
+typedef struct isc_timer isc_timer_t;
+typedef int isc_mutex_t;
+struct __anonstruct_isc__magic_t_22
+{
+ unsigned int magic;
+};
+typedef struct __anonstruct_isc__magic_t_22 isc__magic_t;
+typedef unsigned short sa_family_t;
+struct sockaddr
+{
+ sa_family_t sa_family;
+};
+struct in6_pktinfo
+{
+ struct in6_addr ipi6_addr;
+};
+struct isc_region
+{
+ unsigned char *base;
+ unsigned int length;
+};
+typedef struct dns_acl dns_acl_t;
+typedef struct dns_aclelement dns_aclelement_t;
+typedef struct dns_aclenv dns_aclenv_t;
+typedef struct dns_dispatch dns_dispatch_t;
+typedef struct dns_message dns_message_t;
+typedef isc_uint16_t dns_messageid_t;
+typedef struct dns_name dns_name_t;
+typedef isc_uint16_t dns_rcode_t;
+typedef isc_uint16_t dns_rdataclass_t;
+typedef struct dns_rdataset dns_rdataset_t;
+typedef struct dns_resolver dns_resolver_t;
+typedef struct dns_tsig_keyring dns_tsig_keyring_t;
+typedef isc_uint32_t dns_ttl_t;
+typedef struct dns_view dns_view_t;
+struct __anonstruct_dns_viewlist_t_34
+{
+ dns_view_t *head;
+};
+typedef struct __anonstruct_dns_viewlist_t_34 dns_viewlist_t;
+struct isc_event
+{
+ isc_eventtype_t ev_type;
+ void *ev_arg;
+ void *ev_sender;
+};
+typedef isc_uint32_t isc_stdtime_t;
+union __anonunion_type_55
+{
+ struct sockaddr sa;
+};
+struct isc_sockaddr
+{
+ union __anonunion_type_55 type;
+};
+struct isc_socketevent
+{
+ isc_eventtype_t ev_type;
+ void *ev_arg;
+ isc_result_t result;
+ unsigned int n;
+ isc_region_t region;
+ isc_sockaddr_t address;
+ struct in6_pktinfo pktinfo;
+ isc_uint32_t attributes;
+};
+struct dns_message
+{
+ dns_messageid_t id;
+ dns_rcode_t rcode;
+ unsigned int opcode;
+ dns_rdataclass_t rdclass;
+ dns_rcode_t tsigstatus;
+};
+struct dns_rdataset
+{
+ dns_rdataclass_t rdclass;
+ dns_ttl_t ttl;
+};
+struct __anonstruct_link_78
+{
+ struct dns_view *next;
+};
+struct dns_view
+{
+ dns_rdataclass_t rdclass;
+ char *name;
+ dns_resolver_t *resolver;
+ isc_boolean_t recursion;
+ dns_acl_t *recursionacl;
+ dns_acl_t *matchclients;
+ dns_acl_t *matchdestinations;
+ isc_boolean_t matchrecursiveonly;
+ struct __anonstruct_link_78 link;
+};
+typedef struct ns_client ns_client_t;
+typedef struct ns_clientmgr ns_clientmgr_t;
+typedef struct ns_server ns_server_t;
+typedef struct ns_interface ns_interface_t;
+struct ns_interface
+{
+ isc_sockaddr_t addr;
+};
+struct dns_tcpmsg
+{
+ isc_buffer_t buffer;
+ isc_result_t result;
+};
+typedef struct dns_tcpmsg dns_tcpmsg_t;
+struct __anonstruct_client_list_t_87
+{
+ ns_client_t *head;
+ ns_client_t *tail;
+};
+typedef struct __anonstruct_client_list_t_87 client_list_t;
+struct __anonstruct_link_89
+{
+ ns_client_t *prev;
+ ns_client_t *next;
+};
+struct ns_client
+{
+ unsigned int magic;
+ isc_mem_t *mctx;
+ ns_clientmgr_t *manager;
+ int state;
+ int newstate;
+ int naccepts;
+ int nreads;
+ int nsends;
+ int nrecvs;
+ int nctls;
+ int references;
+ unsigned int attributes;
+ isc_task_t *task;
+ dns_view_t *view;
+ dns_dispatch_t *dispatch;
+ isc_socket_t *udpsocket;
+ isc_socket_t *tcplistener;
+ isc_socket_t *tcpsocket;
+ unsigned char *tcpbuf;
+ dns_tcpmsg_t tcpmsg;
+ isc_boolean_t tcpmsg_valid;
+ isc_timer_t *timer;
+ isc_boolean_t timerset;
+ dns_message_t *message;
+ isc_socketevent_t *sendevent;
+ isc_socketevent_t *recvevent;
+ unsigned char *recvbuf;
+ dns_rdataset_t *opt;
+ isc_uint16_t udpsize;
+ isc_uint16_t extflags;
+ isc_stdtime_t requesttime;
+ isc_stdtime_t now;
+ dns_name_t signername;
+ dns_name_t *signer;
+ isc_boolean_t mortal;
+ isc_quota_t *tcpquota;
+ isc_quota_t *recursionquota;
+ ns_interface_t *interface;
+ isc_sockaddr_t peeraddr;
+ isc_boolean_t peeraddr_valid;
+ struct in6_pktinfo pktinfo;
+ struct __anonstruct_link_89 link;
+ client_list_t *list;
+};
+struct ns_server
+{
+ dns_acl_t *blackholeacl;
+ dns_aclenv_t aclenv;
+ dns_viewlist_t viewlist;
+};
+struct ns_clientmgr
+{
+ isc_mutex_t lock;
+ isc_boolean_t exiting;
+ client_list_t active;
+ client_list_t inactive;
+};
+void (*isc_assertion_failed) (char const *, int, isc_assertiontype_t,
+ char const *);
+isc_logcategory_t dns_categories[11];
+ns_server_t *ns_g_server;
+isc_log_t *ns_g_lctx;
+isc_logcategory_t *ns_g_categories;
+isc_logmodule_t *ns_g_modules;
+static isc_boolean_t
+exit_check (ns_client_t * client)
+{
+ ns_clientmgr_t *locked_manager;
+ ns_clientmgr_t *destroy_manager;
+ int tmp;
+ int tmp___0;
+ int tmp___1;
+ isc_socket_t *socket___0;
+ int tmp___2;
+ int tmp___3;
+ int tmp___4;
+ int tmp___6;
+ int tmp___7;
+ int tmp___8;
+ int tmp___9;
+ int tmp___11;
+ isc_mutex_t tmp___12;
+ int tmp___13;
+ int tmp___14;
+ int tmp___15;
+ int tmp___16;
+ int tmp___17;
+ isc_boolean_t tmp___18;
+ int tmp___19;
+ ns_clientmgr_t *manager;
+ int tmp___21;
+ isc_mutex_t tmp___22;
+ int tmp___23;
+ int tmp___24;
+ int tmp___25;
+ int tmp___26;
+ int tmp___27;
+ {
+ locked_manager = (ns_clientmgr_t *) ((void *) 0);
+ destroy_manager = (ns_clientmgr_t *) ((void *) 0);
+ if ((unsigned long) client != (unsigned long) ((void *) 0))
+ {
+ if (((isc__magic_t const *) client)->magic == 1314079587U)
+ {
+ tmp = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 205, 0,
+ (char const *)
+ "(((client) != ((void *)0)) && (((const isc__magic_t *)(client))->magic == ( ((\'N\') << 24 | (\'S\') << 16 | (\'C\') << 8 | (\'c\')))))");
+ tmp = 0;
+ }
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 205, 0,
+ (char const *)
+ "(((client) != ((void *)0)) && (((const isc__magic_t *)(client))->magic == ( ((\'N\') << 24 | (\'S\') << 16 | (\'C\') << 8 | (\'c\')))))");
+ tmp = 0;
+ }
+ if (client->state <= client->newstate)
+ {
+ return (0);
+ }
+ if (client->newstate < 4)
+ {
+ tmp___0 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 210, 2,
+ (char const *) "client->newstate < 4");
+ tmp___0 = 0;
+ }
+ if (client->newstate == 0)
+ {
+ if ((unsigned long) client->view != (unsigned long) ((void *) 0))
+ {
+ dns_view_detach (&client->view);
+ }
+ }
+ if (client->state == 4)
+ {
+ if (client->newstate <= 3)
+ {
+ tmp___1 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 226, 2,
+ (char const *)
+ "client->newstate <= 3");
+ tmp___1 = 0;
+ }
+ if (client->nsends > 0)
+ {
+ if ((client->attributes & 1U) != 0U)
+ {
+ socket___0 = client->tcpsocket;
+ }
+ else
+ {
+ socket___0 = client->udpsocket;
+ }
+ isc_socket_cancel (socket___0, client->task, 2U);
+ }
+ if (client->nsends == 0)
+ {
+ if (client->nrecvs == 0)
+ {
+ if (!(client->references == 0))
+ {
+ return (1);
+ }
+ }
+ else
+ {
+ return (1);
+ }
+ }
+ else
+ {
+ return (1);
+ }
+ ns_client_endrequest (client);
+ client->state = 3;
+ if ((unsigned long) client->recursionquota ==
+ (unsigned long) ((void *) 0))
+ {
+ tmp___2 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 256, 2,
+ (char const *)
+ "client->recursionquota == ((void *)0)");
+ tmp___2 = 0;
+ }
+ if (3 == client->newstate)
+ {
+ client_read (client);
+ client->newstate = 9;
+ return (1);
+ }
+ }
+ if (client->state == 3)
+ {
+ if ((unsigned long) client->recursionquota ==
+ (unsigned long) ((void *) 0))
+ {
+ tmp___3 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 269, 2,
+ (char const *)
+ "client->recursionquota == ((void *)0)");
+ tmp___3 = 0;
+ }
+ if (client->newstate <= 2)
+ {
+ tmp___4 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 270, 2,
+ (char const *)
+ "client->newstate <= 2");
+ tmp___4 = 0;
+ }
+ if (client->nreads > 0)
+ {
+ dns_tcpmsg_cancelread (&client->tcpmsg);
+ }
+ if (!client->nreads == 0)
+ {
+ return (1);
+ }
+ if (client->tcpmsg_valid)
+ {
+ dns_tcpmsg_invalidate (&client->tcpmsg);
+ client->tcpmsg_valid = 0;
+ }
+ if ((unsigned long) client->tcpsocket != (unsigned long) ((void *) 0))
+ {
+ ns_client_log (client, ns_g_categories + 1, ns_g_modules + 1, 3,
+ (char const *) "%s", "closetcp");
+ isc_socket_detach (&client->tcpsocket);
+ }
+ if ((unsigned long) client->tcpquota != (unsigned long) ((void *) 0))
+ {
+ isc_quota_detach (&client->tcpquota);
+ }
+ if (client->timerset)
+ {
+ isc_timer_reset (client->timer, 2, (isc_time_t *) ((void *) 0),
+ (isc_interval_t *) ((void *) 0), 1);
+ client->timerset = 0;
+ }
+ client->peeraddr_valid = 0;
+ client->state = 2;
+ if ((unsigned long) client->recursionquota ==
+ (unsigned long) ((void *) 0))
+ {
+ tmp___6 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 300, 2,
+ (char const *)
+ "client->recursionquota == ((void *)0)");
+ tmp___6 = 0;
+ }
+ ns_client_checkactive (client);
+ if (2 == client->newstate)
+ {
+ if ((client->attributes & 1U) != 0U)
+ {
+ client_accept (client);
+ }
+ else
+ {
+ client_udprecv (client);
+ }
+ client->newstate = 9;
+ return (1);
+ }
+ }
+ if (client->state == 2)
+ {
+ if (client->newstate <= 1)
+ {
+ tmp___7 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 321, 2,
+ (char const *)
+ "client->newstate <= 1");
+ tmp___7 = 0;
+ }
+ if (client->naccepts > 0)
+ {
+ isc_socket_cancel (client->tcplistener, client->task, 4U);
+ }
+ if (!(client->naccepts == 0))
+ {
+ return (1);
+ }
+ if (client->nrecvs > 0)
+ {
+ isc_socket_cancel (client->udpsocket, client->task, 1U);
+ }
+ if (!(client->nrecvs == 0))
+ {
+ return (1);
+ }
+ if (client->nctls > 0)
+ {
+ return (1);
+ }
+ if (client->interface)
+ {
+ ns_interface_detach (&client->interface);
+ }
+ if (client->naccepts == 0)
+ {
+ tmp___8 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 353, 2,
+ (char const *)
+ "client->naccepts == 0");
+ tmp___8 = 0;
+ }
+ if ((unsigned long) client->recursionquota ==
+ (unsigned long) ((void *) 0))
+ {
+ tmp___9 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 354, 2,
+ (char const *)
+ "client->recursionquota == ((void *)0)");
+ tmp___9 = 0;
+ }
+ if ((unsigned long) client->tcplistener !=
+ (unsigned long) ((void *) 0))
+ {
+ isc_socket_detach (&client->tcplistener);
+ }
+ if ((unsigned long) client->udpsocket != (unsigned long) ((void *) 0))
+ {
+ isc_socket_detach (&client->udpsocket);
+ }
+ if ((unsigned long) client->dispatch != (unsigned long) ((void *) 0))
+ {
+ dns_dispatch_detach (&client->dispatch);
+ }
+ client->attributes = 0U;
+ client->mortal = 0;
+ while (1)
+ {
+ tmp___12 = (client->manager)->lock;
+ (client->manager)->lock++;
+ if (tmp___12 == 0)
+ {
+ tmp___11 = 0;
+ }
+ else
+ {
+ tmp___11 = 34;
+ }
+ if (tmp___11 == 0)
+ {
+ tmp___13 = 1;
+ }
+ else
+ {
+ isc_error_runtimecheck ((char const *) "client.c", 367,
+ (char const *)
+ "((*((&client->manager->lock)))++ == 0 ? 0 : 34) == 0");
+ tmp___13 = 0;
+ }
+ break;
+ }
+ locked_manager = client->manager;
+ while (1)
+ {
+ while (1)
+ {
+ if ((unsigned long) client->link.next !=
+ (unsigned long) ((void *) 0))
+ {
+ (client->link.next)->link.prev = client->link.prev;
+ }
+ else
+ {
+ (client->list)->tail = client->link.prev;
+ }
+ if ((unsigned long) client->link.prev !=
+ (unsigned long) ((void *) 0))
+ {
+ (client->link.prev)->link.next = client->link.next;
+ }
+ else
+ {
+ (client->list)->head = client->link.next;
+ }
+ client->link.prev = (ns_client_t *) ((void *) -1);
+ client->link.next = (ns_client_t *) ((void *) -1);
+ break;
+ }
+ break;
+ }
+ while (1)
+ {
+ while (1)
+ {
+ if ((unsigned long) (client->manager)->inactive.tail !=
+ (unsigned long) ((void *) 0))
+ {
+ ((client->manager)->inactive.tail)->link.next = client;
+ }
+ else
+ {
+ (client->manager)->inactive.head = client;
+ }
+ client->link.prev = (client->manager)->inactive.tail;
+ client->link.next = (ns_client_t *) ((void *) 0);
+ (client->manager)->inactive.tail = client;
+ break;
+ }
+ break;
+ }
+ client->list = &(client->manager)->inactive;
+ client->state = 1;
+ if ((unsigned long) client->recursionquota ==
+ (unsigned long) ((void *) 0))
+ {
+ tmp___14 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 380, 2,
+ (char const *)
+ "client->recursionquota == ((void *)0)");
+ tmp___14 = 0;
+ }
+ if (client->state == client->newstate)
+ {
+ client->newstate = 9;
+ goto unlock;
+ }
+ }
+ if (client->state == 1)
+ {
+ if (client->newstate == 0)
+ {
+ tmp___15 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 389, 2,
+ (char const *)
+ "client->newstate == 0");
+ tmp___15 = 0;
+ }
+ if (client->state == 1)
+ {
+ tmp___16 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 398, 0,
+ (char const *) "client->state == 1");
+ tmp___16 = 0;
+ }
+ if ((unsigned long) client->recursionquota ==
+ (unsigned long) ((void *) 0))
+ {
+ tmp___17 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 400, 2,
+ (char const *)
+ "client->recursionquota == ((void *)0)");
+ tmp___17 = 0;
+ }
+ ns_query_free (client);
+ while (1)
+ {
+ isc__mem_put (client->mctx, (void *) client->recvbuf, 4096U);
+ client->recvbuf = (unsigned char *) ((void *) 0);
+ break;
+ }
+ isc_event_free ((isc_event_t **) (&client->sendevent));
+ isc_event_free ((isc_event_t **) (&client->recvevent));
+ isc_timer_detach (&client->timer);
+ if ((unsigned long) client->tcpbuf != (unsigned long) ((void *) 0))
+ {
+ while (1)
+ {
+ isc__mem_put (client->mctx, (void *) client->tcpbuf, 65537U);
+ client->tcpbuf = (unsigned char *) ((void *) 0);
+ break;
+ }
+ }
+ if ((unsigned long) client->opt != (unsigned long) ((void *) 0))
+ {
+ tmp___18 = dns_rdataset_isassociated (client->opt);
+ if (tmp___18)
+ {
+ tmp___19 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 411, 2,
+ (char const *)
+ "dns_rdataset_isassociated(client->opt)");
+ tmp___19 = 0;
+ }
+ dns_rdataset_disassociate (client->opt);
+ dns_message_puttemprdataset (client->message, &client->opt);
+ }
+ dns_message_destroy (&client->message);
+ if ((unsigned long) client->manager != (unsigned long) ((void *) 0))
+ {
+ manager = client->manager;
+ if ((unsigned long) locked_manager ==
+ (unsigned long) ((void *) 0))
+ {
+ while (1)
+ {
+ tmp___22 = manager->lock;
+ manager->lock++;
+ if (tmp___22 == 0)
+ {
+ tmp___21 = 0;
+ }
+ else
+ {
+ tmp___21 = 34;
+ }
+ if (tmp___21 == 0)
+ {
+ tmp___23 = 1;
+ }
+ else
+ {
+ isc_error_runtimecheck ((char const *) "client.c",
+ 419,
+ (char const *)
+ "((*((&manager->lock)))++ == 0 ? 0 : 34) == 0");
+ tmp___23 = 0;
+ }
+ break;
+ }
+ locked_manager = manager;
+ }
+ while (1)
+ {
+ while (1)
+ {
+ if ((unsigned long) client->link.next !=
+ (unsigned long) ((void *) 0))
+ {
+ (client->link.next)->link.prev = client->link.prev;
+ }
+ else
+ {
+ (client->list)->tail = client->link.prev;
+ }
+ if ((unsigned long) client->link.prev !=
+ (unsigned long) ((void *) 0))
+ {
+ (client->link.prev)->link.next = client->link.next;
+ }
+ else
+ {
+ (client->list)->head = client->link.next;
+ }
+ client->link.prev = (ns_client_t *) ((void *) -1);
+ client->link.next = (ns_client_t *) ((void *) -1);
+ break;
+ }
+ break;
+ }
+ client->list = (client_list_t *) ((void *) 0);
+ if (manager->exiting)
+ {
+ if ((unsigned long) manager->active.head ==
+ (unsigned long) ((void *) 0))
+ {
+ tmp___24 = 1;
+ }
+ else
+ {
+ tmp___24 = 0;
+ }
+ if (tmp___24)
+ {
+ if ((unsigned long) manager->inactive.head ==
+ (unsigned long) ((void *) 0))
+ {
+ tmp___25 = 1;
+ }
+ else
+ {
+ tmp___25 = 0;
+ }
+ if (tmp___25)
+ {
+ destroy_manager = manager;
+ }
+ }
+ }
+ }
+ if ((unsigned long) client->task != (unsigned long) ((void *) 0))
+ {
+ isc_task_detach (&client->task);
+ }
+ ns_client_log (client, ns_g_categories + 1, ns_g_modules + 1, 3,
+ (char const *) "%s", "free");
+ client->magic = 0U;
+ while (1)
+ {
+ isc__mem_put (client->mctx, (void *) client, sizeof ((*client)));
+ client = (ns_client_t *) ((void *) 0);
+ break;
+ }
+ goto unlock;
+ }
+ unlock:if ((unsigned long) locked_manager !=
+ (unsigned long) ((void *) 0))
+ {
+ while (1)
+ {
+ locked_manager->lock--;
+ if (locked_manager->lock == 0)
+ {
+ tmp___26 = 0;
+ }
+ else
+ {
+ tmp___26 = 34;
+ }
+ if (tmp___26 == 0)
+ {
+ tmp___27 = 1;
+ }
+ else
+ {
+ isc_error_runtimecheck ((char const *) "client.c", 446,
+ (char const *)
+ "(--(*((&locked_manager->lock))) == 0 ? 0 : 34) == 0");
+ tmp___27 = 0;
+ }
+ break;
+ }
+ locked_manager = (ns_clientmgr_t *) ((void *) 0);
+ }
+ if ((unsigned long) destroy_manager != (unsigned long) ((void *) 0))
+ {
+ clientmgr_destroy (destroy_manager);
+ }
+ return (1);
+ }
+}
+static void
+client_senddone (isc_task_t * task, isc_event_t * event)
+{
+ ns_client_t *client;
+ isc_socketevent_t *sevent;
+ int tmp;
+ int tmp___0;
+ int tmp___1;
+ int tmp___2;
+ int tmp___3;
+ char const *tmp___4;
+ int tmp___5;
+ int tmp___6;
+ isc_boolean_t tmp___7;
+ {
+ sevent = (isc_socketevent_t *) event;
+ if ((unsigned long) sevent != (unsigned long) ((void *) 0))
+ {
+ tmp = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 626, 0,
+ (char const *) "sevent != ((void *)0)");
+ tmp = 0;
+ }
+ if (sevent->ev_type == 131074U)
+ {
+ tmp___0 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 627, 0,
+ (char const *)
+ "sevent->ev_type == (((2) << 16) + 2)");
+ tmp___0 = 0;
+ }
+ client = (ns_client_t *) sevent->ev_arg;
+ if ((unsigned long) client != (unsigned long) ((void *) 0))
+ {
+ if (((isc__magic_t const *) client)->magic == 1314079587U)
+ {
+ tmp___1 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 629, 0,
+ (char const *)
+ "(((client) != ((void *)0)) && (((const isc__magic_t *)(client))->magic == ( ((\'N\') << 24 | (\'S\') << 16 | (\'C\') << 8 | (\'c\')))))");
+ tmp___1 = 0;
+ }
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 629, 0,
+ (char const *)
+ "(((client) != ((void *)0)) && (((const isc__magic_t *)(client))->magic == ( ((\'N\') << 24 | (\'S\') << 16 | (\'C\') << 8 | (\'c\')))))");
+ tmp___1 = 0;
+ }
+ if ((unsigned long) task == (unsigned long) client->task)
+ {
+ tmp___2 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 630, 0,
+ (char const *) "task == client->task");
+ tmp___2 = 0;
+ }
+ if ((unsigned long) sevent == (unsigned long) client->sendevent)
+ {
+ tmp___3 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 631, 0,
+ (char const *)
+ "sevent == client->sendevent");
+ tmp___3 = 0;
+ }
+ ns_client_log (client, ns_g_categories + 1, ns_g_modules + 1, 3,
+ (char const *) "%s", "senddone");
+ if (sevent->result != 0U)
+ {
+ tmp___4 = isc_result_totext (sevent->result);
+ ns_client_log (client, ns_g_categories + 1, ns_g_modules + 1, -3,
+ (char const *) "error sending response: %s", tmp___4);
+ }
+ if (client->nsends > 0)
+ {
+ tmp___5 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 643, 2,
+ (char const *) "client->nsends > 0");
+ tmp___5 = 0;
+ }
+ client->nsends--;
+ if ((unsigned long) client->tcpbuf != (unsigned long) ((void *) 0))
+ {
+ if ((client->attributes & 1U) != 0U)
+ {
+ tmp___6 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 647, 2,
+ (char const *)
+ "(((client)->attributes & 0x01) != 0)");
+ tmp___6 = 0;
+ }
+ while (1)
+ {
+ isc__mem_put (client->mctx, (void *) client->tcpbuf, 65537U);
+ client->tcpbuf = (unsigned char *) ((void *) 0);
+ break;
+ }
+ client->tcpbuf = (unsigned char *) ((void *) 0);
+ }
+ tmp___7 = exit_check (client);
+ if (tmp___7)
+ {
+ return;
+ }
+ ns_client_next (client, 0U);
+ return;
+ }
+}
+static isc_result_t
+client_sendpkg (ns_client_t * client, isc_buffer_t * buffer)
+{
+ struct in6_pktinfo *pktinfo;
+ isc_result_t result;
+ isc_region_t r;
+ isc_sockaddr_t *address;
+ isc_socket_t *socket___0;
+ isc_netaddr_t netaddr;
+ int match;
+ unsigned int sockflags;
+ isc_result_t tmp;
+ {
+ sockflags = 1U;
+ if ((client->attributes & 1U) != 0U)
+ {
+ socket___0 = client->tcpsocket;
+ address = (isc_sockaddr_t *) ((void *) 0);
+ }
+ else
+ {
+ socket___0 = client->udpsocket;
+ address = &client->peeraddr;
+ isc_netaddr_fromsockaddr (&netaddr,
+ (isc_sockaddr_t const *) (&client->
+ peeraddr));
+ if ((unsigned long) ns_g_server->blackholeacl !=
+ (unsigned long) ((void *) 0))
+ {
+ tmp =
+ dns_acl_match (&netaddr, (dns_name_t *) ((void *) 0),
+ ns_g_server->blackholeacl, &ns_g_server->aclenv,
+ &match, (dns_aclelement_t **) ((void *) 0));
+ if (tmp == 0U)
+ {
+ if (match > 0)
+ {
+ return (65604U);
+ }
+ }
+ }
+ sockflags |= 2U;
+ }
+ if ((client->attributes & 4U) != 0U)
+ {
+ pktinfo = &client->pktinfo;
+ }
+ else
+ {
+ pktinfo = (struct in6_pktinfo *) ((void *) 0);
+ }
+ isc__buffer_usedregion (buffer, &r);
+ ns_client_log (client, ns_g_categories + 1, ns_g_modules + 1, 3,
+ (char const *) "%s", "sendto");
+ result =
+ isc_socket_sendto2 (socket___0, &r, client->task, address, pktinfo,
+ client->sendevent, sockflags);
+ if (result == 0U)
+ {
+ goto _L;
+ }
+ else
+ {
+ if (result == 53U)
+ {
+ _L:client->nsends++;
+ if (result == 0U)
+ {
+ client_senddone (client->task,
+ (isc_event_t *) client->sendevent);
+ }
+ result = 0U;
+ }
+ }
+ return (result);
+ }
+}
+void
+ns_client_sendraw (ns_client_t * client, dns_message_t * message)
+{
+ isc_result_t result;
+ unsigned char *data;
+ isc_buffer_t buffer;
+ isc_region_t r;
+ isc_region_t *mr;
+ unsigned char sendbuf[4096];
+ int tmp;
+ {
+ if ((unsigned long) client != (unsigned long) ((void *) 0))
+ {
+ if (((isc__magic_t const *) client)->magic == 1314079587U)
+ {
+ tmp = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 778, 0,
+ (char const *)
+ "(((client) != ((void *)0)) && (((const isc__magic_t *)(client))->magic == ( ((\'N\') << 24 | (\'S\') << 16 | (\'C\') << 8 | (\'c\')))))");
+ tmp = 0;
+ }
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 778, 0,
+ (char const *)
+ "(((client) != ((void *)0)) && (((const isc__magic_t *)(client))->magic == ( ((\'N\') << 24 | (\'S\') << 16 | (\'C\') << 8 | (\'c\')))))");
+ tmp = 0;
+ }
+ ns_client_log (client, ns_g_categories + 1, ns_g_modules + 1, 3,
+ (char const *) "%s", "sendraw");
+ mr = dns_message_getrawmessage (message);
+ if ((unsigned long) mr == (unsigned long) ((void *) 0))
+ {
+ result = 24U;
+ goto done;
+ }
+ result =
+ client_allocsendbuf (client, &buffer, (isc_buffer_t *) ((void *) 0),
+ mr->length, sendbuf, &data);
+ if (result != 0U)
+ {
+ goto done;
+ }
+ isc__buffer_availableregion (&buffer, &r);
+ result = isc_buffer_copyregion (&buffer, (isc_region_t const *) mr);
+ if (result != 0U)
+ {
+ goto done;
+ }
+ (*(r.base + 0)) =
+ (unsigned char) (((int) (client->message)->id >> 8) & 255);
+ (*(r.base + 1)) = (unsigned char) ((int) (client->message)->id & 255);
+ result = client_sendpkg (client, &buffer);
+ if (result == 0U)
+ {
+ return;
+ }
+ done:if ((unsigned long) client->tcpbuf !=
+ (unsigned long) ((void *) 0))
+ {
+ while (1)
+ {
+ isc__mem_put (client->mctx, (void *) client->tcpbuf, 65537U);
+ client->tcpbuf = (unsigned char *) ((void *) 0);
+ break;
+ }
+ client->tcpbuf = (unsigned char *) ((void *) 0);
+ }
+ ns_client_next (client, result);
+ return;
+ }
+}
+static void
+client_request (isc_task_t * task, isc_event_t * event)
+{
+ ns_client_t *client;
+ isc_socketevent_t *sevent;
+ isc_result_t result;
+ isc_result_t sigresult;
+ isc_buffer_t *buffer;
+ isc_buffer_t tbuffer;
+ dns_view_t *view;
+ dns_rdataset_t *opt;
+ isc_boolean_t ra;
+ isc_netaddr_t netaddr;
+ isc_netaddr_t destaddr;
+ int match;
+ dns_messageid_t id;
+ unsigned int flags;
+ isc_boolean_t notimp;
+ int tmp;
+ int tmp___0;
+ int tmp___1;
+ int tmp___2;
+ int tmp___3;
+ int tmp___4;
+ int tmp___5;
+ int tmp___6;
+ int tmp___7;
+ int tmp___8;
+ int tmp___9;
+ int tmp___10;
+ isc_boolean_t tmp___11;
+ char const *tmp___12;
+ char *tmp___13;
+ isc_result_t tmp___14;
+ unsigned int version;
+ int tmp___15;
+ isc_boolean_t tmp___16;
+ isc_boolean_t tmp___17;
+ char classname[(int) sizeof ("CLASS65535")];
+ isc_buffer_t b;
+ isc_region_t *r;
+ int tmp___18;
+ char const *tmp___19;
+ isc_result_t tmp___20;
+ {
+ if ((unsigned long) event != (unsigned long) ((void *) 0))
+ {
+ tmp = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 1077, 0,
+ (char const *) "event != ((void *)0)");
+ tmp = 0;
+ }
+ client = (ns_client_t *) event->ev_arg;
+ if ((unsigned long) client != (unsigned long) ((void *) 0))
+ {
+ if (((isc__magic_t const *) client)->magic == 1314079587U)
+ {
+ tmp___0 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 1079, 0,
+ (char const *)
+ "(((client) != ((void *)0)) && (((const isc__magic_t *)(client))->magic == ( ((\'N\') << 24 | (\'S\') << 16 | (\'C\') << 8 | (\'c\')))))");
+ tmp___0 = 0;
+ }
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 1079, 0,
+ (char const *)
+ "(((client) != ((void *)0)) && (((const isc__magic_t *)(client))->magic == ( ((\'N\') << 24 | (\'S\') << 16 | (\'C\') << 8 | (\'c\')))))");
+ tmp___0 = 0;
+ }
+ if ((unsigned long) task == (unsigned long) client->task)
+ {
+ tmp___1 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 1080, 0,
+ (char const *) "task == client->task");
+ tmp___1 = 0;
+ }
+ if ((unsigned long) client->recursionquota ==
+ (unsigned long) ((void *) 0))
+ {
+ tmp___2 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 1084, 2,
+ (char const *)
+ "client->recursionquota == ((void *)0)");
+ tmp___2 = 0;
+ }
+ if (client->state == ((client->attributes & 1U) != 0U))
+ {
+ tmp___3 = 3;
+ }
+ else
+ {
+ tmp___3 = 2;
+ }
+ if (tmp___3)
+ {
+ tmp___4 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 1089, 2,
+ (char const *)
+ "client->state == (((client)->attributes & 0x01) != 0) ? 3 : 2");
+ tmp___4 = 0;
+ }
+ if (event->ev_type == 131073U)
+ {
+ if ((client->attributes & 1U) != 0U)
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 1092, 2,
+ (char const *)
+ "!(((client)->attributes & 0x01) != 0)");
+ tmp___5 = 0;
+ }
+ else
+ {
+ tmp___5 = 1;
+ }
+ sevent = (isc_socketevent_t *) event;
+ if ((unsigned long) sevent == (unsigned long) client->recvevent)
+ {
+ tmp___6 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 1094, 0,
+ (char const *)
+ "sevent == client->recvevent");
+ tmp___6 = 0;
+ }
+ isc__buffer_init (&tbuffer, (void const *) sevent->region.base,
+ sevent->n);
+ isc__buffer_add (&tbuffer, sevent->n);
+ buffer = &tbuffer;
+ result = sevent->result;
+ if (result == 0U)
+ {
+ client->peeraddr = sevent->address;
+ client->peeraddr_valid = 1;
+ }
+ if ((sevent->attributes & 1048576U) != 0U)
+ {
+ client->attributes |= 4U;
+ client->pktinfo = sevent->pktinfo;
+ }
+ if ((sevent->attributes & 524288U) != 0U)
+ {
+ client->attributes |= 8U;
+ }
+ client->nrecvs--;
+ }
+ else
+ {
+ if ((client->attributes & 1U) != 0U)
+ {
+ tmp___7 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 1111, 2,
+ (char const *)
+ "(((client)->attributes & 0x01) != 0)");
+ tmp___7 = 0;
+ }
+ if (event->ev_type == 262151U)
+ {
+ tmp___8 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 1112, 0,
+ (char const *)
+ "event->ev_type == (((4) << 16) + 7)");
+ tmp___8 = 0;
+ }
+ if ((unsigned long) event->ev_sender ==
+ (unsigned long) (&client->tcpmsg))
+ {
+ tmp___9 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 1113, 0,
+ (char const *)
+ "event->ev_sender == &client->tcpmsg");
+ tmp___9 = 0;
+ }
+ buffer = &client->tcpmsg.buffer;
+ result = client->tcpmsg.result;
+ if (client->nreads == 1)
+ {
+ tmp___10 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 1116, 2,
+ (char const *) "client->nreads == 1");
+ tmp___10 = 0;
+ }
+ client->nreads--;
+ }
+ tmp___11 = exit_check (client);
+ if (tmp___11)
+ {
+ goto cleanup;
+ }
+ client->newstate = 4;
+ client->state = client->newstate;
+ isc_stdtime_get (&client->requesttime);
+ client->now = client->requesttime;
+ if (result != 0U)
+ {
+ if ((client->attributes & 1U) != 0U)
+ {
+ ns_client_next (client, result);
+ }
+ else
+ {
+ if (result != 20U)
+ {
+ tmp___12 = isc_result_totext (result);
+ isc_log_write (ns_g_lctx, ns_g_categories + 1,
+ ns_g_modules + 1, -4,
+ (char const *)
+ "UDP client handler shutting down due to fatal receive error: %s",
+ tmp___12);
+ }
+ isc_task_shutdown (client->task);
+ }
+ goto cleanup;
+ }
+ isc_netaddr_fromsockaddr (&netaddr,
+ (isc_sockaddr_t const *) (&client->peeraddr));
+ if ((client->attributes & 1U) != 0U)
+ {
+ tmp___13 = "TCP";
+ }
+ else
+ {
+ tmp___13 = "UDP";
+ }
+ ns_client_log (client, ns_g_categories + 1, ns_g_modules + 1, 3,
+ (char const *) "%s request", tmp___13);
+ if (!((client->attributes & 1U) != 0U))
+ {
+ if ((unsigned long) ns_g_server->blackholeacl !=
+ (unsigned long) ((void *) 0))
+ {
+ tmp___14 =
+ dns_acl_match (&netaddr, (dns_name_t *) ((void *) 0),
+ ns_g_server->blackholeacl, &ns_g_server->aclenv,
+ &match, (dns_aclelement_t **) ((void *) 0));
+ if (tmp___14 == 0U)
+ {
+ if (match > 0)
+ {
+ ns_client_log (client, &dns_categories[2],
+ ns_g_modules + 1, 10,
+ (char const *) "blackholed UDP datagram");
+ ns_client_next (client, 0U);
+ goto cleanup;
+ }
+ }
+ }
+ }
+ if ((client->attributes & 8U) != 0U)
+ {
+ ns_client_log (client, ns_g_categories + 1, ns_g_modules + 1, 2,
+ (char const *) "multicast request");
+ }
+ result = dns_message_peekheader (buffer, &id, &flags);
+ if (result != 0U)
+ {
+ ns_client_next (client, result);
+ goto cleanup;
+ }
+ if ((flags & 32768U) != 0U)
+ {
+ if ((client->attributes & 1U) != 0U)
+ {
+ ns_client_log (client, ns_g_categories + 1, ns_g_modules + 1, 3,
+ (char const *) "%s", "unexpected response");
+ ns_client_next (client, 196609U);
+ goto cleanup;
+ }
+ else
+ {
+ dns_dispatch_importrecv (client->dispatch, event);
+ ns_client_next (client, 0U);
+ goto cleanup;
+ }
+ }
+ result = dns_message_parse (client->message, buffer, 0U);
+ if (result != 0U)
+ {
+ ns_client_error (client, result);
+ goto cleanup;
+ }
+ switch ((int) (client->message)->opcode)
+ {
+ case 0:;
+ case 5:;
+ case 4:
+ notimp = 0;
+ break;
+ case 1:;
+ default:
+ notimp = 1;
+ break;
+ }
+ (client->message)->rcode = 0;
+ opt = dns_message_getopt (client->message);
+ if ((unsigned long) opt != (unsigned long) ((void *) 0))
+ {
+ client->udpsize = opt->rdclass;
+ if ((int) client->udpsize < 512)
+ {
+ client->udpsize = 512;
+ }
+ client->extflags = (unsigned short) (opt->ttl & 65535U);
+ result = client_addopt (client);
+ if (result != 0U)
+ {
+ ns_client_error (client, result);
+ goto cleanup;
+ }
+ version = (opt->ttl & 16711680U) >> 16;
+ if (version != 0U)
+ {
+ ns_client_error (client, 196624U);
+ goto cleanup;
+ }
+ }
+ if ((int) (client->message)->rdclass == 0)
+ {
+ ns_client_log (client, ns_g_categories + 1, ns_g_modules + 1, 1,
+ (char const *)
+ "message class could not be determined");
+ ns_client_dumpmessage (client,
+ (char const *)
+ "message class could not be determined");
+ if (notimp)
+ {
+ tmp___15 = 196612;
+ }
+ else
+ {
+ tmp___15 = 196609;
+ }
+ ns_client_error (client, (unsigned int) tmp___15);
+ goto cleanup;
+ }
+ if ((int) (client->interface)->addr.type.sa.sa_family == 10)
+ {
+ if ((client->attributes & 4U) != 0U)
+ {
+ isc_netaddr_fromin6 (&destaddr,
+ (struct in6_addr const *) (&client->pktinfo.
+ ipi6_addr));
+ }
+ else
+ {
+ isc_netaddr_any6 (&destaddr);
+ }
+ }
+ else
+ {
+ isc_netaddr_fromsockaddr (&destaddr,
+ (isc_sockaddr_t const
+ *) (&(client->interface)->addr));
+ }
+ view = ns_g_server->viewlist.head;
+ while ((unsigned long) view != (unsigned long) ((void *) 0))
+ {
+ if ((int) (client->message)->rdclass == (int) view->rdclass)
+ {
+ goto _L;
+ }
+ else
+ {
+ if ((int) (client->message)->rdclass == 255)
+ {
+ _L:tmp___16 =
+ allowed (&netaddr, view->matchclients);
+ if (tmp___16)
+ {
+ tmp___17 = allowed (&destaddr, view->matchdestinations);
+ if (tmp___17)
+ {
+ if ((flags & 256U) == 0U)
+ {
+ if (!view->matchrecursiveonly)
+ {
+ dns_view_attach (view, &client->view);
+ break;
+ }
+ }
+ else
+ {
+ dns_view_attach (view, &client->view);
+ break;
+ }
+ }
+ }
+ }
+ }
+ view = view->link.next;
+ }
+ if ((unsigned long) view == (unsigned long) ((void *) 0))
+ {
+ r = dns_message_getrawmessage (client->message);
+ isc__buffer_init (&b, (void const *) r->base, r->length);
+ isc__buffer_add (&b, r->length);
+ dns_tsig_verify (&b, client->message,
+ (dns_tsig_keyring_t *) ((void *) 0),
+ (dns_tsig_keyring_t *) ((void *) 0));
+ dns_rdataclass_format ((client->message)->rdclass, classname,
+ sizeof (classname));
+ ns_client_log (client, ns_g_categories + 1, ns_g_modules + 1, 1,
+ (char const *) "no matching view in class \'%s\'",
+ classname);
+ ns_client_dumpmessage (client,
+ (char const *) "no matching view in class");
+ if (notimp)
+ {
+ tmp___18 = 196612;
+ }
+ else
+ {
+ tmp___18 = 196613;
+ }
+ ns_client_error (client, (unsigned int) tmp___18);
+ goto cleanup;
+ }
+ ns_client_log (client, ns_g_categories + 1, ns_g_modules + 1, 5,
+ (char const *) "using view \'%s\'", view->name);
+ sigresult = dns_message_checksig (client->message, client->view);
+ client->signer = (dns_name_t *) ((void *) 0);
+ dns_name_init (&client->signername, (unsigned char *) ((void *) 0));
+ result = dns_message_signer (client->message, &client->signername);
+ if (result == 0U)
+ {
+ ns_client_log (client, &dns_categories[2], ns_g_modules + 1, 3,
+ (char const *) "request has valid signature");
+ client->signer = &client->signername;
+ }
+ else
+ {
+ if (result == 23U)
+ {
+ ns_client_log (client, &dns_categories[2], ns_g_modules + 1, 3,
+ (char const *) "request is not signed");
+ }
+ else
+ {
+ if (result == 65591U)
+ {
+ ns_client_log (client, &dns_categories[2], ns_g_modules + 1,
+ 3,
+ (char const *)
+ "request is signed by a nonauthoritative key");
+ }
+ else
+ {
+ tmp___19 = isc_result_totext (result);
+ ns_client_log (client, &dns_categories[2], ns_g_modules + 1,
+ -4,
+ (char const *)
+ "request has invalid signature: %s", tmp___19);
+ if ((int) (client->message)->tsigstatus == 17)
+ {
+ if (!((client->message)->opcode == 5U))
+ {
+ ns_client_error (client, sigresult);
+ goto cleanup;
+ }
+ }
+ else
+ {
+ ns_client_error (client, sigresult);
+ goto cleanup;
+ }
+ }
+ }
+ }
+ ra = 0;
+ if ((unsigned long) (client->view)->resolver !=
+ (unsigned long) ((void *) 0))
+ {
+ if ((int) (client->view)->recursion == 1)
+ {
+ tmp___20 =
+ ns_client_checkacl (client,
+ (char const *) "recursion available:",
+ (client->view)->recursionacl, 1, 1);
+ if (tmp___20 == 0U)
+ {
+ ra = 1;
+ }
+ }
+ }
+ if ((int) ra == 1)
+ {
+ client->attributes |= 2U;
+ }
+ switch ((int) (client->message)->opcode)
+ {
+ case 0:
+ ns_client_log (client, ns_g_categories + 1, ns_g_modules + 1, 3,
+ (char const *) "%s", "query");
+ ns_query_start (client);
+ break;
+ case 5:
+ ns_client_log (client, ns_g_categories + 1, ns_g_modules + 1, 3,
+ (char const *) "%s", "update");
+ ns_client_settimeout (client, 60U);
+ ns_update_start (client, sigresult);
+ break;
+ case 4:
+ ns_client_log (client, ns_g_categories + 1, ns_g_modules + 1, 3,
+ (char const *) "%s", "notify");
+ ns_client_settimeout (client, 60U);
+ ns_notify_start (client);
+ break;
+ case 1:
+ ns_client_log (client, ns_g_categories + 1, ns_g_modules + 1, 3,
+ (char const *) "%s", "iquery");
+ ns_client_error (client, 196612U);
+ break;
+ default:
+ ns_client_log (client, ns_g_categories + 1, ns_g_modules + 1, 3,
+ (char const *) "%s", "unknown opcode");
+ ns_client_error (client, 196612U);
+ }
+ cleanup:return;
+ }
+}
+static void
+client_read (ns_client_t * client)
+{
+ isc_result_t result;
+ int tmp;
+ int tmp___0;
+ {
+ ns_client_log (client, ns_g_categories + 1, ns_g_modules + 1, 3,
+ (char const *) "%s", "read");
+ result =
+ dns_tcpmsg_readmessage (&client->tcpmsg, client->task, &client_request,
+ (void *) client);
+ if (result != 0U)
+ {
+ goto fail;
+ }
+ ns_client_settimeout (client, 30U);
+ client->newstate = 3;
+ client->state = client->newstate;
+ if (client->nreads == 0)
+ {
+ tmp = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 1656, 2,
+ (char const *) "client->nreads == 0");
+ tmp = 0;
+ }
+ if ((unsigned long) client->recursionquota ==
+ (unsigned long) ((void *) 0))
+ {
+ tmp___0 = 1;
+ }
+ else
+ {
+ ((*isc_assertion_failed)) ((char const *) "client.c", 1657, 2,
+ (char const *)
+ "client->recursionquota == ((void *)0)");
+ tmp___0 = 0;
+ }
+ client->nreads++;
+ return;
+ fail:ns_client_next (client, result);
+ return;
+ }
+}
--- /dev/null
+#ifdef _GNUCC
+#define __int64 long long
+#endif
+
+typedef struct {
+ char chr;
+ char srt;
+ int a : 4;
+ int b : 5;
+ __int64 c : 16;
+ int d : 8;
+ int last;
+} S1;
+
+int g1,g2,g3,g4;
+extern int bar(int, int);
+
+
+typedef struct mixes {
+ int * p1;
+ int f2;
+ int m3 : 5;
+ int m4 : 6;
+ int f4;
+ int m5 : 2;
+ int * f6;
+} MIXES;
+
+int foo(S1 *s1) {
+ bar(1, s1->chr);
+ bar(2, s1->srt);
+ bar(3, s1->a);
+ bar(4, s1->b);
+ bar(5, s1->c);
+ bar(6, s1->d);
+
+ {
+ MIXES x, *y;
+ int a = x.f2 + x.m4 + x.m5;
+ x.f2 = 5;
+ x.m3 = 3;
+ x.m5 = 9;
+
+ * y[5].p1 = y->m4;
+
+ }
+}
--- /dev/null
+#include "testharness.h"
+
+struct {
+ int x;
+ int y : 2;
+ int z : 4;
+} g;
+
+int main() {
+
+ g.y = 113;
+ if(g.y != 113 % 4) E(1);
+ g.z = 113;
+ if(g.z != 113 % 16) E(2);
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+typedef struct {
+ char x; // this field is only important for automating
+ // the test, we fail even without it
+ unsigned dns_resolved:1;
+} uri_components;
+
+typedef struct {
+ char x;
+} test;
+int main() {
+ if (sizeof(uri_components) == sizeof(test)) {
+ E(1);
+ }
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+#ifndef CCURED
+#define __TAGGED
+#endif
+
+
+int anint1 = 123, anint2 = 456;
+
+int main() {
+
+ {
+ struct only_bitfields {
+ int bf1 : 1;
+ int bf2 : 4;
+ };
+
+ struct nested1 {
+ int i1;
+ int *p1; // These should be left alone when writing tags to b1
+ struct only_bitfields b1;
+ int *p2;
+ } x1 __TAGGED;
+
+ x1.p1 = & anint1; x1.p2 = & anint2;
+ x1.i1 = 5; if(x1.i1 != 5) E(1);
+
+ x1.b1.bf2 = 4; if(x1.b1.bf2 != 4) E(2);
+
+ // Try to read from x1.p1 and x1.p2 make sure they are valid pointers
+ if(* x1.p1 != anint1) E(3);
+
+ if(* x1.p2 != anint2) E(4);
+
+ }
+
+ {
+ struct start_bitfields {
+ int bf2 : 4;
+ int bf3 : 5;
+ int * ptr2;
+ };
+
+ struct nested2 {
+ int *ptr1;
+ struct start_bitfields b2;
+ } x2 __TAGGED;
+
+ x2.ptr1 = & anint1; x2.b2.ptr2 = & anint2;
+ x2.b2.bf3 = 5; if(x2.b2.bf3 != 5) E(11);
+
+ x2.b2.bf2 = 4; if(x2.b2.bf2 != 4) E(12);
+
+ // Try to read the pointers to ensure they are valid
+ if(* x2.ptr1 != anint1) E(13);
+
+ if(* x2.b2.ptr2 != anint2) E(14);
+ }
+
+
+ {
+ struct end_bitfields {
+ int * ptr1;
+ int bf2 : 4;
+ int bf3 : 5;
+ };
+ struct nested3 {
+ struct end_bitfields b3;
+ int *ptr2;
+ } x3 __TAGGED;
+
+ x3.b3.ptr1 = & anint1; x3.ptr2 = & anint2;
+ x3.b3.bf3 = 5; if(x3.b3.bf3 != 5) E(21);
+
+ x3.b3.bf2 = 4; if(x3.b3.bf2 != 4) E(22);
+
+ // Try to read the pointers to ensure they are valid
+ if(* x3.b3.ptr1 != anint1) E(23);
+
+ if(* x3.ptr2 != anint2) E(24);
+ }
+
+
+
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+#include "testkinds.h"
+
+int main() {
+ int x __attribute__((foo));
+ {
+ __blockattribute__ (nobox)
+ x ++; // Let's see if CCured sees this
+ }
+}
--- /dev/null
+#include "testharness.h"
+
+int main() {
+ double d = __builtin_fabs(-2.0);
+ printf("Result is %lf\n", d);
+ SUCCESS;
+}
--- /dev/null
+int f(__builtin_va_list vl);
+int f(__builtin_va_list vl) {
+ return 0;
+}
+
+int main() {
+ __builtin_va_list vl;
+ return f(vl);
+}
--- /dev/null
+#include "testharness.h"
+
+typedef int my_int;
+
+int main (void)
+{
+ int x = 0;
+ int b = __builtin_constant_p (x++);
+
+ int arr[];
+
+ __builtin_constant_p (x++);
+
+ b = __builtin_constant_p (x++);
+
+ if(! __builtin_constant_p(56 + 34)) { x ++; }
+
+ // The x++ should happen only once
+ (__extension__ (__builtin_constant_p (x++) ? 0 : x++));
+
+ switch(8) {
+ case (__builtin_constant_p (x++) ? x : 8):
+ break;
+ default:
+ E(2);
+ }
+
+ if(x != 1) E(1);
+
+ //__builtin_types_compat_p
+ // http://developer.apple.com/documentation/DeveloperTools/gcc-3.3/gcc/Other-Builtins.html
+ if(__builtin_types_compatible_p(char, char*)) E(10);
+ if(!__builtin_types_compatible_p(int, my_int)) E(11);
+
+
+ SUCCESS;
+ }
--- /dev/null
+#include "testharness.h"
+
+//__builtin_choose_expr is a compile-time version of ?:
+
+int main() {
+ char c = 0;
+ int i = 1;
+ if (sizeof(__builtin_choose_expr(1, c, i)) != sizeof(char)) E(1);
+ if (sizeof(__builtin_choose_expr(0, c, i)) != sizeof(int)) E(2);
+
+ int* p = __builtin_choose_expr(1, &i, 2.0);
+ double d = __builtin_choose_expr(0, &i, 2.0);
+
+ //Don't evaluate the i++
+ c = __builtin_choose_expr(1, c, i++);
+ if (i != 1) E(3)
+
+ return __builtin_choose_expr(1, 0, 1);
+}
--- /dev/null
+#include "testharness.h"
+
+
+int any_int(void) {
+ return 3;
+}
+
+void main() {
+ int tmp = -1;
+ unsigned int G;
+ // We had a bug that replaced the next two lines with
+ // G = any_int ();
+ tmp = any_int();
+ G = tmp;
+ tmp = tmp-3;
+ if(tmp != 0) E(1);
+ SUCCESS;
+}
--- /dev/null
+
+
+
+int foo(int x) {
+ switch(x) {
+ case 6: x ++;
+ case 7 ... 10: return foo(x + 2);
+ case 'A' ... 'E' : return foo (x + 8);
+ case 'F' ... 'Z' : return x;
+ default:
+ return foo (x + 5);
+ }
+}
+
+int main() {
+
+ return (foo(6) - 74);
+}
+
--- /dev/null
+typedef struct {
+ int x;
+} IntStruct;
+
+int y;
+
+int main() {
+ int * ip = &y;
+ IntStruct * sp;
+
+ sp = ip;
+
+ return sp->x;
+}
--- /dev/null
+void free(void*);
+
+void foo()
+{
+ (void)free(0);
+}
--- /dev/null
+#include "testharness.h"
+
+int __finite (double __x)
+{
+ return (__extension__
+ (((((union { double __d; int __i[2]; }) {__d: __x}).__i[1]
+ | 0x800fffffu) + 1) >> 31));
+}
+
+int main() {
+ double inf = 10000000000.0;
+ double old;
+
+ if(! __finite(2.0)) E(1);
+
+ do { // Create an infinity
+ old = inf;
+ inf *= inf;
+ } while(old != inf);
+
+ if(__finite(inf)) E(2);
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+typedef union un {
+ int i;
+ long long l;
+ struct str {
+ int i1, i2;
+ } s;
+} un;
+
+int f(union un x) {
+ return x.s.i1;
+}
+
+un glob = (un)6;
+
+int main() {
+ un x = (un)5LL;
+ if(x.l != 5LL) E(1);
+ if(x.i != 5) E(2);
+
+ {
+ struct str s = { 1, 2 };
+ un y = (union un) s;
+ if(y.s.i1 != 1 || y.s.i2 != 2) E(3);
+
+ if(f((un)s) != 1) E(4);
+ }
+
+ if(glob.i != 6) E(5);
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+/* A very surprising bug that has surfaced after 3 years */
+
+int main() {
+ int base = 5;
+ unsigned long max_over_base =
+ (unsigned long) -1 / base;
+
+ unsigned long correct =
+ ((unsigned long) -1) / base;
+
+ printf("Result is %ld. Correct=%ld\n", max_over_base, correct);
+ if(max_over_base != correct) E(1);
+
+ SUCCESS;
+}
--- /dev/null
+#include <stdio.h>
+#include <stdlib.h>
+
+int main(void) {
+ char *p;
+ int i;
+
+ p = malloc(2*sizeof(int));
+ *(int *)p = 1;
+ *((int *)p + 1) = 2;
+
+ i = *((int *)p)++;
+ printf("%d\n", i);
+ i = *((int *)p)++;
+ printf("%d\n", i);
+
+ return 0;
+}
--- /dev/null
+/* We have 3 files. First defines g1, second g2, and third refers to both g1
+ * and g2. */
+
+struct foo {
+ struct foo * left, * right;
+ int x;
+} g1;
--- /dev/null
+typedef struct foo PSFOO;
+struct foo {
+ struct foo * left;
+ PSFOO * right;
+ int x;
+} g2;
--- /dev/null
+#include "testharness.h"
+
+extern struct foo {
+ struct foo * left, * right;
+ int x;
+} g1, g2;
+
+
+int main() {
+ g1 = g2;
+ SUCCESS;
+}
--- /dev/null
+/* We have two files, each with part of a structure undefined */
+struct list {
+ struct list *next;
+ struct foo *f;
+ struct bar *b;
+} g;
+
+struct foo {
+ double d;
+};
+
+extern void* f2();
+void* f1() {
+ return (void*) & g.f->d;
+}
--- /dev/null
+extern struct list {
+ struct list *next;
+ struct foo *f;
+ struct bar *b;
+} g;
+
+struct bar {
+ enum { A, B, C } e;
+};
+
+void* f2() {
+ return (void*) & g.b->e;
+}
+
+
+int main() {
+ void *v1 = f1(); /* Without prototype */
+ void *v2 = f2();
+}
--- /dev/null
+/* We test isomorphism between structs with different names and anonymous
+ * structs */
+struct bar {
+ int x;
+ struct foo *next;
+};
+
+struct foo {
+ struct bar b;
+} g;
+
+int main() {
+ return 0;
+}
--- /dev/null
+struct bar {
+ struct {
+ int x;
+ struct foo *next;
+ } c;
+};
+
+struct baz {
+ struct {
+ int x;
+ struct bar *next;
+ } b;
+} g;
--- /dev/null
+/* Two identical structures but one uses typedef */
+struct foo {
+ struct foo * left, * right;
+ int x;
+} g;
+
--- /dev/null
+typedef struct foo PSFOO;
+extern struct foo {
+ struct foo * left;
+ PSFOO * right;
+ int x;
+} g;
+
+#include "testharness.h"
+
+int main() {
+ printf("Address is %x\n", &g); /* Make sure we use g */
+ SUCCESS;
+}
--- /dev/null
+/* A tests with function prototypes. We do not want to change the names of
+ * the format arguments of a function to those specified by the prototype.
+ * First the prototype. */
+#include "testharness.h"
+
+int protoname1 = 5;
+extern int protoname2;
+
+void foo(int protoname1);
+
+void bar(int myname) {
+ protoname2 = myname;
+}
+
+int main() {
+ foo(0); /* Should set protoname1 and protoname2 to 0 */
+ if(protoname1 != 0) E(1);
+ if(protoname2 != 0) E(2);
+
+ SUCCESS;
+}
--- /dev/null
+extern int protoname1;
+
+int protoname2 = 5;
+
+void bar(int protoname2);
+
+void foo(int myname) {
+ protoname1 = myname;
+
+ bar(0); /* Should set protoname2 */
+}
--- /dev/null
+/* A test in which two structs in the same file end up being
+ constrained to be isomorphic. We have to pick the earliest-defined as a
+ * representative. We have two sets of tests trying to catch the error no
+ * matter in which order we do the unification. */
+extern struct s1 {
+ int x;
+} x1;
+extern struct d1 {
+ double x;
+} y1;
+
+/* Use s1 and d1 in some way */
+struct use {
+ struct s1 f1;
+ struct d1 f2;
+} ext1;
+
+extern struct s11 {
+ int x;
+} x2;
+extern struct d11 {
+ double x;
+} y2;
+
+/* Use s11 also */
+struct use2 {
+ struct s11 f2;
+ struct d11 f3;
+} ext2;
+
+
+#include "testharness.h"
+int main() {
+ printf("Address of x1=%x and x2=%x\n",
+ &x1, &x2);
+ printf("Address of y1=%x and y2=%x\n",
+ &y1, &y2);
+}
--- /dev/null
+struct s2 {
+ int x;
+} x1, x2; /* Constrain both s11 and s1 to be isomorphic */
+
+struct d2 {
+ double x;
+} y2, y1; /* Constrain both d11 and d1 to be isomorphic */
+
--- /dev/null
+/* A test the tries to produce double renaming */
+extern struct foo1 {
+ int x;
+} x1;
+
+extern struct bar {
+ double d;
+} x2;
+
+extern double test();
+
+
+int main() {
+ if(x1.x + x2.d != test()) return 1;
+
+ return 0;
+}
--- /dev/null
+struct foo2;
+
+struct foo2 {
+ int x;
+} x1; /* This will be isomorphic with struct foo1 in file 1 */
+
+
+struct foo1 { /* This will be isomorphic with struct bar in file 1 */
+ double d;
+} x2;
+
+
+double test() {
+ return x1.x + x2.d;
+}
--- /dev/null
+/* We test that the merger does not borrow the top-level const attribute for
+ * a global declared extern to the definition. Because if the definition is
+ * const then we might not be able to write it to it at all */
+extern const struct { int f; } x;
+
+
+int read() {
+ return x.f;
+}
--- /dev/null
+struct { int f; } x; // Read-write
+
+#include "testharness.h"
+
+int main() {
+ x.f = 5; // Now write to it
+ if(read() != 5) E(1);
+
+ SUCCESS;
+}
--- /dev/null
+/* We test that we rename properly the name of enumeration items */
+enum e1 {
+ ITEM1 = 0,
+ ITEM2 = 1,
+} x1;
+
+extern int getitem5();
+
+#include "testharness.h"
+
+int main() {
+ x1 = ITEM1;
+ if(x1 != 0) E(1);
+ if(getitem5() != 5) E(2);
+ SUCCESS;
+}
--- /dev/null
+enum e2 {
+ ITEM1 = 5,
+ ITEM2 = 6,
+} x2;
+
+int getitem5() {
+ return ITEM1;
+}
--- /dev/null
+typedef int INT;
+
+struct str1 {
+ INT x1;
+ int x2;
+} array;
+
+int var = 7;
+
+extern void printf(char *, ...);
+#define E(n) { printf("Error %d\n", n); return (n); }
+
+extern int c2(void), c3(void);
+int main() {
+ int c1res = sizeof(array);
+ int c2res = c2();
+ int c3res = c3();
+
+ if(c1res != c3res) E(1);
+
+ if(c2res != sizeof(int [10]) + sizeof(int)) E(2);
+
+ if(var != 7) E(3);
+
+ printf("Success\n");
+ return 0;
+}
--- /dev/null
+
+typedef struct str1 {
+ int random;
+} FOO;
+
+static int array[10];
+
+int c2(void) {
+ return sizeof(array) + sizeof(struct str1);
+}
--- /dev/null
+typedef int INT, *PINT;
+
+struct str1 {
+ INT x1;
+ int x2;
+} array2;
+
+int c3(void) {
+ int var;
+
+ var = 9; /* Hopefully we do not overwrite the global one */
+ return sizeof(array2);
+}
--- /dev/null
+
+
+static int tmp ;
+
+int usetmp() {
+ return tmp;
+}
--- /dev/null
+
+struct stralloc {
+ char *s ;
+ unsigned int len ;
+ unsigned int a ;
+};
+
+static struct stralloc tmp; // This will turn into tmp___0 (merger)
+
+
+int main() {
+ int tmp___0 = 5; // This will stay as it is, thus conflicting with the
+ // new global
+ char *path = tmp.s; // This will be changed to tmp___0.s !!!
+ return 0;
+}
--- /dev/null
+static int gflag;
+
+__inline void testit ( int flag )
+{
+ gflag = flag;
+}
+
+extern void otest(int flag);
+
+int
+main(int argc, char **argv)
+{
+ testit(0);
+ otest(2);
+ testit(1);
+ return 0;
+}
--- /dev/null
+// __inline__ void testit ( int flag )
+// {
+// ;
+// }
+
+extern void testit ( int flag );
+
+void otest(int flag)
+{
+ testit(flag);
+}
--- /dev/null
+
+
+// Define an empty struct for now
+struct empty *ptr_empty;
+
+int other() {
+ return (sizeof(struct empty));
+}
--- /dev/null
+// Fill in the old empty struct
+
+
+typedef int MYINT;
+
+struct empty {
+ MYINT i;
+} glob;
+
+struct empty *ptr_empty;
+
+int main() {
+ return glob.i;
+}
--- /dev/null
+/* Declare it as an array but without length */
+extern char* foo[];
+
+/* Now it has a length but is global */
+char *foo[2] = {"first string", "second string"};
+
+extern int bar;
+
+int f1() {
+ return bar;
+}
--- /dev/null
+/* Declare it as an array but without length */
+extern char* foo[];
+
+/* Now it has a length but is static */
+static char *foo[2] = {"first string", "second string"};
+
+static int bar = 0;
+
+static char *foo_static = "My static string";
+
+int f2() {
+ return bar;
+}
--- /dev/null
+#include "testharness.h"
+
+int bar;
+
+int main() {
+ f1();
+ f2();
+
+ SUCCESS;
+}
--- /dev/null
+typedef struct foo *PFOO;
+
+typedef struct foo {
+ int x;
+ PFOO y;
+} *PTR;
+
+PTR g1;
--- /dev/null
+
+typedef struct foo *PFOO;
+
+typedef struct foo {
+ int x;
+ int z; /* This is a new field */
+ PFOO y;
+} *PTR;
+
+PTR g2;
+
+int main2() {
+ int *d = & g2->z; /* Make sure we can refer to it */
+ return 0;
+}
--- /dev/null
+#include "testharness.h"
+
+typedef struct foo *PFOO;
+
+typedef struct foo {
+ int x;
+ PFOO y;
+} *PTR;
+
+PTR g3;
+
+int main() {
+ main2();
+ /* Make sure that the offset is right */
+ if(& g3->y != & ((struct { int x; PFOO y;} *)g3)->y) E(1);
+
+ SUCCESS;
+}
--- /dev/null
+/* A simple test with two files, no structs. The second file refers to the
+ * same exact types and to foo */
+typedef int __intptr_t;
+typedef __intptr_t intptr_t;
+
+intptr_t foo(void) { return 0; }
--- /dev/null
+typedef int __intptr_t;
+typedef int intptr_t;
+
+extern intptr_t foo(void);
+
+int main() {
+ intptr_t x = foo();
+ return x;
+}
--- /dev/null
+typedef long int __time_t;
+
+typedef __time_t time_t;
+
+extern struct
+{
+
+ time_t to_initial;
+ time_t to_mail;
+ time_t to_rcpt;
+ time_t to_datainit;
+ time_t to_datablock;
+ time_t to_datafinal;
+ time_t to_nextcommand;
+
+ time_t to_iconnect;
+ time_t to_connect;
+ time_t to_rset;
+ time_t to_helo;
+ time_t to_quit;
+ time_t to_miscshort;
+ time_t to_ident;
+ time_t to_fileopen;
+ time_t to_control;
+
+ time_t to_q_return[8 ];
+ time_t to_q_warning[8 ];
+ time_t res_retrans[3 ];
+ int res_retry[3 ];
+} TimeOuts;
--- /dev/null
+/* A test with 3 files. In the first two files we include the same .h and in
+ * the third file we copy the contents of the include */
+#include "combine5.h"
+#include "testharness.h"
+
+int main() {
+ printf("Address of TimeOuts=%x\n", &TimeOuts);
+ return 0;
+}
--- /dev/null
+#include "combine5.h"
--- /dev/null
+/* Just so that we make sure that the line numbers do not matter */
+typedef long int __time_t;
+
+typedef __time_t time_t;
+
+/* extern */ struct /* This is a definition */
+{
+
+ time_t to_initial;
+ time_t to_mail;
+ time_t to_rcpt;
+ time_t to_datainit;
+ time_t to_datablock;
+ time_t to_datafinal;
+ time_t to_nextcommand;
+
+ time_t to_iconnect;
+ time_t to_connect;
+ time_t to_rset;
+ time_t to_helo;
+ time_t to_quit;
+ time_t to_miscshort;
+ time_t to_ident;
+ time_t to_fileopen;
+ time_t to_control;
+
+ time_t to_q_return[8 ];
+ time_t to_q_warning[8 ];
+ time_t res_retrans[3 ];
+ int res_retry[3 ];
+} TimeOuts;
+
+
--- /dev/null
+typedef void *PVOID;
+
+
+typedef struct _CALLBACK_OBJECT *PCALLBACK_OBJECT;
+
+
+typedef struct _CALLBACK_OBJECT *PCALLBACK_OBJECT;
+
+
+__declspec(dllimport)
+int
+ExCreateCallback (
+ PCALLBACK_OBJECT *CallbackObject,
+ int ObjectAttributes,
+ int Create,
+ int AllowMultipleCallbacks
+ );
+
+
+int main() {
+ return 0;
+}
--- /dev/null
+typedef void *PVOID;
+
+typedef struct _CALLBACK_OBJECT *PCALLBACK_OBJECT;
+
+
+__declspec(dllimport)
+int
+ExCreateCallback (
+ PCALLBACK_OBJECT *CallbackObject,
+ int ObjectAttributes,
+ int Create,
+ int AllowMultipleCallbacks
+ );
+
--- /dev/null
+struct list1 {
+ struct list2 *realnext;
+ struct list1 *next;
+};
+
+
+struct list2 {
+ double d;
+ struct list2 *data;
+};
--- /dev/null
+struct list12 {
+ struct list22 *realnext;
+ struct list12 *next;
+};
+
+struct list22 {
+ double d;
+ struct list22 *data;
+};
+
+
+int main() {
+ struct list12 l;
+}
--- /dev/null
+/* struct list2 is not defined */
+struct list13 {
+ struct list2 *realnext;
+ struct list13 *next;
+};
--- /dev/null
+#include "testharness.h"
+
+struct foo {
+ int x;
+ struct googoo * next;
+} * g1;
+
+
+struct googoo {
+ double d;
+};
+
+
+int main() {
+ SUCCESS;
+}
--- /dev/null
+typedef struct {
+ int x;
+ struct bar * next;
+} STR;
+
+STR * g1;
+
+struct bar {
+ double d;
+};
--- /dev/null
+/* We have two incompatible definitions of g
+ * The struct looks the same if you do not unroll the typedef */
+#include "testharness.h"
+
+typedef int INT;
+
+struct {
+ INT i;
+ int x;
+} g;
+
+
+int main() {
+ E(1); /* Should not compile */
+}
--- /dev/null
+typedef short INT; /* This was declared int before */
+
+struct {
+ INT i;
+ int x;
+} g;
--- /dev/null
+__inline static void *allocate(unsigned int __8318_34___n ) ;
--- /dev/null
+
+
+__inline static void *allocate (unsigned int __10884_34___n);
+
+__inline static void * allocate (unsigned int __10884_34___n)
+{
+ return 0;
+}
+
+
+__inline static void *allocate___0 (unsigned int __11367_34___n);
+
+
+__inline static void * allocate___0 (unsigned int __11367_34___n)
+{
+ return 0;
+}
+
+
+
+int main () {
+ allocate___0(0);
+ return 0;
+}
--- /dev/null
+typedef char otherChar;
+__inline static otherChar *
+copyptrs (char *first, char *last,
+ otherChar * result, struct true_type const *_4)
+{
+}
--- /dev/null
+struct true_type
+{
+};
+typedef struct true_type ret_true_type;
+typedef char otherChar;
+typedef char value_type;
+typedef ret_true_type Type;
+struct cc
+{
+};
+__inline static char
+ *copy_aux (char
+ *first, char *last, char *result, struct true_type const *_6);
+__inline static struct cc
+ isOkToMemCpy (value_type * __T136310140, value_type * __T136310232)
+{
+ struct cc foo;
+ return foo;
+}
+__inline static char *copyptrs (char *__5338_43___first,
+ char *__5338_63___last,
+ char *__5338_83___result,
+ struct true_type const *__T136310416);
+__inline static Type has_trivial (void)
+{
+ Type foo;
+ return foo;
+}
+__inline static char *
+copy_aux (char *first, char *last, char *result, struct true_type const *_6)
+{
+ Type __T136310508;
+ char *tmp;
+ {
+ isOkToMemCpy ((value_type *) 0, (value_type *) 0);
+ has_trivial ();
+ tmp =
+ copyptrs (first, last, result,
+ (struct true_type const *) (&__T136310508));
+ return (tmp);
+ }
+}
+__inline static char *
+copyptrs (char *__5338_43___first, char *__5338_63___last,
+ char *__5338_83___result, struct true_type const *_6)
+{
+}
+__inline static struct cc
+ isOkToMemCpy___0 (value_type * __T144603992, value_type * __T144604084);
+__inline static otherChar *copyptrs___0 (char *first,
+ char *last,
+ otherChar * result,
+ struct true_type const *_8);
+__inline static Type has_trivial___0 (void)
+{
+ Type *pFoo;
+ return *pFoo;
+}
+__inline static otherChar *
+copy_aux___0 (char
+ *first,
+ char *last, otherChar * result, struct true_type const *_8)
+{
+ Type __T144604360;
+ otherChar *tmp;
+ {
+ isOkToMemCpy___0 ((value_type *) 0, (value_type *) 0);
+ has_trivial___0 ();
+ tmp =
+ copyptrs___0 (first, last, result,
+ (struct true_type const *) (&__T144604360));
+ return (tmp);
+ }
+}
+__inline static otherChar *
+copyptrs___0 (char *__8528_43___first, char *__8528_63___last,
+ otherChar * __8528_83___result, struct true_type const *_8)
+{
+}
+
+int main()
+{
+ copyptrs(0,0,0,0);
+ return 0;
+}
--- /dev/null
+#include "testharness.h"
+
+//This was a bug in cabs2cil. Compiling complicated initializers in
+//multiple files generated overlapping global names __constr_expr*
+
+struct logger {
+ char* s;
+ int i;
+};
+
+struct logger *event_list_CHASSIS[]= {
+ &(struct logger){"redSecondaryCPMStatusChange", 2013},
+ &(struct logger){"redRestoreSuccess", 2014},
+ &(struct logger){"redRestoreFail", 2015},
+ 0
+};
+
+extern int c2(void), c3(void);
+int main() {
+ return 0;
+}
--- /dev/null
+#include "testharness.h"
+
+struct logger {
+ char* s;
+ int i;
+};
+
+struct logger *event_list_CHASSIS_2[]= {
+ &(struct logger){"redRestoreSuccess", 2014},
+ &(struct logger){"redRestoreFail", 2015},
+ 0
+};
--- /dev/null
+// combine_node_alloc_1.c
+// "Out of memory" problem
+
+struct node {
+ struct node *link;
+};
+struct node *list[1] = {
+ ((struct node *) 0)
+};
--- /dev/null
+// combine_node_alloc_1.c
+// "Out of memory" problem
+
+struct node {
+ struct node *link;
+};
+struct node *list[1] = {
+ ((struct node *) 0)
+};
+
+int main()
+{
+ return (int)( list[0] );
+}
--- /dev/null
+// combine_samefn_1.c
+// test merging two source files, each of which contain a definition
+// of a given function, but those definitions are identical (up to
+// alpha renaming of locals/params)
+
+// testing --mergeKeepAnnotations
+#pragma ccuredpoly("some_poly_fn")
+
+// repeated function
+int foo(int xxx)
+{
+ int yyy = xxx + 3; // 8
+ int z = yyy + xxx; // 13
+ return z + xxx; // 18
+}
+
+
+int myglobal __attribute__((mayPointToStack)) = 3;
+
+
+// give two inlines, which look like results of merging
+__inline static int func()
+{
+ return 3;
+}
+
+__inline static int func___0();
+__inline static int func___0()
+{
+ return 3;
+}
+
+
+// defined in combine_samefn_2.c
+int otherFunc();
+
+
+int main()
+{
+ int ret = func() + func___0() - 6; // 0
+ ret += foo(5) - 18 + myglobal - 3; // 0
+ ret += otherFunc() - 3; // 0
+ return ret;
+}
+
--- /dev/null
+// combine_samefn_2.c
+
+// repeated function
+int foo(int x)
+{
+ int y = x + 3; // 8
+ int z = y + x; // 13
+ return z + x; // 18
+}
+
+
+// same thing for globals
+int myglobal = 3;
+
+
+// another inline func to collide with those in other file
+__inline static int func();
+
+__inline static int func()
+{
+ return 3;
+}
+
+int otherFunc()
+{
+ return func();
+}
+
+
+
+
--- /dev/null
+typedef int int_type;
+
+typedef int_type int_type1;
+
+static __inline__ int_type1 sbump(struct str1 *const);
--- /dev/null
+typedef int int_type;
+
+typedef int_type int_type1;
+
+__inline static int_type1 sbump(struct str1 *this ) ;
--- /dev/null
+typedef struct pthread_mutex_t pthread_mutex_t;
+
+struct __Q2_4_STL6locale
+{
+ struct __Q2_4_STL12_Locale_impl *_M_impl;
+};
+
+
+typedef int int_type;
+typedef int_type int_type1;
+struct str1
+{
+ int *_M_get;
+};
+
+__inline static int_type1 sbump (struct str1 *this);
+
+__inline static int_type1 sbump (struct str1 *this)
+{
+ int tmp___3;
+ char const *tmp___4;
+ int tmp___5;
+ {
+ tmp___5 = 5;
+ if (tmp___5 > 0)
+ {
+ tmp___4 = 0;
+ }
+ return (tmp___3);
+ }
+}
+
+__inline static int_type1 sbump___0 (struct str1 *this)
+{
+ int tmp___3;
+ char const *tmp___4;
+ int tmp___5;
+ {
+ tmp___5 = 5;
+ if (tmp___5 > 0)
+ {
+ tmp___4 = 0;
+ }
+ return (tmp___3);
+ }
+}
+
+int main(int argc, char *argv)
+{
+ if (argc > 100) { // gcc doesn't know this is always false
+ sbump___0(0); // if actually called, this segfaults
+ }
+ return 0;
+}
--- /dev/null
+ struct f;
+ static __inline__ int sbump(struct f *const);
+
--- /dev/null
+struct someStruct;
+
+__inline static int sbump (struct someStruct *this) // --> sbump___0
+{
+ return (3);
+}
+
+
+__inline static int sbump___0 (struct someStruct *this); // --> sbump___1
+__inline static int sbump___0 (struct someStruct *this)
+{
+ return (3);
+};
+
+foo ()
+{
+ sbump___0 (0);
+}
+
+int main()
+{
+ foo();
+}
--- /dev/null
+static __inline__ void
+__dt__8mystringFv (struct mystring *const this, int x)
+{
+ if (this != 0)
+ {
+ }
+}
--- /dev/null
+
+struct mystring
+{
+};
+
+
+static __inline__ void __dt__8mystringFv (struct mystring *const, int);
+
+extern int __T_9xSysError;
+
+int * glob = &__T_9xSysError;
+
+int __T_9xSysError = 0;
+
+static void* pdt = __dt__8mystringFv;
+
+static __inline__ void
+__dt__8mystringFv (struct mystring *const this, int x)
+{
+ if (this != 0)
+ {
+ }
+}
+
+int main()
+{
+ return 0;
+}
--- /dev/null
+typedef int ptrdiff_t;
+typedef int FILE;
+static __inline__ ptrdiff_t theFunc (const FILE * __18137_44___f) { }
--- /dev/null
+typedef int ptrdiff_t;
+typedef int FILE;
+__inline static ptrdiff_t theFunc (FILE const *__18137_44___f) { }
+
--- /dev/null
+typedef int ptrdiff_t;
+typedef int FILE;
+
+__inline static char equal___0(void);
+
+__inline static void _M_getc___0(void);
+
+__inline static ptrdiff_t theFunc___0 (FILE const *__20468_44___f);
+
+
+__inline static int sgetc___0(void) {
+ theFunc___0 (0);
+}
+
+__inline static char equal___0(void) {
+ _M_getc___0();
+ return 0;
+}
+
+__inline static void _M_getc___0(void) {
+ sgetc___0 ();
+ return;
+}
+
+__inline static ptrdiff_t theFunc___0 (FILE const *__20468_44___f) {
+
+}
+
+
+int main()
+{
+ theFunc___0(0);
+ return 0;
+}
--- /dev/null
+#include <stdio.h>
+
+void __foo(int x) {
+ printf("Hello, world! %d\n", x);
+}
+
+void foo(int x) __attribute__((__alias__("__foo")));;
--- /dev/null
+
+// For linking with combinealias_1.c
+int main() {
+ foo(42);
+ return 0;
+}
--- /dev/null
+/* Make sure that enumeration isomorphism is lax enough */
+enum {
+ INT = 0,
+ FLOAT,
+} x1;
+
+
+void foo() {
+ x1 = FLOAT;
+}
--- /dev/null
+extern enum {
+ INT = 0,
+ FLOAT = 3,
+} x1;
+
+#include "testharness.h"
+
+int main() {
+ foo(); /* Set x1 */
+ if(FLOAT != 3 || x1 != 1) E(1);
+
+ SUCCESS;
+}
--- /dev/null
+/* Make sure that enumeration items get renamed */
+enum e1 {
+ FIRST,
+ SECOND,
+} x1;
+
+
+int main() {
+ return x1;
+}
--- /dev/null
+enum {
+ SECOND,
+ FIRST,
+} x2;
+
+int foo() {
+ return x2;
+}
--- /dev/null
+/* Try to reuse the enum types with the same name */
+enum e1 {
+ FIRST,
+ SECOND,
+} x1;
+
+int main() {
+ return x1;
+}
--- /dev/null
+enum e1 {
+ FIRST = 0,
+ SECOND,
+} x2;
--- /dev/null
+#include "testharness.h"
+
+/* Test that we remove duplicate inline functions */
+inline int foo(int x) {
+ return x;
+}
+
+extern int getfoo2();
+
+int main() {
+ if(getfoo2() != (int)foo) E(1);
+
+ SUCCESS;
+}
--- /dev/null
+inline int foo(int x) {
+ return x;
+}
+
+
+int getfoo2() {
+ return (int)foo;
+}
--- /dev/null
+#include "testharness.h"
+
+/* Test that we do not share too many inlines */
+static int g;
+static inline int foo(int x) { return g; }
+
+extern int getfoo2();
+
+
+int main() {
+ if(getfoo2() == (int)foo) E(1);
+ SUCCESS;
+}
--- /dev/null
+static int g;
+inline int foo(int x) { return g; }
+
+
+int getfoo2() { return (int)foo; }
--- /dev/null
+#include "testharness.h"
+
+/* Test that we rename properly includes even if they have prototypes */
+int foo(int x); /* Declare it here. */
+
+inline int foo(int x) { return x; }
+
+extern getfoo2();
+
+int main() {
+ if(getfoo2() != (int)foo) E(1);
+
+ SUCCESS;
+}
--- /dev/null
+
+int bar(int x); /* Declare it here. Name does not matter. */
+
+inline int bar(int x) { return x; }
+
+
+int getfoo2() {
+ return (int)bar;
+}
--- /dev/null
+#include "testharness.h"
+
+/* Test that we rename properly inlines even if they have prototypes and
+ if they are used before they are defined */
+int foo(int x); /* Declare it here. */
+
+inline int foo(int x) { return x; }
+
+extern getfoo2();
+
+int main() {
+ if(getfoo2() != (int)foo) {
+ printf("Merging of inlines did not work\n");
+ E(1);
+ }
+
+ SUCCESS;
+}
--- /dev/null
+
+int bar(int x); /* Declare it here. Name does not matter. */
+
+
+int getfoo2() { /* Use bar before definition */
+ return (int)bar;
+}
+
+
+inline int bar(int x) { return x; }
+
--- /dev/null
+// Just one file
+
+// This declaration cannot be dropped even though foo2 will be dropped
+static __inline__ int foo2(int x);
+
+
+int main() {
+ void *p = foo2;
+ return foo2(5);
+}
+
+// This definition will be kept since it is the first
+static __inline__ int foo1(int x) {
+ return x - 5;
+}
+
+// This will be dropped
+static __inline__ int foo2(int x) {
+ return x - 5;
+}
--- /dev/null
+// Just an empty file to make sure the merger runs
--- /dev/null
+/*
+ chunk1.c - show that the CIL merger fails to rename a symbol when it must.
+
+ In this file, we declare chunk to be a typedef.
+ In another file we declare it to be a static variable.
+ One of these two must get renamed but neither is.
+
+ Test on Cygwin under Windows XP using CIL 1.2.4
+
+% cilly --save-temps --merge -c chunk1.c C:/cygwin/bin/gcc -D_GNUCC -E -DCIL=1 chunk1.c -o ./chunk1.i
+
+% cilly --save-temps --merge -c chunk2.c C:/cygwin/bin/gcc -D_GNUCC -E -DCIL=1 chunk2.c -o ./chunk2.i
+
+% cilly --save-temps --keepmerged --merge chunk1.o chunk2.o C:/cygwin/home/dlibrik/cil/obj/x86_WIN32/cilly.asm.exe --out ./a.cil.c chunk1.o chunk2.o --mergedout ./a.out_comb.c C:/cygwin/bin/gcc -D_GNUCC -E ./a.cil.c -o ./a.cil.i C:/cygwin/bin/gcc -D_GNUCC -c -o a.out_comb.o ./a.cil.i
+chunk2.c:4: error: `chunk' redeclared as different kind of symbol
+chunk1.c:8: error: previous declaration of `chunk'
+
+ Investigation of a.cil.c shows that "chunk" has been kept for both names.
+ This is clearly a bug, since both typedef and variable should be local.
+*/
+
+#include <string.h>
+
+struct chunk_struct {
+ char c_tab[20];
+ struct chunk_struct *c_prev;
+};
+
+typedef struct chunk_struct chunk;
+
+
+int chunk1(char *s) {
+
+ chunk c;
+
+ strcpy(s, c.c_tab);
+
+ return c.c_tab[0];
+}
+
--- /dev/null
+/*
+ chunk2.c - show that the CIL merger fails to rename a symbol when it must.
+
+ In this file, we declare chunk to be a static variable.
+ In another file we declare it to be a typedef.
+ One of these two must get renamed but neither is.
+
+ Test on Cygwin under Windows XP using CIL 1.2.4.
+
+ See chunk1.c comments for step-by-step reproduction of bug.
+*/
+
+extern int chunk1(char*);
+
+static char fake[1] ;
+static char *chunk = fake;
+
+int main(void)
+{
+ return chunk1(chunk) - fake[0];
+}
+
+
--- /dev/null
+/* test merging of structures whose field names differ */
+
+struct A {
+ int x;
+};
+
+/* make A's type part of the interface */
+extern struct A *connection;
+
+/* refer to A::x */
+int foo()
+{
+ return connection->x;
+}
--- /dev/null
+/* other half of combinestruct1 */
+
+struct B {
+ int y;
+} x;
+
+/* connect A and B */
+struct B *connection = &x;
+
+/*refer to B::y */
+int main()
+{
+ int whatever;
+
+ whatever = connection->y;
+ whatever += foo(); /* for the heck of it */
+
+ return whatever - whatever;
+}
+
--- /dev/null
+// combinetaggedfn_1.c
+// test problem that arises with --separate when one module
+// infers a function must be tagged, but another inferrs
+// it should not be tagged
+
+// in this module, foo will be untagged
+int foo(int x)
+{
+ return x+1;
+}
--- /dev/null
+// combinetaggedfn_2.c
+
+// foo will be tagged
+int foo(int x);
+
+// wrong type; originally used 'void' but our polymorphism defeats hat
+typedef int* (*Func)(int*);
+
+int main()
+{
+ Func f;
+ int x;
+
+ f = (Func)&foo; // make foo tagged
+
+ // cast to correct type and invoke
+ x = ((int (*)(int))f)(3);
+
+ return x-4;
+}
+
+
--- /dev/null
+#include "testharness.h"
+
+
+int to_hex(int x) { return x; }
+
+int main() {
+
+ if(6 != to_hex((5, 6))) E(1);
+
+ SUCCESS;
+}
+
--- /dev/null
+//Test of boolean operators on values larger than int.
+
+#include "testharness.h"
+
+#ifdef _MSC_VER //Microsoft
+# define int64_t __int64
+#else
+# include "sys/types.h"
+#endif
+int main () {
+
+ int64_t a64, b64;
+ float f;
+ double d;
+ int* p = 0;
+
+ int64_t bignum = 1; // compute 2^40 - this would be truncated
+ bignum = bignum << 40; // to zero if cast to int (typically)
+
+
+ a64 = 42;
+ b64 = a64 + bignum;
+ //a64 = b64 modulo 2^32
+
+ if (a64 == b64) {
+ E(1);
+ }
+ if (a64 >= b64) {
+ E(2);
+ }
+ if ((a64|bignum) == a64)
+ E(3);
+
+ if (! bignum) {
+ E(5);
+ }
+
+ f = 0.125f;
+ if (!f)
+ E(10);
+ if (f >= 0.25f)
+ E(11);
+
+ d = 0.125;
+ if (d < f || d > f)
+ E(12);
+
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+int foo() {
+ return 5;
+}
+
+int main() {
+
+ int x1 = ({goto L1; 0;}) && ({L1: 5;});
+
+ printf("x1 = %d\n", x1);
+
+ if(x1 != 1) E(1);
+
+ {
+ int x2 = 0 && ({L2: 5;});
+ if(x2 != 0) E(2);
+ }
+
+ {
+ int x3 = 0 || 5;
+ printf("x3 = %d\n", x3);
+ if(x3 != 1) E(3);
+ }
+
+ {
+ int x4 = 0 || foo();
+ printf("x4 = %d\n", x4);
+ if(x4 != 1) E(4);
+ }
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+int calls_to_foo = 0;
+int foo() {
+ calls_to_foo ++;
+ return calls_to_foo;
+}
+
+enum
+{
+ _ISupper = (( 0 ) < 8 ? ((1 << ( 0 )) << 8) : ((1 << ( 0 )) >> 8)) ,
+ _IScntrl = (( 9 ) < 8 ? ((1 << ( 9 )) << 8) : ((1 << ( 9 )) >> 8)) ,
+};
+
+int main() {
+ static int x = (sizeof(int) == 4) ? (5 && 4) : &main;
+
+ if(x != 1) E(1);
+
+ {
+ int *x2 = &main ? : 0;
+ if(x2 != &main) E(2);
+ }
+
+ {
+ int x3 = foo() ? : 0;
+ if(x3 != 1 || calls_to_foo != 1) E(3);
+ }
+ SUCCESS;
+}
--- /dev/null
+#include <stdlib.h>
+
+/* We must strip all of the "const" qualifiers in structs that are used for
+ * locals */
+struct foo {
+ const int f1;
+ struct bar {
+ const int f2;
+ const int a[8];
+ } b;
+};
+
+int main()
+{
+ const int values[] = { 0 };
+ struct foo f = { 1, 2, 3, 4, 5, 6 };
+ int x;
+ x = values[0];
+ exit(0);
+}
--- /dev/null
+const struct Structure {
+ int field;
+} structure;
+
+
+typedef int Array[10];
+const Array array;
+
+
+void override()
+{
+ *((int *) array[0]) = 2;
+ *((int *) &structure.field) = 1;
+}
--- /dev/null
+struct inner {
+ int field;
+};
+
+
+struct outer {
+ const struct inner inner;
+};
+
+
+int main()
+{
+ struct outer outer = { { 0 } };
+ return outer.inner.field;
+}
--- /dev/null
+#include "testharness.h"
+
+unsigned long long x1 = 0xff00000000000000ULL;
+
+int main() {
+
+ // We'll use shift left to test for sign
+ if((2147483647 /* 2^31 - 1 */ >> 31) != 0) E(1); // Should be signed
+
+ if(((2147483647 + 1) >> 31) != -1) E(2); // Should be signed int
+
+ // Should be signed long long, but both GCC and MSVC treat it as unsigned int
+ if((2147483648 /* 2^31 */ >> 31) != 1) E(3);
+
+
+ if(((2147483647U + 1) >> 31) != 1) E(4); // Should be unsigned signed int
+
+
+ if(x1 >> 56 != 255) E(5);
+
+ // now see if constant folding misbehaves
+ if(0xff00000000000000ULL >> 56 != 255) E(6);
+
+
+ SUCCESS;
+}
+
--- /dev/null
+typedef int some_type[1];
+const some_type mine = {1};
+
+
+int main() {
+ return mine[0] - 1;
+}
--- /dev/null
+#include "testharness.h"
+
+//"one" won't be folded
+volatile int one = 1;
+volatile int minus_one = -1;
+
+#ifdef _MSC_VER
+#define uint64 unsigned __int64
+#else
+#define uint64 unsigned long long
+#endif
+
+int main () {
+ int x = 257;
+ int aa, bb, cc;
+ //left shift
+ int a = ((char)1) << 9 ; // 512
+ char b = ((char)1) << 9 ; // 0
+ int c = 1 << ((char)257); // 2, since ((char)257) == 1
+ uint64 d = 1 << 33 ; // 0, since 1 is an int.
+ uint64 e = ((uint64)1) << 33 ; // 2,0000,0000h (2**33)
+ int f = 1 << 64; // Don't fold this.
+ int g = 1 << -1; // Don't fold this.
+
+
+ printf("a=%d, b=%d, c=%d, d=%d:%u, e=%d:%u, f=%d, g=%d\n",
+ a, b, c,
+ (int)(d>>32), (unsigned int)d, (int)(e>>32), (unsigned int)e,
+ f, g);
+
+ //right shift:
+ aa = ((uint64)0x200000000LL) >> 33; // 1
+ bb = ((uint64)0x200000000LL) >> 65; // Don't fold this. gcc treats it as 0.
+ cc = 3 >> -1; // Don't fold this.
+
+
+ printf("aa=%d, bb=%d, cc=%d\n",
+ aa, bb, cc);
+
+ if (a != 512) E(2);
+ if (b != 0) E(3);
+ if (c != 2) E(4);
+ if (d != 0) E(5);
+ if (e != ((uint64)0x200000000)) E(6);
+ if (f != 0) E(7);
+ if (g != (one << minus_one)) E(8); //Note: MSVC won't pass this; it folds (1 << -1) to 0.
+
+ if (aa != 1) E(9);
+ if (bb != 0) E(10);
+ if (cc != (3 >> minus_one)) E(11);
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+int main() {
+ unsigned int x = (unsigned)0 - 1;
+
+ if((x >= 0) == 0) E(1);
+
+ if (((unsigned)0 - 1 >= 0) == 0)
+ E(2);
+
+ SUCCESS;
+
+ return 0;
+}
--- /dev/null
+#include "testharness.h"
+
+int main() {
+ long long x = 8LL;
+
+ if(x != 8) E(1);
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+struct reiserfs_de_head {
+ int x, y;
+};
+
+int somefunction() {
+ return 8;
+}
+int main() {
+ char empty_dir[sizeof(struct reiserfs_de_head ) * 2 +
+ (strlen(".") + 8LL
+ - 1u & ~ (8LL - 1u)) +
+ (strlen("..") + 8LL - 1u & ~ (8LL - 1u))];
+
+ char another[somefunction()];
+
+ printf("Sizeof empty_dir=%d\n", (int)sizeof(empty_dir));
+ if(sizeof(empty_dir) != 32) E(1);
+
+ printf("Sizeof another=%d\n", (int)sizeof(another));
+ if(sizeof(another) != 8) E(2);
+
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+#include <string.h>
+
+int main() {
+
+ int slen = strlen(".nfs") + 5;
+ char silly[slen+1];
+
+ slen += 20;
+
+ if(sizeof(silly) != 10) E(1)
+
+ SUCCESS;
+}
--- /dev/null
+// From c-torture
+extern struct foo bar;
+struct foo {
+ int a;
+};
+
+int tst[__alignof__ (bar) >= __alignof__ (int) ? 1 : -1];
+
+
+int main() {
+ if(sizeof(tst) != 4)
+ abort();
+
+ exit(0);
+}
--- /dev/null
+/* There was a parsing error here */
+static const int pi = 3, s0 = 7;
--- /dev/null
+#include "testharness.h"
+
+int main() {
+ unsigned base = 5;
+ unsigned long max = (unsigned long) -1 / base;
+
+ unsigned long max1 = (unsigned long) -1;
+ printf("max = %ld, max1 = %ld\n", max, max1 / base);
+
+ if(max != max1 / base) E(1);
+
+ SUCCESS;
+}
+
+
--- /dev/null
+#include "testharness.h"
+
+int glob;
+int globarray[(sizeof(void *) == sizeof(void *)) ? 4 : (int)&glob];
+
+struct foo {
+ int f1, f2, f3;
+};
+
+int arr1[9 * (int)(&((struct foo*)0)->f3)];
+
+int main() {
+ int x=5,y;
+
+ int array[(sizeof(void *) == sizeof(void *)) ? 4 : y];
+
+ switch (x) {
+
+ case ((sizeof(void *) == sizeof(void *)) ? 4 : y ):
+ break;
+ }
+ SUCCESS;
+}
--- /dev/null
+
+#define X 5
+int foo(int x) {
+ int y = ((1UL << 12) / (6 * 64) * 64 * 8 > 1024 * 1024
+ ? 1024 * 1024
+ : (1UL << 12) / (6 * 64) * 64 * 8)
+ / (8 * sizeof(unsigned long int));
+ if(5 > 7 ? 1 + sizeof(char) : 5 << 2) {
+ x ++;
+ } else {
+ x --;
+ }
+}
--- /dev/null
+// Fron c-torture
+/* Copyright (C) 2000 Free Software Foundation.
+
+ by Alexandre Oliva <oliva@lsd.ic.unicamp.br> */
+
+#pragma /* the token after #pragma is optional. */
--- /dev/null
+#include "testharness.h"
+extern int strlen(const char *);
+/* GCC allows a bunch of escapes in strings */
+
+
+char *str = "\( \{ \[ \% \x20 \e \E \a \b \f \n \r \t \v \? \\ \' ";
+
+int main() {
+ if(strlen(str) != 34) E(1);
+ return 0;
+}
--- /dev/null
+struct timeval {
+ int tv_sec;
+ int tv_usec;
+};
+
+extern struct timeval xtime;
+
+
+volatile struct timeval xtime __attribute__ ((aligned (16)));
+
+extern void printf(char *, ...);
+#define E(n) { printf("Error %d\n", n); return n; }
+
+
+int main() {
+ if((int)&xtime & 0xF != 0) E(1);
+
+ printf("Success\n");
+ return 0;
+}
--- /dev/null
+#include "testharness.h"
+
+int f(int );
+int s(int );
+int d(double );
+
+int main() {
+
+ {
+ int x1 = f(5);
+ if(x1 != 5) E(1);
+ }
+
+ {
+ int x2 = f(256);
+ if(x2 != 0) E(2);
+ }
+
+ {
+ int x3 = s(65536 + 1);
+ if(x3 != 1) E(3);
+ }
+
+ {
+ int x4 = d(1);
+ if(x4 != 1) E(4);
+ }
+
+ SUCCESS;
+
+}
+
+// It appears that here the unsigned char takes precedence
+int f(x)
+ unsigned char x;
+{
+ return x;
+}
+
+int s(x)
+ short x;
+{
+ return x;
+}
+
+int d(x)
+ float x;
+{
+ return x;
+}
--- /dev/null
+// decl_mix_stmt.c
+// declarations mixed with statements, a-la C99
+
+// NOTE: gcc-2.x does not support this syntax (but 3.x does)
+
+int main()
+{
+ int x;
+ x = 3;
+
+ int y;
+ y = 6;
+
+ return x+y - 9;
+}
--- /dev/null
+//this case illustrates an "invalid type argument of '->' (tries to
+//dereference something that is not a pointer) when INFERBOX=infer
+
+#define __FD_SETSIZE 1024
+
+//the following two defines are from <bits/select.h>, which can normally
+//only be included from <sys/select.h>, but are included here to
+//"conglomerate" all the source files needed for this test case.
+
+# define __FD_SET(fd, fdsp) \
+ __asm__ __volatile__ ("btsl %1,%0" \
+ : "=m" (__FDS_BITS (fdsp)[__FDELT (fd)]) \
+ : "r" (((int) (fd)) % __NFDBITS) \
+ : "cc","memory")
+
+# define __FD_CLR(fd, fdsp) \
+ __asm__ __volatile__ ("btrl %1,%0" \
+ : "=m" (__FDS_BITS (fdsp)[__FDELT (fd)]) \
+ : "r" (((int) (fd)) % __NFDBITS) \
+ : "cc","memory")
+
+typedef long int __fd_mask;
+
+/* It's easier to assume 8-bit bytes than to get CHAR_BIT. */
+#define __NFDBITS (8 * sizeof (__fd_mask))
+
+/* fd_set for select and pselect. */
+typedef struct
+ {
+#ifdef __USE_XOPEN
+ __fd_mask fds_bits[__FD_SETSIZE / __NFDBITS];
+# define __FDS_BITS(set) ((set)->fds_bits)
+#else
+ __fd_mask __fds_bits[__FD_SETSIZE / __NFDBITS];
+# define __FDS_BITS(set) ((set)->__fds_bits)
+#endif
+ } fd_set;
+
+/* Maximum number of file descriptors in `fd_set'. */
+#define FD_SETSIZE __FD_SETSIZE
+
+/* Access macros for `fd_set'. */
+#define FD_SET(fd, fdsetp) __FD_SET (fd, fdsetp)
+#define FD_CLR(fd, fdsetp) __FD_CLR (fd, fdsetp)
+#define FD_ISSET(fd, fdsetp) __FD_ISSET (fd, fdsetp)
+#define FD_ZERO(fdsetp) __FD_ZERO (fdsetp)
+
+typedef struct isc_mem {
+ unsigned int magic;
+} isc_mem_t;
+
+/* The fd_set member is required to be an array of longs. */
+typedef long int __fd_mask;
+
+typedef struct isc_socketmgr {
+ isc_mem_t *mctx;
+ fd_set read_fds;
+ fd_set write_fds;
+ int fdstate[FD_SETSIZE];
+} isc_socketmgr_t;
+
+typedef struct isc_socket {
+ isc_socketmgr_t *manager;
+ int fd;
+} isc_socket_t;
+
+typedef struct isc_socketevent {
+ unsigned int minimum;
+} isc_socketevent_t;
+
+static void
+wakeup_socket(isc_socketmgr_t *manager, int fd, int msg) {
+ isc_socket_t *sock;
+
+ if (manager->fdstate[fd] == 0) {
+ FD_CLR(fd, &manager->read_fds);
+ FD_CLR(fd, &manager->write_fds);
+ return;
+ }
+ FD_SET(sock->fd, &manager->read_fds);
+ FD_SET(sock->fd, &manager->write_fds);
+}
+
+static void
+allocate_socketevent(isc_socket_t *sock, unsigned int eventtype,
+ int action, const void *arg)
+{
+ isc_socketevent_t *ev;
+
+ ev = (isc_socketevent_t *)isc_event_allocate(sock->manager->mctx,
+ sock, eventtype,
+ action, arg,
+ sizeof (*ev));
+
+}
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+typedef int agp_setup;
+
+
+static int test___0;
+
+static __inline__ unsigned long
+jiffies_to_timespec(unsigned long jiffies, struct timespec *value)
+{
+ return (jiffies % 100 ) * (1000000000L / 100 );
+}
+
+
+int foo(int jiffies) {
+ return test___0 + jiffies;
+}
+
+
+float test;
+
+float bar() {
+ agp_setup x = 5;
+ return x;
+}
+
+extern float jiffies;
+
+int agp_setup(void) {
+ return 5 + jiffies;
+}
--- /dev/null
+int main() {
+ return 0;
+}
+//Lexer test: comment with no trailing newline.
+//This only happens in .i files, since the preprocessor will add the newline
\ No newline at end of file
--- /dev/null
+
+typedef enum foo {
+ F1 = 0,
+ F2 = (long int)(~0UL >> 1),
+ F3,
+ F4
+} ENUM;
+
+
+
+void foo(void) {
+ int x = F2;
+ int y = F1;
+}
--- /dev/null
+extern void exit(int);
+extern void abort(void);
+
+
+// Fron ctorture
+typedef enum foo E;
+enum foo { e0,
+ e1 = e0 + 2 };
+
+enum bar { b0 = e1 };
+
+struct {
+ E eval;
+ enum bar b;
+} s;
+
+void p() {
+ abort();
+}
+
+void f() {
+ switch (s.eval) {
+ case e0:
+ case e1 + 2:
+ p();
+ }
+}
+
+int main() {
+ s.eval = e1;
+ f();
+ exit(0);
+}
--- /dev/null
+#include "testharness.h"
+
+//Make sure we read and generate escapes correctly
+char escapes[]=
+ "\0\1\2\3\4\5\6\a\b\t\n\v\f\r\016\017"
+ "\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f"
+ "\x20\x21\"\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f"
+ "\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f"
+ "\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f"
+ "\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\\\x5d\x5e\x5f"
+ "\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\157"
+ "\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f"
+ "\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f";
+
+
+//This fails on CCured when i gets to 0x80 because of sign extension problems.
+//CCured drops some intermediate casts, assuming that they have no effect,
+//but this is a problem for sign extension on scalars. In this case,
+// (unsigned char)escapes[i] != i
+//becomes
+// (int)(unsigned char)escapes[i] != (int)i
+//in BinOp. But CCured then omits the unsigned char cast and does this:
+// (int)escapes[i] != (int)i
+//which does a sign-extended conversion to it when it shouldn't.
+
+int main(){
+ unsigned char i;
+ for (i = 0; i < 144; i++){
+ if ((unsigned char)escapes[i] != i) {
+ printf("escapes[%d] = 0x%x\n", i, escapes[i]);
+ E(i);
+ }
+ }
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+// CIL seems to drop this on the floor!!!
+extern int main(int argc) {
+ return 0;
+}
--- /dev/null
+#include "testharness.h"
+
+typedef struct _GUID { // #line 17 "C:/ntddk/inc/guiddef.h"
+ unsigned long Data1 ;
+ unsigned short Data2 ;
+ unsigned short Data3 ;
+ unsigned char Data4[8] ;
+} GUID ;
+
+// #line 37 "C:/ntddk/inc/ntddpar.h"
+extern const GUID __declspec(selectany) GUID_PARALLEL_DEVICE = {0x97F76EF0,
+ 0xF883, 0x11D0, {0xAF, 0x1F, 0x00, 0x00, 0xF8, 0x00, 0x84, 0x5C}};
+extern const GUID __declspec(selectany) GUID_PARCLASS_DEVICE = {0x811FC6A5,
+ 0xF728, 0x11D0, {0xA5, 0x37, 0x00, 0x00, 0xF8, 0x75, 0x3E, 0xD1}};
+
+typedef int NTSTATUS;
+typedef void *PDEVICE_OBJECT;
+typedef void *PUNICODE_STRING;
+
+/* __declspec(dllimport) */ NTSTATUS __stdcall
+IoRegisterDeviceInterface(PDEVICE_OBJECT PhysicalDeviceObject ,
+ const GUID * InterfaceClassGuid ,
+ PUNICODE_STRING ReferenceString ,
+ PUNICODE_STRING SymbolicLinkName ) {
+ if (InterfaceClassGuid->Data1 != 0x97F76EF0) {
+ E(1);
+ }
+ return 0;
+}
+
+int main() {
+ NTSTATUS status;
+
+ // #line 470 "pnp.c" of the parport device driver
+ status = IoRegisterDeviceInterface(0, &GUID_PARALLEL_DEVICE, 0, 0);
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+int main()
+{
+ double f1 = 5.e-1 ; // KAI CC emits code like this
+ double f2 = 5.00000e-1 ; // this is normal
+
+ if (f1 != f2) {
+ E(1);
+ }
+ SUCCESS;
+}
--- /dev/null
+#include <stdio.h>
+#include <string.h>
+int main() {
+ double a[2][2];
+ memcpy(a, (double[2][2]) { { 1.0, 2.0 } , { 3.0, 4.0 } }, sizeof a);
+ printf("%f %f %f %f\n", a[0][0], a[0][1], a[1][0], a[1][1]);
+ return 0;
+}
--- /dev/null
+#include "testharness.h"
+
+int main() {
+ int z;
+ for(int i = 0, j = 5; i <= 3 && j >= 3; i ++, j --, z = i) {
+ i += j - 3;
+ }
+ if(z != 5) E(1);
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+
+//
+//Test scoping of formal names
+//
+
+double renamed;
+
+void bar(typeof(renamed) x, //"renamed" refers to the global, with type double
+ int renamed,
+ typeof(renamed) z) //"renamed" refers to the second formal
+{
+ if (sizeof(x) != sizeof(double)) E(2);
+ if (sizeof(z) != sizeof(int)) E(3);
+ if (x + renamed != z) E(4);
+}
+
+int main(void)
+{
+ bar(1.0, 2, 3);
+ SUCCESS;
+}
--- /dev/null
+int (*pfun1)(int (*)(int), int);
+int (*pfun2)(int (*)(int), int);
+
+typedef int (*intfun)(int);
+intfun arrfun[5];
+
+int testf(int k) {
+ return k;
+}
+
+int foo(int (*bar)(int), int n) {
+
+ pfun1 = foo;
+ pfun1 = & foo;
+ pfun1 = * * * pfun2;
+
+ pfun1 = arrfun[4];
+
+ pfun2(* * testf, 5);
+
+ return 1;
+}
+
+
--- /dev/null
+// gcc and Elsa handle this but Cil can't handle this:
+void
+(*posix_signal(sig_num, action))()
+ int sig_num;
+ void (*action)();
+{
+}
+
+// These are ok in all three tools. The fun thing is that I guessed // these two would go through Cil before I tried them. :-)
+void posix_signal2(sig_num, action)
+ int sig_num;
+ void (*action)();
+{
+}
+
+void
+(*posix_signal3(int sig_num, void (*action)() ))() {
+ return 0;
+}
+
+int main() {
+ return 0;
+}
+
--- /dev/null
+extern void exit(int);
+
+
+// A test with function pointers
+typedef int (* FUN1)();
+
+
+// Fun1 will be a wild function
+int fun1(int i1, int* p2, int* p3, int i4) {
+ return i1 + *p2 + *p3 + i4;
+}
+
+// Now make fun1 a WILD function pointer
+FUN1 g = fun1;
+
+
+int main() {
+ int loc1 = 7, loc2 = 9, loc3 = 11;
+
+ // Call fun1 through g
+ if(g(5, &loc1, &loc2, 13) != 34)
+ exit(1);
+
+ // Call fun1 directly
+ if(fun1(1, &loc1, &loc3, 7) != 26)
+ exit(2);
+
+
+ exit(0);
+}
--- /dev/null
+
+typedef int (*func)(); // Declare this without arguments
+
+int foo(int *x, int z, int *y) {
+ return *x + z + *y;
+}
+
+int main() {
+ int x = 5, y = 7, z = 13;
+
+ func f = foo;
+
+ x = f(&x, &z, &y) - 12 - (int)&z; // Should be 0
+
+ return x + foo(&x, z, &y) - 20;
+
+
+}
+
--- /dev/null
+typedef struct {
+ int (*f)(int);
+} FOO;
+
+int highorder(int a(int), int arg) {
+ return a(arg);
+}
+
+int incr(int x) {
+ return x + 1;
+}
+#include "testharness.h"
+
+int main() {
+ if(highorder(incr, 5) != 6) E(1);
+
+ {
+ FOO x = { incr };
+ if(x.f(6) != 7) E(2);
+ }
+
+ SUCCESS;
+
+}
--- /dev/null
+#include "testharness.h"
+
+/* An argument whose type is a function should be turned into a function
+ * pointer */
+
+int foo(int x()) {
+ return x();
+}
+
+// A prototype. This should work but right now it does not because of the
+// way abs_direct_decl is defined in cparser.mly. If we use the definition
+// from the book we get conflicts
+int bar(int ());
+
--- /dev/null
+#include "testharness.h"
+
+typedef int (ide_dmaproc_t)(int, int *);
+
+
+
+int test(int x, int *y) {
+ return x + *y;
+}
+
+struct foo {
+ ide_dmaproc_t *dmaproc;
+} x = { test };
+
+
+
+int main() {
+ int y = 7;
+
+ if(x.dmaproc(5, &y) != 12) E(1);
+
+ SUCCESS;
+}
--- /dev/null
+
+static int *glob2;
+
+int *glob1 = (int*) & glob2;
+
+static int *glob2 = (int*) & glob1;
+
+int arr2[10];
+int arr2[10];
+int arr2[10];
+
--- /dev/null
+
+extern int base_files[];
+const char *const lang_dir_names[] = { "c",
+((void *)0)};
+
+int base_files[((sizeof (lang_dir_names) / sizeof ((lang_dir_names)[0])) - 1)]
+= { sizeof(lang_dir_names[1]) }
+;
--- /dev/null
+#include <stdio.h>
+
+
+
+int main() {
+ printf("Hello world\n");
+ return 0;
+}
--- /dev/null
+unsigned short read2Target(unsigned char * ptr )
+{
+ if (1 /* targetNotLikeHost */) {
+ return ((unsigned short )(((int )(*ptr) << 8) + (int )(*(ptr + 1))));
+ } else {
+ return ((*((unsigned short *)ptr)));
+ }
+}
+
+int readStructTarget(unsigned char * filePtr ,
+ unsigned char * fileEnd , ...) {
+ int x = read2Target(fileEnd);
+ return x;
+}
--- /dev/null
+#ifndef __NULLTERM
+#define __NULLTERM
+#define __SIZED
+#endif
+#include "testharness.h"
+
+extern int strcmp(const char*, const char*);
+
+/* run this with COMPATMODE=1 if compiling directly, since neither GCC nor
+ * MSVCC fully support the C standard */
+static char *usageplocal = "Usage";
+static char usageescape = 'C';
+
+char *usagep = "Usage non-local";
+char *usagep1 = { "Usage in a brace" };
+int g = { 6 } ;
+
+char usages[] = ("Usage string");
+char strange[] = { "several" };
+
+char *null = (void*)0;
+
+
+typedef struct s {
+ char *name;
+ int data;
+} STR;
+
+extern int afunc(int x);
+int (*fptr)(int) = afunc;
+
+STR a[] = {
+ {"first", 0},
+ {"second", 1},
+ {& usages[2], 2},
+ { & usageescape, 3},
+ { usages, 4},
+};
+
+
+typedef struct {
+ struct {
+ char * a1[10];
+ char * a2;
+ char strbuff[20] __NULLTERM;
+ } f1;
+ struct {
+ int * i1;
+ } f2[5] __SIZED;
+} NESTED;
+
+NESTED glob1;
+
+int glob3;
+int * glob2 = & glob3;
+
+int afunc(int a) {
+ NESTED loc1;
+ char locbuff[30] __NULLTERM;
+ char indexbuff[10] __SIZED;
+
+ loc1.f1.a2 = glob1.f1.a2;
+
+ return * loc1.f2[3].i1 + (locbuff[0] - indexbuff[0]);
+}
+
+
+
+// now initialization for union
+union {
+ struct {
+ int a;
+ int *b;
+ } u1;
+ int c;
+} uarray[] = { 1, 0, 2, 0, 3, 0 };
+
+
+// now some examples from the standard
+int z[4][3] =
+{ { 1 }, { 2 }, { 3 }, { 4 } };
+
+struct str1 { int a[3]; int b;};
+
+struct str1 w[] =
+{ { 1 }, { 2 } };
+
+
+short q[4][3][2] = {
+ { 1 } ,
+ { 2, 3 },
+ { 4, 5, 6}
+};
+
+short q1[4][3][2] = {
+ 1, 0, 0, 0, 0, 0,
+ 2, 3, 0, 0, 0, 0,
+ 4, 5, 6, 0, 0, 0,
+};
+
+
+
+#ifdef _GNUCC
+int a1[10] = {
+ 1, 3, 5, 7, 9, [6] = 8, 6, 4, 2};
+
+
+enum { member_one, member_two, member_three };
+char *nm[] = {
+ [member_two] = "member_two",
+ [member_three] = "member_three",
+};
+
+
+#endif
+
+
+
+#define ERROR(n) { printf("Incorrect init: %d\n", n); exit(1); }
+// Test the initialization
+int main() {
+ int i;
+
+ char localarrayinit = (("init with " "parens"));
+
+ struct str1 astr = w[0];
+
+ if(strcmp(a[0].name, "first")) {
+ ERROR(0);
+ }
+ if(sizeof(uarray) / sizeof(uarray[0]) != 3) {
+ ERROR(1);
+ }
+ if(uarray[2].u1.a != 3) {
+ ERROR(2);
+ }
+
+ if(z[2][0] != 3 ||
+ z[2][1] != 0) {
+ ERROR(4);
+ }
+
+ if(sizeof(w) / sizeof(w[0]) != 2 ||
+ w[1].a[0] != 2) {
+ ERROR(5);
+ }
+ {
+ short * ps = (short*)q, * ps1 = (short*)q1;
+ for(i=0;i<sizeof(q) / sizeof(short); i++, ps ++, ps1 ++) {
+ if(*ps != *ps1) {
+ ERROR(6);
+ }
+ }
+ }
+
+#ifdef _GNUCC
+ if(a1[1] != 3 ||
+ a1[5] != 0 ||
+ a1[6] != 8 ||
+ a1[7] != 6) {
+ ERROR(7);
+ }
+
+
+ if(strcmp(nm[1], "member_two") ||
+ strcmp(nm[2], "member_three") ||
+ sizeof(nm) != 3 * sizeof(nm[0])) {
+ ERROR(8);
+ }
+
+#endif
+
+
+ printf("Initialization test succeeded\n");
+ return 0;
+}
+
+
+
--- /dev/null
+extern void exit(int);
+
+struct {
+ struct {
+ int *f1;
+ int *f2;
+ } s1;
+ struct {
+ int *f3;
+ } s2;
+} memory[10] = { 1 };
+
+int main() {
+ if(memory[0].s1.f1 != (int*)1)
+ exit(1);
+ exit(0);
+}
--- /dev/null
+#include "testharness.h"
+
+typedef int tint;
+
+
+struct foo {
+ int other;
+ int tint; // Reuse the typedef name
+} x = { tint : 5 };
+
+
+int main() {
+ if(x.tint != 5) E(1);
+ if(x.other != 0) E(2);
+
+ SUCCESS;
+}
+
--- /dev/null
+#include "testharness.h"
+
+
+void foo(int invok) {
+ static const int honour_longs = (4 > 4) || (4 > 4);
+ static int bar = 0;
+
+ if(invok == 0) {
+ if(honour_longs != 0) E(1);
+ if(bar != 0) E(2);
+ bar = 1;
+ return;
+ }
+ if(bar != 1) E(3);
+ return;
+}
+
+
+int main() {
+
+ static int bar = 3;
+ foo(0);
+ if(bar != 3) E(4);
+ foo(1);
+ if(bar != 3) E(5);
+
+ SUCCESS;
+}
+
--- /dev/null
+#include "testharness.h"
+
+// From c-torture
+struct empty { };
+struct something {
+ int spacer;
+ struct empty foo;
+ int bar;
+};
+
+struct something X = {
+ foo: (struct empty) { },
+ bar: 1,
+};
+
+
+int main() {
+ if(X.bar != 1) E(1);
+ if(X.spacer != 0) E(2);
+
+ SUCCESS;
+}
--- /dev/null
+// From c-torture
+#include "testharness.h"
+
+typedef struct
+{
+ char *key;
+ char *value;
+} T1;
+
+typedef struct
+{
+ long type;
+ char *value;
+} T3;
+
+T1 a[] =
+{
+ {
+ "",
+ ((char *)&((T3) {1, (char *) 1}))
+ }
+};
+
+
+int main() {
+ T3 *t3;
+
+ if(sizeof(a) != sizeof(T1)) E(1);
+
+ if(a[0].key[0]) E(2);
+
+ t3 = a[0].value;
+ if(t3->type != 1) E(3);
+ if(t3->value != 1) E(4);
+
+
+ SUCCESS;
+}
+
--- /dev/null
+#include "testharness.h"
+
+
+
+
+int main() {
+ if(((int []){1, 2, 3, 4})[1] != 2) E(1);
+
+ ((int []){1, 2, 3, 4})[1] = 15;
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+typedef struct {int x, y;} brlock_read_lock_t;
+
+#define NR_CPUS 4
+#define __BR_IDX_MAX 4
+#define RW_LOCK_UNLOCKED { 5, 6 }
+
+brlock_read_lock_t __brlock_array[NR_CPUS][__BR_IDX_MAX] =
+ { [0 ... NR_CPUS-1] = { [0 ... __BR_IDX_MAX-1] = RW_LOCK_UNLOCKED } };
+
+int main() {
+ int i, j;
+ for(i=0;i<NR_CPUS;i++) {
+ for(j=0;j<__BR_IDX_MAX;j++) {
+ if(__brlock_array[i][j].x != 5 ||
+ __brlock_array[i][j].y != 6) {
+ printf("At index [%d][%d] I found { %d, %d }\n",
+ i, j, __brlock_array[i][j].x, __brlock_array[i][j].y);
+ exit(1);
+ }
+ }
+ }
+ return 0;
+}
+
--- /dev/null
+//The Gnome calendar application uses initializers with arithmetic expressions:
+#include "testharness.h"
+
+
+int x = ! (3 && ! 3);
+
+int array[(3 && !3) ? 6 : 8];
+
+int main() {
+ return x - 1;
+}
+
--- /dev/null
+#include "testharness.h"
+
+static int f()
+{
+ return 0x101;
+}
+
+int c0 = (char)257;
+
+int main(int argc, char **argv)
+{
+ int c1 = (char)f();
+ int c2;
+ int c3 = (char)257;
+ c2 = (char)f();
+ printf("Should be 1: c0=%d, c1=%d, c2=%d, c3=%d\n", c0, c1, c2, c3);
+ if(c0 != 1) E(1);
+ if(c1 != 1) E(2);
+ if(c2 != 1) E(3);
+ if(c3 != 1) E(4);
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+struct foo {
+ int a,b;
+};
+
+//The length should be 5, not 3.
+static struct foo foos[]={
+ {1},
+ {},
+ {3,4},
+ {},
+ {}
+};
+
+int main() {
+ printf("sizeof foos = %d.\n", sizeof(foos));
+
+ if (sizeof(foos) != 5*sizeof(struct foo)) E(1);
+ if (foos[2].b != 4) E(2);
+ if (foos[4].b != 0) E(3);
+
+ return 0;
+}
--- /dev/null
+typedef struct tTimNetAddr {
+ int isIPv4;
+ union
+ {
+ int addr;
+ struct {double d; int x; } addr6;
+ } u;
+} tTimNetAddr;
+
+tTimNetAddr isisPolChangePrefixV6 = {
+ .isIPv4 = 0,
+ .u = {
+ .addr6 = {.d = 0.0, .x = 5},
+ },
+};
+
+
+int main() {
+ return isisPolChangePrefixV6.u.addr6.x != 5;
+}
--- /dev/null
+extern void printf(char *, ...);
+#define E(n) { printf("Error %d\n", n); return n; }
+
+// from linux sources
+int tickadj1 = 500/ 100 ? : 1;
+int tickadj2 = 0 / 100 ? : 1;
+
+int main() {
+ if(tickadj1 != 5) E(1);
+ if(tickadj2 != 1) E(2);
+
+ return 0;
+}
--- /dev/null
+
+#include "testharness.h"
+
+
+typedef struct
+{
+ int b;
+} str2;
+typedef struct
+{
+ int c;
+ int d;
+} str4;
+typedef struct
+{
+ int a;
+ union u
+ {
+ str2 m1;
+ str4 m2;
+ } u;
+} str3;
+
+int scrambleTheStack(int x) __attribute__((__noinline__))
+{
+ char junk[256];
+ int i = 0;
+ while (i < 256) {junk[i++] = 0xaa; }
+ return junk[x];
+}
+
+//What to do with the union z.u, which has no explicit initializer?
+//ISO C says to initialize only the first field (m1, which is smaller than m2),
+//but gcc initializes the whole union to zero
+
+void test(void) __attribute__((__noinline__))
+{
+ str3 z = {0};
+ printf ("z.u.m2.d = 0x%x\n", z.u.m2.d);
+ if (z.u.m2.d != 0) E(2);
+}
+
+
+int main(void)
+{
+ scrambleTheStack(200);
+ test();
+ return 0;
+}
--- /dev/null
+#include "testharness.h"
+
+//Linux: sound/usb/usbaudio.c
+typedef struct snd_usb_audio_quirk snd_usb_audio_quirk_t;
+typedef struct snd_usb_midi_endpoint_info snd_usb_midi_endpoint_info_t;
+
+enum quirk_type {
+ QUIRK_IGNORE_INTERFACE,
+ QUIRK_COMPOSITE,
+ QUIRK_MIDI_STANDARD_INTERFACE,
+ QUIRK_MIDI_FIXED_ENDPOINT,
+ QUIRK_MIDI_YAMAHA,
+ QUIRK_MIDI_MIDIMAN,
+ QUIRK_MIDI_NOVATION,
+ QUIRK_MIDI_RAW,
+ QUIRK_MIDI_EMAGIC,
+ QUIRK_MIDI_MIDITECH,
+ QUIRK_AUDIO_STANDARD_INTERFACE,
+ QUIRK_AUDIO_FIXED_ENDPOINT,
+ QUIRK_AUDIO_EDIROL_UA700_UA25,
+ QUIRK_AUDIO_EDIROL_UA1000,
+
+ QUIRK_TYPE_COUNT
+};
+
+enum sndrv_pcm_format {
+ SNDRV_PCM_FORMAT_S8 = 0,
+ SNDRV_PCM_FORMAT_U8,
+ SNDRV_PCM_FORMAT_S16_LE,
+ SNDRV_PCM_FORMAT_S16_BE,
+ SNDRV_PCM_FORMAT_U16_LE,
+ SNDRV_PCM_FORMAT_U16_BE,
+ SNDRV_PCM_FORMAT_S24_LE,
+ SNDRV_PCM_FORMAT_S24_BE,
+ SNDRV_PCM_FORMAT_U24_LE,
+ SNDRV_PCM_FORMAT_U24_BE,
+ SNDRV_PCM_FORMAT_S32_LE,
+ SNDRV_PCM_FORMAT_S32_BE,
+ SNDRV_PCM_FORMAT_U32_LE,
+ SNDRV_PCM_FORMAT_U32_BE,
+ SNDRV_PCM_FORMAT_FLOAT_LE,
+ SNDRV_PCM_FORMAT_FLOAT_BE,
+ SNDRV_PCM_FORMAT_FLOAT64_LE,
+ SNDRV_PCM_FORMAT_FLOAT64_BE,
+ SNDRV_PCM_FORMAT_IEC958_SUBFRAME_LE,
+ SNDRV_PCM_FORMAT_IEC958_SUBFRAME_BE,
+ SNDRV_PCM_FORMAT_MU_LAW,
+ SNDRV_PCM_FORMAT_A_LAW,
+ SNDRV_PCM_FORMAT_IMA_ADPCM,
+ SNDRV_PCM_FORMAT_MPEG,
+ SNDRV_PCM_FORMAT_GSM,
+ SNDRV_PCM_FORMAT_SPECIAL = 31,
+ SNDRV_PCM_FORMAT_S24_3LE = 32,
+ SNDRV_PCM_FORMAT_S24_3BE,
+ SNDRV_PCM_FORMAT_U24_3LE,
+ SNDRV_PCM_FORMAT_U24_3BE,
+ SNDRV_PCM_FORMAT_S20_3LE,
+ SNDRV_PCM_FORMAT_S20_3BE,
+ SNDRV_PCM_FORMAT_U20_3LE,
+ SNDRV_PCM_FORMAT_U20_3BE,
+ SNDRV_PCM_FORMAT_S18_3LE,
+ SNDRV_PCM_FORMAT_S18_3BE,
+ SNDRV_PCM_FORMAT_U18_3LE,
+ SNDRV_PCM_FORMAT_U18_3BE,
+ SNDRV_PCM_FORMAT_LAST = SNDRV_PCM_FORMAT_U18_3BE,
+
+
+ SNDRV_PCM_FORMAT_S16 = SNDRV_PCM_FORMAT_S16_LE,
+ SNDRV_PCM_FORMAT_U16 = SNDRV_PCM_FORMAT_U16_LE,
+ SNDRV_PCM_FORMAT_S24 = SNDRV_PCM_FORMAT_S24_LE,
+ SNDRV_PCM_FORMAT_U24 = SNDRV_PCM_FORMAT_U24_LE,
+ SNDRV_PCM_FORMAT_S32 = SNDRV_PCM_FORMAT_S32_LE,
+ SNDRV_PCM_FORMAT_U32 = SNDRV_PCM_FORMAT_U32_LE,
+ SNDRV_PCM_FORMAT_FLOAT = SNDRV_PCM_FORMAT_FLOAT_LE,
+ SNDRV_PCM_FORMAT_FLOAT64 = SNDRV_PCM_FORMAT_FLOAT64_LE,
+ SNDRV_PCM_FORMAT_IEC958_SUBFRAME = SNDRV_PCM_FORMAT_IEC958_SUBFRAME_LE,
+};
+
+
+struct snd_usb_audio_quirk {
+ const char *vendor_name;
+ const char *product_name;
+ short ifnum;
+ short type;
+ const void *data;
+};
+
+struct snd_usb_midi_endpoint_info {
+ char out_ep;
+ char out_interval;
+ char in_ep;
+ char in_interval;
+ short out_cables;
+ short in_cables;
+};
+
+
+
+struct usb_device_id {
+
+ short match_flags;
+
+
+ short idVendor;
+ short idProduct;
+ short bcdDevice_lo;
+ short bcdDevice_hi;
+
+
+ char bDeviceClass;
+ char bDeviceSubClass;
+ char bDeviceProtocol;
+
+
+ char bInterfaceClass;
+ char bInterfaceSubClass;
+ char bInterfaceProtocol;
+
+
+ unsigned long driver_info;
+};
+
+struct audioformat {
+ //struct list_head list;
+ int format;
+ unsigned int channels;
+ unsigned int fmt_type;
+ unsigned int frame_size;
+ int iface;
+ unsigned char altsetting;
+ unsigned char altset_idx;
+ unsigned char attributes;
+ unsigned char endpoint;
+ unsigned char ep_attr;
+ unsigned int maxpacksize;
+ unsigned int rates;
+ unsigned int rate_min, rate_max;
+ unsigned int nr_rates;
+ unsigned int *rate_table;
+};
+
+
+static struct usb_device_id usb_audio_ids [] = {
+{ .match_flags = (0x0001 | 0x0002),
+ .idVendor = (0x0499), .idProduct = (0x1000),
+ .driver_info = (unsigned long) & (const snd_usb_audio_quirk_t)
+ { .vendor_name = "Yamaha",
+ .product_name = "UX256",
+ .ifnum = -1,
+ .type = 1 }
+},
+
+{
+ .match_flags = (0x0001 | 0x0002), .idVendor = (0x0582), .idProduct = (0x0000),
+ .driver_info = (unsigned long) & (const snd_usb_audio_quirk_t) {
+ .vendor_name = "Roland",
+ .product_name = "UA-100",
+ .ifnum = -1,
+ .type = QUIRK_COMPOSITE,
+ .data = (const snd_usb_audio_quirk_t[]) {
+ {
+ .ifnum = 0,
+ .type = QUIRK_AUDIO_FIXED_ENDPOINT,
+ .data = & (const struct audioformat) {
+ .format = SNDRV_PCM_FORMAT_S16_LE,
+ .channels = 4,
+ .iface = 0,
+ .altsetting = 1,
+ .altset_idx = 1,
+ .attributes = 0,
+ .endpoint = 0x01,
+ .ep_attr = 0x09,
+ .rates = (1<<30),
+ .rate_min = 44100,
+ .rate_max = 44100,
+ }
+ },
+ {
+ .ifnum = 1,
+ .type = QUIRK_AUDIO_FIXED_ENDPOINT,
+ .data = & (const struct audioformat) {
+ .format = SNDRV_PCM_FORMAT_S16_LE,
+ .channels = 2,
+ .iface = 1,
+ .altsetting = 1,
+ .altset_idx = 1,
+ .attributes = 0x80,
+ .endpoint = 0x81,
+ .ep_attr = 0x05,
+ .rates = (1<<30),
+ .rate_min = 44100,
+ .rate_max = 44100,
+ }
+ },
+ {
+ .ifnum = 2,
+ .type = QUIRK_MIDI_FIXED_ENDPOINT,
+ .data = & (const snd_usb_midi_endpoint_info_t) {
+ .out_cables = 0x0007,
+ .in_cables = 0x0007
+ }
+ },
+ {
+ .ifnum = -1
+ }
+ }
+ }
+},
+{ }
+} ;
+
+
+struct foo{ int x; int y; const void* p; };
+
+//struct foo glb = { .x = 4, .y = (int) & (struct foo){ .x = 1, .y = 2 } };
+
+int main() {
+ // struct foo* p = & (struct foo){ .x = 1, .y = 2 };
+ // return p->x;
+ snd_usb_audio_quirk_t* driver_info = (snd_usb_audio_quirk_t*)
+ (usb_audio_ids[1].driver_info);
+ if (((snd_usb_midi_endpoint_info_t*)((snd_usb_audio_quirk_t*)driver_info->data)[2].data)->out_cables != 7) E(3);
+ if (((snd_usb_audio_quirk_t*)driver_info->data)[3].ifnum
+ != -1) E(4);
+
+ SUCCESS;
+}
--- /dev/null
+//Test for a compound initializer bug. The if statement for t?2:3 was being
+//added twice.
+
+//Bug report from Peter Hawkins, based on
+//linux-2.6.17.1/net/ipv4/route.c:ip_route_output_slow
+
+//Patch by Benjamin Monate
+
+struct bar {
+ int x;
+};
+struct foo {
+ struct bar b;
+ int y;
+};
+
+int rand(void);
+
+int main() {
+ int t = rand();
+ struct foo f = {
+ .b = {
+ .x = (t?2:3),
+ },
+ .y = 42
+ };
+ return 0;
+}
--- /dev/null
+// From the linux sources
+struct hw_interrupt_type {
+ const char * typename;
+ void (*startup)(unsigned int irq);
+ void (*shutdown)(unsigned int irq);
+ void (*handle)(unsigned int irq);
+ void (*enable)(unsigned int irq);
+ void (*disable)(unsigned int irq);
+};
+
+extern struct hw_interrupt_type no_irq_type;
+
+struct irqaction {
+ void (*handler)(int, void *);
+ unsigned long flags;
+ unsigned long mask;
+ const char *name;
+ void *dev_id;
+ struct irqaction *next;
+};
+
+typedef struct {
+ unsigned int status;
+ struct hw_interrupt_type *handler;
+ struct irqaction *action;
+ unsigned int depth;
+} irq_desc_t;
+
+#define NR_IRQS 224
+irq_desc_t irq_desc[] = { [0 ... NR_IRQS -1] = { 0, &no_irq_type, }};
+
+extern void printf(char *, ...);
+#define E(n) {printf("Error %d\n", n); return n;}
+
+int main() {
+
+ if(sizeof(irq_desc) / sizeof(irq_desc[0]) != NR_IRQS) E(1);
+
+ if(irq_desc[0].handler != &no_irq_type) E(2);
+
+ if(irq_desc[NR_IRQS / 2].handler != &no_irq_type) E(2);
+
+ if(irq_desc[NR_IRQS - 1].handler != &no_irq_type) E(2);
+
+ printf("Success\n");
+ return 0;
+}
+
+
+// Define the no_irq_type here
+struct hw_interrupt_type no_irq_type;
--- /dev/null
+typedef unsigned long longtype;
+
+typedef longtype partidtype ;
+
+typedef char parttype[10] ;
+
+typedef struct Connection_Type {
+ partidtype to ;
+ parttype type ;
+ longtype length ;
+} Connection ;
+
+extern void printf(char *, ...);
+#define E(n) { printf("Error %d\n", n); return(1); }
+
+// From VORTEX
+int main() {
+ static Connection link[3] =
+ {{1, "link1", 10}, {2, "link2", 20}, {3, "link3", 30}};
+
+ if (sizeof(long) == 4) {
+ if(sizeof(link[0]) != 4 + 10 + 2 + 4) E(1);
+ } else if (sizeof(long) == 8) {
+ if(sizeof(link[0]) != 8 + 10 + 6 + 8) E(1);
+ }
+
+ if(link[0].length != 10) E(2);
+
+ if(link[2].length != 30) E(3);
+
+ if(strcmp("link2", link[1].type)) E(4);
+
+ if(link[1].type[6] != 0) E(5);
+
+ printf("Success\n");
+ return 0;
+}
--- /dev/null
+#include "testharness.h"
+typedef struct {
+ int gcc_is_buggy ;
+} spinlock_t ;
+
+struct list_head {
+ struct list_head * next , * prev ;
+} ;
+
+struct __wait_queue_head {
+ spinlock_t lock ;
+ struct list_head task_list ;
+} ;
+typedef struct __wait_queue_head wait_queue_head_t ;
+
+
+static wait_queue_head_t reiserfs_commit_thread_done = {
+ .lock = (spinlock_t){0},
+ .task_list = {& reiserfs_commit_thread_done.task_list,
+ & reiserfs_commit_thread_done.task_list}
+};
+
+
+int main() {
+ if(reiserfs_commit_thread_done.task_list.next !=
+ & reiserfs_commit_thread_done.task_list) E(1);
+
+ if(reiserfs_commit_thread_done.task_list.prev !=
+ & reiserfs_commit_thread_done.task_list) E(2);
+
+ SUCCESS;
+
+}
--- /dev/null
+#include "testharness.h"
+
+struct A {
+ struct S { int x; } s;
+ int a[4];
+ int : 8; // Unnnamed field
+ int *p;
+};
+
+struct S s = { 8 };
+
+struct B {
+ struct A a1;
+ struct A a2;
+ struct A a3;
+ struct A a4;
+ struct A a5;
+};
+
+struct A a = { 1, 2, 3, 4, 5, 6 };
+
+
+int main() {
+ struct B b = { .a2 = { .s = { .x = 5 }}, // a2
+ s, 0, 0, 0, 0, 0, // a3
+ 6, { 0 }, 0, // a4
+ a // a5
+ } ;
+
+ if(s.x != 8) E(2);
+
+ if(a.s.x != 1 || a.a[1] != 3 || a.p != 6) E(3);
+
+ if(b.a2.s.x != 5) E(1);
+
+ if(b.a2.a[2] != 0) E(4);
+
+ if(b.a3.s.x != s.x) E(5);
+
+ if(b.a4.s.x != 6) E(6);
+
+ if(b.a5.a[2] != a.a[2]) E(7);
+
+ {
+ struct B b1 = { .a2 = a,
+ .a1 = b.a4 };
+
+ if(b1.a2.a[2] != a.a[2]) E(11);
+
+ if(b1.a1.s.x != b.a4.s.x) E(12);
+
+ }
+
+ {
+ struct B b2 = { .a2.a[1 ... 2] = 7, 8, 9, // a2.a[1], [2] and [3], a2.p
+ 10, 11, 12, 13, 14, // a3
+ .a1.s.x = 15, 16, 17, 18, 19, 20,// a1.s.x a1.a[0 ...3], p
+ 21, 22, 23, // a2.s.x a2.a[0..1]
+ .a3.p = 8, // Overwrite the 14 from above
+ };
+
+ if(b2.a2.a[0] != 22) E(20);
+ if(b2.a2.a[1] != 23) E(21);
+ if(b2.a2.a[2] != 7) E(22);
+ if(b2.a3.s.x != 10) E(23);
+ if(b2.a3.a[0] != 11) E(24);
+ if(b2.a3.a[1] != 12) E(25);
+ if(b2.a3.a[2] != 13) E(26);
+ if(b2.a3.a[3] != 14) E(27);
+ if(b2.a3.p != 8) E(28); // Was overwritten later
+
+ if(b2.a1.s.x != 15) E(29);
+
+ if(b2.a1.a[0] != 16) E(30);
+ if(b2.a1.a[1] != 17) E(31);
+ if(b2.a1.a[2] != 18) E(32);
+ if(b2.a1.a[3] != 19) E(33);
+
+ if(b2.a1.p != 20) E(34);
+
+ if(b2.a2.s.x != 21) E(35);
+ }
+
+ SUCCESS;
+
+}
+
--- /dev/null
+
+#include "testharness.h"
+
+
+struct new_utsname {
+ char sysname[65];
+ char nodename[65];
+ char release[65];
+ char version[65];
+ char machine[65];
+ char domainname[65];
+};
+
+extern struct new_utsname system_utsname;
+
+extern struct rw_semaphore uts_sem;
+
+
+int Version_132101 ;
+
+struct new_utsname system_utsname = {
+ "Linux" , "(none)" , "2.4.5" , "#24 Fri Nov 16 21:05:13 PST 2001" ,
+ "i386" , "(none)"
+};
+
+const char *linux_banner =
+ "Linux version " "2.4.5" " (" "necula" "@"
+ "manju" ") (" "gcc version 2.95.3 20010315 (release)" ") " "#24 Fri Nov 16 21:05:13 PST 2001" "\n";
+
+
+
+int main() {
+ SUCCESS;
+}
--- /dev/null
+struct pci_device_info {
+ unsigned short device;
+ unsigned short seen;
+ const char *name;
+};
+
+static struct pci_device_info __devices_0000 []
+__attribute__ ((__section__ (".data.init"))) = { };
+
--- /dev/null
+#include "testharness.h"
+
+static unsigned char a[00170000 >> 12 ] = {
+ [0100000 >> 12 ] 1 ,
+ [0040000 >> 12 ] 2 ,
+ [0020000 >> 12 ] 3 ,
+ [0060000 >> 12 ] 4 ,
+ [0010000 >> 12 ] 5 ,
+ [0140000 >> 12 ] 6 ,
+ [0120000 >> 12 ] 7 ,
+};
+
+
+int main() {
+ if(a[8] != 1) E(1);
+ if(a[4] != 2) E(2);
+ if(a[2] != 3) E(3);
+ if(a[6] != 4) E(4);
+ if(a[1] != 5) E(5);
+ if(a[12] != 6) E(6);
+ if(a[10] != 7) E(7);
+
+ if(a[3] != 0) E(8);
+ if(a[0] != 0) E(9);
+ if(a[5] != 0) E(10);
+ if(a[7] != 0) E(11);
+ if(a[9] != 0) E(12);
+ if(a[11] != 0) E(13);
+ if(a[13] != 0) E(14);
+ if(a[14] != 0) E(15);
+ if(a[15] != 0) E(16);
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+typedef struct {
+ int a, b;
+} DATA;
+
+typedef struct {
+ int tag[5];
+ int x;
+ DATA d1;
+ DATA d2;
+} TDATA;
+
+
+TDATA x = { {0,0,0},
+ 5 };
+
+TDATA x1 = { .x = 7,
+ .d1 = { .b = 5 },
+ .d2 = { 9 } };
+
+int main() {
+ TDATA x2[] = { [5] = { 8 }} ;
+ if(x2[0].x != 0) E(1);
+
+ if(x2[5].x != 0) E(2); // Make sure you zero even after the last init
+ if(x2[5].d2.b != 0) E(21);
+ if(x2[5].tag[1] != 0) E(22);
+
+ if(x2[5].tag[0] != 8) E(3);
+ if(sizeof(x2) != 6 * sizeof(TDATA)) E(4);
+
+ SUCCESS;
+}
+
+
+
--- /dev/null
+#include "testharness.h"
+
+// From c-torture
+
+// First an extern inline definition
+extern __inline__ int
+odd(void)
+{
+ return 1;
+}
+
+// Now a use of that definition
+int
+odd1(void)
+{
+ // We always use the last definition if we do not optimize
+ // And we use the last extern __inline__ definition when we
+ // do optimize
+
+ // IN CIL WE ALWAYS OPTIMIZE. SO YOU BETTER DEFINE EQUIVALENT
+ // BODIES in the extern inline and in the real definition
+ return odd();
+}
+
+
+// And now a definition without the inline
+int
+odd(void)
+{
+ return 3;
+}
+
+
+int main() {
+ { int x = odd(); if(x != 3) E(1); }
+
+ {
+ int y = odd1();
+ if(y != 1) E(2);
+ }
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+int main(void) {
+ int x = 1, y = 5, z = 0;
+ asm("movl %[in1], %[out] \n addl %[in2], %[out]"
+ : [out] "=r" (z) : [in1] "m" (x), [in2] "m" (y) );
+
+ if(z != 6) E(1);
+ return 0;
+}
+
--- /dev/null
+//MSVC considers _inline a keyword, but gcc doesn't.
+
+//From linux-2.6.17.1/fs/jfs/jfs_incore.h:
+struct {
+ char _unused[16]; /* 16: */
+ int _dxd[4]; /* 16: */
+ char _inline[128]; /* 128: inline symlink */
+ /* _inline_ea may overlay the last part of
+ * file._xtroot if maxentry = XTROOTINITSLOT
+ */
+ char _inline_ea[128]; /* 128: inline extended attr */
+} link;
--- /dev/null
+// jmp_buf.c
+// another setjmp test
+
+// sm: my setjmp_w wrapper needs this
+#include <setjmp.h> // jmp_buf
+
+// may as well add this..
+#include <stdio.h> // printf
+
+//extern void printf(char *, ...);
+
+
+jmp_buf env;
+/*
+ * Actual C code that generates this error ...
+ * Correct output:
+ * Saved state via setjmp, status = 0.
+ * Long-Jumping with status argument 55.
+ * Returned from longjmp, status = 55
+ */
+
+int main()
+{
+ int status;
+
+ if (status=setjmp(&env)) {
+ printf("Returned from longjmp, status = %d\n",status);
+ if (status != 55) {
+ printf("Wrong status value!\n"); return 1;
+ }
+ } else {
+ printf("Saved state via setjmp, status = 0.\n");
+ }
+ if (status == 0) {
+ printf("Long-Jumping with status argument 55.\n");
+ longjmp(&env,55);
+ }
+ printf("success\n");
+ return 0;
+}
+
--- /dev/null
+
+
+
+int old_function(a, b, c)
+ int a, * c;
+ int *b;
+{
+ return a + *b;
+}
+
+
+norettype(int x) {
+ return x;
+}
+
+norettype_old(x)
+ int x;
+{
+ return x;
+}
+
+norettype_old2()
+{
+ return ;
+}
+
+static norettype_old3(a)
+ int **a;
+{
+ return **a;
+}
+
+
+noretnoarg(x) {
+ return x;
+}
--- /dev/null
+#define SEARCH(array, target) \
+({ \
+ __label__ found, retry; \
+ typeof (target) _SEARCH_target = (target); \
+ typeof (*array) *_SEARCH_array = (array); \
+ int i, j;\
+ int value;\
+ int max = sizeof(array) / sizeof(*array);\
+ retry: \
+ for(i=0; i < max; i ++) \
+ if(_SEARCH_array[i] == _SEARCH_target) { \
+ value = i; goto found; \
+ } \
+ ({ __label__ found; goto found; \
+ found: _SEARCH_target += 5; goto retry;}); \
+ found : \
+ value; \
+})
+
+
+int thearray[] = { 1, 3, 5, 7, 9, 11, 13, 15, 17, 21 };
+
+int main() {
+ __label__ endofblock;
+ int res;
+
+ res = -9 + (SEARCH(thearray, 7) /* 3 */ + SEARCH(thearray, 8) /* 6 */);
+ endofblock:
+ return res;
+}
--- /dev/null
+// Example with computed labels
+#include "testharness.h"
+
+int main() {
+
+ void *nextstate = && Loop;
+ int x = 0;
+ int acc = 0;
+ int count = 5;
+
+ Loop:
+ if(x == 10) nextstate = && Done;
+ acc += x; x ++;
+ goto *nextstate;
+ Done:
+
+ if(acc != 11 * 10 / 2) {
+ printf("Bad result: %d\n", acc);
+ return 1;
+ }
+
+ if(count <= 0) return 0;
+
+ acc = 0; x = 0;
+ nextstate = && Loop;
+ count --;
+
+ goto *nextstate;
+}
--- /dev/null
+
+
+
+int main() {
+ static void* array[] = { && L1, && L2, && L3 };
+ int acc = 0;
+
+ L1: acc += 1; goto * array[1];
+ L2: acc += 2; goto * array[2];
+ L3: acc += 3;
+
+ return acc - 6;
+}
--- /dev/null
+#include "testharness.h"
+extern void abort(void);
+// From c-torture
+
+int expect_do1 = 1, expect_do2 = 2;
+
+static int doit(int x){
+ __label__ lbl1;
+ __label__ lbl2;
+ static int jtab_init = 0;
+ static void *jtab[2];
+
+ if(!jtab_init) {
+ jtab[0] = &&lbl1;
+ jtab[1] = &&lbl2;
+ jtab_init = 1;
+ }
+ goto *jtab[x];
+lbl1:
+ return 1;
+lbl2:
+ return 2;
+}
+
+static void do1(void) {
+ if (doit(0) != expect_do1)
+ abort ();
+}
+
+static void do2(void){
+ if (doit(1) != expect_do2)
+ abort ();
+}
+
+int main(void){
+#ifndef NO_LABEL_VALUES
+ do1();
+ do2();
+#endif
+ exit(0);
+}
--- /dev/null
+
+
+
+int main(void){
+ return 0;
+
+ this_label_is_not_used: __attribute__ ((unused))
+ return 1;
+}
--- /dev/null
+typedef struct foo {
+ int x;
+ int *y;
+} Foo;
+
+Foo * xlarg(Foo **pargs) {
+ void * make_me_wild = pargs;
+ return *pargs;
+}
+
+Foo * xeval(Foo *args) {
+ Foo * expr = xlarg(& args);
+}
--- /dev/null
+//There's a gcc bug on Cygwin where filenames referring to
+//non-existent files can result in large line numbers appearing in the
+//preprocessed source.
+
+# 4294967150 "cpp_heap.c"
+int main() { return 0; }
--- /dev/null
+typedef struct { int counter; } atomic_t;
+
+#define TYPE0 volatile struct { int a[100]; }
+#define TYPE1 volatile int
+
+static __inline__ void atomic_add(int i, volatile atomic_t *v)
+{
+ __asm__ __volatile__(
+ "" "addl %1,%0"
+ :"=m" ((*(TYPE0 *) v ) )
+ :"ir" (i), "m" ((*(TYPE0 *) v ) ));
+}
--- /dev/null
+#include "testharness.h"
+ /* Type of a signal handler. */
+ typedef void (*__sighandler_t)(int);
+
+ #define SIG_DFL ((__sighandler_t)0) /* default signal handling */
+ #define SIG_IGN ((__sighandler_t)1) /* ignore signal */
+ #define SIG_ERR ((__sighandler_t)-1) /* error return from signal */
+
+ struct sigaction {
+ __sighandler_t sa_handler;
+ unsigned long sa_flags;
+ void (*sa_restorer)(void);
+ long sa_mask; /* mask last for extensibility */
+ };
+
+ struct k_sigaction {
+ struct sigaction sa;
+ };
+
+
+int main() {
+ struct k_sigaction sa;
+
+// if (sa.sa.sa_handler == SIG_DFL) {
+ sa.sa.sa_handler = SIG_IGN;
+// }
+ SUCCESS;
+}
--- /dev/null
+/* Generated by CIL v. 1.0 */
+
+struct proc_dir_entry;
+struct reiserfs_page_list;
+struct dnotify_struct;
+struct ipv6hdr;
+struct hfs_name;
+struct udphdr;
+struct net_bridge_port;
+struct open_request;
+struct ipxhdr;
+struct usb_bus;
+struct hfs_cat_entry;
+struct nfs_rpc_ops;
+struct tcp_listen_opt;
+struct ip_options;
+struct igmphdr;
+struct bootmem_data;
+struct hfs_fork;
+struct iphdr;
+struct adfs_dir_ops;
+struct usb_device;
+struct spxhdr;
+struct bfs_super_block;
+struct poll_table_struct;
+struct tcp_func;
+struct unix_address;
+struct smb_mount_data_kernel;
+struct module;
+struct ext2_super_block;
+struct kmem_cache_s;
+struct scm_cookie;
+struct hfs_mdb;
+struct packet_opt;
+struct hfs_hdr_layout;
+struct arphdr;
+struct ip_mc_socklist;
+struct nfs_reqlist;
+struct ntfs_attribute;
+struct nlm_host;
+struct rpc_clnt;
+struct adfs_discmap;
+struct iw_statistics;
+struct minix_super_block;
+struct nls_table;
+struct pt_regs {
+ long ebx ;
+ long ecx ;
+ long edx ;
+ long esi ;
+ long edi ;
+ long ebp ;
+ long eax ;
+ int xds ;
+ int xes ;
+ long orig_eax ;
+ long eip ;
+ int xcs ;
+ long eflags ;
+ long esp ;
+ int xss ;
+};
+struct __anonstruct___kernel_fd_set_1 {
+ unsigned long fds_bits[(int )(1024U / (8U * sizeof(unsigned long )))] ;
+};
+typedef struct __anonstruct___kernel_fd_set_1 __kernel_fd_set;
+typedef int __kernel_key_t;
+typedef unsigned short __kernel_dev_t;
+typedef unsigned long __kernel_ino_t;
+typedef unsigned short __kernel_mode_t;
+typedef unsigned short __kernel_nlink_t;
+typedef long __kernel_off_t;
+typedef int __kernel_pid_t;
+typedef unsigned int __kernel_size_t;
+typedef int __kernel_ssize_t;
+typedef long __kernel_time_t;
+typedef long __kernel_suseconds_t;
+typedef long __kernel_clock_t;
+typedef unsigned int __kernel_uid32_t;
+typedef unsigned int __kernel_gid32_t;
+typedef long long __kernel_loff_t;
+struct __anonstruct___kernel_fsid_t_2 {
+ int val[2] ;
+};
+typedef struct __anonstruct___kernel_fsid_t_2 __kernel_fsid_t;
+typedef unsigned short umode_t;
+typedef unsigned char __u8;
+typedef short __s16;
+typedef unsigned short __u16;
+typedef int __s32;
+typedef unsigned int __u32;
+typedef long long __s64;
+typedef unsigned long long __u64;
+typedef unsigned char u8;
+typedef unsigned short u16;
+typedef unsigned int u32;
+typedef __kernel_fd_set fd_set;
+typedef __kernel_dev_t dev_t;
+typedef __kernel_ino_t ino_t;
+typedef __kernel_mode_t mode_t;
+typedef __kernel_nlink_t nlink_t;
+typedef __kernel_off_t off_t;
+typedef __kernel_pid_t pid_t;
+typedef __kernel_key_t key_t;
+typedef __kernel_suseconds_t suseconds_t;
+typedef __kernel_uid32_t uid_t;
+typedef __kernel_gid32_t gid_t;
+typedef __kernel_loff_t loff_t;
+typedef __kernel_size_t size_t;
+typedef __kernel_ssize_t ssize_t;
+typedef __kernel_time_t time_t;
+typedef __kernel_clock_t clock_t;
+typedef unsigned short u_short;
+typedef unsigned long u_long;
+typedef __u32 u_int32_t;
+typedef __s32 int32_t;
+struct list_head {
+ struct list_head *next ;
+ struct list_head *prev ;
+};
+struct __anonstruct_atomic_t_3 {
+ int volatile counter ;
+};
+typedef struct __anonstruct_atomic_t_3 atomic_t;
+struct __anonstruct_pgd_t_6 {
+ unsigned long pgd ;
+};
+typedef struct __anonstruct_pgd_t_6 pgd_t;
+struct __anonstruct_pgprot_t_7 {
+ unsigned long pgprot ;
+};
+typedef struct __anonstruct_pgprot_t_7 pgprot_t;
+struct __anonstruct_spinlock_t_8 {
+ unsigned int volatile lock ;
+};
+typedef struct __anonstruct_spinlock_t_8 spinlock_t;
+struct __anonstruct_rwlock_t_9 {
+ unsigned int volatile lock ;
+};
+typedef struct __anonstruct_rwlock_t_9 rwlock_t;
+struct vm86_regs {
+ long ebx ;
+ long ecx ;
+ long edx ;
+ long esi ;
+ long edi ;
+ long ebp ;
+ long eax ;
+ long __null_ds ;
+ long __null_es ;
+ long __null_fs ;
+ long __null_gs ;
+ long orig_eax ;
+ long eip ;
+ unsigned short cs ;
+ unsigned short __csh ;
+ long eflags ;
+ long esp ;
+ unsigned short ss ;
+ unsigned short __ssh ;
+ unsigned short es ;
+ unsigned short __esh ;
+ unsigned short ds ;
+ unsigned short __dsh ;
+ unsigned short fs ;
+ unsigned short __fsh ;
+ unsigned short gs ;
+ unsigned short __gsh ;
+};
+struct revectored_struct {
+ unsigned long __map[8] ;
+};
+struct vm86_struct {
+ struct vm86_regs regs ;
+ unsigned long flags ;
+ unsigned long screen_bitmap ;
+ unsigned long cpu_type ;
+ struct revectored_struct int_revectored ;
+ struct revectored_struct int21_revectored ;
+};
+struct info {
+ long ___orig_eip ;
+ long ___ret_from_system_call ;
+ long ___ebx ;
+ long ___ecx ;
+ long ___edx ;
+ long ___esi ;
+ long ___edi ;
+ long ___ebp ;
+ long ___eax ;
+ long ___ds ;
+ long ___es ;
+ long ___orig_eax ;
+ long ___eip ;
+ long ___cs ;
+ long ___eflags ;
+ long ___esp ;
+ long ___ss ;
+ long ___vm86_es ;
+ long ___vm86_ds ;
+ long ___vm86_fs ;
+ long ___vm86_gs ;
+};
+struct i387_fsave_struct {
+ long cwd ;
+ long swd ;
+ long twd ;
+ long fip ;
+ long fcs ;
+ long foo ;
+ long fos ;
+ long st_space[20] ;
+ long status ;
+};
+struct i387_fxsave_struct {
+ unsigned short cwd ;
+ unsigned short swd ;
+ unsigned short twd ;
+ unsigned short fop ;
+ long fip ;
+ long fcs ;
+ long foo ;
+ long fos ;
+ long mxcsr ;
+ long reserved ;
+ long st_space[32] ;
+ long xmm_space[32] ;
+ long padding[56] ;
+} __attribute__((__aligned__(16))) ;
+struct i387_soft_struct {
+ long cwd ;
+ long swd ;
+ long twd ;
+ long fip ;
+ long fcs ;
+ long foo ;
+ long fos ;
+ long st_space[20] ;
+ unsigned char ftop ;
+ unsigned char changed ;
+ unsigned char lookahead ;
+ unsigned char no_update ;
+ unsigned char rm ;
+ unsigned char alimit ;
+ struct info *info ;
+ unsigned long entry_eip ;
+};
+union i387_union {
+ struct i387_fsave_struct fsave ;
+ struct i387_fxsave_struct fxsave ;
+ struct i387_soft_struct soft ;
+};
+struct __anonstruct_mm_segment_t_10 {
+ unsigned long seg ;
+};
+typedef struct __anonstruct_mm_segment_t_10 mm_segment_t;
+struct thread_struct {
+ unsigned long esp0 ;
+ unsigned long eip ;
+ unsigned long esp ;
+ unsigned long fs ;
+ unsigned long gs ;
+ unsigned long debugreg[8] ;
+ unsigned long cr2 ;
+ unsigned long trap_no ;
+ unsigned long error_code ;
+ union i387_union i387 ;
+ struct vm86_struct *vm86_info ;
+ unsigned long screen_bitmap ;
+ unsigned long v86flags ;
+ unsigned long v86mask ;
+ unsigned long v86mode ;
+ unsigned long saved_esp0 ;
+ int ioperm ;
+ unsigned long io_bitmap[33] ;
+};
+struct __wait_queue_head {
+ spinlock_t lock ;
+ struct list_head task_list ;
+};
+typedef struct __wait_queue_head wait_queue_head_t;
+struct statfs {
+ long f_type ;
+ long f_bsize ;
+ long f_blocks ;
+ long f_bfree ;
+ long f_bavail ;
+ long f_files ;
+ long f_ffree ;
+ __kernel_fsid_t f_fsid ;
+ long f_namelen ;
+ long f_spare[6] ;
+};
+struct iovec {
+ void *iov_base ;
+ __kernel_size_t iov_len ;
+};
+typedef unsigned short sa_family_t;
+struct sockaddr {
+ sa_family_t sa_family ;
+ char sa_data[14] ;
+};
+struct msghdr {
+ void *msg_name ;
+ int msg_namelen ;
+ struct iovec *msg_iov ;
+ __kernel_size_t msg_iovlen ;
+ void *msg_control ;
+ __kernel_size_t msg_controllen ;
+ unsigned int msg_flags ;
+};
+struct ucred {
+ __u32 pid ;
+ __u32 uid ;
+ __u32 gid ;
+};
+enum __anonenum_socket_state_11 {
+ SS_FREE = 0,
+ SS_UNCONNECTED = 1,
+ SS_CONNECTING = 2,
+ SS_CONNECTED = 3,
+ SS_DISCONNECTING = 4, };
+typedef enum __anonenum_socket_state_11 socket_state;
+struct socket {
+ socket_state state ;
+ unsigned long flags ;
+ struct proto_ops *ops ;
+ struct inode *inode ;
+ struct fasync_struct *fasync_list ;
+ struct file *file ;
+ struct sock *sk ;
+ wait_queue_head_t wait ;
+ short type ;
+ unsigned char passcred ;
+};
+struct proto_ops {
+ int family ;
+ int (*release)(struct socket *sock ) ;
+ int (*bind)(struct socket *sock , struct sockaddr *umyaddr ,
+ int sockaddr_len ) ;
+ int (*connect)(struct socket *sock , struct sockaddr *uservaddr ,
+ int sockaddr_len , int flags ) ;
+ int (*socketpair)(struct socket *sock1 , struct socket *sock2 ) ;
+ int (*accept)(struct socket *sock , struct socket *newsock , int flags ) ;
+ int (*getname)(struct socket *sock , struct sockaddr *uaddr ,
+ int *usockaddr_len , int peer ) ;
+ unsigned int (*poll)(struct file *file , struct socket *sock ,
+ struct poll_table_struct *wait ) ;
+ int (*ioctl)(struct socket *sock , unsigned int cmd , unsigned long arg ) ;
+ int (*listen)(struct socket *sock , int len ) ;
+ int (*shutdown)(struct socket *sock , int flags ) ;
+ int (*setsockopt)(struct socket *sock , int level , int optname ,
+ char *optval , int optlen ) ;
+ int (*getsockopt)(struct socket *sock , int level , int optname ,
+ char *optval , int *optlen ) ;
+ int (*sendmsg)(struct socket *sock , struct msghdr *m , int total_len ,
+ struct scm_cookie *scm ) ;
+ int (*recvmsg)(struct socket *sock , struct msghdr *m , int total_len ,
+ int flags , struct scm_cookie *scm ) ;
+ int (*mmap)(struct file *file , struct socket *sock ,
+ struct vm_area_struct *vma ) ;
+ ssize_t (*sendpage)(struct socket *sock , struct page *page , int offset ,
+ size_t size , int flags ) ;
+};
+typedef unsigned short kdev_t;
+struct vfsmount {
+ struct dentry *mnt_mountpoint ;
+ struct dentry *mnt_root ;
+ struct vfsmount *mnt_parent ;
+ struct list_head mnt_instances ;
+ struct list_head mnt_clash ;
+ struct super_block *mnt_sb ;
+ struct list_head mnt_mounts ;
+ struct list_head mnt_child ;
+ atomic_t mnt_count ;
+ int mnt_flags ;
+ char *mnt_devname ;
+ struct list_head mnt_list ;
+ uid_t mnt_owner ;
+};
+struct qstr {
+ unsigned char const *name ;
+ unsigned int len ;
+ unsigned int hash ;
+};
+struct dentry {
+ atomic_t d_count ;
+ unsigned int d_flags ;
+ struct inode *d_inode ;
+ struct dentry *d_parent ;
+ struct list_head d_vfsmnt ;
+ struct list_head d_hash ;
+ struct list_head d_lru ;
+ struct list_head d_child ;
+ struct list_head d_subdirs ;
+ struct list_head d_alias ;
+ struct qstr d_name ;
+ unsigned long d_time ;
+ struct dentry_operations *d_op ;
+ struct super_block *d_sb ;
+ unsigned long d_vfs_flags ;
+ void *d_fsdata ;
+ unsigned char d_iname[16] ;
+};
+struct dentry_operations {
+ int (*d_revalidate)(struct dentry * , int ) ;
+ int (*d_hash)(struct dentry * , struct qstr * ) ;
+ int (*d_compare)(struct dentry * , struct qstr * , struct qstr * ) ;
+ int (*d_delete)(struct dentry * ) ;
+ void (*d_release)(struct dentry * ) ;
+ void (*d_iput)(struct dentry * , struct inode * ) ;
+};
+struct rw_semaphore {
+ long count ;
+ spinlock_t wait_lock ;
+ struct list_head wait_list ;
+};
+struct semaphore {
+ atomic_t count ;
+ int sleepers ;
+ wait_queue_head_t wait ;
+};
+struct buffer_head {
+ struct buffer_head *b_next ;
+ unsigned long b_blocknr ;
+ unsigned short b_size ;
+ unsigned short b_list ;
+ kdev_t b_dev ;
+ atomic_t b_count ;
+ kdev_t b_rdev ;
+ unsigned long b_state ;
+ unsigned long b_flushtime ;
+ struct buffer_head *b_next_free ;
+ struct buffer_head *b_prev_free ;
+ struct buffer_head *b_this_page ;
+ struct buffer_head *b_reqnext ;
+ struct buffer_head **b_pprev ;
+ char *b_data ;
+ struct page *b_page ;
+ void (*b_end_io)(struct buffer_head *bh , int uptodate ) ;
+ void *b_private ;
+ unsigned long b_rsector ;
+ wait_queue_head_t b_wait ;
+ struct inode *b_inode ;
+ struct list_head b_inode_buffers ;
+};
+struct pipe_inode_info {
+ wait_queue_head_t wait ;
+ char *base ;
+ unsigned int len ;
+ unsigned int start ;
+ unsigned int readers ;
+ unsigned int writers ;
+ unsigned int waiting_readers ;
+ unsigned int waiting_writers ;
+ unsigned int r_counter ;
+ unsigned int w_counter ;
+};
+union __anonunion_u_12 {
+ __u16 i1_data[16] ;
+ __u32 i2_data[16] ;
+};
+struct minix_inode_info {
+ union __anonunion_u_12 u ;
+};
+struct ext2_inode_info {
+ __u32 i_data[15] ;
+ __u32 i_flags ;
+ __u32 i_faddr ;
+ __u8 i_frag_no ;
+ __u8 i_frag_size ;
+ __u16 i_osync ;
+ __u32 i_file_acl ;
+ __u32 i_dir_acl ;
+ __u32 i_dtime ;
+ __u32 not_used_1 ;
+ __u32 i_block_group ;
+ __u32 i_next_alloc_block ;
+ __u32 i_next_alloc_goal ;
+ __u32 i_prealloc_block ;
+ __u32 i_prealloc_count ;
+ __u32 i_high_size ;
+ int i_new_inode : 1 ;
+};
+struct hpfs_inode_info {
+ unsigned long mmu_private ;
+ ino_t i_parent_dir ;
+ unsigned int i_dno ;
+ unsigned int i_dpos ;
+ unsigned int i_dsubdno ;
+ unsigned int i_file_sec ;
+ unsigned int i_disk_sec ;
+ unsigned int i_n_secs ;
+ unsigned int i_ea_size ;
+ unsigned int i_conv : 2 ;
+ unsigned int i_ea_mode : 1 ;
+ unsigned int i_ea_uid : 1 ;
+ unsigned int i_ea_gid : 1 ;
+ unsigned int i_dirty : 1 ;
+ struct semaphore i_sem ;
+ loff_t **i_rddir_off ;
+};
+typedef u32 ntfs_u32;
+typedef __kernel_mode_t ntmode_t;
+typedef uid_t ntfs_uid_t;
+typedef gid_t ntfs_gid_t;
+typedef __kernel_size_t ntfs_size_t;
+struct __anonstruct_index_14 {
+ int recordsize ;
+ int clusters_per_record ;
+};
+union __anonunion_u_13 {
+ struct __anonstruct_index_14 index ;
+};
+struct ntfs_inode_info {
+ unsigned long mmu_private ;
+ struct ntfs_sb_info *vol ;
+ int i_number ;
+ __u16 sequence_number ;
+ unsigned char *attr ;
+ int attr_count ;
+ struct ntfs_attribute *attrs ;
+ int record_count ;
+ int *records ;
+ union __anonunion_u_13 u ;
+};
+struct msdos_inode_info {
+ unsigned long mmu_private ;
+ int i_start ;
+ int i_logstart ;
+ int i_attrs ;
+ int i_ctime_ms ;
+ int i_location ;
+ struct inode *i_fat_inode ;
+ struct list_head i_fat_hash ;
+};
+struct dir_locking_info {
+ wait_queue_head_t p ;
+ short looking ;
+ short creating ;
+ long pid ;
+};
+struct umsdos_inode_info {
+ struct msdos_inode_info msdos_info ;
+ struct dir_locking_info dir_info ;
+ int i_patched ;
+ int i_is_hlink ;
+ off_t pos ;
+};
+struct iso_inode_info {
+ unsigned int i_first_extent ;
+ unsigned char i_file_format ;
+ unsigned long i_next_section_ino ;
+ off_t i_section_size ;
+};
+struct nfs_fh {
+ unsigned short size ;
+ unsigned char data[64] ;
+};
+struct nfs_inode_info {
+ __u64 fsid ;
+ __u64 fileid ;
+ struct nfs_fh fh ;
+ unsigned short flags ;
+ unsigned long read_cache_jiffies ;
+ __u64 read_cache_ctime ;
+ __u64 read_cache_mtime ;
+ __u64 read_cache_atime ;
+ __u64 read_cache_isize ;
+ unsigned long attrtimeo ;
+ unsigned long attrtimeo_timestamp ;
+ __u32 cookieverf[2] ;
+ struct list_head read ;
+ struct list_head dirty ;
+ struct list_head commit ;
+ struct list_head writeback ;
+ unsigned int nread ;
+ unsigned int ndirty ;
+ unsigned int ncommit ;
+ unsigned int npages ;
+ struct inode *hash_next ;
+ struct inode *hash_prev ;
+ unsigned long nextscan ;
+};
+struct nfs_lock_info {
+ u32 state ;
+ u32 flags ;
+ struct nlm_host *host ;
+};
+struct sysv_inode_info {
+ u32 i_data[13] ;
+};
+struct timeval {
+ time_t tv_sec ;
+ suseconds_t tv_usec ;
+};
+struct affs_ext_key {
+ u32 ext ;
+ u32 key ;
+};
+struct affs_inode_info {
+ u32 i_opencnt ;
+ struct semaphore i_link_lock ;
+ struct semaphore i_ext_lock ;
+ u32 i_blkcnt ;
+ u32 i_extcnt ;
+ u32 *i_lc ;
+ u32 i_lc_size ;
+ u32 i_lc_shift ;
+ u32 i_lc_mask ;
+ struct affs_ext_key *i_ac ;
+ u32 i_ext_last ;
+ struct buffer_head *i_ext_bh ;
+ unsigned long mmu_private ;
+ u32 i_protect ;
+ u32 i_lastalloc ;
+ int i_pa_cnt ;
+};
+union __anonunion_i_u1_16 {
+ __u32 i_data[15] ;
+ __u8 i_symlink[60] ;
+};
+struct ufs_inode_info {
+ union __anonunion_i_u1_16 i_u1 ;
+ __u64 i_size ;
+ __u32 i_flags ;
+ __u32 i_gen ;
+ __u32 i_shadow ;
+ __u32 i_unused1 ;
+ __u32 i_unused2 ;
+ __u32 i_oeftflag ;
+ __u16 i_osync ;
+ __u32 i_lastfrag ;
+};
+struct extent_s {
+ unsigned int ex_magic : 8 ;
+ unsigned int ex_bn : 24 ;
+ unsigned int ex_length : 8 ;
+ unsigned int ex_offset : 24 ;
+};
+union extent_u {
+ unsigned char raw[8] ;
+ struct extent_s cooked ;
+};
+typedef union extent_u efs_extent;
+struct efs_inode_info {
+ int numextents ;
+ int lastextent ;
+ efs_extent extents[12] ;
+};
+typedef u_long VolumeId;
+typedef u_long VnodeId;
+typedef u_long Unique_t;
+struct ViceFid {
+ VolumeId Volume ;
+ VnodeId Vnode ;
+ Unique_t Unique ;
+};
+typedef u_int32_t vuid_t;
+typedef u_int32_t vgid_t;
+struct coda_cred {
+ vuid_t cr_uid ;
+ vuid_t cr_euid ;
+ vuid_t cr_suid ;
+ vuid_t cr_fsuid ;
+ vgid_t cr_groupid ;
+ vgid_t cr_egid ;
+ vgid_t cr_sgid ;
+ vgid_t cr_fsgid ;
+};
+struct coda_inode_info {
+ struct ViceFid c_fid ;
+ u_short c_flags ;
+ struct list_head c_cilist ;
+ struct file *c_container ;
+ unsigned int c_contcount ;
+ struct coda_cred c_cached_cred ;
+ unsigned int c_cached_perm ;
+};
+struct romfs_inode_info {
+ unsigned long i_metasize ;
+ unsigned long i_dataoffset ;
+};
+struct __anonstruct_swp_entry_t_17 {
+ unsigned long val ;
+};
+typedef struct __anonstruct_swp_entry_t_17 swp_entry_t;
+struct shmem_inode_info {
+ spinlock_t lock ;
+ unsigned long max_index ;
+ swp_entry_t i_direct[16] ;
+ swp_entry_t **i_indirect ;
+ unsigned long swapped ;
+ int locked ;
+ struct list_head list ;
+};
+struct shmem_sb_info {
+ unsigned long max_blocks ;
+ unsigned long free_blocks ;
+ unsigned long max_inodes ;
+ unsigned long free_inodes ;
+ spinlock_t stat_lock ;
+};
+struct smb_inode_info {
+ unsigned int open ;
+ __u16 fileid ;
+ __u16 attr ;
+ __u16 access ;
+ unsigned long oldmtime ;
+ unsigned long closed ;
+ unsigned int openers ;
+};
+struct hfs_inode_info {
+ int magic ;
+ unsigned long mmu_private ;
+ struct hfs_cat_entry *entry ;
+ struct hfs_fork *fork ;
+ int convert ;
+ ino_t file_type ;
+ char dir_size ;
+ struct hfs_hdr_layout const *default_layout ;
+ struct hfs_hdr_layout *layout ;
+ int tz_secondswest ;
+ void (*d_drop_op)(struct dentry * , ino_t ) ;
+};
+struct adfs_inode_info {
+ unsigned long mmu_private ;
+ unsigned long parent_id ;
+ __u32 loadaddr ;
+ __u32 execaddr ;
+ unsigned int filetype ;
+ unsigned int attr ;
+ int stamped : 1 ;
+};
+typedef __u16 qnx4_nxtnt_t;
+typedef __u8 qnx4_ftype_t;
+struct __anonstruct_qnx4_xtnt_t_18 {
+ __u32 xtnt_blk ;
+ __u32 xtnt_size ;
+};
+typedef struct __anonstruct_qnx4_xtnt_t_18 qnx4_xtnt_t;
+typedef __u16 qnx4_mode_t;
+typedef __u16 qnx4_muid_t;
+typedef __u16 qnx4_mgid_t;
+typedef __u32 qnx4_off_t;
+typedef __u16 qnx4_nlink_t;
+struct qnx4_inode_info {
+ char i_reserved[16] ;
+ qnx4_off_t i_size ;
+ qnx4_xtnt_t i_first_xtnt ;
+ __u32 i_xblk ;
+ __s32 i_ftime ;
+ __s32 i_mtime ;
+ __s32 i_atime ;
+ __s32 i_ctime ;
+ qnx4_nxtnt_t i_num_xtnts ;
+ qnx4_mode_t i_mode ;
+ qnx4_muid_t i_uid ;
+ qnx4_mgid_t i_gid ;
+ qnx4_nlink_t i_nlink ;
+ __u8 i_zero[4] ;
+ qnx4_ftype_t i_type ;
+ __u8 i_status ;
+ unsigned long mmu_private ;
+};
+struct reiserfs_inode_info {
+ __u32 i_key[4] ;
+ int i_version ;
+ int i_pack_on_close ;
+ __u32 i_first_direct_byte ;
+ struct reiserfs_page_list *i_converted_page ;
+ int i_conversion_trans_id ;
+ int i_prealloc_block ;
+ int i_prealloc_count ;
+ struct list_head i_prealloc_list ;
+ int nopack ;
+};
+struct bfs_inode_info {
+ unsigned long i_dsk_ino ;
+ unsigned long i_sblock ;
+ unsigned long i_eblock ;
+};
+struct __anonstruct_lb_addr_19 {
+ __u32 logicalBlockNum ;
+ __u16 partitionReferenceNum ;
+};
+typedef struct __anonstruct_lb_addr_19 lb_addr;
+struct udf_inode_info {
+ long i_uatime ;
+ long i_umtime ;
+ long i_uctime ;
+ lb_addr i_location ;
+ __u64 i_unique ;
+ __u32 i_lenEAttr ;
+ __u32 i_lenAlloc ;
+ __u32 i_next_alloc_block ;
+ __u32 i_next_alloc_goal ;
+ unsigned int i_alloc_type : 3 ;
+ unsigned int i_extended_fe : 1 ;
+ unsigned int i_strat_4096 : 1 ;
+ unsigned int i_new_inode : 1 ;
+ unsigned int reserved : 26 ;
+};
+struct ncp_inode_info {
+ __u32 dirEntNum __attribute__((__packed__)) ;
+ __u32 DosDirNum __attribute__((__packed__)) ;
+ __u32 volNumber __attribute__((__packed__)) ;
+ __u32 nwattr ;
+ struct semaphore open_sem ;
+ atomic_t opened ;
+ int access ;
+ __u32 server_file_handle __attribute__((__packed__)) ;
+ __u8 open_create_action __attribute__((__packed__)) ;
+ __u8 file_handle[6] __attribute__((__packed__)) ;
+};
+union __anonunion_op_20 {
+ int (*proc_get_link)(struct inode * , struct dentry ** ,
+ struct vfsmount ** ) ;
+ int (*proc_read)(struct task_struct *task , char *page ) ;
+};
+struct proc_inode_info {
+ struct task_struct *task ;
+ int type ;
+ union __anonunion_op_20 op ;
+ struct file *file ;
+};
+union __anonunion_p_21 {
+ struct usb_device *dev ;
+ struct usb_bus *bus ;
+};
+struct usbdev_inode_info {
+ struct list_head dlist ;
+ struct list_head slist ;
+ union __anonunion_p_21 p ;
+};
+struct iattr {
+ unsigned int ia_valid ;
+ umode_t ia_mode ;
+ uid_t ia_uid ;
+ gid_t ia_gid ;
+ loff_t ia_size ;
+ time_t ia_atime ;
+ time_t ia_mtime ;
+ time_t ia_ctime ;
+ unsigned int ia_attr_flags ;
+};
+struct dqblk {
+ __u32 dqb_bhardlimit ;
+ __u32 dqb_bsoftlimit ;
+ __u32 dqb_curblocks ;
+ __u32 dqb_ihardlimit ;
+ __u32 dqb_isoftlimit ;
+ __u32 dqb_curinodes ;
+ time_t dqb_btime ;
+ time_t dqb_itime ;
+};
+struct dquot {
+ struct dquot *dq_next ;
+ struct dquot **dq_pprev ;
+ struct list_head dq_free ;
+ struct dquot *dq_hash_next ;
+ struct dquot **dq_hash_pprev ;
+ wait_queue_head_t dq_wait ;
+ int dq_count ;
+ struct super_block *dq_sb ;
+ unsigned int dq_id ;
+ kdev_t dq_dev ;
+ short dq_type ;
+ short dq_flags ;
+ unsigned long dq_referenced ;
+ struct dqblk dq_dqb ;
+};
+struct address_space_operations {
+ int (*writepage)(struct page * ) ;
+ int (*readpage)(struct file * , struct page * ) ;
+ int (*sync_page)(struct page * ) ;
+ int (*prepare_write)(struct file * , struct page * , unsigned int ,
+ unsigned int ) ;
+ int (*commit_write)(struct file * , struct page * , unsigned int ,
+ unsigned int ) ;
+ int (*bmap)(struct address_space * , long ) ;
+};
+struct address_space {
+ struct list_head clean_pages ;
+ struct list_head dirty_pages ;
+ struct list_head locked_pages ;
+ unsigned long nrpages ;
+ struct address_space_operations *a_ops ;
+ struct inode *host ;
+ struct vm_area_struct *i_mmap ;
+ struct vm_area_struct *i_mmap_shared ;
+ spinlock_t i_shared_lock ;
+ int gfp_mask ;
+};
+struct char_device {
+ struct list_head hash ;
+ atomic_t count ;
+ dev_t dev ;
+ atomic_t openers ;
+ struct semaphore sem ;
+};
+struct block_device {
+ struct list_head bd_hash ;
+ atomic_t bd_count ;
+ dev_t bd_dev ;
+ atomic_t bd_openers ;
+ struct block_device_operations const *bd_op ;
+ struct semaphore bd_sem ;
+};
+union __anonunion_u_22 {
+ struct minix_inode_info minix_i ;
+ struct ext2_inode_info ext2_i ;
+ struct hpfs_inode_info hpfs_i ;
+ struct ntfs_inode_info ntfs_i ;
+ struct msdos_inode_info msdos_i ;
+ struct umsdos_inode_info umsdos_i ;
+ struct iso_inode_info isofs_i ;
+ struct nfs_inode_info nfs_i ;
+ struct sysv_inode_info sysv_i ;
+ struct affs_inode_info affs_i ;
+ struct ufs_inode_info ufs_i ;
+ struct efs_inode_info efs_i ;
+ struct romfs_inode_info romfs_i ;
+ struct shmem_inode_info shmem_i ;
+ struct coda_inode_info coda_i ;
+ struct smb_inode_info smbfs_i ;
+ struct hfs_inode_info hfs_i ;
+ struct adfs_inode_info adfs_i ;
+ struct qnx4_inode_info qnx4_i ;
+ struct reiserfs_inode_info reiserfs_i ;
+ struct bfs_inode_info bfs_i ;
+ struct udf_inode_info udf_i ;
+ struct ncp_inode_info ncpfs_i ;
+ struct proc_inode_info proc_i ;
+ struct socket socket_i ;
+ struct usbdev_inode_info usbdev_i ;
+ void *generic_ip ;
+};
+struct inode {
+ struct list_head i_hash ;
+ struct list_head i_list ;
+ struct list_head i_dentry ;
+ struct list_head i_dirty_buffers ;
+ unsigned long i_ino ;
+ atomic_t i_count ;
+ kdev_t i_dev ;
+ umode_t i_mode ;
+ nlink_t i_nlink ;
+ uid_t i_uid ;
+ gid_t i_gid ;
+ kdev_t i_rdev ;
+ loff_t i_size ;
+ time_t i_atime ;
+ time_t i_mtime ;
+ time_t i_ctime ;
+ unsigned long i_blksize ;
+ unsigned long i_blocks ;
+ unsigned long i_version ;
+ struct semaphore i_sem ;
+ struct semaphore i_zombie ;
+ struct inode_operations *i_op ;
+ struct file_operations *i_fop ;
+ struct super_block *i_sb ;
+ wait_queue_head_t i_wait ;
+ struct file_lock *i_flock ;
+ struct address_space *i_mapping ;
+ struct address_space i_data ;
+ struct dquot *i_dquot[2] ;
+ struct pipe_inode_info *i_pipe ;
+ struct block_device *i_bdev ;
+ struct char_device *i_cdev ;
+ unsigned long i_dnotify_mask ;
+ struct dnotify_struct *i_dnotify ;
+ unsigned long i_state ;
+ unsigned int i_flags ;
+ unsigned char i_sock ;
+ atomic_t i_writecount ;
+ unsigned int i_attr_flags ;
+ __u32 i_generation ;
+ union __anonunion_u_22 u ;
+};
+struct fown_struct {
+ int pid ;
+ uid_t uid ;
+ uid_t euid ;
+ int signum ;
+};
+struct file {
+ struct list_head f_list ;
+ struct dentry *f_dentry ;
+ struct vfsmount *f_vfsmnt ;
+ struct file_operations *f_op ;
+ atomic_t f_count ;
+ unsigned int f_flags ;
+ mode_t f_mode ;
+ loff_t f_pos ;
+ unsigned long f_reada ;
+ unsigned long f_ramax ;
+ unsigned long f_raend ;
+ unsigned long f_ralen ;
+ unsigned long f_rawin ;
+ struct fown_struct f_owner ;
+ unsigned int f_uid ;
+ unsigned int f_gid ;
+ int f_error ;
+ unsigned long f_version ;
+ void *private_data ;
+};
+typedef struct files_struct *fl_owner_t;
+union __anonunion_fl_u_23 {
+ struct nfs_lock_info nfs_fl ;
+};
+struct file_lock {
+ struct file_lock *fl_next ;
+ struct list_head fl_link ;
+ struct list_head fl_block ;
+ fl_owner_t fl_owner ;
+ unsigned int fl_pid ;
+ wait_queue_head_t fl_wait ;
+ struct file *fl_file ;
+ unsigned char fl_flags ;
+ unsigned char fl_type ;
+ loff_t fl_start ;
+ loff_t fl_end ;
+ void (*fl_notify)(struct file_lock * ) ;
+ void (*fl_insert)(struct file_lock * ) ;
+ void (*fl_remove)(struct file_lock * ) ;
+ struct fasync_struct *fl_fasync ;
+ union __anonunion_fl_u_23 fl_u ;
+};
+struct fasync_struct {
+ int magic ;
+ int fa_fd ;
+ struct fasync_struct *fa_next ;
+ struct file *fa_file ;
+};
+struct nameidata {
+ struct dentry *dentry ;
+ struct vfsmount *mnt ;
+ struct qstr last ;
+ unsigned int flags ;
+ int last_type ;
+};
+struct quota_mount_options {
+ unsigned int flags ;
+ struct semaphore dqio_sem ;
+ struct semaphore dqoff_sem ;
+ struct file *files[2] ;
+ time_t inode_expire[2] ;
+ time_t block_expire[2] ;
+ char rsquash[2] ;
+};
+struct minix_sb_info {
+ unsigned long s_ninodes ;
+ unsigned long s_nzones ;
+ unsigned long s_imap_blocks ;
+ unsigned long s_zmap_blocks ;
+ unsigned long s_firstdatazone ;
+ unsigned long s_log_zone_size ;
+ unsigned long s_max_size ;
+ int s_dirsize ;
+ int s_namelen ;
+ int s_link_max ;
+ struct buffer_head **s_imap ;
+ struct buffer_head **s_zmap ;
+ struct buffer_head *s_sbh ;
+ struct minix_super_block *s_ms ;
+ unsigned short s_mount_state ;
+ unsigned short s_version ;
+};
+struct ext2_sb_info {
+ unsigned long s_frag_size ;
+ unsigned long s_frags_per_block ;
+ unsigned long s_inodes_per_block ;
+ unsigned long s_frags_per_group ;
+ unsigned long s_blocks_per_group ;
+ unsigned long s_inodes_per_group ;
+ unsigned long s_itb_per_group ;
+ unsigned long s_gdb_count ;
+ unsigned long s_desc_per_block ;
+ unsigned long s_groups_count ;
+ struct buffer_head *s_sbh ;
+ struct ext2_super_block *s_es ;
+ struct buffer_head **s_group_desc ;
+ unsigned short s_loaded_inode_bitmaps ;
+ unsigned short s_loaded_block_bitmaps ;
+ unsigned long s_inode_bitmap_number[8] ;
+ struct buffer_head *s_inode_bitmap[8] ;
+ unsigned long s_block_bitmap_number[8] ;
+ struct buffer_head *s_block_bitmap[8] ;
+ unsigned long s_mount_opt ;
+ uid_t s_resuid ;
+ gid_t s_resgid ;
+ unsigned short s_mount_state ;
+ unsigned short s_pad ;
+ int s_addr_per_block_bits ;
+ int s_desc_per_block_bits ;
+ int s_inode_size ;
+ int s_first_ino ;
+};
+struct hpfs_sb_info {
+ ino_t sb_root ;
+ unsigned int sb_fs_size ;
+ unsigned int sb_bitmaps ;
+ unsigned int sb_dirband_start ;
+ unsigned int sb_dirband_size ;
+ unsigned int sb_dmap ;
+ unsigned int sb_n_free ;
+ unsigned int sb_n_free_dnodes ;
+ uid_t sb_uid ;
+ gid_t sb_gid ;
+ umode_t sb_mode ;
+ unsigned int sb_conv : 2 ;
+ unsigned int sb_eas : 2 ;
+ unsigned int sb_err : 2 ;
+ unsigned int sb_chk : 2 ;
+ unsigned int sb_lowercase : 1 ;
+ unsigned int sb_was_error : 1 ;
+ unsigned int sb_chkdsk : 2 ;
+ unsigned int sb_rd_fnode : 2 ;
+ unsigned int sb_rd_inode : 2 ;
+ wait_queue_head_t sb_iget_q ;
+ unsigned char *sb_cp_table ;
+ unsigned int *sb_bmp_dir ;
+ unsigned int sb_c_bitmap ;
+ wait_queue_head_t sb_creation_de ;
+ unsigned int sb_creation_de_lock : 1 ;
+ int sb_timeshift ;
+};
+struct ntfs_sb_info {
+ ntfs_uid_t uid ;
+ ntfs_gid_t gid ;
+ ntmode_t umask ;
+ unsigned int nct ;
+ void *nls_map ;
+ unsigned int ngt ;
+ ntfs_size_t partition_bias ;
+ ntfs_u32 at_standard_information ;
+ ntfs_u32 at_attribute_list ;
+ ntfs_u32 at_file_name ;
+ ntfs_u32 at_volume_version ;
+ ntfs_u32 at_security_descriptor ;
+ ntfs_u32 at_volume_name ;
+ ntfs_u32 at_volume_information ;
+ ntfs_u32 at_data ;
+ ntfs_u32 at_index_root ;
+ ntfs_u32 at_index_allocation ;
+ ntfs_u32 at_bitmap ;
+ ntfs_u32 at_symlink ;
+ int blocksize ;
+ int clusterfactorbits ;
+ int clustersize ;
+ int mft_recordsize ;
+ int mft_clusters_per_record ;
+ int index_recordsize ;
+ int index_clusters_per_record ;
+ int mft_cluster ;
+ unsigned char *mft ;
+ unsigned short *upcase ;
+ unsigned int upcase_length ;
+ struct ntfs_inode_info *mft_ino ;
+ struct ntfs_inode_info *mftmirr ;
+ struct ntfs_inode_info *bitmap ;
+ struct super_block *sb ;
+};
+struct cvf_format {
+ int cvf_version ;
+ char *cvf_version_text ;
+ unsigned long flags ;
+ int (*detect_cvf)(struct super_block *sb ) ;
+ int (*mount_cvf)(struct super_block *sb , char *options ) ;
+ int (*unmount_cvf)(struct super_block *sb ) ;
+ struct buffer_head *(*cvf_bread)(struct super_block *sb , int block ) ;
+ struct buffer_head *(*cvf_getblk)(struct super_block *sb , int block ) ;
+ void (*cvf_brelse)(struct super_block *sb , struct buffer_head *bh ) ;
+ void (*cvf_mark_buffer_dirty)(struct super_block *sb ,
+ struct buffer_head *bh ) ;
+ void (*cvf_set_uptodate)(struct super_block *sb , struct buffer_head *bh ,
+ int val ) ;
+ int (*cvf_is_uptodate)(struct super_block *sb , struct buffer_head *bh ) ;
+ void (*cvf_ll_rw_block)(struct super_block *sb , int opr , int nbreq ,
+ struct buffer_head **bh ) ;
+ int (*fat_access)(struct super_block *sb , int nr , int new_value ) ;
+ int (*cvf_statfs)(struct super_block *sb , struct statfs *buf , int bufsiz ) ;
+ int (*cvf_bmap)(struct inode *inode , int block ) ;
+ ssize_t (*cvf_file_read)(struct file * , char * , size_t , loff_t * ) ;
+ ssize_t (*cvf_file_write)(struct file * , char const * , size_t ,
+ loff_t * ) ;
+ int (*cvf_mmap)(struct file * , struct vm_area_struct * ) ;
+ int (*cvf_readpage)(struct inode * , struct page * ) ;
+ int (*cvf_writepage)(struct inode * , struct page * ) ;
+ int (*cvf_dir_ioctl)(struct inode *inode , struct file *filp ,
+ unsigned int cmd , unsigned long arg ) ;
+ void (*zero_out_cluster)(struct inode * , int clusternr ) ;
+};
+struct fat_mount_options {
+ uid_t fs_uid ;
+ gid_t fs_gid ;
+ unsigned short fs_umask ;
+ unsigned short codepage ;
+ char *iocharset ;
+ unsigned char name_check ;
+ unsigned char conversion ;
+ unsigned int quiet : 1 ;
+ unsigned int showexec : 1 ;
+ unsigned int sys_immutable : 1 ;
+ unsigned int dotsOK : 1 ;
+ unsigned int isvfat : 1 ;
+ unsigned int utf8 : 1 ;
+ unsigned int unicode_xlate : 1 ;
+ unsigned int posixfs : 1 ;
+ unsigned int numtail : 1 ;
+ unsigned int atari : 1 ;
+ unsigned int fat32 : 1 ;
+ unsigned int nocase : 1 ;
+};
+struct msdos_sb_info {
+ unsigned short cluster_size ;
+ unsigned short cluster_bits ;
+ unsigned char fats ;
+ unsigned char fat_bits ;
+ unsigned short fat_start ;
+ unsigned long fat_length ;
+ unsigned long dir_start ;
+ unsigned short dir_entries ;
+ unsigned long data_start ;
+ unsigned long clusters ;
+ unsigned long root_cluster ;
+ unsigned long fsinfo_sector ;
+ wait_queue_head_t fat_wait ;
+ struct semaphore fat_lock ;
+ int prev_free ;
+ int free_clusters ;
+ struct fat_mount_options options ;
+ struct nls_table *nls_disk ;
+ struct nls_table *nls_io ;
+ struct cvf_format *cvf_format ;
+ void *dir_ops ;
+ void *private_data ;
+ int dir_per_block ;
+ int dir_per_block_bits ;
+};
+struct isofs_sb_info {
+ unsigned long s_ninodes ;
+ unsigned long s_nzones ;
+ unsigned long s_firstdatazone ;
+ unsigned long s_log_zone_size ;
+ unsigned long s_max_size ;
+ unsigned char s_high_sierra ;
+ unsigned char s_mapping ;
+ unsigned char s_rock ;
+ unsigned char s_joliet_level ;
+ unsigned char s_utf8 ;
+ unsigned char s_cruft ;
+ unsigned char s_unhide ;
+ unsigned char s_nosuid ;
+ unsigned char s_nodev ;
+ mode_t s_mode ;
+ gid_t s_gid ;
+ uid_t s_uid ;
+ struct nls_table *s_nls_iocharset ;
+};
+struct nfs_server {
+ struct rpc_clnt *client ;
+ struct nfs_rpc_ops *rpc_ops ;
+ int flags ;
+ unsigned int rsize ;
+ unsigned int rpages ;
+ unsigned int wsize ;
+ unsigned int wpages ;
+ unsigned int dtsize ;
+ unsigned int bsize ;
+ unsigned int acregmin ;
+ unsigned int acregmax ;
+ unsigned int acdirmin ;
+ unsigned int acdirmax ;
+ unsigned int namelen ;
+ char *hostname ;
+ struct nfs_reqlist *rw_requests ;
+};
+struct nfs_sb_info {
+ struct nfs_server s_server ;
+};
+struct sysv_sb_info {
+ int s_type ;
+ unsigned int s_block_size ;
+ unsigned int s_block_size_1 ;
+ unsigned int s_block_size_bits ;
+ unsigned int s_block_size_inc_bits ;
+ unsigned int s_block_size_dec_bits ;
+ char s_convert ;
+ char s_kludge_symlinks ;
+ char s_truncate ;
+ nlink_t s_link_max ;
+ unsigned int s_inodes_per_block ;
+ unsigned int s_inodes_per_block_1 ;
+ unsigned int s_inodes_per_block_bits ;
+ unsigned int s_ind_per_block ;
+ unsigned int s_ind_per_block_1 ;
+ unsigned int s_ind_per_block_bits ;
+ unsigned int s_ind_per_block_2 ;
+ unsigned int s_ind_per_block_2_1 ;
+ unsigned int s_ind_per_block_2_bits ;
+ unsigned int s_ind_per_block_3 ;
+ unsigned int s_ind_per_block_block_size_1 ;
+ unsigned int s_ind_per_block_block_size_bits ;
+ unsigned int s_ind_per_block_2_block_size_1 ;
+ unsigned int s_ind_per_block_2_block_size_bits ;
+ unsigned int s_ind0_size ;
+ unsigned int s_ind1_size ;
+ unsigned int s_ind2_size ;
+ unsigned int s_toobig_block ;
+ unsigned int s_block_base ;
+ unsigned short s_fic_size ;
+ unsigned short s_flc_size ;
+ struct buffer_head *s_bh1 ;
+ struct buffer_head *s_bh2 ;
+ char *s_sbd1 ;
+ char *s_sbd2 ;
+ u16 *s_sb_fic_count ;
+ u16 *s_sb_fic_inodes ;
+ u16 *s_sb_total_free_inodes ;
+ u16 *s_sb_flc_count ;
+ u32 *s_sb_flc_blocks ;
+ u32 *s_sb_total_free_blocks ;
+ u32 *s_sb_time ;
+ u32 *s_sb_state ;
+ u32 s_firstinodezone ;
+ u32 s_firstdatazone ;
+ u32 s_ninodes ;
+ u32 s_ndatazones ;
+ u32 s_nzones ;
+};
+struct affs_bm_info {
+ u32 bm_key ;
+ u32 bm_free ;
+};
+struct affs_sb_info {
+ int s_partition_size ;
+ int s_reserved ;
+ u32 s_data_blksize ;
+ u32 s_root_block ;
+ int s_hashsize ;
+ unsigned long s_flags ;
+ uid_t s_uid ;
+ gid_t s_gid ;
+ umode_t s_mode ;
+ struct buffer_head *s_root_bh ;
+ struct semaphore s_bmlock ;
+ struct affs_bm_info *s_bitmap ;
+ u32 s_bmap_count ;
+ u32 s_bmap_bits ;
+ u32 s_last_bmap ;
+ struct buffer_head *s_bmap_bh ;
+ char *s_prefix ;
+ int s_prefix_len ;
+ char s_volume[32] ;
+};
+struct ufs_csum {
+ __u32 cs_ndir ;
+ __u32 cs_nbfree ;
+ __u32 cs_nifree ;
+ __u32 cs_nffree ;
+};
+struct __anonstruct_cg_44_34 {
+ __u32 cg_clustersumoff ;
+ __u32 cg_clusteroff ;
+ __u32 cg_nclusterblks ;
+ __u32 cg_sparecon[13] ;
+};
+union __anonunion_cg_u_33 {
+ struct __anonstruct_cg_44_34 cg_44 ;
+ __u32 cg_sparecon[16] ;
+};
+struct ufs_cylinder_group {
+ __u32 cg_link ;
+ __u32 cg_magic ;
+ __u32 cg_time ;
+ __u32 cg_cgx ;
+ __u16 cg_ncyl ;
+ __u16 cg_niblk ;
+ __u32 cg_ndblk ;
+ struct ufs_csum cg_cs ;
+ __u32 cg_rotor ;
+ __u32 cg_frotor ;
+ __u32 cg_irotor ;
+ __u32 cg_frsum[8] ;
+ __u32 cg_btotoff ;
+ __u32 cg_boff ;
+ __u32 cg_iusedoff ;
+ __u32 cg_freeoff ;
+ __u32 cg_nextfreeoff ;
+ union __anonunion_cg_u_33 cg_u ;
+ __u8 cg_space[1] ;
+};
+struct ufs_buffer_head {
+ unsigned int fragment ;
+ unsigned int count ;
+ struct buffer_head *bh[8] ;
+};
+struct ufs_cg_private_info {
+ struct ufs_cylinder_group ucg ;
+ __u32 c_cgx ;
+ __u16 c_ncyl ;
+ __u16 c_niblk ;
+ __u32 c_ndblk ;
+ __u32 c_rotor ;
+ __u32 c_frotor ;
+ __u32 c_irotor ;
+ __u32 c_btotoff ;
+ __u32 c_boff ;
+ __u32 c_iusedoff ;
+ __u32 c_freeoff ;
+ __u32 c_nextfreeoff ;
+ __u32 c_clustersumoff ;
+ __u32 c_clusteroff ;
+ __u32 c_nclusterblks ;
+};
+struct ufs_sb_private_info {
+ struct ufs_buffer_head s_ubh ;
+ __u32 s_sblkno ;
+ __u32 s_cblkno ;
+ __u32 s_iblkno ;
+ __u32 s_dblkno ;
+ __u32 s_cgoffset ;
+ __u32 s_cgmask ;
+ __u32 s_size ;
+ __u32 s_dsize ;
+ __u32 s_ncg ;
+ __u32 s_bsize ;
+ __u32 s_fsize ;
+ __u32 s_fpb ;
+ __u32 s_minfree ;
+ __u32 s_bmask ;
+ __u32 s_fmask ;
+ __u32 s_bshift ;
+ __u32 s_fshift ;
+ __u32 s_fpbshift ;
+ __u32 s_fsbtodb ;
+ __u32 s_sbsize ;
+ __u32 s_csmask ;
+ __u32 s_csshift ;
+ __u32 s_nindir ;
+ __u32 s_inopb ;
+ __u32 s_nspf ;
+ __u32 s_npsect ;
+ __u32 s_interleave ;
+ __u32 s_trackskew ;
+ __u32 s_csaddr ;
+ __u32 s_cssize ;
+ __u32 s_cgsize ;
+ __u32 s_ntrak ;
+ __u32 s_nsect ;
+ __u32 s_spc ;
+ __u32 s_ipg ;
+ __u32 s_fpg ;
+ __u32 s_cpc ;
+ __s32 s_contigsumsize ;
+ __s64 s_qbmask ;
+ __s64 s_qfmask ;
+ __s32 s_postblformat ;
+ __s32 s_nrpos ;
+ __s32 s_postbloff ;
+ __s32 s_rotbloff ;
+ __u32 s_fpbmask ;
+ __u32 s_apb ;
+ __u32 s_2apb ;
+ __u32 s_3apb ;
+ __u32 s_apbmask ;
+ __u32 s_apbshift ;
+ __u32 s_2apbshift ;
+ __u32 s_3apbshift ;
+ __u32 s_nspfshift ;
+ __u32 s_nspb ;
+ __u32 s_inopf ;
+ __u32 s_sbbase ;
+ __u32 s_bpf ;
+ __u32 s_bpfshift ;
+ __u32 s_bpfmask ;
+ __u32 s_maxsymlinklen ;
+};
+struct ufs_sb_info {
+ struct ufs_sb_private_info *s_uspi ;
+ struct ufs_csum *s_csp[31] ;
+ unsigned int s_swab ;
+ unsigned int s_flags ;
+ struct buffer_head **s_ucg ;
+ struct ufs_cg_private_info *s_ucpi[8] ;
+ unsigned int s_cgno[8] ;
+ unsigned short s_cg_loaded ;
+ unsigned int s_mount_opt ;
+};
+struct efs_sb_info {
+ int32_t fs_magic ;
+ int32_t fs_start ;
+ int32_t first_block ;
+ int32_t total_blocks ;
+ int32_t group_size ;
+ int32_t data_free ;
+ int32_t inode_free ;
+ short inode_blocks ;
+ short total_groups ;
+};
+struct romfs_sb_info {
+ unsigned long s_maxsize ;
+};
+enum smb_protocol {
+ SMB_PROTOCOL_NONE = 0,
+ SMB_PROTOCOL_CORE = 1,
+ SMB_PROTOCOL_COREPLUS = 2,
+ SMB_PROTOCOL_LANMAN1 = 3,
+ SMB_PROTOCOL_LANMAN2 = 4,
+ SMB_PROTOCOL_NT1 = 5, };
+enum smb_case_hndl {
+ SMB_CASE_DEFAULT = 0,
+ SMB_CASE_LOWER = 1,
+ SMB_CASE_UPPER = 2, };
+struct smb_conn_opt {
+ unsigned int fd ;
+ enum smb_protocol protocol ;
+ enum smb_case_hndl case_handling ;
+ __u32 max_xmit ;
+ __u16 server_uid ;
+ __u16 tid ;
+ __u16 secmode ;
+ __u16 maxmux ;
+ __u16 maxvcs ;
+ __u16 rawmode ;
+ __u32 sesskey ;
+ __u32 maxraw ;
+ __u32 capabilities ;
+ __s16 serverzone ;
+};
+enum smb_conn_state {
+ CONN_VALID = 0,
+ CONN_INVALID = 1,
+ CONN_RETRIED = 2,
+ CONN_RETRYING = 3, };
+struct smb_sb_info {
+ enum smb_conn_state state ;
+ struct file *sock_file ;
+ struct smb_mount_data_kernel *mnt ;
+ unsigned char *temp_buf ;
+ unsigned int generation ;
+ pid_t conn_pid ;
+ struct smb_conn_opt opt ;
+ struct semaphore sem ;
+ wait_queue_head_t wait ;
+ __u32 packet_size ;
+ unsigned char *packet ;
+ unsigned short rcls ;
+ unsigned short err ;
+ void *data_ready ;
+ struct nls_table *remote_nls ;
+ struct nls_table *local_nls ;
+ char *name_buf ;
+ int (*convert)(char * , int , char const * , int , struct nls_table * ,
+ struct nls_table * ) ;
+};
+struct hfs_sb_info {
+ int magic ;
+ struct hfs_mdb *s_mdb ;
+ int s_quiet ;
+ int s_lowercase ;
+ int s_afpd ;
+ int s_version ;
+ int (*s_namein)(char * , struct hfs_name const * ) ;
+ void (*s_nameout)(struct hfs_name * , char const * , int ) ;
+ void (*s_ifill)(struct inode * , ino_t , int ) ;
+ struct hfs_name const *s_reserved1 ;
+ struct hfs_name const *s_reserved2 ;
+ __u32 s_type ;
+ __u32 s_creator ;
+ umode_t s_umask ;
+ uid_t s_uid ;
+ gid_t s_gid ;
+ char s_conv ;
+};
+struct adfs_sb_info {
+ struct adfs_discmap *s_map ;
+ struct adfs_dir_ops *s_dir ;
+ uid_t s_uid ;
+ gid_t s_gid ;
+ umode_t s_owner_mask ;
+ umode_t s_other_mask ;
+ __u32 s_ids_per_zone ;
+ __u32 s_idlen ;
+ __u32 s_map_size ;
+ unsigned long s_size ;
+ int s_map2blk ;
+ unsigned int s_log2sharesize ;
+ unsigned int s_version ;
+ unsigned int s_namelen ;
+};
+struct qnx4_inode_entry {
+ char di_fname[16] ;
+ qnx4_off_t di_size ;
+ qnx4_xtnt_t di_first_xtnt ;
+ __u32 di_xblk ;
+ __s32 di_ftime ;
+ __s32 di_mtime ;
+ __s32 di_atime ;
+ __s32 di_ctime ;
+ qnx4_nxtnt_t di_num_xtnts ;
+ qnx4_mode_t di_mode ;
+ qnx4_muid_t di_uid ;
+ qnx4_mgid_t di_gid ;
+ qnx4_nlink_t di_nlink ;
+ __u8 di_zero[4] ;
+ qnx4_ftype_t di_type ;
+ __u8 di_status ;
+};
+struct qnx4_super_block {
+ struct qnx4_inode_entry RootDir ;
+ struct qnx4_inode_entry Inode ;
+ struct qnx4_inode_entry Boot ;
+ struct qnx4_inode_entry AltBoot ;
+};
+struct qnx4_sb_info {
+ struct buffer_head *sb_buf ;
+ struct qnx4_super_block *sb ;
+ unsigned int Version ;
+ struct qnx4_inode_entry *BitMap ;
+};
+struct tq_struct {
+ struct list_head list ;
+ unsigned long sync ;
+ void (*routine)(void * ) ;
+ void *data ;
+};
+struct reiserfs_super_block {
+ __u32 s_block_count ;
+ __u32 s_free_blocks ;
+ __u32 s_root_block ;
+ __u32 s_journal_block ;
+ __u32 s_journal_dev ;
+ __u32 s_orig_journal_size ;
+ __u32 s_journal_trans_max ;
+ __u32 s_journal_block_count ;
+ __u32 s_journal_max_batch ;
+ __u32 s_journal_max_commit_age ;
+ __u32 s_journal_max_trans_age ;
+ __u16 s_blocksize ;
+ __u16 s_oid_maxsize ;
+ __u16 s_oid_cursize ;
+ __u16 s_state ;
+ char s_magic[12] ;
+ __u32 s_hash_function_code ;
+ __u16 s_tree_height ;
+ __u16 s_bmap_nr ;
+ __u16 s_version ;
+ __u16 s_reserved ;
+ char s_unused[128] ;
+} __attribute__((__packed__)) ;
+struct reiserfs_journal_cnode {
+ struct buffer_head *bh ;
+ kdev_t dev ;
+ unsigned long blocknr ;
+ int state ;
+ struct reiserfs_journal_list *jlist ;
+ struct reiserfs_journal_cnode *next ;
+ struct reiserfs_journal_cnode *prev ;
+ struct reiserfs_journal_cnode *hprev ;
+ struct reiserfs_journal_cnode *hnext ;
+};
+struct reiserfs_bitmap_node {
+ int id ;
+ char *data ;
+ struct list_head list ;
+};
+struct reiserfs_list_bitmap {
+ struct reiserfs_journal_list *journal_list ;
+ struct reiserfs_bitmap_node **bitmaps ;
+};
+struct reiserfs_journal_list {
+ unsigned long j_start ;
+ unsigned long j_len ;
+ atomic_t j_nonzerolen ;
+ atomic_t j_commit_left ;
+ atomic_t j_flushing ;
+ atomic_t j_commit_flushing ;
+ atomic_t j_older_commits_done ;
+ unsigned long j_trans_id ;
+ time_t j_timestamp ;
+ struct reiserfs_list_bitmap *j_list_bitmap ;
+ struct buffer_head *j_commit_bh ;
+ struct reiserfs_journal_cnode *j_realblock ;
+ struct reiserfs_journal_cnode *j_freedlist ;
+ wait_queue_head_t j_commit_wait ;
+ wait_queue_head_t j_flush_wait ;
+};
+struct reiserfs_journal {
+ struct buffer_head **j_ap_blocks ;
+ struct reiserfs_journal_cnode *j_last ;
+ struct reiserfs_journal_cnode *j_first ;
+ int j_state ;
+ unsigned long j_trans_id ;
+ unsigned long j_mount_id ;
+ unsigned long j_start ;
+ unsigned long j_len ;
+ unsigned long j_len_alloc ;
+ atomic_t j_wcount ;
+ unsigned long j_bcount ;
+ unsigned long j_first_unflushed_offset ;
+ unsigned long j_last_flush_trans_id ;
+ struct buffer_head *j_header_bh ;
+ struct reiserfs_page_list *j_flush_pages ;
+ time_t j_trans_start_time ;
+ wait_queue_head_t j_wait ;
+ atomic_t j_wlock ;
+ wait_queue_head_t j_join_wait ;
+ atomic_t j_jlock ;
+ int j_journal_list_index ;
+ int j_list_bitmap_index ;
+ int j_must_wait ;
+ int j_next_full_flush ;
+ int j_next_async_flush ;
+ int j_cnode_used ;
+ int j_cnode_free ;
+ struct reiserfs_journal_cnode *j_cnode_free_list ;
+ struct reiserfs_journal_cnode *j_cnode_free_orig ;
+ int j_free_bitmap_nodes ;
+ int j_used_bitmap_nodes ;
+ struct list_head j_bitmap_nodes ;
+ struct reiserfs_list_bitmap j_list_bitmap[5] ;
+ struct reiserfs_journal_list j_journal_list[64] ;
+ struct reiserfs_journal_cnode *j_hash_table[8192] ;
+ struct reiserfs_journal_cnode *j_list_hash_table[8192] ;
+ struct list_head j_prealloc_list ;
+};
+struct reiserfs_sb_info {
+ struct buffer_head *s_sbh ;
+ struct reiserfs_super_block *s_rs ;
+ struct buffer_head **s_ap_bitmap ;
+ struct reiserfs_journal *s_journal ;
+ unsigned short s_mount_state ;
+ void (*end_io_handler)(struct buffer_head * , int ) ;
+ __u32 (*s_hash_function)(char const * , int ) ;
+ unsigned long s_mount_opt ;
+ wait_queue_head_t s_wait ;
+ atomic_t s_generation_counter ;
+ int s_kmallocs ;
+ int s_disk_reads ;
+ int s_disk_writes ;
+ int s_fix_nodes ;
+ int s_do_balance ;
+ int s_unneeded_left_neighbor ;
+ int s_good_search_by_key_reada ;
+ int s_bmaps ;
+ int s_bmaps_without_search ;
+ int s_direct2indirect ;
+ int s_indirect2direct ;
+};
+struct bfs_sb_info {
+ unsigned long si_blocks ;
+ unsigned long si_freeb ;
+ unsigned long si_freei ;
+ unsigned long si_lf_ioff ;
+ unsigned long si_lf_sblk ;
+ unsigned long si_lf_eblk ;
+ unsigned long si_lasti ;
+ char *si_imap ;
+ struct buffer_head *si_sbh ;
+ struct bfs_super_block *si_bfs_sb ;
+};
+#pragma pack(1)
+union __anonunion_s_spar_remap_50 {
+ __u8 *s_spar_remap8 ;
+ __u16 *s_spar_remap16 ;
+ __u32 *s_spar_remap32 ;
+};
+struct udf_sparing_data {
+ __u32 s_spar_loc[4] ;
+ __u8 s_spar_pshift ;
+ __u8 s_spar_indexsize ;
+ __u32 *s_spar_map ;
+ union __anonunion_s_spar_remap_50 s_spar_remap ;
+};
+struct udf_virtual_data {
+ __u32 s_num_entries ;
+ __u16 s_start_offset ;
+};
+union __anonunion_s_uspace_51 {
+ __u32 bitmap ;
+ struct inode *table ;
+};
+union __anonunion_s_fspace_52 {
+ __u32 bitmap ;
+ struct inode *table ;
+};
+union __anonunion_s_type_specific_53 {
+ struct udf_sparing_data s_sparing ;
+ struct udf_virtual_data s_virtual ;
+};
+struct udf_part_map {
+ union __anonunion_s_uspace_51 s_uspace ;
+ union __anonunion_s_fspace_52 s_fspace ;
+ __u32 s_partition_root ;
+ __u32 s_partition_len ;
+ __u16 s_partition_type ;
+ __u16 s_partition_num ;
+ union __anonunion_s_type_specific_53 s_type_specific ;
+ __u32 (*s_partition_func)(struct super_block * , __u32 , __u16 , __u32 ) ;
+ __u16 s_volumeseqnum ;
+ __u16 s_partition_flags ;
+};
+#pragma pack()
+struct udf_sb_info {
+ struct udf_part_map *s_partmaps ;
+ __u8 s_volident[32] ;
+ __u16 s_partitions ;
+ __u16 s_partition ;
+ __u32 s_session ;
+ __u32 s_anchor[4] ;
+ __u32 s_lastblock ;
+ struct buffer_head *s_lvidbh ;
+ __u16 s_loaded_block_bitmaps ;
+ __u32 s_block_bitmap_number[8] ;
+ struct buffer_head *s_block_bitmap[8] ;
+ mode_t s_umask ;
+ gid_t s_gid ;
+ uid_t s_uid ;
+ time_t s_recordtime ;
+ __u16 s_serialnum ;
+ __u16 s_udfrev ;
+ __u32 s_flags ;
+ struct inode *s_vat ;
+};
+struct ncp_mount_data_kernel {
+ unsigned long flags ;
+ unsigned int int_flags ;
+ __kernel_uid32_t mounted_uid ;
+ __kernel_pid_t wdog_pid ;
+ unsigned int ncp_fd ;
+ unsigned int time_out ;
+ unsigned int retry_count ;
+ unsigned char mounted_vol[17] ;
+ __kernel_uid32_t uid ;
+ __kernel_gid32_t gid ;
+ __kernel_mode_t file_mode ;
+ __kernel_mode_t dir_mode ;
+};
+struct __anonstruct_auth_54 {
+ int auth_type ;
+ size_t object_name_len ;
+ void *object_name ;
+ int object_type ;
+};
+struct __anonstruct_priv_55 {
+ size_t len ;
+ void *data ;
+};
+struct ncp_server {
+ struct ncp_mount_data_kernel m ;
+ __u8 name_space[66] ;
+ struct file *ncp_filp ;
+ u8 sequence ;
+ u8 task ;
+ u16 connection ;
+ u8 completion ;
+ u8 conn_status ;
+ int buffer_size ;
+ int reply_size ;
+ int packet_size ;
+ unsigned char *packet ;
+ int lock ;
+ struct semaphore sem ;
+ int current_size ;
+ int has_subfunction ;
+ int ncp_reply_size ;
+ int root_setuped ;
+ int sign_wanted ;
+ int sign_active ;
+ char sign_root[8] ;
+ char sign_last[16] ;
+ struct __anonstruct_auth_54 auth ;
+ struct __anonstruct_priv_55 priv ;
+ struct nls_table *nls_vol ;
+ struct nls_table *nls_io ;
+ int dentry_ttl ;
+ unsigned int flags ;
+};
+struct usbdev_sb_info {
+ struct list_head slist ;
+ struct list_head ilist ;
+ uid_t devuid ;
+ gid_t devgid ;
+ umode_t devmode ;
+ uid_t busuid ;
+ gid_t busgid ;
+ umode_t busmode ;
+ uid_t listuid ;
+ gid_t listgid ;
+ umode_t listmode ;
+};
+union __anonunion_u_56 {
+ struct minix_sb_info minix_sb ;
+ struct ext2_sb_info ext2_sb ;
+ struct hpfs_sb_info hpfs_sb ;
+ struct ntfs_sb_info ntfs_sb ;
+ struct msdos_sb_info msdos_sb ;
+ struct isofs_sb_info isofs_sb ;
+ struct nfs_sb_info nfs_sb ;
+ struct sysv_sb_info sysv_sb ;
+ struct affs_sb_info affs_sb ;
+ struct ufs_sb_info ufs_sb ;
+ struct efs_sb_info efs_sb ;
+ struct shmem_sb_info shmem_sb ;
+ struct romfs_sb_info romfs_sb ;
+ struct smb_sb_info smbfs_sb ;
+ struct hfs_sb_info hfs_sb ;
+ struct adfs_sb_info adfs_sb ;
+ struct qnx4_sb_info qnx4_sb ;
+ struct reiserfs_sb_info reiserfs_sb ;
+ struct bfs_sb_info bfs_sb ;
+ struct udf_sb_info udf_sb ;
+ struct ncp_server ncpfs_sb ;
+ struct usbdev_sb_info usbdevfs_sb ;
+ void *generic_sbp ;
+};
+struct super_block {
+ struct list_head s_list ;
+ kdev_t s_dev ;
+ unsigned long s_blocksize ;
+ unsigned char s_blocksize_bits ;
+ unsigned char s_dirt ;
+ unsigned long long s_maxbytes ;
+ struct file_system_type *s_type ;
+ struct super_operations *s_op ;
+ struct dquot_operations *dq_op ;
+ unsigned long s_flags ;
+ unsigned long s_magic ;
+ struct dentry *s_root ;
+ struct rw_semaphore s_umount ;
+ struct semaphore s_lock ;
+ struct list_head s_dirty ;
+ struct list_head s_locked_inodes ;
+ struct list_head s_files ;
+ struct block_device *s_bdev ;
+ struct list_head s_mounts ;
+ struct quota_mount_options s_dquot ;
+ union __anonunion_u_56 u ;
+ struct semaphore s_vfs_rename_sem ;
+ struct semaphore s_nfsd_free_path_sem ;
+};
+struct block_device_operations {
+ int (*open)(struct inode * , struct file * ) ;
+ int (*release)(struct inode * , struct file * ) ;
+ int (*ioctl)(struct inode * , struct file * , unsigned int ,
+ unsigned long ) ;
+ int (*check_media_change)(kdev_t ) ;
+ int (*revalidate)(kdev_t ) ;
+};
+struct file_operations {
+ struct module *owner ;
+ loff_t (*llseek)(struct file * , loff_t , int ) ;
+ ssize_t (*read)(struct file * , char * , size_t , loff_t * ) ;
+ ssize_t (*write)(struct file * , char const * , size_t , loff_t * ) ;
+ int (*readdir)(struct file * , void * , int (*)(void * , char const * ,
+ int , off_t , ino_t ,
+ unsigned int ) ) ;
+ unsigned int (*poll)(struct file * , struct poll_table_struct * ) ;
+ int (*ioctl)(struct inode * , struct file * , unsigned int ,
+ unsigned long ) ;
+ int (*mmap)(struct file * , struct vm_area_struct * ) ;
+ int (*open)(struct inode * , struct file * ) ;
+ int (*flush)(struct file * ) ;
+ int (*release)(struct inode * , struct file * ) ;
+ int (*fsync)(struct file * , struct dentry * , int datasync ) ;
+ int (*fasync)(int , struct file * , int ) ;
+ int (*lock)(struct file * , int , struct file_lock * ) ;
+ ssize_t (*readv)(struct file * , struct iovec const * , unsigned long ,
+ loff_t * ) ;
+ ssize_t (*writev)(struct file * , struct iovec const * , unsigned long ,
+ loff_t * ) ;
+ ssize_t (*sendpage)(struct file * , struct page * , int , size_t ,
+ loff_t * , int ) ;
+ unsigned long (*get_unmapped_area)(struct file * , unsigned long ,
+ unsigned long , unsigned long ,
+ unsigned long ) ;
+};
+struct inode_operations {
+ int (*create)(struct inode * , struct dentry * , int ) ;
+ struct dentry *(*lookup)(struct inode * , struct dentry * ) ;
+ int (*link)(struct dentry * , struct inode * , struct dentry * ) ;
+ int (*unlink)(struct inode * , struct dentry * ) ;
+ int (*symlink)(struct inode * , struct dentry * , char const * ) ;
+ int (*mkdir)(struct inode * , struct dentry * , int ) ;
+ int (*rmdir)(struct inode * , struct dentry * ) ;
+ int (*mknod)(struct inode * , struct dentry * , int , int ) ;
+ int (*rename)(struct inode * , struct dentry * , struct inode * ,
+ struct dentry * ) ;
+ int (*readlink)(struct dentry * , char * , int ) ;
+ int (*follow_link)(struct dentry * , struct nameidata * ) ;
+ void (*truncate)(struct inode * ) ;
+ int (*permission)(struct inode * , int ) ;
+ int (*revalidate)(struct dentry * ) ;
+ int (*setattr)(struct dentry * , struct iattr * ) ;
+ int (*getattr)(struct dentry * , struct iattr * ) ;
+};
+struct super_operations {
+ void (*read_inode)(struct inode * ) ;
+ void (*read_inode2)(struct inode * , void * ) ;
+ void (*dirty_inode)(struct inode * ) ;
+ void (*write_inode)(struct inode * , int ) ;
+ void (*put_inode)(struct inode * ) ;
+ void (*delete_inode)(struct inode * ) ;
+ void (*put_super)(struct super_block * ) ;
+ void (*write_super)(struct super_block * ) ;
+ void (*write_super_lockfs)(struct super_block * ) ;
+ void (*unlockfs)(struct super_block * ) ;
+ int (*statfs)(struct super_block * , struct statfs * ) ;
+ int (*remount_fs)(struct super_block * , int * , char * ) ;
+ void (*clear_inode)(struct inode * ) ;
+ void (*umount_begin)(struct super_block * ) ;
+};
+struct dquot_operations {
+ void (*initialize)(struct inode * , short ) ;
+ void (*drop)(struct inode * ) ;
+ int (*alloc_block)(struct inode const * , unsigned long , char ) ;
+ int (*alloc_inode)(struct inode const * , unsigned long ) ;
+ void (*free_block)(struct inode const * , unsigned long ) ;
+ void (*free_inode)(struct inode const * , unsigned long ) ;
+ int (*transfer)(struct dentry * , struct iattr * ) ;
+};
+struct file_system_type {
+ char const *name ;
+ int fs_flags ;
+ struct super_block *(*read_super)(struct super_block * , void * , int ) ;
+ struct module *owner ;
+ struct vfsmount *kern_mnt ;
+ struct file_system_type *next ;
+};
+typedef __u32 kernel_cap_t;
+struct linux_binprm {
+ char buf[128] ;
+ struct page *page[32] ;
+ unsigned long p ;
+ int sh_bang ;
+ struct file *file ;
+ int e_uid ;
+ int e_gid ;
+ kernel_cap_t cap_inheritable ;
+ kernel_cap_t cap_permitted ;
+ kernel_cap_t cap_effective ;
+ int argc ;
+ int envc ;
+ char *filename ;
+ unsigned long loader ;
+ unsigned long exec ;
+};
+struct linux_binfmt {
+ struct linux_binfmt *next ;
+ struct module *module ;
+ int (*load_binary)(struct linux_binprm * , struct pt_regs *regs ) ;
+ int (*load_shlib)(struct file * ) ;
+ int (*core_dump)(long signr , struct pt_regs *regs , struct file *file ) ;
+ unsigned long min_coredump ;
+};
+struct exec_domain {
+ char const *name ;
+ void (*handler)(int , struct pt_regs * ) ;
+ unsigned char pers_low ;
+ unsigned char pers_high ;
+ unsigned long *signal_map ;
+ unsigned long *signal_invmap ;
+ struct module *module ;
+ struct exec_domain *next ;
+};
+struct tms {
+ clock_t tms_utime ;
+ clock_t tms_stime ;
+ clock_t tms_cutime ;
+ clock_t tms_cstime ;
+};
+struct __anonstruct_mm_context_t_60 {
+ void *segments ;
+};
+typedef struct __anonstruct_mm_context_t_60 mm_context_t;
+typedef unsigned char cc_t;
+typedef unsigned int tcflag_t;
+struct termios {
+ tcflag_t c_iflag ;
+ tcflag_t c_oflag ;
+ tcflag_t c_cflag ;
+ tcflag_t c_lflag ;
+ cc_t c_line ;
+ cc_t c_cc[19] ;
+};
+struct winsize {
+ unsigned short ws_row ;
+ unsigned short ws_col ;
+ unsigned short ws_xpixel ;
+ unsigned short ws_ypixel ;
+};
+struct tty_driver {
+ int magic ;
+ char const *driver_name ;
+ char const *name ;
+ int name_base ;
+ short major ;
+ short minor_start ;
+ short num ;
+ short type ;
+ short subtype ;
+ struct termios init_termios ;
+ int flags ;
+ int *refcount ;
+ struct proc_dir_entry *proc_entry ;
+ struct tty_driver *other ;
+ struct tty_struct **table ;
+ struct termios **termios ;
+ struct termios **termios_locked ;
+ void *driver_state ;
+ int (*open)(struct tty_struct *tty , struct file *filp ) ;
+ void (*close)(struct tty_struct *tty , struct file *filp ) ;
+ int (*write)(struct tty_struct *tty , int from_user ,
+ unsigned char const *buf , int count ) ;
+ void (*put_char)(struct tty_struct *tty , unsigned char ch ) ;
+ void (*flush_chars)(struct tty_struct *tty ) ;
+ int (*write_room)(struct tty_struct *tty ) ;
+ int (*chars_in_buffer)(struct tty_struct *tty ) ;
+ int (*ioctl)(struct tty_struct *tty , struct file *file ,
+ unsigned int cmd , unsigned long arg ) ;
+ void (*set_termios)(struct tty_struct *tty , struct termios *old ) ;
+ void (*throttle)(struct tty_struct *tty ) ;
+ void (*unthrottle)(struct tty_struct *tty ) ;
+ void (*stop)(struct tty_struct *tty ) ;
+ void (*start)(struct tty_struct *tty ) ;
+ void (*hangup)(struct tty_struct *tty ) ;
+ void (*break_ctl)(struct tty_struct *tty , int state ) ;
+ void (*flush_buffer)(struct tty_struct *tty ) ;
+ void (*set_ldisc)(struct tty_struct *tty ) ;
+ void (*wait_until_sent)(struct tty_struct *tty , int timeout ) ;
+ void (*send_xchar)(struct tty_struct *tty , char ch ) ;
+ int (*read_proc)(char *page , char **start , off_t off , int count ,
+ int *eof , void *data ) ;
+ int (*write_proc)(struct file *file , char const *buffer ,
+ unsigned long count , void *data ) ;
+ struct tty_driver *next ;
+ struct tty_driver *prev ;
+};
+struct tty_ldisc {
+ int magic ;
+ char *name ;
+ int num ;
+ int flags ;
+ int (*open)(struct tty_struct * ) ;
+ void (*close)(struct tty_struct * ) ;
+ void (*flush_buffer)(struct tty_struct *tty ) ;
+ ssize_t (*chars_in_buffer)(struct tty_struct *tty ) ;
+ ssize_t (*read)(struct tty_struct *tty , struct file *file ,
+ unsigned char *buf , size_t nr ) ;
+ ssize_t (*write)(struct tty_struct *tty , struct file *file ,
+ unsigned char const *buf , size_t nr ) ;
+ int (*ioctl)(struct tty_struct *tty , struct file *file ,
+ unsigned int cmd , unsigned long arg ) ;
+ void (*set_termios)(struct tty_struct *tty , struct termios *old ) ;
+ unsigned int (*poll)(struct tty_struct * , struct file * ,
+ struct poll_table_struct * ) ;
+ void (*receive_buf)(struct tty_struct * , unsigned char const *cp ,
+ char *fp , int count ) ;
+ int (*receive_room)(struct tty_struct * ) ;
+ void (*write_wakeup)(struct tty_struct * ) ;
+};
+struct tty_flip_buffer {
+ struct tq_struct tqueue ;
+ struct semaphore pty_sem ;
+ char *char_buf_ptr ;
+ unsigned char *flag_buf_ptr ;
+ int count ;
+ int buf_num ;
+ unsigned char char_buf[1024] ;
+ char flag_buf[1024] ;
+ unsigned char slop[4] ;
+};
+struct tty_struct {
+ int magic ;
+ struct tty_driver driver ;
+ struct tty_ldisc ldisc ;
+ struct termios *termios ;
+ struct termios *termios_locked ;
+ int pgrp ;
+ int session ;
+ kdev_t device ;
+ unsigned long flags ;
+ int count ;
+ struct winsize winsize ;
+ unsigned char stopped : 1 ;
+ unsigned char hw_stopped : 1 ;
+ unsigned char flow_stopped : 1 ;
+ unsigned char packet : 1 ;
+ unsigned char low_latency : 1 ;
+ unsigned char warned : 1 ;
+ unsigned char ctrl_status ;
+ struct tty_struct *link ;
+ struct fasync_struct *fasync ;
+ struct tty_flip_buffer flip ;
+ int max_flip_cnt ;
+ int alt_speed ;
+ wait_queue_head_t write_wait ;
+ wait_queue_head_t read_wait ;
+ struct tq_struct tq_hangup ;
+ void *disc_data ;
+ void *driver_data ;
+ struct list_head tty_files ;
+ unsigned int column ;
+ unsigned char lnext : 1 ;
+ unsigned char erasing : 1 ;
+ unsigned char raw : 1 ;
+ unsigned char real_raw : 1 ;
+ unsigned char icanon : 1 ;
+ unsigned char closing : 1 ;
+ unsigned short minimum_to_wake ;
+ unsigned int overrun_time ;
+ int num_overrun ;
+ unsigned long process_char_map[(int )(256U / (8U * sizeof(unsigned long )))] ;
+ char *read_buf ;
+ int read_head ;
+ int read_tail ;
+ int read_cnt ;
+ unsigned long read_flags[(int )(4096U / (8U * sizeof(unsigned long )))] ;
+ int canon_data ;
+ unsigned long canon_head ;
+ unsigned int canon_column ;
+ struct semaphore atomic_read ;
+ struct semaphore atomic_write ;
+ spinlock_t read_lock ;
+ struct tq_struct SAK_tq ;
+};
+struct kern_ipc_perm {
+ key_t key ;
+ uid_t uid ;
+ gid_t gid ;
+ uid_t cuid ;
+ gid_t cgid ;
+ mode_t mode ;
+ unsigned long seq ;
+};
+struct sembuf {
+ unsigned short sem_num ;
+ short sem_op ;
+ short sem_flg ;
+};
+struct sem {
+ int semval ;
+ int sempid ;
+};
+struct sem_array {
+ struct kern_ipc_perm sem_perm ;
+ time_t sem_otime ;
+ time_t sem_ctime ;
+ struct sem *sem_base ;
+ struct sem_queue *sem_pending ;
+ struct sem_queue **sem_pending_last ;
+ struct sem_undo *undo ;
+ unsigned long sem_nsems ;
+};
+struct sem_queue {
+ struct sem_queue *next ;
+ struct sem_queue **prev ;
+ struct task_struct *sleeper ;
+ struct sem_undo *undo ;
+ int pid ;
+ int status ;
+ struct sem_array *sma ;
+ int id ;
+ struct sembuf *sops ;
+ int nsops ;
+ int alter ;
+};
+struct sem_undo {
+ struct sem_undo *proc_next ;
+ struct sem_undo *id_next ;
+ int semid ;
+ short *semadj ;
+};
+struct __anonstruct_sigset_t_110 {
+ unsigned long sig[2] ;
+};
+typedef struct __anonstruct_sigset_t_110 sigset_t;
+struct sigaction {
+ void (*sa_handler)(int ) ;
+ unsigned long sa_flags ;
+ void (*sa_restorer)(void) ;
+ sigset_t sa_mask ;
+};
+struct k_sigaction {
+ struct sigaction sa ;
+};
+union sigval {
+ int sival_int ;
+ void *sival_ptr ;
+};
+typedef union sigval sigval_t;
+struct __anonstruct__kill_112 {
+ pid_t _pid ;
+ uid_t _uid ;
+};
+struct __anonstruct__timer_113 {
+ unsigned int _timer1 ;
+ unsigned int _timer2 ;
+};
+struct __anonstruct__rt_114 {
+ pid_t _pid ;
+ uid_t _uid ;
+ sigval_t _sigval ;
+};
+struct __anonstruct__sigchld_115 {
+ pid_t _pid ;
+ uid_t _uid ;
+ int _status ;
+ clock_t _utime ;
+ clock_t _stime ;
+};
+struct __anonstruct__sigfault_116 {
+ void *_addr ;
+};
+struct __anonstruct__sigpoll_117 {
+ int _band ;
+ int _fd ;
+};
+union __anonunion__sifields_111 {
+ int _pad[(int )(128U / sizeof(int ) - 3U)] ;
+ struct __anonstruct__kill_112 _kill ;
+ struct __anonstruct__timer_113 _timer ;
+ struct __anonstruct__rt_114 _rt ;
+ struct __anonstruct__sigchld_115 _sigchld ;
+ struct __anonstruct__sigfault_116 _sigfault ;
+ struct __anonstruct__sigpoll_117 _sigpoll ;
+};
+struct siginfo {
+ int si_signo ;
+ int si_errno ;
+ int si_code ;
+ union __anonunion__sifields_111 _sifields ;
+};
+typedef struct siginfo siginfo_t;
+struct sigqueue {
+ struct sigqueue *next ;
+ siginfo_t info ;
+};
+struct sigpending {
+ struct sigqueue *head ;
+ struct sigqueue **tail ;
+ sigset_t signal ;
+};
+struct fs_struct {
+ atomic_t count ;
+ rwlock_t lock ;
+ int umask ;
+ struct dentry *root ;
+ struct dentry *pwd ;
+ struct dentry *altroot ;
+ struct vfsmount *rootmnt ;
+ struct vfsmount *pwdmnt ;
+ struct vfsmount *altrootmnt ;
+};
+struct rlimit {
+ unsigned long rlim_cur ;
+ unsigned long rlim_max ;
+};
+struct timer_list {
+ struct list_head list ;
+ unsigned long expires ;
+ unsigned long data ;
+ void (*function)(unsigned long ) ;
+};
+struct files_struct {
+ atomic_t count ;
+ rwlock_t file_lock ;
+ int max_fds ;
+ int max_fdset ;
+ int next_fd ;
+ struct file **fd ;
+ fd_set *close_on_exec ;
+ fd_set *open_fds ;
+ fd_set close_on_exec_init ;
+ fd_set open_fds_init ;
+ struct file *fd_array[32] ;
+};
+struct mm_struct {
+ struct vm_area_struct *mmap ;
+ struct vm_area_struct *mmap_avl ;
+ struct vm_area_struct *mmap_cache ;
+ pgd_t *pgd ;
+ atomic_t mm_users ;
+ atomic_t mm_count ;
+ int map_count ;
+ struct rw_semaphore mmap_sem ;
+ spinlock_t page_table_lock ;
+ struct list_head mmlist ;
+ unsigned long start_code ;
+ unsigned long end_code ;
+ unsigned long start_data ;
+ unsigned long end_data ;
+ unsigned long start_brk ;
+ unsigned long brk ;
+ unsigned long start_stack ;
+ unsigned long arg_start ;
+ unsigned long arg_end ;
+ unsigned long env_start ;
+ unsigned long env_end ;
+ unsigned long rss ;
+ unsigned long total_vm ;
+ unsigned long locked_vm ;
+ unsigned long def_flags ;
+ unsigned long cpu_vm_mask ;
+ unsigned long swap_address ;
+ mm_context_t context ;
+};
+struct signal_struct {
+ atomic_t count ;
+ struct k_sigaction action[64] ;
+ spinlock_t siglock ;
+};
+struct user_struct {
+ atomic_t __count ;
+ atomic_t processes ;
+ atomic_t files ;
+ struct user_struct *next ;
+ struct user_struct **pprev ;
+ uid_t uid ;
+};
+struct task_struct {
+ long volatile state ;
+ unsigned long flags ;
+ int sigpending ;
+ mm_segment_t addr_limit ;
+ struct exec_domain *exec_domain ;
+ long volatile need_resched ;
+ unsigned long ptrace ;
+ int lock_depth ;
+ long counter ;
+ long nice ;
+ unsigned long policy ;
+ struct mm_struct *mm ;
+ int has_cpu ;
+ int processor ;
+ unsigned long cpus_allowed ;
+ struct list_head run_list ;
+ unsigned long sleep_time ;
+ struct task_struct *next_task ;
+ struct task_struct *prev_task ;
+ struct mm_struct *active_mm ;
+ struct linux_binfmt *binfmt ;
+ int exit_code ;
+ int exit_signal ;
+ int pdeath_signal ;
+ unsigned long personality ;
+ int dumpable : 1 ;
+ int did_exec : 1 ;
+ pid_t pid ;
+ pid_t pgrp ;
+ pid_t tty_old_pgrp ;
+ pid_t session ;
+ pid_t tgid ;
+ int leader ;
+ struct task_struct *p_opptr ;
+ struct task_struct *p_pptr ;
+ struct task_struct *p_cptr ;
+ struct task_struct *p_ysptr ;
+ struct task_struct *p_osptr ;
+ struct list_head thread_group ;
+ struct task_struct *pidhash_next ;
+ struct task_struct **pidhash_pprev ;
+ wait_queue_head_t wait_chldexit ;
+ struct semaphore *vfork_sem ;
+ unsigned long rt_priority ;
+ unsigned long it_real_value ;
+ unsigned long it_prof_value ;
+ unsigned long it_virt_value ;
+ unsigned long it_real_incr ;
+ unsigned long it_prof_incr ;
+ unsigned long it_virt_incr ;
+ struct timer_list real_timer ;
+ struct tms times ;
+ unsigned long start_time ;
+ long per_cpu_utime[32] ;
+ long per_cpu_stime[32] ;
+ unsigned long min_flt ;
+ unsigned long maj_flt ;
+ unsigned long nswap ;
+ unsigned long cmin_flt ;
+ unsigned long cmaj_flt ;
+ unsigned long cnswap ;
+ int swappable : 1 ;
+ uid_t uid ;
+ uid_t euid ;
+ uid_t suid ;
+ uid_t fsuid ;
+ gid_t gid ;
+ gid_t egid ;
+ gid_t sgid ;
+ gid_t fsgid ;
+ int ngroups ;
+ gid_t groups[32] ;
+ kernel_cap_t cap_effective ;
+ kernel_cap_t cap_inheritable ;
+ kernel_cap_t cap_permitted ;
+ int keep_capabilities : 1 ;
+ struct user_struct *user ;
+ struct rlimit rlim[11] ;
+ unsigned short used_math ;
+ char comm[16] ;
+ int link_count ;
+ struct tty_struct *tty ;
+ unsigned int locks ;
+ struct sem_undo *semundo ;
+ struct sem_queue *semsleeping ;
+ struct thread_struct thread ;
+ struct fs_struct *fs ;
+ struct files_struct *files ;
+ spinlock_t sigmask_lock ;
+ struct signal_struct *sig ;
+ sigset_t blocked ;
+ struct sigpending pending ;
+ unsigned long sas_ss_sp ;
+ size_t sas_ss_size ;
+ int (*notifier)(void *priv ) ;
+ void *notifier_data ;
+ sigset_t *notifier_mask ;
+ u32 parent_exec_id ;
+ u32 self_exec_id ;
+ spinlock_t alloc_lock ;
+};
+struct free_area_struct {
+ struct list_head free_list ;
+ unsigned long *map ;
+};
+typedef struct free_area_struct free_area_t;
+struct zone_struct {
+ spinlock_t lock ;
+ unsigned long free_pages ;
+ unsigned long inactive_clean_pages ;
+ unsigned long inactive_dirty_pages ;
+ unsigned long pages_min ;
+ unsigned long pages_low ;
+ unsigned long pages_high ;
+ struct list_head inactive_clean_list ;
+ free_area_t free_area[10] ;
+ struct pglist_data *zone_pgdat ;
+ struct page *zone_mem_map ;
+ unsigned long zone_start_paddr ;
+ unsigned long zone_start_mapnr ;
+ char *name ;
+ unsigned long size ;
+};
+typedef struct zone_struct zone_t;
+struct zonelist_struct {
+ zone_t *zones[4] ;
+ int gfp_mask ;
+};
+typedef struct zonelist_struct zonelist_t;
+struct pglist_data {
+ zone_t node_zones[3] ;
+ zonelist_t node_zonelists[32] ;
+ struct page *node_mem_map ;
+ unsigned long *valid_addr_bitmap ;
+ struct bootmem_data *bdata ;
+ unsigned long node_start_paddr ;
+ unsigned long node_start_mapnr ;
+ unsigned long node_size ;
+ int node_id ;
+ struct pglist_data *node_next ;
+};
+struct vm_area_struct {
+ struct mm_struct *vm_mm ;
+ unsigned long vm_start ;
+ unsigned long vm_end ;
+ struct vm_area_struct *vm_next ;
+ pgprot_t vm_page_prot ;
+ unsigned long vm_flags ;
+ short vm_avl_height ;
+ struct vm_area_struct *vm_avl_left ;
+ struct vm_area_struct *vm_avl_right ;
+ struct vm_area_struct *vm_next_share ;
+ struct vm_area_struct **vm_pprev_share ;
+ struct vm_operations_struct *vm_ops ;
+ unsigned long vm_pgoff ;
+ struct file *vm_file ;
+ unsigned long vm_raend ;
+ void *vm_private_data ;
+};
+struct vm_operations_struct {
+ void (*open)(struct vm_area_struct *area ) ;
+ void (*close)(struct vm_area_struct *area ) ;
+ struct page *(*nopage)(struct vm_area_struct *area ,
+ unsigned long address , int write_access ) ;
+};
+struct page {
+ struct list_head list ;
+ struct address_space *mapping ;
+ unsigned long index ;
+ struct page *next_hash ;
+ atomic_t count ;
+ unsigned long flags ;
+ struct list_head lru ;
+ unsigned long age ;
+ wait_queue_head_t wait ;
+ struct page **pprev_hash ;
+ struct buffer_head *buffers ;
+ void *virtual ;
+ struct zone_struct *zone ;
+};
+struct tasklet_struct {
+ struct tasklet_struct *next ;
+ unsigned long state ;
+ atomic_t count ;
+ void (*func)(unsigned long ) ;
+ unsigned long data ;
+};
+struct ifmap {
+ unsigned long mem_start ;
+ unsigned long mem_end ;
+ unsigned short base_addr ;
+ unsigned char irq ;
+ unsigned char dma ;
+ unsigned char port ;
+};
+union __anonunion_ifr_ifrn_126 {
+ char ifrn_name[16] ;
+};
+union __anonunion_ifr_ifru_127 {
+ struct sockaddr ifru_addr ;
+ struct sockaddr ifru_dstaddr ;
+ struct sockaddr ifru_broadaddr ;
+ struct sockaddr ifru_netmask ;
+ struct sockaddr ifru_hwaddr ;
+ short ifru_flags ;
+ int ifru_ivalue ;
+ int ifru_mtu ;
+ struct ifmap ifru_map ;
+ char ifru_slave[16] ;
+ char ifru_newname[16] ;
+ char *ifru_data ;
+};
+struct ifreq {
+ union __anonunion_ifr_ifrn_126 ifr_ifrn ;
+ union __anonunion_ifr_ifru_127 ifr_ifru ;
+};
+struct ethhdr {
+ unsigned char h_dest[6] ;
+ unsigned char h_source[6] ;
+ unsigned short h_proto ;
+};
+struct net_device_stats {
+ unsigned long rx_packets ;
+ unsigned long tx_packets ;
+ unsigned long rx_bytes ;
+ unsigned long tx_bytes ;
+ unsigned long rx_errors ;
+ unsigned long tx_errors ;
+ unsigned long rx_dropped ;
+ unsigned long tx_dropped ;
+ unsigned long multicast ;
+ unsigned long collisions ;
+ unsigned long rx_length_errors ;
+ unsigned long rx_over_errors ;
+ unsigned long rx_crc_errors ;
+ unsigned long rx_frame_errors ;
+ unsigned long rx_fifo_errors ;
+ unsigned long rx_missed_errors ;
+ unsigned long tx_aborted_errors ;
+ unsigned long tx_carrier_errors ;
+ unsigned long tx_fifo_errors ;
+ unsigned long tx_heartbeat_errors ;
+ unsigned long tx_window_errors ;
+ unsigned long rx_compressed ;
+ unsigned long tx_compressed ;
+};
+struct sk_buff_head {
+ struct sk_buff *next ;
+ struct sk_buff *prev ;
+ __u32 qlen ;
+ spinlock_t lock ;
+};
+union __anonunion_h_130 {
+ struct tcphdr *th ;
+ struct udphdr *uh ;
+ struct icmphdr *icmph ;
+ struct igmphdr *igmph ;
+ struct iphdr *ipiph ;
+ struct spxhdr *spxh ;
+ unsigned char *raw ;
+};
+union __anonunion_nh_131 {
+ struct iphdr *iph ;
+ struct ipv6hdr *ipv6h ;
+ struct arphdr *arph ;
+ struct ipxhdr *ipxh ;
+ unsigned char *raw ;
+};
+union __anonunion_mac_132 {
+ struct ethhdr *ethernet ;
+ unsigned char *raw ;
+};
+struct sk_buff {
+ struct sk_buff *next ;
+ struct sk_buff *prev ;
+ struct sk_buff_head *list ;
+ struct sock *sk ;
+ struct timeval stamp ;
+ struct net_device *dev ;
+ union __anonunion_h_130 h ;
+ union __anonunion_nh_131 nh ;
+ union __anonunion_mac_132 mac ;
+ struct dst_entry *dst ;
+ char cb[48] ;
+ unsigned int len ;
+ unsigned int data_len ;
+ unsigned int csum ;
+ unsigned char __unused ;
+ unsigned char cloned ;
+ unsigned char pkt_type ;
+ unsigned char ip_summed ;
+ __u32 priority ;
+ atomic_t users ;
+ unsigned short protocol ;
+ unsigned short security ;
+ unsigned int truesize ;
+ unsigned char *head ;
+ unsigned char *data ;
+ unsigned char *tail ;
+ unsigned char *end ;
+ void (*destructor)(struct sk_buff * ) ;
+};
+typedef struct kmem_cache_s kmem_cache_t;
+struct dev_mc_list {
+ struct dev_mc_list *next ;
+ __u8 dmi_addr[7] ;
+ unsigned char dmi_addrlen ;
+ int dmi_users ;
+ int dmi_gusers ;
+};
+struct hh_cache {
+ struct hh_cache *hh_next ;
+ atomic_t hh_refcnt ;
+ unsigned short hh_type ;
+ int hh_len ;
+ int (*hh_output)(struct sk_buff *skb ) ;
+ rwlock_t hh_lock ;
+ unsigned long hh_data[(int )(16U / sizeof(unsigned long ))] ;
+};
+struct net_device {
+ char name[16] ;
+ unsigned long rmem_end ;
+ unsigned long rmem_start ;
+ unsigned long mem_end ;
+ unsigned long mem_start ;
+ unsigned long base_addr ;
+ unsigned int irq ;
+ unsigned char if_port ;
+ unsigned char dma ;
+ unsigned long state ;
+ struct net_device *next ;
+ int (*init)(struct net_device *dev ) ;
+ struct net_device *next_sched ;
+ int ifindex ;
+ int iflink ;
+ struct net_device_stats *(*get_stats)(struct net_device *dev ) ;
+ struct iw_statistics *(*get_wireless_stats)(struct net_device *dev ) ;
+ unsigned long trans_start ;
+ unsigned long last_rx ;
+ unsigned short flags ;
+ unsigned short gflags ;
+ unsigned int mtu ;
+ unsigned short type ;
+ unsigned short hard_header_len ;
+ void *priv ;
+ struct net_device *master ;
+ unsigned char broadcast[7] ;
+ unsigned char pad ;
+ unsigned char dev_addr[7] ;
+ unsigned char addr_len ;
+ struct dev_mc_list *mc_list ;
+ int mc_count ;
+ int promiscuity ;
+ int allmulti ;
+ int watchdog_timeo ;
+ struct timer_list watchdog_timer ;
+ void *atalk_ptr ;
+ void *ip_ptr ;
+ void *dn_ptr ;
+ void *ip6_ptr ;
+ void *ec_ptr ;
+ struct Qdisc *qdisc ;
+ struct Qdisc *qdisc_sleeping ;
+ struct Qdisc *qdisc_list ;
+ struct Qdisc *qdisc_ingress ;
+ unsigned long tx_queue_len ;
+ spinlock_t xmit_lock ;
+ int xmit_lock_owner ;
+ spinlock_t queue_lock ;
+ atomic_t refcnt ;
+ int deadbeaf ;
+ int features ;
+ void (*uninit)(struct net_device *dev ) ;
+ void (*destructor)(struct net_device *dev ) ;
+ int (*open)(struct net_device *dev ) ;
+ int (*stop)(struct net_device *dev ) ;
+ int (*hard_start_xmit)(struct sk_buff *skb , struct net_device *dev ) ;
+ int (*hard_header)(struct sk_buff *skb , struct net_device *dev ,
+ unsigned short type , void *daddr , void *saddr ,
+ unsigned int len ) ;
+ int (*rebuild_header)(struct sk_buff *skb ) ;
+ void (*set_multicast_list)(struct net_device *dev ) ;
+ int (*set_mac_address)(struct net_device *dev , void *addr ) ;
+ int (*do_ioctl)(struct net_device *dev , struct ifreq *ifr , int cmd ) ;
+ int (*set_config)(struct net_device *dev , struct ifmap *map ) ;
+ int (*hard_header_cache)(struct neighbour *neigh , struct hh_cache *hh ) ;
+ void (*header_cache_update)(struct hh_cache *hh , struct net_device *dev ,
+ unsigned char *haddr ) ;
+ int (*change_mtu)(struct net_device *dev , int new_mtu ) ;
+ void (*tx_timeout)(struct net_device *dev ) ;
+ int (*hard_header_parse)(struct sk_buff *skb , unsigned char *haddr ) ;
+ int (*neigh_setup)(struct net_device *dev , struct neigh_parms * ) ;
+ int (*accept_fastpath)(struct net_device * , struct dst_entry * ) ;
+ struct module *owner ;
+ struct net_bridge_port *br_port ;
+};
+struct rtattr {
+ unsigned short rta_len ;
+ unsigned short rta_type ;
+};
+struct tcmsg {
+ unsigned char tcm_family ;
+ unsigned char tcm__pad1 ;
+ unsigned short tcm__pad2 ;
+ int tcm_ifindex ;
+ __u32 tcm_handle ;
+ __u32 tcm_parent ;
+ __u32 tcm_info ;
+};
+struct __anonstruct_echo_140 {
+ __u16 id ;
+ __u16 sequence ;
+};
+struct __anonstruct_frag_141 {
+ __u16 __unused ;
+ __u16 mtu ;
+};
+union __anonunion_un_139 {
+ struct __anonstruct_echo_140 echo ;
+ __u32 gateway ;
+ struct __anonstruct_frag_141 frag ;
+};
+struct icmphdr {
+ __u8 type ;
+ __u8 code ;
+ __u16 checksum ;
+ union __anonunion_un_139 un ;
+};
+struct icmp_filter {
+ __u32 data ;
+};
+struct tcphdr {
+ __u16 source ;
+ __u16 dest ;
+ __u32 seq ;
+ __u32 ack_seq ;
+ __u16 res1 : 4 ;
+ __u16 doff : 4 ;
+ __u16 fin : 1 ;
+ __u16 syn : 1 ;
+ __u16 rst : 1 ;
+ __u16 psh : 1 ;
+ __u16 ack : 1 ;
+ __u16 urg : 1 ;
+ __u16 ece : 1 ;
+ __u16 cwr : 1 ;
+ __u16 window ;
+ __u16 check ;
+ __u16 urg_ptr ;
+};
+struct neigh_parms {
+ struct neigh_parms *next ;
+ int (*neigh_setup)(struct neighbour * ) ;
+ struct neigh_table *tbl ;
+ int entries ;
+ void *priv ;
+ void *sysctl_table ;
+ int base_reachable_time ;
+ int retrans_time ;
+ int gc_staletime ;
+ int reachable_time ;
+ int delay_probe_time ;
+ int queue_len ;
+ int ucast_probes ;
+ int app_probes ;
+ int mcast_probes ;
+ int anycast_delay ;
+ int proxy_delay ;
+ int proxy_qlen ;
+ int locktime ;
+};
+struct neigh_statistics {
+ unsigned long allocs ;
+ unsigned long res_failed ;
+ unsigned long rcv_probes_mcast ;
+ unsigned long rcv_probes_ucast ;
+};
+struct neighbour {
+ struct neighbour *next ;
+ struct neigh_table *tbl ;
+ struct neigh_parms *parms ;
+ struct net_device *dev ;
+ unsigned long used ;
+ unsigned long confirmed ;
+ unsigned long updated ;
+ __u8 flags ;
+ __u8 nud_state ;
+ __u8 type ;
+ __u8 dead ;
+ atomic_t probes ;
+ rwlock_t lock ;
+ unsigned char ha[(int )(((7U + sizeof(unsigned long )) - 1U) &
+ ~ (sizeof(unsigned long ) - 1U))] ;
+ struct hh_cache *hh ;
+ atomic_t refcnt ;
+ int (*output)(struct sk_buff *skb ) ;
+ struct sk_buff_head arp_queue ;
+ struct timer_list timer ;
+ struct neigh_ops *ops ;
+ u8 primary_key[0] ;
+};
+struct neigh_ops {
+ int family ;
+ void (*destructor)(struct neighbour * ) ;
+ void (*solicit)(struct neighbour * , struct sk_buff * ) ;
+ void (*error_report)(struct neighbour * , struct sk_buff * ) ;
+ int (*output)(struct sk_buff * ) ;
+ int (*connected_output)(struct sk_buff * ) ;
+ int (*hh_output)(struct sk_buff * ) ;
+ int (*queue_xmit)(struct sk_buff * ) ;
+};
+struct pneigh_entry {
+ struct pneigh_entry *next ;
+ struct net_device *dev ;
+ u8 key[0] ;
+};
+struct neigh_table {
+ struct neigh_table *next ;
+ int family ;
+ int entry_size ;
+ int key_len ;
+ __u32 (*hash)(void const *pkey , struct net_device const * ) ;
+ int (*constructor)(struct neighbour * ) ;
+ int (*pconstructor)(struct pneigh_entry * ) ;
+ void (*pdestructor)(struct pneigh_entry * ) ;
+ void (*proxy_redo)(struct sk_buff *skb ) ;
+ char *id ;
+ struct neigh_parms parms ;
+ int gc_interval ;
+ int gc_thresh1 ;
+ int gc_thresh2 ;
+ int gc_thresh3 ;
+ unsigned long last_flush ;
+ struct timer_list gc_timer ;
+ struct timer_list proxy_timer ;
+ struct sk_buff_head proxy_queue ;
+ int entries ;
+ rwlock_t lock ;
+ unsigned long last_rand ;
+ struct neigh_parms *parms_list ;
+ kmem_cache_t *kmem_cachep ;
+ struct tasklet_struct gc_task ;
+ struct neigh_statistics stats ;
+ struct neighbour *hash_buckets[32] ;
+ struct pneigh_entry *phash_buckets[16] ;
+};
+struct dst_entry {
+ struct dst_entry *next ;
+ atomic_t __refcnt ;
+ int __use ;
+ struct net_device *dev ;
+ int obsolete ;
+ int flags ;
+ unsigned long lastuse ;
+ unsigned long expires ;
+ unsigned int mxlock ;
+ unsigned int pmtu ;
+ unsigned int window ;
+ unsigned int rtt ;
+ unsigned int rttvar ;
+ unsigned int ssthresh ;
+ unsigned int cwnd ;
+ unsigned int advmss ;
+ unsigned int reordering ;
+ unsigned long rate_last ;
+ unsigned long rate_tokens ;
+ int error ;
+ struct neighbour *neighbour ;
+ struct hh_cache *hh ;
+ int (*input)(struct sk_buff * ) ;
+ int (*output)(struct sk_buff * ) ;
+ struct dst_ops *ops ;
+ char info[0] ;
+};
+struct dst_ops {
+ unsigned short family ;
+ unsigned short protocol ;
+ unsigned int gc_thresh ;
+ int (*gc)(void) ;
+ struct dst_entry *(*check)(struct dst_entry * , __u32 cookie ) ;
+ struct dst_entry *(*reroute)(struct dst_entry * , struct sk_buff * ) ;
+ void (*destroy)(struct dst_entry * ) ;
+ struct dst_entry *(*negative_advice)(struct dst_entry * ) ;
+ void (*link_failure)(struct sk_buff * ) ;
+ int entry_size ;
+ atomic_t entries ;
+ kmem_cache_t *kmem_cachep ;
+};
+struct unix_opt {
+ struct unix_address *addr ;
+ struct dentry *dentry ;
+ struct vfsmount *mnt ;
+ struct semaphore readsem ;
+ struct sock *other ;
+ struct sock **list ;
+ struct sock *gc_tree ;
+ atomic_t inflight ;
+ rwlock_t lock ;
+ wait_queue_head_t peer_wait ;
+};
+struct raw_opt {
+ struct icmp_filter filter ;
+};
+struct inet_opt {
+ int ttl ;
+ int tos ;
+ unsigned int cmsg_flags ;
+ struct ip_options *opt ;
+ unsigned char hdrincl ;
+ __u8 mc_ttl ;
+ __u8 mc_loop ;
+ unsigned int recverr : 1 ;
+ unsigned int freebind : 1 ;
+ __u16 id ;
+ __u8 pmtudisc ;
+ int mc_index ;
+ __u32 mc_addr ;
+ struct ip_mc_socklist *mc_list ;
+};
+struct tcp_sack_block {
+ __u32 start_seq ;
+ __u32 end_seq ;
+};
+struct __anonstruct_ack_146 {
+ __u8 pending ;
+ __u8 quick ;
+ __u8 pingpong ;
+ __u8 blocked ;
+ __u32 ato ;
+ unsigned long timeout ;
+ __u32 lrcvtime ;
+ __u16 last_seg_size ;
+ __u16 rcv_mss ;
+};
+struct __anonstruct_ucopy_147 {
+ struct sk_buff_head prequeue ;
+ int memory ;
+ struct task_struct *task ;
+ struct iovec *iov ;
+ int len ;
+};
+struct tcp_opt {
+ int tcp_header_len ;
+ __u32 pred_flags ;
+ __u32 rcv_nxt ;
+ __u32 snd_nxt ;
+ __u32 snd_una ;
+ __u32 snd_sml ;
+ __u32 rcv_tstamp ;
+ __u32 lsndtime ;
+ struct __anonstruct_ack_146 ack ;
+ struct __anonstruct_ucopy_147 ucopy ;
+ __u32 snd_wl1 ;
+ __u32 snd_wnd ;
+ __u32 max_window ;
+ __u32 pmtu_cookie ;
+ __u16 mss_cache ;
+ __u16 mss_clamp ;
+ __u16 ext_header_len ;
+ __u8 ca_state ;
+ __u8 retransmits ;
+ __u8 reordering ;
+ __u8 queue_shrunk ;
+ __u8 defer_accept ;
+ __u8 backoff ;
+ __u32 srtt ;
+ __u32 mdev ;
+ __u32 mdev_max ;
+ __u32 rttvar ;
+ __u32 rtt_seq ;
+ __u32 rto ;
+ __u32 packets_out ;
+ __u32 left_out ;
+ __u32 retrans_out ;
+ __u32 snd_ssthresh ;
+ __u32 snd_cwnd ;
+ __u16 snd_cwnd_cnt ;
+ __u16 snd_cwnd_clamp ;
+ __u32 snd_cwnd_used ;
+ __u32 snd_cwnd_stamp ;
+ unsigned long timeout ;
+ struct timer_list retransmit_timer ;
+ struct timer_list delack_timer ;
+ struct sk_buff_head out_of_order_queue ;
+ struct tcp_func *af_specific ;
+ struct sk_buff *send_head ;
+ struct page *sndmsg_page ;
+ u32 sndmsg_off ;
+ __u32 rcv_wnd ;
+ __u32 rcv_wup ;
+ __u32 write_seq ;
+ __u32 pushed_seq ;
+ __u32 copied_seq ;
+ char tstamp_ok ;
+ char wscale_ok ;
+ char sack_ok ;
+ char saw_tstamp ;
+ __u8 snd_wscale ;
+ __u8 rcv_wscale ;
+ __u8 nonagle ;
+ __u8 keepalive_probes ;
+ __u32 rcv_tsval ;
+ __u32 rcv_tsecr ;
+ __u32 ts_recent ;
+ long ts_recent_stamp ;
+ __u16 user_mss ;
+ __u8 dsack ;
+ __u8 eff_sacks ;
+ struct tcp_sack_block duplicate_sack[1] ;
+ struct tcp_sack_block selective_acks[4] ;
+ __u32 window_clamp ;
+ __u32 rcv_ssthresh ;
+ __u8 probes_out ;
+ __u8 num_sacks ;
+ __u16 advmss ;
+ __u8 syn_retries ;
+ __u8 ecn_flags ;
+ __u16 prior_ssthresh ;
+ __u32 lost_out ;
+ __u32 sacked_out ;
+ __u32 fackets_out ;
+ __u32 high_seq ;
+ __u32 retrans_stamp ;
+ __u32 undo_marker ;
+ int undo_retrans ;
+ __u32 urg_seq ;
+ __u16 urg_data ;
+ __u8 pending ;
+ __u8 urg_mode ;
+ __u32 snd_up ;
+ rwlock_t syn_wait_lock ;
+ struct tcp_listen_opt *listen_opt ;
+ struct open_request *accept_queue ;
+ struct open_request *accept_queue_tail ;
+ int write_pending ;
+ unsigned int keepalive_time ;
+ unsigned int keepalive_intvl ;
+ int linger2 ;
+};
+struct __anonstruct_socket_lock_t_148 {
+ spinlock_t slock ;
+ unsigned int users ;
+ wait_queue_head_t wq ;
+};
+typedef struct __anonstruct_socket_lock_t_148 socket_lock_t;
+struct __anonstruct_backlog_149 {
+ struct sk_buff *head ;
+ struct sk_buff *tail ;
+};
+union __anonunion_tp_pinfo_150 {
+ struct tcp_opt af_tcp ;
+ struct raw_opt tp_raw4 ;
+};
+union __anonunion_protinfo_151 {
+ void *destruct_hook ;
+ struct unix_opt af_unix ;
+ struct inet_opt af_inet ;
+ struct packet_opt *af_packet ;
+};
+struct sock {
+ __u32 daddr ;
+ __u32 rcv_saddr ;
+ __u16 dport ;
+ unsigned short num ;
+ int bound_dev_if ;
+ struct sock *next ;
+ struct sock **pprev ;
+ struct sock *bind_next ;
+ struct sock **bind_pprev ;
+ unsigned char volatile state ;
+ unsigned char volatile zapped ;
+ __u16 sport ;
+ unsigned short family ;
+ unsigned char reuse ;
+ unsigned char shutdown ;
+ atomic_t refcnt ;
+ socket_lock_t lock ;
+ int rcvbuf ;
+ wait_queue_head_t *sleep ;
+ struct dst_entry *dst_cache ;
+ rwlock_t dst_lock ;
+ atomic_t rmem_alloc ;
+ struct sk_buff_head receive_queue ;
+ atomic_t wmem_alloc ;
+ struct sk_buff_head write_queue ;
+ atomic_t omem_alloc ;
+ int wmem_queued ;
+ int forward_alloc ;
+ __u32 saddr ;
+ unsigned int allocation ;
+ int sndbuf ;
+ struct sock *prev ;
+ char volatile dead ;
+ char volatile done ;
+ char volatile urginline ;
+ char volatile keepopen ;
+ char volatile linger ;
+ char volatile destroy ;
+ char volatile no_check ;
+ char volatile broadcast ;
+ char volatile bsdism ;
+ unsigned char debug ;
+ unsigned char rcvtstamp ;
+ unsigned char use_write_queue ;
+ unsigned char userlocks ;
+ int route_caps ;
+ int proc ;
+ unsigned long lingertime ;
+ int hashent ;
+ struct sock *pair ;
+ struct __anonstruct_backlog_149 backlog ;
+ rwlock_t callback_lock ;
+ struct sk_buff_head error_queue ;
+ struct proto *prot ;
+ union __anonunion_tp_pinfo_150 tp_pinfo ;
+ int err ;
+ int err_soft ;
+ unsigned short ack_backlog ;
+ unsigned short max_ack_backlog ;
+ __u32 priority ;
+ unsigned short type ;
+ unsigned char localroute ;
+ unsigned char protocol ;
+ struct ucred peercred ;
+ int rcvlowat ;
+ long rcvtimeo ;
+ long sndtimeo ;
+ union __anonunion_protinfo_151 protinfo ;
+ struct timer_list timer ;
+ struct timeval stamp ;
+ struct socket *socket ;
+ void *user_data ;
+ void (*state_change)(struct sock *sk ) ;
+ void (*data_ready)(struct sock *sk , int bytes ) ;
+ void (*write_space)(struct sock *sk ) ;
+ void (*error_report)(struct sock *sk ) ;
+ int (*backlog_rcv)(struct sock *sk , struct sk_buff *skb ) ;
+ void (*destruct)(struct sock *sk ) ;
+};
+struct __anonstruct_stats_152 {
+ int inuse ;
+ u8 __pad[(int )(32U - sizeof(int ))] ;
+};
+struct proto {
+ void (*close)(struct sock *sk , long timeout ) ;
+ int (*connect)(struct sock *sk , struct sockaddr *uaddr , int addr_len ) ;
+ int (*disconnect)(struct sock *sk , int flags ) ;
+ struct sock *(*accept)(struct sock *sk , int flags , int *err ) ;
+ int (*ioctl)(struct sock *sk , int cmd , unsigned long arg ) ;
+ int (*init)(struct sock *sk ) ;
+ int (*destroy)(struct sock *sk ) ;
+ void (*shutdown)(struct sock *sk , int how ) ;
+ int (*setsockopt)(struct sock *sk , int level , int optname ,
+ char *optval , int optlen ) ;
+ int (*getsockopt)(struct sock *sk , int level , int optname ,
+ char *optval , int *option ) ;
+ int (*sendmsg)(struct sock *sk , struct msghdr *msg , int len ) ;
+ int (*recvmsg)(struct sock *sk , struct msghdr *msg , int len ,
+ int noblock , int flags , int *addr_len ) ;
+ int (*bind)(struct sock *sk , struct sockaddr *uaddr , int addr_len ) ;
+ int (*backlog_rcv)(struct sock *sk , struct sk_buff *skb ) ;
+ void (*hash)(struct sock *sk ) ;
+ void (*unhash)(struct sock *sk ) ;
+ int (*get_port)(struct sock *sk , unsigned short snum ) ;
+ char name[32] ;
+ struct __anonstruct_stats_152 stats[32] ;
+};
+struct tc_stats {
+ __u64 bytes ;
+ __u32 packets ;
+ __u32 drops ;
+ __u32 overlimits ;
+ __u32 bps ;
+ __u32 pps ;
+ __u32 qlen ;
+ __u32 backlog ;
+ spinlock_t *lock ;
+};
+struct tcf_result {
+ unsigned long class ;
+ u32 classid ;
+};
+struct tcf_proto {
+ struct tcf_proto *next ;
+ void *root ;
+ int (*classify)(struct sk_buff * , struct tcf_proto * ,
+ struct tcf_result * ) ;
+ u32 protocol ;
+ u32 prio ;
+ u32 classid ;
+ struct Qdisc *q ;
+ void *data ;
+ struct tcf_proto_ops *ops ;
+};
+struct tcf_walker {
+ int stop ;
+ int skip ;
+ int count ;
+ int (*fn)(struct tcf_proto * , unsigned long node , struct tcf_walker * ) ;
+};
+struct tcf_proto_ops {
+ struct tcf_proto_ops *next ;
+ char kind[16] ;
+ int (*classify)(struct sk_buff * , struct tcf_proto * ,
+ struct tcf_result * ) ;
+ int (*init)(struct tcf_proto * ) ;
+ void (*destroy)(struct tcf_proto * ) ;
+ unsigned long (*get)(struct tcf_proto * , u32 handle ) ;
+ void (*put)(struct tcf_proto * , unsigned long ) ;
+ int (*change)(struct tcf_proto * , unsigned long , u32 handle ,
+ struct rtattr ** , unsigned long * ) ;
+ int (*delete)(struct tcf_proto * , unsigned long ) ;
+ void (*walk)(struct tcf_proto * , struct tcf_walker *arg ) ;
+ int (*dump)(struct tcf_proto * , unsigned long , struct sk_buff *skb ,
+ struct tcmsg * ) ;
+};
+struct qdisc_walker {
+ int stop ;
+ int skip ;
+ int count ;
+ int (*fn)(struct Qdisc * , unsigned long cl , struct qdisc_walker * ) ;
+};
+struct Qdisc_class_ops {
+ int (*graft)(struct Qdisc * , unsigned long cl , struct Qdisc * ,
+ struct Qdisc ** ) ;
+ struct Qdisc *(*leaf)(struct Qdisc * , unsigned long cl ) ;
+ unsigned long (*get)(struct Qdisc * , u32 classid ) ;
+ void (*put)(struct Qdisc * , unsigned long ) ;
+ int (*change)(struct Qdisc * , u32 , u32 , struct rtattr ** ,
+ unsigned long * ) ;
+ int (*delete)(struct Qdisc * , unsigned long ) ;
+ void (*walk)(struct Qdisc * , struct qdisc_walker *arg ) ;
+ struct tcf_proto **(*tcf_chain)(struct Qdisc * , unsigned long ) ;
+ unsigned long (*bind_tcf)(struct Qdisc * , unsigned long , u32 classid ) ;
+ void (*unbind_tcf)(struct Qdisc * , unsigned long ) ;
+ int (*dump)(struct Qdisc * , unsigned long , struct sk_buff *skb ,
+ struct tcmsg * ) ;
+};
+struct Qdisc_ops {
+ struct Qdisc_ops *next ;
+ struct Qdisc_class_ops *cl_ops ;
+ char id[16] ;
+ int priv_size ;
+ int (*enqueue)(struct sk_buff * , struct Qdisc * ) ;
+ struct sk_buff *(*dequeue)(struct Qdisc * ) ;
+ int (*requeue)(struct sk_buff * , struct Qdisc * ) ;
+ int (*drop)(struct Qdisc * ) ;
+ int (*init)(struct Qdisc * , struct rtattr *arg ) ;
+ void (*reset)(struct Qdisc * ) ;
+ void (*destroy)(struct Qdisc * ) ;
+ int (*change)(struct Qdisc * , struct rtattr *arg ) ;
+ int (*dump)(struct Qdisc * , struct sk_buff * ) ;
+};
+struct Qdisc {
+ int (*enqueue)(struct sk_buff *skb , struct Qdisc *dev ) ;
+ struct sk_buff *(*dequeue)(struct Qdisc *dev ) ;
+ unsigned int flags ;
+ struct Qdisc_ops *ops ;
+ struct Qdisc *next ;
+ u32 handle ;
+ atomic_t refcnt ;
+ struct sk_buff_head q ;
+ struct net_device *dev ;
+ struct tc_stats stats ;
+ int (*reshape_fail)(struct sk_buff *skb , struct Qdisc *q ) ;
+ struct Qdisc *__parent ;
+ char data[0] ;
+};
+/* #pragma cilnoremove("noop_qdisc") */
+struct semaphore;
+extern int ( /* format attribute */ __attribute__((__regparm__(0))) printk)(char const *fmt
+ , ...) ;
+__inline static int atomic_dec_and_test(atomic_t *v )
+{ unsigned char c ;
+
+ {
+ __asm__ volatile ("lock ; "
+ "decl %0; sete %1": "=m" (v->counter),
+ "=qm" (c): "m" (v->counter): "memory");
+ return ((int )c != 0);
+}
+}
+struct task_struct;
+struct mm_struct;
+struct poll_table_struct;
+struct scm_cookie;
+struct vm_area_struct;
+struct page;
+extern int net_ratelimit(void) ;
+struct zone_struct;
+struct poll_table_struct;
+struct task_struct;
+struct rw_semaphore;
+struct ntfs_attribute;
+struct ntfs_sb_info;
+struct reiserfs_page_list;
+struct usb_device;
+struct usb_bus;
+struct page;
+struct address_space;
+struct hfs_name;
+struct adfs_discmap;
+struct adfs_dir_ops;
+struct reiserfs_page_list;
+struct task_struct;
+struct siginfo;
+struct pglist_data;
+struct bootmem_data;
+struct page;
+struct sk_buff;
+extern void __kfree_skb(struct sk_buff *skb ) ;
+__inline static void kfree_skb(struct sk_buff *skb )
+{ int tmp ;
+
+ {
+ if (skb->users.counter == 1) {
+ __kfree_skb(skb);
+ } else {
+ tmp = atomic_dec_and_test(& skb->users);
+ if (tmp) {
+ __kfree_skb(skb);
+ }
+ }
+ return;
+}
+}
+struct neighbour;
+struct neigh_parms;
+struct sk_buff;
+struct sk_buff;
+struct rtattr;
+struct tcmsg;
+struct rtattr;
+struct Qdisc;
+struct Qdisc noop_qdisc ;
+struct Qdisc_ops noop_qdisc_ops ;
+static int noop_enqueue(struct sk_buff *skb , struct Qdisc *qdisc )
+{
+
+ {
+ kfree_skb(skb);
+ return (2);
+}
+}
+static struct sk_buff *noop_dequeue(struct Qdisc *qdisc )
+{
+
+ {
+ return ((struct sk_buff *)((void *)0));
+}
+}
+static int noop_requeue(struct sk_buff *skb , struct Qdisc *qdisc )
+{ int tmp ;
+
+ {
+ tmp = net_ratelimit();
+ if (tmp) {
+ printk((char const *)"<7>%s deferred output. It is buggy.\n",
+ (skb->dev)->name);
+ }
+ kfree_skb(skb);
+ return (2);
+}
+}
+struct Qdisc_ops noop_qdisc_ops = {(struct Qdisc_ops *)((void *)0),
+ (struct Qdisc_class_ops *)((void *)0),
+ {'n', 'o', 'o', 'p', '\0', 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0}, 0, & noop_enqueue,
+ & noop_dequeue, & noop_requeue,
+ (int (*)(struct Qdisc * ))0,
+ (int (*)(struct Qdisc * ,
+ struct rtattr *arg ))0,
+ (void (*)(struct Qdisc * ))0,
+ (void (*)(struct Qdisc * ))0,
+ (int (*)(struct Qdisc * ,
+ struct rtattr *arg ))0,
+ (int (*)(struct Qdisc * ,
+ struct sk_buff * ))0};
+struct Qdisc noop_qdisc = {& noop_enqueue, & noop_dequeue, (unsigned int )1,
+ & noop_qdisc_ops, (struct Qdisc *)0, 0U,
+ {.counter = 0}, {(struct sk_buff *)0,
+ (struct sk_buff *)0, 0U,
+ {.lock = 0U}},
+ (struct net_device *)0,
+ {0ULL, 0U, 0U, 0U, 0U, 0U, 0U, 0U,
+ (spinlock_t *)0}, (int (*)(struct sk_buff *skb ,
+ struct Qdisc *q ))0,
+ (struct Qdisc *)0, {}};
--- /dev/null
+#include <stdlib.h>
+#include <stdio.h>
+
+
+typedef struct list {
+ void * car;
+ struct list * cdr;
+} LIST, * PLIST ;
+
+
+PLIST prepend(PLIST l, void * el) {
+ PLIST n = (PLIST)malloc(sizeof(LIST));
+ n->car = el;
+ n->cdr = l;
+ return n;
+}
+
+
+PLIST append(PLIST l, void * el) {
+ PLIST parent = 0;
+ PLIST n = l;
+ while(n) {
+ parent = n;
+ n = n->cdr;
+ }
+ n = (PLIST)malloc(sizeof(LIST));
+ n->car = el;
+ n->cdr = 0;
+ if(parent) {
+ parent->cdr = n;
+ return l;
+ } else {
+ return n;
+ }
+}
+
+
+PLIST insert(PLIST l, void * el, int pos) {
+ PLIST n = l;
+ PLIST t;
+ if(l) {
+ while(n->cdr && pos > 0) {
+ n = n->cdr;
+ }
+ }
+ t = (PLIST)malloc(sizeof(LIST));
+ if(! l) {
+ t->cdr = NULL;
+ return t;
+ } else {
+ t->cdr = n->cdr;
+ n->cdr = t;
+ return l;
+ }
+}
+
+int exists(PLIST l, void * el) {
+ while(l && l->car != el) {
+ l= l->cdr;
+ /* WEIMER: this increment is an error! */
+ /* l ++; */
+ }
+ return (l != 0);
+}
+
+int length(PLIST l) {
+ int len = 0;
+ while(l) {
+ len ++;
+ l = l->cdr;
+ }
+ return len;
+}
+
+int main() {
+
+ int i;
+ PLIST l = NULL;
+ double clk = 0.0;
+ int sum = 0;
+ int k;
+// TIMESTART(clk);
+ for(i=1;i<1000;i++) {
+ k = random() % 1000;
+ if(length(l) & 1) {
+ l = insert(l, (void* )k, k % i);
+ } else {
+ l = append(l, (void* )k);
+ }
+ }
+ for(i=0;i<10000;i++) {
+ k = random() % 1000;
+ if(exists(l, (void* )k))
+ sum ++;
+ }
+// TIMESTOP(clk);
+ printf("Ran the test %d times in %8.3lfms. Length is %d. Success %d times.\n",
+ i, clk / 1000.0, length(l), sizeof(char*), sum);
+
+ return 0;
+}
--- /dev/null
+
+typedef struct node {
+ struct node *xl_cdr; /* the cdr pointer */
+} NODE;
+
+
+NODE *** xlstack;
+
+#define rplacd(x,y) ((x)->xl_cdr = (y))
+
+
+/* bquote1 - back quote helper function */
+NODE *bquote1(NODE *expr)
+{
+ NODE ***oldstk;
+ expr->xl_cdr = bquote1(expr->xl_cdr);
+ xlstack = oldstk;
+ return (expr);
+}
+
--- /dev/null
+/* xlisp - a small subset of lisp */
+/* Copyright (c) 1985, by David Michael Betz
+ All Rights Reserved
+ Permission is granted for unrestricted non-commercial use */
+
+/* system specific definitions */
+/* #define unix */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <ctype.h>
+#include <setjmp.h>
+
+/* WES */
+#include <string.h>
+
+/* sm: let "make clean build" not choke on __HEAPIFY */
+#ifndef __HEAPIFY
+ #define __HEAPIFY
+#endif
+
+/* NNODES number of nodes to allocate in each request (1000) */
+/* TDEPTH trace stack depth (500) */
+/* EDEPTH evaluation stack depth (1000) */
+/* FORWARD type of a forward declaration () */
+/* LOCAL type of a local function (static) */
+/* AFMT printf format for addresses ("%x") */
+/* FIXNUM data type for fixed point numbers (long) */
+/* ITYPE fixed point input conversion routine type (long atol()) */
+/* ICNV fixed point input conversion routine (atol) */
+/* IFMT printf format for fixed point numbers ("%ld") */
+/* FLONUM data type for floating point numbers (float) */
+/* SYSTEM enable the control-d command */
+
+/* absolute value macros */
+#ifndef abs
+#define abs(n) ((n) < 0 ? -(n) : (n))
+#endif
+#ifndef fabs
+#define fabs(n) ((n) < 0.0 ? -(n) : (n))
+#endif
+
+
+/* default important definitions */
+#define NNODES 1000
+#define TDEPTH 500
+#define EDEPTH 1000
+
+#ifndef FORWARD
+#define FORWARD
+#endif
+#ifndef LOCAL
+#define LOCAL static
+#endif
+#ifndef AFMT
+#define AFMT "%x"
+#endif
+#ifndef FIXNUM
+#define FIXNUM long
+#endif
+#ifndef ITYPE
+#define ITYPE long atol()
+#endif
+#ifndef ICNV
+#define ICNV(n) atol(n)
+#endif
+#ifndef IFMT
+#define IFMT "%ld"
+#endif
+#ifndef FLONUM
+#define FLONUM float
+#endif
+
+/* useful definitions */
+#define TRUE 1
+#define FALSE 0
+#ifndef NIL
+#define NIL (NODE *)0
+#endif
+
+/* program limits */
+#define STRMAX 100 /* maximum length of a string constant */
+#define HSIZE 199 /* symbol hash table size */
+#define SAMPLE 100 /* control character sample rate */
+
+/* node types */
+#define FREE 0
+#define SUBR 1
+#define FSUBR 2
+#define LIST 3
+#define SYM 4
+#define INT 5
+#define STR 6
+#define OBJ 7
+#define FPTR 8
+#define FLOAT 9
+#define VECT 10
+
+/* node flags */
+#define MARK 1
+#define LEFT 2
+
+/* string types */
+#define DYNAMIC 0
+#define STATIC 1
+
+/* new node access macros */
+#define ntype(x) ((x)->n_type)
+
+/* type predicates */
+#define atom(x) ((x) == NIL || (x)->n_type != LIST)
+#define null(x) ((x) == NIL)
+#define listp(x) ((x) == NIL || (x)->n_type == LIST)
+#define consp(x) ((x) && (x)->n_type == LIST)
+#define subrp(x) ((x) && (x)->n_type == SUBR)
+#define fsubrp(x) ((x) && (x)->n_type == FSUBR)
+#define stringp(x) ((x) && (x)->n_type == STR)
+#define symbolp(x) ((x) && (x)->n_type == SYM)
+#define filep(x) ((x) && (x)->n_type == FPTR)
+#define objectp(x) ((x) && (x)->n_type == OBJ)
+#define fixp(x) ((x) && (x)->n_type == INT)
+#define floatp(x) ((x) && (x)->n_type == FLOAT)
+#define vectorp(x) ((x) && (x)->n_type == VECT)
+
+/* cons access macros */
+#define car(x) ((x)->n_car)
+#define cdr(x) ((x)->n_cdr)
+#define rplaca(x,y) ((x)->n_car = (y))
+#define rplacd(x,y) ((x)->n_cdr = (y))
+
+/* symbol access macros */
+#define getvalue(x) ((x)->n_symvalue)
+#define setvalue(x,v) ((x)->n_symvalue = (v))
+#define getplist(x) ((x)->n_symplist->n_cdr)
+#define setplist(x,v) ((x)->n_symplist->n_cdr = (v))
+#define getpname(x) ((x)->n_symplist->n_car)
+
+/* vector access macros */
+#define getsize(x) ((x)->n_vsize)
+#define getelement(x,i) ((x)->n_vdata[i])
+#define setelement(x,i,v) ((x)->n_vdata[i] = (v))
+
+/* object access macros */
+#define getclass(x) ((x)->n_vdata[0])
+#define getivar(x,i) ((x)->n_vdata[i+1])
+#define setivar(x,i,v) ((x)->n_vdata[i+1] = (v))
+
+/* subr/fsubr access macros */
+#define getsubr(x) ((x)->n_subr)
+
+/* fixnum/flonum access macros */
+#define getfixnum(x) ((x)->n_int)
+#define getflonum(x) ((x)->n_float)
+
+/* string access macros */
+#define getstring(x) ((x)->n_str)
+#define setstring(x,v) ((x)->n_str = (v))
+
+/* file access macros */
+#define getfile(x) ((x)->n_fp)
+#define setfile(x,v) ((x)->n_fp = (v))
+#define getsavech(x) ((x)->n_savech)
+#define setsavech(x,v) ((x)->n_savech = (v))
+
+/* symbol node */
+#define n_symplist n_info.n_xsym.xsy_plist
+#define n_symvalue n_info.n_xsym.xsy_value
+
+/* subr/fsubr node */
+#define n_subr n_info.n_xsubr.xsu_subr
+
+/* list node */
+#define n_car n_info.n_xlist.xl_car
+#define n_cdr n_info.n_xlist.xl_cdr
+
+/* integer node */
+#define n_int n_info.n_xint.xi_int
+
+/* float node */
+#define n_float n_info.n_xfloat.xf_float
+
+/* string node */
+#define n_str n_info.n_xstr.xst_str
+#define n_strtype n_info.n_xstr.xst_type
+
+/* file pointer node */
+#define n_fp n_info.n_xfptr.xf_fp
+#define n_savech n_info.n_xfptr.xf_savech
+
+/* vector/object node */
+#define n_vsize n_info.n_xvect.xv_size
+#define n_vdata n_info.n_xvect.xv_data
+
+#ifdef CCURED_MODIFICATIONS
+// modified definition that makes the union less scary
+/* node structure */
+typedef struct node {
+ char n_type; /* type of node */
+ char n_flags; /* flag bits */
+
+ struct {
+
+ union {
+ struct xsym { /* symbol node */
+ struct node *xsy_plist; /* symbol plist - (name . plist) */
+ struct node *xsy_value; /* the current value */
+ } n_xsym;
+ struct xlist { /* list node (cons) */
+ struct node *xl_car; /* the car pointer */
+ struct node *xl_cdr; /* the cdr pointer */
+ } n_xlist;
+ } ; // transparent
+
+ struct xsubr { /* subr/fsubr node */
+ struct node *(*xsu_subr)(struct node *);
+ } n_xsubr;
+
+ struct xint { /* integer node */
+ FIXNUM xi_int; /* integer value */
+ } n_xint;
+ struct xfloat { /* float node */
+ FLONUM xf_float; /* float value */
+ } n_xfloat;
+
+ struct xstr { /* string node */
+ int xst_type; /* string type */
+ char *xst_str; /* string pointer */
+ } n_xstr;
+
+ struct xfptr { /* file pointer node */
+ FILE *xf_fp; /* the file pointer */
+ int xf_savech; /* lookahead character for input files */
+ } n_xfptr;
+
+ struct xvect { /* vector node */
+ int xv_size; /* vector size */
+ struct node **xv_data; /* vector data */
+ } n_xvect;
+
+ } n_info ;
+} NODE;
+#else
+// original definition
+typedef struct node {
+ char n_type; /* type of node */
+ char n_flags; /* flag bits */
+ union { /* value */
+ struct xsym { /* symbol node */
+ struct node *xsy_plist; /* symbol plist - (name . plist) */
+ struct node *xsy_value; /* the current value */
+ } n_xsym;
+ struct xsubr { /* subr/fsubr node */
+ /* WEIMER struct node *(*xsu_subr)(); pointer to an internal routine */
+ struct node *(*xsu_subr)(struct node *);
+ } n_xsubr;
+ struct xlist { /* list node (cons) */
+ struct node *xl_car; /* the car pointer */
+ struct node *xl_cdr; /* the cdr pointer */
+ } n_xlist;
+ struct xint { /* integer node */
+ FIXNUM xi_int; /* integer value */
+ } n_xint;
+ struct xfloat { /* float node */
+ FLONUM xf_float; /* float value */
+ } n_xfloat;
+ struct xstr { /* string node */
+ int xst_type; /* string type */
+ char *xst_str; /* string pointer */
+ } n_xstr;
+ struct xfptr { /* file pointer node */
+ FILE *xf_fp; /* the file pointer */
+ int xf_savech; /* lookahead character for input files */
+ } n_xfptr;
+ struct xvect { /* vector node */
+ int xv_size; /* vector size */
+ struct node **xv_data; /* vector data */
+ } n_xvect;
+ } n_info ;
+} NODE;
+#endif
+
+/* execution context flags */
+#define CF_GO 1
+#define CF_RETURN 2
+#define CF_THROW 4
+#define CF_ERROR 8
+#define CF_CLEANUP 16
+#define CF_CONTINUE 32
+#define CF_TOPLEVEL 64
+
+/* execution context */
+typedef struct context {
+ int c_flags; /* context type flags */
+ struct node *c_expr; /* expression (type dependant) */
+ jmp_buf c_jmpbuf; /* longjmp context */
+ struct context *c_xlcontext; /* old value of xlcontext */
+ struct node ***c_xlstack; /* old value of xlstack */
+ struct node *c_xlenv; /* old value of xlenv */
+ int c_xltrace; /* old value of xltrace */
+} CONTEXT;
+
+/* function table entry structure */
+struct fdef {
+ char *f_name; /* function name */
+ int f_type; /* function type SUBR/FSUBR */
+ //sm: struct node *(*f_fcn)(); /* function code */
+ struct node *(*f_fcn)(NODE*); /* function code */
+};
+
+/* memory segment structure definition */
+struct segment {
+ int sg_size;
+ struct segment *sg_next;
+ // sm: changing this to be an open array
+ //struct node sg_nodes[1];
+ struct node sg_nodes[0];
+};
+
+
--- /dev/null
+#include "testharness.h"
+
+int main () {
+ int x = 5;
+ x = 42; //CIL is moving this below the definition of i
+ int i = x;
+ if (i != 42) E(99);
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+int main() {
+ int x;
+ int *p = 0;
+ x = 1;
+ if(x || *p) { // Do not check p if x = 1
+ x = 0;
+ }
+ if(x && *p) { // Do not check p if x = 0
+ E(1);
+ }
+ SUCCESS;
+}
--- /dev/null
+open Cil
+
+;;
+
+initCIL ();
+
+let variable = makeGlobalVar "value" intType in
+
+let instructions = ref [] in
+for loop = 1 to 25000 do
+ let instruction = Set(var variable, integer loop, locUnknown) in
+ instructions := instruction :: !instructions
+done;
+
+let statement = mkStmt (Instr !instructions) in
+let sink = open_out "/dev/null" in
+dumpStmt defaultCilPrinter sink 0 statement
--- /dev/null
+typedef unsigned short wchar_t;
+typedef wchar_t WCHAR;
+typedef wchar_t *WCHARP;
+
+int fun_accepting_wchar(WCHARP arg) {
+ int i;
+ char * ptr = (char *)arg;
+ for (i=0;i<10;i++)
+ printf("byte %d = '%c'\n",i,ptr[i]);
+ return 0;
+}
+
+int main() {
+ fun_accepting_wchar(L"Hello, world.\n");
+ return 0;
+}
+/* Correct Output (microsoft command line compiler):
+byte 0 = 'H'
+byte 1 = ''
+byte 2 = 'e'
+byte 3 = ''
+byte 4 = 'l'
+byte 5 = ''
+byte 6 = 'l'
+byte 7 = ''
+byte 8 = 'o'
+byte 9 = ''
+*/
--- /dev/null
+#include "testharness.h"
+
+int main() {
+ int a = 0, b = 10;
+ int * pi;
+
+ // Comma expressions
+ (a++, b) ++; // a = 1, b = 11
+
+ a += b; // a = 12, b = 11
+
+ if(a != 12 || b != 11) E(1)
+
+ (a++, b) = 5; // a = 13, b = 5
+
+ if(a != 13 || b != 5) E(2)
+
+ pi = & (a, b); *pi += 4; // a = 13 , b = 9
+
+ if(a != 13 || b != 9) E(3)
+
+
+ // Conditional expressions
+
+ (a > 12 ? a : b) += 5; // a = 18, b = 9
+
+ if(a != 18 || b != 9) E(4)
+
+ (a < 16 ? b : a) = 7; // a = 7, b = 9
+
+ if(a != 7 || b != 9) E(5)
+
+ pi = & (a < 12 ? a : b); *pi += 4; // a = 11, b = 9
+
+ if(a != 11 || b != 9) E(6)
+
+ // Casts
+
+ {
+ double *pa = (double*)16;
+ double *pb;
+
+ pa += ((int)pb = 8); // pb = (double*)8; pa += (int)8
+
+ if((int)pa != 16 + 8 * sizeof(double) || (int)pb != 8) E(7)
+
+ (int)pa += 5; // pa = (int)pa + 5
+
+ if((int)pa != 16 + 8 * sizeof(double) + 5) E(8)
+ }
+
+ SUCCESS;
+ return 0;
+}
--- /dev/null
+#include "testharness.h"
+
+#include <math.h>
+
+int main() {
+ double d = HUGE_VAL;
+
+#ifdef __USE_ISOC99
+ double df = HUGE_VALF;
+ double dl = HUGE_VALL;
+#endif
+
+ SUCCESS;
+}
--- /dev/null
+typedef double real;
+
+#define DIM 3
+typedef real vector[3], matrix[DIM][DIM];
+
+
+void multiply(matrix a, matrix b) {
+ int i, j;
+ matrix c;
+
+ for(i=0;i<DIM;i++) {
+ for(j=0;j<DIM;j++) {
+ real sum = 0.0;
+ int k;
+ for(k=0;k<DIM;k++) {
+ sum += a[i][k] * b[k][j];
+ }
+ c[i][j] = sum;
+ }
+ }
+}
+
+int main() {
+ return 0;
+}
--- /dev/null
+#include "testharness.h"
+#include <string.h>
+#include <stdlib.h>
+
+typedef struct {
+ char *f1;
+ int f2;
+} T1;
+
+// char c1, c2;
+
+// T1 global1;
+T1 globarray[5];
+
+// T1 init[] = { 0, 1, &c1, 2, &c2, 3};
+
+
+//typedef struct {
+// char *w1;
+// int w2;
+//} W1;
+//
+//W1 wild1, wild2;
+//
+//int dummy;
+
+void main(void) {
+// T1 x;
+ T1 *p = (T1*)malloc(8 * sizeof(T1));
+
+// memcpy(&x, & init[1], sizeof(T1));
+// if(x.f2 != 2) {
+// exit(1);
+// }
+// if(x.f1 != (char*)&c1) {
+// exit(11);
+// }
+// memcpy(& p[2], init, 2 * sizeof(T1));
+// if(p[2].f2 != 1 || p[3].f2 != 2) {
+// exit(2);
+// }
+ memcpy(p, globarray, sizeof(globarray));
+
+// // Make wild1 wild
+// {
+// W1 *pw;
+// pw = & dummy;
+// pw = &wild1;
+// wild2.w2 = 15;
+// memcpy(pw, &wild2, sizeof(*pw));
+// if(pw->w2 != 15) {
+// exit(3);
+// }
+// }
+//
+// {
+// char * as[5];
+// char * ad[5];
+// // Make one of ad a FSEQ
+// ad[4] ++;
+// memcpy(ad, as, sizeof(as));
+// }
+ exit(0);
+}
--- /dev/null
+#include "testharness.h"
+
+//a macro from include/linux/kernel.h in the Linux kernel:
+#define min(x,y) ({ \
+ typeof(x) _x = (x); \
+ typeof(y) _y = (y); \
+ (void) (&_x == &_y); \
+ _x < _y ? _x : _y; })
+
+double global = 5.0;
+
+int main() {
+ double res = min(global-1, min(global/2, global));
+
+ if (res != 2.5) E(2);
+ SUCCESS;
+}
--- /dev/null
+
+#include "testharness.h"
+
+extern "C" {
+ int foo(void);
+
+ int bar(void) {
+ return 1;
+ }
+}
+
+extern "C" const int *global = 0;
+
+
+int main() {
+ return 0;
+}
--- /dev/null
+
+#include "testharness.h"
+
+// This must be run with Visual C. NET
+
+typedef __w64 int t1;
+typedef int __w64 t2;
+
+
+int main() {
+ t1 x = 5;
+ t2 y = 6;
+
+ return y - x - 1;
+}
--- /dev/null
+#include "testharness.h"
+
+typedef
+void
+(*PKNORMAL_ROUTINE) (
+ void* NormalContext,
+ void* SystemArgument1,
+ void* SystemArgument2
+ );
+
+typedef struct {
+ int info;
+ PKNORMAL_ROUTINE fun;
+} * PIO_STATUS_BLOCK;
+
+// Make sure we print the __stdcall properly
+typedef
+void
+(__stdcall *PIO_APC_ROUTINE) (
+ void* ApcContext,
+ PIO_STATUS_BLOCK IoStatusBlock,
+ long Reserved
+ );
+
+
+
+int __stdcall test(int x) {
+ return x;
+}
+
+PIO_APC_ROUTINE gfun = 0;
+
+int main() {
+ return 0;
+}
--- /dev/null
+#include "testharness.h"
+
+// This requires VC.NET
+
+// It does not matter where we put the declspec
+__declspec(align(16)) struct foo {
+ int x1;
+} g; // Only g is aligned
+
+
+typedef struct __declspec(align(8)) _DEVICE_OBJECT {
+ int x1;
+} DEVICE_OBJECT;
+
+
+int main() {
+ struct _DEVICE_OBJECT x; // Inherits the alignment
+ struct {
+ int a;
+ // 4 bytes Padding
+ struct _DEVICE_OBJECT x;
+ } y;
+
+ struct {
+ int a;
+ struct foo b; // No padding
+ } z;
+
+ if(sizeof(x) != 8) {
+ printf("sizeof(DEVICE_OBJECT) = %d\n", sizeof(DEVICE_OBJECT));
+ E(1);
+ }
+
+ if(sizeof(y) != 16) {
+ printf("sizeof(DEVICE_OBJECT) = %d\n", sizeof(DEVICE_OBJECT));
+ E(2);
+ }
+
+
+ if(sizeof(struct foo) != 16) {
+ printf("sizeof(foo) = %d\n", sizeof(struct foo));
+ E(3);
+ }
+
+ if(sizeof(z) != 32) {
+ printf("sizeof(z) = %d\n", sizeof(z));
+ E(4);
+ }
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+typedef struct _NDIS30_MINIPORT_CHARACTERISTICS
+{
+ int MajorNdisVersion;
+ int MinorNdisVersion;
+ int Filler;
+ int Reserved;
+ int CheckForHangHandler;
+ int DisableInterruptHandler;
+ int EnableInterruptHandler;
+ int HaltHandler;
+ int HandleInterruptHandler;
+ int InitializeHandler;
+ int ISRHandler;
+ int QueryInformationHandler;
+ int ReconfigureHandler;
+ int ResetHandler;
+ union
+ {
+ int SendHandler;
+ int WanSendHandler;
+ };
+ int SetInformationHandler;
+ union
+ {
+ int TransferDataHandler;
+ int WanTransferDataHandler;
+ };
+} NDIS30_MINIPORT_CHARACTERISTICS;
+
+typedef struct _NDIS40_MINIPORT_CHARACTERISTICS {
+ NDIS30_MINIPORT_CHARACTERISTICS;
+ int ReturnPacketHandler;
+ int SendPacketsHandler;
+ int AllocateCompleteHandler;
+
+} NDIS40_MINIPORT_CHARACTERISTICS;
+
+typedef struct _NDIS50_MINIPORT_CHARACTERISTICS
+{
+ NDIS40_MINIPORT_CHARACTERISTICS;
+
+ int CoCreateVcHandler;
+ int CoDeleteVcHandler;
+ int CoActivateVcHandler;
+ int CoDeactivateVcHandler;
+ int CoSendPacketsHandler;
+ int CoRequestHandler;
+} NDIS50_MINIPORT_CHARACTERISTICS;
+
+typedef struct _NDIS51_MINIPORT_CHARACTERISTICS {
+ NDIS50_MINIPORT_CHARACTERISTICS;
+ int CancelSendPacketsHandler;
+ int PnPEventNotifyHandler;
+ int AdapterShutdownHandler;
+ int Reserved1;
+ int Reserved2;
+ int Reserved3;
+ int Reserved4;
+} NDIS51_MINIPORT_CHARACTERISTICS;
+
+typedef struct _NDIS51_MINIPORT_CHARACTERISTICS NDIS_MINIPORT_CHARACTERISTICS;
+
+
+int main() {
+ NDIS_MINIPORT_CHARACTERISTICS m;
+
+ // Fill the object with 1,2,...
+ m.MajorNdisVersion = 1;
+ m.MinorNdisVersion = 2;
+ m.Filler = 3;
+ m.Reserved = 4;
+
+ m.CheckForHangHandler = 5;
+ m.DisableInterruptHandler = 6;
+ m.EnableInterruptHandler = 7;
+ m.HaltHandler = 8;
+ m.HandleInterruptHandler = 9;
+ m.InitializeHandler = 10;
+ m.ISRHandler = 11;
+ m.QueryInformationHandler = 12;
+ m.ReconfigureHandler = 13;
+ m.ResetHandler = 14;
+
+ m.SendHandler = 15;
+ if(m.WanSendHandler != 15) E(1);
+
+ m.SetInformationHandler = 16;
+ m.TransferDataHandler = 17;
+ if(m.WanTransferDataHandler != 17) E(2);
+
+ // These are from NDIS40
+ m.ReturnPacketHandler = 18;
+ m.SendPacketsHandler = 19;
+ m.AllocateCompleteHandler = 20;
+
+
+ // These are from NDIS50
+ m.CoCreateVcHandler = 21;
+ m.CoDeleteVcHandler = 22;
+ m.CoActivateVcHandler = 23;
+ m.CoDeactivateVcHandler = 24;
+ m.CoSendPacketsHandler = 25;
+ m.CoRequestHandler = 26;
+
+ // These are from NDIS51
+ m.CancelSendPacketsHandler = 27;
+ m.PnPEventNotifyHandler = 28;
+ m.AdapterShutdownHandler = 29;
+ m.Reserved1 = 30;
+ m.Reserved2 = 31;
+ m.Reserved3 = 32;
+ m.Reserved4 = 33;
+
+
+ // Now go and check the we have initialized properly
+ {
+ int i;
+ for(i=0;i<sizeof(m) / sizeof(int); i++) {
+ if(((int*)&m)[i] != i + 1) {
+ printf("The %dth word is %d\n", i, ((int*)&m)[i]);
+ E(3);
+ }
+ }
+ }
+ SUCCESS;
+}
--- /dev/null
+
+int main() {
+ __annotation(L"TMC:", L"f25b6b4c" L"-" L"98d9" L"-" L"41bf" L"-" L"bf48" L"-" L"36255d508a22", L"AmccS5933DK1TraceGuid" ,
+ L"RDK_TRACE_INIT" , L"RDK_TRACE_SHUTDOWN" , L"RDK_TRACE_IO");
+ __annotation(L"TMC:", L"5a08c3db" L"-" L"5c89" L"-" L"4089" L"-" L"bfdc" L"-" L"6b7b679faac3", L"AmccS5933DK1TraceGuid2" ,
+ L"RDK2_TRACE_THIS" , L"RDK2_TRACE_THAT");
+}
+
--- /dev/null
+
+typedef
+int
+(__stdcall *LPOVERLAPPED_COMPLETION_ROUTINE)(int x);
+
+
+int __stdcall AsynchRead(int x) {
+ return x + 5;
+}
+
+
+int
+__stdcall
+ReadFileEx(int x1,
+ LPOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine) {
+
+ return lpCompletionRoutine(x1) + 6;
+}
+
+
+int main() {
+ return -11 + ReadFileEx(0,
+ (int (__stdcall *)(int x))&AsynchRead);
+}
--- /dev/null
+#include "testharness.h"
+
+// It turns out that MSVC allows continuation lines
+// ... and they are not filtered by the preprocessor
+int a = \
+0;
+
+
+int main() {
+ if(__LINE__ != 10) E(1);
+
+ return a;
+}
--- /dev/null
+
+typedef struct _BUSENUM_PLUGIN_HARDWARE
+{
+ int Size;
+ #pragma warning(disable:4200) // nonstandard extension used
+ int HardwareIDs[];
+ #pragma warning(default:4200) // nonstandard extension used
+
+} BUSENUM_PLUGIN_HARDWARE, *PBUSENUM_PLUGIN_HARDWARE;
+
+typedef struct _UNICODE_STRING {
+ short Length;
+ short MaximumLength;
+ char * Buffer;
+} UNICODE_STRING;
+
+void foo() {
+ int param;
+
+ char buffer_buffer[80]; __pragma(warning(disable:4221)) __pragma(warning(disable:4204)) UNICODE_STRING buffer = { 0, 80 * sizeof(char) , buffer_buffer } __pragma(warning(default:4221)) __pragma(warning(default:4204));
+
+ (param);
+}
+
+
+#ifdef _MSVC
+typedef unsigned __int64 ULONGLONG;
+
+int
+RtlIntToULongLong(
+ int iOperand,
+ ULONGLONG* pullResult)
+{
+ int status = ((int)0xC0000095L);
+ *pullResult = (0xffffffffffffffffui64);
+
+ return status;
+}
+#endif
--- /dev/null
+#include "testharness.h"
+
+// Test the handling of no-prototype functions
+
+int main() {
+ int *x, *y;
+
+ int *res = &x; // Make res like x
+
+ res = noprotofun(&x + 1, &y);
+ // Try to read from x and y
+ if(res != &x + 1) { E(1); }
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+// Test the handling of no-prototype functions
+
+int main() {
+ int *x, *y;
+
+ int *res = &x; // Make res like x
+
+ // Call with the wrong number of arguments
+ res = noprotofun(&x);
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+// Test the handling of no-prototype functions
+
+int main() {
+ int *x, *y;
+
+ int *res = &x; // Make res like x
+
+ // Call with integers instead of pointers
+ res = noprotofun(5, 6);
+
+ SUCCESS;
+}
--- /dev/null
+void direct() __attribute__((noreturn));
+
+// Pointer to function
+void (*indirect)() __attribute__((noreturn)) = direct;
+
+// An array of pointers to functions
+void (* afun[2])() __attribute__((noreturn)) = { direct, direct };
+
+void caller()
+{
+ direct();
+ indirect();
+}
+
+
+int main() {
+ return 0;
+}
--- /dev/null
+#include <stddef.h>
+#include "testharness.h"
+
+typedef struct mystruct {
+ int a;
+ int b;
+} Mystruct;
+
+Mystruct Foo;
+
+int main() {
+ long addr_b;
+
+ addr_b = (long)&Foo;
+
+ addr_b += (long)offsetof(Mystruct, b);
+
+ if (addr_b != (long)&Foo.b) E(1);
+
+ SUCCESS;
+}
--- /dev/null
+
+struct align_short {
+ char c;
+ short a;
+};
+
+
+
+int main()
+{
+ int align_of_short;
+
+ align_of_short =
+ (((char*)&(((struct align_short *)0)->a)) - ((char*)0)) ;
+
+ return 0 ;
+}
+
--- /dev/null
+#include "testharness.h"
+#include <stddef.h>
+
+struct foo {
+ struct bar {
+ int a[8];
+ int b;
+ } f1;
+ struct baz {
+ int c[4];
+ } f2[2];
+};
+
+//Make "f2" a typedef as well as a field, and make sure that doesn't break
+// anything.
+typedef struct foo f2;
+
+int main() {
+ if(offsetof(struct foo, f1.b) != 8 * sizeof(int)) E(1);
+
+ if(offsetof(struct foo, f1.a[2]) != 2 * sizeof(int)) E(2);
+
+ if(offsetof(struct foo, f2[1].c[3])
+ != sizeof(struct bar) + sizeof(struct baz) + 3 * sizeof(int)) E(3);
+
+ if(offsetof(f2, f2) != sizeof(struct bar)) E(4);
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+#include <stddef.h>
+
+// same as offsetof2.c, but uses gcc's __builtin_offsetof
+
+struct foo {
+ struct bar {
+ int a[8];
+ int b;
+ } f1;
+ struct baz {
+ int c[4];
+ } f2[2];
+};
+
+//Make "f2" a typedef as well as a field, and make sure that doesn't break
+// anything. This was a bug for Roberto Bagnara.
+typedef struct foo f2;
+
+int main() {
+
+ // Test for gcc's __builtin_offsetof, which we handle specially
+
+ if(__builtin_offsetof(struct foo, f1.b) != 8 * sizeof(int)) E(1);
+
+ if(__builtin_offsetof(struct foo, f1.a[2]) != 2 * sizeof(int)) E(2);
+
+ if(__builtin_offsetof(f2, f2[1].c[3])
+ != sizeof(struct bar) + sizeof(struct baz) + 3 * sizeof(int)) E(3);
+
+ if(__builtin_offsetof(f2, f2) != sizeof(struct bar)) E(4);
+
+ SUCCESS;
+}
--- /dev/null
+
+// What happens if malloc returns null?
+
+#include "testharness.h"
+#include <malloc.h>
+#include <sys/resource.h>
+#include <unistd.h>
+
+struct list {
+ struct list* next;
+ int data[1024*10];
+};
+
+int main() {
+ struct list* p = 0;
+
+ // This test tries to run out of memory. To avoid annoying other users,
+ // put a 10MB limit on the memory that is allocated to this test.
+ const int heapSize = 1024*1024*10;
+ struct rlimit limit = {heapSize, heapSize};
+ int res = setrlimit(RLIMIT_DATA, &limit);
+ if (res != 0){
+ printf("***setrlimit didn't work");
+ }
+
+ while(1) {
+ //Eventually, malloc returns null. Hopefully, CCured won't try to
+ //dereference it.
+ struct list* newp = malloc(sizeof(struct list));
+ if (! newp) { break; }
+ newp->next = p;
+ p = newp;
+ }
+ SUCCESS;
+}
+
--- /dev/null
+
+int buffer[50];
+int *buffp, *buffa, *buffb, *buffc;
+int separator(int);
+int bar(int);
+int f2(int, int), f1(int);
+
+int foo(void) {
+ // Both MSVC and GCC do the ++ after the assignment !
+ *buffp = buffer[(*buffa) ++];
+ separator(1);
+ // Both MSVC and GCC do the ++ before the call to bar !
+ // buffb is incremented first in both compilers
+ *buffp = bar(buffer[(*buffa) ++] + buffer[(*buffb) ++]);
+ separator(2);
+ // The +7 must be done before the assignment
+ *buffp = buffer[(*buffa) += 7];
+ separator(3);
+ bar((*buffa) ++) + bar((*buffb) ++);
+
+ separator(4);
+ buffer[*buffp + 4] = buffer[(*buffa) ++] + f2(f1((*buffb)++), (*buffc) ++);
+
+ return *buffp;
+}
--- /dev/null
+#include <alloca.h>
+
+struct elim_table
+{
+ int foo;
+};
+
+struct elim_table reg_eliminate[5];
+
+#define NUM_ELIMINABLE_REGS (sizeof reg_eliminate / sizeof reg_eliminate[0])
+static int (*offsets_at)[NUM_ELIMINABLE_REGS];
+
+void reload2 (void)
+{
+ offsets_at =
+ (int (*)[NUM_ELIMINABLE_REGS]) alloca (NUM_ELIMINABLE_REGS);
+}
+
--- /dev/null
+
+void P();
+int x1,x2,x3;
+
+void P() {
+ if (x1>5) {
+ x1=x1+x2+1;
+ x3=x3+1;
+ P();
+ x1=x1-x2;
+ }
+}
+
+void main() {
+ x2 = x1;
+ x3=0;
+ P();
+ x1=x1-x2-x3;
+}
--- /dev/null
+#include "testharness.h"
+
+struct __attribute__ ((__packed__)) abstract_struct;
+
+typedef struct s {
+ char x1;
+ double d;
+} __attribute__ ((__packed__)) s;
+
+s foo;
+
+extern int x9[9U];
+extern int x9[sizeof(foo)];
+
+int main() {
+ printf("sizeof(foo) = %d.\n", (int)sizeof(foo));
+ if (sizeof(foo) != 9) E(1);
+ return 0;
+}
+
+
+typedef struct {
+ int x1;
+ short x2;
+ short x3;
+} __attribute__ ((__packed__)) t1;
+
+typedef struct __attribute__ ((__packed__)) {
+ int x1;
+ short x2;
+ short x3;
+} t2;
+
+typedef __attribute__ ((__packed__)) struct {
+ int x1;
+ short x2;
+ short x3;
+} t3;
+
+t1 t1_;
+t2 t2_;
+t3 t3_;
--- /dev/null
+
+//Tests for CIL's handling of the packed attribute
+
+#define offsetof(t,f) ((unsigned long)&(((t *)0)->f))
+
+
+//has size 6
+struct s1 {
+ short a;
+ char b;
+ short c;
+} ;
+//Duplicate array declarations force CIL (and gcc) to constant-fold and
+//ensure sizeof(struct s1) equals 6:
+extern int size6[6];
+extern int size6[sizeof(struct s1)];
+
+//has size 5
+struct s2 {
+ short a;
+ char b;
+ short c;
+} __attribute__((packed));
+extern int size5[5];
+extern int size5[sizeof(struct s2)];
+
+
+extern int size1[1];
+extern int size3[3];
+extern int size4[4];
+extern int size8[8];
+
+//has size 8. The packed prevents the 1 byte of padding from being added
+//before b, but doesn't prevent the byte that is added afterwards.
+struct s3 {
+ char a;
+ short b __attribute__((packed));
+ int c;
+} s3;
+extern int size8[sizeof(struct s3)];
+
+//offsetof (struct s3).b == 1
+extern int size1[offsetof(struct s3, b)];
+//offsetof (struct s3).c == 4
+extern int size4[offsetof(struct s3, c)];
+
+//has size 6. The first field has alignment 2,
+// so the whole struct has alignment 2.
+struct s4 {
+ short a;
+ char b __attribute__((packed));
+ short c __attribute__((packed));
+};
+extern int size6[sizeof(struct s4)];
+extern int size3[offsetof(struct s4, c)];
+
+//has size 5
+struct s5 {
+ short a ;
+ char b __attribute__((packed));
+ short c __attribute__((packed));
+} __attribute__((packed));
+extern int size5[sizeof(struct s5)];
+
+//has size 7. s1 has size 6, and the packed attribute here applies only to s6,
+// not transitively to s1.
+struct s6 {
+ char a ;
+ struct s1 s;
+} __attribute__((packed));
+extern int size7[7];
+extern int size7[sizeof(struct s6)];
+
+
+int main() {
+ return 0;
+}
--- /dev/null
+
+union indir {
+ int data; // always odd
+ union indir *next; // always even
+};
+
+union indir *a; // an array
+
+
+int foo() {
+ int i, acc = 0;
+ for(i=0;i<100;i++) {
+ union indir e = a[i];
+ while(e.data % 2 == 0) e = * e.next;
+ acc += (e.data >> 1);
+ }
+ return acc;
+}
--- /dev/null
+
+
+int * * a; // an array
+
+
+int foo() {
+ int i, acc = 0;
+ for(i=0;i<100; i++) {
+ int * e = a[i];
+ while((int)e % 2 == 0) e = * (int * *) e;
+ acc += ((int)e >> 1);
+ }
+ return acc;
+}
--- /dev/null
+#include <stdio.h>
+
+int main (void) {
+ char buf[10] = "abc", *str;
+ sscanf(buf, "%400", str);
+ return 0;
+}
--- /dev/null
+#include <syslog.h>
+#include <stdio.h>
+
+int main(void) {
+ syslog(LOG_ERR, "%m");
+ return 0;
+}
--- /dev/null
+void perror_1();
+
+#include <stdio.h>
+
+void perror_1 (string)
+char * string;
+{
+ char *copy = "hello";
+ perror (copy);
+}
+
+int main(int argc, char ** argv) {
+ return 0;
+}
+
+
+
+
--- /dev/null
+#if defined (HAVE_SOCKETS)
+#include <stdio.h>
+int main() {
+ printf("how did i get here?");
+}
+
+#else
+
+void perror_1();
+
+#include <stdio.h>
+
+void perror_1 (string)
+char * string;
+{
+ char *copy = "hello";
+ perror (copy);
+}
+
+int main(int argc, char ** argv) {
+ return 0;
+}
+
+#endif
+
+
--- /dev/null
+int * z1[6] __SIZED;
+void foo1(void *y) {
+ int * * p = & z1[3] ;
+
+ int * * a = p + z1[2][2];
+}
+
+extern void* malloc(unsigned int);
+
+void foo2() {
+ int * * p = (int * *)malloc(20);
+ p ++;
+ {
+ int ***q = (int***)p;
+ }
+}
--- /dev/null
+#include "testharness.h"
+
+int g;
+void testg(int x, int err) {
+ if(g != 6) E(err);
+}
+
+int main()
+{
+ int x = 7;
+
+ /*
+ * Strictly speaking, the order of increment versus assignment here
+ * is not well defined: see ANSI C standard section 6.5.2.4 [Postfix
+ * increment and decrement operators], paragraph 2. However, both
+ * GCC and VC do the assignment before the side effect. For maximum
+ * compatibility, then, the ending value of x should be 8, not 7.
+ */
+ x = x++;
+ if (x != 8) E(1);
+
+
+ // Both postincrements happen after the assignment !
+ // x == 8
+ x = x++ + x++;
+ if(x != 18) E(2);
+
+ // The postincrement happens BEFORE the function call !
+ g = 5;
+ testg(g ++, 5);
+
+ SUCCESS;
+}
--- /dev/null
+/* Generated by Frontc */
+
+typedef struct demand {
+ double P ;
+ double Q ;
+} Demand ;
+
+extern void * malloc() ;
+extern double sqrt(double);
+
+typedef struct root {
+ Demand D ;
+ double theta_R ;
+ double theta_I ;
+ Demand last ;
+ double last_theta_R ;
+ double last_theta_I ;
+ struct lateral * feeders[10] ; // Forward reference
+} * Root ;
+
+typedef struct lateral {
+ Demand D ;
+ double alpha ;
+ double beta ;
+ double R ;
+ double X ;
+ struct lateral * next_lateral ;
+ struct branch * branch ; // Forward reference
+} * Lateral ;
+
+typedef struct branch {
+ Demand D ;
+ double alpha ;
+ double beta ;
+ double R ;
+ double X ;
+ struct branch * next_branch ;
+ struct leaf * leaves[10] ; // Forward reference
+} * Branch ;
+
+typedef struct leaf {
+ Demand D ;
+ double pi_R ;
+ double pi_I ;
+} * Leaf ;
+
+void Compute_Tree(Root r ) ;
+Demand Compute_Lateral(Lateral l , double theta_R ,
+ double theta_I , double pi_R
+ , double pi_I ) ;
+Demand Compute_Branch(Branch b , double theta_R ,
+ double theta_I , double pi_R ,
+ double pi_I ) ;
+Demand Compute_Leaf(Leaf l , double pi_R , double pi_I ) ;
+
+
+static double P = 1.0;
+static double Q = 1.0;
+void optimize_node(double pi_R , double pi_I ) ;
+
+void Compute_Tree(Root r )
+{
+
+ register int i ;
+ Lateral l ;
+
+ Demand a ;
+
+ Demand tmp ;
+ double theta_R , theta_I ;
+
+ for(i = 0; i < 10; i++)
+ {
+ l = (r->feeders)[i];
+ a = Compute_Lateral(l, theta_R, theta_I, theta_R, theta_I);
+ }
+}
+
+Demand Compute_Lateral(Lateral l , double theta_R , double theta_I , double pi_R
+ , double pi_I )
+{
+ Demand a1 ;
+ Demand a2 ;
+ double new_pi_R , new_pi_I ;
+ double a , b , c , root ;
+ Lateral next ;
+ Branch br ;
+
+ next = l->next_lateral;
+ a1 = Compute_Lateral(next, theta_R, theta_I, new_pi_R, new_pi_I);
+
+ br = l->branch;
+ a2 = Compute_Branch(br, theta_R, theta_I, new_pi_R, new_pi_I);
+ return l->D;
+}
--- /dev/null
+#include <stdio.h>
+
+int main() {
+ int x = 100 ,y = 200 ,z = 300, len = 6;
+
+ char *p = "<<p>>" ,*q = "<<q>>" ,*r = "<<r>>" ;
+ char dest_buf[1024];
+ char *s1, *s2;
+
+ printf("printf: %s %ld %0.20s %x\n",p,x,q,y);
+ fprintf(stdout,"fprintf: %s %ld %0.20s %x\n",p,y,q,z);
+ sprintf(dest_buf,"sprintf: %s %ld %0.20s %x",p,z,q,x);
+ printf("printf: dest_buf = [%s]\n",dest_buf);
+
+ s1 = &dest_buf[5];
+ s2 = &s1[5];
+
+ printf("printf: chop 5: [%s]\n", s1);
+ printf("printf: chop 5 more, print %d: [%.*s]\n",len,len,s2);
+
+ printf("printf: null = %s\n",(char*)0);
+
+ return 0;
+}
--- /dev/null
+#include "testharness.h"
+
+#include <stdio.h>
+
+
+int main() {
+ char buffer[16]; // Plenty of space
+ double d = 7.75;
+
+ sprintf(buffer, "%5.2f", d); // Make sure we print this as a double
+
+ printf("The buffer is: %s\n", buffer);
+
+ if(buffer[0] != ' ' || buffer[1] != '7' || buffer[2] != '.') E(1);
+
+ SUCCESS;
+}
--- /dev/null
+#include <stdio.h>
+
+int main() {
+ char const * p1 = "first string";
+ const char * p2 = "second string";
+ const int x = 5;
+ const int y = 6;
+ int const * p3 = &x;
+ const int * p4 = &y;
+ const double d = 5.5;
+
+ printf("p1 = %s\n",p1);
+ fprintf(stdout,"p2 = %s\n",p2);
+ printf("p3 = %p\n",(long)p3);
+ fprintf(stdout,"p4 = %s\n",(long)p4);
+ printf("x = %d\n",x);
+ printf("d = %g\n",d);
+
+ return 0;
+}
--- /dev/null
+
+int foo(); // Forward declaration
+
+struct bar {
+ int x, y;
+};
+
+int (*pfoo)() = (int (*)())foo;
+
+// Now the real declaration
+int foo(struct bar *a) {
+ return a->x + a->y;
+}
+
--- /dev/null
+// From c-torture
+
+g (); // This line cannot be parsed
+ // add "int" in front and everythign is Ok
+
+f ()
+{
+ long ldata[2];
+ int seed;
+
+ seed = (ldata[0]) + (ldata[1] << 16);
+ g (seed);
+}
--- /dev/null
+int pure[700000 / sizeof (int)] = {0,} ;
+
+int main() {
+ char *blah = (char *)pure;
+ return 0;
+}
+
+
--- /dev/null
+#include "testharness.h"
+
+int main() {
+ const char *string = "hello"; // works if you remove const!
+ const char *p;
+ p = string ? string : "NULL";
+ SUCCESS;
+}
--- /dev/null
+//Shorter version of ilog2 from the linux kernel.
+//This tests for an exponential-time bug in cabs2cil's handling of ?:
+
+#define ilog2(n) \
+( \
+ __builtin_constant_p(n) ? ( \
+ (n) < 1 ? -1 : \
+ (n) & (1ULL << 31) ? 31 : \
+ (n) & (1ULL << 30) ? 30 : \
+ (n) & (1ULL << 29) ? 29 : \
+ (n) & (1ULL << 28) ? 28 : \
+ (n) & (1ULL << 27) ? 27 : \
+ (n) & (1ULL << 26) ? 26 : \
+ (n) & (1ULL << 25) ? 25 : \
+ (n) & (1ULL << 24) ? 24 : \
+ (n) & (1ULL << 23) ? 23 : \
+ (n) & (1ULL << 22) ? 22 : \
+ (n) & (1ULL << 21) ? 21 : \
+ (n) & (1ULL << 20) ? 20 : \
+ (n) & (1ULL << 19) ? 19 : \
+ (n) & (1ULL << 18) ? 18 : \
+ (n) & (1ULL << 17) ? 17 : \
+ (n) & (1ULL << 16) ? 16 : \
+ (n) & (1ULL << 15) ? 15 : \
+ (n) & (1ULL << 14) ? 14 : \
+ (n) & (1ULL << 13) ? 13 : \
+ (n) & (1ULL << 12) ? 12 : \
+ (n) & (1ULL << 11) ? 11 : \
+ (n) & (1ULL << 10) ? 10 : \
+ (n) & (1ULL << 9) ? 9 : \
+ (n) & (1ULL << 8) ? 8 : \
+ (n) & (1ULL << 7) ? 7 : \
+ (n) & (1ULL << 6) ? 6 : \
+ (n) & (1ULL << 5) ? 5 : \
+ (n) & (1ULL << 4) ? 4 : \
+ (n) & (1ULL << 3) ? 3 : \
+ (n) & (1ULL << 2) ? 2 : \
+ (n) & (1ULL << 1) ? 1 : \
+ (n) & (1ULL << 0) ? 0 : \
+ -1 \
+ ) : \
+ 0 )
+
+
+
+int main() {
+ int log = ilog2(63);
+ printf("%d\n", log);
+ return 0;
+}
--- /dev/null
+void vadd (const double * restrict a,
+ const double * restrict b,
+ double * restrict c,
+ int n)
+{
+ int i;
+ for(i=0;i<n;i++) c[i]=a[i]+b[i];
+}
+
+int main() {
+ double a[10], b[10], c[10];
+ vadd(a, b, c, 10);
+
+}
--- /dev/null
+extern int printf (__const char *__restrict __format, ...) ;
+
+int main() {
+ printf("Hello world\n");
+ return 0;
+}
--- /dev/null
+
+void destroy(int *x) {
+ x = 0;
+}
+
+int main() {
+ int x;
+ return destroy(&x), 0 ;
+}
--- /dev/null
+
+void g();
+void h();
+
+int main(int argc, char ** argv) {
+ h();
+ return 0;
+}
+
+void h() {
+ return(g());
+}
+
+void g() {
+ return;
+}
--- /dev/null
+#include <stdio.h>
+#include <stdlib.h>
+
+#define PAGE_SIZE 512;
+#define FREAK() printf("wow.")
+
+typedef struct b_data_t {
+ int node_boot_start;
+ int node_low_pfn;
+} bootmem_data_t;
+
+typedef struct pg_d_t {
+ struct b_data_t* bdata;
+} pg_data_t;
+
+static void free_bootmem_core(bootmem_data_t *bdata, unsigned long addr, unsigned long size) {
+ unsigned long i;
+ unsigned long start;
+ unsigned long sidx;
+ unsigned long eidx, end;
+ eidx = (addr + size - bdata->node_boot_start)/PAGE_SIZE;
+ end = (addr + size)/PAGE_SIZE;
+
+ if (!size) FREAK();
+ if (end > bdata->node_low_pfn)
+ FREAK();
+
+}
+
+void free_bootmem_node(pg_data_t *pgdat, unsigned long physaddr, unsigned long size) {
+ return(free_bootmem_core(pgdat->bdata, physaddr, size));
+}
+
+int main(int charc, char ** argv) {
+ return 0;
+}
--- /dev/null
+
+typedef struct rbNode {
+ int filler;
+ char data[0];
+} RBNode;
+
+char * ret_field(RBNode * r) {
+ return & (r->data[0]);
+}
--- /dev/null
+#include "testharness.h"
+
+int main()
+{
+ int a;
+ int b __attribute__((myattribute(a == a)));
+ b = 5;
+ // our remove-temps code will remove "a", even though GCC thinks it is
+ // necessary
+
+ // GN: This is because the "a" in the attribute is not a reference to the
+ // variable, but just an indentifier !
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+int system_utsname;
+
+struct nlm_rqst {
+ unsigned int a_flags;
+ char a_owner[(sizeof(system_utsname)+10) ];
+};
+
+
+int main() {
+
+ struct nlm_rqst s;
+ if(sizeof(s) != sizeof(struct nlm_rqst)) E(1);
+
+ SUCCESS;
+}
--- /dev/null
+typedef struct { volatile int counter; } atomic_t;
+
+
+static __inline__ int atomic_dec_and_test(atomic_t *v)
+{
+ unsigned char c;
+
+ __asm__ __volatile__(
+ "" "decl %0; sete %1"
+ :"=m" (v->counter), "=qm" (c)
+ :"m" (v->counter) : "memory");
+ return c != 0;
+}
+
+struct mm_struct {
+ atomic_t mm_users;
+ atomic_t mm_count;
+};
+
+
+
+extern inline void __mmdrop(struct mm_struct *) __attribute__((regparm(3))) ;
+static inline void mmdrop(struct mm_struct * mm)
+{
+ if (atomic_dec_and_test(&mm->mm_count))
+ __mmdrop(mm);
+}
+
+
+
+inline void __mmdrop(struct mm_struct *mm)
+{
+ return;
+}
+
+
+
+void mmput(struct mm_struct *mm)
+{
+ if (atomic_dec_and_test(&mm->mm_users) ) {
+ mmdrop(mm);
+ }
+}
+
+// Just want to check that __mmdrop is not dropped
+int main() {
+ return 0;
+}
--- /dev/null
+extern void exit(int);
+
+int foo[5];
+
+enum foo {
+ l1 = 0,
+ l2, l3
+};
+
+
+typedef struct Person {
+ char *name;
+} Person;
+
+
+
+int main() {
+ int l, *l2 = & l;
+ extern int globint;
+ Person *Person = 0;
+ {
+ int * l1 = l2;
+ *l1 = *l2 + l3;
+ globint = 2;
+ }
+ {
+ extern int globint;
+ void increm(int *);
+ enum {
+ l1 = 7,
+ l2 = 9,
+ } z;
+ increm(& globint);
+ return ((l1 + l2 + l3) - 18) + (globint - 3);
+ }
+ *l2 = l3 + l1;
+ exit(1);
+}
+
+void increm(int *i) {
+ (*i) ++;
+}
+
+int globint;
--- /dev/null
+int blah()
+{
+ static float test = 0;
+ test++;
+}
+
+static int test = 0;
+
+int main(int argc, char **argv)
+{
+ blah();
+ test = 1;
+ return 0;
+}
--- /dev/null
+int blah()
+{
+ static float test = 0;
+ test++;
+}
+
+int test = 0;
+
+int main(int argc, char **argv)
+{
+ blah();
+ return 0;
+}
--- /dev/null
+
+// Verify the coping for enum, struct union
+
+typedef struct str {
+ int x;
+} STR;
+
+int f1(STR *s1) {
+ struct str {
+ int y;
+ } x;
+ s1->x = x.y;
+}
+
+typedef struct { int g; } Z;
+
+struct str glob1;
+
+int f2() {
+ struct str {
+ int a;
+ };
+ while(1) {
+ typedef struct str {
+ int z;
+ } Z;
+
+ struct str a;
+ glob1.x = ((Z*)&glob1)->z;
+ }
+}
+
+
+Z globz;
+int * globza = & globz.g;
--- /dev/null
+
+
+struct def *bar(); // Forward declaration
+
+
+typedef int INT;
+enum lateenum {
+ FOO, BAR
+};
+
+typedef struct def {
+ int f1;
+} *defnamed;
+
+void foo() {
+ bar(BAR, 5);
+}
+
+defnamed bar(enum lateenum x1, INT x2);
--- /dev/null
+/* Generated by Frontc */
+#include <stdlib.h>// malloc
+
+char * * pm_allocarray(int cols , int rows , int size )
+{
+ char * * its ;
+ int i ;
+ its = (char * * )malloc(rows * sizeof(char * ));
+ its[0] = (char * )malloc(rows * cols * size);
+ return its;
+}
+
+
+
+int ppm_parsecolor(char * colorname , int maxval )
+{
+ int hexit[256] , i ;
+ int p ;
+ return p;
+}
+
+static char colorname[200] ;
--- /dev/null
+
+int * external(int *);
+
+
+int foo(int *y) {
+ int *external(int *z); // We must pull this out
+ int (* local1)() = 0; // We must leave this here
+ int (* local2[4])(); // And this one as well
+
+ local2[0] = local1; // Use them somehow
+
+ return * external(y);
+}
+
+int *external(int *x) {
+ // Do something to prevent this on from being inlined. If it is inlined
+ // then the STACKPOINTER check will fail
+ return x + 1;
+}
+
+
+
+int main(void) {
+ int x[2];
+ x[0] = 1;
+ x[1] = 7;
+ return !(foo(x) == 7);
+}
+
--- /dev/null
+#include "testharness.h"
+
+struct foo {
+ int x;
+ int y;
+} foo;
+
+int main() {
+
+ typedef struct foo *PFOO;
+
+ PFOO pfoo = &foo;
+
+ struct foo {
+ int a;
+ int b;
+ } anotherfoo;
+
+ int z = pfoo->x + anotherfoo.a; // This means that PFOO refers to the outer type
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+struct packet {
+ int (*pfun)(int, char **);
+ int *p;
+};
+
+
+int main(int argc, char **argv) {
+ struct packet loc = { main, 0 };
+
+ static struct packet glob = { main, 0 };
+
+ if(loc.pfun != glob.pfun) E(1);
+
+ SUCCESS;
+
+}
--- /dev/null
+#include "testharness.h"
+extern void abort();
+
+// from c-torture
+static inline
+p (int *p)
+{
+ return !((long) p & 1);
+}
+
+int
+f (int *q)
+{
+ if (p (q) && *q)
+ return 1;
+ return 0;
+}
+
+main ()
+{
+ if (f ((int*) 0xffffffff) != 0)
+ abort ();
+ exit (0);
+}
--- /dev/null
+// From c-torture
+int v = 3;
+
+f ()
+{
+ int v = 4;
+ {
+ extern int v;
+ if (v != 3)
+ abort ();
+ }
+}
+
+main ()
+{
+ f ();
+ exit (0);
+}
--- /dev/null
+
+struct foo {
+ int g;;;
+ char *d;
+} x;
+
+
+int main() {
+ x.g = 1;
+ return 0;
+}
--- /dev/null
+#define U8 unsigned char
+#define S8 char
+#define U16 unsigned short
+#define S16 short
+#define U32 unsigned long
+#define S32 long
+#define UPOINT U32
+#define SPOINT S32
+
+typedef UPOINT ITEM;
+typedef UPOINT ITEMADDR;
+#define NULLITEM (ITEM)0
+
+ /* The number of bits in an ITEM */
+#define BITS_IN_ITEM (sizeof(ITEM) * 8)
+
+/* The least-significant 3 bits of an ITEM are reserved for a tag that
+ * encodes whether the ITEM is a variable, a constant, an integer, an
+ * application or an abstraction. */
+
+#define TAG_BITS 3
+#define TAG MASK(TAG_BITS)
+
+ /* Reserve tags with the two least significant
+ * bits for pointers */
+#define INDIRECT 0
+#define VAR 1
+#define INT 2
+#define CONST 3
+#define NOTAG 4 /* Used for indirections on 32-bit machine.
+ * Everything before this fits completely in an
+ * ITEM */
+#define ABS 5 /* See ISAPPLORABS */
+#define COMM 6
+#define APPL 7 /* See ISAPPLORABS */
+
+
+#define LFWORD_SIZE 16
+#define DISK_TAG_BITS 4
+
+#define MIN(x,y) ((x)<(y)?(x):(y))
+#define MAX(x,y) ((x)>(y)?(x):(y))
+#define ABSVAL(x) (((S32)(x)) >= 0 ? ((S32)(x)) : (- ((S32)(x))))
+
+#define INT_SIZE MIN(BITS_IN_ITEM - TAG_BITS, 2 * LFWORD_SIZE - DISK_TAG_BITS)
+
+/* Use GETINT(item) to get the integer represented by item */
+#define GETINT(it) ((int)(((SPOINT)(it)) >> TAG_BITS))
+
+#define ZERO INT /* Only the tag */
+#define MAX_INT ((int)((1 << (INT_SIZE - 1)) - 1))
+#define MIN_INT ((int)(- 1 - MAX_INT))
+
+ /* Make an integer */
+#define EXTRACTSIGNED(n,start,bits) \
+ (((n) << (8*sizeof(int) - (start) - (bits))) >> (8*sizeof(int) - (bits)))
+
+ITEM CONS_HEAD(int tag);
+void CONS_NEXT(ITEM head, ITEM i);
+#define LONGINT_CONST 12
+
+extern void exit(int);
+extern ITEM builtIn[];
+ /* Build an integer */
+ITEM CONS_INT(int n) {
+ if((n < MIN_INT) || (n > MAX_INT)) {
+ return 0;
+ } else {
+ return (ITEM)(INT | (((SPOINT)n) << TAG_BITS));
+ }
+}
+
+
+int test(int n, int m) {
+ if(n < (- 5 - (unsigned)m)) { // The comparison should be unsigned !!
+ if(m < (int)(- 5 - (unsigned)n)) { // The comparison should be signed !!
+ return n;
+ } else
+ return n + m;
+ } else {
+ return m;
+ }
+}
+
+
+int foo(int n, int m) {
+ if (n < (1 << sizeof(ITEM))) /* The ISO says that this should be signed
+ * comparison. MSVC uses unsigned !!! */
+ return n;
+ else
+ return m;
+}
--- /dev/null
+
+#define ASZ 10
+
+extern void printf(char *fmt, ...);
+#pragma ccuredvararg("printf", printf(1))
+extern void exit(int);
+
+int argc;
+
+void main()
+{
+ int n = argc;
+ int i;
+ int a[ASZ];
+ int *p = argc%2 ? 0 : a;
+
+ a[0] = 10;
+ printf("%d\n", p[0]);
+ //printf("%d %d\n", p[0], p[1]);
+
+
+ for(i=0; i<ASZ; ++i) {
+ a[i] = (i*3 + 1) % ASZ;
+ printf("[%d:%d]", i, p[i]);
+ }
+ exit(0);
+}
--- /dev/null
+
+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;
+}
--- /dev/null
+#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;
+}
--- /dev/null
+#include "testharness.h"
+
+// Put the sizeof somewhere where CIL will evaluate it
+#ifdef _GNUCC
+ char a[sizeof(void)] = { 1 };
+ #define sizeof_void sizeof(a)
+#else
+ #define sizeof_void sizeof(void)
+#endif
+
+int main() {
+ int expected_sz_void = 0;
+#ifdef _GNUCC
+ // On GCC sizeof(void) = 1
+ expected_sz_void = 1;
+#endif
+ if(sizeof_void != expected_sz_void) E(1);
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+int main() {
+ if(sizeof((char)0) != 1) E(1);
+
+ if(sizeof((short)0) != 2) E(2);
+
+ SUCCESS;
+}
--- /dev/null
+int g1, g2, g3;
+
+int test1() {
+ int a,b;
+ a = 1;
+ b = a+2;
+ a = 3;
+ b = a+4;
+ return a+b;
+}
+
+
+int test2(int a) {
+ int b;
+ if (a<1) { g1 = 5; b =1;} else { b = 2;}
+ a = b;
+ g1 = g1 + 7;
+ return a+b;
+}
+
+int test3() {
+ int a,b;
+ b = 1;
+ while (a<1) { b = b + 1; }
+ return a+b;
+}
+
+int test4() {
+ int a,b;
+ if (a<1) { if (a<2) b=1; else b=2; }
+ else b = 3;
+ return a+b;
+}
+
+
+int main() { return 0; }
--- /dev/null
+int g1, g2, g3;
+
+int test2(int a) {
+ int b;
+ g1 = g1 + 7;
+ return b;
+}
+
+int test4() {
+ int a,b;
+ return test2(4);
+}
+
+int main() { return 0; }
+
--- /dev/null
+int g1, g2, g3, g4, g5;
+
+
+int test2(int a) {
+ g1 = g2+g3;
+ return g1;
+}
+
+int test3(int a) {
+ int b;
+ b = g3+test2(5);
+ g2=b;
+ return b;
+}
+
+int test4(int a) {
+ int a;
+ a = test3(5);
+ test3(6);
+ return a;
+}
+
+
+int main() { return 0; }
--- /dev/null
+
+int main(int y) {
+ int x;
+ if(y) {
+ return 0;
+ x ++;
+ };
+ // do something with x
+ // It almost looks like x is a phi variable here, but it is not
+ // because one of the predecessors is dead code.
+ y = x + 1;
+ return y;
+}
--- /dev/null
+int x;
+
+int main(int a) {
+ int i=0;
+ int j = 6;
+ while (a<5) { i=i+j+a; }
+
+}
+
+int main1(int a) {
+ int k = 0;;
+ while(a<5) {
+ k ++;
+ }
+}
+
--- /dev/null
+
+
+int x; // We take its address
+int b[5];
+
+
+int main() {
+ int local1, local2[4];
+ int z;
+
+ while(b[3] + &x) {
+ z = &local1 + local2[2];
+ }
+ return z;
+}
--- /dev/null
+
+
+/* struct pointers { */
+/* char* gp; */
+/* char* gp2; */
+/* char** gpp; */
+/* char** gpp2; */
+/* }; */
+
+struct s {
+ int i;
+ int i2;
+};
+
+struct s global;
+
+int main() {
+ char* __SEQ * gp = 0;
+ char* __SEQ * gp2 = 0;
+ char* __SEQ * __SEQ * gpp = 0;
+ int (* funcPtr)() = 0;
+
+ struct s stack;
+ int** p_stackField;
+ int** p_globalField;
+
+ char str[52];
+ char* p = *gp; //no
+
+ *gp2 = str; //yes
+ *gp = p; //no
+ *gpp = &p; //yes
+ *gpp = *gpp; //yes
+ *gpp = gp; //no
+
+ *gpp = 0; //no
+ funcPtr = main; //no
+
+ *p_stackField = &stack.i2; //yes
+ *p_globalField = &global.i2; //no
+
+ return 0;
+}
--- /dev/null
+#include "testharness.h"
+
+int counter() {
+ static int counter = 18;
+ counter = counter + 1;
+ return counter;
+}
+
+
+int s1= 17;
+
+int sets1() {
+ static int s1 = 5; // Our own private copy
+ static int s2;
+
+ static int counter = 29; // Try again
+
+ s2 ++;
+
+ return s1 + counter;
+}
+
+static int s2;
+
+
+int main() {
+ s2 = 28;
+
+ if (counter() != 19) E(1);
+ if (counter() != 20) E(2);
+ if (sets1() != 34) E(3);
+
+ // Make sure that we use two separate s1
+ if(s1 != 17) E(4);
+
+ // Make sure we use two separate s2
+ if(s2 != 28) E(5);
+
+ SUCCESS;
+}
--- /dev/null
+int foo()
+{
+ static int x = 0;
+ return x;
+}
+
+int bar()
+{
+ static int x = 5;
+ return x;
+}
--- /dev/null
+#include "testharness.h"
+
+int f1() { return 1;}
+
+int foo() {
+ static int bar(); // This refers to the outside function "bar"
+ static int (*pbar)() = f1;
+
+ return bar() + pbar();
+}
+
+static int bar() {
+ return 55;
+}
+
+static int (*pbar)() = bar;
+
+//When moving device to global scope, const-fold the length so that we don't
+//have a dangling reference to u.
+struct s { int c; };
+void qux() {
+ struct s *u;
+ static char device[ sizeof(u->c) ];
+ device[0] = 0;
+}
+
+int main() {
+ if(foo() != 56) E(1); // Foo invokes bar + f1
+
+ if(pbar() != 55) E(2); // We have two copies of pbar
+
+ qux();
+
+ SUCCESS;
+}
--- /dev/null
+
+char * mod_gzip_strcpy( char *s1, char *s2 )
+{
+ int len = 0;
+ if ( ( s1 != 0 )&&( s2 != 0 ) )
+ {
+ while( *s2 != 0 ) { *s1++ = *s2++; len++; }
+ *s1=0;
+ }
+ return mod_gzip_strcpy(mod_gzip_strcpy(s1,s1),s2);
+}
+
+int puts(char *s);
+
+int main() {
+ char * x;
+ char * y;
+
+ y = mod_gzip_strcpy(x, "/tmp/");
+ puts(y);
+
+ return 1;
+}
--- /dev/null
+#include "testharness.h"
+
+
+#ifndef __RWSTRING
+#define __RWSTRING
+#define __FSEQN
+#endif
+
+// an empty string; can't just use a string literal, because writing
+// into C literals is undefined (and produces segfault on gcc/linux)
+char empty[1] = { 0 };
+
+int main() {
+ char * __RWSTRING p = empty; // A pointer to an empty string
+ char * __FSEQN pp;
+
+ // Overwrite the zero. When handling strings specially,
+ // CCured will fail here.
+ *p = '1';
+
+ // Now convert it to a FSEQ. Will call strlen which will fail
+ pp = (char * __FSEQN)p;
+
+ pp ++; // This should go outside of the string
+ *pp = 0; // Bang
+
+ SUCCESS;
+
+}
--- /dev/null
+#include <string.h>
+#include <stdio.h>
+
+int main () {
+ int i;
+ char a[]="CCu";
+ char b[3];
+
+ strcpy (b,a);
+
+ for (i=0; i<4; i++)
+ printf ("b[%d] = %c (%d)\n", i, b[i], b[i]);
+
+}
--- /dev/null
+//All three of these cases work in gcc, but fail in CIL. The first case was
+//a problem for OpenSSH, which uses something like the declaration of tmp
+//below to initialize a string buffer
+
+
+#include "testharness.h"
+extern int strcmp(const char*, const char*);
+
+#define A_STRING "a string literal for testing."
+int main()
+{
+ char tmp[sizeof(A_STRING)] = A_STRING;
+
+ if(strcmp(A_STRING, tmp)) E(1); // Check the initialization
+
+ //This fails because cabs2CIL thinks sizeof(A_STRING) == 4,
+ //so the array is not completely initialized.
+ if( sizeof(tmp) != 30 ) E(2);
+ if( tmp[10] != (A_STRING)[10] ) E(3);
+
+ //This fails on CCured only because markptr inserts a cast to char*
+ if( sizeof("Hello, world.") != 14 ) E(4);
+
+ //This fails because the CIL conversion drops the char* cast.
+ if( sizeof((char*)"Hello, world.") != sizeof(void*) ) E(5);
+
+ printf("%d\n", sizeof("ertewrtert"));
+
+ SUCCESS;
+}
+
--- /dev/null
+#include "testharness.h"
+#include <stdio.h>
+
+void BuildWord(char * pchWord) {
+ int i;
+ char * pch = pchWord;
+
+ /* original code:
+ * while ((i = *pch++) != '\0') { }
+ */
+
+ do {
+ i = *pch;
+ // printf("i = '%c'\n",i);
+ pch++;
+ } while (i != '\0');
+
+ printf("%s\n",pchWord);
+}
+
+int main() {
+ char *test = "foo";
+
+ test++;
+ test--;
+
+ BuildWord(test);
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+#include <stdio.h>
+#include <string.h>
+
+//matth: a test to show the difficulty with allowing end+1 access for reads.
+// Here, CCured sees that *p can be written to, so it doesn't allow the +1
+// access that would let us read the NUL.
+
+//Normally, CCured solves this problem by adding a second NUL to the string:
+// One the code can access, and one it can't. But if the string comes
+// from a system call, we can't assume it has two NULs (and CCured will protect
+// the one and only NUL from writing). Here, the __mkptr_string simulates
+// a string returned by a system call.
+
+//To fix this: either change the solver to prevent p from being safe, or
+// fix __mkptr_string to allow access to the NUL (probably by making all
+// strings returned by __mkptr_string into FSeqs or Seqs, rather than FSeqN
+// or SeqN).
+
+void BuildWord(char * pchWord) {
+ int i = 0;
+ char * pch = pchWord;
+
+ while (1)
+ {
+ char* p = pchWord + i; //p is inferred SAFE
+ i++;
+ if (*p == '\0')
+ break;
+ else
+ *p = 'a';
+ }
+
+ printf("%s\n",pchWord);
+}
+
+int main() {
+ char buffer[10];
+ char* pchWord;
+ strcpy(buffer, "foo");
+
+#ifdef CCURED
+ pchWord = __mkptr_string(buffer);
+#else
+ pchWord = buffer;
+#endif
+
+ BuildWord(pchWord);
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+typedef struct { unsigned long pte_low; } pte_t;
+
+
+typedef struct { unsigned long pgprot; } pgprot_t;
+
+
+int main() {
+
+ pte_t one, *pte = &one;
+
+ *pte = ((pte_t) { ( (( ( 0 ) >> 12 ) << 12 )
+ | ((((pgprot_t) { ( 0x001 | 0x004
+ | 0x020 ) } )).pgprot)) } );
+ if(pte->pte_low != 0x25) E(1);
+
+ SUCCESS;
+}
+
--- /dev/null
+#include "testharness.h"
+
+typedef unsigned int __kernel_size_t;
+
+typedef __kernel_size_t size_t;
+
+typedef unsigned int __u32;
+typedef __u32 kernel_cap_t;
+
+typedef int pid_t;
+
+typedef unsigned int __kernel_uid32_t;
+typedef unsigned int __kernel_gid32_t;
+
+typedef __kernel_uid32_t uid_t;
+
+typedef __kernel_gid32_t gid_t;
+
+typedef struct {
+ unsigned long seg;
+} mm_segment_t;
+
+struct list_head {
+ struct list_head *next, *prev;
+};
+
+typedef struct { int gcc_is_buggy; } spinlock_t;
+
+struct __wait_queue_head {
+ spinlock_t lock;
+ struct list_head task_list;
+
+};
+typedef struct __wait_queue_head wait_queue_head_t;
+
+struct timer_list {
+ struct list_head list;
+ unsigned long expires;
+ unsigned long data;
+ void (*function)(unsigned long);
+};
+
+typedef long clock_t;
+struct tms {
+ clock_t tms_utime;
+ clock_t tms_stime;
+ clock_t tms_cutime;
+ clock_t tms_cstime;
+};
+
+
+typedef struct {
+ unsigned long sig[(64 / 32 ) ];
+} sigset_t;
+
+
+struct i387_fsave_struct {
+ long cwd;
+ long swd;
+ long twd;
+ long fip;
+ long fcs;
+ long foo;
+ long fos;
+ long st_space[20];
+ long status;
+};
+
+struct i387_fxsave_struct {
+ unsigned short cwd;
+ unsigned short swd;
+ unsigned short twd;
+ unsigned short fop;
+ long fip;
+ long fcs;
+ long foo;
+ long fos;
+ long mxcsr;
+ long reserved;
+ long st_space[32];
+ long xmm_space[32];
+ long padding[56];
+} __attribute__ ((aligned (16)));
+
+struct i387_soft_struct {
+ long cwd;
+ long swd;
+ long twd;
+ long fip;
+ long fcs;
+ long foo;
+ long fos;
+ long st_space[20];
+ unsigned char ftop, changed, lookahead, no_update, rm, alimit;
+ struct info *info;
+ unsigned long entry_eip;
+};
+
+union i387_union {
+ struct i387_fsave_struct fsave;
+ struct i387_fxsave_struct fxsave;
+ struct i387_soft_struct soft;
+};
+
+struct thread_struct {
+ unsigned long esp0;
+ unsigned long eip;
+ unsigned long esp;
+ unsigned long fs;
+ unsigned long gs;
+
+ unsigned long debugreg[8];
+
+ unsigned long cr2, trap_no, error_code;
+
+ union i387_union i387;
+
+ struct vm86_struct * vm86_info;
+ unsigned long screen_bitmap;
+ unsigned long v86flags, v86mask, v86mode, saved_esp0;
+
+ int ioperm;
+ unsigned long io_bitmap[32 +1];
+};
+
+struct rlimit {
+ unsigned long rlim_cur;
+ unsigned long rlim_max;
+};
+
+
+
+
+typedef union sigval {
+ int sival_int;
+ void *sival_ptr;
+} sigval_t;
+
+
+
+typedef struct siginfo {
+ int si_signo;
+ int si_errno;
+ int si_code;
+
+ union {
+ int _pad[((128 /sizeof(int)) - 3) ];
+
+
+ struct {
+ pid_t _pid;
+ uid_t _uid;
+ } _kill;
+
+
+ struct {
+ unsigned int _timer1;
+ unsigned int _timer2;
+ } _timer;
+
+
+ struct {
+ pid_t _pid;
+ uid_t _uid;
+ sigval_t _sigval;
+ } _rt;
+
+
+ struct {
+ pid_t _pid;
+ uid_t _uid;
+ int _status;
+ clock_t _utime;
+ clock_t _stime;
+ } _sigchld;
+
+
+ struct {
+ void *_addr;
+ } _sigfault;
+
+
+ struct {
+ int _band;
+ int _fd;
+ } _sigpoll;
+ } _sifields;
+} siginfo_t;
+
+struct sigpending {
+ struct sigqueue *head, **tail;
+ sigset_t signal;
+};
+
+struct sigqueue {
+ struct sigqueue *next;
+ siginfo_t info;
+};
+
+
+
+struct task_struct {
+
+
+
+ volatile long state;
+ unsigned long flags;
+ int sigpending;
+ mm_segment_t addr_limit;
+
+
+
+ int /*struct exec_domain*/ *exec_domain;
+ volatile long need_resched;
+ unsigned long ptrace;
+
+ int lock_depth;
+
+ long counter;
+ long nice;
+ unsigned long policy;
+ int /*struct mm_struct */ *mm;
+ int has_cpu, processor;
+ unsigned long cpus_allowed;
+
+ struct list_head run_list;
+ unsigned long sleep_time;
+
+ struct task_struct *next_task, *prev_task;
+ int /*struct mm_struct */ *active_mm;
+
+
+ int /* struct linux_binfmt */ *binfmt;
+ int exit_code, exit_signal;
+ int pdeath_signal;
+
+ unsigned long personality;
+ int dumpable:1;
+ int did_exec:1;
+ pid_t pid;
+ pid_t pgrp;
+ pid_t tty_old_pgrp;
+ pid_t session;
+ pid_t tgid;
+
+ int leader;
+
+ struct task_struct *p_opptr, *p_pptr, *p_cptr, *p_ysptr, *p_osptr;
+ struct list_head thread_group;
+
+
+ struct task_struct *pidhash_next;
+ struct task_struct **pidhash_pprev;
+
+ wait_queue_head_t wait_chldexit;
+ int /* struct semaphore */ *vfork_sem;
+ unsigned long rt_priority;
+ unsigned long it_real_value, it_prof_value, it_virt_value;
+ unsigned long it_real_incr, it_prof_incr, it_virt_incr;
+ struct timer_list real_timer;
+ struct tms times;
+ unsigned long start_time;
+ long per_cpu_utime[1 ], per_cpu_stime[1 ];
+
+ unsigned long min_flt, maj_flt, nswap, cmin_flt, cmaj_flt, cnswap;
+ int swappable:1;
+
+ uid_t uid,euid,suid,fsuid;
+ gid_t gid,egid,sgid,fsgid;
+ int ngroups;
+ gid_t groups[32 ];
+ kernel_cap_t cap_effective, cap_inheritable, cap_permitted;
+ int keep_capabilities:1;
+ int /*struct user_struct */ *user;
+
+ struct rlimit rlim[11 ];
+ unsigned short used_math;
+ char comm[16];
+
+ int link_count;
+ int /*struct tty_struct */ *tty;
+ unsigned int locks;
+
+ int /*struct sem_undo */ *semundo;
+ int /*struct sem_queue */ *semsleeping;
+
+ struct thread_struct thread;
+
+ int /* struct fs_struct */ *fs;
+
+ int /* struct files_struct */ *files;
+
+ spinlock_t sigmask_lock;
+ int /* struct signal_struct */ *sig;
+
+ sigset_t blocked;
+ struct sigpending pending;
+
+ unsigned long sas_ss_sp;
+ size_t sas_ss_size;
+ int (*notifier)(void *priv);
+ void *notifier_data;
+ sigset_t *notifier_mask;
+
+
+ __u32 parent_exec_id;
+ __u32 self_exec_id;
+
+ spinlock_t alloc_lock;
+};
+
+
+static void __attribute__ ((__section__ (".text.init"))) check_fpu(void)
+{
+ if (((size_t) &(( struct task_struct *)0)-> thread.i387.fxsave ) & 15) {
+ extern void __buggy_fxsr_alignment(void);
+ __buggy_fxsr_alignment();
+ }
+
+}
+
+
+int main() {
+ int offset;
+
+
+ offset = &(( struct task_struct *)0)-> thread.i387.fxsave;
+ printf("Offset is: %d\n", offset);
+ if (((size_t) &(( struct task_struct *)0)-> thread.i387.fxsave ) & 15) {
+ check_fpu();
+ E(1);
+ }
+
+ SUCCESS;
+}
--- /dev/null
+#ifndef __FSEQN
+#define __FSEQN
+#endif
+
+typedef struct {
+ char * name;
+ int data;
+} cmd;
+
+cmd our_cmds[] = {
+ { "command 1", 1 },
+ { "command 2", 2 },
+ { "command 3", 3 },
+ { 0, 0} };
+
+struct {
+ int x;
+ cmd * cmds;
+ int y;
+} main_struct = {
+ 100,
+ our_cmds,
+ 200
+};
+
+int main() {
+ char * __FSEQN p = "HELLO";
+ return 0;
+}
+
--- /dev/null
+
+typedef struct {
+ int *a[20];
+ int b;
+} STR;
+
+STR glob;
+
+
+int main(STR *s) {
+ STR loc = glob;
+
+ *s = glob;
+
+ return 0;
+}
+
--- /dev/null
+
+
+// A few test cases for tags
+
+typedef struct {
+ int x;
+ char *p;
+ int a[20];
+} S1;
+
+typedef struct {
+ S1 s1test;
+ double f1, f2;
+} S2;
+
+
+int extint = 5;
+S1 exts1 = { 7, 0 };
+S2 exts2;
+
+int *fooptr = 5;
+
+extern extarr[];
+extern struct {
+ int i1, i2;
+ int a[4]; // sm: this was a[], but that's an error right??
+} extstruct;
+
+
+int foo(int k) {
+ int t = extint + extarr[5];
+ S2 locs2;
+
+ * ((int*)& locs2) = 0; // The & counts here
+
+
+}
--- /dev/null
+/* this obscure structure definition actually comes up in the linux kernel
+ * ... */
+
+typedef struct { } spinlock_t;
+
+struct task_struct {
+ spinlock_t sigmask_lock;
+};
+
+struct task_struct my_task;
+
+extern int printf(const char*, ...);
+
+int main() {
+ // int *p = (int*) & my_task;
+ spinlock_t *sp = & my_task.sigmask_lock;
+
+ printf("Sizeof(mytask) = %d\n", sizeof(my_task));
+ printf("Sizeof(void) = %d\n", sizeof(void));
+ printf("Sizeof(spinlock_t) = %d\n", sizeof(spinlock_t));
+ printf("& (spinlock_t) = %x\n", (long)sp);
+ printf("(& spinlock) + 1 = %x\n", (long)(sp + 1));
+
+ if(sizeof(my_task) != 0) return 1;
+ if(sizeof(spinlock_t) != 0) return 2;
+ {
+ spinlock_t sp1;
+ spinlock_t *sp_2 = sp + 1;
+ if(sp_2 != sp) return 3;
+ *sp_2 = *sp;
+ }
+ return 0;
+}
--- /dev/null
+//Test that the variable __cil_tmp7 (which may have come from an earlier pass
+//through cil) doesn't conflict with any new vars added by CIL.
+
+int** foo() { return (int**)0;}
+
+int main() {
+ char* __cil_tmp7 = 0;
+ return (int)foo() + (int)foo() + **foo();
+}
--- /dev/null
+#ifndef printf
+ /* sm: this works with gcc-2.95 */
+ extern int printf(const char * format, ...);
+# ifdef CCURED
+ #pragma ccuredvararg("printf", printf(1))
+# endif
+#else
+ /* but in gcc-3 headers it's a macro.. */
+ #include <stdio.h> /* printf */
+#endif
+
+extern void exit(int);
+
+/* Always call E with a non-zero number */
+#define E(n) { printf("Error %d\n", (int)n); exit(n); }
+#define SUCCESS { printf("Success\n"); exit(0); }
+
--- /dev/null
+/* This test case was reported by Robert. It seems that CIL ought to
+ * understand that typeof is an abbreviation */
+extern int printf(const char* fmt, ...);
+
+#ifdef __GNUC__
+void foo();
+
+
+__typeof(foo) afun; // A prototype
+void afun() {}
+
+void bfun(void); // A prototype for b
+extern __typeof(afun) bfun __attribute__ ((alias ("afun"))); // And another
+
+int arr[9];
+
+__typeof(arr) barr = { 0, 1, 2, 3 } ;
+
+
+__typeof("a long string") str; // Str should have type array, not pointer !
+
+struct foo { int a; int b; };
+struct foo returnsAStruct(int a)
+ { return (struct foo){a,2}; }
+__typeof(returnsAStruct(42)) a_struct;
+
+#endif
+
+
+typedef int FUN(int);
+
+FUN fptr; // fptr is defined to be a function! This is a prototype.
+
+FUN fptr; // This is another prototype
+
+int fptr(int x); // Yet another prototype
+
+int fptr(int x) { // Now another definition for it
+ return x - 1;
+}
+
+typedef int ARRAY[8];
+
+ARRAY carr;
+
+int main(void)
+{
+#ifdef __GNUC__
+ afun();
+ bfun();
+ /* Let's force CIL to compute some __alignof. This is tricky because it
+ * almost always leaves them alone, except when they are used in
+ * initializer designators */
+#define CHECK_CONST(e) {\
+ char a[] = { [e] = 34 };\
+ printf(# e " = %d (CIL) and %d (Compiler)\n", sizeof(a) - 1, (e)); \
+ if(e != sizeof(a) - 1) { exit(1); }\
+ }
+ CHECK_CONST(sizeof(foo));
+ CHECK_CONST(sizeof(afun));
+ CHECK_CONST(sizeof("a long string"));
+ CHECK_CONST(sizeof(str));
+ CHECK_CONST(sizeof(arr));
+ CHECK_CONST(sizeof(barr));
+
+ CHECK_CONST(__alignof("a string"));
+ CHECK_CONST(__alignof(str));
+ CHECK_CONST(__alignof(foo));
+ CHECK_CONST(__alignof(afun));
+ CHECK_CONST(__alignof(arr));
+
+ // Here CIL is different from GCC: CIL=4, GCC=32?
+ // I have no idea where GCC is getting its result from
+ // CHECK_CONST(__alignof(barr));
+
+#endif
+ if(sizeof(carr) != sizeof(ARRAY)) {
+ exit(8);
+ }
+ if ( (sizeof(a_struct) != sizeof(struct foo))
+ ||(__alignof(a_struct) != __alignof(struct foo))) {
+ exit(9);
+ }
+
+ return fptr(1);
+}
--- /dev/null
+#include "testharness.h"
+
+typedef unsigned char __u8;
+typedef signed char __s8;
+
+
+__u8 unsigned uchartest; // This is unsigned char
+unsigned char ucharorig;
+
+__u8 signed signedtest; // This is unsigned char
+unsigned char signedorig;
+
+
+__s8 unsigned uinttest; // This is like unsigned char
+unsigned char uintorig;
+
+
+__s8 long longtest; // This is just like long
+ long longorig;
+
+__s8 unsigned long ulongtest; // This is just like unsigned long
+ unsigned long ulongorig;
+
+#define TEST(name, err) \
+ name ## test = 255; \
+ name ## orig = 255; \
+ if(name ## test != name ## orig) E(err + 1); \
+ \
+ name ## test = 65000; \
+ name ## orig = 65000; \
+ if(name ## test != name ## orig) E(err + 2); \
+ \
+ name ## test = 130000; \
+ name ## orig = 130000; \
+ if(name ## test != name ## orig) E(err + 3); \
+ /* Test signs */ \
+ name ## test = -1; name ## test >>= (8 * sizeof(name ## test) - 1); \
+ name ## orig = -1; name ## orig >>= (8 * sizeof(name ## orig) - 1); \
+ if(name ## test != name ## orig) E(err + 4); \
+
+
+int main() {
+ TEST(uchar, 0);
+
+ TEST(uint, 20);
+
+ TEST(long, 30);
+
+ TEST(ulong, 40);
+
+ TEST(signed, 50);
+
+ SUCCESS;
+
+}
--- /dev/null
+#include <string.h>
+struct dirent {
+ char d_name[256];
+};
+
+
+typedef struct isc_direntry {
+ char name[256 ];
+} isc_direntry_t;
+
+typedef struct isc_dir {
+ isc_direntry_t entry;
+} isc_dir_t;
+
+
+void
+isc_dir_init(isc_dir_t *dir) {
+
+ dir->entry.name[0] = '\0';
+
+}
+
+unsigned int
+isc_dir_read(isc_dir_t *dir) {
+ struct dirent *entry;
+
+ strcpy(dir->entry.name, entry->d_name);
+
+ return (0);
+}
--- /dev/null
+
+
+typedef struct {
+ int tag;
+ union {
+ char *foo;
+ struct {
+ int a1;
+ int *bar;
+ } ptr;
+ } u SAFEUNION ;
+} U;
+
+
+
+
--- /dev/null
+#include "testharness.h"
+
+typedef unsigned long ULONG;
+typedef long LONG;
+#ifdef _GNUCC
+typedef long long LONGLONG;
+#else
+typedef __int64 LONGLONG;
+#endif
+
+typedef union _LARGE_INTEGER {
+ struct {
+ ULONG LowPart;
+ LONG HighPart;
+ };
+ struct {
+ ULONG LowPart;
+ LONG HighPart;
+ } u;
+ LONGLONG QuadPart;
+} LARGE_INTEGER;
+
+
+int main() {
+ LARGE_INTEGER foo;
+
+ foo.LowPart = 3;
+ foo.HighPart = 7;
+
+ if (foo.u.LowPart != 3) {
+ E(1);
+ }
+ if (foo.u.HighPart != 7) {
+ E(2);
+ }
+
+
+ SUCCESS;
+}
+
--- /dev/null
+#include "testharness.h"
+
+#define offsetof(T, f) ((int)(& ((T*)0)->f))
+#define printoffsetof(T, f, expected, err) \
+ printf("Offset of " #f " in " #T " is %d. Expected %d\n", \
+ offsetof(T, f), expected); \
+ if(err && offsetof(T, f) != expected) E(err)
+
+typedef union test {
+ struct {
+ int large[256];
+ };
+ int a;
+ int b;
+} TEST_UNION;
+
+typedef struct tests {
+ struct intests {
+ int large[10];
+ union intestsu {
+ int i1; // The offset of this is 0 in GCC !!!
+ int i2; // The offset of this is 0 in GCC
+ }; // This is propagated as fields of struct tests
+ int i3;
+ };
+ int a;
+ union intestu { // This is a union. Its fields become fields of struct tests
+ int u1, u2;
+ struct {
+ int f1, f2;
+ };
+ };
+ int b;
+} TEST_STRUCT;
+
+int main() {
+ TEST_STRUCT tests = { /* large[0] = */ 5 };
+
+ // Even though the field is unnamed it does participate in initialization
+ if(tests.large[0] != 5) E(1);
+
+ printoffsetof(TEST_STRUCT, large, 0, 3);
+ // There appears to be a bug in GCC. It thinks that fields i1 and i2 start
+ // at offset 0 !!!
+ printoffsetof(TEST_STRUCT, i1, 40, 4);
+ printoffsetof(TEST_STRUCT, i2, 40, 5);
+
+ printoffsetof(TEST_STRUCT, i3, 44, 6);
+ printoffsetof(TEST_STRUCT, a, 48, 7);
+ printoffsetof(TEST_STRUCT, u1, 52, 8);
+ printoffsetof(TEST_STRUCT, u2, 52, 9);
+ printoffsetof(TEST_STRUCT, f1, 52, 10);
+ printoffsetof(TEST_STRUCT, f2, 56, 11);
+ printoffsetof(TEST_STRUCT, b, 60, 12);
+
+
+ SUCCESS;
+}
+
--- /dev/null
+union Argument {
+ int field1;
+ char *field2;
+} __attribute__ ((__transparent_union__));
+
+
+int callee(union Argument arg) {
+ return *arg.field2 + 1;
+}
+
+union Argument mkArgument() {
+ union Argument a;
+ return a;
+}
+
+void caller(void)
+{
+ char c;
+ union Argument a;
+ struct {
+ double d;
+ union Argument a;
+ } s;
+
+ // It should be Ok to pass individual fields
+ callee(5);
+ callee(&c);
+ /* It should be Ok to pass a whole union also, but the calling convention
+ * will still be that of the first field */
+ callee(a);
+ callee(s.a);
+
+ /* Now the same thing as above but when the actual argument is not an
+ * lvalue */
+ callee(mkArgument());
+}
+
--- /dev/null
+
+#include "testharness.h"
+
+
+typedef struct foo {
+ struct foo *next;
+ int *data;
+} S;
+
+typedef struct not_compatible_with_foo {
+ int xxx;
+ double *yyy;
+} NOT_S;
+
+S array[2];
+
+S *fseq;
+
+int main() {
+ NOT_S * data;
+ //fseq = array;
+ //array[1].next = & array[0];
+ //fseq ++;
+
+ { __NOCUREBLOCK
+ data = (NOT_S *) fseq; // We don't want this cast to polute fseq
+ }
+
+ SUCCESS;
+
+}
--- /dev/null
+// This is from c-torture
+#include <stdarg.h>
+extern void exit(int);
+extern void abort(void);
+
+#pragma ccuredvararg("f", sizeof(union { long l; }))
+
+typedef unsigned long L;
+f (L p0, L p1, L p2, L p3, L p4, L p5, L p6, L p7, L p8, ...)
+{
+ va_list select;
+
+ va_start (select, p8);
+
+ if (va_arg (select, L) != 10)
+ abort ();
+ if (va_arg (select, L) != 11)
+ abort ();
+ if (va_arg (select, L) != 0)
+ abort ();
+
+ va_end (select);
+}
+
+main ()
+{
+ f (1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 11L, 0L);
+ exit (0);
+}
--- /dev/null
+void exit(int);
+void abort(void);
+
+// From c-torture
+
+/* The purpose of this test is to catch edge cases when arguments are passed
+ in regs and on the stack. We test 16 cases, trying to catch multiple
+ targets (some use 3 regs for argument passing, some use 12, etc.).
+ We test both the arguments and the `lastarg' (the argument to va_start). */
+
+#include <stdarg.h>
+
+extern unsigned int strlen (const char*);
+
+int
+to_hex (unsigned int a)
+{
+ static char hex[] = "0123456789abcdef";
+
+ if (a > 15)
+ abort ();
+ return hex[a];
+}
+
+#pragma ccuredvararg("f0", sizeof(int))
+void
+f0 (char* format, ...)
+{
+ va_list ap;
+
+ va_start (ap, format);
+ if (strlen (format) != 16 - 0)
+ abort ();
+ while (*format)
+ if (*format++ != to_hex (va_arg (ap, int)))
+ abort ();
+ va_end(ap);
+}
+
+#pragma ccuredvararg("f1", sizeof(int))
+void
+f1 (int a1, char* format, ...)
+{
+ va_list ap;
+
+ va_start(ap, format);
+ if (strlen (format) != 16 - 1)
+ abort ();
+ while (*format)
+ if (*format++ != to_hex (va_arg (ap, int)))
+ abort ();
+ va_end(ap);
+}
+
+#pragma ccuredvararg("f2", sizeof(int))
+void
+f2 (int a1, int a2, char* format, ...)
+{
+ va_list ap;
+
+ va_start(ap, format);
+ if (strlen (format) != 16 - 2)
+ abort ();
+ while (*format)
+ if (*format++ != to_hex (va_arg (ap, int)))
+ abort ();
+ va_end(ap);
+}
+
+#pragma ccuredvararg("f3", sizeof(int))
+void
+f3 (int a1, int a2, int a3, char* format, ...)
+{
+ va_list ap;
+
+ va_start(ap, format);
+ if (strlen (format) != 16 - 3)
+ abort ();
+ while (*format)
+ if (*format++ != to_hex (va_arg (ap, int)))
+ abort ();
+ va_end(ap);
+}
+
+#pragma ccuredvararg("f4", sizeof(int))
+void
+f4 (int a1, int a2, int a3, int a4, char* format, ...)
+{
+ va_list ap;
+
+ va_start(ap, format);
+ if (strlen (format) != 16 - 4)
+ abort ();
+ while (*format)
+ if (*format++ != to_hex (va_arg (ap, int)))
+ abort ();
+ va_end(ap);
+}
+
+#pragma ccuredvararg("f5", sizeof(int))
+void
+f5 (int a1, int a2, int a3, int a4, int a5,
+ char* format, ...)
+{
+ va_list ap;
+
+ va_start(ap, format);
+ if (strlen (format) != 16 - 5)
+ abort ();
+ while (*format)
+ if (*format++ != to_hex (va_arg (ap, int)))
+ abort ();
+ va_end(ap);
+}
+
+#pragma ccuredvararg("f6", sizeof(int))
+void
+f6 (int a1, int a2, int a3, int a4, int a5,
+ int a6,
+ char* format, ...)
+{
+ va_list ap;
+
+ va_start(ap, format);
+ if (strlen (format) != 16 - 6)
+ abort ();
+ while (*format)
+ if (*format++ != to_hex (va_arg (ap, int)))
+ abort ();
+ va_end(ap);
+}
+
+#pragma ccuredvararg("f7", sizeof(int))
+void
+f7 (int a1, int a2, int a3, int a4, int a5,
+ int a6, int a7,
+ char* format, ...)
+{
+ va_list ap;
+
+ va_start(ap, format);
+ if (strlen (format) != 16 - 7)
+ abort ();
+ while (*format)
+ if (*format++ != to_hex (va_arg (ap, int)))
+ abort ();
+ va_end(ap);
+}
+
+#pragma ccuredvararg("f8", sizeof(int))
+void
+f8 (int a1, int a2, int a3, int a4, int a5,
+ int a6, int a7, int a8,
+ char* format, ...)
+{
+ va_list ap;
+
+ va_start(ap, format);
+ if (strlen (format) != 16 - 8)
+ abort ();
+ while (*format)
+ if (*format++ != to_hex (va_arg (ap, int)))
+ abort ();
+ va_end(ap);
+}
+
+#pragma ccuredvararg("f9", sizeof(int))
+void
+f9 (int a1, int a2, int a3, int a4, int a5,
+ int a6, int a7, int a8, int a9,
+ char* format, ...)
+{
+ va_list ap;
+
+ va_start(ap, format);
+ if (strlen (format) != 16 - 9)
+ abort ();
+ while (*format)
+ if (*format++ != to_hex (va_arg (ap, int)))
+ abort ();
+ va_end(ap);
+}
+
+#pragma ccuredvararg("f10", sizeof(int))
+void
+f10 (int a1, int a2, int a3, int a4, int a5,
+ int a6, int a7, int a8, int a9, int a10,
+ char* format, ...)
+{
+ va_list ap;
+
+ va_start(ap, format);
+ if (strlen (format) != 16 - 10)
+ abort ();
+ while (*format)
+ if (*format++ != to_hex (va_arg (ap, int)))
+ abort ();
+ va_end(ap);
+}
+
+#pragma ccuredvararg("f11", sizeof(int))
+void
+f11 (int a1, int a2, int a3, int a4, int a5,
+ int a6, int a7, int a8, int a9, int a10,
+ int a11,
+ char* format, ...)
+{
+ va_list ap;
+
+ va_start(ap, format);
+ if (strlen (format) != 16 - 11)
+ abort ();
+ while (*format)
+ if (*format++ != to_hex (va_arg (ap, int)))
+ abort ();
+ va_end(ap);
+}
+
+#pragma ccuredvararg("f12", sizeof(int))
+void
+f12 (int a1, int a2, int a3, int a4, int a5,
+ int a6, int a7, int a8, int a9, int a10,
+ int a11, int a12,
+ char* format, ...)
+{
+ va_list ap;
+
+ va_start(ap, format);
+ if (strlen (format) != 16 - 12)
+ abort ();
+ while (*format)
+ if (*format++ != to_hex (va_arg (ap, int)))
+ abort ();
+ va_end(ap);
+}
+
+#pragma ccuredvararg("f13", sizeof(int))
+void
+f13 (int a1, int a2, int a3, int a4, int a5,
+ int a6, int a7, int a8, int a9, int a10,
+ int a11, int a12, int a13,
+ char* format, ...)
+{
+ va_list ap;
+
+ va_start(ap, format);
+ if (strlen (format) != 16 - 13)
+ abort ();
+ while (*format)
+ if (*format++ != to_hex (va_arg (ap, int)))
+ abort ();
+ va_end(ap);
+}
+
+#pragma ccuredvararg("f14", sizeof(int))
+void
+f14 (int a1, int a2, int a3, int a4, int a5,
+ int a6, int a7, int a8, int a9, int a10,
+ int a11, int a12, int a13, int a14,
+ char* format, ...)
+{
+ va_list ap;
+
+ va_start(ap, format);
+ if (strlen (format) != 16 - 14)
+ abort ();
+ while (*format)
+ if (*format++ != to_hex (va_arg (ap, int)))
+ abort ();
+ va_end(ap);
+}
+
+#pragma ccuredvararg("f15", sizeof(int))
+void
+f15 (int a1, int a2, int a3, int a4, int a5,
+ int a6, int a7, int a8, int a9, int a10,
+ int a11, int a12, int a13, int a14, int a15,
+ char* format, ...)
+{
+ va_list ap;
+
+ va_start(ap, format);
+ if (strlen (format) != 16 - 15)
+ abort ();
+ while (*format)
+ if (*format++ != to_hex (va_arg (ap, int)))
+ abort ();
+ va_end(ap);
+}
+
+main ()
+{
+ char *f = "0123456789abcdef";
+
+ f0 (f+0, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15);
+ f1 (0, f+1, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15);
+ f2 (0, 1, f+2, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15);
+ f3 (0, 1, 2, f+3, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15);
+ f4 (0, 1, 2, 3, f+4, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15);
+ f5 (0, 1, 2, 3, 4, f+5, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15);
+ f6 (0, 1, 2, 3, 4, 5, f+6, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15);
+ f7 (0, 1, 2, 3, 4, 5, 6, f+7, 7, 8, 9, 10, 11, 12, 13, 14, 15);
+ f8 (0, 1, 2, 3, 4, 5, 6, 7, f+8, 8, 9, 10, 11, 12, 13, 14, 15);
+ f9 (0, 1, 2, 3, 4, 5, 6, 7, 8, f+9, 9, 10, 11, 12, 13, 14, 15);
+ f10 (0, 1, 2, 3, 4, 5, 6, 7, 8, 9, f+10, 10, 11, 12, 13, 14, 15);
+ f11 (0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, f+11, 11, 12, 13, 14, 15);
+ f12 (0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, f+12, 12, 13, 14, 15);
+ f13 (0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, f+13, 13, 14, 15);
+ f14 (0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, f+14, 14, 15);
+ f15 (0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, f+15, 15);
+
+ exit (0);
+}
--- /dev/null
+void exit(int);
+void abort(void);
+
+// From c-torture
+/* Origin: Franz Sirl <Franz.Sirl-kernel@lauterbach.com> */
+//modified for stdarg.h
+
+#pragma ccuredvararg("debug", sizeof(union { int i; double d;}))
+
+#if __GNUC__ >= 3 || !defined __GNUC__
+
+#include <stdarg.h>
+inline void
+debug(int i1, int i2, int i3, int i4, int i5, int i6, int i7,
+ double f1, double f2, double f3, double f4, double f5, double f6,
+ double f7, double f8, double f9,
+ ...)
+#else
+//old version:
+#include <varargs.h>
+inline void
+debug(i1, i2, i3, i4, i5, i6, i7, f1, f2, f3, f4, f5, f6, f7, f8, f9, va_alist)
+ int i1, i2, i3, i4, i5, i6, i7;
+ double f1, f2, f3, f4, f5, f6, f7, f8, f9;
+ va_dcl
+
+#endif
+{
+ va_list ap;
+
+#if __GNUC__ >= 3 || !defined __GNUC__
+ va_start (ap, f9);
+#else
+ va_start (ap); //varargs.h
+#endif
+
+ if (va_arg (ap,int) != 8)
+ abort ();
+ if (va_arg (ap,int) != 9)
+ abort ();
+ if (va_arg (ap,int) != 10)
+ abort ();
+
+ va_end (ap);
+}
+
+int
+main(void)
+{
+ debug (1, 2, 3, 4, 5, 6, 7, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0,
+ 8.0, 9.0, 8, 9, 10);
+ exit (0);
+}
--- /dev/null
+int v2;
+
+F1()
+{
+ int v1,v2;
+ F2(v1);
+ F2(v2);
+}
+
+int v1;
+
+F2(int a) {
+ v1=0;
+ v2=0;
+}
--- /dev/null
+
+/* VA.C: The program below illustrates passing a variable
+ * number of arguments using the following macros:
+ * va_start va_arg va_end
+ * va_list va_dcl (UNIX only)
+ */
+
+#include <stdio.h>
+#include <stdarg.h>
+int average( int first, ... );
+union vararg_average {
+ int ints; /* We only pass ints to this one */
+};
+
+#include "testharness.h"
+
+int main( void )
+{
+ /* Call with 3 integers (-1 is used as terminator). */
+ if(average( 2, 3, 4, -1 ) != 3) E(1);
+ if(average( 5, 7, 9, 11, 13, -1 ) != 9) E(2);
+ if(average( -1 ) != 0) E(3);
+
+ SUCCESS;
+}
+
+
+
+/* Returns the average of a variable list of integers. */
+int average( int first, ... )
+{
+ int count = 0, sum = 0, i = first;
+ va_list marker;
+
+ va_start( marker, first ); /* Initialize variable arguments. */
+ while( i != -1 )
+ {
+ sum += i;
+ count++;
+ i = va_arg( marker, int);
+ }
+ va_end( marker ); /* Reset variable arguments. */
+ return( sum ? (sum / count) : 0 );
+}
+
+// Put this intentionally at the end
+#pragma ccuredvararg("average", sizeof(union vararg_average))
--- /dev/null
+#include <stdarg.h>
+#include <string.h>
+#include "../small1/testharness.h"
+
+//Test for OO and varargs. These features are not supported,
+// so this is not in the regression suite.
+
+#ifndef CCURED
+#define __RTTI
+#endif
+
+typedef struct parent {
+ int *f1;
+} Parent;
+
+#pragma ccured_extends("Schild", "Sparent")
+
+typedef struct child {
+ int *f1;
+ int f2;
+} Child;
+
+// Expects a Child*, then a Parent*, then a Child
+void vararg(int x, ...);
+
+int main() {
+ int x = 5;
+ Child c = {&x, 2};
+ void* __RTTI cp = &c;
+ vararg(4, cp, cp, c);
+ SUCCESS;
+}
+
+
+void vararg(int x, ...) {
+ va_list marker;
+ va_start(marker, x);
+
+ Child * cp = va_arg(marker, Child*);
+ if (cp->f2 != 2) E(10);
+
+ void * __RTTI vp = va_arg(marker, void* __RTTI);
+ Parent* p = vp;
+ if (*(p->f1) != 5) E(11);
+
+ Child c = va_arg(marker, Child);
+ if (c.f2 != 2) E(12);
+
+}
+
--- /dev/null
+
+/* A test to see if we can split the last argument in a vararg function */
+#include <stdarg.h>
+
+// Takes just ints
+#pragma ccuredvararg("myvararg", sizeof(int));
+
+
+int myvararg(char *format, ...) {
+ // Make sure the format is a FSEQ
+ va_list ap;
+ int sum = 0;
+
+ va_start(ap, format);
+ // Get as many ints as there are letters in the string
+ while(*format ++) {
+ sum += va_arg(ap, int);
+ }
+ va_end(ap);
+
+ return sum;
+}
+
+
+int main() {
+ if(10 != myvararg("1234", 1, 2, 3, 4))
+ return 1;
+
+ return 0;
+
+}
--- /dev/null
+
+#include <stdio.h>
+#include <stdarg.h>
+
+struct vararg_sum {
+ int ints; /* We only pass ints to this one */
+ int *pints;
+};
+#pragma ccuredvararg("sum", sizeof(struct vararg_sum))
+
+int sum( int descriptor, ... );
+
+#include "testharness.h"
+
+int main( void )
+{
+ int i1 = 5;
+ int i2 = 7;
+
+ /* Call with 3 integers (-1 is used as terminator). */
+ if(sum(0xA, 3, &i1, 7, &i2, 0) != 22) E(1);
+
+ SUCCESS;
+}
+
+
+
+/* Returns the average of a variable list of integers and pointers to
+ * integers. Each bit in the descriptor says what type is the corresponding
+ * argument (1 for pointer). 0 is used as a terminator. */
+int sum( int descriptor, ... )
+{
+ int sum = 0;
+ va_list marker;
+
+ va_start( marker, descriptor ); /* Initialize variable arguments. */
+ while(1) {
+ int next;
+ if (descriptor & 1) {
+ next = * va_arg (marker, int*);
+ } else {
+ next = va_arg(marker, int);
+ }
+ if(!next) return sum;
+ sum += next;
+ descriptor >>=1;
+ }
+ va_end(marker);
+}
--- /dev/null
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <ctype.h>
+#include <stdarg.h>
+
+#include "testharness.h"
+
+char* progname = "vararg3";
+int showmessages = 1;
+
+#pragma ccuredvararg("my_vfprintf", printf(2))
+int my_vfprintf(FILE *stream, char const *format, va_list args );
+
+#pragma ccuredvararg("pm_error", printf(1))
+void pm_error( char* format, ... ) {
+ va_list args;
+
+ va_start( args, format );
+
+ fprintf( stderr, "%s: ", progname );
+ (void) my_vfprintf( stderr, format, args );
+ fputc( '\n', stderr );
+ va_end( args );
+}
+
+
+/* Portable mini-vfprintf, for systems that don't have either vfprintf or
+** _doprnt. This depends only on fprintf. If you don't have fprintf,
+** you might consider getting a new stdio library.
+*/
+
+int my_vfprintf(FILE *stream, char const *format, va_list vargs ) {
+ int n;
+ char* ep;
+ char fchar;
+ char tformat[512];
+ int do_long;
+ int i;
+ long l;
+ unsigned u;
+ unsigned long ul;
+ char* s;
+ double d;
+
+ n = 0;
+ while ( *format != '\0' )
+ {
+ if ( *format != '%' )
+ { /* Not special, just write out the char. */
+ (void) putc( *format, stream );
+ ++n;
+ ++format;
+ }
+ else
+ {
+ do_long = 0;
+ ep = format + 1;
+
+ /* Skip over all the field width and precision junk. */
+ if ( *ep == '-' )
+ ++ep;
+ if ( *ep == '0' )
+ ++ep;
+ while ( isdigit( *ep ) )
+ ++ep;
+ if ( *ep == '.' )
+ {
+ ++ep;
+ while ( isdigit( *ep ) )
+ ++ep;
+ }
+ if ( *ep == '#' )
+ ++ep;
+ if ( *ep == 'l' )
+ {
+ do_long = 1;
+ ++ep;
+ }
+
+ /* Here's the field type. Extract it, and copy this format
+ ** specifier to a temp string so we can add an end-of-string.
+ */
+ fchar = *ep;
+ (void) strncpy( tformat, format, ep - format + 1 );
+ tformat[ep - format + 1] = '\0';
+
+ /* Now do a one-argument fprintf with the format string we have
+ ** isolated.
+ */
+ switch ( fchar )
+ {
+ case 'd':
+ if ( do_long )
+ {
+ l = va_arg( vargs, long );
+ n += fprintf( stream, tformat, l );
+ }
+ else
+ {
+ i = va_arg( vargs, int );
+ n += fprintf( stream, tformat, i );
+ }
+ break;
+
+ case 'o':
+ case 'x':
+ case 'X':
+ case 'u':
+ if ( do_long )
+ {
+ ul = va_arg( vargs, unsigned long );
+ n += fprintf( stream, tformat, ul );
+ }
+ else
+ {
+ u = va_arg( vargs, unsigned );
+ n += fprintf( stream, tformat, u );
+ }
+ break;
+
+ case 'c':
+ i = (char) va_arg( vargs, int );
+ n += fprintf( stream, tformat, i );
+ break;
+
+ case 's':
+ s = va_arg( vargs, char* );
+ n += fprintf( stream, tformat, s );
+ break;
+
+ case 'e':
+ case 'E':
+ case 'f':
+ case 'g':
+ case 'G':
+ d = va_arg( vargs, double );
+ n += fprintf( stream, tformat, d );
+ break;
+
+ case '%':
+ (void) putc( '%', stream );
+ ++n;
+ break;
+
+ default:
+ return -1;
+ }
+
+ /* Resume formatting on the next character. */
+ format = ep + 1;
+ }
+ }
+ return n;
+ }
+
+
+
+int main() {
+ pm_error("Cucu %s", "Bau");
+ SUCCESS;
+}
--- /dev/null
+
+#include <stdio.h>
+#include <stdarg.h>
+
+union vararg_sum {
+ int ints; /* We only pass ints to this one */
+ int *pints;
+};
+
+
+#pragma ccuredvararg("sum", sizeof(union vararg_sum))
+int sum( int descriptor, ... );
+
+// Argument 0 is a valist.
+#pragma ccuredvararg("sum_valist", sizeof(union vararg_sum))
+int sum_valist(va_list args, int descriptor);
+
+#include "testharness.h"
+
+int main( void )
+{
+ int i1 = 5;
+ int i2 = 7;
+
+ /* Call with 3 integers (-1 is used as terminator). */
+ if(sum(0xA, 3, &i1, 7, &i2, 0) != 22) E(1);
+
+ SUCCESS;
+}
+
+
+
+/* Returns the average of a variable list of integers and pointers to
+ * integers. Each bit in the descriptor says what type is the corresponding
+ * argument (1 for pointer). 0 is used as a terminator. */
+int sum( int descriptor, ... )
+{
+ int sum;
+ va_list marker;
+
+ va_start( marker, descriptor ); /* Initialize variable arguments. */
+ sum = sum_valist(marker, descriptor);
+ va_end(marker);
+ return sum;
+}
+
+int sum_valist(va_list args, int descriptor) {
+ int sum = 0;
+ while(1) {
+ int next;
+ if (descriptor & 1) {
+ next = * va_arg (args, int*);
+ } else {
+ next = va_arg(args, int);
+ }
+ if(!next) return sum;
+ sum += next;
+ descriptor >>=1;
+ }
+ return sum;
+}
--- /dev/null
+#include "testharness.h"
+
+
+/*
+This file is a test for variable argument functions, where the call to
+print is made in a separate function, talking. This checks to see if we
+can retrieve the arguments in a variable argument function if we call a
+separate function.
+*/
+
+#include <stdarg.h>
+#include <stddef.h>
+#include <stdio.h>
+#include <fcntl.h>
+#include <string.h>
+
+#pragma ccuredvararg("talking", printf(2))
+void talking(FILE *out, char *s, ...);
+
+int main(int argc, char** argv) {
+ int x, y;
+ char* s;
+ char buff[128];
+ float f = 5.0;
+ double d = 10.0;
+
+ FILE *out = fopen("vararg.out", "w+");
+ if(! out) E(1);
+
+ x = 5;
+ y = 1;
+ s = "hello";
+ talking(out, "%d %3.1f %3.1f\n", x, f, d);
+ fseek(out, 0, SEEK_SET);
+ fread(buff, 1, sizeof(buff)-1, out);
+ fclose(out);
+ buff[10] = '\0';
+ printf("Should be 5 5.0 10.0: %s\n", buff);
+ if(strncmp(buff, "5 5.0 10.0", 10)) E(2);
+ SUCCESS;
+}
+
+void talking(FILE *out, char* s, ...) {
+ va_list ap;
+ va_start(ap, s);
+ vfprintf(out, s, ap);
+ va_end(ap);
+}
--- /dev/null
+// Original from c-torture
+//modified for stdarg.h
+
+#include "testharness.h"
+
+typedef double TYPE;
+
+#pragma ccuredvararg("vafunction", sizeof(union { TYPE d; }))
+
+#if __GNUC__ >= 3 || !defined __GNUC__
+//new version:
+#include <stdarg.h>
+void vafunction (TYPE dummy1, TYPE dummy2, ...)
+#else
+//old version:
+#include <varargs.h>
+void vafunction (dummy1, dummy2, va_alist)
+ TYPE dummy1, dummy2;
+ va_dcl
+#endif
+{
+ va_list ap;
+
+#if __GNUC__ >= 3 || !defined __GNUC__
+ va_start (ap, dummy2);
+#else
+ va_start (ap); //varargs.h
+#endif
+ if (dummy1 != 888.) exit(1);
+ if (dummy2 != 999.) exit(2);
+ if (va_arg (ap, TYPE) != 1.) exit(3);
+ if (va_arg (ap, TYPE) != 2.) exit(4);
+ if (va_arg (ap, TYPE) != 3.) exit(5);
+ if (va_arg (ap, TYPE) != 4.) exit(6);
+ if (va_arg (ap, TYPE) != 5.) exit(7);
+ if (va_arg (ap, TYPE) != 6.) exit(8);
+ if (va_arg (ap, TYPE) != 7.) exit(9);
+ if (va_arg (ap, TYPE) != 8.) exit(10);
+ if (va_arg (ap, TYPE) != 9.) exit(11);
+ va_end(ap);
+}
+
+
+int main (void)
+{
+ vafunction( 888., 999., 1., 2., 3., 4., 5., 6., 7., 8., 9. );
+
+ SUCCESS;
+}
--- /dev/null
+#include <stdio.h>
+#include <stdarg.h>
+
+// abstracted from bind
+
+#define ISC_FORMAT_PRINTF(fmt, args) __attribute__((__format__(__printf__, fmt, args)))
+
+struct mystruct {
+ int i;
+ char *s;
+};
+
+#define CCURED_PRINTF(fmt) __attribute__((__ccuredvararg__(sizeof(struct mystruct))))
+typedef struct dns_rdatacallbacks {
+ /*
+ * dns_load_master calls this when it has rdatasets to commit.
+ */
+ long add;
+ /*
+ * dns_load_master / dns_rdata_fromtext call this to issue a error.
+ */
+ void (CCURED_PRINTF(3) *error)(struct dns_rdatacallbacks *,
+ const char * , ...)
+ ISC_FORMAT_PRINTF(2,3) ;
+ /*
+ * dns_load_master / dns_rdata_fromtext call this to issue a warning.
+ */
+ void (CCURED_PRINTF(3) *warn)(struct dns_rdatacallbacks *,
+ const char * , ...)
+ ISC_FORMAT_PRINTF(2,3) ;
+
+ /*
+ * Private data handles for use by the above callback functions.
+ */
+ void *add_private;
+ void *error_private;
+ void *warn_private;
+} dns_rdatacallbacks_t;
+
+static void
+stdio_error_warn_callback(dns_rdatacallbacks_t *, const char *, ...)
+ ISC_FORMAT_PRINTF(2, 3);
+
+static void
+stdio_error_warn_callback(dns_rdatacallbacks_t *callbacks,
+ const char *fmt, ...)
+{
+ va_list ap;
+
+// UNUSED(callbacks);
+
+ va_start(ap, fmt);
+ vfprintf(stderr, fmt, ap);
+ va_end(ap);
+ fprintf(stderr, "\n");
+}
+
+void
+dns_rdatacallbacks_init(dns_rdatacallbacks_t *callbacks) {
+ callbacks->error = stdio_error_warn_callback;
+ callbacks->warn = stdio_error_warn_callback;
+}
+
+int foo(dns_rdatacallbacks_t *ptr) {
+ stdio_error_warn_callback(ptr,"Does it work %s","if we call it directly?");
+ ptr->warn(ptr,"Warning Int %d\n",55);
+ ptr->warn(ptr,"Warning String %s\n","mystring");
+}
--- /dev/null
+#include "testharness.h"
+#include <stdio.h>
+#include <stdarg.h>
+
+// A test case with automatic vararg descriptors
+struct foo {
+ int f;
+};
+// This will be passed char*, int*, int and struct foo*
+#define AN_INT 0
+#define AN_STR 1
+#define AN_INTPTR 2
+#define AN_FOOPTR 3
+
+void myva1(int many, ...);
+
+int main() {
+ struct foo x = { 1 } , y = { 2 };
+ struct foo *px = &x, *py = &y;
+
+ myva1(4, AN_INT, 5,
+ AN_STR, "hello",
+ AN_STR, "world",
+ AN_INTPTR, &px->f);
+ SUCCESS;
+}
+
+
+void myva1(int many, ...) {
+ int count;
+ va_list marker;
+
+ va_start(marker, many);
+ for(count=0;count<many;count++) {
+ int tag = va_arg(marker, int);
+ switch(tag) {
+ case AN_INT:
+ {
+ int data = va_arg(marker, int);
+ printf("An_int: %d\n", data);
+ break;
+ }
+ case AN_STR:
+ {
+ char* data = va_arg(marker, char*);
+ printf("An_str: %s\n", data);
+ break;
+ }
+ case AN_INTPTR:
+ {
+ int* data = va_arg(marker, int*);
+ printf("An_intptr: %x (%d)\n", (long)data, *data);
+ break;
+ }
+ case AN_FOOPTR:
+ {
+ struct foo* data = va_arg(marker, struct foo*);
+ printf("An_fooptr: %d\n", data->f);
+ break;
+ }
+ }
+ }
+}
--- /dev/null
+/* An example with various kinds of pointers */
+extern void* copy(void *);
+
+
+typedef struct list {
+ struct list *next; // We'll use this safely
+ char *data;
+} LIST;
+
+#pragma ccuredpoly("copy")
+void *copy(void *x) {
+ return x;
+}
+
+int ga[8];
+
+int **w;
+
+int main() {
+ int x;
+ int * px = &x;
+ int * * qx = & px; // SEQ to FSEQ to int
+
+ int * * c = copy(qx);
+
+ if(x) {
+ px = & ga[5];
+ } else {
+ px ++;
+ }
+ c += *px;
+
+ {
+ char * pw = &w;
+ char * * cpw = copy(& pw);
+
+ x = * * cpw;
+ }
+
+ {
+ int * intcast = (int *)6;
+ *px = *intcast;
+ }
+
+ {
+ int ** pp1, *p2;
+ void *v1 = pp1;
+ void *v2 = p2;
+ v1 = v2;
+ }
+
+ {
+ void *vi1 = 5;
+ void *vi2 = vi1;
+ }
+
+ {
+ void *vi3 = 5;
+ void *vi4 = vi3;
+ int *p3 = vi4;
+ int **pp4 = vi4;
+ }
+
+
+ {
+ int *p;
+ int **q;
+ void **b5;
+ void **b6 = b5;
+ p = *b5;
+ *b6 = q;
+ }
+}
+
+
+
+
+
--- /dev/null
+/* version.c: version definition for the ed editor. */
+/* ed line editor.
+ Copyright (C) 1993, 1994 Andrew Moore, Talke Studio
+ All Rights Reserved
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+*/
+
+static char *rcsid = "@(#)$Id: version.c 192 2001-02-17 22:56:13Z necula $";
+
+char version_string[] = "GNU ed version 0.2";
--- /dev/null
+#include <stdio.h>
+#include <stdlib.h>
+
+void f(int x, int y) {
+ printf("wow\n");
+}
+
+void g(int x, int y) {
+ printf("yippie!\n");
+}
+
+#define FUNC(x, y) ({ f((x), (y)); g((x), (y)); })
+
+#define NUMBER 1
+
+int k(int a) {
+
+ int x, y, z;
+ z = 0;
+ FUNC(NUMBER, z);
+ return 1;
+}
+
+int main(int argc, char** argv) {
+ k(5);
+ return 0;
+}
--- /dev/null
+#include <stdio.h>
+
+int main(int argc, char** argv) {
+
+ int (* badfunc) ();
+
+ badfunc = puts;
+
+ (*badfunc)("hello, nice to meet you.");
+
+ return 0;
+}
--- /dev/null
+extern void* malloc(unsigned int);
+
+typedef struct list {
+ void* data;
+ struct list * next;
+} LIST;
+
+
+extern void* listfind(LIST *l, int nth);
+extern void* listinsert(LIST **, int nth, void *elem);
+
+int listadd(LIST * * pl, void* elem) {
+ LIST *n = (LIST*)malloc(sizeof(LIST));
+ n->data = elem;
+ n->next = *pl;
+ return pl;
+}
+
+LIST * glob = 0;
+
+int add5(LIST *cell) {
+ cell->data = (void*)cell;
+ listadd(& glob, (void*)add5);
+
+}
+
+
+int get1(void) {
+ LIST *l = (LIST*)listfind(glob, 5);
+}
--- /dev/null
+//test for using a typedef as void.
+typedef void tVoid;
+
+void pimInit(void);
+
+tVoid pimInit(tVoid)
+{
+ return;
+}
+
+int main() {
+ pimInit();
+ return 0;
+}
--- /dev/null
+#include <stdio.h>
+#include <stdarg.h>
+#include "testharness.h"
+
+static void
+ns_client_logv(void *client, void *category,
+ void *module, int level, const char *fmt, va_list ap)
+{
+ char msgbuf[2048];
+ char peerbuf[2048];
+
+ vsnprintf(msgbuf, sizeof(msgbuf), fmt, ap);
+ puts(msgbuf);
+}
+
+// You must add this pragma to prevent CCured from infering a bad
+// descriptor
+#pragma ccuredvararg("ns_client_log", printf(5))
+void
+ns_client_log(void *client, void *category, void *module, int level,
+ const char *fmt, ...)
+{
+ va_list ap;
+
+ va_start(ap,fmt);
+ ns_client_logv(client,category,module,level,fmt,ap);
+ va_end(ap);
+}
+
+int main()
+{
+ int i;
+
+ ns_client_log(NULL, NULL, NULL, 0,
+ "Hello, %s! 2+2=%d\n", "world", 4);
+
+ return 0;
+}
--- /dev/null
+const int a = 3;
+
+const int *f() {
+ return &a;
+}
+
+int main() {
+ // Make sure we keep the cast from "const int*" to "int*"
+ // If it's dropped, gcc emits a warning.
+ int *p = (int*) f();
+ *p = 4;
+ return *p;
+}
--- /dev/null
+#include "testharness.h"
+
+
+void croak() __attribute__((noreturn));
+void die() __attribute__((noreturn));
+
+
+void terminate(int) __attribute__((noreturn));
+
+void terminate(int frog)
+{
+ if (frog)
+ croak();
+ else
+ die();
+}
+
+
+int main()
+{
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+
+
+/* What's going wrong here? CIL's printing routines try to eliminate
+ some trivial gotos. In this test program, the "goto successor"
+ statement is useless and therefore doesn't get printed out.
+ However, the "successor:" label is left behind. This yields a
+ warning about a label being defined but not used. */
+
+
+int branch(int selector)
+{
+ if (selector)
+ return 1;
+ else
+ goto successor;
+
+ successor:
+ return 0;
+}
+
+
+int main()
+{
+ branch(0);
+ SUCCESS;
+}
--- /dev/null
+#include <wchar.h>
+#include "testharness.h"
+
+// NUMERRORS 4
+
+
+
+int main(){
+ unsigned char c1[] = "\7";
+ unsigned char c2[] = "\77";
+
+ //character too big:
+ unsigned char c3[] = "\777"; //ERROR(1): too big
+
+ //OK, because only the first three digits are part of the escape.
+ unsigned char c4[] = "\1111";
+
+ //OK, because it's a wide string.
+ wchar_t c5[] = L"\777";
+
+#if defined _MSVC || defined __CYGWIN__
+ // Assumes sizeof(wchar_t) == 16
+ wchar_t w1[] = L"\x1";
+ wchar_t w2[] = L"\x1234";
+ wchar_t w3[] = L"\x12345"; //ERROR(2): too big
+ wchar_t w4[] = L"\xcdefg"; //OK, because g is not a hex digit.
+#else
+ // Assumes sizeof(wchar_t) == 32
+ wchar_t w1[] = L"\x1";
+ wchar_t w2[] = L"\x12345678";
+ wchar_t w3[] = L"\x123456789"; //ERROR(2): too big
+ wchar_t w4[] = L"\x89abcdefg"; //OK, because g is not a hex digit.
+#endif
+
+ //type mismatches in array initialization:
+ char s1[] = L"Hi"; //ERROR(3): a wide string literal
+ wchar_t s2[] = "Hi"; //ERROR(4): a string literal
+
+ SUCCESS;
+}
--- /dev/null
+#include "testharness.h"
+#include <stddef.h>
+
+int main() {
+ wchar_t *wbase = L"Hello" L", world";
+ char * w = (char *)wbase;
+ char * s = "Hello" ", world";
+ int i;
+
+ // See if this is little or big endian
+ short foo = 0x0011;
+ char little_endian = (int) * (char*)&foo;
+
+ for (i=0; i < 10; i++) {
+ if (w[i * sizeof(wchar_t)] != (little_endian ? s[i] : 0)) {
+ E(1);
+ }
+ if (w[i * sizeof(wchar_t) + (sizeof(wchar_t)-1)]
+ != (little_endian ? 0 : s[i])) {
+ E(2);
+ }
+ }
+ SUCCESS;
+}
--- /dev/null
+//# 1 "wchar1.c"
+//# 1 "testharness.h" 1
+extern int printf(const char *, ...);
+extern void exit(int);
+
+
+
+
+
+//# 1 "wchar1.c" 2
+
+//# 1 "/usr/include/stddef.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+//# 1 "/usr/include/machine/ansi.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+typedef int __attribute__((__mode__(__DI__))) __int64_t;
+typedef unsigned int __attribute__((__mode__(__DI__))) __uint64_t;
+
+
+
+
+
+
+
+
+
+
+typedef __signed char __int8_t;
+typedef unsigned char __uint8_t;
+typedef short __int16_t;
+typedef unsigned short __uint16_t;
+typedef int __int32_t;
+typedef unsigned int __uint32_t;
+
+typedef int __intptr_t;
+typedef unsigned int __uintptr_t;
+
+
+
+
+
+typedef union {
+ char __mbstate8[128];
+ __int64_t _mbstateL;
+} __mbstate_t;
+
+
+# 41 "/usr/include/stddef.h" 2 3
+
+
+typedef int ptrdiff_t;
+
+
+
+typedef int rune_t;
+
+
+
+
+
+typedef unsigned int size_t;
+
+
+
+
+typedef int wchar_t;
+
+
+
+
+
+
+
+
+
+
+# 2 "wchar1.c" 2
+
+
+int main() {
+ wchar_t *wbase = L"Hello" L", world";
+ char * w = (char *)wbase;
+ char * s = "Hello" ", world";
+ int i;
+
+ for (i=0; i < 10; i++) {
+ if (w[i * sizeof(wchar_t)] != s[i]) {
+ { printf("Error %d\n", 1 ); exit( 1 ); } ;
+ }
+ if (w[i * sizeof(wchar_t)+ 1] != 0) {
+ { printf("Error %d\n", 2 ); exit( 2 ); } ;
+ }
+ }
+ { printf("Success\n"); exit(0); } ;
+}
--- /dev/null
+#include "testharness.h"
+
+int main() {
+ long w = L'W'; // wide character constant
+ char * s = "W";
+ int i;
+
+ if (w != s[0]) { E(1); }
+ SUCCESS;
+
+}
--- /dev/null
+#include "testharness.h"
+
+int check(char *p1, char *p2, int size, int code) {
+ int i;
+ for (i=0; i<size; i++ ){
+ if (p1[i] != p2[i]) {
+ E(code);
+ }
+ }
+}
+
+int main() {
+ long l1 = '\001\002a\003';
+ char * s1 = "\003a\002\001";
+
+ long l2 = 'abc';
+ char * s2 = "cba";
+
+ long l3 = 'polF';
+ char * s3 = "Flop";
+
+ long l4 = '\r\n';
+ char * s4 = "\n\r";
+
+ check((char *)&l1, s1, 4, 1);
+ check((char *)&l2, s2, 3, 2);
+ check((char *)&l3, s3, 4, 3);
+ check((char *)&l4, s4, 2, 4);
+
+ SUCCESS;
+}
--- /dev/null
+#include <stdio.h>
+#include <wchar.h>
+#include "testharness.h"
+
+/*
+void printchars(wchar_t* str)
+{
+ while (1){
+ printf("0x%x", *str);
+ if (*str == 0) {
+ printf("\n\n");
+ return;
+ }
+ printf(", ");
+ str++;
+ }
+}
+*/
+
+int main(){
+ wchar_t wa[] = L"H" L"i\xabcd" "e";
+ // wa == L"Hi\xabcd\x65". Since 'e' was in a separate token from \xabcd,
+ //it is not part of the escape. Instead, it's a regular old 'e' (ascii 65h).
+
+ //wa should equal one of these byte strings:
+ char *a_16bit = "H\0i\0\xcd\xab\x65\0";
+ char *a_32bit = "H\0\0\0i\0\0\0\xcd\xab\0\0\x65\0\0\0";
+
+ wchar_t wb[] = L"Hi\300";
+ unsigned char b[] = "Hi\300";
+
+ int i;
+ if (sizeof(wchar_t) == 2) // 16 bits
+ {
+ char* tmp = (char*)wa;
+ for (i = 0; i < 4*2; i++) { //byte-for-byte compare
+ if (tmp[i] != a_16bit[i]) E(1);
+ }
+ }
+ else if (sizeof(wchar_t) == 4) // 32 bites
+ {
+ char* tmp = (char*)wa;
+ for (i = 0; i < 4*4; i++) { //byte-for-byte compare
+ if (tmp[i] != a_32bit[i]) E(2);
+ }
+ }
+ else
+ {
+ E(3); //how big is wchar_t??
+ }
+
+ for (i = 0; i < 4; i++) { //char-to-wchar_t compare
+ if (b[i] != (unsigned char)wb[i]) E(4);
+ }
+
+ //printchars(wa);
+ //printchars(wb);
+
+ {
+ //Test character constants.
+ wchar_t c = L'\xabcd';
+ unsigned short s = 0xABCD;
+ if (s != c) E(10);
+ int c2 = L'ac'; //wide constants are 16 bits wide, so truncate this to 'c'.
+ if (c2 != L'c') E(11);
+ }
+
+ SUCCESS;
+}
--- /dev/null
+#include <wchar.h>
+#include "testharness.h"
+
+//matth: some lexer bugs that I haven't had time to fix
+
+
+int main(){
+ //BUG: the "i\xabcd" has no L in front, so we treat it like a normal string,
+ // and can't handle the big value.
+
+ wchar_t a[] = L"H" "i\xabcd";
+ // should be the same as:
+ wchar_t b[] = L"Hi\xabcd";
+
+
+ int i;
+ for (i = 0; i < 4; i++){
+ if (a[i] != b[i]) E(i);
+ }
+
+ SUCCESS;
+}
--- /dev/null
+#include <wchar.h>
+#include "testharness.h"
+
+int main()
+{
+ wchar_t aa[] = L"A\xabcd"; // 2 wide chars
+ wchar_t ba[] = L"A\\xabcd"; // 7 wide chars
+ wchar_t *ap = L"A\xabcd";
+ wchar_t *bp = L"A\\xabcd";
+ char *p1, *p2;
+ int i;
+
+ if (wcslen(aa) != wcslen(ap)) { E(1); }
+ if (wcslen(ba) != wcslen(bp)) { E(2); }
+ if (wcslen(aa) == wcslen(ba)) { E(3); }
+ if (wcslen(ap) == wcslen(bp)) { E(4); }
+
+ p1 = aa;
+ p2 = ap;
+ for (i=0; i<2 * sizeof(wchar_t); i++) {
+ if (p1[i] != p2[i]) { E(5); }
+ }
+ p1 = ba;
+ p2 = bp;
+ for (i=0; i<7 * sizeof(wchar_t); i++) {
+ if (p1[i] != p2[i]) { E(6); }
+ }
+
+ if (wcscmp(aa,ap) != 0) { E(7); }
+ if (wcscmp(ba,bp) != 0) { E(8); }
+ if (wcscmp(aa,ba) == 0) { E(9); }
+ if (wcscmp(ap,bp) == 0) { E(10); }
+
+ SUCCESS;
+}
--- /dev/null
+#include <wchar.h>
+#include "testharness.h"
+
+int main()
+{
+ wchar_t aa[] = L"\""; // 1 wide char
+ wchar_t *ap = L"\"";
+ char *p1, *p2;
+ int i;
+
+ if (wcslen(aa) != wcslen(ap)) { E(1); }
+ p1 = aa;
+ p2 = ap;
+ for (i=0; i<2 * sizeof(wchar_t); i++) {
+ if (p1[i] != p2[i]) { E(2); }
+ }
+ if (wcscmp(aa,ap) != 0) { E(3); }
+
+ SUCCESS;
+}
--- /dev/null
+#include <stdio.h>
+
+void f(s1, s2) char *s1, *s2;
+{
+ printf(s1, s2);
+}
+
+int main(int argc, char** argv) {
+ f("hello %S!\n", "wow");
+ f("hello there: %s!\n", "wow");
+ f("hello again!\n");
+}
+
--- /dev/null
+typedef struct {
+ int *foo;
+ int bar;
+} wildstruct;
+
+int makewild(void *x) {
+ return *((int *)x);
+}
+
+int main() {
+ wildstruct w;
+ int p = 55, q;
+ int *ptr;
+
+ makewild(&w);
+
+ w.foo = &p;
+ w.foo = 0;
+
+ ptr = w.foo;
+
+ q = *ptr;
+
+ return q;
+}
--- /dev/null
+hola
+*cil.c
+*infer.c
+*box.c
+*cabs.c
+*.pdb
+*.i
+*_ppp.c
+*.origi
+*_all.c
+*.pdb
+*.ilk
+*cured.c
+*.cured.s
+*_comb.c
+*.browser
+*-tmp.*
+comb
+ocamlprof*
+voidfree
+recursetype
+rmunused
+regbeforeassign
+partialbracket
+enuminit
+staticafternostorage
+voidfree
+simplewild
+multiplestatics
+*.log
+ptrtolocal
+tprintf
+ptrinint
+ptrmanip
+twoprintfs
+regthenprintf
+nested
+debug_table
+s59
+tmp.c
+tmp
+putc
+bogus_redef
+cof
+lexnum
+funcptr
+ptrkinds
+transpunion
+sockaddr
+oldstyle
+typeof
+asmfndecl
+funcname
+qsort
+memset_sizeof
+jpeg_compress_struct
+funcptr2
+argv
+ctype
+heapify
+xlsubr
+baddef
+baddef.rept
+litstruct
+cmpzero
+a.out
+ioctl
+stralloc
+segfault
+strpbrk
+fgets
+memcpy
+open
+constdecl
+mknod
+realloc
+strchr
+getopt
+scary
+scary*.s
+*.s
+ope.m
+*cured.c
+*.optim.c
+*.stackdump
+fmtstr
+bisonerror
+errorinfn
+globalprob
+invalredef
+invalredef2
+kernel?
+main
+memberofptr
+xcheckers
+unionassign
+models
+test-bad-tmp*
+alloca2
+poly
+getpwnam
+reply
+stackptrptr
+popen
+execv
+sockets
+printfllong
+stat
+replydirname
+boundaries
+constfold
+hufftable
+scanf
+rusage
+bzero
+memset_int
+rmunused2
+gimpdouble
+struct_cs
+retptr
+arraytags
+strloop2
+mode_sizes
+*-tmp.c
+*tmp
+*.tmp.exe
+test-bad.err
+brlock
+test-bad.out
+qsort_wild
+regparm0
+unscomp
+*optimcured*
+mergestruct
+trace
+globstackptr
+complex_float
+mergeinline
+ehstack
+setjmp
+suppress_optim
+name-capture-bitand
+dblarg.int
+wildfun2
+gdb.log
+decl_inl
+tagfile
+.gdbinit
+monthname
+floatarg
+structs_edg_stl_ccuredlib_test
+ptrarith
+chararr1
+thing
+chararr2
+strerror1
+merged-once.c
+merged-twice.c
+funptr1
+union5
+arrayexpand
+byteprintf
+null_pointer_field
+bufferlinegetter
+checkinit
+voidstarint
+signal
+*.out
+seq_align_malloc
+bsearch
+readv
+getaddrinfo
+sockunion
+fseq1
+closefunc
+addr
+polystruct-tmp
+glob
+sin_zero
+bloop
+funcptr3
+merge-ar
--- /dev/null
+# Makefile in small2
+
+hola: hola.c
+ gcc -g -Wall -o hola hola.c
+ ./hola
+
+holabox: holabox.c
+ gcc -g -Wall -o holabox -D_GNUCC -Dx86_LINUX -DBEFOREBOX \
+ -I /home/scott/wrk/safec/cil/lib \
+ ./holabox.c \
+ /home/scott/wrk/safec/cil/lib/../obj/safecdebuglib.a
+
+# sm: clean-cvsignore is a script of mine, I make it ok to fail below
+clean:
+ rm -f *.o *_all.c *cil.c *box.c *_ppp.c *.i *.origi *infer.c *cabs.c
+ rm -f comb enuminit multiplestatics staticafternostorage
+ rm -f hola partialbracket ptrtolocal rmunused recursetype
+ rm -f regbeforeassign simplewild tprintf voidfree
+ rm -f *.exe *.obj *.pdb *.ilk
+ rm -f __scalar2pointer.txt ocamlprof.dump "#"*
+ rm -f *cured.c *.optim.c *_comb.c
+ rm -rf *.browser
+ clean-cvsignore || true
+
--- /dev/null
+
+typedef struct {
+ volatile unsigned int lock;
+} spinlock_t;
+
+typedef struct {
+} __attribute__((__aligned__((1 << ((5) ) ) ))) irq_desc_t;
+extern irq_desc_t irq_desc [224 ];
+
+
+
+int main () {
+ return 0;
+}
--- /dev/null
+
+//KEEP baseline: success
+
+const unsigned char G___152598331 = 0;
+void f() {
+ const unsigned char G___152598331 = 0;
+}
+
+//This suffix is so long that it will be alpha-renamed as G___1525983317___0
+const unsigned char G___1525983317 = 0;
+void f2() {
+ const unsigned char G___1525983317 = 0;
+}
+
+const unsigned char G___1525983317999999999994352352523523993424999 = 0;
+void f3() {
+const unsigned char G__1525983317999999999994352352523523993424999 = 0;
+}
+
+
+const unsigned char G___999999999 = 0; //KEEP overflow:error = Encountered a variable name containing ___ and many digits
+void f4() {
+ const unsigned char G___152598331 = 0;
+}
+
+int main() {
+ return 0;
+}
--- /dev/null
+// arrayinit.c
+// char array with initializer exactly filling it, not including NUL
+// from sac at stevechamberlain dot com
+
+#include <assert.h> // assert
+
+char a[5]="12345"; // CIL prior to 8/01/03 16:17 yielded a warning
+char b[5]="1234"; // 5th char is a NUL
+char c[]="12345"; // 6th char is a NUL
+char d[5]="123"; // 4th, 5th char are NULs
+//char e[5]="123456"; // too big! (yields a warning)
+
+int main()
+{
+ assert(sizeof(a) / sizeof(a[0]) == 5);
+ return 0;
+}
--- /dev/null
+#include "../small1/testharness.h"
+
+// NUMERRORS 8
+
+int g1[-1]; // ERROR(1):Length of array is negative
+
+#define MAXINT (1ull << ((8 * sizeof(int)) - 1))
+
+int g1[ MAXINT / sizeof(int) ]; //ERROR(2):Length of array is too large
+typedef int g1[ MAXINT / sizeof(int) - 1 ];//ERROR(3):Error 3
+
+char g1[ MAXINT / sizeof(char) ]; //ERROR(4):Length of array is too large
+typedef char g1[ MAXINT / sizeof(char) - 1 ]; //ERROR(5):Error 5
+
+double g1[ MAXINT / sizeof(double) ]; //ERROR(6):Length of array is too large
+typedef double g1[ MAXINT / sizeof(double) - 1 ]; //ERROR(7):Error 7
+
+#if ERROR == 8
+struct cmsghdr {
+ int cmsg_type;
+
+ __extension__ unsigned char __cmsg_data [];
+
+ };
+
+void os_rcv_fd()
+{
+ char buf[sizeof(struct cmsghdr)];
+}
+#endif
+
+int main() {
+ g1 *p; E(3); //ERROR(3)
+ g1 *p; E(5); //ERROR(5)
+ g1 *p; E(7); //ERROR(7)
+ E(8); //ERROR(8)
+ return 0;
+}
--- /dev/null
+typedef void (*__sighandler_t) (int) ;
+
+extern __sighandler_t
+ mysignal(int __sig, __sighandler_t __handler)
+ __asm__ ( "" "__sysv_signal" ) ;
+
+int main()
+{
+ // make some use of the signal function so that we don't drop it
+ mysignal(5, (__sighandler_t)0);
+ return 0;
+}
+
--- /dev/null
+struct mpc_config_bus
+{
+ unsigned char mpc_bustype[6] __attribute((packed));
+};
+
+int main () {
+ return 0;
+}
--- /dev/null
+extern inline void __set_64bit (unsigned long long * ptr,
+ unsigned int low, unsigned int high)
+{
+ __asm__ __volatile__ (
+ "\n1:\t"
+ "movl (%0), %%eax\n\t"
+ "movl 4(%0), %%edx\n\t"
+ "cmpxchg8b (%0)\n\t"
+ "jnz 1b"
+ :
+ : "D"(ptr),
+ "b"(low),
+ "c"(high)
+ : "ax","dx","memory");
+}
--- /dev/null
+// baddef1.c: complain about inconsistent redef
+
+struct S {
+ int x;
+ int y;
+};
+
+int size1() { return sizeof(struct S); }
--- /dev/null
+// baddef2.c: other def'n
+
+#include <stdio.h>
+
+struct S {
+ int x;
+ int y;
+ int z; // third field!
+};
+
+int size2() { return sizeof(struct S); }
+int size1(); // from baddef1
+
+int main()
+{
+ int s1, s2;
+
+ printf("size1: %d\n", s1=size1());
+ printf("size2: %d\n", s2=size2());
+ printf("(correct output is 8, then 12)\n");
+
+ if (s1==8 && s2==12) {
+ return 0;
+ }
+ else {
+ return 2;
+ }
+}
+
+
--- /dev/null
+/* Generated by Frontc */
+
+typedef struct core {
+ int somefield;
+} core ;
+
+void closure(short * core , int n )
+{
+ short * csend ;
+ csend = core + n;
+}
+
+int main () {
+ core x;
+ return 0;
+}
--- /dev/null
+// provoke bogus "redefinition" message
+
+//This will not compile on gcc 4.0 or later, but CIL handles it.
+
+int foo()
+{
+ // call before decl
+ return bar();
+}
+
+// now define statically
+static // comment me out to make problem disappear
+int bar()
+{
+ return 4;
+}
+
+int main()
+{
+ return foo() - 4;
+}
--- /dev/null
+// brlock.c
+// reproduce compile problem with linux lib/brlock.c
+
+typedef struct {
+ volatile unsigned int lock;
+
+
+
+} rwlock_t;
+typedef rwlock_t brlock_read_lock_t;
+
+enum brlock_indices {
+ BR_GLOBALIRQ_LOCK,
+ BR_NETPROTO_LOCK,
+
+ __BR_END
+};
+
+brlock_read_lock_t __brlock_array[32 ][(((sizeof(brlock_read_lock_t)*__BR_END + (1 << ((5) ) ) -1) & ~((1 << ((5) ) ) -1)) / sizeof(brlock_read_lock_t)) ] =
+ { [0 ... 32 -1] = { [0 ... (((sizeof(brlock_read_lock_t)*__BR_END + (1 << ((5) ) ) -1) & ~((1 << ((5) ) ) -1)) / sizeof(brlock_read_lock_t)) -1] = (rwlock_t) { 0x01000000 } } };
--- /dev/null
+// bzero.c
+// we call bzero w/o any complaint?
+
+//#include <strings.h> // bzero
+
+char buf[80];
+
+int main()
+{
+ bzero(buf, (void*)80); // this is how anagram does it
+ return 0;
+}
--- /dev/null
+// Checking of initialization code
+#include "../small1/testharness.h"
+#include "../small1/testkinds.h"
+
+// NUMERRORS 6
+
+//Prevent inlinging of these functions. We want to make sure their
+//stack frames overlap.
+#if __GNUC__ >= 3
+#define NOINLINE __attribute__((noinline))
+#else
+#define NOINLINE
+#endif
+
+
+// Fill the stack with values that are invalid as pointers
+void dirtyStack() NOINLINE {
+ int i, frame[1024];
+ for(i=0;i<sizeof(frame)/ sizeof(int);i++) {
+ frame[i] = i;
+ }
+}
+
+
+int foo() NOINLINE {
+ int *p;
+ if(p == 0) E(1);//ERROR(1):Error 1
+
+ // Initialization of structures
+#if 2 <= ERROR && ERROR <= 3
+ {
+ struct str {
+ int *f1;
+ struct {
+ int *i2;
+ int i3;
+ } f2;
+ int *f3;
+ } l;
+ // All pointers must have been initialized
+ if(l.f1 == 0 && l.f2.i2 == 0 && l.f3 == 0) E(2); //ERROR(2):Error 2
+ // But the integers should not be initialized.
+ // If this test fails then we are probably inserting too much
+ // initialization code
+ if(l.f2.i3 != 0) E(3); //ERROR(3):Error 3
+ }
+#endif
+
+ // Initialization of arrays
+#if 4 <= ERROR && ERROR <= 5
+ {
+ int *a[4];if(a[0] == 0 && a[1] == 0 && a[2] == 0 && a[3] == 0) E(4);//ERROR(4):Error 4
+ struct s { int *a[2]; } l;if(l.a[0] == 0 && l.a[1] == 0) E(5);//ERROR(5):Error 5
+ }
+#endif
+
+ // Initialization of unions
+#if 6 <= ERROR && ERROR <= 7
+ {
+ union { int *a, *b[2]; } l;if(l.a == 0 && l.b[0] == 0 && l.b[1] == 0) E(6);//ERROR(6):Error 6
+ }
+#endif
+
+ // Initialization of metadata for pointers
+}
+
+int main() {
+ dirtyStack();
+ return foo();
+}
--- /dev/null
+/* Tests for checking the return values */
+#include "../small1/testharness.h"
+
+TESTDEF succ : success
+
+struct str1 {
+ int x1;
+ int *x2;
+ struct {
+ int i1;
+ int *i2;
+ } x3;
+};
+
+int global;
+
+struct str1 retstr() {
+ int local;
+ struct str1 res = { 0, &global, 1, &global }; // KEEP : error
+ struct str1 res = { 0, &local, 1, &global }; // KEEP : error = Returning a local
+ struct str1 res = { 0, &global, 1, &local }; // KEEP : error = Returning a local
+ return res;
+}
+
+struct strarr {
+ int i1;
+ int *a[7];
+};
+
+struct strarr retarr() {
+ int local;
+ struct strarr res = { 0, &global, &global, &global }; // KEEP : error=Error 3
+ struct strarr res = { 0, &global, &local, &global }; // KEEP : error=Returning a local
+ return res;
+}
+
+union unfoo {
+ struct { int *e1; int *e2; int *e3; int *e4; } f1;
+ int *f2[4];
+};
+
+union unfoo retunion() {
+ int local;
+ union unfoo res = { &global, &local, &global }; // KEEP : error =Returning a local
+ return res;
+}
+
+union unempty { } retunempty() {
+ union unempty res;
+ return res;
+}
+
+int main() {
+ retstr();
+ retarr();
+ retunion();
+ retunempty(); E(6);// KEEP : error = Error 6
+
+ E(3); // ERROR(3)
+ SUCCESS;
+}
--- /dev/null
+#include "../small1/testharness.h"
+#include "../small1/testkinds.h"
+
+// NUMERRORS 13
+
+
+struct aPointer {
+ int* p;
+};
+
+//Store one local inside another.
+void storeLocals(void)
+{
+ int a;
+ struct aPointer localStruct;
+ int b;
+ struct aPointer *plocalStruct;
+ plocalStruct = &localStruct; //Try to confuse CCured about whether *plocalStruct is local.
+
+ localStruct.p = &a;
+
+ //These should be legal, even though b is lower on the stack than localStruct.
+ plocalStruct->p = &a;
+ plocalStruct->p = &b;
+}
+
+//Store a stack variable that sits higher in the stack inside a local
+void storeToStack(int* pStack)
+{
+ struct aPointer localStruct;
+ struct aPointer *plocalStruct = &localStruct;
+
+ //This should be legal, since localStruct will go away before *pStack does.
+ plocalStruct->p = pStack;
+}
+
+int *gptr;
+
+int global;
+
+int function() {
+ int local;
+
+ // This should work
+ gptr = &global; //ERROR(0)
+
+ // so should this
+ storeLocals();
+ // and this
+ storeToStack(&local);
+
+ // This should fail
+ gptr = &local; // ERROR(1):STORE_SP
+
+ // Play a trick with pointer arithemtic (SEQ)
+#if ERROR == 2
+ {
+ // ERROR(2):Storing stack address
+ int *t = &local; t += (&global - t);
+ if(! HAS_KIND(t, SEQ_KIND)) E(2);
+ gptr = t; // Should fail
+ local = *(gptr + (&local - gptr));
+ }
+#endif
+
+ // The same trick with WILD
+#if ERROR == 3
+ {
+ // ERROR(3):Storing stack address
+ int *t = (int**)&local; // t is WILD now
+ if(! HAS_KIND(t, WILD_KIND)) E(3);
+ t += (&global - t); gptr = t; // Should fail
+ }
+#endif
+
+ // The same trick with FSEQ
+#if ERROR == 4
+ {
+ //matth: we get an LBound failure in Linux in "f = s" because the global is
+ // stored below the stack. In windows, we get a UBound failure converting f
+ // to a SAFE in "gptr = f" because the global is above the stack.
+ // ERROR(4):bound
+ int *f = &local;
+ int *s = &local; s += (&global - s); // s is SEQ
+ f ++; // f has type FSEQ
+ if(! HAS_KIND(f, FSEQ_KIND)) E(4);
+ f = s; //Actually we fail here because s is below its home
+ gptr = f; // Should fail
+ }
+#endif
+
+
+ // Now writing structures
+#if 5 <= ERROR && ERROR <= 7
+ {
+ static struct str1 {
+ int i1;
+ struct {
+ int *s2;
+ } i2;
+ int * i3;
+ } gstr;
+ struct str1 res = { 0, &global, &global };//ERROR(5):Error 5
+ struct str1 res = { 0, &local, &global };//ERROR(6):Storing stack address
+ struct str1 res = { 0, &global, &local };//ERROR(7):Storing stack address
+ gstr = res;
+ E(5);
+ }
+#endif
+
+ // Now write an array
+#if 8 <= ERROR && ERROR <= 10
+ {
+ static struct strarr {
+ int *a[4];
+ } garr;
+ struct strarr res = { &global, &global, &global };//ERROR(8):Error 8
+ struct strarr res = { 0, &local, &global };//ERROR(9):Storing stack address
+ struct strarr res = { 0, &global, &local };//ERROR(10):Storing stack address
+ garr = res;
+ E(8);
+ }
+#endif
+
+ // Now write a union
+#if 11 <= ERROR && ERROR <= 13
+ {
+ static union un {
+ int *a[4];
+ struct { int *a1, *a2, *a3; } b;
+ } gun;
+ union un res = { &global, &global, &global };//ERROR(11):Error 11
+ union un res = { 0, &local, &global };//ERROR(12):Storing stack address
+ union un res = { 0, &global, &local };//ERROR(13):Storing stack address
+ gun = res;
+ E(11);
+ }
+#endif
+
+ //make this function look recursive to discourage inlining.
+ // (if we are inlined into main, then 'local' looks like one of main's
+ // locals, and will be treated like a global because we treate main
+ // as a special case.)
+ if (gptr == 0xdeadbeef) {
+ function ();
+ }
+
+}
+
+
+// We must do all tests not in main, because CCured now allows
+// addresses of locals in main to be stored into the heap
+int main() {
+ function();
+}
--- /dev/null
+
+int *globptr;
+
+int global;
+
+int foo() {
+ int local;
+ int *s = &local; s += (&global - s); // s == &global but with the home of the local
+ globptr = s; // Store away the pointer. Succeeds because s's value is not on the stack
+ return (int)&local; // We'll need this later
+}
+
+int main() {
+ int localaddr = foo();
+ globptr += (localaddr - (int)globptr);// glob == &local with the home of the &local
+ return *globptr; // We are reading from a dead stack frame
+}
--- /dev/null
+// Makes sure that pointers within structures are checked.
+// NUMERRORS 1
+
+struct foo
+{
+ char * __FSEQ p;
+};
+
+int
+bar(struct foo *fp)
+{
+ struct foo f;
+ char buf[10];
+ f.p = buf;
+ *fp = f; // ERROR(1):Storing stack address
+ return 0;
+}
+
+int
+main(void)
+{
+ struct foo f;
+ return bar(&f);
+}
--- /dev/null
+typedef unsigned short setword;
+
+typedef struct { setword S[6]; } symset;
+
+typedef char boolean;
+boolean Member(), Le(), Ge(), Eq(), Ne();
+
+typedef enum { sand, sarray, sbegin, scase,
+ sconst, sdiv, sdo, sdownto,
+ selse, send, sextern, sfile,
+ sfor, sforward, sfunc, sgoto,
+ sif, sinn, slabel, smod,
+ snil, snot, sof, sor,
+ sother, spacked, sproc, spgm,
+ srecord, srepeat, sset, sthen,
+ sto, stype, suntil, svar,
+ swhile, swith, seof, sinteger,
+ sreal, sstring, schar, sid,
+ splus, sminus, smul, squot,
+ sarrow, slpar, srpar, slbrack,
+ srbrack, seq, sne, slt,
+ sle, sgt, sge, scomma,
+ scolon, ssemic, sassign, sdotdot,
+ sdot } symtyp;
+
+typedef unsigned char hashtyp;
+typedef unsigned short strindx;
+
+typedef struct S59 * idptr;
+typedef struct S59 {
+ idptr inext;
+ unsigned char inref;
+ hashtyp ihash;
+ strindx istr;
+} idnode;
+
+
+typedef struct S180 {
+ symtyp st;
+ union {
+ struct {
+ idptr vid;
+ } V1;
+ struct {
+ char vchr;
+ } V2;
+#if 0
+ struct {
+ integer vint;
+ } V3;
+ struct {
+ strindx vflt;
+ } V4;
+ struct {
+ strindx vstr;
+ } V5;
+#endif // 0
+ } U;
+} lexsym;
+
+lexsym currsym;
+
+void error();
+
+typedef enum { ebadsymbol, elongstring, elongtokn, erange,
+ emanytokn, enotdeclid, emultdeclid, enotdecllab,
+ emultdecllab, emuldeflab, ebadstring, enulchr,
+ ebadchar, eeofcmnt, eeofstr, evarpar,
+ enew, esetbase, esetsize, eoverflow,
+ etree, etag, euprconf, easgnconf,
+ ecmpconf, econfconf, evrntfile, evarfile,
+ emanymachs, ebadmach } errors;
+
+ void
+checksymbol(ss)
+ symset ss;
+{
+ if (!(Member((unsigned)(currsym.st), ss.S)))
+ error(ebadsymbol);
+}
+
+#if 0
+static boolean
+Member(m, sp)
+ register unsigned int m;
+ register setptr sp;
+{
+ register unsigned int i = m / (setbits+1) + 1;
+
+ if ((i <= *sp) && (sp[i] & (1 << (m % (setbits+1)))))
+ return (true);
+ return (false);
+}
+#else
+static boolean Member() { return 1; }
+#endif
+
+
+int main()
+{
+ return 0;
+}
--- /dev/null
+
+// A CIL test. But use CCured on it for stricter checking of the foo2 case.
+
+int z;
+typedef struct bar { int* ip; } Bar;
+Bar global = {0};
+
+int foo (int x) {
+ switch (x) {
+ case 0:
+ x++;
+ z++;
+ break;
+ default:
+ return z;
+ }
+ // we need a return here. Make sure there's a warning if it's missing.
+ return z; //DROP switch: success = Warning: Body of function foo falls-through
+}
+
+Bar foo2 (int x) {
+ while (1) {
+ if (z++)
+ return global;
+ }
+ // no need for a return here. If CIL falsely assumes we need a return,
+ // ccured will fail to compile since it doesn't know how to make a Bar.
+}
+
+Bar foo3 (int x) {
+ while (z < 10) {
+ z++;
+ }
+ // we need this return.
+ return global; //DROP loop: error
+}
+
+int main(){
+ return 0;
+}
--- /dev/null
+// comparison of 0 and '\0' ..
+
+#include <stdio.h> // printf
+
+int main()
+{
+ int *i = (int*)512; // low byte is 0
+ char c = (char)i; // should be 0
+
+ printf("i: %d\n", (int)i);
+ printf("c: %d\n", (int)c);
+
+ if (i == '\0') {
+ printf("yes. This is not correct!!\n"); // cil'd code does this!
+ return 1;
+ }
+ else {
+ printf("no\n"); // ordinary gcc does this
+ }
+
+ if ((int)(char)i == (int)'\0') {
+ printf("2nd yes\n"); // ordinary gcc does this
+ }
+ else {
+ printf("2nd no\n");
+ }
+ printf("Success\n");
+ return 0;
+}
--- /dev/null
+# 1 "cof.c"
+# 1 "/home/scott/wrk/safec/cil/lib/fixup.h" 1
+
+
+# 21 "/home/scott/wrk/safec/cil/lib/fixup.h"
+
+
+
+
+
+
+
+
+
+
+
+
+# 55 "/home/scott/wrk/safec/cil/lib/fixup.h"
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+void exit(int);
+
+
+
+
+
+#pragma ccuredalloc("malloc", nozero, sizein(1))
+#pragma ccuredalloc("alloca", nozero, sizein(1))
+#pragma ccuredalloc("calloc", zero, sizemul(1,2))
+
+#pragma ccuredvararg("printf", printf(1))
+#pragma ccuredvararg("fprintf", printf(2))
+#pragma ccuredvararg("sprintf", printf(2))
+#pragma ccuredvararg("snprintf", printf(3))
+
+#pragma ccuredexported("main")
+
+
+
+
+
+# 1 "cof.c" 2
+# 1 "espresso.h" 1
+
+
+
+
+# 1 "port.h" 1
+
+
+
+
+
+
+
+# 19 "port.h"
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+typedef long int32;
+typedef int int16;
+
+
+
+
+# 57 "port.h"
+
+
+
+
+
+
+# 1 "/usr/include/stdio.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/include/features.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 137 "/usr/include/features.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 195 "/usr/include/features.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/include/sys/cdefs.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 71 "/usr/include/sys/cdefs.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 103 "/usr/include/sys/cdefs.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 249 "/usr/include/features.h" 2 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/include/gnu/stubs.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 277 "/usr/include/features.h" 2 3
+
+
+
+
+# 27 "/usr/include/stdio.h" 2 3
+
+
+
+
+
+
+# 1 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 1 3
+
+
+
+
+
+
+
+
+
+# 19 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 61 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 131 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+typedef unsigned int size_t;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 271 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+# 283 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+# 317 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 33 "/usr/include/stdio.h" 2 3
+
+
+
+
+
+# 1 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stdarg.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+typedef void *__gnuc_va_list;
+
+
+
+
+
+# 116 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stdarg.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 202 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stdarg.h" 3
+
+
+
+
+# 38 "/usr/include/stdio.h" 2 3
+
+
+# 1 "/usr/include/bits/types.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 1 3
+
+
+
+
+
+
+
+
+
+# 19 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 61 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 131 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+# 188 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+# 271 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+# 283 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+# 317 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 29 "/usr/include/bits/types.h" 2 3
+
+
+
+typedef unsigned char __u_char;
+typedef unsigned short __u_short;
+typedef unsigned int __u_int;
+typedef unsigned long __u_long;
+
+__extension__ typedef unsigned long long int __u_quad_t;
+__extension__ typedef long long int __quad_t;
+# 48 "/usr/include/bits/types.h" 3
+
+typedef signed char __int8_t;
+typedef unsigned char __uint8_t;
+typedef signed short int __int16_t;
+typedef unsigned short int __uint16_t;
+typedef signed int __int32_t;
+typedef unsigned int __uint32_t;
+
+__extension__ typedef signed long long int __int64_t;
+__extension__ typedef unsigned long long int __uint64_t;
+
+typedef __quad_t *__qaddr_t;
+
+typedef __u_quad_t __dev_t;
+typedef __u_int __uid_t;
+typedef __u_int __gid_t;
+typedef __u_long __ino_t;
+typedef __u_int __mode_t;
+typedef __u_int __nlink_t;
+typedef long int __off_t;
+typedef __quad_t __loff_t;
+typedef int __pid_t;
+typedef int __ssize_t;
+typedef long int __rlim_t;
+typedef __quad_t __rlim64_t;
+typedef __u_int __id_t;
+
+typedef struct
+ {
+ int __val[2];
+ } __fsid_t;
+
+
+typedef int __daddr_t;
+typedef char *__caddr_t;
+typedef long int __time_t;
+typedef long int __swblk_t;
+\f
+typedef long int __clock_t;
+
+
+typedef unsigned long int __fd_mask;
+
+
+
+
+
+
+
+
+
+
+typedef struct
+ {
+
+
+
+
+
+
+ __fd_mask __fds_bits[1024 / (8 * sizeof (__fd_mask)) ];
+
+
+ } __fd_set;
+
+
+typedef int __key_t;
+
+
+typedef unsigned short int __ipc_pid_t;
+
+
+
+
+
+typedef long int __blkcnt_t;
+typedef __quad_t __blkcnt64_t;
+
+
+typedef __u_long __fsblkcnt_t;
+typedef __u_quad_t __fsblkcnt64_t;
+
+
+typedef __u_long __fsfilcnt_t;
+typedef __u_quad_t __fsfilcnt64_t;
+
+
+typedef __u_long __ino64_t;
+
+
+typedef __loff_t __off64_t;
+
+
+typedef int __t_scalar_t;
+typedef unsigned int __t_uscalar_t;
+
+
+typedef int __intptr_t;
+
+
+
+
+
+
+
+
+# 40 "/usr/include/stdio.h" 2 3
+
+
+
+
+
+
+
+
+typedef struct _IO_FILE FILE;
+
+
+
+
+
+
+
+
+# 1 "/usr/include/libio.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/include/_G_config.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 1 3
+
+
+
+
+
+
+
+
+
+# 19 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 61 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 131 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+# 188 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+typedef long int wchar_t;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+typedef unsigned int wint_t;
+
+
+
+
+
+
+
+
+# 317 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 14 "/usr/include/_G_config.h" 2 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+typedef int _G_int16_t __attribute__ ((__mode__ (__HI__)));
+typedef int _G_int32_t __attribute__ ((__mode__ (__SI__)));
+typedef unsigned int _G_uint16_t __attribute__ ((__mode__ (__HI__)));
+typedef unsigned int _G_uint32_t __attribute__ ((__mode__ (__SI__)));
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 30 "/usr/include/libio.h" 2 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stdarg.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 116 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stdarg.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 202 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stdarg.h" 3
+
+
+
+
+# 48 "/usr/include/libio.h" 2 3
+
+
+
+
+
+
+
+# 67 "/usr/include/libio.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 98 "/usr/include/libio.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+struct _IO_jump_t; struct _IO_FILE;
+
+
+
+
+
+
+
+
+
+typedef void _IO_lock_t;
+
+
+
+
+
+struct _IO_marker {
+ struct _IO_marker *_next;
+ struct _IO_FILE *_sbuf;
+
+
+
+ int _pos;
+# 186 "/usr/include/libio.h" 3
+
+};
+
+struct _IO_FILE {
+ int _flags;
+
+
+
+
+ char* _IO_read_ptr;
+ char* _IO_read_end;
+ char* _IO_read_base;
+ char* _IO_write_base;
+ char* _IO_write_ptr;
+ char* _IO_write_end;
+ char* _IO_buf_base;
+ char* _IO_buf_end;
+
+ char *_IO_save_base;
+ char *_IO_backup_base;
+ char *_IO_save_end;
+
+ struct _IO_marker *_markers;
+
+ struct _IO_FILE *_chain;
+
+ int _fileno;
+ int _blksize;
+ __off_t _old_offset;
+
+
+
+ unsigned short _cur_column;
+ signed char _vtable_offset;
+ char _shortbuf[1];
+
+
+
+ _IO_lock_t *_lock;
+
+
+
+
+
+
+
+
+ __off64_t _offset;
+
+ int _unused2[16];
+
+};
+
+
+typedef struct _IO_FILE _IO_FILE;
+
+
+struct _IO_FILE_plus;
+extern struct _IO_FILE_plus _IO_2_1_stdin_;
+extern struct _IO_FILE_plus _IO_2_1_stdout_;
+extern struct _IO_FILE_plus _IO_2_1_stderr_;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+typedef __ssize_t __io_read_fn (void * __cookie, char *__buf,
+ size_t __nbytes) ;
+
+
+
+
+
+
+
+typedef __ssize_t __io_write_fn (void * __cookie, __const char *__buf,
+ size_t __n) ;
+
+
+
+
+
+
+
+typedef int __io_seek_fn (void * __cookie, __off_t __pos, int __w) ;
+
+
+typedef int __io_close_fn (void * __cookie) ;
+
+
+# 311 "/usr/include/libio.h" 3
+
+
+
+
+
+
+
+extern int __underflow (_IO_FILE *) ;
+extern int __uflow (_IO_FILE *) ;
+extern int __overflow (_IO_FILE *, int) ;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+extern int _IO_getc (_IO_FILE *__fp) ;
+extern int _IO_putc (int __c, _IO_FILE *__fp) ;
+extern int _IO_feof (_IO_FILE *__fp) ;
+extern int _IO_ferror (_IO_FILE *__fp) ;
+
+extern int _IO_peekc_locked (_IO_FILE *__fp) ;
+
+
+
+
+
+extern void _IO_flockfile (_IO_FILE *) ;
+extern void _IO_funlockfile (_IO_FILE *) ;
+extern int _IO_ftrylockfile (_IO_FILE *) ;
+
+
+
+
+
+
+
+
+
+
+
+
+extern int _IO_vfscanf (_IO_FILE * , const char * ,
+ __gnuc_va_list , int * ) ;
+extern int _IO_vfprintf (_IO_FILE * , const char * ,
+ __gnuc_va_list ) ;
+extern __ssize_t _IO_padn (_IO_FILE *, int, __ssize_t ) ;
+extern size_t _IO_sgetn (_IO_FILE *, void *, size_t ) ;
+
+extern __off64_t _IO_seekoff (_IO_FILE *, __off64_t , int, int) ;
+extern __off64_t _IO_seekpos (_IO_FILE *, __off64_t , int) ;
+
+extern void _IO_free_backup_area (_IO_FILE *) ;
+
+
+
+
+
+
+# 57 "/usr/include/stdio.h" 2 3
+
+
+
+
+typedef __off_t fpos_t;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/include/bits/stdio_lim.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 110 "/usr/include/stdio.h" 2 3
+
+
+
+
+extern FILE *stdin;
+extern FILE *stdout;
+extern FILE *stderr;
+
+
+
+extern int remove (__const char *__filename) ;
+
+extern int rename (__const char *__old, __const char *__new) ;
+
+
+
+
+extern FILE *tmpfile (void) ;
+
+
+
+
+
+
+
+
+
+
+
+extern char *tmpnam (char *__s) ;
+
+
+
+
+extern char *tmpnam_r (char *__s) ;
+
+
+
+
+
+
+
+
+
+
+
+extern char *tempnam (__const char *__dir, __const char *__pfx) ;
+
+
+
+
+extern int fclose (FILE *__stream) ;
+
+extern int fflush (FILE *__stream) ;
+
+
+
+extern int fflush_unlocked (FILE *__stream) ;
+
+
+
+
+
+
+
+
+
+
+extern FILE *fopen (__const char * __filename,
+ __const char * __modes) ;
+
+extern FILE *freopen (__const char * __filename,
+ __const char * __modes,
+ FILE * __stream) ;
+# 197 "/usr/include/stdio.h" 3
+
+
+
+
+
+
+
+
+
+
+
+extern FILE *fdopen (int __fd, __const char *__modes) ;
+
+
+# 223 "/usr/include/stdio.h" 3
+
+
+
+
+
+extern void setbuf (FILE * __stream, char * __buf) ;
+
+
+
+extern int setvbuf (FILE * __stream, char * __buf,
+ int __modes, size_t __n) ;
+
+
+
+
+extern void setbuffer (FILE * __stream, char * __buf,
+ size_t __size) ;
+
+
+extern void setlinebuf (FILE *__stream) ;
+
+
+
+
+extern int fprintf (FILE * __stream,
+ __const char * __format, ...) ;
+
+extern int printf (__const char * __format, ...) ;
+
+extern int sprintf (char * __s,
+ __const char * __format, ...) ;
+
+
+extern int vfprintf (FILE * __s,
+ __const char * __format,
+ __gnuc_va_list __arg) ;
+
+extern int vprintf (__const char * __format,
+ __gnuc_va_list __arg) ;
+
+extern int vsprintf (char * __s,
+ __const char * __format,
+ __gnuc_va_list __arg) ;
+
+
+
+extern int snprintf (char * __s, size_t __maxlen,
+ __const char * __format, ...)
+ __attribute__ ((__format__ (__printf__, 3, 4)));
+
+extern int __vsnprintf (char * __s, size_t __maxlen,
+ __const char * __format,
+ __gnuc_va_list __arg)
+ __attribute__ ((__format__ (__printf__, 3, 0)));
+extern int vsnprintf (char * __s, size_t __maxlen,
+ __const char * __format,
+ __gnuc_va_list __arg)
+ __attribute__ ((__format__ (__printf__, 3, 0)));
+
+
+# 302 "/usr/include/stdio.h" 3
+
+
+
+
+extern int fscanf (FILE * __stream,
+ __const char * __format, ...) ;
+
+extern int scanf (__const char * __format, ...) ;
+
+extern int sscanf (__const char * __s,
+ __const char * __format, ...) ;
+
+# 330 "/usr/include/stdio.h" 3
+
+
+
+
+extern int fgetc (FILE *__stream) ;
+extern int getc (FILE *__stream) ;
+
+
+extern int getchar (void) ;
+
+
+
+
+
+
+
+extern int getc_unlocked (FILE *__stream) ;
+extern int getchar_unlocked (void) ;
+
+
+
+
+extern int fgetc_unlocked (FILE *__stream) ;
+
+
+
+
+extern int fputc (int __c, FILE *__stream) ;
+extern int putc (int __c, FILE *__stream) ;
+
+
+extern int putchar (int __c) ;
+
+
+
+
+
+
+
+extern int fputc_unlocked (int __c, FILE *__stream) ;
+
+
+
+
+extern int putc_unlocked (int __c, FILE *__stream) ;
+extern int putchar_unlocked (int __c) ;
+
+
+
+
+
+extern int getw (FILE *__stream) ;
+
+
+extern int putw (int __w, FILE *__stream) ;
+
+
+
+
+extern char *fgets (char * __s, int __n,
+ FILE * __stream) ;
+
+
+
+
+
+
+
+
+
+extern char *gets (char *__s) ;
+
+
+# 420 "/usr/include/stdio.h" 3
+
+
+
+
+extern int fputs (__const char * __s,
+ FILE * __stream) ;
+
+
+
+
+
+
+
+
+extern int puts (__const char *__s) ;
+
+
+
+extern int ungetc (int __c, FILE *__stream) ;
+
+
+
+extern size_t fread (void * __ptr, size_t __size,
+ size_t __n, FILE * __stream) ;
+
+extern size_t fwrite (__const void * __ptr, size_t __size,
+ size_t __n, FILE * __s) ;
+
+
+
+extern size_t fread_unlocked (void * __ptr, size_t __size,
+ size_t __n, FILE * __stream) ;
+extern size_t fwrite_unlocked (__const void * __ptr,
+ size_t __size, size_t __n,
+ FILE * __stream) ;
+
+
+
+
+extern int fseek (FILE *__stream, long int __off, int __whence) ;
+
+extern long int ftell (FILE *__stream) ;
+
+extern void rewind (FILE *__stream) ;
+
+
+
+
+
+
+
+
+
+typedef __off_t off_t;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+extern int fgetpos (FILE * __stream,
+ fpos_t * __pos) ;
+
+extern int fsetpos (FILE *__stream, __const fpos_t *__pos) ;
+# 519 "/usr/include/stdio.h" 3
+
+
+# 529 "/usr/include/stdio.h" 3
+
+
+
+extern void clearerr (FILE *__stream) ;
+
+extern int feof (FILE *__stream) ;
+
+extern int ferror (FILE *__stream) ;
+
+
+
+extern void clearerr_unlocked (FILE *__stream) ;
+extern int feof_unlocked (FILE *__stream) ;
+extern int ferror_unlocked (FILE *__stream) ;
+
+
+
+
+extern void perror (__const char *__s) ;
+
+
+
+
+extern int sys_nerr;
+extern __const char *__const sys_errlist[];
+
+
+
+
+
+
+
+
+
+extern int fileno (FILE *__stream) ;
+
+
+
+
+extern int fileno_unlocked (FILE *__stream) ;
+
+
+
+
+
+
+extern FILE *popen (__const char *__command, __const char *__modes) ;
+
+
+extern int pclose (FILE *__stream) ;
+
+
+
+
+
+extern char *ctermid (char *__s) ;
+
+
+
+
+
+
+
+
+
+# 603 "/usr/include/stdio.h" 3
+
+
+
+
+
+
+
+extern void flockfile (FILE *__stream) ;
+
+
+
+extern int ftrylockfile (FILE *__stream) ;
+
+
+extern void funlockfile (FILE *__stream) ;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 63 "port.h" 2
+
+# 1 "/usr/include/ctype.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/include/endian.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/include/bits/endian.h" 1 3
+
+
+
+
+
+
+
+# 35 "/usr/include/endian.h" 2 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 40 "/usr/include/ctype.h" 2 3
+
+
+
+
+
+
+
+enum
+{
+ _ISupper = (( 0 ) < 8 ? ((1 << ( 0 )) << 8) : ((1 << ( 0 )) >> 8)) ,
+ _ISlower = (( 1 ) < 8 ? ((1 << ( 1 )) << 8) : ((1 << ( 1 )) >> 8)) ,
+ _ISalpha = (( 2 ) < 8 ? ((1 << ( 2 )) << 8) : ((1 << ( 2 )) >> 8)) ,
+ _ISdigit = (( 3 ) < 8 ? ((1 << ( 3 )) << 8) : ((1 << ( 3 )) >> 8)) ,
+ _ISxdigit = (( 4 ) < 8 ? ((1 << ( 4 )) << 8) : ((1 << ( 4 )) >> 8)) ,
+ _ISspace = (( 5 ) < 8 ? ((1 << ( 5 )) << 8) : ((1 << ( 5 )) >> 8)) ,
+ _ISprint = (( 6 ) < 8 ? ((1 << ( 6 )) << 8) : ((1 << ( 6 )) >> 8)) ,
+ _ISgraph = (( 7 ) < 8 ? ((1 << ( 7 )) << 8) : ((1 << ( 7 )) >> 8)) ,
+ _ISblank = (( 8 ) < 8 ? ((1 << ( 8 )) << 8) : ((1 << ( 8 )) >> 8)) ,
+ _IScntrl = (( 9 ) < 8 ? ((1 << ( 9 )) << 8) : ((1 << ( 9 )) >> 8)) ,
+ _ISpunct = (( 10 ) < 8 ? ((1 << ( 10 )) << 8) : ((1 << ( 10 )) >> 8)) ,
+ _ISalnum = (( 11 ) < 8 ? ((1 << ( 11 )) << 8) : ((1 << ( 11 )) >> 8))
+};
+
+
+
+
+
+
+
+
+
+
+
+
+
+extern __const unsigned short int *__ctype_b;
+extern __const __int32_t *__ctype_tolower;
+extern __const __int32_t *__ctype_toupper;
+
+
+
+
+
+
+
+
+
+
+
+
+
+extern int isalnum (int) ;
+extern int isalpha (int) ;
+extern int iscntrl (int) ;
+extern int isdigit (int) ;
+extern int islower (int) ;
+extern int isgraph (int) ;
+extern int isprint (int) ;
+extern int ispunct (int) ;
+extern int isspace (int) ;
+extern int isupper (int) ;
+extern int isxdigit (int) ;
+
+
+
+
+
+
+
+extern int tolower (int __c) ;
+
+
+extern int toupper (int __c) ;
+
+
+
+
+
+
+extern int isascii (int __c) ;
+
+
+
+extern int toascii (int __c) ;
+
+
+
+
+
+
+extern int _toupper (int) ;
+extern int _tolower (int) ;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 164 "/usr/include/ctype.h" 3
+
+
+# 186 "/usr/include/ctype.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 273 "/usr/include/ctype.h" 3
+
+
+
+
+
+# 64 "port.h" 2
+
+# 1 "/usr/include/sys/types.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+typedef __u_char u_char;
+typedef __u_short u_short;
+typedef __u_int u_int;
+typedef __u_long u_long;
+typedef __quad_t quad_t;
+typedef __u_quad_t u_quad_t;
+typedef __fsid_t fsid_t;
+
+
+typedef __loff_t loff_t;
+
+
+
+typedef __ino_t ino_t;
+
+
+
+
+
+
+
+
+
+
+typedef __dev_t dev_t;
+
+
+
+
+typedef __gid_t gid_t;
+
+
+
+
+typedef __mode_t mode_t;
+
+
+
+
+typedef __nlink_t nlink_t;
+
+
+
+
+typedef __uid_t uid_t;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+typedef __pid_t pid_t;
+
+
+
+
+typedef __id_t id_t;
+
+
+
+typedef __ssize_t ssize_t;
+
+
+
+
+typedef __daddr_t daddr_t;
+typedef __caddr_t caddr_t;
+
+
+
+typedef __key_t key_t;
+
+
+
+
+
+
+# 1 "/usr/include/time.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 51 "/usr/include/time.h" 3
+
+
+
+# 62 "/usr/include/time.h" 3
+
+
+
+
+
+
+
+
+
+typedef __time_t time_t;
+
+
+
+
+
+# 89 "/usr/include/time.h" 3
+
+
+
+
+# 279 "/usr/include/time.h" 3
+
+
+
+# 121 "/usr/include/sys/types.h" 2 3
+
+
+
+# 1 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 1 3
+
+
+
+
+
+
+
+
+
+# 19 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 61 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 131 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+# 188 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+# 271 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+# 283 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+# 317 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 124 "/usr/include/sys/types.h" 2 3
+
+
+
+
+typedef unsigned long int ulong;
+typedef unsigned short int ushort;
+typedef unsigned int uint;
+
+
+
+
+# 158 "/usr/include/sys/types.h" 3
+
+
+
+
+
+
+
+
+
+
+typedef int int8_t __attribute__ ((__mode__ ( __QI__ ))) ;
+typedef int int16_t __attribute__ ((__mode__ ( __HI__ ))) ;
+typedef int int32_t __attribute__ ((__mode__ ( __SI__ ))) ;
+typedef int int64_t __attribute__ ((__mode__ ( __DI__ ))) ;
+
+
+typedef unsigned int u_int8_t __attribute__ ((__mode__ ( __QI__ ))) ;
+typedef unsigned int u_int16_t __attribute__ ((__mode__ ( __HI__ ))) ;
+typedef unsigned int u_int32_t __attribute__ ((__mode__ ( __SI__ ))) ;
+typedef unsigned int u_int64_t __attribute__ ((__mode__ ( __DI__ ))) ;
+
+typedef int register_t __attribute__ ((__mode__ (__word__)));
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/include/sys/select.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/include/bits/select.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 36 "/usr/include/bits/select.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+# 56 "/usr/include/bits/select.h" 3
+
+# 72 "/usr/include/bits/select.h" 3
+
+# 31 "/usr/include/sys/select.h" 2 3
+
+
+
+# 1 "/usr/include/bits/sigset.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+typedef int __sig_atomic_t;
+
+
+
+
+typedef struct
+ {
+ unsigned long int __val[(1024 / (8 * sizeof (unsigned long int))) ];
+ } __sigset_t;
+
+
+
+
+
+
+
+
+
+
+# 125 "/usr/include/bits/sigset.h" 3
+
+# 34 "/usr/include/sys/select.h" 2 3
+
+
+
+
+# 1 "/usr/include/time.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 51 "/usr/include/time.h" 3
+
+
+
+# 62 "/usr/include/time.h" 3
+
+
+
+# 73 "/usr/include/time.h" 3
+
+
+
+
+
+
+
+
+
+
+struct timespec
+ {
+ long int tv_sec;
+ long int tv_nsec;
+ };
+
+
+
+
+
+# 279 "/usr/include/time.h" 3
+
+
+
+# 38 "/usr/include/sys/select.h" 2 3
+
+
+
+
+
+
+
+
+struct timeval;
+
+typedef __fd_mask fd_mask;
+
+
+typedef __fd_set fd_set;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+extern int __select (int __nfds, __fd_set *__readfds,
+ __fd_set *__writefds, __fd_set *__exceptfds,
+ struct timeval *__timeout) ;
+extern int select (int __nfds, __fd_set *__readfds,
+ __fd_set *__writefds, __fd_set *__exceptfds,
+ struct timeval *__timeout) ;
+
+# 91 "/usr/include/sys/select.h" 3
+
+
+
+
+
+# 193 "/usr/include/sys/types.h" 2 3
+
+
+
+# 1 "/usr/include/sys/sysmacros.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 47 "/usr/include/sys/sysmacros.h" 3
+
+
+
+# 196 "/usr/include/sys/types.h" 2 3
+
+
+
+
+
+
+typedef __blkcnt_t blkcnt_t;
+typedef __fsblkcnt_t fsblkcnt_t;
+typedef __fsfilcnt_t fsfilcnt_t;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 65 "port.h" 2
+
+
+# 1 "/usr/include/math.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/include/bits/huge_val.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 68 "/usr/include/bits/huge_val.h" 3
+
+# 33 "/usr/include/math.h" 2 3
+
+
+
+
+
+
+
+# 1 "/usr/include/bits/mathdef.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 45 "/usr/include/bits/mathdef.h" 3
+
+# 40 "/usr/include/math.h" 2 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/include/bits/mathcalls.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+extern double acos (double __x) ; extern double __acos (double __x) ;
+
+extern double asin (double __x) ; extern double __asin (double __x) ;
+
+extern double atan (double __x) ; extern double __atan (double __x) ;
+
+extern double atan2 (double __y, double __x) ; extern double __atan2 (double __y, double __x) ;
+
+
+extern double cos (double __x) ; extern double __cos (double __x) ;
+
+extern double sin (double __x) ; extern double __sin (double __x) ;
+
+extern double tan (double __x) ; extern double __tan (double __x) ;
+
+
+
+
+
+
+
+
+
+
+extern double cosh (double __x) ; extern double __cosh (double __x) ;
+
+extern double sinh (double __x) ; extern double __sinh (double __x) ;
+
+extern double tanh (double __x) ; extern double __tanh (double __x) ;
+
+
+
+extern double acosh (double __x) ; extern double __acosh (double __x) ;
+
+extern double asinh (double __x) ; extern double __asinh (double __x) ;
+
+extern double atanh (double __x) ; extern double __atanh (double __x) ;
+
+
+
+
+
+extern double exp (double __x) ; extern double __exp (double __x) ;
+
+
+
+
+
+
+
+
+
+extern double frexp (double __x, int *__exponent) ; extern double __frexp (double __x, int *__exponent) ;
+
+
+extern double ldexp (double __x, int __exponent) ; extern double __ldexp (double __x, int __exponent) ;
+
+
+extern double log (double __x) ; extern double __log (double __x) ;
+
+
+extern double log10 (double __x) ; extern double __log10 (double __x) ;
+
+
+extern double modf (double __x, double *__iptr) ; extern double __modf (double __x, double *__iptr) ;
+
+
+
+extern double expm1 (double __x) ; extern double __expm1 (double __x) ;
+
+
+extern double log1p (double __x) ; extern double __log1p (double __x) ;
+
+
+extern double logb (double __x) ; extern double __logb (double __x) ;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+extern double pow (double __x, double __y) ; extern double __pow (double __x, double __y) ;
+
+
+extern double sqrt (double __x) ; extern double __sqrt (double __x) ;
+
+
+
+extern double hypot (double __x, double __y) ; extern double __hypot (double __x, double __y) ;
+
+
+
+
+extern double cbrt (double __x) ; extern double __cbrt (double __x) ;
+
+
+
+
+
+
+extern double ceil (double __x) ; extern double __ceil (double __x) ;
+
+
+extern double fabs (double __x) __attribute__ ( (__const__) ); extern double __fabs (double __x) __attribute__ ( (__const__) ) ;
+
+
+extern double floor (double __x) ; extern double __floor (double __x) ;
+
+
+extern double fmod (double __x, double __y) ; extern double __fmod (double __x, double __y) ;
+
+
+
+
+extern int __isinf (double __value) __attribute__ ((__const__));
+
+
+
+
+extern int isinf (double __value) __attribute__ ((__const__));
+
+
+extern int finite (double __value) __attribute__ ( (__const__) ); extern int __finite (double __value) __attribute__ ( (__const__) ) ;
+
+
+
+
+
+
+
+extern double infnan (int __error) __attribute__ ( (__const__) ); extern double __infnan (int __error) __attribute__ ( (__const__) ) ;
+
+
+extern double drem (double __x, double __y) ; extern double __drem (double __x, double __y) ;
+
+
+
+extern double significand (double __x) ; extern double __significand (double __x) ;
+
+
+
+
+extern double copysign (double __x, double __y) __attribute__ ( (__const__) ); extern double __copysign (double __x, double __y) __attribute__ ( (__const__) ) ;
+
+
+
+
+
+
+
+
+
+
+extern int isnan (double __value) __attribute__ ( (__const__) ); extern int __isnan (double __value) __attribute__ ( (__const__) ) ;
+
+
+extern double j0 (double ) ; extern double __j0 (double ) ;
+extern double j1 (double ) ; extern double __j1 (double ) ;
+extern double jn (int, double ) ; extern double __jn (int, double ) ;
+extern double y0 (double ) ; extern double __y0 (double ) ;
+extern double y1 (double ) ; extern double __y1 (double ) ;
+extern double yn (int, double ) ; extern double __yn (int, double ) ;
+
+
+
+
+
+extern double erf (double ) ; extern double __erf (double ) ;
+extern double erfc (double ) ; extern double __erfc (double ) ;
+extern double lgamma (double ) ; extern double __lgamma (double ) ;
+extern double tgamma (double ) ; extern double __tgamma (double ) ;
+
+
+
+
+extern double gamma (double ) ; extern double __gamma (double ) ;
+
+
+
+
+
+
+extern double lgamma_r (double , int *__signgamp) ; extern double __lgamma_r (double , int *__signgamp) ;
+
+
+
+
+
+
+extern double rint (double __x) ; extern double __rint (double __x) ;
+
+
+extern double nextafter (double __x, double __y) __attribute__ ( (__const__) ); extern double __nextafter (double __x, double __y) __attribute__ ( (__const__) ) ;
+
+
+
+
+
+extern double remainder (double __x, double __y) ; extern double __remainder (double __x, double __y) ;
+
+
+
+extern double scalb (double __x, double __n) ; extern double __scalb (double __x, double __n) ;
+
+
+
+extern double scalbn (double __x, int __n) ; extern double __scalbn (double __x, int __n) ;
+
+
+extern int ilogb (double __x) ; extern int __ilogb (double __x) ;
+
+
+# 330 "/usr/include/bits/mathcalls.h" 3
+
+# 63 "/usr/include/math.h" 2 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/include/bits/mathcalls.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+extern float acosf (float __x) ; extern float __acosf (float __x) ;
+
+extern float asinf (float __x) ; extern float __asinf (float __x) ;
+
+extern float atanf (float __x) ; extern float __atanf (float __x) ;
+
+extern float atan2f (float __y, float __x) ; extern float __atan2f (float __y, float __x) ;
+
+
+extern float cosf (float __x) ; extern float __cosf (float __x) ;
+
+extern float sinf (float __x) ; extern float __sinf (float __x) ;
+
+extern float tanf (float __x) ; extern float __tanf (float __x) ;
+
+
+
+
+
+
+
+
+
+
+extern float coshf (float __x) ; extern float __coshf (float __x) ;
+
+extern float sinhf (float __x) ; extern float __sinhf (float __x) ;
+
+extern float tanhf (float __x) ; extern float __tanhf (float __x) ;
+
+
+
+extern float acoshf (float __x) ; extern float __acoshf (float __x) ;
+
+extern float asinhf (float __x) ; extern float __asinhf (float __x) ;
+
+extern float atanhf (float __x) ; extern float __atanhf (float __x) ;
+
+
+
+
+
+extern float expf (float __x) ; extern float __expf (float __x) ;
+
+
+
+
+
+
+
+
+
+extern float frexpf (float __x, int *__exponent) ; extern float __frexpf (float __x, int *__exponent) ;
+
+
+extern float ldexpf (float __x, int __exponent) ; extern float __ldexpf (float __x, int __exponent) ;
+
+
+extern float logf (float __x) ; extern float __logf (float __x) ;
+
+
+extern float log10f (float __x) ; extern float __log10f (float __x) ;
+
+
+extern float modff (float __x, float *__iptr) ; extern float __modff (float __x, float *__iptr) ;
+
+
+
+extern float expm1f (float __x) ; extern float __expm1f (float __x) ;
+
+
+extern float log1pf (float __x) ; extern float __log1pf (float __x) ;
+
+
+extern float logbf (float __x) ; extern float __logbf (float __x) ;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+extern float powf (float __x, float __y) ; extern float __powf (float __x, float __y) ;
+
+
+extern float sqrtf (float __x) ; extern float __sqrtf (float __x) ;
+
+
+
+extern float hypotf (float __x, float __y) ; extern float __hypotf (float __x, float __y) ;
+
+
+
+
+extern float cbrtf (float __x) ; extern float __cbrtf (float __x) ;
+
+
+
+
+
+
+extern float ceilf (float __x) ; extern float __ceilf (float __x) ;
+
+
+extern float fabsf (float __x) __attribute__ ( (__const__) ); extern float __fabsf (float __x) __attribute__ ( (__const__) ) ;
+
+
+extern float floorf (float __x) ; extern float __floorf (float __x) ;
+
+
+extern float fmodf (float __x, float __y) ; extern float __fmodf (float __x, float __y) ;
+
+
+
+
+extern int __isinff (float __value) __attribute__ ((__const__));
+
+
+
+
+extern int isinff (float __value) __attribute__ ((__const__));
+
+
+extern int finitef (float __value) __attribute__ ( (__const__) ); extern int __finitef (float __value) __attribute__ ( (__const__) ) ;
+
+
+
+
+
+
+
+extern float infnanf (int __error) __attribute__ ( (__const__) ); extern float __infnanf (int __error) __attribute__ ( (__const__) ) ;
+
+
+extern float dremf (float __x, float __y) ; extern float __dremf (float __x, float __y) ;
+
+
+
+extern float significandf (float __x) ; extern float __significandf (float __x) ;
+
+
+
+
+extern float copysignf (float __x, float __y) __attribute__ ( (__const__) ); extern float __copysignf (float __x, float __y) __attribute__ ( (__const__) ) ;
+
+
+
+
+
+
+
+
+
+
+extern int isnanf (float __value) __attribute__ ( (__const__) ); extern int __isnanf (float __value) __attribute__ ( (__const__) ) ;
+
+
+extern float j0f (float ) ; extern float __j0f (float ) ;
+extern float j1f (float ) ; extern float __j1f (float ) ;
+extern float jnf (int, float ) ; extern float __jnf (int, float ) ;
+extern float y0f (float ) ; extern float __y0f (float ) ;
+extern float y1f (float ) ; extern float __y1f (float ) ;
+extern float ynf (int, float ) ; extern float __ynf (int, float ) ;
+
+
+
+
+
+extern float erff (float ) ; extern float __erff (float ) ;
+extern float erfcf (float ) ; extern float __erfcf (float ) ;
+extern float lgammaf (float ) ; extern float __lgammaf (float ) ;
+extern float tgammaf (float ) ; extern float __tgammaf (float ) ;
+
+
+
+
+extern float gammaf (float ) ; extern float __gammaf (float ) ;
+
+
+
+
+
+
+extern float lgammaf_r (float , int *__signgamp) ; extern float __lgammaf_r (float , int *__signgamp) ;
+
+
+
+
+
+
+extern float rintf (float __x) ; extern float __rintf (float __x) ;
+
+
+extern float nextafterf (float __x, float __y) __attribute__ ( (__const__) ); extern float __nextafterf (float __x, float __y) __attribute__ ( (__const__) ) ;
+
+
+
+
+
+extern float remainderf (float __x, float __y) ; extern float __remainderf (float __x, float __y) ;
+
+
+
+extern float scalbf (float __x, float __n) ; extern float __scalbf (float __x, float __n) ;
+
+
+
+extern float scalbnf (float __x, int __n) ; extern float __scalbnf (float __x, int __n) ;
+
+
+extern int ilogbf (float __x) ; extern int __ilogbf (float __x) ;
+
+
+# 330 "/usr/include/bits/mathcalls.h" 3
+
+# 82 "/usr/include/math.h" 2 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/include/bits/mathcalls.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+extern long double acosl (long double __x) ; extern long double __acosl (long double __x) ;
+
+extern long double asinl (long double __x) ; extern long double __asinl (long double __x) ;
+
+extern long double atanl (long double __x) ; extern long double __atanl (long double __x) ;
+
+extern long double atan2l (long double __y, long double __x) ; extern long double __atan2l (long double __y, long double __x) ;
+
+
+extern long double cosl (long double __x) ; extern long double __cosl (long double __x) ;
+
+extern long double sinl (long double __x) ; extern long double __sinl (long double __x) ;
+
+extern long double tanl (long double __x) ; extern long double __tanl (long double __x) ;
+
+
+
+
+
+
+
+
+
+
+extern long double coshl (long double __x) ; extern long double __coshl (long double __x) ;
+
+extern long double sinhl (long double __x) ; extern long double __sinhl (long double __x) ;
+
+extern long double tanhl (long double __x) ; extern long double __tanhl (long double __x) ;
+
+
+
+extern long double acoshl (long double __x) ; extern long double __acoshl (long double __x) ;
+
+extern long double asinhl (long double __x) ; extern long double __asinhl (long double __x) ;
+
+extern long double atanhl (long double __x) ; extern long double __atanhl (long double __x) ;
+
+
+
+
+
+extern long double expl (long double __x) ; extern long double __expl (long double __x) ;
+
+
+
+
+
+
+
+
+
+extern long double frexpl (long double __x, int *__exponent) ; extern long double __frexpl (long double __x, int *__exponent) ;
+
+
+extern long double ldexpl (long double __x, int __exponent) ; extern long double __ldexpl (long double __x, int __exponent) ;
+
+
+extern long double logl (long double __x) ; extern long double __logl (long double __x) ;
+
+
+extern long double log10l (long double __x) ; extern long double __log10l (long double __x) ;
+
+
+extern long double modfl (long double __x, long double *__iptr) ; extern long double __modfl (long double __x, long double *__iptr) ;
+
+
+
+extern long double expm1l (long double __x) ; extern long double __expm1l (long double __x) ;
+
+
+extern long double log1pl (long double __x) ; extern long double __log1pl (long double __x) ;
+
+
+extern long double logbl (long double __x) ; extern long double __logbl (long double __x) ;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+extern long double powl (long double __x, long double __y) ; extern long double __powl (long double __x, long double __y) ;
+
+
+extern long double sqrtl (long double __x) ; extern long double __sqrtl (long double __x) ;
+
+
+
+extern long double hypotl (long double __x, long double __y) ; extern long double __hypotl (long double __x, long double __y) ;
+
+
+
+
+extern long double cbrtl (long double __x) ; extern long double __cbrtl (long double __x) ;
+
+
+
+
+
+
+extern long double ceill (long double __x) ; extern long double __ceill (long double __x) ;
+
+
+extern long double fabsl (long double __x) __attribute__ ( (__const__) ); extern long double __fabsl (long double __x) __attribute__ ( (__const__) ) ;
+
+
+extern long double floorl (long double __x) ; extern long double __floorl (long double __x) ;
+
+
+extern long double fmodl (long double __x, long double __y) ; extern long double __fmodl (long double __x, long double __y) ;
+
+
+
+
+extern int __isinfl (long double __value) __attribute__ ((__const__));
+
+
+
+
+extern int isinfl (long double __value) __attribute__ ((__const__));
+
+
+extern int finitel (long double __value) __attribute__ ( (__const__) ); extern int __finitel (long double __value) __attribute__ ( (__const__) ) ;
+
+
+
+
+
+
+
+extern long double infnanl (int __error) __attribute__ ( (__const__) ); extern long double __infnanl (int __error) __attribute__ ( (__const__) ) ;
+
+
+extern long double dreml (long double __x, long double __y) ; extern long double __dreml (long double __x, long double __y) ;
+
+
+
+extern long double significandl (long double __x) ; extern long double __significandl (long double __x) ;
+
+
+
+
+extern long double copysignl (long double __x, long double __y) __attribute__ ( (__const__) ); extern long double __copysignl (long double __x, long double __y) __attribute__ ( (__const__) ) ;
+
+
+
+
+
+
+
+
+
+
+extern int isnanl (long double __value) __attribute__ ( (__const__) ); extern int __isnanl (long double __value) __attribute__ ( (__const__) ) ;
+
+
+extern long double j0l (long double ) ; extern long double __j0l (long double ) ;
+extern long double j1l (long double ) ; extern long double __j1l (long double ) ;
+extern long double jnl (int, long double ) ; extern long double __jnl (int, long double ) ;
+extern long double y0l (long double ) ; extern long double __y0l (long double ) ;
+extern long double y1l (long double ) ; extern long double __y1l (long double ) ;
+extern long double ynl (int, long double ) ; extern long double __ynl (int, long double ) ;
+
+
+
+
+
+extern long double erfl (long double ) ; extern long double __erfl (long double ) ;
+extern long double erfcl (long double ) ; extern long double __erfcl (long double ) ;
+extern long double lgammal (long double ) ; extern long double __lgammal (long double ) ;
+extern long double tgammal (long double ) ; extern long double __tgammal (long double ) ;
+
+
+
+
+extern long double gammal (long double ) ; extern long double __gammal (long double ) ;
+
+
+
+
+
+
+extern long double lgammal_r (long double , int *__signgamp) ; extern long double __lgammal_r (long double , int *__signgamp) ;
+
+
+
+
+
+
+extern long double rintl (long double __x) ; extern long double __rintl (long double __x) ;
+
+
+extern long double nextafterl (long double __x, long double __y) __attribute__ ( (__const__) ); extern long double __nextafterl (long double __x, long double __y) __attribute__ ( (__const__) ) ;
+
+
+
+
+
+extern long double remainderl (long double __x, long double __y) ; extern long double __remainderl (long double __x, long double __y) ;
+
+
+
+extern long double scalbl (long double __x, long double __n) ; extern long double __scalbl (long double __x, long double __n) ;
+
+
+
+extern long double scalbnl (long double __x, int __n) ; extern long double __scalbnl (long double __x, int __n) ;
+
+
+extern int ilogbl (long double __x) ; extern int __ilogbl (long double __x) ;
+
+
+# 330 "/usr/include/bits/mathcalls.h" 3
+
+# 99 "/usr/include/math.h" 2 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+extern int signgam;
+
+
+
+
+# 232 "/usr/include/math.h" 3
+
+
+
+
+typedef enum
+{
+ _IEEE_ = -1,
+ _SVID_,
+ _XOPEN_,
+ _POSIX_,
+ _ISOC_
+} _LIB_VERSION_TYPE;
+
+
+
+
+extern _LIB_VERSION_TYPE _LIB_VERSION;
+
+
+
+
+
+
+
+
+
+
+
+
+struct exception
+
+ {
+ int type;
+ char *name;
+ double arg1;
+ double arg2;
+ double retval;
+ };
+
+
+
+
+extern int matherr (struct exception *__exc) ;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/float.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+union __convert_long_double {
+ unsigned __convert_long_double_i[4];
+ long double __convert_long_double_d;
+};
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 289 "/usr/include/math.h" 2 3
+
+
+# 299 "/usr/include/math.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 336 "/usr/include/math.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 407 "/usr/include/math.h" 3
+
+
+
+
+
+
+# 67 "port.h" 2
+
+# 1 "/usr/include/signal.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/include/bits/sigset.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 33 "/usr/include/bits/sigset.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 97 "/usr/include/bits/sigset.h" 3
+
+
+
+
+
+
+extern int __sigismember (__const __sigset_t *, int);
+extern int __sigaddset (__sigset_t *, int);
+extern int __sigdelset (__sigset_t *, int);
+
+# 122 "/usr/include/bits/sigset.h" 3
+
+
+
+
+# 33 "/usr/include/signal.h" 2 3
+
+
+
+
+
+
+
+
+typedef __sig_atomic_t sig_atomic_t;
+
+
+
+
+
+
+
+typedef __sigset_t sigset_t;
+
+
+
+
+
+
+# 1 "/usr/include/bits/signum.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 56 "/usr/include/signal.h" 2 3
+
+
+
+
+
+
+
+
+
+typedef void (*__sighandler_t) (int) ;
+
+
+
+
+extern __sighandler_t __sysv_signal (int __sig,
+ __sighandler_t __handler) ;
+
+
+
+
+
+
+
+
+extern __sighandler_t signal (int __sig, __sighandler_t __handler) ;
+# 90 "/usr/include/signal.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+extern int kill (__pid_t __pid, int __sig) ;
+
+
+
+
+
+
+extern int killpg (__pid_t __pgrp, int __sig) ;
+
+
+
+extern int raise (int __sig) ;
+
+
+
+extern __sighandler_t ssignal (int __sig, __sighandler_t __handler) ;
+extern int gsignal (int __sig) ;
+
+
+
+
+extern void psignal (int __sig, __const char *__s) ;
+
+
+
+
+
+
+
+
+extern int __sigpause (int __sig_or_mask, int __is_sig) ;
+
+
+
+
+extern int sigpause (int __mask) ;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+extern int sigblock (int __mask) ;
+
+
+extern int sigsetmask (int __mask) ;
+
+
+extern int siggetmask (void) ;
+
+
+
+
+
+
+
+
+
+
+
+
+
+typedef __sighandler_t sig_t;
+
+
+
+
+
+
+
+# 1 "/usr/include/time.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 51 "/usr/include/time.h" 3
+
+
+
+# 62 "/usr/include/time.h" 3
+
+
+
+# 73 "/usr/include/time.h" 3
+
+
+
+
+# 89 "/usr/include/time.h" 3
+
+
+
+
+# 279 "/usr/include/time.h" 3
+
+
+
+# 185 "/usr/include/signal.h" 2 3
+
+
+
+# 1 "/usr/include/bits/siginfo.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+typedef union sigval
+ {
+ int sival_int;
+ void *sival_ptr;
+ } sigval_t;
+
+
+
+
+typedef struct siginfo
+ {
+ int si_signo;
+ int si_errno;
+
+ int si_code;
+
+ union
+ {
+ int _pad[((128 / sizeof (int)) - 3) ];
+
+
+ struct
+ {
+ __pid_t si_pid;
+ __uid_t si_uid;
+ } _kill;
+
+
+ struct
+ {
+ unsigned int _timer1;
+ unsigned int _timer2;
+ } _timer;
+
+
+ struct
+ {
+ __pid_t si_pid;
+ __uid_t si_uid;
+ sigval_t si_sigval;
+ } _rt;
+
+
+ struct
+ {
+ __pid_t si_pid;
+ __uid_t si_uid;
+ int si_status;
+ __clock_t si_utime;
+ __clock_t si_stime;
+ } _sigchld;
+
+
+ struct
+ {
+ void *si_addr;
+ } _sigfault;
+
+
+ struct
+ {
+ int si_band;
+ int si_fd;
+ } _sigpoll;
+ } _sifields;
+ } siginfo_t;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+enum
+{
+ SI_SIGIO = -5,
+
+ SI_ASYNCIO,
+
+ SI_MESGQ,
+
+ SI_TIMER,
+
+ SI_QUEUE,
+
+ SI_USER
+
+};
+
+
+
+enum
+{
+ ILL_ILLOPC = 1,
+
+ ILL_ILLOPN,
+
+ ILL_ILLADR,
+
+ ILL_ILLTRP,
+
+ ILL_PRVOPC,
+
+ ILL_PRVREG,
+
+ ILL_COPROC,
+
+ ILL_BADSTK
+
+};
+
+
+enum
+{
+ FPE_INTDIV = 1,
+
+ FPE_INTOVF,
+
+ FPE_FLTDIV,
+
+ FPE_FLTOVF,
+
+ FPE_FLTUND,
+
+ FPE_FLTRES,
+
+ FPE_FLTINV,
+
+ FPE_FLTSUB
+
+};
+
+
+enum
+{
+ SEGV_MAPERR = 1,
+
+ SEGV_ACCERR
+
+};
+
+
+enum
+{
+ BUS_ADRALN = 1,
+
+ BUS_ADRERR,
+
+ BUS_OBJERR
+
+};
+
+
+enum
+{
+ TRAP_BRKPT = 1,
+
+ TRAP_TRACE
+
+};
+
+
+enum
+{
+ CLD_EXITED = 1,
+
+ CLD_KILLED,
+
+ CLD_DUMPED,
+
+ CLD_TRAPPED,
+
+ CLD_STOPPED,
+
+ CLD_CONTINUED
+
+};
+
+
+enum
+{
+ POLL_IN = 1,
+
+ POLL_OUT,
+
+ POLL_MSG,
+
+ POLL_ERR,
+
+ POLL_PRI,
+
+ POLL_HUP
+
+};
+
+
+
+
+
+
+
+
+
+
+
+
+typedef struct sigevent
+ {
+ sigval_t sigev_value;
+ int sigev_signo;
+ int sigev_notify;
+
+ union
+ {
+ int _pad[((64 / sizeof (int)) - 3) ];
+
+ struct
+ {
+ void (*_function) (sigval_t) ;
+ void *_attribute;
+ } _sigev_thread;
+ } _sigev_un;
+ } sigevent_t;
+
+
+
+
+
+
+enum
+{
+ SIGEV_SIGNAL = 0,
+
+ SIGEV_NONE,
+
+ SIGEV_THREAD
+
+};
+
+
+# 188 "/usr/include/signal.h" 2 3
+
+
+
+
+extern int sigemptyset (sigset_t *__set) ;
+
+
+extern int sigfillset (sigset_t *__set) ;
+
+
+extern int sigaddset (sigset_t *__set, int __signo) ;
+
+
+extern int sigdelset (sigset_t *__set, int __signo) ;
+
+
+extern int sigismember (__const sigset_t *__set, int __signo) ;
+
+# 217 "/usr/include/signal.h" 3
+
+
+
+
+# 1 "/usr/include/bits/sigaction.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+struct sigaction
+ {
+
+
+ union
+ {
+
+ __sighandler_t sa_handler;
+
+ void (*sa_sigaction) (int, siginfo_t *, void *) ;
+ }
+ __sigaction_handler;
+
+
+
+
+
+
+
+ __sigset_t sa_mask;
+
+
+ int sa_flags;
+
+
+ void (*sa_restorer) (void) ;
+ };
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 221 "/usr/include/signal.h" 2 3
+
+
+
+extern int sigprocmask (int __how,
+ __const sigset_t *__set, sigset_t *__oset) ;
+
+
+
+extern int sigsuspend (__const sigset_t *__set) ;
+
+
+extern int __sigaction (int __sig, __const struct sigaction *__act,
+ struct sigaction *__oact) ;
+extern int sigaction (int __sig, __const struct sigaction *__act,
+ struct sigaction *__oact) ;
+
+
+extern int sigpending (sigset_t *__set) ;
+
+
+
+extern int sigwait (__const sigset_t *__set, int *__sig) ;
+
+
+
+extern int sigwaitinfo (__const sigset_t *__set, siginfo_t *__info) ;
+
+
+
+extern int sigtimedwait (__const sigset_t *__set, siginfo_t *__info,
+ __const struct timespec *__timeout) ;
+
+
+
+extern int sigqueue (__pid_t __pid, int __sig,
+ __const union sigval __val) ;
+
+
+
+
+
+
+
+
+extern __const char *__const _sys_siglist[64 ];
+extern __const char *__const sys_siglist[64 ];
+
+
+struct sigvec
+ {
+ __sighandler_t sv_handler;
+ int sv_mask;
+
+ int sv_flags;
+
+ };
+
+
+
+
+
+
+
+
+
+
+
+
+extern int sigvec (int __sig, __const struct sigvec *__vec,
+ struct sigvec *__ovec) ;
+
+
+
+# 1 "/usr/include/bits/sigcontext.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/include/asm/sigcontext.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+struct _fpreg {
+ unsigned short significand[4];
+ unsigned short exponent;
+};
+
+struct _fpstate {
+ unsigned long cw,
+ sw,
+ tag,
+ ipoff,
+ cssel,
+ dataoff,
+ datasel;
+ struct _fpreg _st[8];
+ unsigned long status;
+};
+
+struct sigcontext {
+ unsigned short gs, __gsh;
+ unsigned short fs, __fsh;
+ unsigned short es, __esh;
+ unsigned short ds, __dsh;
+ unsigned long edi;
+ unsigned long esi;
+ unsigned long ebp;
+ unsigned long esp;
+ unsigned long ebx;
+ unsigned long edx;
+ unsigned long ecx;
+ unsigned long eax;
+ unsigned long trapno;
+ unsigned long err;
+ unsigned long eip;
+ unsigned short cs, __csh;
+ unsigned long eflags;
+ unsigned long esp_at_signal;
+ unsigned short ss, __ssh;
+ struct _fpstate * fpstate;
+ unsigned long oldmask;
+ unsigned long cr2;
+};
+
+
+
+# 28 "/usr/include/bits/sigcontext.h" 2 3
+
+
+# 294 "/usr/include/signal.h" 2 3
+
+
+
+extern int sigreturn (struct sigcontext *__scp) ;
+
+
+
+
+
+
+
+
+
+extern int siginterrupt (int __sig, int __interrupt) ;
+
+# 1 "/usr/include/bits/sigstack.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+struct sigstack
+ {
+ void * ss_sp;
+ int ss_onstack;
+ };
+
+
+
+enum
+{
+ SS_ONSTACK = 1,
+
+ SS_DISABLE
+
+};
+
+
+
+
+
+
+
+
+
+typedef struct sigaltstack
+ {
+ void * ss_sp;
+ int ss_flags;
+ size_t ss_size;
+ } stack_t;
+# 309 "/usr/include/signal.h" 2 3
+
+
+
+
+
+extern int sigstack (__const struct sigstack *__ss,
+ struct sigstack *__oss) ;
+
+
+
+extern int sigaltstack (__const struct sigaltstack *__ss,
+ struct sigaltstack *__oss) ;
+
+
+
+# 342 "/usr/include/signal.h" 3
+
+
+
+
+
+
+extern int __libc_current_sigrtmin (void) ;
+
+extern int __libc_current_sigrtmax (void) ;
+
+
+
+
+
+
+# 68 "port.h" 2
+
+
+# 80 "port.h"
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 147 "port.h"
+
+
+
+
+
+# 1 "/usr/include/stdlib.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 1 3
+
+
+
+
+
+
+
+
+
+# 19 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 61 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 131 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+# 188 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 269 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+# 283 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+# 317 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 33 "/usr/include/stdlib.h" 2 3
+
+
+
+
+
+
+
+
+typedef struct
+ {
+ int quot;
+ int rem;
+ } div_t;
+
+
+
+typedef struct
+ {
+ long int quot;
+ long int rem;
+ } ldiv_t;
+
+
+
+# 65 "/usr/include/stdlib.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+extern size_t __ctype_get_mb_cur_max (void) ;
+
+
+
+extern double atof (__const char *__nptr) ;
+
+extern int atoi (__const char *__nptr) ;
+
+extern long int atol (__const char *__nptr) ;
+
+
+
+__extension__ extern long long int atoll (__const char *__nptr) ;
+
+
+
+extern double strtod (__const char * __nptr,
+ char ** __endptr) ;
+
+
+
+
+
+
+
+
+
+
+
+extern long int strtol (__const char * __nptr,
+ char ** __endptr, int __base) ;
+
+extern unsigned long int strtoul (__const char * __nptr,
+ char ** __endptr,
+ int __base) ;
+
+
+
+__extension__
+extern long long int strtoq (__const char * __nptr,
+ char ** __endptr, int __base) ;
+
+__extension__
+extern unsigned long long int strtouq (__const char * __nptr,
+ char ** __endptr,
+ int __base) ;
+
+
+
+
+
+
+__extension__
+extern long long int strtoll (__const char * __nptr,
+ char ** __endptr, int __base) ;
+
+__extension__
+extern unsigned long long int strtoull (__const char * __nptr,
+ char ** __endptr,
+ int __base) ;
+
+
+
+# 190 "/usr/include/stdlib.h" 3
+
+
+
+
+
+
+extern double __strtod_internal (__const char * __nptr,
+ char ** __endptr,
+ int __group) ;
+extern float __strtof_internal (__const char * __nptr,
+ char ** __endptr, int __group) ;
+extern long double __strtold_internal (__const char *
+ __nptr,
+ char ** __endptr,
+ int __group) ;
+
+extern long int __strtol_internal (__const char * __nptr,
+ char ** __endptr,
+ int __base, int __group) ;
+
+
+
+extern unsigned long int __strtoul_internal (__const char *
+ __nptr,
+ char ** __endptr,
+ int __base, int __group) ;
+
+
+
+
+__extension__
+extern long long int __strtoll_internal (__const char * __nptr,
+ char ** __endptr,
+ int __base, int __group) ;
+
+
+
+__extension__
+extern unsigned long long int __strtoull_internal (__const char *
+ __nptr,
+ char **
+ __endptr,
+ int __base,
+ int __group) ;
+
+
+
+
+# 326 "/usr/include/stdlib.h" 3
+
+
+
+
+
+
+
+extern char *l64a (long int __n) ;
+
+
+extern long int a64l (__const char *__s) ;
+
+
+
+
+
+
+
+
+
+extern int32_t random (void) ;
+
+
+extern void srandom (unsigned int __seed) ;
+
+
+
+
+
+extern void * initstate (unsigned int __seed, void * __statebuf,
+ size_t __statelen) ;
+
+
+
+extern void * setstate (void * __statebuf) ;
+
+
+
+
+
+
+
+struct random_data
+ {
+ int32_t *fptr;
+ int32_t *rptr;
+ int32_t *state;
+ int rand_type;
+ int rand_deg;
+ int rand_sep;
+ int32_t *end_ptr;
+ };
+
+extern int random_r (struct random_data * __buf,
+ int32_t * __result) ;
+
+extern int srandom_r (unsigned int __seed, struct random_data *__buf) ;
+
+extern int initstate_r (unsigned int __seed,
+ void * __statebuf,
+ size_t __statelen,
+ struct random_data * __buf) ;
+
+extern int setstate_r (void * __statebuf,
+ struct random_data * __buf) ;
+
+
+
+
+
+extern int rand (void) ;
+
+extern void srand (unsigned int __seed) ;
+
+
+
+extern int rand_r (unsigned int *__seed) ;
+
+
+
+
+
+
+
+extern double drand48 (void) ;
+extern double erand48 (unsigned short int __xsubi[3]) ;
+
+
+extern long int lrand48 (void) ;
+extern long int nrand48 (unsigned short int __xsubi[3]) ;
+
+
+extern long int mrand48 (void) ;
+extern long int jrand48 (unsigned short int __xsubi[3]) ;
+
+
+extern void srand48 (long int __seedval) ;
+extern unsigned short int *seed48 (unsigned short int __seed16v[3]) ;
+extern void lcong48 (unsigned short int __param[7]) ;
+
+
+struct drand48_data
+ {
+ unsigned short int x[3];
+ unsigned short int a[3];
+ unsigned short int c;
+ unsigned short int old_x[3];
+ int init;
+ };
+
+
+
+extern int drand48_r (struct drand48_data * __buffer,
+ double * __result) ;
+extern int erand48_r (unsigned short int __xsubi[3],
+ struct drand48_data * __buffer,
+ double * __result) ;
+
+
+extern int lrand48_r (struct drand48_data * __buffer,
+ long int * __result) ;
+extern int nrand48_r (unsigned short int __xsubi[3],
+ struct drand48_data * __buffer,
+ long int * __result) ;
+
+
+extern int mrand48_r (struct drand48_data * __buffer,
+ long int * __result) ;
+extern int jrand48_r (unsigned short int __xsubi[3],
+ struct drand48_data * __buffer,
+ long int * __result) ;
+
+
+extern int srand48_r (long int __seedval, struct drand48_data *__buffer) ;
+
+extern int seed48_r (unsigned short int __seed16v[3],
+ struct drand48_data *__buffer) ;
+
+extern int lcong48_r (unsigned short int __param[7],
+ struct drand48_data *__buffer) ;
+
+
+
+
+
+
+
+
+extern void * malloc (size_t __size) ;
+
+extern void * calloc (size_t __nmemb, size_t __size) ;
+
+
+
+
+
+extern void * realloc (void * __ptr, size_t __size) ;
+
+extern void free (void * __ptr) ;
+
+
+
+extern void cfree (void * __ptr) ;
+
+
+
+# 1 "/usr/include/alloca.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 1 3
+
+
+
+
+
+
+
+
+
+# 19 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 61 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 131 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+# 188 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+# 271 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+# 283 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+# 317 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 25 "/usr/include/alloca.h" 2 3
+
+
+
+
+
+
+
+
+extern void * alloca (size_t __size) ;
+
+
+
+
+
+
+
+
+# 492 "/usr/include/stdlib.h" 2 3
+
+
+
+
+
+extern void * valloc (size_t __size) ;
+
+
+
+
+extern void abort (void) __attribute__ ((__noreturn__));
+
+
+
+extern int atexit (void (*__func) (void)) ;
+
+
+
+
+extern int __on_exit (void (*__func) (int __status, void * __arg),
+ void * __arg) ;
+extern int on_exit (void (*__func) (int __status, void * __arg),
+ void * __arg) ;
+
+
+
+
+
+extern void exit (int __status) __attribute__ ((__noreturn__));
+
+
+
+
+
+
+
+
+
+extern char *getenv (__const char *__name) ;
+
+
+
+extern char *__secure_getenv (__const char *__name) ;
+
+
+
+
+
+extern int putenv (__const char *__string) ;
+
+
+
+
+
+extern int setenv (__const char *__name, __const char *__value,
+ int __replace) ;
+
+
+extern void unsetenv (__const char *__name) ;
+
+
+
+
+
+
+extern int clearenv (void) ;
+
+
+
+
+
+
+
+
+extern char *mktemp (char *__template) ;
+
+
+
+
+
+
+extern int mkstemp (char *__template) ;
+
+
+
+
+extern int system (__const char *__command) ;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+extern char *realpath (__const char * __name,
+ char * __resolved) ;
+
+
+
+
+
+
+typedef int (*__compar_fn_t) (__const void * , __const void * ) ;
+
+
+
+
+
+
+
+
+extern void * bsearch (__const void * __key, __const void * __base,
+ size_t __nmemb, size_t __size,
+ __compar_fn_t __compar) ;
+
+
+
+extern void qsort (void * __base, size_t __nmemb, size_t __size,
+ __compar_fn_t __compar) ;
+
+
+
+extern int abs (int __x) __attribute__ ((__const__));
+extern long int labs (long int __x) __attribute__ ((__const__));
+
+
+
+
+
+
+
+
+
+extern div_t div (int __numer, int __denom) __attribute__ ((__const__));
+extern ldiv_t ldiv (long int __numer, long int __denom)
+ __attribute__ ((__const__));
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+extern char *ecvt (double __value, int __ndigit, int * __decpt,
+ int * __sign) ;
+
+
+
+
+extern char *fcvt (double __value, int __ndigit, int * __decpt,
+ int * __sign) ;
+
+
+
+
+extern char *gcvt (double __value, int __ndigit, char *__buf) ;
+
+
+extern char *qecvt (long double __value, int __ndigit,
+ int * __decpt, int * __sign) ;
+extern char *qfcvt (long double __value, int __ndigit,
+ int * __decpt, int * __sign) ;
+extern char *qgcvt (long double __value, int __ndigit, char *__buf) ;
+
+
+
+
+
+extern int ecvt_r (double __value, int __ndigit, int * __decpt,
+ int * __sign, char * __buf,
+ size_t __len) ;
+extern int fcvt_r (double __value, int __ndigit, int * __decpt,
+ int * __sign, char * __buf,
+ size_t __len) ;
+
+extern int qecvt_r (long double __value, int __ndigit,
+ int * __decpt, int * __sign,
+ char * __buf, size_t __len) ;
+extern int qfcvt_r (long double __value, int __ndigit,
+ int * __decpt, int * __sign,
+ char * __buf, size_t __len) ;
+
+
+
+
+
+
+extern int mblen (__const char *__s, size_t __n) ;
+
+
+extern int mbtowc (wchar_t * __pwc,
+ __const char * __s, size_t __n) ;
+
+
+extern int wctomb (char *__s, wchar_t __wchar) ;
+
+
+
+extern size_t mbstowcs (wchar_t * __pwcs,
+ __const char * __s, size_t __n) ;
+
+extern size_t wcstombs (char * __s,
+ __const wchar_t * __pwcs, size_t __n) ;
+
+
+
+
+
+
+
+extern int rpmatch (__const char *__response) ;
+
+
+
+# 732 "/usr/include/stdlib.h" 3
+
+
+
+# 756 "/usr/include/stdlib.h" 3
+
+
+# 766 "/usr/include/stdlib.h" 3
+
+
+
+
+
+
+
+
+# 152 "port.h" 2
+
+# 175 "port.h"
+
+
+
+
+
+# 1 "/usr/include/string.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 1 3
+
+
+
+
+
+
+
+
+
+# 19 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 61 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 131 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+# 188 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+# 271 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+# 283 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+# 317 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/stddef.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 33 "/usr/include/string.h" 2 3
+
+
+
+
+extern void * memcpy (void * __dest,
+ __const void * __src, size_t __n) ;
+
+
+extern void * memmove (void * __dest, __const void * __src,
+ size_t __n) ;
+
+
+
+
+
+extern void * memccpy (void * __dest, __const void * __src,
+ int __c, size_t __n) ;
+
+
+
+
+extern void * memset (void * __s, int __c, size_t __n) ;
+
+
+extern int memcmp (__const void * __s1, __const void * __s2,
+ size_t __n) ;
+
+
+extern void * memchr (__const void * __s, int __c, size_t __n) ;
+
+
+
+
+
+
+
+
+
+extern char *strcpy (char * __dest,
+ __const char * __src) ;
+
+extern char *strncpy (char * __dest,
+ __const char * __src, size_t __n) ;
+
+
+extern char *strcat (char * __dest,
+ __const char * __src) ;
+
+extern char *strncat (char * __dest,
+ __const char * __src, size_t __n) ;
+
+
+extern int strcmp (__const char *__s1, __const char *__s2) ;
+
+extern int strncmp (__const char *__s1, __const char *__s2, size_t __n) ;
+
+
+extern int strcoll (__const char *__s1, __const char *__s2) ;
+
+extern size_t strxfrm (char * __dest,
+ __const char * __src, size_t __n) ;
+
+# 107 "/usr/include/string.h" 3
+
+
+
+
+extern char *__strdup (__const char *__s) ;
+extern char *strdup (__const char *__s) ;
+
+
+
+
+
+
+
+
+
+# 143 "/usr/include/string.h" 3
+
+
+
+extern char *strchr (__const char *__s, int __c) ;
+
+extern char *strrchr (__const char *__s, int __c) ;
+
+
+
+
+
+
+
+
+
+extern size_t strcspn (__const char *__s, __const char *__reject) ;
+
+
+extern size_t strspn (__const char *__s, __const char *__accept) ;
+
+extern char *strpbrk (__const char *__s, __const char *__accept) ;
+
+extern char *strstr (__const char *__haystack, __const char *__needle) ;
+
+
+
+
+
+
+
+
+
+
+extern char *strtok (char * __s,
+ __const char * __delim) ;
+
+
+
+extern char *__strtok_r (char * __s,
+ __const char * __delim,
+ char ** __save_ptr) ;
+
+extern char *strtok_r (char * __s,
+ __const char * __delim,
+ char ** __save_ptr) ;
+
+
+# 203 "/usr/include/string.h" 3
+
+
+
+
+extern size_t strlen (__const char *__s) ;
+
+
+
+
+
+
+
+
+
+extern char *strerror (int __errnum) ;
+
+
+
+extern char *__strerror_r (int __errnum, char *__buf, size_t __buflen) ;
+extern char *strerror_r (int __errnum, char *__buf, size_t __buflen) ;
+
+
+
+
+extern void __bzero (void * __s, size_t __n) ;
+
+
+
+extern void bcopy (__const void * __src, void * __dest, size_t __n) ;
+
+
+extern void bzero (void * __s, size_t __n) ;
+
+
+extern int bcmp (__const void * __s1, __const void * __s2, size_t __n) ;
+
+
+extern char *index (__const char *__s, int __c) ;
+
+
+extern char *rindex (__const char *__s, int __c) ;
+
+
+
+extern int __ffs (int __i) __attribute__ ((const));
+extern int ffs (int __i) __attribute__ ((const));
+
+
+
+
+
+
+
+
+
+
+
+
+extern int __strcasecmp (__const char *__s1, __const char *__s2) ;
+extern int strcasecmp (__const char *__s1, __const char *__s2) ;
+
+
+extern int strncasecmp (__const char *__s1, __const char *__s2,
+ size_t __n) ;
+
+
+# 277 "/usr/include/string.h" 3
+
+
+
+
+
+extern char *strsep (char ** __stringp,
+ __const char * __delim) ;
+
+
+# 319 "/usr/include/string.h" 3
+
+
+
+
+# 347 "/usr/include/string.h" 3
+
+
+
+
+
+
+# 180 "port.h" 2
+
+# 192 "port.h"
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+extern void srandom();
+
+
+
+
+
+
+
+
+
+
+extern void sleep();
+
+
+
+
+
+
+# 1 "/usr/include/assert.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 32 "/usr/include/assert.h" 3
+
+
+
+
+
+
+
+
+
+
+# 56 "/usr/include/assert.h" 3
+
+
+
+
+
+extern void __assert_fail (__const char *__assertion,
+ __const char *__file,
+ unsigned int __line,
+ __const char *__function)
+ __attribute__ ((__noreturn__));
+
+
+extern void __assert_perror_fail (int __errnum,
+ __const char *__file,
+ unsigned int __line,
+ __const char *__function)
+ __attribute__ ((__noreturn__));
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 224 "port.h" 2
+
+# 238 "port.h"
+
+
+
+
+
+# 1 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/limits.h" 1 3
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/syslimits.h" 1 3
+
+
+
+
+
+
+# 1 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/limits.h" 1 3
+
+
+
+
+
+# 114 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/limits.h" 3
+
+
+
+# 1 "/usr/include/limits.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/include/bits/posix1_lim.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/include/bits/local_lim.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "/usr/include/linux/limits.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 27 "/usr/include/bits/local_lim.h" 2 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 126 "/usr/include/bits/posix1_lim.h" 2 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 30 "/usr/include/limits.h" 2 3
+
+
+
+
+# 1 "/usr/include/bits/posix2_lim.h" 1 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 34 "/usr/include/limits.h" 2 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 121 "/usr/include/limits.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 117 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/limits.h" 2 3
+
+
+
+
+# 7 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/syslimits.h" 2 3
+
+
+# 11 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/limits.h" 2 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 107 "/usr/lib/gcc-lib/i386-slackware-linux/egcs-2.91.66/include/limits.h" 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 243 "port.h" 2
+
+
+
+
+
+
+
+
+
+
+
+
+# 5 "espresso.h" 2
+
+# 1 "utility.h" 1
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 1 "ansi.h" 1
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 42 "utility.h" 2
+
+
+extern long util_cpu_time
+ () ;
+extern char *util_path_search
+ (char *program) ;
+extern char *util_file_search
+ (char *file, char *path, char *mode) ;
+extern int util_pipefork
+ (char **argv, FILE **toCommand, FILE **fromCommand, int *pid) ;
+extern int util_csystem
+ (char *command) ;
+extern char *util_print_time
+ (long t) ;
+extern char *util_strsav
+ (char *ptr) ;
+extern char *util_tilde_expand
+ (char *filename) ;
+extern char *util_tilde_compress
+ (char *filename) ;
+extern void util_register_user
+ (char *user, char *directory) ;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 6 "espresso.h" 2
+
+# 1 "sparse.h" 1
+
+
+
+
+
+
+
+typedef struct sm_element_struct sm_element;
+typedef struct sm_row_struct sm_row;
+typedef struct sm_col_struct sm_col;
+typedef struct sm_matrix_struct sm_matrix;
+
+
+
+
+
+struct sm_element_struct {
+ int row_num;
+ int col_num;
+ sm_element *next_row;
+ sm_element *prev_row;
+ sm_element *next_col;
+ sm_element *prev_col;
+ char *user_word;
+};
+
+
+
+
+
+struct sm_row_struct {
+ int row_num;
+ int length;
+ int flag;
+ sm_element *first_col;
+ sm_element *last_col;
+ sm_row *next_row;
+ sm_row *prev_row;
+ char *user_word;
+};
+
+
+
+
+
+struct sm_col_struct {
+ int col_num;
+ int length;
+ int flag;
+ sm_element *first_row;
+ sm_element *last_row;
+ sm_col *next_col;
+ sm_col *prev_col;
+ char *user_word;
+};
+
+
+
+
+
+struct sm_matrix_struct {
+ sm_row **rows;
+ int rows_size;
+ sm_col **cols;
+ int cols_size;
+ sm_row *first_row;
+ sm_row *last_row;
+ int nrows;
+ sm_col *first_col;
+ sm_col *last_col;
+ int ncols;
+ char *user_word;
+};
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+extern sm_matrix *sm_alloc(), *sm_alloc_size(), *sm_dup();
+extern void sm_free(), sm_delrow(), sm_delcol(), sm_resize();
+extern void sm_write(), sm_print(), sm_dump(), sm_cleanup();
+extern void sm_copy_row(), sm_copy_col();
+extern void sm_remove(), sm_remove_element();
+extern sm_element *sm_insert(), *sm_find();
+extern sm_row *sm_longest_row();
+extern sm_col *sm_longest_col();
+extern int sm_read(), sm_read_compressed();
+
+extern sm_row *sm_row_alloc(), *sm_row_dup(), *sm_row_and();
+extern void sm_row_free(), sm_row_remove(), sm_row_print();
+extern sm_element *sm_row_insert(), *sm_row_find();
+extern int sm_row_contains(), sm_row_intersects();
+extern int sm_row_compare(), sm_row_hash();
+
+extern sm_col *sm_col_alloc(), *sm_col_dup(), *sm_col_and();
+extern void sm_col_free(), sm_col_remove(), sm_col_print();
+extern sm_element *sm_col_insert(), *sm_col_find();
+extern int sm_col_contains(), sm_col_intersects();
+extern int sm_col_compare(), sm_col_hash();
+
+extern int sm_row_dominance(), sm_col_dominance(), sm_block_partition();
+
+
+# 7 "espresso.h" 2
+
+# 1 "mincov.h" 1
+
+extern sm_row *sm_minimum_cover();
+# 8 "espresso.h" 2
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\f
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+typedef unsigned int *pset;
+
+
+typedef struct set_family {
+ int wsize;
+ int sf_size;
+ int capacity;
+ int count;
+ int active_count;
+ pset data;
+ struct set_family *next;
+} set_family_t, *pset_family;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 178 "espresso.h"
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+extern int bit_count[256];
+
+\f
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+typedef struct cost_struct {
+ int cubes;
+ int in;
+ int out;
+ int mv;
+ int total;
+ int primes;
+} cost_t, *pcost;
+
+
+
+typedef struct pair_struct {
+ int cnt;
+ int *var1;
+ int *var2;
+} pair_t, *ppair;
+
+
+
+typedef struct symbolic_list_struct {
+ int variable;
+ int pos;
+ struct symbolic_list_struct *next;
+} symbolic_list_t;
+
+
+
+typedef struct symbolic_label_struct {
+ char *label;
+ struct symbolic_label_struct *next;
+} symbolic_label_t;
+
+
+
+typedef struct symbolic_struct {
+ symbolic_list_t *symbolic_list;
+ int symbolic_list_length;
+ symbolic_label_t *symbolic_label;
+ int symbolic_label_length;
+ struct symbolic_struct *next;
+} symbolic_t;
+
+
+
+typedef struct {
+ pset_family F, D, R;
+ char *filename;
+ int pla_type;
+ pset phase;
+ ppair pair;
+ char **label;
+ symbolic_t *symbolic;
+ symbolic_t *symbolic_output;
+} PLA_t, *pPLA;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\f
+
+
+
+
+extern unsigned int debug;
+extern int verbose_debug;
+extern char *total_name[16 ];
+extern long total_time[16 ];
+extern int total_calls[16 ];
+
+extern int echo_comments;
+extern int echo_unknown_commands;
+extern int force_irredundant;
+extern int skip_make_sparse;
+extern int kiss;
+extern int pos;
+extern int print_solution;
+extern int recompute_onset;
+extern int remove_essential;
+extern int single_expand;
+extern int summary;
+extern int trace;
+extern int unwrap_onset;
+extern int use_random_order;
+extern int use_super_gasp;
+extern char *filename;
+extern int debug_exact_minimization;
+
+
+
+
+
+struct pla_types_struct {
+ char *key;
+ int value;
+};
+
+
+
+
+
+
+
+
+
+
+struct cube_struct {
+ int size;
+ int num_vars;
+ int num_binary_vars;
+ int *first_part;
+ int *last_part;
+ int *part_size;
+ int *first_word;
+ int *last_word;
+ pset binary_mask;
+ pset mv_mask;
+ pset *var_mask;
+ pset *temp;
+ pset fullset;
+ pset emptyset;
+ unsigned int inmask;
+ int inword;
+ int *sparse;
+ int num_mv_vars;
+ int output;
+};
+
+struct cdata_struct {
+ int *part_zeros;
+ int *var_zeros;
+ int *parts_active;
+ int *is_unate;
+ int vars_active;
+ int vars_unate;
+ int best;
+};
+
+
+extern struct pla_types_struct pla_types[];
+/*extern*/ struct cube_struct cube, temp_cube_save;
+extern struct cdata_struct cdata, temp_cdata_save;
+
+
+
+
+
+
+
+
+
+
+\f
+
+
+ extern int binate_split_select();
+ extern pset_family cubeunlist();
+ extern pset *cofactor();
+ extern pset *cube1list();
+ extern pset *cube2list();
+ extern pset *cube3list();
+ extern pset *scofactor();
+ extern void massive_count();
+ extern pset_family complement();
+ extern pset_family simplify();
+ extern void simp_comp();
+ extern int d1_rm_equal();
+ extern int rm2_contain();
+ extern int rm2_equal();
+ extern int rm_contain();
+ extern int rm_equal();
+ extern int rm_rev_contain();
+ extern pset *sf_list();
+ extern pset *sf_sort();
+ extern pset_family d1merge();
+ extern pset_family dist_merge();
+ extern pset_family sf_contain();
+ extern pset_family sf_dupl();
+ extern pset_family sf_ind_contain();
+ extern pset_family sf_ind_unlist();
+ extern pset_family sf_merge();
+ extern pset_family sf_rev_contain();
+ extern pset_family sf_union();
+ extern pset_family sf_unlist();
+ extern void cube_setup();
+ extern void restore_cube_struct();
+ extern void save_cube_struct();
+ extern void setdown_cube();
+ extern PLA_labels();
+ extern char *get_word();
+ extern int label_index();
+ extern int read_pla();
+ extern int read_symbolic();
+ extern pPLA new_PLA();
+ extern void PLA_summary();
+ extern void free_PLA();
+ extern void parse_pla();
+ extern void read_cube();
+ extern void skip_line();
+ extern foreach_output_function();
+ extern int cubelist_partition();
+ extern int so_both_do_espresso();
+ extern int so_both_do_exact();
+ extern int so_both_save();
+ extern int so_do_espresso();
+ extern int so_do_exact();
+ extern int so_save();
+ extern pset_family cof_output();
+ extern pset_family lex_sort();
+ extern pset_family mini_sort();
+ extern pset_family random_order();
+ extern pset_family size_sort();
+ extern pset_family sort_reduce();
+ extern pset_family uncof_output();
+ extern pset_family unravel();
+ extern pset_family unravel_range();
+ extern void so_both_espresso();
+ extern void so_espresso();
+ extern char *fmt_cost();
+ extern char *print_cost();
+ extern char *strsav();
+ extern void copy_cost();
+ extern void cover_cost();
+ extern void fatal();
+ extern void print_trace();
+ extern void size_stamp();
+ extern void totals();
+ extern char *fmt_cube();
+ extern char *fmt_expanded_cube();
+ extern char *pc1();
+ extern char *pc2();
+ extern char *pc3();
+ extern int makeup_labels();
+ extern kiss_output();
+ extern kiss_print_cube();
+ extern output_symbolic_constraints();
+ extern void cprint();
+ extern void debug1_print();
+ extern void debug_print();
+ extern void eqn_output();
+ extern void fpr_header();
+ extern void fprint_pla();
+ extern void pls_group();
+ extern void pls_label();
+ extern void pls_output();
+ extern void print_cube();
+ extern void print_expanded_cube();
+ extern void sf_debug_print();
+ extern find_equiv_outputs();
+ extern int check_equiv();
+ extern pset_family espresso();
+ extern int essen_cube();
+ extern pset_family cb_consensus();
+ extern pset_family cb_consensus_dist0();
+ extern pset_family essential();
+ extern pset_family minimize_exact();
+ extern pset_family minimize_exact_literals();
+ extern int feasibly_covered();
+ extern int most_frequent();
+ extern pset_family all_primes();
+ extern pset_family expand();
+ extern pset_family find_all_primes();
+ extern void elim_lowering();
+ extern void essen_parts();
+ extern void essen_raising();
+ extern void expand1();
+ extern void mincov();
+ extern void select_feasible();
+ extern void setup_BB_CC();
+ extern pset_family expand_gasp();
+ extern pset_family irred_gasp();
+ extern pset_family last_gasp();
+ extern pset_family super_gasp();
+ extern void expand1_gasp();
+ extern int getopt();
+ extern find_dc_inputs();
+ extern find_inputs();
+ extern form_bitvector();
+ extern map_dcset();
+ extern map_output_symbolic();
+ extern map_symbolic();
+ extern pset_family map_symbolic_cover();
+ extern symbolic_hack_labels();
+ extern int cube_is_covered();
+ extern int taut_special_cases();
+ extern int tautology();
+ extern pset_family irredundant();
+ extern void mark_irredundant();
+ extern void irred_split_cover();
+ extern sm_matrix *irred_derive_table();
+ extern pset minterms();
+ extern void explode();
+ extern void map();
+ extern output_phase_setup();
+ extern pPLA set_phase();
+ extern pset_family opo();
+ extern pset find_phase();
+ extern pset_family find_covers();
+ extern pset_family form_cover_table();
+ extern pset_family opo_leaf();
+ extern pset_family opo_recur();
+ extern void opoall();
+ extern void phase_assignment();
+ extern void repeated_phase_assignment();
+ extern generate_all_pairs();
+ extern int **find_pairing_cost();
+ extern int find_best_cost();
+ extern int greedy_best_cost();
+ extern int minimize_pair();
+ extern int pair_free();
+ extern pair_all();
+ extern pset_family delvar();
+ extern pset_family pairvar();
+ extern ppair pair_best_cost();
+ extern ppair pair_new();
+ extern ppair pair_save();
+ extern print_pair();
+ extern void find_optimal_pairing();
+ extern void set_pair();
+ extern void set_pair1();
+ extern pset_family primes_consensus();
+ extern int sccc_special_cases();
+ extern pset_family reduce();
+ extern pset reduce_cube();
+ extern pset sccc();
+ extern pset sccc_cube();
+ extern pset sccc_merge();
+ extern int set_andp();
+ extern int set_orp();
+ extern int setp_disjoint();
+ extern int setp_empty();
+ extern int setp_equal();
+ extern int setp_full();
+ extern int setp_implies();
+ extern char *pbv1();
+ extern char *ps1();
+ extern int *sf_count();
+ extern int *sf_count_restricted();
+ extern int bit_index();
+ extern int set_dist();
+ extern int set_ord();
+ extern void set_adjcnt();
+ extern pset set_and();
+ extern pset set_clear();
+ extern pset set_copy();
+ extern pset set_diff();
+ extern pset set_fill();
+ extern pset set_merge();
+ extern pset set_or();
+ extern pset set_xor();
+ extern pset sf_and();
+ extern pset sf_or();
+ extern pset_family sf_active();
+ extern pset_family sf_addcol();
+ extern pset_family sf_addset();
+ extern pset_family sf_append();
+ extern pset_family sf_bm_read();
+ extern pset_family sf_compress();
+ extern pset_family sf_copy();
+ extern pset_family sf_copy_col();
+ extern pset_family sf_delc();
+ extern pset_family sf_delcol();
+ extern pset_family sf_inactive();
+ extern pset_family sf_join();
+ extern pset_family sf_new();
+ extern pset_family sf_permute();
+ extern pset_family sf_read();
+ extern pset_family sf_save();
+ extern pset_family sf_transpose();
+ extern void set_write();
+ extern void sf_bm_print();
+ extern void sf_cleanup();
+ extern void sf_delset();
+ extern void sf_free();
+ extern void sf_print();
+ extern void sf_write();
+ extern int ccommon();
+ extern int cdist0();
+ extern int full_row();
+ extern int ascend();
+ extern int cactive();
+ extern int cdist();
+ extern int cdist01();
+ extern int cvolume();
+ extern int d1_order();
+ extern int d1_order_size();
+ extern int desc1();
+ extern int descend();
+ extern int lex_order();
+ extern int lex_order1();
+ extern pset force_lower();
+ extern void consensus();
+ extern pset_family cb1_dsharp();
+ extern pset_family cb_dsharp();
+ extern pset_family cb_recur_dsharp();
+ extern pset_family cb_recur_sharp();
+ extern pset_family cb_sharp();
+ extern pset_family cv_dsharp();
+ extern pset_family cv_intersect();
+ extern pset_family cv_sharp();
+ extern pset_family dsharp();
+ extern pset_family make_disjoint();
+ extern pset_family sharp();
+ pset do_sm_minimum_cover();
+ extern pset_family make_sparse();
+ extern pset_family mv_reduce();
+
+ extern qst();
+ extern pset_family find_all_minimal_covers_petrick();
+ extern pset_family map_cover_to_unate();
+ extern pset_family map_unate_to_cover();
+ extern pset_family exact_minimum_cover();
+ extern pset_family gen_primes();
+ extern pset_family unate_compl();
+ extern pset_family unate_complement();
+ extern pset_family unate_intersect();
+ extern PLA_permute();
+ extern int PLA_verify();
+ extern int check_consistency();
+ extern int verify();
+# 1 "cof.c" 2
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+pset *cofactor(T, c)
+ pset *T;
+ register pset c;
+{
+ pset temp = cube.temp[0], *Tc_save, *Tc, *T1;
+ register pset p;
+ int listlen;
+
+
+# 49 "cof.c"
+
+
+
+ for(T1 = T+2; (p = *T1++) != ((void *)0) ; ) {
+ if (p != c) {
+
+
+ {
+ register int w, last;
+ register unsigned int x;
+
+ if ((last=cube.inword) != -1) {
+ x = p[last] & c[last];
+ if (~(x|x>>1) & cube.inmask)
+ goto false;
+ for (w=1;w<last;w++) {
+ x = p[w] & c[w];
+ if (~(x|x>>1) & 0x55555555 )
+ goto false;
+ }
+ }
+ }
+
+ {
+ register int w, var, last;
+ register pset mask;
+
+ for (var=cube.num_binary_vars; var<cube.num_vars; var++) {
+ mask = cube.var_mask[var];
+ last = cube.last_word[var];
+ for (w=cube.first_word[var]; w<=last; w++)
+ if (p[w] & c[w] & mask[w])
+ goto nextvar;
+ goto false;
+ nextvar:;
+ }
+ }
+
+
+ *Tc++ = p;
+ false: ;
+ }
+ }
+
+ *Tc++ = (pset ) ((void *)0) ;
+ Tc_save[1] = (pset ) Tc;
+ return Tc_save;
+}
+\f
+
+# 400 "cof.c"
+
+int main()
+{
+ return 0;
+}
--- /dev/null
+// comb1.c
+// part 1/4 of a program expected to be combined
+
+#ifndef __HEAPIFY
+ #define __HEAPIFY
+#endif
+
+int global_com4; //even without an extern decl, this should link to comb4's
+ //global var, which is initialized to 5.
+
+int *globalPtr;
+
+void hpfy()
+{
+ int local __HEAPIFY;
+ globalPtr = &local;
+}
+
+int foo_com1(int x)
+{
+ return x + global_com4;
+}
+
--- /dev/null
+// comb2.c
+// part 2/4 of a program expected to be combined
+
+#include "../small1/testharness.h"
+
+static int global_com2 = 5;
+
+int foo2_com2(int x)
+{
+ return x + global_com2;
+}
+
+extern int foo_com3(int x);
+extern void hpfy();
+
+int main()
+{
+ int res1 = foo_com3(6);
+ int res2 = foo2_com4(61);
+ printf("foo_com3(6): %d\n", res1);
+ printf("foo2_com4(61): %d\n", res2);
+ if (res1 != (11+sizeof(int*))) E(1);
+ if (res2 != 70) E(2);
+ hpfy();
+ return 0;
+}
--- /dev/null
+// comb3.c
+// part 3/4 of a program expected to be combined
+
+static double global_com2 = 1.0;
+extern int foo_com1(int x);
+
+int foo_com3(int x)
+{
+ return foo_com1(x) + sizeof(int*);
+}
+
--- /dev/null
+// comb4.c
+// part 4/4 of a program expected to be combined
+
+int global_com4 = 5;
+int foo2_com2(int x);
+
+int foo2_com4(int x)
+{
+ return foo2_com2(x) +4;
+}
+
--- /dev/null
+typedef unsigned short setword;
+typedef setword * setptr;
+extern setptr Conset[];
+typedef struct { setword S[6]; } symset;
+
+void checksymbol(symset ss) {}
+void Member(unsigned int m, setptr sp) {}
+
+int main()
+{
+ Member((unsigned)(7), Conset[0]);
+ Member((unsigned)(8), Conset[1]);
+ checksymbol(*((symset *)Conset[6]));
+ checksymbol(*((symset *)Conset[7]));
+ return 0;
+}
+
+static setword Q0[] = {
+ 1,
+ 0x03FD
+};
+static setword Q1[] = {
+ 1,
+ 0x004C
+};
+static setword Q2[] = {
+ 1,
+ 0x0000
+};
+static setword Q3[] = {
+ 2,
+ 0x000E, 0x5210
+};
+static setword Q4[] = {
+ 2,
+ 0x000E, 0x1210
+};
+static setword Q5[] = {
+ 1,
+ 0x0C00
+};
+static setword Q6[] = {
+ 1,
+ 0x000C
+};
+static setword Q7[] = {
+ 2,
+ 0x000E, 0x0210
+};
+static setword Q8[] = {
+ 3,
+ 0x0000, 0x0000, 0x0060
+};
+static setword Q9[] = {
+ 4,
+ 0x0002, 0x0000, 0x0064, 0x0800
+};
+static setword Q10[] = {
+ 1,
+ 0x0C00
+};
+static setword *Conset[] = {
+ Q10, Q9, Q8, Q7, Q6, Q5,
+ Q4, Q3, Q2, Q1, Q0
+};
--- /dev/null
+// tricky const decl
+
+#include <string.h> // strlen
+
+// first declare the fn
+static int foo(char const *a, char const *b);
+
+// now define it using old-style args
+static int foo(a, b)
+ #if 0
+ char const *a, *b; // looks like we're not associating 'const' with 'b'?
+ #else
+ char const *a; // actually, this fails too..
+ char const *b;
+ #endif
+{
+ return strlen(a) + strlen(b);
+}
+
+int main()
+{
+ return foo("aa", "bbb") - 5;
+}
--- /dev/null
+// constfold.c
+// problem with ijpeg and power constant folding
+
+double sqrt(double x)
+{
+ return x*x; // close enough for parsing testing
+}
+
+int main()
+{
+ {
+ float z10, z5, tmp12;
+ tmp12 = (float )(- 2.613125930) * z10 + z5; // ijpeg
+ }
+
+ {
+ double a,b,c,root;
+ root = (-b-sqrt(b*b-4*a*c))/(2*a); // power
+ }
+
+ return 0;
+}
--- /dev/null
+
+
+enum foo {
+ e0 = sizeof(int),
+ e1,
+ e2 = e0 + 1
+};
+
+int useenum(enum foo x) {
+ switch(x) {
+ case e1: return 0;
+ case e2 * 2: return 1;
+ case sizeof(int): return 2;
+
+ }
+}
+
+TESTDEF "enum1" : success ~ case +sizeof *\( *int *\)
+TESTDEF "enum2" : success ~ e2 *\* *2
+TESTDEF "enum3" : success ~ e0 *\+ *1
+int main() {
+ return 0;
+}
--- /dev/null
+// test ctype functions
+
+#include <ctype.h> // various
+#include <stdio.h> // printf
+
+void analyze(int ch)
+{
+ printf("character: %c\n", ch);
+ printf(" decimal: %d\n", ch);
+ printf(" isalpha: %d\n", !!isalpha(ch));
+ printf(" isdigit: %d\n", !!isdigit(ch));
+}
+
+int main()
+{
+ analyze('a');
+ analyze('5');
+ analyze('$');
+ analyze('Z');
+ return 0;
+}
+
--- /dev/null
+struct Foo {
+ char *name;
+ int value;
+};
+struct Foo debug_table[] = {
+ { "", 0x0004 + 0x0002 + 0x0020 + 0x0040 + 0x0100 + 0x0010 + 0x2000 + 0x0800 },
+ { "compl", 0x0001 , },{ "essen", 0x0002 },
+ { "expand", 0x0004 , },{ "expand1", 0x0008 | 0x0004 },
+ { "irred", 0x0020 , },{ "irred1", 0x4000 | 0x0020 },
+ { "reduce", 0x0040 , },{ "reduce1", 0x0080 | 0x0040 },
+ { "mincov", 0x0800 , },{ "mincov1", 0x1000 | 0x0800 },
+ { "sparse", 0x0100 , },{ "sharp", 0x2000 },
+ { "taut", 0x0200 , },{ "gasp", 0x0010 },
+ { "exact", 0x0400 },
+ { 0 },
+};
+
+unsigned int debug;
+
+int main()
+{
+ debug = debug_table[0].value;
+ return 0;
+}
--- /dev/null
+// ehstack.c
+// NUMERRORS 1
+// build a small exception-handling stack, verify field annotation works
+
+#ifndef CCURED
+ #define __MAYPOINTTOSTACK
+#endif
+
+struct Entry {
+ struct Entry *next __MAYPOINTTOSTACK;
+ int *otherPointer; // not allowed to point at stack
+ int x;
+};
+
+int *somePtr;
+
+//matth: making e1 global so ERROR(1) below fails.
+struct Entry e1;
+
+int function(int argc, char **argv)
+{
+ //matth: if e1 is local, there's nothing wrong with storing &e2.x in it.
+ struct Entry /*e1,*/ e2;
+ int *wildGuy;
+
+ // make everybody wild
+ wildGuy = (int*)&somePtr;
+ wildGuy = (int*)&e1;
+ wildGuy = (int*)&e2;
+
+ // I want to allow this
+ e1.next = &e2;
+
+ // but not this
+ e1.otherPointer = &e2.x; // ERROR(1): Storing stack address
+
+ return 0;
+}
+
+
+int main(int argc, char **argv) {
+ function(argc, argv);
+}
--- /dev/null
+// enumattr.c
+// enums with attributes
+
+typedef enum {
+ x = 256
+} __attribute__((__packed__)) large_enum;
+
+large_enum enum_l = x;
+
+int main()
+{
+ return 0;
+}
--- /dev/null
+// enumerator_sizeof.c
+// an example from the CIL docs, this is an enumeration
+// where one of the enumerators is a sizeof expression
+
+#include <assert.h> // assert
+
+enum {
+ FIVE = 5,
+ SIX, SEVEN,
+ FOUR = FIVE - 1,
+ EIGHT = sizeof(double)
+};
+
+int main()
+{
+ // store the enumerator values in an array, so the
+ // optimizer won't get too clever
+ int n[10], i;
+ n[4] = FOUR;
+ n[5] = FIVE;
+ n[6] = SIX;
+ n[7] = SEVEN;
+ n[8] = EIGHT;
+
+ for (i=4; i<=8; i++) {
+ assert(i == n[i]);
+ }
+
+ return 0;
+}
+
--- /dev/null
+// enums where one tag is init'd with another
+
+int printf(char const *fmt, ...);
+
+// this was messing up the parser
+enum __rlimit_resource {
+ _RLIMIT_CPU = 0,
+ RLIMIT_CPU = _RLIMIT_CPU,
+ _RLIMIT_FSIZE = 1,
+ RLIMIT_FSIZE = _RLIMIT_FSIZE,
+ _RLIMIT_DATA = 2,
+ RLIMIT_DATA = _RLIMIT_DATA,
+};
+
+#define PVAL(val) printf(#val " = %d\n", val)
+
+int main()
+{
+ printf("whazzup?!\n");
+ PVAL(_RLIMIT_CPU);
+ PVAL(RLIMIT_CPU);
+ PVAL(_RLIMIT_FSIZE);
+ PVAL(RLIMIT_FSIZE);
+ PVAL(_RLIMIT_DATA);
+ PVAL(RLIMIT_DATA);
+ return 0;
+}
--- /dev/null
+// enuminit2.c
+// from sac at stevechamberlain dot com
+
+// some weird expression kinds for enums
+
+// NUMERRORS 1
+
+// should fail
+enum {x = 3.0 }; // ERROR(1)
+
+// should pass
+struct a { int j:' ';} p;
+
+
+int main()
+{
+ return 0;
+}
--- /dev/null
+
+int main () {
+ char c[8] = "an error!";
+ return c[0] - 'a' + c[7] - 'r';
+}
--- /dev/null
+//Here is code that might be generated by CIL. Test that
+//when reading it back in, the suffix __extinline doesn't cause problems.
+
+//This bug comes up when merging Apache.
+
+//Make sure the test runs without changes:
+//KEEP baseline: success
+
+__inline static int identity__extinline(int x) {
+ return x;
+}
+
+int foo(int x) {
+ return identity__extinline(x);
+}
+
+//But what if there's another extern inline function called identity,
+// that we want to rename to identity__extinline?
+//Make sure we report an error in this case
+inline extern int identity(int x) { //KEEP bad: error = Trying to rename
+ return 10; //KEEP bad
+} //KEEP bad
+int bar(x) { return identity(x); } //KEEP bad
+
+int identity(int x);
+int identity(int x) {
+ return x+2;
+}
+
+
+int main(int *p, char** argv)
+{
+ return identity(-2) + foo(0);
+}
+
+
--- /dev/null
+// fig1.c
+// program in our paper, figure 1
+
+#include <stdio.h> // printf
+#include <stdlib.h> // malloc
+
+int **getArray()
+{
+ int **a = (int**)malloc(100 * sizeof(*a));
+ int i;
+
+ for (i=0; i<100; i++) {
+ a[i] = (int*) (((i+1) << 1) | 1); // for the moment, no boxing
+ }
+
+ return a;
+}
+
+
+int main()
+{
+ int **a = getArray();
+ int i;
+ int acc;
+ int **p;
+ int *e;
+
+ acc = 0;
+ for (i=0; i<100; i++) {
+ p = a + i;
+ e = *p;
+ while ((int)e % 2 == 0) {
+ e = *(int**)e;
+ }
+ acc += ((int)e >> 1);
+ }
+
+ printf("acc is %d\n", acc); // should be 5050
+ return 0;
+}
--- /dev/null
+// fmtstr.c
+// demonstrate a format-string bug
+
+#include <stdio.h>
+
+int main()
+{
+ char *s = "%d -- bad!\n";
+ printf(s);
+ return 0;
+}
--- /dev/null
+#include "../small1/testharness.h"
+
+// NUMERRORS 4
+
+int one; // Just to hide the arithemtic from CCured
+
+typedef struct { int i1, i2; } two_int;
+
+two_int g;
+
+// Tests for FSEQ and FSEQN
+#ifdef ERROR == 0
+ #define P_KIND __FSEQ
+#elif ERROR == 1
+ #define P_KIND __FSEQ
+#elif ERROR == 2
+ #define P_KIND __FSEQN
+#elif ERROR == 3
+ #define P_KIND __SEQ
+#else
+ #define P_KIND __SEQN
+#endif
+
+// Converts without seeing in
+int * P_KIND safeToSeq(two_int * __SAFE in) {
+ // Will convert to { in, in + 8bytes }, if the bug is present
+ // It should check first that in is non ZERO
+ return (int*)in;
+}
+
+
+int test_fseq() {
+ int *f = safeToSeq(&g);
+ int dummy = f[one]; // Make sure f is FSEQ
+#if ERROR >= 3
+ int dummy2 = *(f + one); // Make it SEQ
+#endif
+ // Now use the same function to convert the number 0
+ // The bug is that we return the pointer {0, 8}
+ // Bad cannot be SAFE of else we'll fail the Non-pointer test
+ int * P_KIND bad = safeToSeq(0);
+ // We can increment bad and read
+ // ERROR(1):Non-pointer
+ // ERROR(2):Non-pointer
+ // ERROR(3):Non-pointer
+ // ERROR(4):Non-pointer
+#if ERROR > 0
+ int res = bad[1];
+#endif
+ return 0;
+}
+
+
+int main() {
+ one = 1;
+ test_fseq();
+ SUCCESS;
+}
+
--- /dev/null
+extern void exit(int);
+extern int strcmp(const char*, const char*);
+extern int printf(const char*, ...);
+
+//Note that the concatenation in the strcmp arguments doesn't work on gcc4.
+//Maybe __FUNCTION__ is no longer considered a literal??
+
+int main(void) {
+
+ printf("__FUNCTION__ = %s\n", __FUNCTION__);
+ printf("__PRETTY_FUNCTION__ = %s\n", __PRETTY_FUNCTION__);
+
+ if(strcmp("This is " __FUNCTION__, "This is main") ||
+ strcmp("This is " __PRETTY_FUNCTION__, "This is main")) {
+ exit(1);
+ }
+ exit(0);
+}
--- /dev/null
+// testing function ptrs etc
+
+#include <stdlib.h> // malloc/free
+#include <stdio.h> // printf
+
+struct S {
+ int ix;
+ int *py;
+};
+
+// gratuitously incompatible with S
+struct T {
+ int *px;
+ int iy;
+};
+
+typedef int (*acceptsS)(struct S *ps, int a);
+
+int multXbyY(struct S *ps, int a)
+{
+ printf("in multXbyY, a is %d\n", a);
+ return ps->ix * (* (ps->py) ) + a;
+}
+
+int zero = 0; // hide a literal from CCured
+
+int doSomethingToS(struct S *ps, acceptsS func)
+{
+ struct S *wildptr = ps;
+
+ printf("in doSomethingToS\n");
+
+ // make wildptr be wild
+ if (zero) {
+ struct T *pt = (struct T*)malloc(sizeof(*pt));
+ pt->px = (int*)malloc(sizeof(* (pt->px) ));
+ *(pt->px) = 3;
+ pt->iy = 13;
+
+ wildptr = (struct S*)pt;
+ }
+
+ // wildptr is wild, and func's type has been changed to appear
+ // to accept a wild pointer, but it still points to 'multXbyY',
+ // which has been inferred to accept a safe ptr; therefore, instead
+ // of '9' being passed as the 2nd arg, 'multXbyY' sees wildptr's _b
+ // field as its 'a' arg
+ printf("calling func with a=%d\n", 9);
+ return func(wildptr, 9);
+}
+
+int main()
+{
+ struct S *ps = (struct S*)malloc(sizeof(*ps));
+ int ret;
+
+ ps->ix = 8;
+ ps->py = (int*)malloc(sizeof(* (ps->py) ));
+ *(ps->py) = 9;
+ ret = doSomethingToS(ps, multXbyY) - 81;
+
+ free(ps);
+
+ printf("returning %d from main\n", ret);
+ return ret;
+}
--- /dev/null
+// testing function ptrs etc
+
+#include <stdlib.h> // malloc/free
+#include <stdio.h> // printf
+
+struct S {
+ int ix;
+ int *py;
+};
+
+// gratuitously incompatible with S
+struct T {
+ int *px;
+ int iy;
+};
+
+struct Func {
+ struct S* (*returnsS)(int a);
+};
+
+struct Func *makeFunc(struct S* (*func)())
+{
+ struct Func *f = (struct Func*)malloc(sizeof(*f));
+ f->returnsS = func;
+ return f;
+}
+
+struct S* makeAnS(int a)
+{
+ struct S *ret = (struct S*)malloc(sizeof(*ret));
+ ret->ix = a;
+ ret->py = NULL;
+ printf("returning %p\n", ret);
+ return ret;
+}
+
+int zero = 0;
+
+int doSomethingToS(struct Func *func, int a)
+{
+ struct S *wildptr;
+
+ wildptr = (*(func->returnsS))(a);
+
+ printf("got back %p\n", wildptr);
+
+ // make wildptr be wild
+ if (zero) {
+ struct T *pt = (struct T*)malloc(sizeof(*pt));
+ pt->px = (int*)malloc(sizeof(* (pt->px) ));
+ *(pt->px) = 3;
+ pt->iy = 13;
+
+ wildptr = (struct S*)pt;
+ }
+
+ return 0;
+}
+
+struct Func f;
+
+int main()
+{
+ return doSomethingToS(makeFunc(makeAnS), 4);
+ // ^^^^^^^
+ // this argument is the wrong type, but silently accepted!
+}
--- /dev/null
+/* This exhibits a bug with the types of tagged functions whose arguments
+ * appear tagged */
+int foo(int x);
+
+struct S {
+ void (*fptr)();
+} g = { &foo };
+
+int main() {
+ // Make g (and thus foo) TAGGED
+ int *pg = (int*)&g;
+}
+
+int foo(int arg) {
+ // Now take the address of x and make it tagged
+ int **px = &arg;
+ return arg;
+}
--- /dev/null
+// gimpdouble.c
+// examples of gimp's usage of doubles and enums
+
+typedef enum {
+ ZERO,
+ ONE
+} Something;
+
+int main()
+{
+ double d;
+ Something s;
+
+ d = ZERO;
+ s = d;
+
+ return s;
+}
+
--- /dev/null
+
+typedef struct {
+ volatile unsigned int lock;
+} spinlock_t;
+
+spinlock_t runqueue_lock __attribute__((__aligned__(32 ),
+ __section__(".data.cacheline_aligned"))) = (spinlock_t) { 1 } ;
+
+
+int main () {
+ return 0;
+}
--- /dev/null
+#include "../small1/testharness.h"
+#include "../small1/testkinds.h"
+
+#ifndef __SEQ
+#define __SEQ
+#define __WILD
+#define __INDEX
+#endif
+// Test the global initializer
+
+// NUMERRORS 14
+
+struct S {
+ struct {
+ int *p1;
+ int i2;
+ int * p3[4];
+ } a[4];
+ char *f2;
+ struct B {
+ int *p4;
+ int nested [8]; /* Use a large number because CIL does not use long
+ * initializers if they are 0 */
+ } b[4];
+};
+
+int i1 = 1, i2 = 2, i3 = 3, i4 = 4, i5 = 5;
+int ia[8] = { 0, 1, 2, 3, 4, 5, 6, 7};
+
+struct S g = { .a[0].p1 = &i1, .a[0].i2 = 5, .a[0].p3[0] = &i2,
+ .a[1].p3[0] = ia, .f2 = "test" };
+
+
+#if 12 <= ERROR
+// Define a long SIZED array of arrays
+int matrix[64][4] = { 1, 2, 3 };
+#endif
+
+int main() {
+
+ // Test with wildness
+#if 1 <= ERROR && ERROR <= 3
+ //ERROR(1):Error 1
+ {
+ struct S * __WILD wg = &g; // Make g WILD
+
+ // Test that the address is right
+ if(HAS_KIND(&i1, WILD_KIND) && // ERROR(1)
+ g.a[0].p1 == &i1 && * g.a[0].p1 == 1) E(1);//ERROR(1)
+ if(* g.f2 == 't') E(2);//ERROR(2):Error 2
+ // Now check a bit that the tag bits are right
+ { int *p = * (int **)(& g.a[0].i2); } //ERROR(3):tampered
+ }
+#endif
+
+ // Now make sure that we can write SEQ pointers
+#if 4 <= ERROR && ERROR <= 6
+ {
+ int * __SEQ x = g.a[2].p3[1]; // Just to propagate the constraint
+ // Make sure that we can read
+ if(g.a[1].p3[0] [5] == 5) E(4); // ERROR(4):Error 4
+ // Make sure the bounds are right
+ { int x = *(g.a[1].p3[0] - 1); } //ERROR(5):Lbound
+ { int x = *(g.a[1].p3[0] + 8); } //ERROR(6):Ubound
+ }
+#endif
+
+ // Now try the sized arrays
+#if 7 <= ERROR && ERROR <= 11
+ // Make both the b and the nested array SIZED
+ {
+ int * __INDEX pnested = g.b[3].nested;
+ struct B * __INDEX pb = g.b;
+ // Now try to read
+ if(! *(pnested + 7)) E(7); //ERROR(7):Error 7
+ // Now try to read from outside
+ { int x = * (g.b[2].nested - 1); } //ERROR(8):Lbound
+ { int x = * (g.b[3].nested + 8); } //ERROR(9):Ubound
+ { int x = (g.b - 1)->p4; } //ERROR(10):Lbound
+ { int x = (g.b + 4)->p4; } //ERROR(11):Ubound
+ }
+#endif
+
+#if 12 <= ERROR && ERROR <= 14
+ {
+ int * __INDEX x = matrix[4];
+ // Now try to read
+ if(! *(x + 3)) E(12);//ERROR(12):Error 12
+ // Now try to read outside of bounds
+ { int y = * (x - 1); } //ERROR(13):Lbound
+ { int y = * (x + 4); } //ERROR(14):Ubound
+ }
+#endif
+
+ SUCCESS;
+}
+
--- /dev/null
+// a global table
+
+int nums[] = { 1,2,3 };
+
+struct Foo {
+ int a,b;
+};
+struct Foo foos[] = { {4,5}, {6,7} };
+
+int main()
+{
+ return nums[1] - 2 +
+ foos[0].b - 5;
+}
--- /dev/null
+
+
+ignore UBOUND
+stop * at handler1.c:10 : main()
+
+ignore LBOUND at *:20
+
\ No newline at end of file
--- /dev/null
+
+
+/* A special purpose main */
+#include "main.h"
+#include "hash.h"
+#include "alloc.h"
+
+/* Some globals that PCC needs */
+int error_level, anerror;
+void myexit(int n) {
+ exit(n);
+}
+#ifdef _MSVC
+#define random rand
+#else
+/* extern int random(void); -- Weimer: not needed! */
+#endif
+int __mmId;
+int debugMM;
+int debug;
+
+
+#pragma interceptCasts(on)
+
+#ifndef ITERS
+ #define ITERS 500000
+#endif // ITERS
+
+int main() {
+ /* Test hash tables */
+ PHASH h = NewHash();
+ int i;
+ double clk;
+ int count = 0;
+ int sz;
+ // int *foo, *foo1;
+
+ /* Add and delete random numbers from the hash table */
+ printf("inserting...\n");
+ TIMESTART(clk);
+ for(i=0;i<ITERS;i++) {
+ int k = random() & 0x7FFFL;
+ // printf("inserting #%d\n", i);
+// if(i == 30000) {
+// foo = (int*) ((int) &main); // Test scalar2pointer
+// }
+ AddToHash(h, k, (void*)k);
+ }
+
+ // Now try to read from foo
+ // foo1 = foo + 1;
+ // i = *foo1;
+ printf("finding...\n");
+ for(i=0;i<ITERS;i++) {
+ int k = random() & 0x7FFFL;
+ void *data = NULL;
+ if(HashLookup(h, k, & data)) {
+ count ++;
+ }
+ }
+ sz = SizeHash(h);
+
+ printf("freeing...\n");
+ FreeHash(h);
+ TIMESTOP(clk);
+ fprintf(stderr, "Hash has %d elements. Found %d times\n",
+ sz, count);
+ printf("Run hashtest in %8.3lfms\n", clk / 1000.0);
+ fprintf(stderr, "Hello\n");
+ exit (0);
+ return 0;
+}
+
+
--- /dev/null
+// hola.c
+// tiny program for scott's testing purposes
+
+#include <stdio.h> // printf
+#include <stdlib.h> // malloc
+
+#if 1
+// this is a pointer in the global area
+int *globalPtr;
+
+// here is a global integer to point at
+int globalInt = 5;
+
+
+// something so I can tell one section from another
+void separator() {}
+
+
+// explicitly declare the entry to the gc
+void GC_gcollect(void);
+
+
+// wtf?
+int LibTkn;
+int LibTkn010;
+
+
+int main()
+{
+ // here's a local int to point at
+ int localInt;
+
+ // point at them
+ globalPtr = &globalInt;
+
+ separator();
+
+ // this simply isn't allowed!
+ //globalPtr = &localInt;
+
+ separator();
+
+ globalPtr = (int*)malloc(sizeof(int));
+
+
+ // allocate lots of memory which will all be unreachable,
+ // in hopes of triggering the GC
+ {
+ int i;
+ void **p, ***q;
+ for (i=0; i<1000; i++) {
+ p = (void**)malloc(sizeof(*p));
+ *p = (void*)5;
+ // **((int**)p) = 7;
+ }
+ }
+
+ // now will the gc be called?
+ // (requires BOX=1 so we get safec{debug,}lib.a ...)
+ //GC_gcollect();
+
+ printf("hola finished successfully\n");
+ return 0;
+
+
+ #if 0
+ int x,y;
+ x = printf("hola senior.\n");
+ x += printf("what is ascii for accented o and tilde n?\n");
+ x++;
+ printf("x = %d\n", x);
+ y = printf("hmm\n");
+ return x?0:x;
+ #endif // 0
+}
+#endif // 0
--- /dev/null
+// hufftable.c
+// problem with sizes of huffmann tables in jcparam.c
+
+#include <stdio.h> // printf
+#include <string.h> // memcpy
+
+//char seventeen[17];
+char twofivesix[256];
+
+typedef unsigned char UINT8;
+
+void
+add_huff_table (/*const UINT8 *bits,*/ const UINT8 *val, int valLen)
+/* Define a Huffman table */
+{
+ //MEMCOPY((*htblptr)->bits, bits, SIZEOF((*htblptr)->bits));
+ //memcpy(seventeen, bits, sizeof(seventeen));
+
+ // sm: bugfix code
+ {
+ int bytesToCopy = sizeof(twofivesix); // original size
+ if (valLen < bytesToCopy) {
+ printf("caught buffer underrun (reading %d bytes from %d byte array)\n",
+ bytesToCopy, valLen);
+ memset(twofivesix, 0, bytesToCopy); // zero entire dest
+ bytesToCopy = valLen;
+ }
+ memcpy(twofivesix, val, bytesToCopy);
+ //MEMCOPY((*htblptr)->huffval, val, bytesToCopy);
+ }
+}
+
+
+void std_huff_tables()
+/* Set up the standard Huffman tables (cf. JPEG standard section K.3) */
+/* IMPORTANT: these are only valid for 8-bit data precision! */
+{
+ //static const UINT8 bits_dc_luminance[17] =
+ // { /* 0-base */ 0, 0, 1, 5, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0 };
+ static const UINT8 val_dc_luminance[] =
+ { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11 };
+
+ #if 0
+ static const UINT8 bits_dc_chrominance[17] =
+ { /* 0-base */ 0, 0, 3, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0 };
+ static const UINT8 val_dc_chrominance[] =
+ { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11 };
+
+ static const UINT8 bits_ac_luminance[17] =
+ { /* 0-base */ 0, 0, 2, 1, 3, 3, 2, 4, 3, 5, 5, 4, 4, 0, 0, 1, 0x7d };
+ static const UINT8 val_ac_luminance[] =
+ { 0x01, 0x02, 0x03, 0x00, 0x04, 0x11, 0x05, 0x12,
+ 0x21, 0x31, 0x41, 0x06, 0x13, 0x51, 0x61, 0x07,
+ 0x22, 0x71, 0x14, 0x32, 0x81, 0x91, 0xa1, 0x08,
+ 0x23, 0x42, 0xb1, 0xc1, 0x15, 0x52, 0xd1, 0xf0,
+ 0x24, 0x33, 0x62, 0x72, 0x82, 0x09, 0x0a, 0x16,
+ 0x17, 0x18, 0x19, 0x1a, 0x25, 0x26, 0x27, 0x28,
+ 0x29, 0x2a, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39,
+ 0x3a, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49,
+ 0x4a, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59,
+ 0x5a, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69,
+ 0x6a, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79,
+ 0x7a, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89,
+ 0x8a, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98,
+ 0x99, 0x9a, 0xa2, 0xa3, 0xa4, 0xa5, 0xa6, 0xa7,
+ 0xa8, 0xa9, 0xaa, 0xb2, 0xb3, 0xb4, 0xb5, 0xb6,
+ 0xb7, 0xb8, 0xb9, 0xba, 0xc2, 0xc3, 0xc4, 0xc5,
+ 0xc6, 0xc7, 0xc8, 0xc9, 0xca, 0xd2, 0xd3, 0xd4,
+ 0xd5, 0xd6, 0xd7, 0xd8, 0xd9, 0xda, 0xe1, 0xe2,
+ 0xe3, 0xe4, 0xe5, 0xe6, 0xe7, 0xe8, 0xe9, 0xea,
+ 0xf1, 0xf2, 0xf3, 0xf4, 0xf5, 0xf6, 0xf7, 0xf8,
+ 0xf9, 0xfa };
+
+ static const UINT8 bits_ac_chrominance[17] =
+ { /* 0-base */ 0, 0, 2, 1, 2, 4, 4, 3, 4, 7, 5, 4, 4, 0, 1, 2, 0x77 };
+ static const UINT8 val_ac_chrominance[] =
+ { 0x00, 0x01, 0x02, 0x03, 0x11, 0x04, 0x05, 0x21,
+ 0x31, 0x06, 0x12, 0x41, 0x51, 0x07, 0x61, 0x71,
+ 0x13, 0x22, 0x32, 0x81, 0x08, 0x14, 0x42, 0x91,
+ 0xa1, 0xb1, 0xc1, 0x09, 0x23, 0x33, 0x52, 0xf0,
+ 0x15, 0x62, 0x72, 0xd1, 0x0a, 0x16, 0x24, 0x34,
+ 0xe1, 0x25, 0xf1, 0x17, 0x18, 0x19, 0x1a, 0x26,
+ 0x27, 0x28, 0x29, 0x2a, 0x35, 0x36, 0x37, 0x38,
+ 0x39, 0x3a, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48,
+ 0x49, 0x4a, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58,
+ 0x59, 0x5a, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68,
+ 0x69, 0x6a, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78,
+ 0x79, 0x7a, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87,
+ 0x88, 0x89, 0x8a, 0x92, 0x93, 0x94, 0x95, 0x96,
+ 0x97, 0x98, 0x99, 0x9a, 0xa2, 0xa3, 0xa4, 0xa5,
+ 0xa6, 0xa7, 0xa8, 0xa9, 0xaa, 0xb2, 0xb3, 0xb4,
+ 0xb5, 0xb6, 0xb7, 0xb8, 0xb9, 0xba, 0xc2, 0xc3,
+ 0xc4, 0xc5, 0xc6, 0xc7, 0xc8, 0xc9, 0xca, 0xd2,
+ 0xd3, 0xd4, 0xd5, 0xd6, 0xd7, 0xd8, 0xd9, 0xda,
+ 0xe2, 0xe3, 0xe4, 0xe5, 0xe6, 0xe7, 0xe8, 0xe9,
+ 0xea, 0xf2, 0xf3, 0xf4, 0xf5, 0xf6, 0xf7, 0xf8,
+ 0xf9, 0xfa };
+ #endif // 0
+
+ add_huff_table(/*bits_dc_luminance,*/ val_dc_luminance, sizeof(val_dc_luminance));
+ //add_huff_table(bits_ac_luminance, val_ac_luminance, sizeof(val_ac_luminance));
+ //add_huff_table(bits_dc_chrominance, val_dc_chrominance, sizeof(val_dc_chrominance));
+ //add_huff_table(bits_ac_chrominance, val_ac_chrominance, sizeof(val_ac_chrominance));
+}
+
+
+int main()
+{
+ // make sure twofivesix becomes wild
+ int **x = twofivesix; // interpret first 4 bytes as pointer
+ int *y = *x; // read that pointer
+ // (don't use it though)
+
+ std_huff_tables();
+ return 0;
+}
--- /dev/null
+
+
+/* A special purpose main */
+#include "main.h"
+#include "hash.h"
+#include "alloc.h"
+#include "pccio.h"
+#include "huffman.h"
+
+/* Some globals that PCC needs */
+int error_level, anerror;
+void myexit(int n) {
+ exit(n);
+}
+#ifdef _MSVC
+#define random rand
+#else
+/* extern int random(void); -- Weimer: not needed! */
+#endif
+int __mmId;
+int debugMM;
+int debug = 0; // Make this 1 to debug the compressor
+
+
+/* Callback for writing to the compressed file */
+int compressfid;
+#define BUFFSIZE 1024
+U8 outbuff[BUFFSIZE];
+int outPoint = 0;
+int written = 0;
+static int flushOut(void) {
+ int many;
+ if(outPoint <= 0) return 0;
+ many = write(compressfid, outbuff, outPoint);
+ if(many != outPoint) {
+ ERROR0(-1, "Error writing to the compressed file");
+ }
+ written += outPoint;
+ outPoint = 0;
+ return 0;
+}
+static int writeByte(U8 b) {
+ outbuff[outPoint ++] = b;
+ if(outPoint == BUFFSIZE) {
+ flushOut();
+ }
+ return 0;
+}
+
+#define TIMES 10
+int main(int argc, char **argv) {
+ PHASH freq = NewHash();
+ int freqfid, codefid;
+ int nrSource, delta;
+ double clk;
+ int count = 0;
+
+ INDATA srcFile, compFile;
+
+ /* Must be passed the name of a file to compress */
+ if(argc < 2) {
+ printf("Must give a file to compress\n");
+ exit(1);
+ }
+ TIMESTART(clk);
+
+ initLFIOFile(&srcFile, argv[1]);
+
+ /* Read the file, 2 bytes at a time and create the frequency table */
+ nrSource = 0;
+ while(canFetch(&srcFile, 2)) {
+ U16 wrd = fetchWordLE(&srcFile);
+ nrSource += 2;
+ bumpFrequency(freq, wrd);
+ }
+ finishIOFile(&srcFile);
+ printf("Read %d bytes\n", nrSource);
+ /* Open the code and frequency files */
+ freqfid = CREAT("huffman.freq");
+ codefid = CREAT("huffman.code");
+ compressfid = CREAT("huffman.compressed");
+ if(freqfid < 0 || codefid < 0 || compressfid < 0) {
+ ERROR0(1, "Cannot create frequency and code files\n");
+ }
+ createCompressTables(freq, freqfid, codefid);
+ close(freqfid); close(codefid);
+ FreeHash(freq);
+
+ /* Now read again and compress */
+ initCompressor("huffman.code");
+ initLFIOFile(&srcFile, argv[1]);
+ outPoint = 0; written = 0;
+ startCompress(&writeByte);
+ /* Read the file, 2 bytes at a time and compress */
+ while(canFetch(&srcFile, 2)) {
+ U16 wrd = fetchWordLE(&srcFile);
+ writeCompressedSymbol(wrd);
+ }
+ endCompress();
+ flushOut();
+ close(compressfid);
+ finishIOFile(&srcFile);
+
+ /* Now decompress and compare */
+ for(count=0;count<30;count++) {
+ initLFIOFile(&compFile, "huffman.compressed");
+ initLFIOFile(&srcFile, argv[1]);
+ startDecompress();
+ delta = nrSource;
+ while(delta > 0) {
+ int comp = fetchCompressedSymbol(&compFile);
+ int src = fetchWordLE(&srcFile);
+ if(src != comp) {
+ ERROR3(-1, "Src(%04x) != Comp(%04x) (at offset %d)\n",
+ src, comp, nrSource - delta);
+ }
+ delta -= 2;
+ }
+ endDecompress(&compFile);
+ finishIOFile(&srcFile); finishIOFile(&compFile);
+ }
+ finalizeCompressor();
+
+
+ TIMESTOP(clk);
+
+ // sm: according to my man pages, the 'l' flag doesn't apply
+ // to the 'f' format, which is always a double argument
+ printf("Source %d bytes. Compressed %d bytes. Ratio: %5.2f\n",
+ nrSource, written, (double)nrSource / (double)written);
+ printf("Run hufftest in %8.3fms\n", clk / 1000.0);
+ exit (0);
+ return 0;
+}
+
+
--- /dev/null
+#include "../small1/testharness.h"
+#include "../small1/testkinds.h"
+
+// NUMERRORS 3
+
+struct foo {
+ int a[8];
+ int *b;
+} gfoo;
+
+struct bar {
+ int a[8];
+ int *b;
+};
+
+#if ERROR == 2
+struct s1 {
+ int a[8];
+ int *b;
+} * s1;
+struct s2 {
+ int *c;
+ int d[8];
+} * s2;
+#endif
+
+#if ERROR == 3
+struct s_with_index {
+ int __INDEX arr[8] __INDEX;
+} * s1;
+
+struct s_with_non_array {
+ int a,b,c,d,e,f,g,h;
+} * s2;
+#endif
+
+int main() {
+ int * __INDEX p = & gfoo.a[2]; // Force gfoo.a to have a length
+
+ // This should be Ok, but pbar->b is gfoo.a[7]
+ struct bar *pbar = (struct bar*)&gfoo;
+
+ pbar->b = 0;
+ gfoo.a[7] = 5;
+
+ printf("Pointer is %lx\n", (unsigned long)pbar->b);
+ *(pbar->b) = 0; //ERROR(1): Null
+
+ s1 = s2; if (HAS_KIND(s1, WILD_KIND)) E(2); // ERROR(2):Error
+
+#if ERROR == 3
+ s1 = s2; // ERROR(3): compared with a non-array
+#endif
+
+ SUCCESS;
+}
--- /dev/null
+// initedextern.c
+// from sac at stevechamberlain dot com
+
+// claim is that this is common enough that we should support it
+
+extern int foo = 3;
+
+int main()
+{
+ return 0;
+}
--- /dev/null
+
+
+extern int wchgat(const void *);
+
+int wchgat(const void *opts __attribute__((unused)) )
+{
+ return 1;
+}
+
+int main () {
+ return 0;
+}
--- /dev/null
+
+enum token {
+ TERM = - 1
+} ; /*onlytypedef*/
+
+
+static int parse(int * ) ;
+
+static int parse(enum token * tok )
+{
+ return 0;
+}
+
+int main () {
+ return 0;
+}
--- /dev/null
+#include <stdio.h> // printf
+
+typedef unsigned int size_t ;
+extern void * memset(void * __s , int __c , size_t __n ) ;
+
+typedef struct jpeg_compress_struct * j_compress_ptr ;
+
+struct jpeg_compress_struct {
+ struct jpeg_error_mgr * err ;
+};
+
+struct jpeg_error_mgr {
+};
+
+void foo(int x)
+{
+ printf("sizeof is %d\n", x);
+}
+
+void jpeg_create_compress(j_compress_ptr cinfo )
+{
+ struct jpeg_error_mgr * err = cinfo->err;
+
+ foo(sizeof(struct jpeg_compress_struct ));
+
+ memset((void * )cinfo, 0, (size_t )((size_t
+ )sizeof(struct jpeg_compress_struct )));
+
+ cinfo->err = err;
+}
+
+int main()
+{
+ struct jpeg_compress_struct cinfo;
+ jpeg_create_compress(&cinfo);
+ return 0;
+}
--- /dev/null
+
+DECLARE_WAIT_QUEUE_HEAD(log_wait);
+
+
+
+int main () {
+ return 0;
+}
+
+
--- /dev/null
+struct module
+{
+ unsigned long size_of_struct;
+ const char *name;
+};
+
+
+static struct module kernel_module =
+{
+ size_of_struct: sizeof(struct module),
+ name: "",
+};
+
+int main () {
+ return 0;
+}
--- /dev/null
+// testing proper lexical interpretation of integer literals
+
+#include <stdio.h> // printf
+#include <stdlib.h> // exit
+
+//Make sure that $ is allowed in identifiers:
+void print$Int(char *label, int i, int shouldBe)
+{
+ printf("%s: decimal %d, octal 0%o, hex 0x%X, shouldBe %d (decimal)\n",
+ label, i, i, i, shouldBe);
+ if (i != shouldBe) {
+ printf("this is wrong\n");
+ exit(2);
+ }
+}
+
+#define PVAL(val, should) print$Int(#val, val, should)
+
+int main()
+{
+ PVAL(0, 0);
+ PVAL(1, 1);
+ PVAL(10, 10); // decimal
+ PVAL(010, 8); // octal (leading "0")
+ PVAL(0x10, 16); // hexadecimal (leading "0x")
+ PVAL(100, 100);
+ PVAL(0100, 64);
+ PVAL(0101, 65);
+ PVAL(0x0101, 257);
+ PVAL(1 | 64 | 512, 577);
+ PVAL(01 | 0100, 65);
+ PVAL(01 | 0100 | 01000, 577);
+ // Now check for some overflow
+ PVAL(0xFFFFFFFF, -1);
+ PVAL(0x80000000 | 0x7FFFFFFFU, -1);
+ return 0;
+}
--- /dev/null
+extern void exit(int);
+
+struct Foo {
+ int a;
+ int b;
+} structure;
+
+int main()
+{
+ char **foo;
+
+ structure = ((struct Foo) {3, 4});
+ if(structure.a + structure.b != 7) exit(1);
+
+
+ foo = (char *[]) { "x", "y", "z"};
+ if(* foo[1] != 'y') exit(2);
+
+
+ if( ((int[]) { 1, 2, 3})[1] != 2) exit(3);
+
+ exit(0);
+}
+
--- /dev/null
+
+#pragma pack(1)
+
+#pragma pack()
+
+struct udf_sb_info
+{
+ struct buffer_head *s_block_bitmap[8 ];
+
+ struct inode *s_vat;
+};
+
+int main () {
+ return 0;
+}
--- /dev/null
+#include "../small1/testharness.h"
+
+// This test checks malloc on compatible pointers.
+// NUMERRORS 3
+
+#include <malloc.h>
+
+int main(void)
+{
+ int *p1 = malloc(sizeof(*p1));
+ int * __FSEQ * __COMPAT p2 = malloc(10 * sizeof(*p2));
+ int i;
+
+ // Check initialization.
+ *p1 = *p2[9]; // ERROR(1)
+
+ *p1 = 42;
+
+ for (i = 0; i < 10; i++)
+ {
+ p2[i] = p1;
+ }
+
+ // Check alloc bounds.
+ p2[10] = &x; // ERROR(2)
+
+ // Check bounds of pointer in array.
+ *(p2[5] + 1) = 4242; // ERROR(3)
+
+ // Check contents of pointers.
+ if (**p2 != 42) E(3);
+
+ // Check aliasing of pointers.
+ **p2 = 4242;
+ if (*p2[9] != 4242) E(4);
+
+ SUCCESS;
+}
--- /dev/null
+struct posix_header {
+ char name[100] ;
+ char typeflag ;
+ char prefix[155] ;
+} ; /*onlytypedef*/
+union block {
+ struct posix_header header ;
+} ; /*onlytypedef*/
+
+
+enum read_header {
+ HEADER_FAILURE,
+ HEADER_SUCCESS,
+
+} ; /*onlytypedef*/
+
+
+int read_header(void )
+{
+ union block * header ; /*decdef*/
+ static char * next; /*decdef*/
+ struct posix_header * h; /*decdef*/
+ char namebuf[sizeof(h->prefix) + 1] ; /*decdef*/
+ return sizeof(namebuf);
+}
+
+#include "../small1/testharness.h"
+
+int main () {
+ if(read_header() != 156) E(1);
+ SUCCESS;
+
+}
--- /dev/null
+// boxing sizeof?
+
+#include <stdio.h> // printf
+#include <string.h> // memset
+
+struct S {
+ int *x;
+};
+
+int main()
+{
+ //printf("sizeof is %d\n", sizeof(struct S));
+ memset(NULL, 0, sizeof(struct S));
+ //return sizeof(struct S);
+ return 0;
+}
--- /dev/null
+
+//There's a problem with the merger when a parameter overlaps with a static local.
+
+
+int fun1(int n)
+{
+ return n;
+}
+
+int qux()
+{
+ static int n = 3;
+ return n;
+}
+
+int fun2()
+{
+ int n; //This local doesn't seem to cause any problems.
+ return n;
+}
+
+
+
+int main() {
+ return 0;
+}
--- /dev/null
+// merge-twice: testcase of merging merged results
+
+int foo()
+{
+ return 3;
+}
--- /dev/null
+
+
+int bar()
+{
+ return 4;
+}
--- /dev/null
+
+
+int baz()
+{
+ return 7;
+}
--- /dev/null
+// mergeinline1.c
+// hypothesis about fill_n_... problem
+
+// prototype
+static long *fill();
+
+// call
+int foo()
+{
+ long *w = fill();
+ return (int)(*w);
+}
+
+// inline definition
+// (remove "__inline" to work around the bug)
+__inline static long *fill()
+{
+ return 0;
+}
+
+int main()
+{
+ return 0;
+}
--- /dev/null
+// mergeinline2.c
+// counterpart to mergeinline1.c
+
+// prototype
+static long *fill();
+
+// call
+int bar()
+{
+ long *w = fill();
+ return (int)(*w);
+}
+
+// inline definition
+// (remove "__inline" to work around the bug)
+__inline static long *fill()
+{
+ return 0;
+}
+
--- /dev/null
+// mergestruct1.c
+// test merging of structures whose field names differ
+
+struct A {
+ int x;
+};
+
+// make A's type part of the interface
+extern struct A *connection;
+
+// decl of foo()
+int foo();
+
+// refer to A::x
+int foo()
+{
+ if (connection) {
+ return connection->x;
+ }
+ else {
+ return 3;
+ }
+}
+
+// unrelated: test merging of 'unsigned char' and 'signed char'
+unsigned char sharedChar;
--- /dev/null
+// mergestruct2.c
+// other half of mergestruct1.c
+
+struct B {
+ int y;
+};
+
+// connect A and B
+struct B *connection;
+
+// refer to B::y
+int main()
+{
+ int whatever;
+
+ if (connection) {
+ whatever = connection->y;
+ }
+ whatever += foo(); // for the heck of it
+
+ return whatever-whatever;
+}
+
+// unrelated: test merging of 'unsigned char' and 'signed char'
+// (I edit this to introduce inconsistency..)
+unsigned char sharedChar;
--- /dev/null
+#include "../small1/testharness.h"
+#include "../small1/testkinds.h"
+
+#ifndef ERROR
+#define __WILD
+#endif
+
+// NUMERRORS 1
+typedef struct foo Foo;
+struct bar
+{
+ Foo * __WILD next;
+};
+struct foo
+{
+ int *base;
+ unsigned int length;
+ struct bar link;
+};
+int main()
+{
+ struct foo s, *sptr = &s;
+ if(HAS_KIND(sptr->base, WILD_KIND)) E(1); //ERROR(1):Error 1
+}
--- /dev/null
+// mode_sizes.c
+// demonstrate a problem with 'ping'
+
+// /usr/include/sys/types.h, around line 177, after macro expansion
+typedef int int8_t __attribute__ ((__mode__ ( __QI__ ))) ;
+typedef int int16_t __attribute__ ((__mode__ ( __HI__ ))) ;
+typedef int int32_t __attribute__ ((__mode__ ( __SI__ ))) ;
+typedef int int64_t __attribute__ ((__mode__ ( __DI__ ))) ;
+
+typedef unsigned int u_int8_t __attribute__ ((__mode__ ( __QI__ ))) ;
+typedef unsigned int u_int16_t __attribute__ ((__mode__ ( __HI__ ))) ;
+typedef unsigned int u_int32_t __attribute__ ((__mode__ ( __SI__ ))) ;
+typedef unsigned int u_int64_t __attribute__ ((__mode__ ( __DI__ ))) ;
+
+typedef int someInt; // something I don't want to mess with
+
+typedef short x8_t __attribute__ ((__mode__ ( byte ))) ;
+
+// avoid pulling in conflicting definitions
+someInt printf(char const *fmt, ...);
+
+int main()
+{
+ int ok = 1;
+
+ #define PRSIZE(type, should) \
+ printf("size of " #type " is: %d (should be %d)\n", \
+ sizeof(type), should); ok = ok && (sizeof(type) == should)
+ PRSIZE(int8_t, 1);
+ PRSIZE(int16_t, 2);
+ PRSIZE(int32_t, 4);
+ PRSIZE(int64_t, 8);
+
+ PRSIZE(u_int8_t, 1);
+ PRSIZE(u_int16_t, 2);
+ PRSIZE(u_int32_t, 4);
+ PRSIZE(u_int64_t, 8);
+
+ PRSIZE(x8_t, 1);
+ #undef PRSIZE
+
+ return ok? 0 : 1;
+}
--- /dev/null
+// two static variables with the same name
+
+int foo()
+{
+ static int x = 0;
+ return x;
+}
+
+int bar()
+{
+ static int x = 5;
+ return x;
+}
+
+int main()
+{
+ return !( foo() + bar() == 5 );
+ return 0;
+}
+
--- /dev/null
+// neg64.c
+// testcase for -2^63 problem
+// from sac at stevechamberlain dot com
+
+float
+sll2f(s)
+ long long int s;
+{
+ return s;
+}
+
+main()
+{
+ if (sll2f((long long int)(~((~0ULL) >> 1))) != (float)(long long int)~((~0ULL) >> 1)) /* 0x80000000 */
+ abort();
+
+ exit(0);
+}
--- /dev/null
+// example of a situation where nested areas are registered
+
+#include <stdio.h> // printf
+
+struct Foo {
+ int a;
+ int b[8];
+} foo [16];
+
+int main()
+{
+ struct Foo *f = foo;
+ int i;
+ int acc = 0;
+
+ printf("start of nested\n");
+
+ for (i=0; i<16; i++) {
+ int *b = f[i].b;
+ b += 2;
+ b[0] = 3;
+ b[1] = 4;
+ acc += b[1] - b[0];
+ }
+
+ printf("end of nested\n");
+
+ return acc - 16;
+}
+
--- /dev/null
+extern void error(int status , int errnum , const char * format , ...)
+ __attribute__((__format__(__printf__, 3, 4))) ;
+
+
+static void parse_group(const char * name) {
+ if(0) error(1, 0, gettext("invalid group name %s"), quote(name));
+}
+
+
+int main(int argc , char * * argv ) {
+ return 0;
+}
+
--- /dev/null
+// oldstyle decls are problematic in themselves?
+
+static int foo(int x); // right now, 'static' is the problem
+
+int foo(x)
+ int x;
+{
+ return x;
+}
+
+int main()
+{
+ return foo(0);
+}
--- /dev/null
+// testing problem with args to open...
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <unistd.h> // read, close
+#include <stdio.h> // perror
+
+
+int main()
+{
+// int fd = open("/dev/zero", O_RDONLY, 0); // must pass 3rd arg (matth: why?)
+
+ int fd = open("./open_test", O_CREAT | O_WRONLY, S_IRUSR);
+ char buf = 'a';
+ if (fd < 0){
+ perror("open(./open_test, O_CREAT | O_WRONLY, S_IRUSR) < 0");
+ return 1;
+ }
+
+ if (write(fd, &buf, 1) != 1) {
+ perror("write(fd, &buf, 1) != 1");
+ return 2;
+ }
+ close(fd);
+ buf = 0;
+
+ fd = open("./open_test", O_RDONLY);
+ if (fd < 0){
+ perror("open(./open_test, O_RDONLY) < 0");
+ return 3;
+ }
+
+ if (read(fd, &buf, 1) != 1) {
+ perror("read(fd, &buf, 1) != 1");
+ return 4;
+ }
+ close(fd);
+ if (buf != 'a'){
+ perror("read wrong value");
+ return 5;
+ }
+
+ if (unlink("./open_test") != 0)
+ {
+ perror("unlink(./open_test) != 0");
+ return 6;
+ }
+
+ printf("Open Succeeded!\n");
+ return 0;
+}
--- /dev/null
+#include "../small1/testharness.h"
+#include "../small1/testkinds.h"
+
+// NUMERRORS 5
+
+int * __SAFE global_variable_1;
+
+typedef struct {
+ int * __SAFE field_1;
+ int *field_2;
+ int *field_3;
+} my_struct;
+
+my_struct *global_variable_2;
+
+int main() {
+ int * __SAFE local_variable_1;
+
+#if ERROR == 1
+ local_variable_1 = 55;
+ if(!(HAS_KIND(local_variable_1, SAFE_KIND))) E(1); //ERROR(1):Error 1
+#endif
+#if ERROR == 2
+ global_variable_1 = 55;
+ if(!(HAS_KIND(global_variable_1, SAFE_KIND))) E(2); //ERROR(2):Error 2
+#endif
+#if ERROR == 3
+ global_variable_2 = global_variable_1;
+ if((HAS_KIND(global_variable_1, WILD_KIND))) E(3); //ERROR(3):Error 3
+#endif
+#if ERROR == 4
+ global_variable_2 = global_variable_1;
+ if((HAS_KIND(global_variable_2, WILD_KIND))) E(4); //ERROR(4):Error 4
+#endif
+#if ERROR == 5
+ global_variable_2 = &global_variable_1;
+ if((HAS_KIND(global_variable_2->field_1, WILD_KIND))) E(5); //ERROR(5):Error 5
+#endif
+ SUCCESS;
+}
--- /dev/null
+// partially-bracketed initializers cause problems
+
+struct S {
+ int x, y;
+};
+
+struct S array[] = {
+ 1,2,
+ 3,4
+};
+
+struct S array_ok[] = {
+ {1,2},
+ {3,4}
+};
+
+int main()
+{
+ return array[0].x - 1; // should be 0
+}
--- /dev/null
+
+
+int main()
+{
+ int someVariable, restrict;
+
+ return 0;
+}
--- /dev/null
+// test storing ints in pointers
+
+
+int main()
+{
+ // local variable
+ int local = 7;
+
+ // pointer to this variable
+ int *ptr = &local;
+ *ptr = 9; // modify via pointer
+
+ // now store an int in the ptr
+ ptr = (int*)23;
+ local = (int)ptr; // read the int out of the ptr
+
+ // point the ptr back at the local
+ ptr = &local;
+
+ // and verify everything is 23
+ return *ptr + local*10 - (23 + 23*10);
+}
--- /dev/null
+// test simple character functions, which give us
+// troubles because they are macros
+
+#include <stdio.h> // putc
+#include <unistd.h> // unlink
+
+int main()
+{
+ FILE *tmp;
+ int ch;
+
+ putc('c', stdout);
+ putc('\n', stdout);
+
+ tmp = fopen("putc.tmp", "w");
+ fputc('a', tmp);
+ fclose(tmp);
+
+ tmp = fopen("putc.tmp", "r");
+ ch = fgetc(tmp);
+ fclose(tmp);
+ if (ch != 'a') {
+ return 4;
+ }
+
+ unlink("putc.tmp");
+
+ puts("putc seems to work"); // puts outputs a trailing newline
+
+ return 0;
+}
--- /dev/null
+
+
+/* A special purpose main */
+#include "main.h"
+#include "redblack.h"
+#include "alloc.h"
+
+/* Some globals that PCC needs */
+int error_level, anerror;
+void myexit(int n) {
+ exit(n);
+}
+#ifdef _MSVC
+#define random rand
+#else
+/* weimer: not needed: extern int random(void); */
+#endif
+int __mmId;
+int debugMM;
+int debug;
+
+// allow explicit call into gc
+//int explicit_gc();
+
+
+#define DATASIZE 16 // This is the size of the data that is reserved in
+ // each node
+
+#ifndef ITERS
+ #define ITERS 500000
+#endif // ITERS
+
+// had to make these global since spreading the functionality
+// across several functions
+int count = 0;
+int sz;
+
+void innerDoTreeStuff(int letGcFree)
+{
+ RBNode *t = NULL;
+ int i;
+
+ /* Add and delete random numbers from the hash table */
+ printf("inserting...\n");
+ for(i=0;i<ITERS;i++) {
+ int k = random() & 0x7FFFL;
+ insertRB(& t, k, DATASIZE);
+ }
+ printf("finding...\n");
+ for(i=0;i<ITERS;i++) {
+ int k = random() & 0x7FFFL;
+ if(findRB(t, k)) {
+ count ++;
+ }
+ }
+ sz = 0;
+ printf("sz++...\n");
+ FORALLRBNODES(t, { sz ++; });
+
+ if (!letGcFree) {
+ // explicit freeing
+ printf("freeing...\n");
+ freeRB(t, NULL);
+ }
+ else {
+ // will free a little further down, once the
+ // stack is cleaner
+ }
+}
+
+// this intermediate function serves to separate the computation,
+// and its dirtying of the stack, from the gc which may follow
+void doTreeStuff(int letGcFree)
+{
+ // cleanse the stack
+ char buf[256];
+ int i;
+
+ for (i=0; i<256; i++) {
+ buf[i] = 0;
+ }
+
+ innerDoTreeStuff(letGcFree);
+
+ for (i=0; i<256; i++) {
+ buf[i] = 0;
+ }
+}
+
+
+
+int main(int argc /* char*argv[] */) /* Drop this to avoid changing name*/
+{
+ /* Test hash tables */
+ double clk;
+ int letGcFree = (argc != 1); // gc if any args
+ RBNode *another = NULL;
+
+ TIMESTART(clk);
+
+ doTreeStuff(letGcFree);
+
+ // another singleton tree to make the page not homogeneous
+ insertRB(&another, 1, DATASIZE);
+
+ if (letGcFree) {
+ // use the gc
+ printf("garbage collecting...\n");
+
+ // sm: I can't figure out why this won't work when
+ // boxing is off.. it complains about explicit_gc_ (an
+ // extra trailing underscore)..
+ printf("# bytes freed: %d\n", 0); //explicit_gc());
+ }
+
+ TIMESTOP(clk);
+
+ fprintf(stderr, "Hash has %d elements. Found %d times\n",
+ sz, count);
+ printf("Run rbtest in %8.3fms\n", clk / 1000.0);
+ // sm: removed 'l' in format string because gcc complains
+ exit (0);
+ return 0;
+}
+
+
--- /dev/null
+// registers before assigning
+
+#include <stdio.h> // printf
+
+void innerDoTreeStuff(int letGcFree)
+{
+ int i;
+
+ /* Add and delete random numbers from the hash table */
+ printf("inserting...\n");
+}
+
+int main()
+{
+ innerDoTreeStuff(0);
+ return 0;
+}
--- /dev/null
+// regparm0.c
+// test of the regparm(0) problem in linux/arch/i386/kernel/signal.c
+
+// first, problematic prototype; basically, the regparm(0) is
+// parsed as associated with the return type (int), and hence a
+// no-op; the regparm(3) should be what's attached to do_signal
+__attribute__((regparm(0))) int do_signal(int *regs, int *oldset)
+ __attribute__((regparm(2))) __attribute__((regparm(3)));
+
+// call this function
+int main()
+{
+ int r=6, o=5;
+ return do_signal(&o, &r) - 11;
+}
+
+// now an implementation which will die if its args are mis-passed
+int do_signal(int *regs, int *oldset)
+{
+ return *regs + *oldset;
+}
+
+
+
+
--- /dev/null
+// register an area, then clobber by calling fn
+
+#include <stdio.h> // printf
+#include <stdlib.h> // malloc
+
+void clobber()
+{
+ printf("clobbering\n");
+
+ // at the end we unregisterbelow, which will kill global/heap
+ // areas since at the moment I fail to distinguish
+}
+
+
+int main()
+{
+ // make and register an area
+ int *p = (int*)malloc(sizeof(*p));
+
+ printf("printf result: %p\n", p);
+
+ // clobber registration
+ clobber();
+
+ // try to use *p
+ *p = 9;
+
+ printf("worked ok!\n");
+
+ return 0;
+}
+
--- /dev/null
+
+
+int main (int argc, char **argv)
+{
+ return 0;
+}
+//Our parser was allowing trailing right braces
+} //KEEP rbrace: error = syntax error
+
--- /dev/null
+struct rusage ;
+
+struct foobar_not_used;
+
+int w3(struct rusage *__usage ) { return 0; }
+
+int main()
+{
+ struct rusage *r;
+ w3(r);
+ return 0;
+}
+
--- /dev/null
+typedef unsigned char hashtyp;
+typedef unsigned short strindx;
+
+
+typedef struct S59 * idptr;
+typedef struct S59 {
+ idptr inext;
+ unsigned char inref;
+ hashtyp ihash;
+ strindx istr;
+} idnode;
+
+void printtok(strindx istr){}
+
+ void
+printid(ip)
+ idptr ip;
+{
+ printtok(ip->istr);
+}
+
+int main()
+{
+ return 0;
+}
--- /dev/null
+// scary.c
+// seeing what gcc is afraid of
+
+#include <stdio.h> // printf
+#include <stdlib.h> // atoi
+#include <sys/time.h> // struct timeval, gettimeofday
+
+// return the # of milliseconds since some unspecified, but
+// constant for the life of the program, event
+long getMilliseconds()
+{
+# ifdef __WIN32__
+ // # of milliseconds since program started
+ return GetTickCount();
+
+# else
+ // some unspecified millisecond count (unspecified
+ // because tv.tv_sec * 1000 will overflow a 32-bit
+ // long, for typical values)
+ struct timeval tv;
+ gettimeofday(&tv, NULL);
+ // according to HPUX man page, this always returns 0 and does
+ // not have any errors defined
+
+ //printf("tv.tv_sec = %d, tv.tv_usec = %d\n",
+ // tv.tv_sec, tv.tv_usec);
+ return tv.tv_sec * 1000 + tv.tv_usec / 1000;
+# endif
+}
+
+int loop1(int m)
+{
+ int i=0;
+ while (i<m) {
+ i++;
+ }
+ return i;
+}
+
+int loop2(int m)
+{
+ int i=0;
+ while (i<m) {
+ (*&i)++;
+ }
+ return i;
+}
+
+int loop3(int m)
+{
+ int i=0;
+ while (*&i < m) {
+ i++;
+ }
+ return i;
+}
+
+int loop4(int m)
+{
+ int i=0;
+ while (*&i < m) {
+ (*&i)++;
+ }
+ return i;
+}
+
+
+int main(int argc, char *argv[])
+{
+ int m;
+ long start;
+
+ if (argc < 2) {
+ printf("usage: %s <iters>\n", argv[0]);
+ return 0;
+ }
+
+ m = atoi(argv[1]);
+
+ #define LOOP(n) \
+ start = getMilliseconds(); \
+ printf("loop%d: ", n); \
+ loop##n(m); \
+ printf("%ld ms\n", getMilliseconds() - start) /* user ; */
+
+ LOOP(1);
+ LOOP(2);
+ LOOP(3);
+ LOOP(4);
+
+ printf("done\n");
+
+ return 0;
+}
+
+
--- /dev/null
+#include <stdlib.h> // malloc
+
+#define N 100000
+
+struct S1 { struct T1* b; };
+struct S2 { struct T2* b; };
+
+struct T1 { int x; };
+struct T2 { int x, y[N]; };
+
+int main() {
+
+ struct S1 *s1p;
+ struct S2 *s2p;
+
+ s2p = (struct S2*)malloc(sizeof(struct S2));
+
+ s1p = (struct S1*) s2p;
+
+ s1p->b = (struct T1*)malloc(sizeof(struct T1));
+ //s2p->b = (struct T2*)(s1p->b);
+
+ s2p->b->x = 1;
+
+ /* if N is large enough, this should segfault */
+ s2p->b->y[N-1] = 3;
+
+ return 0;
+
+}
--- /dev/null
+// attempt to reproduce this error:
+// Failure at ./Config_Test.mergedcured.c:open__112ACE_Malloc_T__tm__92_21ACE_Local_Memory_Pool29ACE_Local_Memory_Pool_Options16ACE_Thread_Mutex17ACE_Control_BlockFv_i:161967: Creating an unaligned sequence
+
+#include <stdlib.h>
+
+/* This code is from a custom allocator that allocates a header before the
+ * actual memory block */
+int main() {
+ struct header {
+ int one;
+ int *two;
+ int three;
+ } *h;
+ char *p;
+ // We allocate 3 chars but with a header
+ char* v = (char*)malloc(sizeof(struct header) + 4);
+
+#ifndef CCURED
+ h = (struct header*)v; // Will check here that there is enough space in p
+ h->one = 5; // Write something to the header
+ p = (char*)(h + 1); // Skip the header, but this makes h SEQ
+#else
+ // In the CCURED version we have to play some tricks
+ // Make sure h is not SEQ, so, don't do h + 1
+
+ // We want h to be SAFE. If header did not contain pointers we could do:
+ // h = (struct header*)v;
+ // But since header contains pointers, it is not SAFE to cast from a
+ // char-ptr to a header-ptr. trusted_cast wants its both ends to have
+ // the same kind, which would make h SEQ. We use __ptrof instead.
+ // But be careful how you use h in the future, because if you make it
+ // SEQ, you will need __ptrof_qq, which does not exist!
+ h = (struct header*)__ptrof(v);
+ h->one = 5;
+ // Use v to compute p, not h. This way h can stay SAFE.
+ p = v + sizeof(struct header);
+#endif
+
+ // And we need the result to be SEQ
+ p ++;
+ p --;
+
+
+ return 0;
+}
--- /dev/null
+// attempt to reproduce this error:
+// Failure at ./Config_Test.mergedcured.c:open__112ACE_Malloc_T__tm__92_21ACE_Local_Memory_Pool29ACE_Local_Memory_Pool_Options16ACE_Thread_Mutex17ACE_Control_BlockFv_i:161967: Creating an unaligned sequence
+
+#include <stdio.h>
+#include <stdlib.h>
+
+struct a_struct {
+ int one;
+ int *two;
+ int three;
+};
+
+#ifdef CCURED
+ #define IFCCURED(cc,noncc) cc
+#else
+ #define IFCCURED(cc,noncc) noncc
+#endif
+
+#define CCURED_TRUSTED_CAST(t, what) \
+ IFCCURED(((t)__trusted_cast((void*)(what))), ((t)(what)))
+
+// imitate an allocator
+void *make_a_struct(int num, size_t size) {
+ // We allocate num things plus some extra. Ccured hates this.
+ return (struct a_struct *) malloc (num*size + 1);
+}
+
+int main() {
+ const int array_size = 3;
+ struct a_struct *p;
+
+ char *temp = make_a_struct(array_size, sizeof *p);
+
+#ifdef CCURED
+ // Whack down the home area.
+ temp = __align_seq(temp, sizeof *p);
+#endif
+ p = CCURED_TRUSTED_CAST(struct a_struct*, temp);
+ // access it
+ {
+ int i;
+ for(i=0; i<array_size; ++i) p[i].three = 17;
+ for(i=0; i<array_size; ++i) {
+ printf("p[%d].three = %d\n", i, p[i].three);
+ }
+ }
+
+ // Force p to be SEQ
+ p ++;
+ p --;
+
+
+ return 0;
+}
--- /dev/null
+#include "../small1/testharness.h"
+
+// NUMERRORS 9
+
+char carray[127];
+long larray[128];
+
+
+int main() {
+ char * __FSEQ fc = carray;
+ char * __SEQ sc = carray;
+
+ long * __FSEQ fl = larray;
+ long * __SEQ sl = larray;
+
+ // This should succeed because carray is 127 bytes long.
+ fl = (long*) (fc + 3);
+
+ fl = (long*) (fc + 1); //ERROR(1):unaligned
+ sl = (long*) (sc + 4); //ERROR(2):unaligned
+ // Now from SAFE -> FSEQ
+#if ERROR == 3
+ {
+ long along;
+ long * pl = &along;
+ fc = (char*)pl;
+ pl = (long*)(fc + 1); //ERROR(3):unaligned
+ }
+#endif
+
+ // Now from SEQ -> FSEQ
+ fl = (long*)(sc + 3); /* should succeed */ E(4);//ERROR(4):Error 4
+ fl = (long*)sc; //ERROR(5):unaligned
+
+ // Now through polymorphism
+ {
+ void * v1 = sc;
+ void * v2 = sc + 3;
+ if(HAS_KIND(v1, WILD_KIND)) E(16);
+ // A good one
+ fl = (long*)v2; /* Should be Ok */ E(6);//ERROR(6):Error 6
+ fl = (long*)v1;//ERROR(7):unaligned
+ }
+
+ // Now test the __align_seq
+ fl = (long*)__align_seq(sc, sizeof(*fl)); E(9);//ERROR(9):Error 9
+
+ SUCCESS;
+}
+
+#if ERROR == 8
+// Try a global trick
+long * __FSEQ glob = &carray[1]; //ERROR(8):unaligned
+#endif
--- /dev/null
+//Bug caused by overflow in bitsSizeOf (SourceForge #1641570)
+
+//Partial workaround: define "bytesSizeOf", not bitsSizeOf, to give us 8x more
+//breathing room.
+//Better workaround: make bitsSizeOf return an int64
+//Current solution: a warning
+
+char tab[300000000]; // three hundred million times 8 bits = -947483648 mod 2**31
+
+//TODO: give somthing better than a warning here ...
+extern char foo[sizeof(tab)]; //KEEP folding: error = Int constant too large
+
+char foo[300000000];
+
+int main () {
+ int i;
+
+ tab[999999999] = foo[5];
+ i = sizeof (tab);
+
+ return 0;
+}
--- /dev/null
+// sizeofchar.c
+// from sac at stevechamberlain dot com
+
+// problems with sizeof and chars
+
+#include <assert.h> // assert
+
+int main()
+{
+ int sz1, sz2;
+ int i;
+
+ sz1 = sizeof('a'); // 'a' is actually an int constant, so this is 4
+ assert(sz1 == sizeof(int));
+
+ sz2 = sizeof((char)'a'); // now it's 1!
+ assert(sz2 == sizeof(char));
+
+ //character constants are ints, so this should be sign-extended to 0xFFFFFFFF
+ i = '\xff';
+ assert((int)i == (int)-1);
+
+ {
+ //Test CIL's understanding of '\xff' by forcing it to do constant folding:
+ char array[(unsigned int)'\xff' - (unsigned int)0xfffff000];
+ assert (sizeof(array) == 0xfff);
+ }
+
+
+ return 0;
+}
+
--- /dev/null
+typedef unsigned short int sa_family_t;
+
+typedef signed short int __int16_t;
+
+typedef unsigned char uint8_t;
+typedef unsigned short int uint16_t;
+typedef unsigned int uint32_t;
+
+typedef unsigned int socklen_t;
+
+struct sockaddr
+ {
+ sa_family_t sa_family ;
+ char sa_data[14];
+ };
+
+
+struct in_addr
+ {
+ uint32_t s_addr;
+ };
+
+struct sockaddr_in
+ {
+ sa_family_t sin_family ;
+ uint16_t sin_port;
+ struct in_addr sin_addr;
+
+
+ unsigned char sin_zero[sizeof (struct sockaddr) -
+ (sizeof (unsigned short int)) -
+ sizeof (uint16_t) -
+ sizeof (struct in_addr)];
+ };
+
+struct in6_addr
+ {
+ union
+ {
+ uint8_t u6_addr8[16];
+ uint16_t u6_addr16[8];
+ uint32_t u6_addr32[4];
+ } in6_u;
+ };
+
+struct sockaddr_in6
+ {
+ sa_family_t sin6_family ;
+ uint16_t sin6_port;
+ uint32_t sin6_flowinfo;
+ struct in6_addr sin6_addr;
+ };
+
+
+union sockunion {
+ struct sockinet {
+ sa_family_t si_family ;
+ uint16_t si_port;
+ } su_si;
+ struct sockaddr_in su_sin;
+ struct sockaddr_in6 su_sin6;
+};
+
+union sockunion server_addr;
+
+typedef union {
+ __const struct sockaddr *__sockaddr__;
+ //__const struct sockaddr_at *__sockaddr_at__;
+ //__const struct sockaddr_ax25 *__sockaddr_ax25__;
+ //__const struct sockaddr_dl *__sockaddr_dl__;
+ //__const struct sockaddr_eon *__sockaddr_eon__;
+ __const struct sockaddr_in *__sockaddr_in__;
+ __const struct sockaddr_in6 *__sockaddr_in6__;
+ //__const struct sockaddr_inarp *__sockaddr_inarp__;
+ //__const struct sockaddr_ipx *__sockaddr_ipx__;
+ //__const struct sockaddr_iso *__sockaddr_iso__;
+ //__const struct sockaddr_ns *__sockaddr_ns__;
+ //__const struct sockaddr_un *__sockaddr_un__;
+ //__const struct sockaddr_x25 *__sockaddr_x25__;
+} __CONST_SOCKADDR_ARG __attribute__ ((__transparent_union__));
+
+extern int bind (int __fd, __CONST_SOCKADDR_ARG __addr, socklen_t __len) ;
+
+//extern int __libc_sa_len (sa_family_t __af) ;
+
+int main()
+{
+ int ctl_sock=0;
+ struct sockaddr *addrptr;
+
+ addrptr = (struct sockaddr *)&server_addr;
+ bind(ctl_sock, addrptr, 3);
+ //__libc_sa_len(( (struct sockaddr *)&server_addr )->sa_family) );
+
+ return ctl_sock;
+}
+
--- /dev/null
+#include "../small1/testharness.h"
+
+#define NUMERRORS 2
+
+char * global;
+
+int notmain() {
+ char loc;
+ // We check that the __checkStackBottom is not too lenient
+ global = &loc; //ERROR(2):STORE_SP
+}
+
+int main(int argv, char **argv, char **envp) {
+ char mainloc;
+ // We should be able to store mainloc
+ global = & mainloc; E(1); // ERROR(1):Error 1
+
+ // We should be able to store argv
+ global = *argv; E(2); // ERROR(2):Error 2
+
+ // And envp
+ global = *envp; E(3); // ERROR(3):Error 3
+
+ SUCCESS;
+}
--- /dev/null
+// stackptrptr.c
+// NUMERRORS(1)
+// demonstrate problem with stack ptr to stack ptr
+
+#define MESS_UP // ERROR(1)
+
+#ifndef MESS_UP
+ int main()
+ {
+ int x = 0;
+ int *px = &x;
+ int **ppx = &px; // allowed
+
+ return **ppx;
+ }
+
+#else
+ int main()
+ {
+ int x = 0;
+ int *px = &x;
+ int *ppx[1];
+
+ ppx[0] = &px; // not allowed
+ return *(ppx[0]);
+ }
+#endif // 0/1
--- /dev/null
+// struct_cs.c
+// reproduce a problem from gimp and an internally-declared struct
+// from plug-ins/gfig/gfig.c
+
+typedef double gdouble;
+typedef int gint;
+
+static void
+reverse_pairs_list (gdouble *list,
+ gint size)
+{
+ gint i;
+
+ struct cs
+ {
+ gdouble i1;
+ gdouble i2;
+ } copyit, *orglist;
+
+ orglist = (struct cs *) list;
+
+
+ for (i = 0; i < size / 2; i++)
+ {
+ copyit = orglist[i];
+ orglist[i] = orglist[size - 1 - i];
+ orglist[size - 1 - i] = copyit;
+ }
+}
+
+int main() {
+ return 0;
+}
--- /dev/null
+// structattr.c
+// testing some placement of 'attribute' w.r.t. 'struct' etc.
+
+struct A {
+ int x;
+} __attribute__((packed));
+struct A a;
+
+struct B {
+ int x;
+} __attribute__((packed)) b;
+
+#if 1
+// this is allowed by gcc, but I don't want to implement it because
+// it means somehow merging all the attributes across all the
+// forward decls and the defn ...
+//struct __attribute__((packed)) C;
+
+struct __attribute__((packed)) C {
+ int x;
+};
+struct C c;
+
+struct __attribute__((packed)) D {
+ int x;
+} d;
+#endif // 0/1
+
+// not allowed
+// struct E __attribute__((packed)) {
+// int x;
+// };
+
+// 8/31/03: also need it to work with anonymous structs
+struct __attribute__((__packed__)) {
+ int i;
+ char c;
+} e;
+
+
+typedef unsigned long ULONG;
+typedef int WCHAR;
+typedef struct __attribute__((packed, aligned(4))) _INFORMATION {
+ ULONG FileAttributes;
+ ULONG FileNameLength;
+ WCHAR FileName[1];
+} INFORMATION, *PINFORMATION;
+
+INFORMATION i;
+PINFORMATION pi;
+
+int main()
+{
+ return 0;
+}
--- /dev/null
+// structattr2.c
+// another structure/attribute example
+// from sac at stevechamberlain dot com
+
+#include "../small1/testharness.h"
+
+// should associate 'const' with 'b' and 'e', but not 'c'
+const struct c { int a; } b, e;
+
+// so that now, 'd' is *not* const
+struct c d;
+
+
+// Same here
+struct c2 { int a; } const b2, e2;
+
+struct c2 d2;
+
+
+// this const has no effect
+struct c3 { int a; } const;
+struct c3 b3, e3;
+
+// nor does this one
+const struct c4 { int a; };
+struct c4 b4, e4;
+
+struct __attribute__((packed)) c5 { char c; int a; } b5, e5;
+struct c5 d5;
+
+struct c6 { char c; int a; } __attribute__((packed)) b6, e6;
+struct c6 d6;
+
+struct c7 { char c; int a; } __attribute__((packed));
+struct c7 b7;
+
+struct c8 { char c; int a; };
+struct c8 b8;
+
+TESTDEF baseline: success
+
+TESTDEF archspecific: success
+
+int main() {
+ e.a++; //KEEP const1: error
+ d.a++;
+ e2.a++; //KEEP const2: error
+ d2.a++;
+ e3.a++;
+ e4.a++;
+IFTEST archspecific
+ //These tests work on a 32-bit machine:
+ if (sizeof(e5) != 5) E(5);
+ if (sizeof(d5) != 5) E(15);
+ if (sizeof(e6) != 5) E(6);
+ if (sizeof(d6) != 5) E(16);
+ if (sizeof(b7) != 5) E(7);
+ if (sizeof(b8) != 8) E(8);
+ENDIF
+ return 0;
+ }
+
--- /dev/null
+// structattr3.c
+// yet more experiments
+
+
+struct S { char a; } __attribute__((aligned(8))) const x = {1};
+
+struct S y[10] = {1,2,3};
+int z = 5;
+
+int main() { return 0; }
--- /dev/null
+#include "../small1/testharness.h"
+
+//the file should compile without changes.
+TESTDEF baseline: success
+
+// Testing some ugly switch cases
+int foo(int x, int y) {
+ switch(x) {
+ y = "who runs this?"[3];
+ exit(1);
+ default:
+ default: //KEEP dupDefault1: error = duplicate default
+ y ++;
+ goto L1;
+ case 1:
+ L2:
+ case 20:
+ y ++;
+ break;
+ y ++;
+ L1:
+ if(y > 5) {
+ case 7:
+ x ++;
+ } else {
+ while(x < 33) {
+ default: //KEEP dupDefault2: error = duplicate default
+ case 9:
+ x ++;
+ break;
+ }
+ break;
+ }
+
+ goto L2;
+ }
+ if(x < 30)
+ goto L1;
+ return x + y;
+}
+
+//braces aren't required.
+// (the two cases and the return are in the same statement.)
+int bar(int i) {
+ switch (i)
+ case 0:
+ case 1:
+ return i;
+ return 0;
+}
+
+int main() {
+ int one = bar(1) + bar(2);
+ int res =
+ one +
+ foo(1, 2) +
+ 17 * foo(9, 5) +
+ 126 * foo(7, 2) +
+ 3037 * foo(15, 9);
+ printf("Result is: %d\n", res);
+ if(res != 171822)
+ exit(1);
+ return 0;
+}
--- /dev/null
+# tagfile.txt
+# lists all the functions to tag
+# (hash isn't really a comment, but any line with a leading hash
+# is sure not to match any function name)
+
+# blank lines should be ok too
+
+foo
+
+# end of tagfile.txt
+
--- /dev/null
+// tagfile1.c
+// first half of a tagfile tester
+
+// perfectly ordinary definition
+int foo(int x)
+{
+ return x+7;
+}
+
+#ifdef STATIC_FUNC
+// wrong function type
+typedef void (*VoidFn)();
+
+// static function definition that will provoke a descriptor
+static int bar(int *p)
+{
+ VoidFn vf;
+ vf = (VoidFn)bar;
+ return *p;
+}
+#endif // STATIC_FUNC
--- /dev/null
+// tagfile2.c
+// second half of a tagfile tester
+
+// external decl of function in tagfile1.c
+int foo(int x);
+
+typedef void (*VoidFn)();
+
+int main()
+{
+ VoidFn tagMaker;
+ int x;
+
+ tagMaker = (VoidFn)&foo; // make CCured tag 'foo'
+ x = foo(3); // but call it normally
+
+ return x-10; // should be 0
+}
+
+
+#ifdef STATIC_FUNC
+// static function definition that will provoke a descriptor
+static int bar(int *p)
+{
+ VoidFn vf;
+ vf = (VoidFn)bar;
+ return *p;
+}
+#endif // STATIC_FUNC
--- /dev/null
+/***********************************************************************\
+| |
+| B+tree function tests |
+| |
+| |
+| Jan Jannink created 12/22/94 revised 1/30/95 |
+| |
+\***********************************************************************/
+
+#include <stdio.h>
+#include <stdlib.h>
+#include "btree.h"
+
+
+#ifdef _MSVC
+ #define CLOCKS_PER_SEC 1000
+ typedef long clock_t;
+ clock_t __cdecl clock(void);
+#else
+ int clock(void);
+#endif
+
+#define TIMESTART(clk) {clk=(double)clock();}
+#define TIMESTOP(clk) {clk=1000000.0 * \
+ ((double)clock()-(clk))/CLOCKS_PER_SEC;}
+
+
+int main(void)
+{
+ Tree *Bplus;
+ Nptr keyNode;
+ int i, j;
+ double clk;
+
+ TIMESTART(clk);
+
+ Bplus = initBtree(ARRAY_SIZE, MAX_FAN_OUT, compareKeys);
+ for (i = 0; i < 20000; i++) {
+ j = rand();
+ if (search(Bplus, j) == NONODE) {
+ insert(Bplus, j);
+ //fprintf(stderr, "XXX %d, insert %d XXX\n", i, j);
+ }
+ else {
+ delete(Bplus, j);
+ //fprintf(stderr, "XXX %d, delete %d XXX\n", i, j);
+ }
+ // if (i > 2000) { listAllBtreeValues(Bplus); }
+ }
+ for (i = 0; i < 1505600; i++)
+ (void) search(Bplus, i);
+ // listAllBtreeValues(Bplus);
+ freeBtree(Bplus);
+
+ TIMESTOP(clk);
+ printf("Run btreetest in %8.3lfms\n", clk / 1000.0);
+
+ return 0;
+}
+
--- /dev/null
+// thing.c
+// strange casts to 'void' on pointer comparisons??
+
+struct Thing *thing;
+
+int test()
+{
+ return thing == 0;
+}
+
+int main()
+{
+ test();
+ return 0;
+}
--- /dev/null
+// transparent unions?
+
+struct BoxedInt {
+ int x;
+};
+
+typedef union {
+ int *intPtr;
+ struct BoxedInt *boxedPtr;
+} CompatArgUnion __attribute__((__transparent_union__));
+
+extern int compatFunc(int, CompatArgUnion);
+
+int compatFunc(int firstArg, CompatArgUnion secondArg)
+{
+ return firstArg + *(secondArg.intPtr);
+}
+
+
+int main()
+{
+ int i = 6;
+ struct BoxedInt b;
+ int ret = 0;
+
+ b.x = 7;
+
+ // today I pass an int ptr
+ ret += compatFunc(-6, &i);
+
+ // tomorrow I pass a ptr to a struct with an embedded int
+ ret += compatFunc(-7, &b);
+
+ return ret;
+}
+
+
--- /dev/null
+// trivial-tb.c
+// NUMERRORS 4
+// test the test-bad target and lib/test-bad script
+
+#include <stdio.h> // printf
+#include <stdlib.h> // exit
+
+void fail(int val)
+{
+ printf("fail(%d)\n", val);
+ exit(val);
+}
+
+int main()
+{
+ fail(1); // ERROR(1)
+ fail(2); // ERROR(2)
+ fail(3); // ERROR(3)
+ fail(4); // ERROR(4)
+
+ printf("no failure\n");
+ return 0;
+}
+
+
--- /dev/null
+#include "../small1/testharness.h"
+
+#include <excpt.h>
+
+// NUMERRORS 3
+
+// This is for MSVC
+#ifndef _MSVC
+error This test works only for MSVC
+#endif
+
+int throw() {
+ // Simulate a segfault
+ { __NOCUREBLOCK
+ // We do not want CCured to notice this one
+ *((int*)0) = 5;
+ }
+}
+
+void incr(int *px) {
+ *px = 1 + *px;
+}
+
+int main() {
+
+ int i = 0;
+
+ __try {
+ i ++;
+ } __finally {
+ i --;
+ }
+
+#if ERROR >= 1 && ERROR <= 2
+ __try {
+ i ++;
+ throw (); // ERROR2
+ } __except(i +=5, EXCEPTION_EXECUTE_HANDLER) {
+ i --;
+ }
+ if(i == 1) E(1); // ERROR1:Error 1
+ if(i == 5) E(2); // ERROR2:Error 2
+#endif
+
+#if ERROR >= 3
+ __try {
+ __try {
+ i ++;
+ throw ();
+ } __except(i ++, EXCEPTION_CONTINUE_SEARCH) {
+ E(3); // Should not get here
+ }
+ } __except(incr(&i), incr(&i), EXCEPTION_EXECUTE_HANDLER) {
+ if(i == 4) E(32); // ERROR3:Error 32
+ }
+ E(31);
+#endif
+
+ if(i != 0) E(100); // ERROR0
+
+ SUCCESS;
+}
+
+
--- /dev/null
+// call a function twice, which does printf of a literal string
+
+#include <stdio.h> // printf
+
+void pr()
+{
+ printf("hi there\n");
+}
+
+int main()
+{
+ pr();
+ pr();
+ return 0;
+}
--- /dev/null
+// simple use of typeof
+
+int globalInt;
+
+void y() {
+ exit(-2); //make sure y() is not invoked!
+}
+
+void typeofVoid() {
+ (typeof(y()))0;
+}
+
+
+int main()
+{
+ __typeof(globalInt) localInt;
+ typeofVoid();
+ localInt = 6 * 2 - 12;
+ return localInt;
+}
+
--- /dev/null
+// Demonstrate what happens when you call a function that is not
+// defined.
+
+int main() {
+ int a = 3;
+ gronkwaerawerawerwae(a);
+ return 0;
+}
--- /dev/null
+// uninit_tmp.c
+// demonstrate a CIL bug with commas and function calls
+
+void * function_of_interest(int x, int y)
+{
+ return (void*)5;
+}
+
+struct struct_one *bad_function(struct struct_one *os, long x)
+{
+ auto const struct struct_two *other_variable;
+
+ auto const struct struct_of_interest *variable_of_interest;
+
+ variable_of_interest =
+ (
+ other_variable = 0,
+
+ (const struct struct_of_interest *) function_of_interest(0, 0)
+ );
+
+ return (struct struct_one*)variable_of_interest;
+}
+
+int main()
+{
+ struct struct_one *p;
+
+ p = bad_function(0,0);
+
+ if (p != (struct struct_one*)5) {
+ printf("cil bug is still present\n");
+ return 2;
+ }
+ else {
+ printf("bug has been fixed!\n");
+ return 0;
+ }
+}
--- /dev/null
+#include "../small1/testharness.h"
+#include "../small1/testkinds.h"
+
+// NUMERRORS 12
+
+union unsafeu1 {
+ int *f1;
+ int *f2[2];
+ struct { int *a1, a2, *a3; } f3;
+ /* unsafe union: a2 and f2[1] */
+} * x;
+
+union unsafeu2 {
+ int *g1;
+ struct { int *b1, b2; } g2;
+ struct { int *c1, *c2, *c3; } g3;
+ /* unsafe union: c2 and b2 */
+} * y;
+
+union safeu {
+ int a[2];
+ char b[8];
+ // safe union: all scalars
+} * z;
+
+union safeu2 {
+ struct { int a; int *b; } s1;
+ struct { int c; int *d; } s2;
+} same, *sptr;
+
+
+int main() {
+ if(HAS_KIND(x->f1, WILD_KIND)) E(1); //ERROR(1):Error 1
+ // x will be SAFE because it is not used at all to access the fields
+ if(HAS_KIND(x, SAFE_KIND)) E(12); //ERROR(12):Error 12
+ if(HAS_KIND(y->g1, WILD_KIND)) E(2); //ERROR(2):Error 2
+ if(HAS_KIND(z, SAFE_KIND)) E(3); //ERROR(3):Error 3
+#if ERROR == 4
+ sptr = &same;
+ sptr->s1.b++;
+ if(HAS_KIND(sptr->s2.d, FSEQ_KIND)) E(4); //ERROR(4):Error 4
+#endif
+#if ERROR == 5
+ sptr = &same;
+ sptr->s2.d--;
+ if(HAS_KIND(sptr->s1.b, SEQ_KIND)) E(5); //ERROR(5):Error 5
+#endif
+#if ERROR == 6
+ sptr = &same;
+ y = sptr->s2.d; // makes things WILD
+ if(HAS_KIND(sptr->s1.b, WILD_KIND)) E(6); //ERROR(6):Error 6
+#endif
+#if ERROR == 7
+ sptr = &same;
+ y = sptr->s1.b; // makes things WILD
+ if(HAS_KIND(sptr, SAFE_KIND)) E(7); //ERROR(7):Error 7
+#endif
+ {
+ // These two unions should be fine
+ union {
+ struct { int a; int b; int c; } one;
+ struct { int p; int q; int r; int *s; } two;
+ } *aa;
+ union {
+ struct { int a; int b; } one;
+ struct { int p; int q; int *s; } two;
+ } *bb;
+#if ERROR == 8
+ aa = bb;
+ if(HAS_KIND(aa, WILD_KIND)) E(8); //ERROR(8):Error 8
+#endif
+#if ERROR == 9
+ bb = aa;
+ if(HAS_KIND(aa, WILD_KIND)) E(9); //ERROR(9):Error 9
+#endif
+ }
+ {
+ // These two unions should be fine
+ union ulong {
+ struct { int a; int b; int c; } one;
+ struct { int p; int q; int r; int s; } two;
+ } adata, *aa = &adata;
+ union ushort {
+ struct { int a; int b; } one;
+ struct { int p; int q; int s; } two;
+ } bdata, *bb = &bdata;
+#if ERROR == 10
+ // Since aa is longer, the bb will have to be FSEQ to be able to check the
+ // length
+ aa = bb; //ERROR(10):Failure UBOUND
+#endif
+#if ERROR == 11
+ bb = aa;
+ if(HAS_KIND(aa, SAFE_KIND)) E(11); //ERROR(11):Error 11
+#endif
+ }
+ SUCCESS;
+}
--- /dev/null
+#include "../small1/testharness.h"
+
+#define NUMERRORS 3
+
+/* A test case with tagged unions */
+#ifndef __TAGGED
+ #define __TAGGED
+#endif
+
+union u {
+ int f1;
+ int* f2;
+ struct {
+ int *f3_1;
+ int *f3_2;
+ } f3;
+ int* (*f4)(int*);
+ char f5;
+} __TAGGED;
+
+int* foo(int *x) { return x;}
+
+int main() {
+ int i, i1;
+ union u x;
+ union u *px = &x;
+#if ERROR == 0
+ //x is uninitialized:
+ if (CCURED_HASUNIONTAG(x.f1)) E(11);
+ if (CCURED_HASUNIONTAG(x.f2)) E(12);
+ if (CCURED_HASUNIONTAG(x.f3)) E(13);
+ if (CCURED_HASUNIONTAG(x.f4)) E(14);
+ if (CCURED_HASUNIONTAG(x.f5)) E(15);
+
+ x.f1 = 5;
+ if(x.f1 != 5) E(1);
+ if (!CCURED_HASUNIONTAG(x.f1)) E(16);
+
+ x.f5 = 20;
+ if(x.f5 != 20) E(1);
+ if (!CCURED_HASUNIONTAG(x.f5)) E(17);
+
+ x.f2 = &i;
+ if(px->f2 != &i) E(2);
+ if (CCURED_HASUNIONTAG(x.f4)) E(18);
+ if (!CCURED_HASUNIONTAG(x.f2)) E(19);
+
+ //writing to f3.f3_2 should clear f3.f3_1
+ x.f3.f3_2 = &i1;
+ if (x.f3.f3_1 != 0) E(3);
+ //but writing to f3 again should not clear f3_2!
+ x.f3.f3_1 = &i;
+ if(x.f3.f3_2 != &i1) E(4);
+
+ // And some trick with the thing appearing both on left and right-side
+ x.f2 = x.f3.f3_1;
+ if(px->f2 != &i) E(5);
+
+ // Same for a function call
+ x.f3.f3_1 = &i;
+ x.f2 = x.f3.f3_1; // Make sure we check the read before the write
+ if (x.f2 != &i) E(6);
+
+ x.f4 = foo;
+ x.f2 = x.f4(&i); // make sure that we check the read before the write
+#endif
+
+ // Try to provoke some errors
+#if ERROR == 1
+ x.f1 = 5;
+ i = * x.f2; // ERROR(1): wrong union field
+#endif
+
+#if ERROR == 2
+ // We should not be allowed to take the address of a tagged field
+ i1 = & px->f1; // ERROR(2): cannot take the address
+#endif
+
+#if ERROR == 3
+ {
+ struct s {
+ union u u1;
+ } x;
+ i = & x.u1.f1; // ERROR(3): cannot take the address
+ }
+#endif
+
+ if(! HAS_KIND(px, SAFE_KIND)) E(10);
+
+ SUCCESS;
+}
--- /dev/null
+#include "../small1/testharness.h"
+
+#ifndef HAS_KIND
+#define HAS_KIND(x, y) 1
+#endif
+
+typedef unsigned char MzU8;
+typedef unsigned short MzU16;
+typedef unsigned int MzU32;
+typedef MzU32 MzEventSupp;
+struct key_pressed {
+ MzU8 repeatCount ;
+};
+struct char_char {
+ MzU8 repeatCount ;
+};
+struct pointer_moved {
+ unsigned int lButton : 1 ;
+ unsigned int mButton : 1 ;
+ unsigned int rButton : 1 ;
+};
+union supp {
+ MzEventSupp supp ;
+ struct key_pressed key_pressed ;
+ struct char_char char_char ;
+ struct pointer_moved pointer_moved ;
+};
+
+
+int main() {
+ union supp *p;
+ if(! HAS_KIND(p, SAFE_KIND)) E(1);
+
+ SUCCESS;
+}
--- /dev/null
+#include "../small1/testharness.h"
+
+// NUMERRORS 3
+
+union { //size = 12
+ struct {
+ int *a, *b;
+ } f1;
+ int f2;
+
+ // An ugly, unrealistic case
+ struct { //size = 12
+ union { //size = 8
+ int x;
+ struct { //size = 8
+ int* s1;
+ int* s2;
+ } s;
+ } __TAGGED f3_u;
+ int f3_int;
+ } f3;
+
+} __TAGGED u;
+
+int i;
+
+int main() {
+
+ u.f2 = 5; // now u.f1.a = 5
+ u.f1.b = &i; // now the tag says that u.f1 is active
+
+ i = * u.f1.a; //ERROR(1): Null pointer
+
+ u.f2 = 5; // now u.f3.f3_u.s.s1 = 5
+
+ //Union in a union. This will clear the f3 struct and (redundantly) the
+ // f3.f3_u.s struct.
+
+ u.f3.f3_u.s.s2 = &i;
+#if ERROR == 0
+ if (u.f3.f3_u.s.s2 != &i) E(1);
+ if (u.f3.f3_u.s.s1 != 0) E(2);
+ if (u.f3.f3_int != 0) E(3);
+ if (! CCURED_HASUNIONTAG(u.f3.f3_u.s.s1)) E(4);
+ if (CCURED_HASUNIONTAG(u.f3.f3_u.x)) E(5);
+ if (CCURED_HASUNIONTAG(u.f1.a)) E(6);
+
+#else
+ i = * u.f3.f3_u.s.s1; //ERROR(2): Null pointer
+ i = * u.f1.b; //ERROR(3): WRONGFIELD
+#endif
+
+ SUCCESS;
+}
--- /dev/null
+#include "../small1/testharness.h"
+
+// NUMERRORS 19
+
+enum tags {
+ TAG_ZERO = 0,
+};
+
+struct host {
+ int tag; // 0 for integer, 1 for int*, 2 for structure, 3 if tag2 choses
+ char tag2; //If tag is 3, then 0 for int, 1 for int*
+
+ union bar {
+ int anint __SELECTEDWHEN(tag == TAG_ZERO);
+ int * ptrint __SELECTEDWHEN(tag == 1);
+ struct str {
+ int * * ptrptr;
+ } ptrptr
+ __SELECTEDWHEN(tag == 5) // ERROR(0)
+ /* missing selected when */ // ERROR(1):Error 1
+ __SELECTEDWHEN(tag == foo) // ERROR(2):Cannot compile the discriminator
+ __SELECTEDWHEN(tag_bad == 5) // ERROR(3):Cannot compile the discriminator
+ __SELECTEDWHEN(tag == 5) __SELECTEDWHEN(tag == 6) // ERROR(4):more than one SELECTEDWHEN clause
+ __SELECTEDWHEN(somethingelse == 5) // ERROR(5):does not have an integer type
+#if ERROR >= 6
+ __SELECTEDWHEN(tag == 5)
+#endif
+ ;
+ int *disj __SELECTEDWHEN(tag == 10 || tag == 11);
+ int *conj __SELECTEDWHEN(tag >= 15 && tag <= 17);
+
+ int int2 __SELECTEDWHEN(tag == 3 && tag2 == 0);
+ int * ptr2 __SELECTEDWHEN(tag == 3 && tag2 == 1);
+ } data;
+
+ //A second union that uses the same tags.
+ union foo {
+ int fooint __SELECTEDWHEN(tag == TAG_ZERO);
+ int * fooptrint __SELECTEDWHEN(tag == 1);
+ } data2;
+
+ struct {
+ int x;
+ } somethingelse;
+} g;
+
+
+int x;
+int * px = &x;
+
+int one() { return 1; }
+
+int main() {
+
+ g.tag = 0;
+
+ // This is good behavior
+
+#if ERROR == 0
+ g.data.anint = 5;
+ x = g.data.anint;
+
+
+ g.tag = 1;
+ g.data2.fooptrint = px;
+ px = g.data2.fooptrint;
+
+ g.tag = 5;
+ g.data.ptrptr.ptrptr = &px;
+ x = * * g.data.ptrptr.ptrptr;
+
+ g.tag = 3; g.tag2 = 1;
+ g.data.ptr2 = px;
+ px = g.data.ptr2;
+
+ // This is allowed because we are not reading a pointer
+ // matth: this is no longer allowed. We enforce all discriminators
+ //g.tag = 1; x = g.data.anint;
+
+#endif
+
+ if(KIND_OF(g.data.ptrint) != SAFE_KIND) E(1);// ERROR(1)
+
+
+ // We cannot access pointers when the tag is wrong
+ g.tag = 0; x = g.data.ptrint; // ERROR(19):Failure WRONGFIELD
+ g.tag = 0; * g.data.ptrptr.ptrptr = x; // ERROR(6):Failure WRONGFIELD
+ g.tag = 0; { struct str s = g.data.ptrptr; } // ERROR(7):Failure WRONGFIELD
+
+#if ERROR == 8
+ {
+ union {
+ int * ptr __SELECTEDWHEN(tag);
+ } a;
+ // We should not be able to acces this one
+ // ERROR(8):outside a host structure
+ px = a.ptr;
+ }
+#endif
+
+ // We cannot take the address of fields in discriminated unions
+ px = & g.data.anint; // ERROR(9):cannot take the address of a field
+ // We cannot take the address of a field in a subfield
+ { int * * * a = & g.data.ptrptr.ptrptr; } // ERROR(10):cannot take the address of a field
+
+ // We can take the address of a non-discriminated field
+ px = & g.somethingelse.x; E(11); // ERROR(11):Error 11
+
+#if ERROR >= 12 && ERROR <= 14
+ g.tag = 10;px = g.data.disj; E(12); // ERROR(12):Error 12
+ g.tag = 11;px = g.data.disj; E(13); // ERROR(13):Error 13
+ g.tag = 12;px = g.data.disj; // ERROR(14):Failure WRONGFIELD
+#endif
+
+#if ERROR >= 15 && ERROR <= 18
+ g.tag = 10;px = g.data.conj; // ERROR(15):Failure WRONGFIELD
+ g.tag = 15;px = g.data.conj; E(16); // ERROR(16):Error 16
+ g.tag = 16;px = g.data.conj; E(17); // ERROR(17):Error 17
+ g.tag = 18;px = g.data.conj; // ERROR(18):Failure WRONGFIELD
+#endif
+
+ // When we switch tags we clear the pointers.
+ g.tag = 1;
+ g.data.ptrint = &x;
+ g.tag = one(); //This doesn't change the tag, so no need to clear g.data
+ if (g.data.ptrint != &x) E(98);
+
+ g.tag = 5; //should clear g.data
+ if(g.data.ptrptr.ptrptr != 0) E(99);
+
+ SUCCESS;
+}
+
--- /dev/null
+//Make sure everything runs as is
+//KEEP baseline: success
+
+#include "../small1/testharness.h"
+
+
+typedef struct parent {
+ void * __RTTI * vtbl;
+ int *fseq;
+ int *f1;
+} Parent;
+
+#pragma ccured_extends("Schild", "Sparent")
+
+typedef struct child {
+ void * __RTTI * vtbl;
+ int * __FSEQ fseq;
+ int *f1;
+ int f2;
+} Child;
+
+
+//OpenSSL does casts between union fields like this.
+union {
+ int i;
+ void* vp;
+ int* ip;
+ char* str;
+ double d;
+ Parent * __RTTI pp;
+ Child * cp;
+ int** ptrptr;
+} __TAGGED u;
+
+int global[11];
+
+int* foo(int* x) { return x; }
+
+int main() {
+ Child carray[5];
+ Parent parray[2];
+
+ u.ip = foo(&global[0]);
+ unsigned long x = u.vp;
+ x += u.i;
+ u.ip++; //KEEP fseq: success
+ x += *u.ip;
+
+ u.i = x; //KEEP wrongfield: error = wrong union field
+ void* __RTTI v = u.vp;
+
+ u.str = "literal"; //KEEP str: success
+ v = u.vp; //KEEP str
+ printf((char*)v); //KEEP str
+
+ u.cp = &carray[2];
+ Parent * __RTTI p= u.pp;
+ if (__endof(p) != (unsigned long)(carray + 5)) E(2); //KEEP fseq
+ Child * c = p;
+ c++; //KEEP fseq
+ x += c->f2;
+
+ u.vp = p; //make sure we preserve the RTTI.
+ x += u.cp->f2;
+
+ u.d = 1.0 / 10; //DROP double: error = wrong union field
+ double dd = u.d;
+
+ //Use a union to cast an int* __FSEQ * to void* __RTTI, and back to int**.
+ //Make sure the right compatibility edges are added.
+ int * z2 = &global[0];
+ int* __FSEQ z = global; //KEEP ptrptr: success
+ u.ptrptr = &z; //KEEP ptrptr
+ void * __RTTI r = u.vp; //KEEP ptrptr
+ *((int**)r) = z2; // z2 should be FSEQ! //KEEP ptrptr
+ if (KIND_OF(z) != FSEQ_KIND) E(3); //KEEP ptrptr
+ if (KIND_OF(z2) != FSEQ_KIND) E(4); //KEEP ptrptr
+
+ if (KIND_OF(z2) != SAFE_KIND) E(5); //DROP ptrptr
+
+ //The dual of the above test: RTTI first, then the union.
+ int * z3 = &global[0];
+ void * __RTTI r = &z3; //KEEP ptrptr2: success
+ u.vp = r; //KEEP ptrptr2
+ int* __FSEQ z = global; //KEEP ptrptr2
+ (*(u.ptrptr))++; //KEEP ptrptr2
+ // u.ptrptr (and therefore z3) should be FSEQ!
+ if (KIND_OF(z) != FSEQ_KIND) E(6); //KEEP ptrptr2
+ if (KIND_OF(z3) != FSEQ_KIND) E(7); //KEEP ptrptr2
+
+ if (KIND_OF(z3) != SAFE_KIND) E(8); //DROP ptrptr2
+
+ int* __FSEQ z = global;
+ void* __RTTI r = &z;
+
+
+ SUCCESS;
+}
--- /dev/null
+// unionassign.c
+// assign a union variable to another union variable
+
+
+// ------------------ this part works -----------------------
+struct S1 {
+ int x;
+};
+
+struct S2 {
+ char p;
+};
+
+struct S3 {
+ int x1;
+ int y1;
+};
+
+union U {
+ struct S1 s1;
+ struct S2 s2;
+ struct S3 s3;
+};
+
+int main()
+{
+ union U x,y;
+ x.s1.x = 5;
+ y = x;
+ return y.s1.x - 5;
+}
+
+
+
+// ------------------- this part fails -------------------
+typedef unsigned short int sa_family_t ;
+typedef unsigned char uint8_t ;
+typedef unsigned short int uint16_t ;
+typedef unsigned int uint32_t ;
+
+struct in_addr {
+ uint32_t s_addr ;
+} ;
+
+struct sockaddr {
+ sa_family_t sa_family ;
+ char sa_data[14] ;
+} ;
+
+struct sockaddr_in {
+ sa_family_t sin_family ;
+ uint16_t sin_port ;
+ struct in_addr sin_addr ;
+ unsigned char sin_zero[sizeof(struct sockaddr ) -
+ sizeof(unsigned short int ) - sizeof(uint16_t ) -
+ sizeof(struct in_addr )] ;
+} ;
+
+struct in6_addr {
+ union {
+ uint8_t u6_addr8[16] ;
+ uint16_t u6_addr16[8] ;
+ uint32_t u6_addr32[4] ;
+ } in6_u ;
+} ;
+
+struct sockaddr_in6 {
+ sa_family_t sin6_family ;
+ uint16_t sin6_port ;
+ uint32_t sin6_flowinfo ;
+ struct in6_addr sin6_addr ;
+} ;
+
+union sockunion {
+ struct sockinet {
+ sa_family_t si_family ;
+ uint16_t si_port ;
+ } su_si ;
+ struct sockaddr_in su_sin ;
+ struct sockaddr_in6 su_sin6 ;
+} ;
+
+int foo()
+{
+ union sockunion x,y;
+ x = y;
+ return 3;
+}
--- /dev/null
+// union decl in a compound statement expression
+
+int main()
+{
+ int status;
+
+ return
+ (
+ (__extension__
+ ({
+ union {
+ __typeof( status ) __in;
+ int __i;
+ } __u;
+
+ __u.__in = status;
+ __u.__i;
+ })
+ ) & 0xff00
+ ) >> 8 ;
+}
--- /dev/null
+// unscomp.c
+// show problem with linux/fs/buffer.c and unsigned comparisons
+
+#include <stdio.h> // printf
+int main()
+{
+ unsigned long size;
+ long offset;
+
+ size = 1024;
+ offset = 50;
+
+ if ((offset -= size) >= 0) {
+ // 50 - 1024 is negative
+ printf("no -- this is wrong\n");
+ return 2;
+ }
+
+ // Now a similar thing. The result of the subtraction is unsigned
+ // and so is the comparison
+ offset = 50;
+ if(offset - size < 0) {
+ printf("This is also wrong\n"); return 3;
+ }
+
+ printf("yes this is right\n");
+ return 0;
+}
--- /dev/null
+
+typedef struct sm_element_struct sm_element;
+typedef struct sm_row_struct sm_row;
+typedef struct sm_col_struct sm_col;
+typedef struct sm_matrix_struct sm_matrix;
+
+
+
+
+struct sm_element_struct {
+ int row_num;
+ int col_num;
+ sm_element *next_row;
+ sm_element *prev_row;
+ sm_element *next_col;
+ sm_element *prev_col;
+ char *user_word;
+};
+
+
+
+
+
+struct sm_row_struct {
+ int row_num;
+ int length;
+ int flag;
+ sm_element *first_col;
+ sm_element *last_col;
+ sm_row *next_row;
+ sm_row *prev_row;
+ char *user_word;
+};
+
+
+
+
+
+struct sm_col_struct {
+ int col_num;
+ int length;
+ int flag;
+ sm_element *first_row;
+ sm_element *last_row;
+ sm_col *next_col;
+ sm_col *prev_col;
+ char *user_word;
+};
+
+
+
+
+
+struct sm_matrix_struct {
+ sm_row **rows;
+ int rows_size;
+ sm_col **cols;
+ int cols_size;
+ sm_row *first_row;
+ sm_row *last_row;
+ int nrows;
+ sm_col *first_col;
+ sm_col *last_col;
+ int ncols;
+ char *user_word;
+};
+
+
+
+
+
+
+
+
+
+static int
+visit_row(A, prow, rows_visited, cols_visited)
+sm_matrix *A;
+sm_row *prow;
+int *rows_visited;
+int *cols_visited;
+{
+ sm_element *p;
+ sm_col *pcol;
+
+ if (! prow->flag) {
+ prow->flag = 1;
+ (*rows_visited)++;
+ if (*rows_visited == A->nrows) {
+ return 1;
+ }
+ for(p = prow->first_col; p != 0; p = p->next_col) {
+ pcol = ((( p->col_num ) >= 0 && ( p->col_num ) < ( A )->cols_size) ? ( A )->cols[ p->col_num ] : (sm_col *) 0) ;
+ if (! pcol->flag) {
+ if (visit_col(A, pcol, rows_visited, cols_visited)) {
+ return 1;
+ }
+ }
+ }
+ }
+ return 0;
+}
+
+
+int
+visit_col(A, pcol, rows_visited, cols_visited)
+sm_matrix *A;
+sm_col *pcol;
+int *rows_visited;
+int *cols_visited;
+{
+ sm_element *p;
+ sm_row *prow;
+
+ if (! pcol->flag) {
+ pcol->flag = 1;
+ (*cols_visited)++;
+ if (*cols_visited == A->ncols) {
+ return 1;
+ }
+ for(p = pcol->first_row; p != 0; p = p->next_row) {
+ prow = ((( p->row_num ) >= 0 && ( p->row_num ) < ( A )->rows_size) ? ( A )->rows[ p->row_num ] : (sm_row *) 0) ;
+ if (! prow->flag) {
+ if (visit_row(A, prow, rows_visited, cols_visited)) {
+ return 1;
+ }
+ }
+ }
+ }
+ return 0;
+}
--- /dev/null
+#include "../small1/testharness.h"
+#include "../small1/testkinds.h"
+#include <stdlib.h>
+
+/* weimer
+ * Mon Aug 5 13:28:25 PDT 2002
+ *
+ * This represents my best efforts to somehow sneak an integer into a
+ * pointer via a void*.
+ *
+ * Note that derefing such a pointer sometimes gives "ubound" and sometimes
+ * gives "reading a pointer that has been tampered with".
+ *
+ * GN: adjusted to expect Non-pointer error messages.
+ */
+
+// NUMERRORS 8
+
+int function() {
+#if ERROR == 1
+ {
+ int i1 = 5;
+ void **vi5 = &i1;
+ void *vi6 = vi5;
+ int * * pi2 = vi5;
+ return * * pi2; //ERROR(1):Non-pointer
+ }
+#endif
+#if ERROR == 2
+ {
+ struct { int a; int b; } c;
+ void **v1 = &c;
+ void *v2 = v1;
+ int **p = v2;
+ c.a = 5;
+ return **p; //ERROR(2):Reading
+ }
+#endif
+#if ERROR == 3
+ {
+ struct { int a; int b; } c;
+ void **v1 = &c.b;
+ void *v2 = v1;
+ int **p = v2;
+ c.b = 5;
+ return **p; //ERROR(3):Non-pointer
+ }
+#endif
+#if ERROR == 4
+ {
+ struct { struct { int a; int b; } c ; int d; } e;
+ void **v1 = &e.c.b;
+ void *v2 = v1;
+ int **p = v2;
+ e.c.b = 5;
+ return **p; //ERROR(4):Reading
+ }
+#endif
+#if ERROR == 5
+ {
+ int i = 5;
+ void ****v1;
+ void *v2;
+ int ****v3;
+ v1 = malloc(sizeof(*v1));
+ *v1 = malloc(sizeof(**v1));
+ **v1 = malloc(sizeof(***v1));
+ ***v1 = &i; //ERROR(5):Storing stack address
+ v2 = v1;
+ v3 = v2;
+ return ****v3;
+ }
+#endif
+#if ERROR == 6
+ {
+ int i __HEAPIFY = 5;
+ void ****v1;
+ void *v2;
+ int ****v3;
+ v1 = malloc(sizeof(*v1));
+ *v1 = malloc(sizeof(**v1));
+ **v1 = malloc(sizeof(***v1));
+ **v1 = &i;
+ v2 = v1;
+ v3 = v2;
+ return ****v3; //ERROR(6):Non-pointer
+ }
+#endif
+#if ERROR == 7
+ {
+ int i __HEAPIFY = 5;
+ void ****v1;
+ void *v2;
+ int *****v3;
+ v1 = malloc(sizeof(*v1));
+ *v1 = malloc(sizeof(**v1));
+ **v1 = malloc(sizeof(***v1));
+ ***v1 = &i;
+ v2 = v1;
+ v3 = v2;
+ return *****v3; //ERROR(7):Non-pointer
+ }
+#endif
+#if ERROR == 8
+ {
+ extern int deref(void *);
+ int (*fptr)(void *) = deref;
+ int x ;
+ x = fptr(5);
+ }
+#endif
+}
+
+int deref(void *a) {
+ int *b = a;
+ return *b; //ERROR(8):Non-pointer
+}
+
+int main() {
+ function();
+}
--- /dev/null
+// volatilestruct.c
+// from sac at stevechamberlain dot com
+
+// problem with associating attributes with structs instead
+// of the declared instances
+
+struct foo
+{
+ int AAAAAAAAAAAAAAAAAAA:7;
+} xxx;
+
+int main ()
+{
+ struct foo
+ {
+ double BBBBBBBBBBBBBBBBBBB;
+ } volatile bar;
+
+ static struct foo baz;
+ bar = baz;
+
+ return 0;
+}
--- /dev/null
+#include <stdio.h>
+#include <stdlib.h>
+
+#ifdef _GNUCC
+#include <unistd.h> // dup, close
+#endif
+#ifdef _MSVC
+#include <io.h>
+#endif
+
+//#include "main.h"
+/****** Data sizes *******
+* U8 must be an unsigned of 8 bits
+* U16 must be an unsigned of 16 bits *
+* U32 must be an unsigned of 32 bits *
+* U64 must be an unsigned on 64 bits *
+* UPOINT must be an unsigned of the size of a pointer
+* ALIGN must be the number of bytes the data accesses must be aligned to - 1
+* i.e. it must be 3 for the data to be aligned on a 32-bit boundary. It
+* must be at least 1 (16-bit alignment). It must be <= UPOINT
+* ALSHIFT is log2(ALIGN + 1)
+* UALIGN is the integer whose size if ALIGN + 1.
+*************************/
+
+typedef unsigned long UL;
+typedef unsigned char UC;
+typedef int BOOL;
+#define TRUE 1
+#define FALSE 0
+
+#define MASK(bitlen) ((1 << (bitlen)) - 1)
+
+#ifdef alpha_UNIX /* Both GCC and DEC cc seem to have the same */
+#define ALSHIFT 3
+#define ALIGN MASK(ALSHIFT)
+#define UALIGN U64
+
+#define U8 unsigned char
+#define S8 char
+#define U16 unsigned short
+#define S16 short
+#define U32 unsigned int
+#define S32 int
+#define U64 unsigned long
+#define S64 long
+#define UPOINT U64
+#define SPOINT S64
+#define DIRLISTSEP ':'
+#endif /* alpha_UNIX */
+
+#ifdef x86_WIN32
+#define ALSHIFT 2
+#define ALIGN MASK(ALSHIFT)
+#define UALIGN U32
+
+#define U8 unsigned char
+#define S8 char
+#define U16 unsigned short
+#define S16 short
+#define U32 unsigned long
+#define S32 long
+#define UPOINT U32
+#define SPOINT S32
+
+#define DIRLISTSEP ';'
+
+#ifdef _MSVC /* MSVC on x86 */
+#define U64 unsigned __int64
+#define S64 __int64
+#endif /* _MSVC */
+
+#ifdef _GNUCC /* GNU CC on x86 */
+#define U64 unsigned long long
+#define S64 long long
+#endif /* _GNUCC */
+
+#endif /* x86_WIN32 */
+
+#ifdef x86_LINUX
+#define ALSHIFT 2
+#define ALIGN MASK(ALSHIFT)
+#define UALIGN U32
+#define __cdecl
+
+#define U8 unsigned char
+#define S8 char
+#define U16 unsigned short
+#define S16 short
+#define U32 unsigned long
+#define S32 long
+#define UPOINT U32
+#define SPOINT S32
+#define U64 unsigned long long
+#define S64 long long
+#define DIRLISTSEP ':'
+#endif /* x86_WIN32 */
+
+#define _ASSERT(be) {if(!(be)){fprintf(stderr,"Assertion failed on line %d in file %s\n", __LINE__, __FILE__);exit(2);}}
+
+#define ERR_SET
+#define ERR_CHECK(v,stop,prg)
+#define EXIT(v, n) exit(n)
+
+#define ERRLINE {fprintf(stderr, "Error at %s(%d):",__FILE__,__LINE__);\
+ ERR_SET;}
+#define WARNLINE {fprintf(stderr, "Warning at %s(%d):",__FILE__,__LINE__);}
+
+#define ERROR0(v, txt) {ERRLINE;\
+ fprintf(stderr,txt);EXIT(v,1);}
+#define ERROR1(v, txt, d1) {ERRLINE;\
+ fprintf(stderr,txt, d1);EXIT(v,1);}
+
+typedef long clock_t;
+ clock_t __cdecl clock(void);
+ int __cdecl rand(void);
+#ifdef _MSVC
+# define CLOCKS_PER_SEC 1000
+#else
+# define CLOCKS_PER_SEC 1000000
+#endif
+
+
+#define TIMESTART(clk) {clk=(double)clock();}
+#define TIMESTOP(clk) {clk=1000000.0 * ((double)clock()-(clk))/CLOCKS_PER_SEC;}
+
+
+extern int debugMM;
+
+#define SETDBGOUT int _stdout; fflush(stdout);_stdout=dup(1);dup2(2,1);
+#define RESTOREOUT fflush(stdout); dup2(_stdout, 1); close(_stdout);
+
+
+extern char* __stackInit;
+extern int __mmId;
+#define STACK_CHECK(category) { char __probe;\
+ long _pDepth = __stackInit - & __probe;\
+ __MM_REPORT("stack", &__probe, _pDepth, category);}
+
+#define STACK_INIT { char __probe;\
+ __stackInit = & __probe; __mmId = 0; }
+
+#define MALLOC(mallocfun, res, err, sz, type, category) {\
+ long _sz = (sz);\
+ (res) = (type)mallocfun(_sz);\
+ if(! (res)) {\
+ ERROR0(err, "Cannot malloc\n"); \
+ }\
+ __MM_REPORT("malloc", (res), _sz, category);}
+
+#define FREE(freefun, res, category) {\
+ if(res) {\
+ __MM_REPORT("free", (res), 0, category);\
+ freefun(res); }}
+
+#define CALLOC(callocfun, res, err, nrelem, sz, type, category) {\
+ int _nrelem = (nrelem);\
+ long _sz = (sz);\
+ (res) = (type)callocfun(_nrelem, _sz);\
+ if(! (res)) {\
+ ERROR0(err, "Cannot calloc\n"); \
+ }\
+ __MM_REPORT("malloc", (res), _sz * _nrelem, category);}
+
+#define REALLOC(res, err, sz, type, category) {\
+ long _sz = (sz);\
+ if((res)) { __MM_REPORT("free", (res), 0, category); }\
+ (res) = (type)realloc((res), _sz);\
+ if(! (res)) {\
+ ERROR0(err, "Cannot realloc\n"); \
+ }\
+ __MM_REPORT("malloc", (res), _sz, category);}
+
+#define STRDUP(res, err, what, category) {\
+ char* _what = what;\
+ long _sz = strlen(_what) + 1;\
+ (res) = strdup(_what);\
+ if(! (res)) {\
+ ERROR0(err, "Cannot strdup\n"); \
+ }\
+ __MM_REPORT("malloc", (res), _sz, category);}
+
+#if defined(_DEBUG) || defined(_DEBUGMM)
+#define __MM_REPORT(what, where, size, category) {\
+ if(debugMM) {\
+ SETDBGOUT; \
+ printf("*MM%d: %-6s 0x%08lx %08ld %-20s %s:%d\n", \
+ __mmId ++, \
+ (what), (where), (long)(size), (category),__FILE__,__LINE__);\
+ RESTOREOUT; } \
+ }
+#else
+#define __MM_REPORT(what, where, size, category) { }
+#endif
+
+//#include "hash.h"
+typedef int HASH_KEY;
+
+
+
+
+
+#ifdef SMALLMEM
+#define BUCKETS_SHIFT 5
+#define BUCKET_SIZE 4
+#else
+#define BUCKETS_SHIFT 8
+#define BUCKET_SIZE 8
+#endif
+
+#define NR_HASH_BUCKETS (1 << (BUCKETS_SHIFT)) /* These must be 2^k */
+
+
+ /* A Hash entry holds a particular pair (key,
+ * data) */
+#define EMPTY_ENTRY 0x54854A33
+
+typedef struct HashEntry {
+ int key; /* The key EMPTY_ENTRY is reserved for empty
+ * entries */
+ void * data;
+} HASH_ENTRY;
+
+ /* A bucket is a list of clusters of
+ * HASH_ENTRIES. It behaves like a list of
+ * entries but it is optimized by allocating
+ * a cluster of entries at a time */
+typedef struct BucketData {
+ struct BucketData * next;
+ HASH_ENTRY entries[BUCKET_SIZE];
+} BUCKET_DATA;
+
+
+typedef struct {
+ int size;
+ BUCKET_DATA * data;
+} HASH_BUCKET;
+
+
+typedef HASH_BUCKET * PHASH;
+
+
+PHASH NewHash(void);
+void FreeHash(PHASH);
+
+ /* The following functions return TRUE if the
+ * particular data was already in the hash */
+int HashLookup(PHASH, HASH_KEY, void * * data);
+ /* If data already exists, then replace it */
+int AddToHash(PHASH, HASH_KEY, void * );
+
+ /* Nothing happens if the key does not exits */
+int DeleteFromHash(PHASH, HASH_KEY);
+
+ /* Maps a function to a hash table. The last
+ * element is a closure. The data is
+ * overwritten but not placed into another
+ * bucket ! */
+int MapHash(PHASH, void * (* )(HASH_KEY, void * , UPOINT),
+ UPOINT);
+
+ /* Returns the number of elements in the table */
+unsigned int SizeHash(PHASH);
+ /* Preallocates some hashes */
+int preallocateHashes(void);
+ /* And release them */
+int releaseHashes(void);
+// End hash.h
+
+
+unsigned SizeHash(PHASH hash) {
+ int i;
+ HASH_BUCKET * pBucket = (HASH_BUCKET * )hash;
+ unsigned res = 0;
+ for(i=0;i<NR_HASH_BUCKETS;i++, pBucket++) {
+ res += pBucket->size;
+ }
+ return res;
+}
+ /* A hash table is actually an array of
+ * NR_HASH_BUCKETS * HASH_BUCKET */
+
+ /* Converts a hash key to a bucket index */
+#define HashKeyToBucket(k, res) { unsigned int _t = (unsigned int)k;\
+ res = 0;\
+ for(res = 0;_t;_t >>= BUCKETS_SHIFT) {\
+ res ^= (_t & (NR_HASH_BUCKETS - 1));\
+ }}
+
+
+ /* Keep a list of pre-allocated buckets */
+#define BUCKET_CACHE_SIZE (2 * NR_HASH_BUCKETS)
+
+#ifdef SMALLMEM
+#define BUCKET_CACHE_PREALLOC (BUCKET_CACHE_SIZE >> 2)
+#else
+#define BUCKET_CACHE_PREALLOC BUCKET_CACHE_SIZE
+#endif
+
+static BUCKET_DATA * bucketCache[BUCKET_CACHE_SIZE];
+static int nextFreeBucket = 0;
+
+
+static BUCKET_DATA * acquireHashBucket(void) {
+ if(nextFreeBucket == 0) {
+ BUCKET_DATA * buck;
+ MALLOC(malloc, buck, NULL, sizeof(BUCKET_DATA), BUCKET_DATA*,
+ "hash_bucket_data");
+ return buck;
+ } else {
+ return bucketCache[-- nextFreeBucket];
+ }
+}
+
+static int releaseHashBucket(BUCKET_DATA * buck) {
+ if(nextFreeBucket < BUCKET_CACHE_SIZE) {
+ bucketCache[nextFreeBucket ++] = buck;
+ } else {
+ FREE(free, buck, "hash_bucket_data");
+ }
+ return 0;
+}
+
+int preallocateHashes(void) {
+ int i;
+ nextFreeBucket = 0; /* So that acquire does not steal our buckets */
+ _ASSERT(BUCKET_CACHE_PREALLOC <= BUCKET_CACHE_SIZE);
+ for(i=0;i<BUCKET_CACHE_PREALLOC;i++) {
+ bucketCache[i] = acquireHashBucket();
+ }
+ nextFreeBucket = i;
+ return 0;
+}
+
+int releaseHashes(void) {
+ int i;
+ for(i=0;i<nextFreeBucket;i++) {
+ FREE(free, bucketCache[i], "hash_bucket_data");
+ }
+ nextFreeBucket = 0;
+ return 0;
+}
+
+/**************** NewHash *******************/
+PHASH NewHash(void) {
+ /* Allocate a hash */
+ PHASH res = (PHASH)calloc(NR_HASH_BUCKETS, sizeof(HASH_BUCKET));
+ if(! (res)) {
+ ERROR0(err, "Cannot calloc\n");
+ }
+ return (PHASH)res;
+}
+
+void FreeHash(PHASH hin) {
+ int i;
+ HASH_BUCKET * h = (HASH_BUCKET * )hin;
+ for(i=0;i<NR_HASH_BUCKETS;i++) {
+ HASH_BUCKET * buck = & h[i];
+ BUCKET_DATA * bdata = buck->data;
+ while(bdata != NULL) {
+ BUCKET_DATA * t_bdata = bdata;
+ bdata = bdata->next;
+ releaseHashBucket(t_bdata);
+ }
+ }
+ FREE(free, h, "hash_table");
+}
+
+typedef enum {SET, LOOKUP, DELETE} HashOper;
+
+static void * ProcessHash(PHASH hin, HASH_KEY key, void * data,
+ int * found, HashOper oper) {
+ int bucket_no, i, k;
+ BUCKET_DATA * buck = NULL;
+ BUCKET_DATA * * next = NULL;
+ HASH_ENTRY *target = NULL;
+ HASH_BUCKET * h = (HASH_BUCKET * )hin;
+
+ if(key == EMPTY_ENTRY) { key ++; }
+
+ _ASSERT(h);
+
+ HashKeyToBucket(key, bucket_no); /* Get the bucket number */
+ next = & h[bucket_no].data;
+
+ i = BUCKET_SIZE;
+ for(k=h[bucket_no].size;k > 0;) { /* Look for the data */
+ HASH_ENTRY * e;
+ buck = *next; /* Get the next cluster */
+ next = &(buck->next); /* Move one to next cluster */
+ e = buck->entries; /* This is the current entry */
+ for(i=0;i < BUCKET_SIZE && k > 0; k--, i++, e++) {
+ if(!target && e->key == EMPTY_ENTRY) target = e;
+ if(e->key == key) {
+ *found = 1;
+ switch(oper) {
+ case SET: e->data = data; return e->data;
+ case LOOKUP: return e->data;
+ case DELETE: e->data = NULL; e->key = EMPTY_ENTRY; return NULL;
+ }
+ }
+ }
+ if(k == 0) /* Not in the bucket, hence not in table */
+ break;
+ _ASSERT(i == BUCKET_SIZE);
+ }
+ _ASSERT(k == 0);
+ *found = 0; /* Here if not found */
+ if(oper != SET) {
+ return NULL;
+ }
+ if(! target) {
+ /* Must create a new entry */
+ if(i == BUCKET_SIZE) {
+ if(! next) {
+ next = &(h[bucket_no].data);
+ }
+ _ASSERT(*next == NULL);
+ buck = acquireHashBucket();
+ *next = buck;
+ buck->next = NULL;
+ i = 0;
+ }
+ target = &buck->entries[i];
+ h[bucket_no].size ++;
+ }
+ target->key = key;
+ target->data = data;
+ return NULL;
+}
+
+ /* Lookup a hash key. Put the result in *data */
+int HashLookup(PHASH h, HASH_KEY key, void * * data) {
+ int found;
+ *data = ProcessHash(h, key, NULL, &found, LOOKUP);
+ return found;
+}
+
+ /* Extend the hash. If the data already exists
+ * then replace it*/
+int AddToHash(PHASH h, HASH_KEY key, void* data) {
+ int found;
+ ProcessHash(h, key, data, &found, SET);
+ return found;
+}
+
+int DeleteFromHash(PHASH h, HASH_KEY key) {
+ int found;
+ ProcessHash(h, key, NULL, &found, DELETE);
+ return 0;
+}
+
+int MapHash(PHASH h, void* (* f)(HASH_KEY, void* , UPOINT),
+ UPOINT closure) {
+ int i;
+ HASH_BUCKET * pBucket = (HASH_BUCKET* )h;
+
+ for(i=0;i<NR_HASH_BUCKETS;i++, pBucket ++) {
+ int sz = pBucket->size;
+ BUCKET_DATA * pData = pBucket->data;
+ HASH_ENTRY * pEntry = pData->entries;
+ int k = 0;
+ for(;sz > 0;sz --, k++, pEntry++) {
+ if(k == BUCKET_SIZE) {
+ k = 0;
+ pData = pData->next;
+ pEntry = pData->entries;
+ }
+ if(pEntry->key == EMPTY_ENTRY)
+ continue;
+ pEntry->data = (*f)(pEntry->key, pEntry->data, closure);
+ }
+ }
+ return 0;
+}
+
+
+
+
+
+
+
+
+/* Some globals that PCC needs */
+int error_level, anerror;
+void myexit(int n) {
+ exit(n);
+}
+#ifdef _MSVC
+#define random rand
+#else
+/* extern int random(void); -- Weimer: not needed! */
+#endif
+int __mmId;
+int debugMM;
+int debug;
+
+
+#ifndef ITERS
+ #define ITERS 50000
+#endif
+
+
+
+int main() {
+ /* Test hash tables */
+ PHASH h = NewHash();
+ int i;
+ double clk;
+ int count = 0;
+ int sz;
+
+ /* Add and delete random numbers from the hash table */
+ TIMESTART(clk);
+ for(i=0;i<ITERS;i++) {
+ int k = random() & 0x7FFFL;
+ AddToHash(h, k, (void* )k);
+ }
+ for(i=0;i<ITERS;i++) {
+ int k = random() & 0x7FFFL;
+ void *data = NULL;
+ if(HashLookup(h, k, & data)) {
+ count ++;
+ }
+ }
+ sz = SizeHash(h);
+ FreeHash(h);
+ TIMESTOP(clk);
+ printf("Hash has %d elements. Found %d times\n",
+ sz, count);
+ printf("Run hashtest in %8.3lfms\n", clk / 1000.0);
+ exit (0);
+}
+
+
--- /dev/null
+#ifndef __SAFE
+#define __WILD
+#define __SAFE
+#define __FSEQ
+#define __SEQ
+#define __SIZED
+#endif
+
+
+#if ! defined(_MSVC) && ! defined(_GNUCC)
+#define U32 int
+#define __cdecl
+#endif
+
+#include <stdio.h>
+#include <stdlib.h>
+#ifdef _GNUCC
+#include <unistd.h> // dup, close
+#endif
+#ifdef _MSVC
+#include <io.h>
+#endif
+
+/* A special purpose main */
+//#include "main.h"
+/****** Data sizes *******
+* U8 must be an unsigned of 8 bits
+* U16 must be an unsigned of 16 bits *
+* U32 must be an unsigned of 32 bits *
+* U64 must be an unsigned on 64 bits *
+* UPOINT must be an unsigned of the size of a pointer
+* ALIGN must be the number of bytes the data accesses must be aligned to - 1
+* i.e. it must be 3 for the data to be aligned on a 32-bit boundary. It
+* must be at least 1 (16-bit alignment). It must be <= UPOINT
+* ALSHIFT is log2(ALIGN + 1)
+* UALIGN is the integer whose size if ALIGN + 1.
+*************************/
+typedef unsigned long UL;
+typedef unsigned char UC;
+typedef int BOOL;
+#define TRUE 1
+#define FALSE 0
+
+#define MASK(bitlen) ((1 << (bitlen)) - 1)
+
+#ifdef alpha_UNIX /* Both GCC and DEC cc seem to have the same */
+#define ALSHIFT 3
+#define ALIGN MASK(ALSHIFT)
+#define UALIGN U64
+
+#define U8 unsigned char
+#define S8 char
+#define U16 unsigned short
+#define S16 short
+#define U32 unsigned int
+#define S32 int
+#define U64 unsigned long
+#define S64 long
+#define UPOINT U64
+#define SPOINT S64
+#define DIRLISTSEP ':'
+#endif /* alpha_UNIX */
+
+#ifdef x86_WIN32
+#define ALSHIFT 2
+#define ALIGN MASK(ALSHIFT)
+#define UALIGN U32
+
+#define U8 unsigned char
+#define S8 char
+#define U16 unsigned short
+#define S16 short
+#define U32 unsigned long
+#define S32 long
+#define UPOINT U32
+#define SPOINT S32
+
+#define DIRLISTSEP ';'
+
+#ifdef _MSVC /* MSVC on x86 */
+#define U64 unsigned __int64
+#define S64 __int64
+#endif /* _MSVC */
+
+#ifdef _GNUCC /* GNU CC on x86 */
+#define U64 unsigned long long
+#define S64 long long
+#endif /* _GNUCC */
+
+#endif /* x86_WIN32 */
+
+#ifdef x86_LINUX
+#define ALSHIFT 2
+#define ALIGN MASK(ALSHIFT)
+#define UALIGN U32
+
+#define U8 unsigned char
+#define S8 char
+#define U16 unsigned short
+#define S16 short
+#define U32 unsigned long
+#define S32 long
+#define UPOINT U32
+#define SPOINT S32
+#define U64 unsigned long long
+#define S64 long long
+#define DIRLISTSEP ':'
+#endif /* x86_WIN32 */
+
+extern void exit(int);
+
+#ifdef _DEBUG
+#define _ASSERT(be) {if(!(be)){fprintf(stderr,"Assertion failed on line %d in file %s\n", __LINE__, __FILE__);exit(2);}}
+#else
+#define _ASSERT(be)
+#endif
+
+#define ERR_SET
+#define ERR_CHECK(v,stop,prg)
+#define EXIT(v, n) exit(n)
+
+#define ERRLINE {fprintf(stderr, "Error at %s(%d):",__FILE__,__LINE__);\
+ ERR_SET;}
+#define WARNLINE {fprintf(stderr, "Warning at %s(%d):",__FILE__,__LINE__);}
+
+#define ERROR0(v, txt) {ERRLINE;\
+ fprintf(stderr,txt);EXIT(v,1);}
+#define ERROR1(v, txt, d1) {ERRLINE;\
+ fprintf(stderr,txt, d1);EXIT(v,1);}
+
+typedef long clock_t;
+ clock_t __cdecl clock(void);
+ int __cdecl rand(void);
+#ifdef _MSVC
+# define CLOCKS_PER_SEC 1000
+#else
+# define CLOCKS_PER_SEC 1000000
+#endif
+
+#define TIMESTART(clk) {clk=(double)clock();}
+#define TIMESTOP(clk) {clk=1000000.0 * ((double)clock()-(clk))/CLOCKS_PER_SEC;}
+
+
+extern int debugMM;
+
+#define SETDBGOUT int _stdout; fflush(stdout);_stdout=dup(1);dup2(2,1);
+#define RESTOREOUT fflush(stdout); dup2(_stdout, 1); close(_stdout);
+#ifdef _DEBUG
+#define IFDEBUG(txt) {if(debug) {SETDBGOUT; txt; RESTOREOUT;}}
+#else /* _DEBUG */
+#define IFDEBUG(txt) {;}
+#endif /* _DEBUG */
+
+
+extern char* __stackInit;
+extern int __mmId;
+#define STACK_CHECK(category) { char __probe;\
+ long _pDepth = __stackInit - & __probe;\
+ __MM_REPORT("stack", &__probe, _pDepth, category);}
+
+#define STACK_INIT { char __probe;\
+ __stackInit = & __probe; __mmId = 0; }
+
+
+
+#if defined(_DEBUG) || defined(_DEBUGMM)
+#define __MM_REPORT(what, where, size, category) {\
+ if(debugMM) {\
+ SETDBGOUT; \
+ printf("*MM%d: %-6s 0x%08lx %08ld %-20s %s:%d\n", \
+ __mmId ++, \
+ (what), (where), (long)(size), (category),__FILE__,__LINE__);\
+ RESTOREOUT; } \
+ }
+#else
+#define __MM_REPORT(what, where, size, category) { }
+#endif
+
+
+
+
+//#include "redblack.h"
+typedef struct rbNode {
+ struct rbNode * __SAFE left, * __SAFE right, * __SAFE parent;
+ U32 key;
+ U32 color; // To make the data aligned
+ char data[0] __SIZED;
+} RBNode;
+
+extern void * __SAFE calloc_rbnode(unsigned int nrelem, unsigned int size);
+
+/*** KEYS are compared using unsigned comparisons ****/
+
+/* Creates a new RB node. The node has room for some data but nothing is put
+ * in there. The pointer to the data is returned. Start with NULL as an
+ * empty tree */
+char * __FSEQ insertRB(RBNode * * tree, U32 key, int datalen);
+
+
+/* Finds a node. Returns a pointer to the data */
+char * __FSEQ findRB(RBNode * tree, U32 key);
+
+/* Pass freeData=NULL if the data does not contain pointers that need to be
+ * deallocated */
+int freeRB(RBNode * tree, int (* freeData)(U32 key, char * __FSEQ data));
+
+// A non-recursive scanner for RB trees
+#define FORALLRBNODES(tree, donode) {\
+ if(tree) {\
+ DoLeftChildren:\
+ while(tree->left) {\
+ tree = tree->left;\
+ }\
+ DoNode:\
+ /* No left child, or have done all the left descendants*/\
+ donode;\
+ if(tree->right) {\
+ tree = tree->right;\
+ goto DoLeftChildren;\
+ }\
+ /* No right child and we have done all the left descendants*/\
+ while(tree->parent && tree->parent->right == tree)\
+ tree = tree->parent;\
+ if(tree->parent) {\
+ tree = tree->parent;\
+ goto DoNode;\
+ }\
+ }\
+}
+
+/* Some globals that PCC needs */
+int error_level, anerror;
+void myexit(int n) {
+ exit(n);
+}
+#ifdef _MSVC
+#define random rand
+#else
+/* weimer: not needed: extern int random(void); */
+#endif
+int __mmId;
+int debugMM;
+int debug;
+
+
+#define DATASIZE 16 // This is the size of the data that is reserved in
+ // each node
+
+#ifndef ITERS
+ #define ITERS 100000
+#endif
+
+int main() {
+ /* Test hash tables */
+ RBNode *t = NULL;
+ int i;
+ double clk;
+ int count = 0;
+ int sz;
+
+ /* Add and delete random numbers from the hash table */
+ TIMESTART(clk);
+ for(i=0;i<ITERS;i++) {
+ int k = random() & 0x7FFFL;
+ insertRB(& t, k, DATASIZE);
+ }
+ for(i=0;i<ITERS;i++) {
+ int k = random() & 0x7FFFL;
+ void *data = NULL;
+ if(findRB(t, k)) {
+ count ++;
+ }
+ }
+ sz = 0;
+ FORALLRBNODES(t, { sz ++; });
+ freeRB(t, NULL);
+ TIMESTOP(clk);
+ fprintf(stderr, "RBTree has %d elements. Found %d times\n",
+ sz, count);
+ printf("Run rbtest in %8.3lfms\n", clk / 1000.0);
+ exit (0);
+ return 0;
+}
+
+
+// redblack.c
+
+#define Red 0
+#define Black 1
+
+
+static RBNode *leftRotate(RBNode *r) {
+ RBNode *t;
+ _ASSERT(r->right);
+ t = r->right;
+ r->right = t->left; if(t->left) {t->left->parent = r; }
+
+ if(r->parent) {
+ if(r->parent->left == r) {
+ r->parent->left = t;
+ } else {
+ r->parent->right = t;
+ }
+ }
+ t->parent = r->parent;
+ t->left = r; r->parent = t;
+ return t; // like r = t
+}
+
+static RBNode *rightRotate(RBNode *r) {
+ RBNode *t;
+ _ASSERT(r->left);
+ t = r->left;
+ r->left = t->right; if(t->right) { t->right->parent = r; }
+
+ if(r->parent) {
+ if(r->parent->left == r) {
+ r->parent->left = t;
+ } else {
+ r->parent->right = t;
+ }
+ }
+ t->parent = r->parent;
+ t->right = r; r->parent = t;
+ return t;
+}
+
+static RBNode * fixupRB(RBNode *x);
+#ifdef _DEBUG
+/* Check the tree and return the black height */
+static int checkRBTreeRec(RBNode *tree, U32 minKey, U32 maxKey) {
+ int bhl, bhr;
+ if(! tree) return 1;
+ _ASSERT((! tree->left || tree->left->parent == tree) &&
+ (! tree->right || tree->right->parent == tree));
+ _ASSERT(tree->key >= minKey && tree->key <= maxKey);
+ _ASSERT(tree->color == Red || tree->color == Black);
+ _ASSERT(tree->color == Black ||
+ ((!tree->left || tree->left->color == Black) &&
+ (!tree->right || tree->right->color == Black)));
+ bhl = checkRBTreeRec(tree->left, minKey, tree->key);
+ bhr = checkRBTreeRec(tree->right, tree->key + 1, maxKey);
+ _ASSERT(bhl == bhr);
+ return tree->color == Black ? bhl + 1 : bhl;
+}
+
+static int checkRBTree(RBNode *tree) {
+ _ASSERT(tree->color == Black);
+ checkRBTreeRec(tree, 0, (U32)(-1));
+ return 1;
+}
+
+static int printRBIndent(U32 address) {
+ if(address) {
+ printf(" ");
+ printRBIndent(address >> 1);
+ printf("%d", address & 1);
+ }
+ return 1;
+}
+
+static int printRBTree(RBNode *tree, U32 address) {
+ printRBIndent(address);
+ if(tree) {
+ printf(":%s - 0x%08lx\n",
+ tree->color == Red ? "Red " : "Black", tree->key);
+ printRBTree(tree->left, address << 1);
+ printRBTree(tree->right, (address << 1) + 1);
+ } else {
+ printf(":NIL\n");
+ }
+ return 1;
+}
+#endif
+
+char * __FSEQ insertRB(RBNode **tree, U32 key, int datalen) {
+ RBNode *x, *t;
+ x = (RBNode*)malloc(sizeof(RBNode) + datalen);
+ x->left = NULL;
+ x->right = NULL;
+ x->parent = NULL;
+ x->color = Red;
+ x->key = key;
+
+ // Now insert as if it were a simple binary search tree
+ {
+ RBNode **p = tree;
+ RBNode *parent = NULL;
+ while(*p) { /* We have not reached a NIL */
+ parent = *p;
+ if(key <= (*p)->key) {
+ p = & (*p)->left;
+ } else {
+ p = & (*p)->right;
+ }
+ }
+ // Now *p = NIL
+ *p = x; x->parent = parent;
+ }
+ t = fixupRB(x);
+ if(t->parent == NULL) {
+ *tree = t;
+ }
+ _ASSERT(*tree);
+ (*tree)->color = Black;
+ // IFDEBUG(printf("Tree after insert of key=0x%08lx is\n", key);
+ // printRBTree(*tree, 1););
+ IFDEBUG(checkRBTree(*tree));
+ return & x->data[0]; /* Return the allocated node */
+}
+
+
+static RBNode * fixupRB(RBNode *x) {
+ // Now fixup. We know that x is always RED. The root is always Black
+ while(x->parent && x->parent->color == Red) {
+ RBNode *par = x->parent;
+ RBNode *gpar = par->parent;
+ RBNode *uncle;
+ _ASSERT(x->color == Red);
+ _ASSERT(gpar); // the root is always black, so we must have a grand par
+ _ASSERT(gpar->color == Black);
+ if(par == gpar->left) {
+ uncle = gpar->right;
+ if(uncle && uncle->color == Red) {
+ Case1:
+ par->color = Black;
+ uncle->color = Black;
+ gpar->color = Red;
+ x = gpar;
+ continue;
+ } else {
+ _ASSERT(!uncle || uncle->color == Black);
+ if(x == par->right) {
+ uncle = x;
+ leftRotate(par);
+ x = par;
+ par = uncle;
+ }
+ _ASSERT(x == par->left);
+ rightRotate(gpar);
+ par->color = Black;
+ gpar->color = Red;
+ return par;
+ }
+ } else {
+ uncle = gpar->left;
+ _ASSERT(par == gpar->right);
+ if(uncle && uncle->color == Red) {
+ goto Case1;
+ } else {
+ _ASSERT(! uncle || uncle->color == Black);
+ if(x == par->left) {
+ uncle = x;
+ rightRotate(par);
+ x = par;
+ par = uncle;
+ }
+ _ASSERT(x == par->right);
+ leftRotate(gpar);
+ par->color = Black;
+ gpar->color = Red;
+ return par;
+ }
+ }
+ }
+ return x;
+}
+
+char* __FSEQ findRB(RBNode *tree, U32 key) {
+ while(tree) {
+ if(tree->key == key)
+ return & tree->data[0];
+ if(key < tree->key)
+ tree = tree->left;
+ else
+ tree = tree->right;
+ }
+ return NULL;
+}
+
+int freeRB(RBNode *tree, int (*freeData)(U32 key, char * __FSEQ data)) {
+ if(! tree) return 1;
+ freeRB(tree->left, freeData);
+ freeRB(tree->right, freeData);
+ // Now free the node
+ if(freeData) {
+ (*freeData)(tree->key, & tree->data[0]);
+ }
+ free(tree);
+ return 1;
+}
--- /dev/null
+// DO NOT CHANGE THIS LINE
+// Test that read and readv work.
+
+#include <sys/uio.h>
+#include <stdlib.h>
+#include <unistd.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <string.h>
+#include <stdio.h>
+#include <errno.h>
+
+#include <sys/types.h>
+#include <unistd.h>
+
+#define myassert(I) do { \
+ if(!(I)) { \
+ printf("%s:%d **************** assertion failure\n", __FILE__, __LINE__); \
+ abort(); \
+ } \
+} while(0)
+
+# define MSG0 "HI THERE"
+# define MSG1 "BYE NOW!"
+# define TESTFILE "writev_test.tmp"
+
+void delete_file(char *name) {
+ if(!(unlink(TESTFILE)==0)) {
+ if (errno!=ENOENT) perror("error unlinking");
+ }
+ errno = 0;
+ {
+ struct stat s;
+ int statval = stat(TESTFILE, &s);
+ myassert(statval == -1);
+ myassert(errno == ENOENT);
+ }
+}
+
+void test_writev() {
+ int in;
+ int out;
+ int num_written;
+ int num_left;
+ char *buf;
+ const int size = 8;
+ struct iovec iov[2];
+ char *dummy;
+ iov[0].iov_base = "HI THERE";
+ iov[0].iov_len = strlen(iov[0].iov_base);
+ myassert(iov[0].iov_len == size);
+ dummy = "asdfasdf"; // attempt to break string contiguity
+ iov[1].iov_base = "BYE NOW!";
+ iov[1].iov_len = strlen(iov[1].iov_base);
+ myassert(iov[1].iov_len == size);
+
+ // Get rid of the testfile.
+ delete_file(TESTFILE);
+
+ out = open(TESTFILE, O_WRONLY | O_TRUNC | O_CREAT, S_IRUSR | S_IWUSR);
+ if (out==-1) {
+ perror("**** error opening file for writing");
+ abort();
+ }
+
+ // NOTE: we assume that it maximally flushes the buffers.
+ {
+ num_written = writev(out, iov, 2);
+ myassert(num_written = 2 * size);
+ myassert(close(out)==0);
+ }
+ printf("wrote file\n");
+
+ // check it is what we expect.
+ {
+ buf = malloc((2*size+1) * sizeof buf[0]);
+ in = open(TESTFILE, O_RDONLY);
+ myassert(buf!=0);
+ if (in==-1) {
+ perror("**** error opening file for reading");
+ abort();
+ }
+
+ // read
+ printf("trying to read file\n");
+ {
+ num_left = 2*size;
+ while(num_left) {
+ int num_read = read(in, buf+(2*size)-num_left, num_left);
+ num_left -= num_read;
+ }
+ buf[2*size] = '\0';
+ myassert(num_left==0);
+ myassert(close(in)==0);
+ }
+
+ // check it is what we expect.
+ // NOTE: strings literals concatenate at compile time
+ printf("read:%s:\n", buf);
+ myassert(strcmp(buf, MSG0 MSG1)==0);
+ printf("success\n");
+
+ // Get rid of the testfile.
+ delete_file(TESTFILE);
+}
+}
+
+int main() {
+ printf("test writev\n");
+ test_writev();
+ return 0;
+}
--- /dev/null
+
+typedef struct {
+ unsigned long cmap ;
+} Screen ; /*typedef*/
+
+typedef struct _XDisplay Display ; /*typedef*/
+typedef struct {
+ Screen * screens ;
+} * _XPrivDisplay ; /*typedef*/
+
+Display * dpy ;
+unsigned long paper ;
+static int getColor(unsigned long cmap , char * color_name )
+{
+ return 1;
+}
+
+static void loadImage(void )
+{
+ char * thisScene ;
+ paper = getColor((& (((_XPrivDisplay )dpy)->screens)[1])->cmap, thisScene);
+ /*(colorTable[1]).c_color);*/
+
+}
+
+int main () {
+ return 0;
+}
--- /dev/null
+#!/bin/sh
+eval 'exec perl -S ./testcil.pl ${1+"$@"}'
+ if 0;
--- /dev/null
+perl -S testcil.pl %*
--- /dev/null
+// #define PRINT_ALL
+
+extern int retval;
+extern int printf(char*, ...);
+
+void checkOffset(unsigned char * start, unsigned int size,
+ unsigned int expected_start,
+ unsigned int expected_width,
+ char *name) {
+ int bits = 0;
+ unsigned char *p = (unsigned char*)start;
+ unsigned char c;
+
+ // Advance past 0 bytes
+ for(bits = 0; (! *p) && bits < 8 * size; bits += 8)
+ p ++;
+
+ c = *p ++;
+
+ if(bits >= 8 * size) {
+ printf("Cannot find 1 bits in %s\n", name);
+ retval = 1;
+ return;
+ }
+
+ // Find the first bit = 1
+ while(! (c & 1)) {
+ c >>= 1; bits ++;
+ }
+ if(expected_start != bits) {
+ printf("Error: Offset of %s is %d and I thought it was %d\n", name, bits,
+ expected_start);
+ retval = 1;
+ }
+#ifdef PRINT_ALL
+ else {
+ printf("Offset of %s is %d\n", name, expected_start);
+ }
+#endif
+ expected_start = bits;
+
+ // Now find the end
+ while(1) {
+ while(c & 1) { c >>= 1; bits ++; }
+ if((bits & 7) == 0) {
+ if(bits == 8 * size) break;
+ c = * p ++;
+ if(! (c & 1)) break;
+ } else
+ break;
+ }
+ if(bits - expected_start != expected_width) {
+ int i;
+ printf("Error: Width of %s is %d and I thought it was %d.\n", name,
+ bits - expected_start, expected_width);
+ retval = 1;
+ for(i=0;i<size;i++) {
+ printf("[%d] = 0x%02x,", i, start[i]);
+ }
+ printf("\n");
+ }
+
+}
+
+void checkSizeOf(unsigned int size,
+ unsigned int expected, char *name) {
+ if(expected & 7) {
+ printf("Expected %d bits for the length of %s. Should be 8x\n",
+ expected, name);
+ retval = 1;
+ }
+ if(size != expected / 8) {
+ printf("Error: Size of %s is %d and I thought it was %d\n", name,
+ size, expected / 8);
+ retval = 1;
+ }
+#ifdef PRINT_ALL
+ else {
+ printf("Sizeof %s is %d\n", name, expected / 8);
+ }
+#endif
+}
+
+
--- /dev/null
+# A regression tester for CIL
+#
+require 5.000;
+
+
+# Packages to import.
+use Getopt::Long; # Command-line option processing
+use File::Basename; # File name parsing
+use Cwd; # Directory navigation
+use strict;
+# use Data::Dumper;
+use FindBin;
+use lib "$FindBin::Bin/../ocamlutil";
+
+use RegTest;
+
+$ENV{LANG} = 'C';
+
+print "Test infrastructure for CIL\n";
+
+# Create our customized test harness
+my $TEST = CilRegTest->new(AvailParams => { 'RUN' => 1,
+ 'SUCCESS' => 0},
+ LogFile => "cil.log",
+ CommandName => "testcil");
+
+# sm: I want a global name for this $TEST thing, since I find it is merely
+# excess verbiage when adding tests..
+$main::globalTEST = $TEST;
+
+my $inferbox="none";
+
+# am I on win32?
+my $win32 = ($^O eq 'MSWin32' || $^O eq 'cygwin');
+my $unix = !$win32;
+my $solaris = $^O eq 'solaris';
+
+
+# operating modes
+my $gcc = "_GNUCC=1"; # sm: not sure where/why this is needed
+
+
+# am I using egcs?
+my $egcs = $unix && system("gcc -v 2>&1 | grep egcs >/dev/null")==0;
+
+# am I on manju?
+my $manju = $unix && system("hostname | grep manju >/dev/null")==0;
+
+my $make;
+if ($solaris) {
+ $make = "gmake";
+} else {
+ $make = "make";
+}
+
+# We watch the log and we remember in what stage we are (so that we can
+# interpret the error)
+
+# Stages:
+# 1000 - Start (scripts, preprocessors, etc.)
+# 1001 - Parsing
+# 1002 - cabs2cil
+# 1003 - Compilation
+# 1004 - Running
+
+
+my %commonerrors =
+ ("^Parsing " => sub { $_[1]->{instage} = 1001; },
+
+ "^Converting CABS" => sub { $_[1]->{instage} = 1002; },
+
+ "^Linked the cured program" => sub { $_[1]->{instage} = 1008; },
+
+# We are seeing an error from make. Try to classify it based on the stage
+# in which we are
+ "^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): .+)\$"
+ => sub { if(! defined $_[1]->{ErrorMsg}) {
+ $_[1]->{ErrorMsg} = $_[2];} },
+ "^(.+ : error .+)\$" => sub { if(! defined $_[1]->{ErrorMsg}) {
+ $_[1]->{ErrorMsg} = $_[2];} },
+ "^(.+:\\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" =>
+ sub { if(! defined $_[1]->{ErrorMsg}) {
+ $_[1]->{ErrorMsg} = $_[2];} },
+
+
+ "^user\\s+(\\d+)m([\\d.]+)s"
+ => sub { $_[1]->{RUN} = 60 * $_[2] + $_[3]; },
+
+ "^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
+# fields must be fields to be added to the newly created tests
+sub addTest {
+ my($command, %extrafields) = @_;
+
+ my $self = $main::globalTEST;
+ my ($name, $extraargs) =
+ ($command =~ /^(\S+) ?(.*)$/); # name is first word
+
+ my $theargs = $self->testCommandExtras($extraargs);
+
+ my %patterns = %commonerrors;
+ my $kind;
+
+ my $tst =
+ $self->newTest(Name => $name,
+ Dir => ".",
+ Cmd => "$make " . $name . $theargs,
+ Group => [ ],
+ Patterns => \%patterns);
+ # Add the extra fields
+ my $key;
+ foreach $key (keys %extrafields) {
+ $tst->{$key} = $extrafields{$key};
+ }
+ return $tst;
+}
+sub addTestFail {
+ my($command, $failpattern) = @_;
+ addTest($command, MustFail => $failpattern);
+}
+
+
+
+
+sub addBadComment {
+ my($name, $comm) = @_;
+ my $self = $main::globalTEST;
+ $self->addComment($name, $comm);
+ $self->addGroups($name, "bad");
+}
+
+
+
+
+sub addToGroup {
+ my ($name, @groups) = @_;
+ my $self = $main::globalTEST;
+ $self->addGroups($name, @groups);
+}
+
+
+# Start with a few tests that must be run first
+$TEST->newTest(
+ Name => "!inittests0",
+ Dir => "..",
+ Cmd => "$make setup",
+ Group => ['ALWAYS']);
+$TEST->newTest(
+ Name => "!inittests2",
+ Dir => "..",
+ Cmd => "$make setup _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");
+addTest("test/const-struct-init WARNINGS_ARE_ERRORS=1");
+addTest("testrun/warnings-noreturn WARNINGS_ARE_ERRORS=1");
+addTest("testrun/warnings-unused-label WARNINGS_ARE_ERRORS=1");
+addTest("test/warnings-cast WARNINGS_ARE_ERRORS=1");
+addTest("testrun/castincr WARNINGS_ARE_ERRORS=1");
+
+addTest("test/apachebits");
+addTest("testrun/apachebuf");
+
+addTest("testrun/apachefptr");
+addTest("testrun/asm1 _GNUCC=1");
+addTest("test/asm2 _GNUCC=1");
+addTest("test/asm3 _GNUCC=1");
+addTest("test/asm4 _GNUCC=1");
+addTest("testobj/asm5 _GNUCC=1");
+
+addTest("testrun/offsetof");
+addTest("testrun/offsetof1");
+addTest("testrun/offsetof2");
+addTest("testrun/offsetof3");
+addTest("testrun/question");
+addTest("testrun/question2");
+addTest("test/argcast");
+addBadComment("test/argcast",
+ "Fails --check because of mismatched prototypes.");
+addTest("test/array1");
+addTest("test/array2");
+addTest("testrun/array_varsize");
+addTest("testrun/array_formal");
+addTest("testrun/formalscope");
+addTest("test/matrix");
+addTest("runall/switch");
+addTest("testrun/strloop");
+addTest("testrun/strloop3");
+addTest("testrun/percentm");
+addTest("testrun/percent400");
+addTest("testrun/caserange _GNUCC=1");
+addTest("test/attr");
+addTest("test/attr2 _GNUCC=1");
+addTest("test/attr3 _GNUCC=1");
+addTest("testrun/attr4 _GNUCC=1");
+addTest("testrun/attr5_GNUCC=1");
+addTest("test/attr6 _GNUCC=1");
+addTest("test/attr7 _GNUCC=1");
+addTest("test/attr8 _GNUCC=1");
+addTest("test/attr9 _GNUCC=1 WARNINGS_ARE_ERRORS=1");
+addTest("test/attr10 _GNUCC=1");
+addTest("test/attr11 _GNUCC=1");
+addTest("test/attr12 _GNUCC=1");
+addTest("test/attr13 _GNUCC=1");
+addTest("testrun/packed _GNUCC=1 WARNINGS_ARE_ERRORS=1");
+addTest("test/packed2 _GNUCC=1");
+addTest("test/bitfield");
+addTest("testrun/bitfield3");
+
+addTest("testrun/bitfield2");
+addTest("testrun/call2 ");
+addTest("test/cast1");
+addTest("test/cast2");
+addTest("test/cast4 _GNUCC=1");
+addTest("testrun/cast8 ");
+addTest("test/constprop");
+addTest("testrun/const1 _GNUCC=1");
+addTest("testrun/const2 ");
+addTest("testrun/const3 ");
+addTest("testrun/const4 _GNUCC=1");
+addTest("testrun/const5 _GNUCC=1");
+addTest("testrun/const6 ");
+addTest("test/const7 ");
+addTest("testrun/const8 ");
+addTest("test/const9 ");
+addTest("testrun/const10 ");
+addTest("testrun/const11 ");
+addTest("test/deref _GNUCC=1");
+addTest("test_i/empty");
+addTest("test/enum");
+addTest("testrun/enum2");
+addTest("test/func");
+addTest("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",
+ "Cil bug: Cannot parse some strange K&R function definition");
+addTest("test/globals");
+addTest("test/globals2 ");
+addBadComment("test/globals2", "CIL bug: we print array size expressions that refer to variables that haven't been defined yet.");
+addTest("testrun/float");
+addTest("testrun/float2 ");
+addTest("test/huff1");
+addTest("testrun/init");
+addTest("testrun/init1");
+addTest("testrun/init2 _GNUCC=1");
+addTest("testrun/init3 _GNUCC=1");
+addTest("testrun/init4 _GNUCC=1");
+addTest("testrun/init5 _GNUCC=1");
+addTest("testrun/init6 ");
+addTest("test/init8 _GNUCC=1");
+addTest("testrun/init9 _GNUCC=1");
+addTest("testrun/init9 _GNUCC=1");
+addTest("testrun/init10 _GNUCC=1");
+addTest("testrun/init11 _GNUCC=1");
+addTest("testrun/init12 _GNUCC=1");
+addTest("testrun/init13 _GNUCC=1");
+addTest("testrun/init14 _GNUCC=1");
+addTest("testrun/init15 _GNUCC=1");
+addTest("testrun/init16 ");
+addTest("testrun/init17 ");
+addTest("testrun/init18 ");
+addTest("testrun/init19 WARNINGS_ARE_ERRORS=1");
+addTest("testrun/init20 _GNUCC=1");
+addTest("testrun/init21 _GNUCC=1");
+addTest("testrun/init22 ");
+addTest("test/array-size-trick ");
+addTest("testrun/logical ");
+addTest("testrun/cond1 _GNUCC=1");
+addTest("testrun/cond2 _GNUCC=1");
+addTest("testrun/initial _GNUCC=1");
+addTest("testrun/inline1 _GNUCC=1");
+addTest("testrun/inline2 _GNUCC=1");
+addTest("test/inline3 _GNUCC=1");
+addTest("test/decl2 _GNUCC=1");
+addBadComment("test/decl2",
+ "Fails --check because of mismatched prototypes.");
+addTest("test/jmp_buf");
+addTest("test/linux_atomic _GNUCC=1");
+addTest("testrun/linux_signal _GNUCC=1");
+addTest("test/li");
+addTest("test_i/lineno");
+addTest("test/list");
+addTest("testrun/localinit ");
+
+addTest('testrun/longBlock', '');
+addTest("testrun/perror");
+addTest("testrun/perror1");
+addTest("test/pure");
+addTest("testrun/post-assign ");
+addBadComment("testrun/post-assign",
+ "CIL does not have the same evaluation order for ++ as gcc");
+addTest("test/printf ");
+addTest("test/printf_const ");
+addTest("testrun/printf2");
+addTest("test/unimplemented");
+addTest("testrun/vararg1");
+addTest("testrun/vararg2");
+addTest("testrun/vararg3");
+addTest("testrun/vararg4");
+if($win32) {
+ addTest("testrun/vararg11 _MSVC=1");
+}
+addTest("testrun/varargauto1");
+addTest("testrun/vararg5 _GNUCC=1");
+addTest("testrun/vararg6");
+addTest("test/vararg7 _GNUCC=1");
+addTest("testrun/va-arg-1 _GNUCC=1");
+addTest("testrun/va-arg-2 _GNUCC=1");
+addTest("testrun/va-arg-7 _GNUCC=1");
+addTest("test-bad/arrsize ");
+addTest("testrun/comma1 _GNUCC=1");
+addTest("test/retval");
+addTest("testrun/static ");
+addTest("test/static1");
+addTest("testrun/static2 ");
+addTest("test/strcpy");
+addTest("test/struct_init");
+addTest("test/structassign");
+addTest("testrun/align1 _GNUCC=1");
+addTest("testrun/align2 _GNUCC=1 EXTRAARGS=-O2");
+addTest("test/align3 _GNUCC=1");
+addTest("test/tags");
+addTest("test/task _GNUCC=1");
+addTest("test/power1");
+addTest("testrun/scope1");
+addTest("test/scope2");
+addTest("test/scope3");
+addTest("test/scope4");
+addTest("testrun/scope5 _GNUCC=1");
+addTest("testrun/scope6");
+addTest("testrun/scope8");
+addTest("testrun/scope9 ");
+addTest("testrun/scope10 ");
+addTest("testrun/scope11 ");
+addTest("test/voidstar");
+addTest("testrun/memcpy1");
+
+addTest("test/noreturn ");
+
+
+addTest("testrun/label1");
+addTest("testrun/label2");
+addTest("testrun/label3");
+addTest("testrun/label4 _GNUCC=1");
+addTest("test/label5");
+addTest("testrun/wchar1");
+addTest("testrun/wchar2");
+addTest("testrun/wchar3");
+addTest("testrun/wchar4");
+addTest("testrun/wchar5 ");
+addTest("testrun/wchar6");
+addTest("testrun/wchar7");
+addTest("testrun/escapes");
+addTest("test-bad1/wchar-bad ");
+addTest("testrun/addrof3 _GNUCC=1");
+addTest("testrun/lval1 _GNUCC=1");
+addTest("test/bind2 EXTRAARGS=--allowInlineAssembly");
+addToGroup("test/bind2", "slow");
+addTest("testrun/decl1 _GNUCC=1");
+addTest("testrun/addr-array");
+addTest("combine1 ");
+addTest("combine2 ");
+addTest("combine3 ");
+addTest("combine5 ");
+addTest("combine6 ");
+addTest("combine8 ");
+addTestFail("combine9 ", "Incompatible declaration for g");
+addTest("combine10 ");
+addTest("combine11 ");
+addTest("combine12 ");
+addTest("combine13 ");
+addTest("combine14 ");
+addTest("combine15 ");
+addTest("combine16 ");
+addTest("combine17 ");
+addTest("combine18 ");
+addTest("combine20 ");
+addTest("combine21 ");
+addTest("combine22 ");
+addTest("combinealias ");
+addTest("combinelibrik ");
+addTest("combineenum1 ");
+addTest("combineenum2 ");
+addTest("combineenum3 ");
+addTest("combine_init ");
+addTest("combineinline1 ");
+addTest("combineinline2 ");
+addTest("combineinline3 ");
+addTest("combineinline4 ");
+addTest("combineinline6 ");
+addTest("combinestruct1 ");
+addTest("mixedcomb ");
+addTest("testrun/math1 ");
+addTest("test/linuxcombine1_1 ");
+
+addTest("arcombine _GNUCC=1");
+addTest("testrun/funptr1");
+addTest("testrun/typespec1 _GNUCC=1");
+addBadComment("testrun/typespec1",
+ "Must emulate bug in GCC?");
+addTest("testrun/returnvoid ");
+addTest("testrun/returnvoid1 ");
+addTest("testrun/return1 ");
+addTest("testrun/for1 ");
+addTest("testrun/void _GNUCC=1");
+addTest("test/voidtypedef ");
+addTest("testrun/wrongnumargs ");
+addBadComment("testrun/wrongnumargs",
+ "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",
+ "Fails --check because of mismatched prototypes.");
+addTest("test/proto2 ");
+addBadComment("test/proto2",
+ "Bug in parser (precedences)");
+addTest("testrun/struct1 ");
+addTest("testrun/voidarg ");
+addTest("testrun/union2 ");
+addTest("testrun/union3 ");
+addTest("test/union5 ");
+addTest("testrun/inline1 ");
+addTest("runall/extinline ");
+
+addTest("testrun/rmtmps-attr ");
+addBadComment("testrun/rmtmps-attr",
+ "A limitation of our support for attributes");
+
+addTest("testrun/vsp");
+
+addTest("test/cpp-2 ");
+addBadComment("test/cpp-2",
+ "Bug in parser (empty pragmas)");
+addTest("test/cpp-3 _GNUCC=1");
+
+
+
+if($win32) {
+ addTest("testrun/extern_init _MSVC=1");
+ addTest("testrun/msvc2 _MSVC=1");
+ addTest("testrun/msvc3 _MSVC=1");
+ addTest("testrun/msvc4 _MSVC=1");
+ addTest("testrun/msvc6 _MSVC=1");
+ addTest("testrun/msvc7 _MSVC=1");
+ addTest("testrun/msvc8 _MSVC=1");
+ addTest("testrun/msvc9 _MSVC=1");
+
+ addTest("test-bad/try1 _MSVC=1");
+}
+addTest("testrun/msvc1 ");
+addTest("testrun/msvc5 ");
+
+addTest("testrun/extern1 ");
+
+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("testrun/typeof1 ");
+addTest("testrun/semicolon _GNUCC=1");
+
+addTest("merge-ar ");
+
+
+
+addTest("testrun/sizeof1");
+addTest("testrun/sizeof2");
+addTest("runall/sizeof3");
+addTest("test/outofmem ");
+addTest("testrun/builtin ");
+addTest("test/builtin2 ");
+addTest("testrun/builtin3 ");
+addTest("testrun/builtin_choose_expr");
+addTest("testrun/comparisons");
+addTest("testrun/assign");
+
+
+
+
+# self-contained tests of specific things which had problems before
+addTest("scott/multiplestatics");
+addTest("scott/partialbracket");
+addTest("scott/enuminit");
+
+addTest("scott/gimpdouble");
+addTest("scott/struct_cs");
+
+
+addTest("scott-nogcc/bogus_redef");
+addTest("scott/s59");
+addTest("scott/putc $gcc");
+addTest("scott/lexnum");
+addTest("scott/ctype");
+
+
+# function pointers don't work with inferred wildness
+addTest("scott/funcptr");
+
+# transparent unions are a problem for network apps
+addTest("scott/transpunion $gcc");
+addTest("scott/sockaddr $gcc");
+
+# misc...
+addTest("scott/constdecl");
+addTest("scott/oldstyle");
+addTest("scott/typeof $gcc");
+addTest("scott/asmfndecl $gcc");
+addTest("scott/open $gcc");
+addTest("scott/constfold");
+addTest("scott/mode_sizes $gcc"); # mode(__QI__) stuff
+addTest("scott-nolink/brlock $gcc");
+addTest("scott/regparm0 $gcc"); # this works, unfortunately..
+addTest("scott/unscomp"); # kernel/fs/buffer.c
+addTest("scott/thing");
+
+# current problematic test cases
+addTest("mergeinline");
+addTest("scott/uninit_tmp");
+addTest("combine_samefn");
+addTest("combine_node_alloc");
+addTest("combine_sbump");
+addTest("combine_sbumpB");
+addTest("combine_sbumpB MERGEINLINES=1");
+addTest("combine_allocate");
+addTest("combine_allocate MERGEINLINES=1");
+addTest("combine_theFunc");
+addTest("combine_theFunc MERGEINLINES=1");
+addTest("combine_syserr");
+addTest("combine_syserr MERGEINLINES=1");
+addTest("combine_copyptrs WARNINGS_ARE_ERRORS=1");
+addTest("combine_copyptrs WARNINGS_ARE_ERRORS=1 MERGEINLINES=1");
+
+# tests of things implemented for EDG compatibility
+addTest("mergestruct");
+
+# a few things that should fail
+addTest("test-bad/trivial-tb");
+addTest("runall/runall_misc");
+
+
+# simple test of combiner
+addTest("comb $gcc");
+
+# test combiner's ability to detect inconsistency
+addTest("baddef");
+
+
+# does not work: complains of many incompatible type redefinitions
+#runTest $make apache/rewrite
+
+addTest("test/init");
+addTest("test/initial");
+addTest("test/jmp_buf");
+addTest("test/static");
+
+
+# more random stuff
+addTest("scott-nogcc/funcname $gcc");
+addTest("scott/litstruct $gcc");
+addTest("scott/main $gcc");
+addTest("scott/globalprob $gcc");
+addTest("scott/bisonerror $gcc");
+addTest("scott/cmpzero");
+addTest("scott/kernel1 $gcc");
+addTest("scott/kernel2 $gcc");
+addTest("scott/xcheckers $gcc");
+addTest("scott/memberofptr $gcc");
+addTest("scott/invalredef $gcc");
+addTest("scott/invalredef2 $gcc");
+addTest("scott/errorinfn");
+addTest("scott/unionassign");
+addTest("scott/structattr");
+addTest("scott/neg64");
+addTest("testrun/arrayinitsize");
+addTest("test-bad/enuminit2");
+addTest("scott/volatilestruct");
+addTest("scott/sizeofchar");
+addTest("scott/initedextern");
+addTest("scott/arrayinit");
+addTest("runall/structattr2");
+addTest("scott/structattr3");
+addTest("scott/enumerator_sizeof");
+addTest("testrun/decl_mix_stmt");
+addTest("scott/enumattr");
+addTest("runall/alpha");
+
+
+
+# ---------------- 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 &&
+ 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/complex-5', 'execute/complex-2', 'execute/complex-5',
+ 'execute/960512-1', 'execute/complex-4',
+ 'execute/complex-1', 'execute/20010605-2');
+
+ # Also omit those with inner functions
+ push @omit,
+ ('compile/951116-1', 'compile/920415-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/931002-1', 'execute/nestfunc-1', 'execute/20000822-1',
+ 'compile/930506-2', 'execute/20010209-1');
+
+ # Read the compile tests
+ my @tortures;
+ 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/$_";
+ ! grep { $_ =~ m|$t|} @omit } @tortures;
+ foreach my $tst (@tortures) {
+ addTest("tort/$tortdir/$tst _GNUCC=1");
+ $TEST->addGroups("tort/$tortdir/$tst", 'ctorture');
+ }
+ }
+}
+
+
+## We add here a mechanism for adding new tests
+if(defined $ENV{CILEXTRATESTS}) {
+ require $ENV{CILEXTRATESTS};
+}
+
+# print Dumper($TEST);
+
+
+# Now invoke it
+$TEST->doit();
+
+# print Dumper($TEST);
+
+exit(0);
+
+
+###
+###
+###
+### Specialize RegTest
+###
+package CilRegTest;
+
+use strict;
+# use Data::Dumper;
+
+BEGIN {
+ use RegTest;
+ @CilRegTest::ISA = qw(RegTest); # Inherit from RegTest
+}
+
+# The constructor
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = $class->SUPER::new(@_);
+
+ return $self;
+}
+
+# Special command line options
+sub extraOptions {
+ my($self) = @_;
+ my @supopt = $self->SUPER::extraOptions();
+ return (
+ @supopt,
+ "--cildebug!",
+ "--noremake!",
+ );
+}
+
+
+sub extraHelpMessage {
+ my($self) = @_;
+
+ my ($scriptname, $extra) = $self->SUPER::extraHelpMessage();
+ return ("testcil",
+ $extra . << "EOF");
+
+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
+ is running)
+ Default log file is safec.log
+EOF
+}
+
+sub errorHeading {
+ my($self, $err) = @_;
+ return "Not executed" if $err == -1;
+ return "Success" if $err == 0;
+ return "Preprocessor error" if $err == 1000;
+ return "Parse error" if $err == 1001;
+ return "Cabs2cil error" if $err == 1002;
+ return "Compilation error" if $err == 1007;
+ return "Execution error" if $err == 1008;
+ return $self->SUPER::errorHeading($err);
+}
+
+sub startParsingLog {
+ my($self, $tst) = @_;
+ $tst->{instage} = 1000;
+ $tst->{ErrorCode} = 0;
+}
+
+
+sub availableParameters {
+ my($self) = @_;
+ return %::availpars;
+}
+
+
+# given the current options configuration, return a string of
+# additional 'make' arguments to append to test commands
+sub testCommandExtras {
+ my ($self, $extraargs) = @_;
+
+ # (sm: pulled this out of addTests so I could write my own addTests)
+ my $theargs = defined($self->{option}->{cildebug})
+ ? " " : " RELEASE=1 ";
+ $theargs .= " $extraargs ";
+ if(defined $self->{option}->{noremake}) {
+ $theargs .= " NOREMAKE=1";
+ }
+ # Turn on the verbose flag
+ $theargs .= " STATS=1 PRINTSTAGES=1 ";
+ # Turn on the strings
+ # $theargs .= " EXTRAARGS=--useStrings ";
+
+ return $theargs;
+}
+
+
+
+# ensure uniqueness of names (I don't like using these names to
+# name tests.. regrtest used numbers.. oh well)
+sub uniqueName {
+ my ($self, $name) = @_;
+
+ if (!$self->testExists($name)) {
+ return $name; # already unique
+ }
+ else {
+ my $ct = 2;
+ while ($self->testExists($name . $ct)) {
+ $ct++;
+ }
+ return $name . $ct;
+ }
+}
+
+
+1;
--- /dev/null
+#! /bin/sh
+# Attempt to guess a canonical system name.
+# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+# 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
+# Inc.
+
+timestamp='2006-07-02'
+
+# This file is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA
+# 02110-1301, USA.
+#
+# As a special exception to the GNU General Public License, if you
+# distribute this file as part of a program that contains a
+# configuration script generated by Autoconf, you may include it under
+# the same distribution terms that you use for the rest of that program.
+
+
+# Originally written by Per Bothner <per@bothner.com>.
+# Please send patches to <config-patches@gnu.org>. Submit a context
+# diff and a properly formatted ChangeLog entry.
+#
+# This script attempts to guess a canonical system name similar to
+# config.sub. If it succeeds, it prints the system name on stdout, and
+# exits with 0. Otherwise, it exits with 1.
+#
+# The plan is that this can be called by configure scripts if you
+# don't specify an explicit build system type.
+
+me=`echo "$0" | sed -e 's,.*/,,'`
+
+usage="\
+Usage: $0 [OPTION]
+
+Output the configuration name of the system \`$me' is run on.
+
+Operation modes:
+ -h, --help print this help, then exit
+ -t, --time-stamp print date of last modification, then exit
+ -v, --version print version number, then exit
+
+Report bugs and patches to <config-patches@gnu.org>."
+
+version="\
+GNU config.guess ($timestamp)
+
+Originally written by Per Bothner.
+Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005
+Free Software Foundation, Inc.
+
+This is free software; see the source for copying conditions. There is NO
+warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
+
+help="
+Try \`$me --help' for more information."
+
+# Parse command line
+while test $# -gt 0 ; do
+ case $1 in
+ --time-stamp | --time* | -t )
+ echo "$timestamp" ; exit ;;
+ --version | -v )
+ echo "$version" ; exit ;;
+ --help | --h* | -h )
+ echo "$usage"; exit ;;
+ -- ) # Stop option processing
+ shift; break ;;
+ - ) # Use stdin as input.
+ break ;;
+ -* )
+ echo "$me: invalid option $1$help" >&2
+ exit 1 ;;
+ * )
+ break ;;
+ esac
+done
+
+if test $# != 0; then
+ echo "$me: too many arguments$help" >&2
+ exit 1
+fi
+
+trap 'exit 1' 1 2 15
+
+# CC_FOR_BUILD -- compiler used by this script. Note that the use of a
+# compiler to aid in system detection is discouraged as it requires
+# temporary files to be created and, as you can see below, it is a
+# headache to deal with in a portable fashion.
+
+# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still
+# use `HOST_CC' if defined, but it is deprecated.
+
+# Portable tmp directory creation inspired by the Autoconf team.
+
+set_cc_for_build='
+trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ;
+trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ;
+: ${TMPDIR=/tmp} ;
+ { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } ||
+ { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } ||
+ { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } ||
+ { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ;
+dummy=$tmp/dummy ;
+tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ;
+case $CC_FOR_BUILD,$HOST_CC,$CC in
+ ,,) echo "int x;" > $dummy.c ;
+ for c in cc gcc c89 c99 ; do
+ if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then
+ CC_FOR_BUILD="$c"; break ;
+ fi ;
+ done ;
+ if test x"$CC_FOR_BUILD" = x ; then
+ CC_FOR_BUILD=no_compiler_found ;
+ fi
+ ;;
+ ,,*) CC_FOR_BUILD=$CC ;;
+ ,*,*) CC_FOR_BUILD=$HOST_CC ;;
+esac ; set_cc_for_build= ;'
+
+# This is needed to find uname on a Pyramid OSx when run in the BSD universe.
+# (ghazi@noc.rutgers.edu 1994-08-24)
+if (test -f /.attbin/uname) >/dev/null 2>&1 ; then
+ PATH=$PATH:/.attbin ; export PATH
+fi
+
+UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown
+UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown
+UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown
+UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown
+
+# Note: order is significant - the case branches are not exclusive.
+
+case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
+ *:NetBSD:*:*)
+ # NetBSD (nbsd) targets should (where applicable) match one or
+ # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*,
+ # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently
+ # switched to ELF, *-*-netbsd* would select the old
+ # object file format. This provides both forward
+ # compatibility and a consistent mechanism for selecting the
+ # object file format.
+ #
+ # Note: NetBSD doesn't particularly care about the vendor
+ # portion of the name. We always set it to "unknown".
+ sysctl="sysctl -n hw.machine_arch"
+ UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \
+ /usr/sbin/$sysctl 2>/dev/null || echo unknown)`
+ case "${UNAME_MACHINE_ARCH}" in
+ armeb) machine=armeb-unknown ;;
+ arm*) machine=arm-unknown ;;
+ sh3el) machine=shl-unknown ;;
+ sh3eb) machine=sh-unknown ;;
+ *) machine=${UNAME_MACHINE_ARCH}-unknown ;;
+ esac
+ # The Operating System including object format, if it has switched
+ # to ELF recently, or will in the future.
+ case "${UNAME_MACHINE_ARCH}" in
+ arm*|i386|m68k|ns32k|sh3*|sparc|vax)
+ eval $set_cc_for_build
+ if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \
+ | grep __ELF__ >/dev/null
+ then
+ # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout).
+ # Return netbsd for either. FIX?
+ os=netbsd
+ else
+ os=netbsdelf
+ fi
+ ;;
+ *)
+ os=netbsd
+ ;;
+ esac
+ # The OS release
+ # Debian GNU/NetBSD machines have a different userland, and
+ # thus, need a distinct triplet. However, they do not need
+ # kernel version information, so it can be replaced with a
+ # suitable tag, in the style of linux-gnu.
+ case "${UNAME_VERSION}" in
+ Debian*)
+ release='-gnu'
+ ;;
+ *)
+ release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'`
+ ;;
+ esac
+ # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM:
+ # contains redundant information, the shorter form:
+ # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used.
+ echo "${machine}-${os}${release}"
+ exit ;;
+ *:OpenBSD:*:*)
+ UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'`
+ echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE}
+ exit ;;
+ *:ekkoBSD:*:*)
+ echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE}
+ exit ;;
+ *:SolidBSD:*:*)
+ echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE}
+ exit ;;
+ macppc:MirBSD:*:*)
+ echo powerpc-unknown-mirbsd${UNAME_RELEASE}
+ exit ;;
+ *:MirBSD:*:*)
+ echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE}
+ exit ;;
+ alpha:OSF1:*:*)
+ case $UNAME_RELEASE in
+ *4.0)
+ UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'`
+ ;;
+ *5.*)
+ UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'`
+ ;;
+ esac
+ # According to Compaq, /usr/sbin/psrinfo has been available on
+ # OSF/1 and Tru64 systems produced since 1995. I hope that
+ # covers most systems running today. This code pipes the CPU
+ # types through head -n 1, so we only detect the type of CPU 0.
+ ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1`
+ case "$ALPHA_CPU_TYPE" in
+ "EV4 (21064)")
+ UNAME_MACHINE="alpha" ;;
+ "EV4.5 (21064)")
+ UNAME_MACHINE="alpha" ;;
+ "LCA4 (21066/21068)")
+ UNAME_MACHINE="alpha" ;;
+ "EV5 (21164)")
+ UNAME_MACHINE="alphaev5" ;;
+ "EV5.6 (21164A)")
+ UNAME_MACHINE="alphaev56" ;;
+ "EV5.6 (21164PC)")
+ UNAME_MACHINE="alphapca56" ;;
+ "EV5.7 (21164PC)")
+ UNAME_MACHINE="alphapca57" ;;
+ "EV6 (21264)")
+ UNAME_MACHINE="alphaev6" ;;
+ "EV6.7 (21264A)")
+ UNAME_MACHINE="alphaev67" ;;
+ "EV6.8CB (21264C)")
+ UNAME_MACHINE="alphaev68" ;;
+ "EV6.8AL (21264B)")
+ UNAME_MACHINE="alphaev68" ;;
+ "EV6.8CX (21264D)")
+ UNAME_MACHINE="alphaev68" ;;
+ "EV6.9A (21264/EV69A)")
+ UNAME_MACHINE="alphaev69" ;;
+ "EV7 (21364)")
+ UNAME_MACHINE="alphaev7" ;;
+ "EV7.9 (21364A)")
+ UNAME_MACHINE="alphaev79" ;;
+ esac
+ # A Pn.n version is a patched version.
+ # A Vn.n version is a released version.
+ # A Tn.n version is a released field test version.
+ # A Xn.n version is an unreleased experimental baselevel.
+ # 1.2 uses "1.2" for uname -r.
+ echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'`
+ exit ;;
+ Alpha\ *:Windows_NT*:*)
+ # How do we know it's Interix rather than the generic POSIX subsystem?
+ # Should we change UNAME_MACHINE based on the output of uname instead
+ # of the specific Alpha model?
+ echo alpha-pc-interix
+ exit ;;
+ 21064:Windows_NT:50:3)
+ echo alpha-dec-winnt3.5
+ exit ;;
+ Amiga*:UNIX_System_V:4.0:*)
+ echo m68k-unknown-sysv4
+ exit ;;
+ *:[Aa]miga[Oo][Ss]:*:*)
+ echo ${UNAME_MACHINE}-unknown-amigaos
+ exit ;;
+ *:[Mm]orph[Oo][Ss]:*:*)
+ echo ${UNAME_MACHINE}-unknown-morphos
+ exit ;;
+ *:OS/390:*:*)
+ echo i370-ibm-openedition
+ exit ;;
+ *:z/VM:*:*)
+ echo s390-ibm-zvmoe
+ exit ;;
+ *:OS400:*:*)
+ echo powerpc-ibm-os400
+ exit ;;
+ arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*)
+ echo arm-acorn-riscix${UNAME_RELEASE}
+ exit ;;
+ arm:riscos:*:*|arm:RISCOS:*:*)
+ echo arm-unknown-riscos
+ exit ;;
+ SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*)
+ echo hppa1.1-hitachi-hiuxmpp
+ exit ;;
+ Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*)
+ # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE.
+ if test "`(/bin/universe) 2>/dev/null`" = att ; then
+ echo pyramid-pyramid-sysv3
+ else
+ echo pyramid-pyramid-bsd
+ fi
+ exit ;;
+ NILE*:*:*:dcosx)
+ echo pyramid-pyramid-svr4
+ exit ;;
+ DRS?6000:unix:4.0:6*)
+ echo sparc-icl-nx6
+ exit ;;
+ DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*)
+ case `/usr/bin/uname -p` in
+ sparc) echo sparc-icl-nx7; exit ;;
+ esac ;;
+ sun4H:SunOS:5.*:*)
+ echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ exit ;;
+ sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*)
+ echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ exit ;;
+ i86pc:SunOS:5.*:*)
+ echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ exit ;;
+ sun4*:SunOS:6*:*)
+ # According to config.sub, this is the proper way to canonicalize
+ # SunOS6. Hard to guess exactly what SunOS6 will be like, but
+ # it's likely to be more like Solaris than SunOS4.
+ echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ exit ;;
+ sun4*:SunOS:*:*)
+ case "`/usr/bin/arch -k`" in
+ Series*|S4*)
+ UNAME_RELEASE=`uname -v`
+ ;;
+ esac
+ # Japanese Language versions have a version number like `4.1.3-JL'.
+ echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'`
+ exit ;;
+ sun3*:SunOS:*:*)
+ echo m68k-sun-sunos${UNAME_RELEASE}
+ exit ;;
+ sun*:*:4.2BSD:*)
+ UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null`
+ test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3
+ case "`/bin/arch`" in
+ sun3)
+ echo m68k-sun-sunos${UNAME_RELEASE}
+ ;;
+ sun4)
+ echo sparc-sun-sunos${UNAME_RELEASE}
+ ;;
+ esac
+ exit ;;
+ aushp:SunOS:*:*)
+ echo sparc-auspex-sunos${UNAME_RELEASE}
+ exit ;;
+ # The situation for MiNT is a little confusing. The machine name
+ # can be virtually everything (everything which is not
+ # "atarist" or "atariste" at least should have a processor
+ # > m68000). The system name ranges from "MiNT" over "FreeMiNT"
+ # to the lowercase version "mint" (or "freemint"). Finally
+ # the system name "TOS" denotes a system which is actually not
+ # MiNT. But MiNT is downward compatible to TOS, so this should
+ # be no problem.
+ atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*)
+ echo m68k-atari-mint${UNAME_RELEASE}
+ exit ;;
+ atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*)
+ echo m68k-atari-mint${UNAME_RELEASE}
+ exit ;;
+ *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*)
+ echo m68k-atari-mint${UNAME_RELEASE}
+ exit ;;
+ milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*)
+ echo m68k-milan-mint${UNAME_RELEASE}
+ exit ;;
+ hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*)
+ echo m68k-hades-mint${UNAME_RELEASE}
+ exit ;;
+ *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*)
+ echo m68k-unknown-mint${UNAME_RELEASE}
+ exit ;;
+ m68k:machten:*:*)
+ echo m68k-apple-machten${UNAME_RELEASE}
+ exit ;;
+ powerpc:machten:*:*)
+ echo powerpc-apple-machten${UNAME_RELEASE}
+ exit ;;
+ RISC*:Mach:*:*)
+ echo mips-dec-mach_bsd4.3
+ exit ;;
+ RISC*:ULTRIX:*:*)
+ echo mips-dec-ultrix${UNAME_RELEASE}
+ exit ;;
+ VAX*:ULTRIX*:*:*)
+ echo vax-dec-ultrix${UNAME_RELEASE}
+ exit ;;
+ 2020:CLIX:*:* | 2430:CLIX:*:*)
+ echo clipper-intergraph-clix${UNAME_RELEASE}
+ exit ;;
+ mips:*:*:UMIPS | mips:*:*:RISCos)
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+#ifdef __cplusplus
+#include <stdio.h> /* for printf() prototype */
+ int main (int argc, char *argv[]) {
+#else
+ int main (argc, argv) int argc; char *argv[]; {
+#endif
+ #if defined (host_mips) && defined (MIPSEB)
+ #if defined (SYSTYPE_SYSV)
+ printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0);
+ #endif
+ #if defined (SYSTYPE_SVR4)
+ printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0);
+ #endif
+ #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD)
+ printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0);
+ #endif
+ #endif
+ exit (-1);
+ }
+EOF
+ $CC_FOR_BUILD -o $dummy $dummy.c &&
+ dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` &&
+ SYSTEM_NAME=`$dummy $dummyarg` &&
+ { echo "$SYSTEM_NAME"; exit; }
+ echo mips-mips-riscos${UNAME_RELEASE}
+ exit ;;
+ Motorola:PowerMAX_OS:*:*)
+ echo powerpc-motorola-powermax
+ exit ;;
+ Motorola:*:4.3:PL8-*)
+ echo powerpc-harris-powermax
+ exit ;;
+ Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*)
+ echo powerpc-harris-powermax
+ exit ;;
+ Night_Hawk:Power_UNIX:*:*)
+ echo powerpc-harris-powerunix
+ exit ;;
+ m88k:CX/UX:7*:*)
+ echo m88k-harris-cxux7
+ exit ;;
+ m88k:*:4*:R4*)
+ echo m88k-motorola-sysv4
+ exit ;;
+ m88k:*:3*:R3*)
+ echo m88k-motorola-sysv3
+ exit ;;
+ AViiON:dgux:*:*)
+ # DG/UX returns AViiON for all architectures
+ UNAME_PROCESSOR=`/usr/bin/uname -p`
+ if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ]
+ then
+ if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \
+ [ ${TARGET_BINARY_INTERFACE}x = x ]
+ then
+ echo m88k-dg-dgux${UNAME_RELEASE}
+ else
+ echo m88k-dg-dguxbcs${UNAME_RELEASE}
+ fi
+ else
+ echo i586-dg-dgux${UNAME_RELEASE}
+ fi
+ exit ;;
+ M88*:DolphinOS:*:*) # DolphinOS (SVR3)
+ echo m88k-dolphin-sysv3
+ exit ;;
+ M88*:*:R3*:*)
+ # Delta 88k system running SVR3
+ echo m88k-motorola-sysv3
+ exit ;;
+ XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3)
+ echo m88k-tektronix-sysv3
+ exit ;;
+ Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD)
+ echo m68k-tektronix-bsd
+ exit ;;
+ *:IRIX*:*:*)
+ echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'`
+ exit ;;
+ ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX.
+ echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id
+ exit ;; # Note that: echo "'`uname -s`'" gives 'AIX '
+ i*86:AIX:*:*)
+ echo i386-ibm-aix
+ exit ;;
+ ia64:AIX:*:*)
+ if [ -x /usr/bin/oslevel ] ; then
+ IBM_REV=`/usr/bin/oslevel`
+ else
+ IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE}
+ fi
+ echo ${UNAME_MACHINE}-ibm-aix${IBM_REV}
+ exit ;;
+ *:AIX:2:3)
+ if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+ #include <sys/systemcfg.h>
+
+ main()
+ {
+ if (!__power_pc())
+ exit(1);
+ puts("powerpc-ibm-aix3.2.5");
+ exit(0);
+ }
+EOF
+ if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy`
+ then
+ echo "$SYSTEM_NAME"
+ else
+ echo rs6000-ibm-aix3.2.5
+ fi
+ elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then
+ echo rs6000-ibm-aix3.2.4
+ else
+ echo rs6000-ibm-aix3.2
+ fi
+ exit ;;
+ *:AIX:*:[45])
+ IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'`
+ if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then
+ IBM_ARCH=rs6000
+ else
+ IBM_ARCH=powerpc
+ fi
+ if [ -x /usr/bin/oslevel ] ; then
+ IBM_REV=`/usr/bin/oslevel`
+ else
+ IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE}
+ fi
+ echo ${IBM_ARCH}-ibm-aix${IBM_REV}
+ exit ;;
+ *:AIX:*:*)
+ echo rs6000-ibm-aix
+ exit ;;
+ ibmrt:4.4BSD:*|romp-ibm:BSD:*)
+ echo romp-ibm-bsd4.4
+ exit ;;
+ ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and
+ echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to
+ exit ;; # report: romp-ibm BSD 4.3
+ *:BOSX:*:*)
+ echo rs6000-bull-bosx
+ exit ;;
+ DPX/2?00:B.O.S.:*:*)
+ echo m68k-bull-sysv3
+ exit ;;
+ 9000/[34]??:4.3bsd:1.*:*)
+ echo m68k-hp-bsd
+ exit ;;
+ hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*)
+ echo m68k-hp-bsd4.4
+ exit ;;
+ 9000/[34678]??:HP-UX:*:*)
+ HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`
+ case "${UNAME_MACHINE}" in
+ 9000/31? ) HP_ARCH=m68000 ;;
+ 9000/[34]?? ) HP_ARCH=m68k ;;
+ 9000/[678][0-9][0-9])
+ if [ -x /usr/bin/getconf ]; then
+ sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null`
+ sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null`
+ case "${sc_cpu_version}" in
+ 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0
+ 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1
+ 532) # CPU_PA_RISC2_0
+ case "${sc_kernel_bits}" in
+ 32) HP_ARCH="hppa2.0n" ;;
+ 64) HP_ARCH="hppa2.0w" ;;
+ '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20
+ esac ;;
+ esac
+ fi
+ if [ "${HP_ARCH}" = "" ]; then
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+
+ #define _HPUX_SOURCE
+ #include <stdlib.h>
+ #include <unistd.h>
+
+ int main ()
+ {
+ #if defined(_SC_KERNEL_BITS)
+ long bits = sysconf(_SC_KERNEL_BITS);
+ #endif
+ long cpu = sysconf (_SC_CPU_VERSION);
+
+ switch (cpu)
+ {
+ case CPU_PA_RISC1_0: puts ("hppa1.0"); break;
+ case CPU_PA_RISC1_1: puts ("hppa1.1"); break;
+ case CPU_PA_RISC2_0:
+ #if defined(_SC_KERNEL_BITS)
+ switch (bits)
+ {
+ case 64: puts ("hppa2.0w"); break;
+ case 32: puts ("hppa2.0n"); break;
+ default: puts ("hppa2.0"); break;
+ } break;
+ #else /* !defined(_SC_KERNEL_BITS) */
+ puts ("hppa2.0"); break;
+ #endif
+ default: puts ("hppa1.0"); break;
+ }
+ exit (0);
+ }
+EOF
+ (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy`
+ test -z "$HP_ARCH" && HP_ARCH=hppa
+ fi ;;
+ esac
+ if [ ${HP_ARCH} = "hppa2.0w" ]
+ then
+ eval $set_cc_for_build
+
+ # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating
+ # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler
+ # generating 64-bit code. GNU and HP use different nomenclature:
+ #
+ # $ CC_FOR_BUILD=cc ./config.guess
+ # => hppa2.0w-hp-hpux11.23
+ # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess
+ # => hppa64-hp-hpux11.23
+
+ if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) |
+ grep __LP64__ >/dev/null
+ then
+ HP_ARCH="hppa2.0w"
+ else
+ HP_ARCH="hppa64"
+ fi
+ fi
+ echo ${HP_ARCH}-hp-hpux${HPUX_REV}
+ exit ;;
+ ia64:HP-UX:*:*)
+ HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`
+ echo ia64-hp-hpux${HPUX_REV}
+ exit ;;
+ 3050*:HI-UX:*:*)
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+ #include <unistd.h>
+ int
+ main ()
+ {
+ long cpu = sysconf (_SC_CPU_VERSION);
+ /* The order matters, because CPU_IS_HP_MC68K erroneously returns
+ true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct
+ results, however. */
+ if (CPU_IS_PA_RISC (cpu))
+ {
+ switch (cpu)
+ {
+ case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break;
+ case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break;
+ case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break;
+ default: puts ("hppa-hitachi-hiuxwe2"); break;
+ }
+ }
+ else if (CPU_IS_HP_MC68K (cpu))
+ puts ("m68k-hitachi-hiuxwe2");
+ else puts ("unknown-hitachi-hiuxwe2");
+ exit (0);
+ }
+EOF
+ $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` &&
+ { echo "$SYSTEM_NAME"; exit; }
+ echo unknown-hitachi-hiuxwe2
+ exit ;;
+ 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* )
+ echo hppa1.1-hp-bsd
+ exit ;;
+ 9000/8??:4.3bsd:*:*)
+ echo hppa1.0-hp-bsd
+ exit ;;
+ *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*)
+ echo hppa1.0-hp-mpeix
+ exit ;;
+ hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* )
+ echo hppa1.1-hp-osf
+ exit ;;
+ hp8??:OSF1:*:*)
+ echo hppa1.0-hp-osf
+ exit ;;
+ i*86:OSF1:*:*)
+ if [ -x /usr/sbin/sysversion ] ; then
+ echo ${UNAME_MACHINE}-unknown-osf1mk
+ else
+ echo ${UNAME_MACHINE}-unknown-osf1
+ fi
+ exit ;;
+ parisc*:Lites*:*:*)
+ echo hppa1.1-hp-lites
+ exit ;;
+ C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*)
+ echo c1-convex-bsd
+ exit ;;
+ C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*)
+ if getsysinfo -f scalar_acc
+ then echo c32-convex-bsd
+ else echo c2-convex-bsd
+ fi
+ exit ;;
+ C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*)
+ echo c34-convex-bsd
+ exit ;;
+ C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*)
+ echo c38-convex-bsd
+ exit ;;
+ C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*)
+ echo c4-convex-bsd
+ exit ;;
+ CRAY*Y-MP:*:*:*)
+ echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+ exit ;;
+ CRAY*[A-Z]90:*:*:*)
+ echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \
+ | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \
+ -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \
+ -e 's/\.[^.]*$/.X/'
+ exit ;;
+ CRAY*TS:*:*:*)
+ echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+ exit ;;
+ CRAY*T3E:*:*:*)
+ echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+ exit ;;
+ CRAY*SV1:*:*:*)
+ echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+ exit ;;
+ *:UNICOS/mp:*:*)
+ echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+ exit ;;
+ F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*)
+ FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'`
+ FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'`
+ FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'`
+ echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
+ exit ;;
+ 5000:UNIX_System_V:4.*:*)
+ FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'`
+ FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'`
+ echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
+ exit ;;
+ i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*)
+ echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE}
+ exit ;;
+ sparc*:BSD/OS:*:*)
+ echo sparc-unknown-bsdi${UNAME_RELEASE}
+ exit ;;
+ *:BSD/OS:*:*)
+ echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE}
+ exit ;;
+ *:FreeBSD:*:*)
+ case ${UNAME_MACHINE} in
+ pc98)
+ echo i386-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;
+ amd64)
+ echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;
+ *)
+ echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;
+ esac
+ exit ;;
+ i*:CYGWIN*:*)
+ echo ${UNAME_MACHINE}-pc-cygwin
+ exit ;;
+ i*:MINGW*:*)
+ echo ${UNAME_MACHINE}-pc-mingw32
+ exit ;;
+ i*:windows32*:*)
+ # uname -m includes "-pc" on this system.
+ echo ${UNAME_MACHINE}-mingw32
+ exit ;;
+ i*:PW*:*)
+ echo ${UNAME_MACHINE}-pc-pw32
+ exit ;;
+ x86:Interix*:[3456]*)
+ echo i586-pc-interix${UNAME_RELEASE}
+ exit ;;
+ EM64T:Interix*:[3456]*)
+ echo x86_64-unknown-interix${UNAME_RELEASE}
+ exit ;;
+ [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*)
+ echo i${UNAME_MACHINE}-pc-mks
+ exit ;;
+ i*:Windows_NT*:* | Pentium*:Windows_NT*:*)
+ # How do we know it's Interix rather than the generic POSIX subsystem?
+ # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we
+ # UNAME_MACHINE based on the output of uname instead of i386?
+ echo i586-pc-interix
+ exit ;;
+ i*:UWIN*:*)
+ echo ${UNAME_MACHINE}-pc-uwin
+ exit ;;
+ amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*)
+ echo x86_64-unknown-cygwin
+ exit ;;
+ p*:CYGWIN*:*)
+ echo powerpcle-unknown-cygwin
+ exit ;;
+ prep*:SunOS:5.*:*)
+ echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ exit ;;
+ *:GNU:*:*)
+ # the GNU system
+ echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'`
+ exit ;;
+ *:GNU/*:*:*)
+ # other systems with GNU libc and userland
+ echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu
+ exit ;;
+ i*86:Minix:*:*)
+ echo ${UNAME_MACHINE}-pc-minix
+ exit ;;
+ arm*:Linux:*:*)
+ echo ${UNAME_MACHINE}-unknown-linux-gnu
+ exit ;;
+ avr32*:Linux:*:*)
+ echo ${UNAME_MACHINE}-unknown-linux-gnu
+ exit ;;
+ cris:Linux:*:*)
+ echo cris-axis-linux-gnu
+ exit ;;
+ crisv32:Linux:*:*)
+ echo crisv32-axis-linux-gnu
+ exit ;;
+ frv:Linux:*:*)
+ echo frv-unknown-linux-gnu
+ exit ;;
+ ia64:Linux:*:*)
+ echo ${UNAME_MACHINE}-unknown-linux-gnu
+ exit ;;
+ m32r*:Linux:*:*)
+ echo ${UNAME_MACHINE}-unknown-linux-gnu
+ exit ;;
+ m68*:Linux:*:*)
+ echo ${UNAME_MACHINE}-unknown-linux-gnu
+ exit ;;
+ mips:Linux:*:*)
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+ #undef CPU
+ #undef mips
+ #undef mipsel
+ #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL)
+ CPU=mipsel
+ #else
+ #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB)
+ CPU=mips
+ #else
+ CPU=
+ #endif
+ #endif
+EOF
+ eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n '
+ /^CPU/{
+ s: ::g
+ p
+ }'`"
+ test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; }
+ ;;
+ mips64:Linux:*:*)
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+ #undef CPU
+ #undef mips64
+ #undef mips64el
+ #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL)
+ CPU=mips64el
+ #else
+ #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB)
+ CPU=mips64
+ #else
+ CPU=
+ #endif
+ #endif
+EOF
+ eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n '
+ /^CPU/{
+ s: ::g
+ p
+ }'`"
+ test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; }
+ ;;
+ or32:Linux:*:*)
+ echo or32-unknown-linux-gnu
+ exit ;;
+ ppc:Linux:*:*)
+ echo powerpc-unknown-linux-gnu
+ exit ;;
+ ppc64:Linux:*:*)
+ echo powerpc64-unknown-linux-gnu
+ exit ;;
+ alpha:Linux:*:*)
+ case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in
+ EV5) UNAME_MACHINE=alphaev5 ;;
+ EV56) UNAME_MACHINE=alphaev56 ;;
+ PCA56) UNAME_MACHINE=alphapca56 ;;
+ PCA57) UNAME_MACHINE=alphapca56 ;;
+ EV6) UNAME_MACHINE=alphaev6 ;;
+ EV67) UNAME_MACHINE=alphaev67 ;;
+ EV68*) UNAME_MACHINE=alphaev68 ;;
+ esac
+ objdump --private-headers /bin/sh | grep ld.so.1 >/dev/null
+ if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi
+ echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC}
+ exit ;;
+ parisc:Linux:*:* | hppa:Linux:*:*)
+ # Look for CPU level
+ case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in
+ PA7*) echo hppa1.1-unknown-linux-gnu ;;
+ PA8*) echo hppa2.0-unknown-linux-gnu ;;
+ *) echo hppa-unknown-linux-gnu ;;
+ esac
+ exit ;;
+ parisc64:Linux:*:* | hppa64:Linux:*:*)
+ echo hppa64-unknown-linux-gnu
+ exit ;;
+ s390:Linux:*:* | s390x:Linux:*:*)
+ echo ${UNAME_MACHINE}-ibm-linux
+ exit ;;
+ sh64*:Linux:*:*)
+ echo ${UNAME_MACHINE}-unknown-linux-gnu
+ exit ;;
+ sh*:Linux:*:*)
+ echo ${UNAME_MACHINE}-unknown-linux-gnu
+ exit ;;
+ sparc:Linux:*:* | sparc64:Linux:*:*)
+ echo ${UNAME_MACHINE}-unknown-linux-gnu
+ exit ;;
+ vax:Linux:*:*)
+ echo ${UNAME_MACHINE}-dec-linux-gnu
+ exit ;;
+ x86_64:Linux:*:*)
+ echo x86_64-unknown-linux-gnu
+ exit ;;
+ i*86:Linux:*:*)
+ # The BFD linker knows what the default object file format is, so
+ # first see if it will tell us. cd to the root directory to prevent
+ # problems with other programs or directories called `ld' in the path.
+ # Set LC_ALL=C to ensure ld outputs messages in English.
+ ld_supported_targets=`cd /; LC_ALL=C ld --help 2>&1 \
+ | sed -ne '/supported targets:/!d
+ s/[ ][ ]*/ /g
+ s/.*supported targets: *//
+ s/ .*//
+ p'`
+ case "$ld_supported_targets" in
+ elf32-i386)
+ TENTATIVE="${UNAME_MACHINE}-pc-linux-gnu"
+ ;;
+ a.out-i386-linux)
+ echo "${UNAME_MACHINE}-pc-linux-gnuaout"
+ exit ;;
+ coff-i386)
+ echo "${UNAME_MACHINE}-pc-linux-gnucoff"
+ exit ;;
+ "")
+ # Either a pre-BFD a.out linker (linux-gnuoldld) or
+ # one that does not give us useful --help.
+ echo "${UNAME_MACHINE}-pc-linux-gnuoldld"
+ exit ;;
+ esac
+ # Determine whether the default compiler is a.out or elf
+ eval $set_cc_for_build
+ sed 's/^ //' << EOF >$dummy.c
+ #include <features.h>
+ #ifdef __ELF__
+ # ifdef __GLIBC__
+ # if __GLIBC__ >= 2
+ LIBC=gnu
+ # else
+ LIBC=gnulibc1
+ # endif
+ # else
+ LIBC=gnulibc1
+ # endif
+ #else
+ #if defined(__INTEL_COMPILER) || defined(__PGI) || defined(__SUNPRO_C) || defined(__SUNPRO_CC)
+ LIBC=gnu
+ #else
+ LIBC=gnuaout
+ #endif
+ #endif
+ #ifdef __dietlibc__
+ LIBC=dietlibc
+ #endif
+EOF
+ eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n '
+ /^LIBC/{
+ s: ::g
+ p
+ }'`"
+ test x"${LIBC}" != x && {
+ echo "${UNAME_MACHINE}-pc-linux-${LIBC}"
+ exit
+ }
+ test x"${TENTATIVE}" != x && { echo "${TENTATIVE}"; exit; }
+ ;;
+ i*86:DYNIX/ptx:4*:*)
+ # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there.
+ # earlier versions are messed up and put the nodename in both
+ # sysname and nodename.
+ echo i386-sequent-sysv4
+ exit ;;
+ i*86:UNIX_SV:4.2MP:2.*)
+ # Unixware is an offshoot of SVR4, but it has its own version
+ # number series starting with 2...
+ # I am not positive that other SVR4 systems won't match this,
+ # I just have to hope. -- rms.
+ # Use sysv4.2uw... so that sysv4* matches it.
+ echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION}
+ exit ;;
+ i*86:OS/2:*:*)
+ # If we were able to find `uname', then EMX Unix compatibility
+ # is probably installed.
+ echo ${UNAME_MACHINE}-pc-os2-emx
+ exit ;;
+ i*86:XTS-300:*:STOP)
+ echo ${UNAME_MACHINE}-unknown-stop
+ exit ;;
+ i*86:atheos:*:*)
+ echo ${UNAME_MACHINE}-unknown-atheos
+ exit ;;
+ i*86:syllable:*:*)
+ echo ${UNAME_MACHINE}-pc-syllable
+ exit ;;
+ i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.0*:*)
+ echo i386-unknown-lynxos${UNAME_RELEASE}
+ exit ;;
+ i*86:*DOS:*:*)
+ echo ${UNAME_MACHINE}-pc-msdosdjgpp
+ exit ;;
+ i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*)
+ UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'`
+ if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then
+ echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL}
+ else
+ echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL}
+ fi
+ exit ;;
+ i*86:*:5:[678]*)
+ # UnixWare 7.x, OpenUNIX and OpenServer 6.
+ case `/bin/uname -X | grep "^Machine"` in
+ *486*) UNAME_MACHINE=i486 ;;
+ *Pentium) UNAME_MACHINE=i586 ;;
+ *Pent*|*Celeron) UNAME_MACHINE=i686 ;;
+ esac
+ echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION}
+ exit ;;
+ i*86:*:3.2:*)
+ if test -f /usr/options/cb.name; then
+ UNAME_REL=`sed -n 's/.*Version //p' </usr/options/cb.name`
+ echo ${UNAME_MACHINE}-pc-isc$UNAME_REL
+ elif /bin/uname -X 2>/dev/null >/dev/null ; then
+ UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')`
+ (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486
+ (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \
+ && UNAME_MACHINE=i586
+ (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \
+ && UNAME_MACHINE=i686
+ (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \
+ && UNAME_MACHINE=i686
+ echo ${UNAME_MACHINE}-pc-sco$UNAME_REL
+ else
+ echo ${UNAME_MACHINE}-pc-sysv32
+ fi
+ exit ;;
+ pc:*:*:*)
+ # Left here for compatibility:
+ # uname -m prints for DJGPP always 'pc', but it prints nothing about
+ # the processor, so we play safe by assuming i386.
+ echo i386-pc-msdosdjgpp
+ exit ;;
+ Intel:Mach:3*:*)
+ echo i386-pc-mach3
+ exit ;;
+ paragon:*:*:*)
+ echo i860-intel-osf1
+ exit ;;
+ i860:*:4.*:*) # i860-SVR4
+ if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then
+ echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4
+ else # Add other i860-SVR4 vendors below as they are discovered.
+ echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4
+ fi
+ exit ;;
+ mini*:CTIX:SYS*5:*)
+ # "miniframe"
+ echo m68010-convergent-sysv
+ exit ;;
+ mc68k:UNIX:SYSTEM5:3.51m)
+ echo m68k-convergent-sysv
+ exit ;;
+ M680?0:D-NIX:5.3:*)
+ echo m68k-diab-dnix
+ exit ;;
+ M68*:*:R3V[5678]*:*)
+ test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;;
+ 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0)
+ OS_REL=''
+ test -r /etc/.relid \
+ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid`
+ /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
+ && { echo i486-ncr-sysv4.3${OS_REL}; exit; }
+ /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \
+ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;;
+ 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*)
+ /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
+ && { echo i486-ncr-sysv4; exit; } ;;
+ m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*)
+ echo m68k-unknown-lynxos${UNAME_RELEASE}
+ exit ;;
+ mc68030:UNIX_System_V:4.*:*)
+ echo m68k-atari-sysv4
+ exit ;;
+ TSUNAMI:LynxOS:2.*:*)
+ echo sparc-unknown-lynxos${UNAME_RELEASE}
+ exit ;;
+ rs6000:LynxOS:2.*:*)
+ echo rs6000-unknown-lynxos${UNAME_RELEASE}
+ exit ;;
+ PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.0*:*)
+ echo powerpc-unknown-lynxos${UNAME_RELEASE}
+ exit ;;
+ SM[BE]S:UNIX_SV:*:*)
+ echo mips-dde-sysv${UNAME_RELEASE}
+ exit ;;
+ RM*:ReliantUNIX-*:*:*)
+ echo mips-sni-sysv4
+ exit ;;
+ RM*:SINIX-*:*:*)
+ echo mips-sni-sysv4
+ exit ;;
+ *:SINIX-*:*:*)
+ if uname -p 2>/dev/null >/dev/null ; then
+ UNAME_MACHINE=`(uname -p) 2>/dev/null`
+ echo ${UNAME_MACHINE}-sni-sysv4
+ else
+ echo ns32k-sni-sysv
+ fi
+ exit ;;
+ PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort
+ # says <Richard.M.Bartel@ccMail.Census.GOV>
+ echo i586-unisys-sysv4
+ exit ;;
+ *:UNIX_System_V:4*:FTX*)
+ # From Gerald Hewes <hewes@openmarket.com>.
+ # How about differentiating between stratus architectures? -djm
+ echo hppa1.1-stratus-sysv4
+ exit ;;
+ *:*:*:FTX*)
+ # From seanf@swdc.stratus.com.
+ echo i860-stratus-sysv4
+ exit ;;
+ i*86:VOS:*:*)
+ # From Paul.Green@stratus.com.
+ echo ${UNAME_MACHINE}-stratus-vos
+ exit ;;
+ *:VOS:*:*)
+ # From Paul.Green@stratus.com.
+ echo hppa1.1-stratus-vos
+ exit ;;
+ mc68*:A/UX:*:*)
+ echo m68k-apple-aux${UNAME_RELEASE}
+ exit ;;
+ news*:NEWS-OS:6*:*)
+ echo mips-sony-newsos6
+ exit ;;
+ R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*)
+ if [ -d /usr/nec ]; then
+ echo mips-nec-sysv${UNAME_RELEASE}
+ else
+ echo mips-unknown-sysv${UNAME_RELEASE}
+ fi
+ exit ;;
+ BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only.
+ echo powerpc-be-beos
+ exit ;;
+ BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only.
+ echo powerpc-apple-beos
+ exit ;;
+ BePC:BeOS:*:*) # BeOS running on Intel PC compatible.
+ echo i586-pc-beos
+ exit ;;
+ SX-4:SUPER-UX:*:*)
+ echo sx4-nec-superux${UNAME_RELEASE}
+ exit ;;
+ SX-5:SUPER-UX:*:*)
+ echo sx5-nec-superux${UNAME_RELEASE}
+ exit ;;
+ SX-6:SUPER-UX:*:*)
+ echo sx6-nec-superux${UNAME_RELEASE}
+ exit ;;
+ Power*:Rhapsody:*:*)
+ echo powerpc-apple-rhapsody${UNAME_RELEASE}
+ exit ;;
+ *:Rhapsody:*:*)
+ echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE}
+ exit ;;
+ *:Darwin:*:*)
+ UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown
+ case $UNAME_PROCESSOR in
+ unknown) UNAME_PROCESSOR=powerpc ;;
+ esac
+ echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE}
+ exit ;;
+ *:procnto*:*:* | *:QNX:[0123456789]*:*)
+ UNAME_PROCESSOR=`uname -p`
+ if test "$UNAME_PROCESSOR" = "x86"; then
+ UNAME_PROCESSOR=i386
+ UNAME_MACHINE=pc
+ fi
+ echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE}
+ exit ;;
+ *:QNX:*:4*)
+ echo i386-pc-qnx
+ exit ;;
+ NSE-?:NONSTOP_KERNEL:*:*)
+ echo nse-tandem-nsk${UNAME_RELEASE}
+ exit ;;
+ NSR-?:NONSTOP_KERNEL:*:*)
+ echo nsr-tandem-nsk${UNAME_RELEASE}
+ exit ;;
+ *:NonStop-UX:*:*)
+ echo mips-compaq-nonstopux
+ exit ;;
+ BS2000:POSIX*:*:*)
+ echo bs2000-siemens-sysv
+ exit ;;
+ DS/*:UNIX_System_V:*:*)
+ echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE}
+ exit ;;
+ *:Plan9:*:*)
+ # "uname -m" is not consistent, so use $cputype instead. 386
+ # is converted to i386 for consistency with other x86
+ # operating systems.
+ if test "$cputype" = "386"; then
+ UNAME_MACHINE=i386
+ else
+ UNAME_MACHINE="$cputype"
+ fi
+ echo ${UNAME_MACHINE}-unknown-plan9
+ exit ;;
+ *:TOPS-10:*:*)
+ echo pdp10-unknown-tops10
+ exit ;;
+ *:TENEX:*:*)
+ echo pdp10-unknown-tenex
+ exit ;;
+ KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*)
+ echo pdp10-dec-tops20
+ exit ;;
+ XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*)
+ echo pdp10-xkl-tops20
+ exit ;;
+ *:TOPS-20:*:*)
+ echo pdp10-unknown-tops20
+ exit ;;
+ *:ITS:*:*)
+ echo pdp10-unknown-its
+ exit ;;
+ SEI:*:*:SEIUX)
+ echo mips-sei-seiux${UNAME_RELEASE}
+ exit ;;
+ *:DragonFly:*:*)
+ echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`
+ exit ;;
+ *:*VMS:*:*)
+ UNAME_MACHINE=`(uname -p) 2>/dev/null`
+ case "${UNAME_MACHINE}" in
+ A*) echo alpha-dec-vms ; exit ;;
+ I*) echo ia64-dec-vms ; exit ;;
+ V*) echo vax-dec-vms ; exit ;;
+ esac ;;
+ *:XENIX:*:SysV)
+ echo i386-pc-xenix
+ exit ;;
+ i*86:skyos:*:*)
+ echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//'
+ exit ;;
+ i*86:rdos:*:*)
+ echo ${UNAME_MACHINE}-pc-rdos
+ exit ;;
+esac
+
+#echo '(No uname command or uname output not recognized.)' 1>&2
+#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2
+
+eval $set_cc_for_build
+cat >$dummy.c <<EOF
+#ifdef _SEQUENT_
+# include <sys/types.h>
+# include <sys/utsname.h>
+#endif
+main ()
+{
+#if defined (sony)
+#if defined (MIPSEB)
+ /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed,
+ I don't know.... */
+ printf ("mips-sony-bsd\n"); exit (0);
+#else
+#include <sys/param.h>
+ printf ("m68k-sony-newsos%s\n",
+#ifdef NEWSOS4
+ "4"
+#else
+ ""
+#endif
+ ); exit (0);
+#endif
+#endif
+
+#if defined (__arm) && defined (__acorn) && defined (__unix)
+ printf ("arm-acorn-riscix\n"); exit (0);
+#endif
+
+#if defined (hp300) && !defined (hpux)
+ printf ("m68k-hp-bsd\n"); exit (0);
+#endif
+
+#if defined (NeXT)
+#if !defined (__ARCHITECTURE__)
+#define __ARCHITECTURE__ "m68k"
+#endif
+ int version;
+ version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`;
+ if (version < 4)
+ printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version);
+ else
+ printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version);
+ exit (0);
+#endif
+
+#if defined (MULTIMAX) || defined (n16)
+#if defined (UMAXV)
+ printf ("ns32k-encore-sysv\n"); exit (0);
+#else
+#if defined (CMU)
+ printf ("ns32k-encore-mach\n"); exit (0);
+#else
+ printf ("ns32k-encore-bsd\n"); exit (0);
+#endif
+#endif
+#endif
+
+#if defined (__386BSD__)
+ printf ("i386-pc-bsd\n"); exit (0);
+#endif
+
+#if defined (sequent)
+#if defined (i386)
+ printf ("i386-sequent-dynix\n"); exit (0);
+#endif
+#if defined (ns32000)
+ printf ("ns32k-sequent-dynix\n"); exit (0);
+#endif
+#endif
+
+#if defined (_SEQUENT_)
+ struct utsname un;
+
+ uname(&un);
+
+ if (strncmp(un.version, "V2", 2) == 0) {
+ printf ("i386-sequent-ptx2\n"); exit (0);
+ }
+ if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */
+ printf ("i386-sequent-ptx1\n"); exit (0);
+ }
+ printf ("i386-sequent-ptx\n"); exit (0);
+
+#endif
+
+#if defined (vax)
+# if !defined (ultrix)
+# include <sys/param.h>
+# if defined (BSD)
+# if BSD == 43
+ printf ("vax-dec-bsd4.3\n"); exit (0);
+# else
+# if BSD == 199006
+ printf ("vax-dec-bsd4.3reno\n"); exit (0);
+# else
+ printf ("vax-dec-bsd\n"); exit (0);
+# endif
+# endif
+# else
+ printf ("vax-dec-bsd\n"); exit (0);
+# endif
+# else
+ printf ("vax-dec-ultrix\n"); exit (0);
+# endif
+#endif
+
+#if defined (alliant) && defined (i860)
+ printf ("i860-alliant-bsd\n"); exit (0);
+#endif
+
+ exit (1);
+}
+EOF
+
+$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` &&
+ { echo "$SYSTEM_NAME"; exit; }
+
+# Apollos put the system type in the environment.
+
+test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; }
+
+# Convex versions that predate uname can use getsysinfo(1)
+
+if [ -x /usr/convex/getsysinfo ]
+then
+ case `getsysinfo -f cpu_type` in
+ c1*)
+ echo c1-convex-bsd
+ exit ;;
+ c2*)
+ if getsysinfo -f scalar_acc
+ then echo c32-convex-bsd
+ else echo c2-convex-bsd
+ fi
+ exit ;;
+ c34*)
+ echo c34-convex-bsd
+ exit ;;
+ c38*)
+ echo c38-convex-bsd
+ exit ;;
+ c4*)
+ echo c4-convex-bsd
+ exit ;;
+ esac
+fi
+
+cat >&2 <<EOF
+$0: unable to guess system type
+
+This script, last modified $timestamp, has failed to recognize
+the operating system you are using. It is advised that you
+download the most up to date version of the config scripts from
+
+ http://savannah.gnu.org/cgi-bin/viewcvs/*checkout*/config/config/config.guess
+and
+ http://savannah.gnu.org/cgi-bin/viewcvs/*checkout*/config/config/config.sub
+
+If the version you run ($0) is already up to date, please
+send the following data and any information you think might be
+pertinent to <config-patches@gnu.org> in order to provide the needed
+information to handle your system.
+
+config.guess timestamp = $timestamp
+
+uname -m = `(uname -m) 2>/dev/null || echo unknown`
+uname -r = `(uname -r) 2>/dev/null || echo unknown`
+uname -s = `(uname -s) 2>/dev/null || echo unknown`
+uname -v = `(uname -v) 2>/dev/null || echo unknown`
+
+/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null`
+/bin/uname -X = `(/bin/uname -X) 2>/dev/null`
+
+hostinfo = `(hostinfo) 2>/dev/null`
+/bin/universe = `(/bin/universe) 2>/dev/null`
+/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null`
+/bin/arch = `(/bin/arch) 2>/dev/null`
+/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null`
+/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null`
+
+UNAME_MACHINE = ${UNAME_MACHINE}
+UNAME_RELEASE = ${UNAME_RELEASE}
+UNAME_SYSTEM = ${UNAME_SYSTEM}
+UNAME_VERSION = ${UNAME_VERSION}
+EOF
+
+exit 1
+
+# Local variables:
+# eval: (add-hook 'write-file-hooks 'time-stamp)
+# time-stamp-start: "timestamp='"
+# time-stamp-format: "%:y-%02m-%02d"
+# time-stamp-end: "'"
+# End:
--- /dev/null
+#! /bin/sh
+# Configuration validation subroutine script.
+# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+# 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
+# Inc.
+
+timestamp='2006-07-02'
+
+# This file is (in principle) common to ALL GNU software.
+# The presence of a machine in this file suggests that SOME GNU software
+# can handle that machine. It does not imply ALL GNU software can.
+#
+# This file is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA
+# 02110-1301, USA.
+#
+# As a special exception to the GNU General Public License, if you
+# distribute this file as part of a program that contains a
+# configuration script generated by Autoconf, you may include it under
+# the same distribution terms that you use for the rest of that program.
+
+
+# Please send patches to <config-patches@gnu.org>. Submit a context
+# diff and a properly formatted ChangeLog entry.
+#
+# Configuration subroutine to validate and canonicalize a configuration type.
+# Supply the specified configuration type as an argument.
+# If it is invalid, we print an error message on stderr and exit with code 1.
+# Otherwise, we print the canonical config type on stdout and succeed.
+
+# This file is supposed to be the same for all GNU packages
+# and recognize all the CPU types, system types and aliases
+# that are meaningful with *any* GNU software.
+# Each package is responsible for reporting which valid configurations
+# it does not support. The user should be able to distinguish
+# a failure to support a valid configuration from a meaningless
+# configuration.
+
+# The goal of this file is to map all the various variations of a given
+# machine specification into a single specification in the form:
+# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM
+# or in some cases, the newer four-part form:
+# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM
+# It is wrong to echo any other type of specification.
+
+me=`echo "$0" | sed -e 's,.*/,,'`
+
+usage="\
+Usage: $0 [OPTION] CPU-MFR-OPSYS
+ $0 [OPTION] ALIAS
+
+Canonicalize a configuration name.
+
+Operation modes:
+ -h, --help print this help, then exit
+ -t, --time-stamp print date of last modification, then exit
+ -v, --version print version number, then exit
+
+Report bugs and patches to <config-patches@gnu.org>."
+
+version="\
+GNU config.sub ($timestamp)
+
+Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005
+Free Software Foundation, Inc.
+
+This is free software; see the source for copying conditions. There is NO
+warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
+
+help="
+Try \`$me --help' for more information."
+
+# Parse command line
+while test $# -gt 0 ; do
+ case $1 in
+ --time-stamp | --time* | -t )
+ echo "$timestamp" ; exit ;;
+ --version | -v )
+ echo "$version" ; exit ;;
+ --help | --h* | -h )
+ echo "$usage"; exit ;;
+ -- ) # Stop option processing
+ shift; break ;;
+ - ) # Use stdin as input.
+ break ;;
+ -* )
+ echo "$me: invalid option $1$help"
+ exit 1 ;;
+
+ *local*)
+ # First pass through any local machine types.
+ echo $1
+ exit ;;
+
+ * )
+ break ;;
+ esac
+done
+
+case $# in
+ 0) echo "$me: missing argument$help" >&2
+ exit 1;;
+ 1) ;;
+ *) echo "$me: too many arguments$help" >&2
+ exit 1;;
+esac
+
+# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any).
+# Here we must recognize all the valid KERNEL-OS combinations.
+maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'`
+case $maybe_os in
+ nto-qnx* | linux-gnu* | linux-dietlibc | linux-newlib* | linux-uclibc* | \
+ uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* | \
+ storm-chaos* | os2-emx* | rtmk-nova*)
+ os=-$maybe_os
+ basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`
+ ;;
+ *)
+ basic_machine=`echo $1 | sed 's/-[^-]*$//'`
+ if [ $basic_machine != $1 ]
+ then os=`echo $1 | sed 's/.*-/-/'`
+ else os=; fi
+ ;;
+esac
+
+### Let's recognize common machines as not being operating systems so
+### that things like config.sub decstation-3100 work. We also
+### recognize some manufacturers as not being operating systems, so we
+### can provide default operating systems below.
+case $os in
+ -sun*os*)
+ # Prevent following clause from handling this invalid input.
+ ;;
+ -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \
+ -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \
+ -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \
+ -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\
+ -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \
+ -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \
+ -apple | -axis | -knuth | -cray)
+ os=
+ basic_machine=$1
+ ;;
+ -sim | -cisco | -oki | -wec | -winbond)
+ os=
+ basic_machine=$1
+ ;;
+ -scout)
+ ;;
+ -wrs)
+ os=-vxworks
+ basic_machine=$1
+ ;;
+ -chorusos*)
+ os=-chorusos
+ basic_machine=$1
+ ;;
+ -chorusrdb)
+ os=-chorusrdb
+ basic_machine=$1
+ ;;
+ -hiux*)
+ os=-hiuxwe2
+ ;;
+ -sco6)
+ os=-sco5v6
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -sco5)
+ os=-sco3.2v5
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -sco4)
+ os=-sco3.2v4
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -sco3.2.[4-9]*)
+ os=`echo $os | sed -e 's/sco3.2./sco3.2v/'`
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -sco3.2v[4-9]*)
+ # Don't forget version if it is 3.2v4 or newer.
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -sco5v6*)
+ # Don't forget version if it is 3.2v4 or newer.
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -sco*)
+ os=-sco3.2v2
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -udk*)
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -isc)
+ os=-isc2.2
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -clix*)
+ basic_machine=clipper-intergraph
+ ;;
+ -isc*)
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+ ;;
+ -lynx*)
+ os=-lynxos
+ ;;
+ -ptx*)
+ basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'`
+ ;;
+ -windowsnt*)
+ os=`echo $os | sed -e 's/windowsnt/winnt/'`
+ ;;
+ -psos*)
+ os=-psos
+ ;;
+ -mint | -mint[0-9]*)
+ basic_machine=m68k-atari
+ os=-mint
+ ;;
+esac
+
+# Decode aliases for certain CPU-COMPANY combinations.
+case $basic_machine in
+ # Recognize the basic CPU types without company name.
+ # Some are omitted here because they have special meanings below.
+ 1750a | 580 \
+ | a29k \
+ | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \
+ | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \
+ | am33_2.0 \
+ | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr | avr32 \
+ | bfin \
+ | c4x | clipper \
+ | d10v | d30v | dlx | dsp16xx \
+ | fr30 | frv \
+ | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \
+ | i370 | i860 | i960 | ia64 \
+ | ip2k | iq2000 \
+ | m32c | m32r | m32rle | m68000 | m68k | m88k \
+ | maxq | mb | microblaze | mcore \
+ | mips | mipsbe | mipseb | mipsel | mipsle \
+ | mips16 \
+ | mips64 | mips64el \
+ | mips64vr | mips64vrel \
+ | mips64orion | mips64orionel \
+ | mips64vr4100 | mips64vr4100el \
+ | mips64vr4300 | mips64vr4300el \
+ | mips64vr5000 | mips64vr5000el \
+ | mips64vr5900 | mips64vr5900el \
+ | mipsisa32 | mipsisa32el \
+ | mipsisa32r2 | mipsisa32r2el \
+ | mipsisa64 | mipsisa64el \
+ | mipsisa64r2 | mipsisa64r2el \
+ | mipsisa64sb1 | mipsisa64sb1el \
+ | mipsisa64sr71k | mipsisa64sr71kel \
+ | mipstx39 | mipstx39el \
+ | mn10200 | mn10300 \
+ | mt \
+ | msp430 \
+ | nios | nios2 \
+ | ns16k | ns32k \
+ | or32 \
+ | pdp10 | pdp11 | pj | pjl \
+ | powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \
+ | pyramid \
+ | sh | sh[1234] | sh[24]a | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \
+ | sh64 | sh64le \
+ | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \
+ | sparcv8 | sparcv9 | sparcv9b | sparcv9v \
+ | spu | strongarm \
+ | tahoe | thumb | tic4x | tic80 | tron \
+ | v850 | v850e \
+ | we32k \
+ | x86 | xscale | xscalee[bl] | xstormy16 | xtensa \
+ | z8k)
+ basic_machine=$basic_machine-unknown
+ ;;
+ m6811 | m68hc11 | m6812 | m68hc12)
+ # Motorola 68HC11/12.
+ basic_machine=$basic_machine-unknown
+ os=-none
+ ;;
+ m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k)
+ ;;
+ ms1)
+ basic_machine=mt-unknown
+ ;;
+
+ # We use `pc' rather than `unknown'
+ # because (1) that's what they normally are, and
+ # (2) the word "unknown" tends to confuse beginning users.
+ i*86 | x86_64)
+ basic_machine=$basic_machine-pc
+ ;;
+ # Object if more than one company name word.
+ *-*-*)
+ echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
+ exit 1
+ ;;
+ # Recognize the basic CPU types with company name.
+ 580-* \
+ | a29k-* \
+ | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \
+ | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \
+ | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \
+ | arm-* | armbe-* | armle-* | armeb-* | armv*-* \
+ | avr-* | avr32-* \
+ | bfin-* | bs2000-* \
+ | c[123]* | c30-* | [cjt]90-* | c4x-* | c54x-* | c55x-* | c6x-* \
+ | clipper-* | craynv-* | cydra-* \
+ | d10v-* | d30v-* | dlx-* \
+ | elxsi-* \
+ | f30[01]-* | f700-* | fr30-* | frv-* | fx80-* \
+ | h8300-* | h8500-* \
+ | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \
+ | i*86-* | i860-* | i960-* | ia64-* \
+ | ip2k-* | iq2000-* \
+ | m32c-* | m32r-* | m32rle-* \
+ | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \
+ | m88110-* | m88k-* | maxq-* | mcore-* \
+ | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \
+ | mips16-* \
+ | mips64-* | mips64el-* \
+ | mips64vr-* | mips64vrel-* \
+ | mips64orion-* | mips64orionel-* \
+ | mips64vr4100-* | mips64vr4100el-* \
+ | mips64vr4300-* | mips64vr4300el-* \
+ | mips64vr5000-* | mips64vr5000el-* \
+ | mips64vr5900-* | mips64vr5900el-* \
+ | mipsisa32-* | mipsisa32el-* \
+ | mipsisa32r2-* | mipsisa32r2el-* \
+ | mipsisa64-* | mipsisa64el-* \
+ | mipsisa64r2-* | mipsisa64r2el-* \
+ | mipsisa64sb1-* | mipsisa64sb1el-* \
+ | mipsisa64sr71k-* | mipsisa64sr71kel-* \
+ | mipstx39-* | mipstx39el-* \
+ | mmix-* \
+ | mt-* \
+ | msp430-* \
+ | nios-* | nios2-* \
+ | none-* | np1-* | ns16k-* | ns32k-* \
+ | orion-* \
+ | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \
+ | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \
+ | pyramid-* \
+ | romp-* | rs6000-* \
+ | sh-* | sh[1234]-* | sh[24]a-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \
+ | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \
+ | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \
+ | sparclite-* \
+ | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | strongarm-* | sv1-* | sx?-* \
+ | tahoe-* | thumb-* \
+ | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \
+ | tron-* \
+ | v850-* | v850e-* | vax-* \
+ | we32k-* \
+ | x86-* | x86_64-* | xps100-* | xscale-* | xscalee[bl]-* \
+ | xstormy16-* | xtensa-* \
+ | ymp-* \
+ | z8k-*)
+ ;;
+ # Recognize the various machine names and aliases which stand
+ # for a CPU type and a company and sometimes even an OS.
+ 386bsd)
+ basic_machine=i386-unknown
+ os=-bsd
+ ;;
+ 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc)
+ basic_machine=m68000-att
+ ;;
+ 3b*)
+ basic_machine=we32k-att
+ ;;
+ a29khif)
+ basic_machine=a29k-amd
+ os=-udi
+ ;;
+ abacus)
+ basic_machine=abacus-unknown
+ ;;
+ adobe68k)
+ basic_machine=m68010-adobe
+ os=-scout
+ ;;
+ alliant | fx80)
+ basic_machine=fx80-alliant
+ ;;
+ altos | altos3068)
+ basic_machine=m68k-altos
+ ;;
+ am29k)
+ basic_machine=a29k-none
+ os=-bsd
+ ;;
+ amd64)
+ basic_machine=x86_64-pc
+ ;;
+ amd64-*)
+ basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ amdahl)
+ basic_machine=580-amdahl
+ os=-sysv
+ ;;
+ amiga | amiga-*)
+ basic_machine=m68k-unknown
+ ;;
+ amigaos | amigados)
+ basic_machine=m68k-unknown
+ os=-amigaos
+ ;;
+ amigaunix | amix)
+ basic_machine=m68k-unknown
+ os=-sysv4
+ ;;
+ apollo68)
+ basic_machine=m68k-apollo
+ os=-sysv
+ ;;
+ apollo68bsd)
+ basic_machine=m68k-apollo
+ os=-bsd
+ ;;
+ aux)
+ basic_machine=m68k-apple
+ os=-aux
+ ;;
+ balance)
+ basic_machine=ns32k-sequent
+ os=-dynix
+ ;;
+ c90)
+ basic_machine=c90-cray
+ os=-unicos
+ ;;
+ convex-c1)
+ basic_machine=c1-convex
+ os=-bsd
+ ;;
+ convex-c2)
+ basic_machine=c2-convex
+ os=-bsd
+ ;;
+ convex-c32)
+ basic_machine=c32-convex
+ os=-bsd
+ ;;
+ convex-c34)
+ basic_machine=c34-convex
+ os=-bsd
+ ;;
+ convex-c38)
+ basic_machine=c38-convex
+ os=-bsd
+ ;;
+ cray | j90)
+ basic_machine=j90-cray
+ os=-unicos
+ ;;
+ craynv)
+ basic_machine=craynv-cray
+ os=-unicosmp
+ ;;
+ cr16c)
+ basic_machine=cr16c-unknown
+ os=-elf
+ ;;
+ crds | unos)
+ basic_machine=m68k-crds
+ ;;
+ crisv32 | crisv32-* | etraxfs*)
+ basic_machine=crisv32-axis
+ ;;
+ cris | cris-* | etrax*)
+ basic_machine=cris-axis
+ ;;
+ crx)
+ basic_machine=crx-unknown
+ os=-elf
+ ;;
+ da30 | da30-*)
+ basic_machine=m68k-da30
+ ;;
+ decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn)
+ basic_machine=mips-dec
+ ;;
+ decsystem10* | dec10*)
+ basic_machine=pdp10-dec
+ os=-tops10
+ ;;
+ decsystem20* | dec20*)
+ basic_machine=pdp10-dec
+ os=-tops20
+ ;;
+ delta | 3300 | motorola-3300 | motorola-delta \
+ | 3300-motorola | delta-motorola)
+ basic_machine=m68k-motorola
+ ;;
+ delta88)
+ basic_machine=m88k-motorola
+ os=-sysv3
+ ;;
+ djgpp)
+ basic_machine=i586-pc
+ os=-msdosdjgpp
+ ;;
+ dpx20 | dpx20-*)
+ basic_machine=rs6000-bull
+ os=-bosx
+ ;;
+ dpx2* | dpx2*-bull)
+ basic_machine=m68k-bull
+ os=-sysv3
+ ;;
+ ebmon29k)
+ basic_machine=a29k-amd
+ os=-ebmon
+ ;;
+ elxsi)
+ basic_machine=elxsi-elxsi
+ os=-bsd
+ ;;
+ encore | umax | mmax)
+ basic_machine=ns32k-encore
+ ;;
+ es1800 | OSE68k | ose68k | ose | OSE)
+ basic_machine=m68k-ericsson
+ os=-ose
+ ;;
+ fx2800)
+ basic_machine=i860-alliant
+ ;;
+ genix)
+ basic_machine=ns32k-ns
+ ;;
+ gmicro)
+ basic_machine=tron-gmicro
+ os=-sysv
+ ;;
+ go32)
+ basic_machine=i386-pc
+ os=-go32
+ ;;
+ h3050r* | hiux*)
+ basic_machine=hppa1.1-hitachi
+ os=-hiuxwe2
+ ;;
+ h8300hms)
+ basic_machine=h8300-hitachi
+ os=-hms
+ ;;
+ h8300xray)
+ basic_machine=h8300-hitachi
+ os=-xray
+ ;;
+ h8500hms)
+ basic_machine=h8500-hitachi
+ os=-hms
+ ;;
+ harris)
+ basic_machine=m88k-harris
+ os=-sysv3
+ ;;
+ hp300-*)
+ basic_machine=m68k-hp
+ ;;
+ hp300bsd)
+ basic_machine=m68k-hp
+ os=-bsd
+ ;;
+ hp300hpux)
+ basic_machine=m68k-hp
+ os=-hpux
+ ;;
+ hp3k9[0-9][0-9] | hp9[0-9][0-9])
+ basic_machine=hppa1.0-hp
+ ;;
+ hp9k2[0-9][0-9] | hp9k31[0-9])
+ basic_machine=m68000-hp
+ ;;
+ hp9k3[2-9][0-9])
+ basic_machine=m68k-hp
+ ;;
+ hp9k6[0-9][0-9] | hp6[0-9][0-9])
+ basic_machine=hppa1.0-hp
+ ;;
+ hp9k7[0-79][0-9] | hp7[0-79][0-9])
+ basic_machine=hppa1.1-hp
+ ;;
+ hp9k78[0-9] | hp78[0-9])
+ # FIXME: really hppa2.0-hp
+ basic_machine=hppa1.1-hp
+ ;;
+ hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893)
+ # FIXME: really hppa2.0-hp
+ basic_machine=hppa1.1-hp
+ ;;
+ hp9k8[0-9][13679] | hp8[0-9][13679])
+ basic_machine=hppa1.1-hp
+ ;;
+ hp9k8[0-9][0-9] | hp8[0-9][0-9])
+ basic_machine=hppa1.0-hp
+ ;;
+ hppa-next)
+ os=-nextstep3
+ ;;
+ hppaosf)
+ basic_machine=hppa1.1-hp
+ os=-osf
+ ;;
+ hppro)
+ basic_machine=hppa1.1-hp
+ os=-proelf
+ ;;
+ i370-ibm* | ibm*)
+ basic_machine=i370-ibm
+ ;;
+# I'm not sure what "Sysv32" means. Should this be sysv3.2?
+ i*86v32)
+ basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
+ os=-sysv32
+ ;;
+ i*86v4*)
+ basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
+ os=-sysv4
+ ;;
+ i*86v)
+ basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
+ os=-sysv
+ ;;
+ i*86sol2)
+ basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
+ os=-solaris2
+ ;;
+ i386mach)
+ basic_machine=i386-mach
+ os=-mach
+ ;;
+ i386-vsta | vsta)
+ basic_machine=i386-unknown
+ os=-vsta
+ ;;
+ iris | iris4d)
+ basic_machine=mips-sgi
+ case $os in
+ -irix*)
+ ;;
+ *)
+ os=-irix4
+ ;;
+ esac
+ ;;
+ isi68 | isi)
+ basic_machine=m68k-isi
+ os=-sysv
+ ;;
+ m88k-omron*)
+ basic_machine=m88k-omron
+ ;;
+ magnum | m3230)
+ basic_machine=mips-mips
+ os=-sysv
+ ;;
+ merlin)
+ basic_machine=ns32k-utek
+ os=-sysv
+ ;;
+ mingw32)
+ basic_machine=i386-pc
+ os=-mingw32
+ ;;
+ miniframe)
+ basic_machine=m68000-convergent
+ ;;
+ *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*)
+ basic_machine=m68k-atari
+ os=-mint
+ ;;
+ mips3*-*)
+ basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`
+ ;;
+ mips3*)
+ basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown
+ ;;
+ monitor)
+ basic_machine=m68k-rom68k
+ os=-coff
+ ;;
+ morphos)
+ basic_machine=powerpc-unknown
+ os=-morphos
+ ;;
+ msdos)
+ basic_machine=i386-pc
+ os=-msdos
+ ;;
+ ms1-*)
+ basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'`
+ ;;
+ mvs)
+ basic_machine=i370-ibm
+ os=-mvs
+ ;;
+ ncr3000)
+ basic_machine=i486-ncr
+ os=-sysv4
+ ;;
+ netbsd386)
+ basic_machine=i386-unknown
+ os=-netbsd
+ ;;
+ netwinder)
+ basic_machine=armv4l-rebel
+ os=-linux
+ ;;
+ news | news700 | news800 | news900)
+ basic_machine=m68k-sony
+ os=-newsos
+ ;;
+ news1000)
+ basic_machine=m68030-sony
+ os=-newsos
+ ;;
+ news-3600 | risc-news)
+ basic_machine=mips-sony
+ os=-newsos
+ ;;
+ necv70)
+ basic_machine=v70-nec
+ os=-sysv
+ ;;
+ next | m*-next )
+ basic_machine=m68k-next
+ case $os in
+ -nextstep* )
+ ;;
+ -ns2*)
+ os=-nextstep2
+ ;;
+ *)
+ os=-nextstep3
+ ;;
+ esac
+ ;;
+ nh3000)
+ basic_machine=m68k-harris
+ os=-cxux
+ ;;
+ nh[45]000)
+ basic_machine=m88k-harris
+ os=-cxux
+ ;;
+ nindy960)
+ basic_machine=i960-intel
+ os=-nindy
+ ;;
+ mon960)
+ basic_machine=i960-intel
+ os=-mon960
+ ;;
+ nonstopux)
+ basic_machine=mips-compaq
+ os=-nonstopux
+ ;;
+ np1)
+ basic_machine=np1-gould
+ ;;
+ nsr-tandem)
+ basic_machine=nsr-tandem
+ ;;
+ op50n-* | op60c-*)
+ basic_machine=hppa1.1-oki
+ os=-proelf
+ ;;
+ openrisc | openrisc-*)
+ basic_machine=or32-unknown
+ ;;
+ os400)
+ basic_machine=powerpc-ibm
+ os=-os400
+ ;;
+ OSE68000 | ose68000)
+ basic_machine=m68000-ericsson
+ os=-ose
+ ;;
+ os68k)
+ basic_machine=m68k-none
+ os=-os68k
+ ;;
+ pa-hitachi)
+ basic_machine=hppa1.1-hitachi
+ os=-hiuxwe2
+ ;;
+ paragon)
+ basic_machine=i860-intel
+ os=-osf
+ ;;
+ pbd)
+ basic_machine=sparc-tti
+ ;;
+ pbb)
+ basic_machine=m68k-tti
+ ;;
+ pc532 | pc532-*)
+ basic_machine=ns32k-pc532
+ ;;
+ pc98)
+ basic_machine=i386-pc
+ ;;
+ pc98-*)
+ basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ pentium | p5 | k5 | k6 | nexgen | viac3)
+ basic_machine=i586-pc
+ ;;
+ pentiumpro | p6 | 6x86 | athlon | athlon_*)
+ basic_machine=i686-pc
+ ;;
+ pentiumii | pentium2 | pentiumiii | pentium3)
+ basic_machine=i686-pc
+ ;;
+ pentium4)
+ basic_machine=i786-pc
+ ;;
+ pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*)
+ basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ pentiumpro-* | p6-* | 6x86-* | athlon-*)
+ basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*)
+ basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ pentium4-*)
+ basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ pn)
+ basic_machine=pn-gould
+ ;;
+ power) basic_machine=power-ibm
+ ;;
+ ppc) basic_machine=powerpc-unknown
+ ;;
+ ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ ppcle | powerpclittle | ppc-le | powerpc-little)
+ basic_machine=powerpcle-unknown
+ ;;
+ ppcle-* | powerpclittle-*)
+ basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ ppc64) basic_machine=powerpc64-unknown
+ ;;
+ ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ ppc64le | powerpc64little | ppc64-le | powerpc64-little)
+ basic_machine=powerpc64le-unknown
+ ;;
+ ppc64le-* | powerpc64little-*)
+ basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'`
+ ;;
+ ps2)
+ basic_machine=i386-ibm
+ ;;
+ pw32)
+ basic_machine=i586-unknown
+ os=-pw32
+ ;;
+ rdos)
+ basic_machine=i386-pc
+ os=-rdos
+ ;;
+ rom68k)
+ basic_machine=m68k-rom68k
+ os=-coff
+ ;;
+ rm[46]00)
+ basic_machine=mips-siemens
+ ;;
+ rtpc | rtpc-*)
+ basic_machine=romp-ibm
+ ;;
+ s390 | s390-*)
+ basic_machine=s390-ibm
+ ;;
+ s390x | s390x-*)
+ basic_machine=s390x-ibm
+ ;;
+ sa29200)
+ basic_machine=a29k-amd
+ os=-udi
+ ;;
+ sb1)
+ basic_machine=mipsisa64sb1-unknown
+ ;;
+ sb1el)
+ basic_machine=mipsisa64sb1el-unknown
+ ;;
+ sei)
+ basic_machine=mips-sei
+ os=-seiux
+ ;;
+ sequent)
+ basic_machine=i386-sequent
+ ;;
+ sh)
+ basic_machine=sh-hitachi
+ os=-hms
+ ;;
+ sh64)
+ basic_machine=sh64-unknown
+ ;;
+ sparclite-wrs | simso-wrs)
+ basic_machine=sparclite-wrs
+ os=-vxworks
+ ;;
+ sps7)
+ basic_machine=m68k-bull
+ os=-sysv2
+ ;;
+ spur)
+ basic_machine=spur-unknown
+ ;;
+ st2000)
+ basic_machine=m68k-tandem
+ ;;
+ stratus)
+ basic_machine=i860-stratus
+ os=-sysv4
+ ;;
+ sun2)
+ basic_machine=m68000-sun
+ ;;
+ sun2os3)
+ basic_machine=m68000-sun
+ os=-sunos3
+ ;;
+ sun2os4)
+ basic_machine=m68000-sun
+ os=-sunos4
+ ;;
+ sun3os3)
+ basic_machine=m68k-sun
+ os=-sunos3
+ ;;
+ sun3os4)
+ basic_machine=m68k-sun
+ os=-sunos4
+ ;;
+ sun4os3)
+ basic_machine=sparc-sun
+ os=-sunos3
+ ;;
+ sun4os4)
+ basic_machine=sparc-sun
+ os=-sunos4
+ ;;
+ sun4sol2)
+ basic_machine=sparc-sun
+ os=-solaris2
+ ;;
+ sun3 | sun3-*)
+ basic_machine=m68k-sun
+ ;;
+ sun4)
+ basic_machine=sparc-sun
+ ;;
+ sun386 | sun386i | roadrunner)
+ basic_machine=i386-sun
+ ;;
+ sv1)
+ basic_machine=sv1-cray
+ os=-unicos
+ ;;
+ symmetry)
+ basic_machine=i386-sequent
+ os=-dynix
+ ;;
+ t3e)
+ basic_machine=alphaev5-cray
+ os=-unicos
+ ;;
+ t90)
+ basic_machine=t90-cray
+ os=-unicos
+ ;;
+ tic54x | c54x*)
+ basic_machine=tic54x-unknown
+ os=-coff
+ ;;
+ tic55x | c55x*)
+ basic_machine=tic55x-unknown
+ os=-coff
+ ;;
+ tic6x | c6x*)
+ basic_machine=tic6x-unknown
+ os=-coff
+ ;;
+ tx39)
+ basic_machine=mipstx39-unknown
+ ;;
+ tx39el)
+ basic_machine=mipstx39el-unknown
+ ;;
+ toad1)
+ basic_machine=pdp10-xkl
+ os=-tops20
+ ;;
+ tower | tower-32)
+ basic_machine=m68k-ncr
+ ;;
+ tpf)
+ basic_machine=s390x-ibm
+ os=-tpf
+ ;;
+ udi29k)
+ basic_machine=a29k-amd
+ os=-udi
+ ;;
+ ultra3)
+ basic_machine=a29k-nyu
+ os=-sym1
+ ;;
+ v810 | necv810)
+ basic_machine=v810-nec
+ os=-none
+ ;;
+ vaxv)
+ basic_machine=vax-dec
+ os=-sysv
+ ;;
+ vms)
+ basic_machine=vax-dec
+ os=-vms
+ ;;
+ vpp*|vx|vx-*)
+ basic_machine=f301-fujitsu
+ ;;
+ vxworks960)
+ basic_machine=i960-wrs
+ os=-vxworks
+ ;;
+ vxworks68)
+ basic_machine=m68k-wrs
+ os=-vxworks
+ ;;
+ vxworks29k)
+ basic_machine=a29k-wrs
+ os=-vxworks
+ ;;
+ w65*)
+ basic_machine=w65-wdc
+ os=-none
+ ;;
+ w89k-*)
+ basic_machine=hppa1.1-winbond
+ os=-proelf
+ ;;
+ xbox)
+ basic_machine=i686-pc
+ os=-mingw32
+ ;;
+ xps | xps100)
+ basic_machine=xps100-honeywell
+ ;;
+ ymp)
+ basic_machine=ymp-cray
+ os=-unicos
+ ;;
+ z8k-*-coff)
+ basic_machine=z8k-unknown
+ os=-sim
+ ;;
+ none)
+ basic_machine=none-none
+ os=-none
+ ;;
+
+# Here we handle the default manufacturer of certain CPU types. It is in
+# some cases the only manufacturer, in others, it is the most popular.
+ w89k)
+ basic_machine=hppa1.1-winbond
+ ;;
+ op50n)
+ basic_machine=hppa1.1-oki
+ ;;
+ op60c)
+ basic_machine=hppa1.1-oki
+ ;;
+ romp)
+ basic_machine=romp-ibm
+ ;;
+ mmix)
+ basic_machine=mmix-knuth
+ ;;
+ rs6000)
+ basic_machine=rs6000-ibm
+ ;;
+ vax)
+ basic_machine=vax-dec
+ ;;
+ pdp10)
+ # there are many clones, so DEC is not a safe bet
+ basic_machine=pdp10-unknown
+ ;;
+ pdp11)
+ basic_machine=pdp11-dec
+ ;;
+ we32k)
+ basic_machine=we32k-att
+ ;;
+ sh[1234] | sh[24]a | sh[34]eb | sh[1234]le | sh[23]ele)
+ basic_machine=sh-unknown
+ ;;
+ sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v)
+ basic_machine=sparc-sun
+ ;;
+ cydra)
+ basic_machine=cydra-cydrome
+ ;;
+ orion)
+ basic_machine=orion-highlevel
+ ;;
+ orion105)
+ basic_machine=clipper-highlevel
+ ;;
+ mac | mpw | mac-mpw)
+ basic_machine=m68k-apple
+ ;;
+ pmac | pmac-mpw)
+ basic_machine=powerpc-apple
+ ;;
+ *-unknown)
+ # Make sure to match an already-canonicalized machine name.
+ ;;
+ *)
+ echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
+ exit 1
+ ;;
+esac
+
+# Here we canonicalize certain aliases for manufacturers.
+case $basic_machine in
+ *-digital*)
+ basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'`
+ ;;
+ *-commodore*)
+ basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'`
+ ;;
+ *)
+ ;;
+esac
+
+# Decode manufacturer-specific aliases for certain operating systems.
+
+if [ x"$os" != x"" ]
+then
+case $os in
+ # First match some system type aliases
+ # that might get confused with valid system types.
+ # -solaris* is a basic system type, with this one exception.
+ -solaris1 | -solaris1.*)
+ os=`echo $os | sed -e 's|solaris1|sunos4|'`
+ ;;
+ -solaris)
+ os=-solaris2
+ ;;
+ -svr4*)
+ os=-sysv4
+ ;;
+ -unixware*)
+ os=-sysv4.2uw
+ ;;
+ -gnu/linux*)
+ os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'`
+ ;;
+ # First accept the basic system types.
+ # The portable systems comes first.
+ # Each alternative MUST END IN A *, to match a version number.
+ # -sysv* is not here because it comes later, after sysvr4.
+ -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \
+ | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\
+ | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \
+ | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \
+ | -aos* \
+ | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \
+ | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \
+ | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \
+ | -openbsd* | -solidbsd* \
+ | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \
+ | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \
+ | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \
+ | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \
+ | -chorusos* | -chorusrdb* \
+ | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \
+ | -mingw32* | -linux-gnu* | -linux-newlib* | -linux-uclibc* \
+ | -uxpv* | -beos* | -mpeix* | -udk* \
+ | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \
+ | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \
+ | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \
+ | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \
+ | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \
+ | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \
+ | -skyos* | -haiku* | -rdos* | -toppers*)
+ # Remember, each alternative MUST END IN *, to match a version number.
+ ;;
+ -qnx*)
+ case $basic_machine in
+ x86-* | i*86-*)
+ ;;
+ *)
+ os=-nto$os
+ ;;
+ esac
+ ;;
+ -nto-qnx*)
+ ;;
+ -nto*)
+ os=`echo $os | sed -e 's|nto|nto-qnx|'`
+ ;;
+ -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \
+ | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \
+ | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*)
+ ;;
+ -mac*)
+ os=`echo $os | sed -e 's|mac|macos|'`
+ ;;
+ -linux-dietlibc)
+ os=-linux-dietlibc
+ ;;
+ -linux*)
+ os=`echo $os | sed -e 's|linux|linux-gnu|'`
+ ;;
+ -sunos5*)
+ os=`echo $os | sed -e 's|sunos5|solaris2|'`
+ ;;
+ -sunos6*)
+ os=`echo $os | sed -e 's|sunos6|solaris3|'`
+ ;;
+ -opened*)
+ os=-openedition
+ ;;
+ -os400*)
+ os=-os400
+ ;;
+ -wince*)
+ os=-wince
+ ;;
+ -osfrose*)
+ os=-osfrose
+ ;;
+ -osf*)
+ os=-osf
+ ;;
+ -utek*)
+ os=-bsd
+ ;;
+ -dynix*)
+ os=-bsd
+ ;;
+ -acis*)
+ os=-aos
+ ;;
+ -atheos*)
+ os=-atheos
+ ;;
+ -syllable*)
+ os=-syllable
+ ;;
+ -386bsd)
+ os=-bsd
+ ;;
+ -ctix* | -uts*)
+ os=-sysv
+ ;;
+ -nova*)
+ os=-rtmk-nova
+ ;;
+ -ns2 )
+ os=-nextstep2
+ ;;
+ -nsk*)
+ os=-nsk
+ ;;
+ # Preserve the version number of sinix5.
+ -sinix5.*)
+ os=`echo $os | sed -e 's|sinix|sysv|'`
+ ;;
+ -sinix*)
+ os=-sysv4
+ ;;
+ -tpf*)
+ os=-tpf
+ ;;
+ -triton*)
+ os=-sysv3
+ ;;
+ -oss*)
+ os=-sysv3
+ ;;
+ -svr4)
+ os=-sysv4
+ ;;
+ -svr3)
+ os=-sysv3
+ ;;
+ -sysvr4)
+ os=-sysv4
+ ;;
+ # This must come after -sysvr4.
+ -sysv*)
+ ;;
+ -ose*)
+ os=-ose
+ ;;
+ -es1800*)
+ os=-ose
+ ;;
+ -xenix)
+ os=-xenix
+ ;;
+ -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*)
+ os=-mint
+ ;;
+ -aros*)
+ os=-aros
+ ;;
+ -kaos*)
+ os=-kaos
+ ;;
+ -zvmoe)
+ os=-zvmoe
+ ;;
+ -none)
+ ;;
+ *)
+ # Get rid of the `-' at the beginning of $os.
+ os=`echo $os | sed 's/[^-]*-//'`
+ echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2
+ exit 1
+ ;;
+esac
+else
+
+# Here we handle the default operating systems that come with various machines.
+# The value should be what the vendor currently ships out the door with their
+# machine or put another way, the most popular os provided with the machine.
+
+# Note that if you're going to try to match "-MANUFACTURER" here (say,
+# "-sun"), then you have to tell the case statement up towards the top
+# that MANUFACTURER isn't an operating system. Otherwise, code above
+# will signal an error saying that MANUFACTURER isn't an operating
+# system, and we'll never get to this point.
+
+case $basic_machine in
+ spu-*)
+ os=-elf
+ ;;
+ *-acorn)
+ os=-riscix1.2
+ ;;
+ arm*-rebel)
+ os=-linux
+ ;;
+ arm*-semi)
+ os=-aout
+ ;;
+ c4x-* | tic4x-*)
+ os=-coff
+ ;;
+ # This must come before the *-dec entry.
+ pdp10-*)
+ os=-tops20
+ ;;
+ pdp11-*)
+ os=-none
+ ;;
+ *-dec | vax-*)
+ os=-ultrix4.2
+ ;;
+ m68*-apollo)
+ os=-domain
+ ;;
+ i386-sun)
+ os=-sunos4.0.2
+ ;;
+ m68000-sun)
+ os=-sunos3
+ # This also exists in the configure program, but was not the
+ # default.
+ # os=-sunos4
+ ;;
+ m68*-cisco)
+ os=-aout
+ ;;
+ mips*-cisco)
+ os=-elf
+ ;;
+ mips*-*)
+ os=-elf
+ ;;
+ or32-*)
+ os=-coff
+ ;;
+ *-tti) # must be before sparc entry or we get the wrong os.
+ os=-sysv3
+ ;;
+ sparc-* | *-sun)
+ os=-sunos4.1.1
+ ;;
+ *-be)
+ os=-beos
+ ;;
+ *-haiku)
+ os=-haiku
+ ;;
+ *-ibm)
+ os=-aix
+ ;;
+ *-knuth)
+ os=-mmixware
+ ;;
+ *-wec)
+ os=-proelf
+ ;;
+ *-winbond)
+ os=-proelf
+ ;;
+ *-oki)
+ os=-proelf
+ ;;
+ *-hp)
+ os=-hpux
+ ;;
+ *-hitachi)
+ os=-hiux
+ ;;
+ i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent)
+ os=-sysv
+ ;;
+ *-cbm)
+ os=-amigaos
+ ;;
+ *-dg)
+ os=-dgux
+ ;;
+ *-dolphin)
+ os=-sysv3
+ ;;
+ m68k-ccur)
+ os=-rtu
+ ;;
+ m88k-omron*)
+ os=-luna
+ ;;
+ *-next )
+ os=-nextstep
+ ;;
+ *-sequent)
+ os=-ptx
+ ;;
+ *-crds)
+ os=-unos
+ ;;
+ *-ns)
+ os=-genix
+ ;;
+ i370-*)
+ os=-mvs
+ ;;
+ *-next)
+ os=-nextstep3
+ ;;
+ *-gould)
+ os=-sysv
+ ;;
+ *-highlevel)
+ os=-bsd
+ ;;
+ *-encore)
+ os=-bsd
+ ;;
+ *-sgi)
+ os=-irix
+ ;;
+ *-siemens)
+ os=-sysv4
+ ;;
+ *-masscomp)
+ os=-rtu
+ ;;
+ f30[01]-fujitsu | f700-fujitsu)
+ os=-uxpv
+ ;;
+ *-rom68k)
+ os=-coff
+ ;;
+ *-*bug)
+ os=-coff
+ ;;
+ *-apple)
+ os=-macos
+ ;;
+ *-atari*)
+ os=-mint
+ ;;
+ *)
+ os=-none
+ ;;
+esac
+fi
+
+# Here we handle the case where we know the os, and the CPU type, but not the
+# manufacturer. We pick the logical manufacturer.
+vendor=unknown
+case $basic_machine in
+ *-unknown)
+ case $os in
+ -riscix*)
+ vendor=acorn
+ ;;
+ -sunos*)
+ vendor=sun
+ ;;
+ -aix*)
+ vendor=ibm
+ ;;
+ -beos*)
+ vendor=be
+ ;;
+ -hpux*)
+ vendor=hp
+ ;;
+ -mpeix*)
+ vendor=hp
+ ;;
+ -hiux*)
+ vendor=hitachi
+ ;;
+ -unos*)
+ vendor=crds
+ ;;
+ -dgux*)
+ vendor=dg
+ ;;
+ -luna*)
+ vendor=omron
+ ;;
+ -genix*)
+ vendor=ns
+ ;;
+ -mvs* | -opened*)
+ vendor=ibm
+ ;;
+ -os400*)
+ vendor=ibm
+ ;;
+ -ptx*)
+ vendor=sequent
+ ;;
+ -tpf*)
+ vendor=ibm
+ ;;
+ -vxsim* | -vxworks* | -windiss*)
+ vendor=wrs
+ ;;
+ -aux*)
+ vendor=apple
+ ;;
+ -hms*)
+ vendor=hitachi
+ ;;
+ -mpw* | -macos*)
+ vendor=apple
+ ;;
+ -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*)
+ vendor=atari
+ ;;
+ -vos*)
+ vendor=stratus
+ ;;
+ esac
+ basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"`
+ ;;
+esac
+
+echo $basic_machine$os
+exit
+
+# Local variables:
+# eval: (add-hook 'write-file-hooks 'time-stamp)
+# time-stamp-start: "timestamp='"
+# time-stamp-format: "%:y-%02m-%02d"
+# time-stamp-end: "'"
+# End:
--- /dev/null
+#! /bin/sh
+# Guess values for system-dependent variables and create Makefiles.
+# Generated by GNU Autoconf 2.61.
+#
+# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
+# 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+# This configure script is free software; the Free Software Foundation
+# gives unlimited permission to copy, distribute and modify it.
+## --------------------- ##
+## M4sh Initialization. ##
+## --------------------- ##
+
+# Be more Bourne compatible
+DUALCASE=1; export DUALCASE # for MKS sh
+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
+ emulate sh
+ NULLCMD=:
+ # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
+ # is contrary to our usage. Disable this feature.
+ alias -g '${1+"$@"}'='"$@"'
+ setopt NO_GLOB_SUBST
+else
+ case `(set -o) 2>/dev/null` in
+ *posix*) set -o posix ;;
+esac
+
+fi
+
+
+
+
+# PATH needs CR
+# Avoid depending upon Character Ranges.
+as_cr_letters='abcdefghijklmnopqrstuvwxyz'
+as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
+as_cr_Letters=$as_cr_letters$as_cr_LETTERS
+as_cr_digits='0123456789'
+as_cr_alnum=$as_cr_Letters$as_cr_digits
+
+# The user is always right.
+if test "${PATH_SEPARATOR+set}" != set; then
+ echo "#! /bin/sh" >conf$$.sh
+ echo "exit 0" >>conf$$.sh
+ chmod +x conf$$.sh
+ if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then
+ PATH_SEPARATOR=';'
+ else
+ PATH_SEPARATOR=:
+ fi
+ rm -f conf$$.sh
+fi
+
+# Support unset when possible.
+if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then
+ as_unset=unset
+else
+ as_unset=false
+fi
+
+
+# IFS
+# We need space, tab and new line, in precisely that order. Quoting is
+# there to prevent editors from complaining about space-tab.
+# (If _AS_PATH_WALK were called with IFS unset, it would disable word
+# splitting by setting IFS to empty value.)
+as_nl='
+'
+IFS=" "" $as_nl"
+
+# Find who we are. Look in the path if we contain no directory separator.
+case $0 in
+ *[\\/]* ) as_myself=$0 ;;
+ *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break
+done
+IFS=$as_save_IFS
+
+ ;;
+esac
+# We did not find ourselves, most probably we were run as `sh COMMAND'
+# in which case we are not to be found in the path.
+if test "x$as_myself" = x; then
+ as_myself=$0
+fi
+if test ! -f "$as_myself"; then
+ echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
+ { (exit 1); exit 1; }
+fi
+
+# Work around bugs in pre-3.0 UWIN ksh.
+for as_var in ENV MAIL MAILPATH
+do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var
+done
+PS1='$ '
+PS2='> '
+PS4='+ '
+
+# NLS nuisances.
+for as_var in \
+ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \
+ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \
+ LC_TELEPHONE LC_TIME
+do
+ if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then
+ eval $as_var=C; export $as_var
+ else
+ ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var
+ fi
+done
+
+# Required to use basename.
+if expr a : '\(a\)' >/dev/null 2>&1 &&
+ test "X`expr 00001 : '.*\(...\)'`" = X001; then
+ as_expr=expr
+else
+ as_expr=false
+fi
+
+if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then
+ as_basename=basename
+else
+ as_basename=false
+fi
+
+
+# Name of the executable.
+as_me=`$as_basename -- "$0" ||
+$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
+ X"$0" : 'X\(//\)$' \| \
+ X"$0" : 'X\(/\)' \| . 2>/dev/null ||
+echo X/"$0" |
+ sed '/^.*\/\([^/][^/]*\)\/*$/{
+ s//\1/
+ q
+ }
+ /^X\/\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\/\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+
+# CDPATH.
+$as_unset CDPATH
+
+
+if test "x$CONFIG_SHELL" = x; then
+ if (eval ":") 2>/dev/null; then
+ as_have_required=yes
+else
+ as_have_required=no
+fi
+
+ if test $as_have_required = yes && (eval ":
+(as_func_return () {
+ (exit \$1)
+}
+as_func_success () {
+ as_func_return 0
+}
+as_func_failure () {
+ as_func_return 1
+}
+as_func_ret_success () {
+ return 0
+}
+as_func_ret_failure () {
+ return 1
+}
+
+exitcode=0
+if as_func_success; then
+ :
+else
+ exitcode=1
+ echo as_func_success failed.
+fi
+
+if as_func_failure; then
+ exitcode=1
+ echo as_func_failure succeeded.
+fi
+
+if as_func_ret_success; then
+ :
+else
+ exitcode=1
+ echo as_func_ret_success failed.
+fi
+
+if as_func_ret_failure; then
+ exitcode=1
+ echo as_func_ret_failure succeeded.
+fi
+
+if ( set x; as_func_ret_success y && test x = \"\$1\" ); then
+ :
+else
+ exitcode=1
+ echo positional parameters were not saved.
+fi
+
+test \$exitcode = 0) || { (exit 1); exit 1; }
+
+(
+ as_lineno_1=\$LINENO
+ as_lineno_2=\$LINENO
+ test \"x\$as_lineno_1\" != \"x\$as_lineno_2\" &&
+ test \"x\`expr \$as_lineno_1 + 1\`\" = \"x\$as_lineno_2\") || { (exit 1); exit 1; }
+") 2> /dev/null; then
+ :
+else
+ as_candidate_shells=
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ case $as_dir in
+ /*)
+ for as_base in sh bash ksh sh5; do
+ as_candidate_shells="$as_candidate_shells $as_dir/$as_base"
+ done;;
+ esac
+done
+IFS=$as_save_IFS
+
+
+ for as_shell in $as_candidate_shells $SHELL; do
+ # Try only shells that exist, to save several forks.
+ if { test -f "$as_shell" || test -f "$as_shell.exe"; } &&
+ { ("$as_shell") 2> /dev/null <<\_ASEOF
+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
+ emulate sh
+ NULLCMD=:
+ # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
+ # is contrary to our usage. Disable this feature.
+ alias -g '${1+"$@"}'='"$@"'
+ setopt NO_GLOB_SUBST
+else
+ case `(set -o) 2>/dev/null` in
+ *posix*) set -o posix ;;
+esac
+
+fi
+
+
+:
+_ASEOF
+}; then
+ CONFIG_SHELL=$as_shell
+ as_have_required=yes
+ if { "$as_shell" 2> /dev/null <<\_ASEOF
+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
+ emulate sh
+ NULLCMD=:
+ # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
+ # is contrary to our usage. Disable this feature.
+ alias -g '${1+"$@"}'='"$@"'
+ setopt NO_GLOB_SUBST
+else
+ case `(set -o) 2>/dev/null` in
+ *posix*) set -o posix ;;
+esac
+
+fi
+
+
+:
+(as_func_return () {
+ (exit $1)
+}
+as_func_success () {
+ as_func_return 0
+}
+as_func_failure () {
+ as_func_return 1
+}
+as_func_ret_success () {
+ return 0
+}
+as_func_ret_failure () {
+ return 1
+}
+
+exitcode=0
+if as_func_success; then
+ :
+else
+ exitcode=1
+ echo as_func_success failed.
+fi
+
+if as_func_failure; then
+ exitcode=1
+ echo as_func_failure succeeded.
+fi
+
+if as_func_ret_success; then
+ :
+else
+ exitcode=1
+ echo as_func_ret_success failed.
+fi
+
+if as_func_ret_failure; then
+ exitcode=1
+ echo as_func_ret_failure succeeded.
+fi
+
+if ( set x; as_func_ret_success y && test x = "$1" ); then
+ :
+else
+ exitcode=1
+ echo positional parameters were not saved.
+fi
+
+test $exitcode = 0) || { (exit 1); exit 1; }
+
+(
+ as_lineno_1=$LINENO
+ as_lineno_2=$LINENO
+ test "x$as_lineno_1" != "x$as_lineno_2" &&
+ test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2") || { (exit 1); exit 1; }
+
+_ASEOF
+}; then
+ break
+fi
+
+fi
+
+ done
+
+ if test "x$CONFIG_SHELL" != x; then
+ for as_var in BASH_ENV ENV
+ do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var
+ done
+ export CONFIG_SHELL
+ exec "$CONFIG_SHELL" "$as_myself" ${1+"$@"}
+fi
+
+
+ if test $as_have_required = no; then
+ echo This script requires a shell more modern than all the
+ echo shells that I found on your system. Please install a
+ echo modern shell, or manually run the script under such a
+ echo shell if you do have one.
+ { (exit 1); exit 1; }
+fi
+
+
+fi
+
+fi
+
+
+
+(eval "as_func_return () {
+ (exit \$1)
+}
+as_func_success () {
+ as_func_return 0
+}
+as_func_failure () {
+ as_func_return 1
+}
+as_func_ret_success () {
+ return 0
+}
+as_func_ret_failure () {
+ return 1
+}
+
+exitcode=0
+if as_func_success; then
+ :
+else
+ exitcode=1
+ echo as_func_success failed.
+fi
+
+if as_func_failure; then
+ exitcode=1
+ echo as_func_failure succeeded.
+fi
+
+if as_func_ret_success; then
+ :
+else
+ exitcode=1
+ echo as_func_ret_success failed.
+fi
+
+if as_func_ret_failure; then
+ exitcode=1
+ echo as_func_ret_failure succeeded.
+fi
+
+if ( set x; as_func_ret_success y && test x = \"\$1\" ); then
+ :
+else
+ exitcode=1
+ echo positional parameters were not saved.
+fi
+
+test \$exitcode = 0") || {
+ echo No shell found that supports shell functions.
+ echo Please tell autoconf@gnu.org about your system,
+ echo including any error possibly output before this
+ echo message
+}
+
+
+
+ as_lineno_1=$LINENO
+ as_lineno_2=$LINENO
+ test "x$as_lineno_1" != "x$as_lineno_2" &&
+ test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || {
+
+ # Create $as_me.lineno as a copy of $as_myself, but with $LINENO
+ # uniformly replaced by the line number. The first 'sed' inserts a
+ # line-number line after each line using $LINENO; the second 'sed'
+ # does the real work. The second script uses 'N' to pair each
+ # line-number line with the line containing $LINENO, and appends
+ # trailing '-' during substitution so that $LINENO is not a special
+ # case at line end.
+ # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the
+ # scripts with optimization help from Paolo Bonzini. Blame Lee
+ # E. McMahon (1931-1989) for sed's syntax. :-)
+ sed -n '
+ p
+ /[$]LINENO/=
+ ' <$as_myself |
+ sed '
+ s/[$]LINENO.*/&-/
+ t lineno
+ b
+ :lineno
+ N
+ :loop
+ s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/
+ t loop
+ s/-\n.*//
+ ' >$as_me.lineno &&
+ chmod +x "$as_me.lineno" ||
+ { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2
+ { (exit 1); exit 1; }; }
+
+ # Don't try to exec as it changes $[0], causing all sort of problems
+ # (the dirname of $[0] is not the place where we might find the
+ # original and so on. Autoconf is especially sensitive to this).
+ . "./$as_me.lineno"
+ # Exit status is that of the last command.
+ exit
+}
+
+
+if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then
+ as_dirname=dirname
+else
+ as_dirname=false
+fi
+
+ECHO_C= ECHO_N= ECHO_T=
+case `echo -n x` in
+-n*)
+ case `echo 'x\c'` in
+ *c*) ECHO_T=' ';; # ECHO_T is single tab character.
+ *) ECHO_C='\c';;
+ esac;;
+*)
+ ECHO_N='-n';;
+esac
+
+if expr a : '\(a\)' >/dev/null 2>&1 &&
+ test "X`expr 00001 : '.*\(...\)'`" = X001; then
+ as_expr=expr
+else
+ as_expr=false
+fi
+
+rm -f conf$$ conf$$.exe conf$$.file
+if test -d conf$$.dir; then
+ rm -f conf$$.dir/conf$$.file
+else
+ rm -f conf$$.dir
+ mkdir conf$$.dir
+fi
+echo >conf$$.file
+if ln -s conf$$.file conf$$ 2>/dev/null; then
+ as_ln_s='ln -s'
+ # ... but there are two gotchas:
+ # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.
+ # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.
+ # In both cases, we have to default to `cp -p'.
+ ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
+ as_ln_s='cp -p'
+elif ln conf$$.file conf$$ 2>/dev/null; then
+ as_ln_s=ln
+else
+ as_ln_s='cp -p'
+fi
+rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
+rmdir conf$$.dir 2>/dev/null
+
+if mkdir -p . 2>/dev/null; then
+ as_mkdir_p=:
+else
+ test -d ./-p && rmdir ./-p
+ as_mkdir_p=false
+fi
+
+if test -x / >/dev/null 2>&1; then
+ as_test_x='test -x'
+else
+ if ls -dL / >/dev/null 2>&1; then
+ as_ls_L_option=L
+ else
+ as_ls_L_option=
+ fi
+ as_test_x='
+ eval sh -c '\''
+ if test -d "$1"; then
+ test -d "$1/.";
+ else
+ case $1 in
+ -*)set "./$1";;
+ esac;
+ case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in
+ ???[sx]*):;;*)false;;esac;fi
+ '\'' sh
+ '
+fi
+as_executable_p=$as_test_x
+
+# Sed expression to map a string onto a valid CPP name.
+as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
+
+# Sed expression to map a string onto a valid variable name.
+as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"
+
+
+
+exec 7<&0 </dev/null 6>&1
+
+# Name of the host.
+# hostname on some systems (SVR3.2, Linux) returns a bogus exit status,
+# so uname gets run too.
+ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q`
+
+#
+# Initializations.
+#
+ac_default_prefix=/usr/local
+ac_clean_files=
+ac_config_libobj_dir=.
+LIBOBJS=
+cross_compiling=no
+subdirs=
+MFLAGS=
+MAKEFLAGS=
+SHELL=${CONFIG_SHELL-/bin/sh}
+
+# Identity of this package.
+PACKAGE_NAME=
+PACKAGE_TARNAME=
+PACKAGE_VERSION=
+PACKAGE_STRING=
+PACKAGE_BUGREPORT=
+
+ac_unique_file="src/main.ml"
+ac_subst_vars='SHELL
+PATH_SEPARATOR
+PACKAGE_NAME
+PACKAGE_TARNAME
+PACKAGE_VERSION
+PACKAGE_STRING
+PACKAGE_BUGREPORT
+exec_prefix
+prefix
+program_transform_name
+bindir
+sbindir
+libexecdir
+datarootdir
+datadir
+sysconfdir
+sharedstatedir
+localstatedir
+includedir
+oldincludedir
+docdir
+infodir
+htmldir
+dvidir
+pdfdir
+psdir
+libdir
+localedir
+mandir
+DEFS
+ECHO_C
+ECHO_N
+ECHO_T
+LIBS
+build_alias
+host_alias
+target_alias
+CC
+CFLAGS
+LDFLAGS
+CPPFLAGS
+ac_ct_CC
+EXEEXT
+OBJEXT
+INSTALL_PROGRAM
+INSTALL_SCRIPT
+INSTALL_DATA
+build
+build_cpu
+build_vendor
+build_os
+host
+host_cpu
+host_vendor
+host_os
+target
+target_cpu
+target_vendor
+target_os
+LINUX_DIR
+USE_LINUX
+USE_MINE_OCT
+USE_CVCL
+USE_YICES
+SATURNHOME
+USE_SATURN
+ARCHOS
+DEPUTYHOME
+DEFAULT_CIL_MODE
+DEPUTY_VERSION
+CVCLLIB
+CVCLINC
+OCAMLINC
+LIBOBJS
+LTLIBOBJS'
+ac_subst_files=''
+ ac_precious_vars='build_alias
+host_alias
+target_alias
+CC
+CFLAGS
+LDFLAGS
+LIBS
+CPPFLAGS'
+
+
+# Initialize some variables set by options.
+ac_init_help=
+ac_init_version=false
+# The variables have the same names as the options, with
+# dashes changed to underlines.
+cache_file=/dev/null
+exec_prefix=NONE
+no_create=
+no_recursion=
+prefix=NONE
+program_prefix=NONE
+program_suffix=NONE
+program_transform_name=s,x,x,
+silent=
+site=
+srcdir=
+verbose=
+x_includes=NONE
+x_libraries=NONE
+
+# Installation directory options.
+# These are left unexpanded so users can "make install exec_prefix=/foo"
+# and all the variables that are supposed to be based on exec_prefix
+# by default will actually change.
+# Use braces instead of parens because sh, perl, etc. also accept them.
+# (The list follows the same order as the GNU Coding Standards.)
+bindir='${exec_prefix}/bin'
+sbindir='${exec_prefix}/sbin'
+libexecdir='${exec_prefix}/libexec'
+datarootdir='${prefix}/share'
+datadir='${datarootdir}'
+sysconfdir='${prefix}/etc'
+sharedstatedir='${prefix}/com'
+localstatedir='${prefix}/var'
+includedir='${prefix}/include'
+oldincludedir='/usr/include'
+docdir='${datarootdir}/doc/${PACKAGE}'
+infodir='${datarootdir}/info'
+htmldir='${docdir}'
+dvidir='${docdir}'
+pdfdir='${docdir}'
+psdir='${docdir}'
+libdir='${exec_prefix}/lib'
+localedir='${datarootdir}/locale'
+mandir='${datarootdir}/man'
+
+ac_prev=
+ac_dashdash=
+for ac_option
+do
+ # If the previous option needs an argument, assign it.
+ if test -n "$ac_prev"; then
+ eval $ac_prev=\$ac_option
+ ac_prev=
+ continue
+ fi
+
+ case $ac_option in
+ *=*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;;
+ *) ac_optarg=yes ;;
+ esac
+
+ # Accept the important Cygnus configure options, so we can diagnose typos.
+
+ case $ac_dashdash$ac_option in
+ --)
+ ac_dashdash=yes ;;
+
+ -bindir | --bindir | --bindi | --bind | --bin | --bi)
+ ac_prev=bindir ;;
+ -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)
+ bindir=$ac_optarg ;;
+
+ -build | --build | --buil | --bui | --bu)
+ ac_prev=build_alias ;;
+ -build=* | --build=* | --buil=* | --bui=* | --bu=*)
+ build_alias=$ac_optarg ;;
+
+ -cache-file | --cache-file | --cache-fil | --cache-fi \
+ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c)
+ ac_prev=cache_file ;;
+ -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \
+ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)
+ cache_file=$ac_optarg ;;
+
+ --config-cache | -C)
+ cache_file=config.cache ;;
+
+ -datadir | --datadir | --datadi | --datad)
+ ac_prev=datadir ;;
+ -datadir=* | --datadir=* | --datadi=* | --datad=*)
+ datadir=$ac_optarg ;;
+
+ -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \
+ | --dataroo | --dataro | --datar)
+ ac_prev=datarootdir ;;
+ -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \
+ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*)
+ datarootdir=$ac_optarg ;;
+
+ -disable-* | --disable-*)
+ ac_feature=`expr "x$ac_option" : 'x-*disable-\(.*\)'`
+ # Reject names that are not valid shell variable names.
+ expr "x$ac_feature" : ".*[^-._$as_cr_alnum]" >/dev/null &&
+ { echo "$as_me: error: invalid feature name: $ac_feature" >&2
+ { (exit 1); exit 1; }; }
+ ac_feature=`echo $ac_feature | sed 's/[-.]/_/g'`
+ eval enable_$ac_feature=no ;;
+
+ -docdir | --docdir | --docdi | --doc | --do)
+ ac_prev=docdir ;;
+ -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*)
+ docdir=$ac_optarg ;;
+
+ -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv)
+ ac_prev=dvidir ;;
+ -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*)
+ dvidir=$ac_optarg ;;
+
+ -enable-* | --enable-*)
+ ac_feature=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'`
+ # Reject names that are not valid shell variable names.
+ expr "x$ac_feature" : ".*[^-._$as_cr_alnum]" >/dev/null &&
+ { echo "$as_me: error: invalid feature name: $ac_feature" >&2
+ { (exit 1); exit 1; }; }
+ ac_feature=`echo $ac_feature | sed 's/[-.]/_/g'`
+ eval enable_$ac_feature=\$ac_optarg ;;
+
+ -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \
+ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \
+ | --exec | --exe | --ex)
+ ac_prev=exec_prefix ;;
+ -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \
+ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \
+ | --exec=* | --exe=* | --ex=*)
+ exec_prefix=$ac_optarg ;;
+
+ -gas | --gas | --ga | --g)
+ # Obsolete; use --with-gas.
+ with_gas=yes ;;
+
+ -help | --help | --hel | --he | -h)
+ ac_init_help=long ;;
+ -help=r* | --help=r* | --hel=r* | --he=r* | -hr*)
+ ac_init_help=recursive ;;
+ -help=s* | --help=s* | --hel=s* | --he=s* | -hs*)
+ ac_init_help=short ;;
+
+ -host | --host | --hos | --ho)
+ ac_prev=host_alias ;;
+ -host=* | --host=* | --hos=* | --ho=*)
+ host_alias=$ac_optarg ;;
+
+ -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht)
+ ac_prev=htmldir ;;
+ -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \
+ | --ht=*)
+ htmldir=$ac_optarg ;;
+
+ -includedir | --includedir | --includedi | --included | --include \
+ | --includ | --inclu | --incl | --inc)
+ ac_prev=includedir ;;
+ -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \
+ | --includ=* | --inclu=* | --incl=* | --inc=*)
+ includedir=$ac_optarg ;;
+
+ -infodir | --infodir | --infodi | --infod | --info | --inf)
+ ac_prev=infodir ;;
+ -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*)
+ infodir=$ac_optarg ;;
+
+ -libdir | --libdir | --libdi | --libd)
+ ac_prev=libdir ;;
+ -libdir=* | --libdir=* | --libdi=* | --libd=*)
+ libdir=$ac_optarg ;;
+
+ -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \
+ | --libexe | --libex | --libe)
+ ac_prev=libexecdir ;;
+ -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \
+ | --libexe=* | --libex=* | --libe=*)
+ libexecdir=$ac_optarg ;;
+
+ -localedir | --localedir | --localedi | --localed | --locale)
+ ac_prev=localedir ;;
+ -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*)
+ localedir=$ac_optarg ;;
+
+ -localstatedir | --localstatedir | --localstatedi | --localstated \
+ | --localstate | --localstat | --localsta | --localst | --locals)
+ ac_prev=localstatedir ;;
+ -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \
+ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*)
+ localstatedir=$ac_optarg ;;
+
+ -mandir | --mandir | --mandi | --mand | --man | --ma | --m)
+ ac_prev=mandir ;;
+ -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)
+ mandir=$ac_optarg ;;
+
+ -nfp | --nfp | --nf)
+ # Obsolete; use --without-fp.
+ with_fp=no ;;
+
+ -no-create | --no-create | --no-creat | --no-crea | --no-cre \
+ | --no-cr | --no-c | -n)
+ no_create=yes ;;
+
+ -no-recursion | --no-recursion | --no-recursio | --no-recursi \
+ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r)
+ no_recursion=yes ;;
+
+ -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \
+ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \
+ | --oldin | --oldi | --old | --ol | --o)
+ ac_prev=oldincludedir ;;
+ -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \
+ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \
+ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*)
+ oldincludedir=$ac_optarg ;;
+
+ -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)
+ ac_prev=prefix ;;
+ -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)
+ prefix=$ac_optarg ;;
+
+ -program-prefix | --program-prefix | --program-prefi | --program-pref \
+ | --program-pre | --program-pr | --program-p)
+ ac_prev=program_prefix ;;
+ -program-prefix=* | --program-prefix=* | --program-prefi=* \
+ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*)
+ program_prefix=$ac_optarg ;;
+
+ -program-suffix | --program-suffix | --program-suffi | --program-suff \
+ | --program-suf | --program-su | --program-s)
+ ac_prev=program_suffix ;;
+ -program-suffix=* | --program-suffix=* | --program-suffi=* \
+ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*)
+ program_suffix=$ac_optarg ;;
+
+ -program-transform-name | --program-transform-name \
+ | --program-transform-nam | --program-transform-na \
+ | --program-transform-n | --program-transform- \
+ | --program-transform | --program-transfor \
+ | --program-transfo | --program-transf \
+ | --program-trans | --program-tran \
+ | --progr-tra | --program-tr | --program-t)
+ ac_prev=program_transform_name ;;
+ -program-transform-name=* | --program-transform-name=* \
+ | --program-transform-nam=* | --program-transform-na=* \
+ | --program-transform-n=* | --program-transform-=* \
+ | --program-transform=* | --program-transfor=* \
+ | --program-transfo=* | --program-transf=* \
+ | --program-trans=* | --program-tran=* \
+ | --progr-tra=* | --program-tr=* | --program-t=*)
+ program_transform_name=$ac_optarg ;;
+
+ -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd)
+ ac_prev=pdfdir ;;
+ -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*)
+ pdfdir=$ac_optarg ;;
+
+ -psdir | --psdir | --psdi | --psd | --ps)
+ ac_prev=psdir ;;
+ -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*)
+ psdir=$ac_optarg ;;
+
+ -q | -quiet | --quiet | --quie | --qui | --qu | --q \
+ | -silent | --silent | --silen | --sile | --sil)
+ silent=yes ;;
+
+ -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
+ ac_prev=sbindir ;;
+ -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
+ | --sbi=* | --sb=*)
+ sbindir=$ac_optarg ;;
+
+ -sharedstatedir | --sharedstatedir | --sharedstatedi \
+ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \
+ | --sharedst | --shareds | --shared | --share | --shar \
+ | --sha | --sh)
+ ac_prev=sharedstatedir ;;
+ -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \
+ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \
+ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \
+ | --sha=* | --sh=*)
+ sharedstatedir=$ac_optarg ;;
+
+ -site | --site | --sit)
+ ac_prev=site ;;
+ -site=* | --site=* | --sit=*)
+ site=$ac_optarg ;;
+
+ -srcdir | --srcdir | --srcdi | --srcd | --src | --sr)
+ ac_prev=srcdir ;;
+ -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)
+ srcdir=$ac_optarg ;;
+
+ -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \
+ | --syscon | --sysco | --sysc | --sys | --sy)
+ ac_prev=sysconfdir ;;
+ -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \
+ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*)
+ sysconfdir=$ac_optarg ;;
+
+ -target | --target | --targe | --targ | --tar | --ta | --t)
+ ac_prev=target_alias ;;
+ -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)
+ target_alias=$ac_optarg ;;
+
+ -v | -verbose | --verbose | --verbos | --verbo | --verb)
+ verbose=yes ;;
+
+ -version | --version | --versio | --versi | --vers | -V)
+ ac_init_version=: ;;
+
+ -with-* | --with-*)
+ ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`
+ # Reject names that are not valid shell variable names.
+ expr "x$ac_package" : ".*[^-._$as_cr_alnum]" >/dev/null &&
+ { echo "$as_me: error: invalid package name: $ac_package" >&2
+ { (exit 1); exit 1; }; }
+ ac_package=`echo $ac_package | sed 's/[-.]/_/g'`
+ eval with_$ac_package=\$ac_optarg ;;
+
+ -without-* | --without-*)
+ ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'`
+ # Reject names that are not valid shell variable names.
+ expr "x$ac_package" : ".*[^-._$as_cr_alnum]" >/dev/null &&
+ { echo "$as_me: error: invalid package name: $ac_package" >&2
+ { (exit 1); exit 1; }; }
+ ac_package=`echo $ac_package | sed 's/[-.]/_/g'`
+ eval with_$ac_package=no ;;
+
+ --x)
+ # Obsolete; use --with-x.
+ with_x=yes ;;
+
+ -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \
+ | --x-incl | --x-inc | --x-in | --x-i)
+ ac_prev=x_includes ;;
+ -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \
+ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*)
+ x_includes=$ac_optarg ;;
+
+ -x-libraries | --x-libraries | --x-librarie | --x-librari \
+ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l)
+ ac_prev=x_libraries ;;
+ -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \
+ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*)
+ x_libraries=$ac_optarg ;;
+
+ -*) { echo "$as_me: error: unrecognized option: $ac_option
+Try \`$0 --help' for more information." >&2
+ { (exit 1); exit 1; }; }
+ ;;
+
+ *=*)
+ ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='`
+ # Reject names that are not valid shell variable names.
+ expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null &&
+ { echo "$as_me: error: invalid variable name: $ac_envvar" >&2
+ { (exit 1); exit 1; }; }
+ eval $ac_envvar=\$ac_optarg
+ export $ac_envvar ;;
+
+ *)
+ # FIXME: should be removed in autoconf 3.0.
+ echo "$as_me: WARNING: you should use --build, --host, --target" >&2
+ expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null &&
+ echo "$as_me: WARNING: invalid host type: $ac_option" >&2
+ : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}
+ ;;
+
+ esac
+done
+
+if test -n "$ac_prev"; then
+ ac_option=--`echo $ac_prev | sed 's/_/-/g'`
+ { echo "$as_me: error: missing argument to $ac_option" >&2
+ { (exit 1); exit 1; }; }
+fi
+
+# Be sure to have absolute directory names.
+for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \
+ datadir sysconfdir sharedstatedir localstatedir includedir \
+ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \
+ libdir localedir mandir
+do
+ eval ac_val=\$$ac_var
+ case $ac_val in
+ [\\/$]* | ?:[\\/]* ) continue;;
+ NONE | '' ) case $ac_var in *prefix ) continue;; esac;;
+ esac
+ { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
+ { (exit 1); exit 1; }; }
+done
+
+# There might be people who depend on the old broken behavior: `$host'
+# used to hold the argument of --host etc.
+# FIXME: To remove some day.
+build=$build_alias
+host=$host_alias
+target=$target_alias
+
+# FIXME: To remove some day.
+if test "x$host_alias" != x; then
+ if test "x$build_alias" = x; then
+ cross_compiling=maybe
+ echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host.
+ If a cross compiler is detected then cross compile mode will be used." >&2
+ elif test "x$build_alias" != "x$host_alias"; then
+ cross_compiling=yes
+ fi
+fi
+
+ac_tool_prefix=
+test -n "$host_alias" && ac_tool_prefix=$host_alias-
+
+test "$silent" = yes && exec 6>/dev/null
+
+
+ac_pwd=`pwd` && test -n "$ac_pwd" &&
+ac_ls_di=`ls -di .` &&
+ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` ||
+ { echo "$as_me: error: Working directory cannot be determined" >&2
+ { (exit 1); exit 1; }; }
+test "X$ac_ls_di" = "X$ac_pwd_ls_di" ||
+ { echo "$as_me: error: pwd does not report name of working directory" >&2
+ { (exit 1); exit 1; }; }
+
+
+# Find the source files, if location was not specified.
+if test -z "$srcdir"; then
+ ac_srcdir_defaulted=yes
+ # Try the directory containing this script, then the parent directory.
+ ac_confdir=`$as_dirname -- "$0" ||
+$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$0" : 'X\(//\)[^/]' \| \
+ X"$0" : 'X\(//\)$' \| \
+ X"$0" : 'X\(/\)' \| . 2>/dev/null ||
+echo X"$0" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)[^/].*/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+ srcdir=$ac_confdir
+ if test ! -r "$srcdir/$ac_unique_file"; then
+ srcdir=..
+ fi
+else
+ ac_srcdir_defaulted=no
+fi
+if test ! -r "$srcdir/$ac_unique_file"; then
+ test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .."
+ { echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2
+ { (exit 1); exit 1; }; }
+fi
+ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work"
+ac_abs_confdir=`(
+ cd "$srcdir" && test -r "./$ac_unique_file" || { echo "$as_me: error: $ac_msg" >&2
+ { (exit 1); exit 1; }; }
+ pwd)`
+# When building in place, set srcdir=.
+if test "$ac_abs_confdir" = "$ac_pwd"; then
+ srcdir=.
+fi
+# Remove unnecessary trailing slashes from srcdir.
+# Double slashes in file names in object file debugging info
+# mess up M-x gdb in Emacs.
+case $srcdir in
+*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;;
+esac
+for ac_var in $ac_precious_vars; do
+ eval ac_env_${ac_var}_set=\${${ac_var}+set}
+ eval ac_env_${ac_var}_value=\$${ac_var}
+ eval ac_cv_env_${ac_var}_set=\${${ac_var}+set}
+ eval ac_cv_env_${ac_var}_value=\$${ac_var}
+done
+
+#
+# Report the --help message.
+#
+if test "$ac_init_help" = "long"; then
+ # Omit some internal or obsolete options to make the list less imposing.
+ # This message is too long to be a string in the A/UX 3.1 sh.
+ cat <<_ACEOF
+\`configure' configures this package to adapt to many kinds of systems.
+
+Usage: $0 [OPTION]... [VAR=VALUE]...
+
+To assign environment variables (e.g., CC, CFLAGS...), specify them as
+VAR=VALUE. See below for descriptions of some of the useful variables.
+
+Defaults for the options are specified in brackets.
+
+Configuration:
+ -h, --help display this help and exit
+ --help=short display options specific to this package
+ --help=recursive display the short help of all the included packages
+ -V, --version display version information and exit
+ -q, --quiet, --silent do not print \`checking...' messages
+ --cache-file=FILE cache test results in FILE [disabled]
+ -C, --config-cache alias for \`--cache-file=config.cache'
+ -n, --no-create do not create output files
+ --srcdir=DIR find the sources in DIR [configure dir or \`..']
+
+Installation directories:
+ --prefix=PREFIX install architecture-independent files in PREFIX
+ [$ac_default_prefix]
+ --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX
+ [PREFIX]
+
+By default, \`make install' will install all the files in
+\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify
+an installation prefix other than \`$ac_default_prefix' using \`--prefix',
+for instance \`--prefix=\$HOME'.
+
+For better control, use the options below.
+
+Fine tuning of the installation directories:
+ --bindir=DIR user executables [EPREFIX/bin]
+ --sbindir=DIR system admin executables [EPREFIX/sbin]
+ --libexecdir=DIR program executables [EPREFIX/libexec]
+ --sysconfdir=DIR read-only single-machine data [PREFIX/etc]
+ --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com]
+ --localstatedir=DIR modifiable single-machine data [PREFIX/var]
+ --libdir=DIR object code libraries [EPREFIX/lib]
+ --includedir=DIR C header files [PREFIX/include]
+ --oldincludedir=DIR C header files for non-gcc [/usr/include]
+ --datarootdir=DIR read-only arch.-independent data root [PREFIX/share]
+ --datadir=DIR read-only architecture-independent data [DATAROOTDIR]
+ --infodir=DIR info documentation [DATAROOTDIR/info]
+ --localedir=DIR locale-dependent data [DATAROOTDIR/locale]
+ --mandir=DIR man documentation [DATAROOTDIR/man]
+ --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE]
+ --htmldir=DIR html documentation [DOCDIR]
+ --dvidir=DIR dvi documentation [DOCDIR]
+ --pdfdir=DIR pdf documentation [DOCDIR]
+ --psdir=DIR ps documentation [DOCDIR]
+_ACEOF
+
+ cat <<\_ACEOF
+
+System types:
+ --build=BUILD configure for building on BUILD [guessed]
+ --host=HOST cross-compile to build programs to run on HOST [BUILD]
+ --target=TARGET configure for building compilers for TARGET [HOST]
+_ACEOF
+fi
+
+if test -n "$ac_init_help"; then
+
+ cat <<\_ACEOF
+
+Optional Packages:
+ --with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
+ --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
+ --with-linux[=PATH] enable Linux kernel support
+ --with-mine-oct use Mine's Octagon library
+ --with-cvcl use the CVCL solver
+ --with-yices use the Yices solver
+ --with-saturn[=PATH] enable use of Saturn analysis
+
+Some influential environment variables:
+ CC C compiler command
+ CFLAGS C compiler flags
+ LDFLAGS linker flags, e.g. -L<lib dir> if you have libraries in a
+ nonstandard directory <lib dir>
+ LIBS libraries to pass to the linker, e.g. -l<library>
+ CPPFLAGS C/C++/Objective C preprocessor flags, e.g. -I<include dir> if
+ you have headers in a nonstandard directory <include dir>
+
+Use these variables to override the choices made by `configure' or to help
+it to find libraries and programs with nonstandard names/locations.
+
+_ACEOF
+ac_status=$?
+fi
+
+if test "$ac_init_help" = "recursive"; then
+ # If there are subdirs, report their specific --help.
+ for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue
+ test -d "$ac_dir" || continue
+ ac_builddir=.
+
+case "$ac_dir" in
+.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
+*)
+ ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'`
+ # A ".." for each directory in $ac_dir_suffix.
+ ac_top_builddir_sub=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,/..,g;s,/,,'`
+ case $ac_top_builddir_sub in
+ "") ac_top_builddir_sub=. ac_top_build_prefix= ;;
+ *) ac_top_build_prefix=$ac_top_builddir_sub/ ;;
+ esac ;;
+esac
+ac_abs_top_builddir=$ac_pwd
+ac_abs_builddir=$ac_pwd$ac_dir_suffix
+# for backward compatibility:
+ac_top_builddir=$ac_top_build_prefix
+
+case $srcdir in
+ .) # We are building in place.
+ ac_srcdir=.
+ ac_top_srcdir=$ac_top_builddir_sub
+ ac_abs_top_srcdir=$ac_pwd ;;
+ [\\/]* | ?:[\\/]* ) # Absolute name.
+ ac_srcdir=$srcdir$ac_dir_suffix;
+ ac_top_srcdir=$srcdir
+ ac_abs_top_srcdir=$srcdir ;;
+ *) # Relative name.
+ ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix
+ ac_top_srcdir=$ac_top_build_prefix$srcdir
+ ac_abs_top_srcdir=$ac_pwd/$srcdir ;;
+esac
+ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix
+
+ cd "$ac_dir" || { ac_status=$?; continue; }
+ # Check for guested configure.
+ if test -f "$ac_srcdir/configure.gnu"; then
+ echo &&
+ $SHELL "$ac_srcdir/configure.gnu" --help=recursive
+ elif test -f "$ac_srcdir/configure"; then
+ echo &&
+ $SHELL "$ac_srcdir/configure" --help=recursive
+ else
+ echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2
+ fi || ac_status=$?
+ cd "$ac_pwd" || { ac_status=$?; break; }
+ done
+fi
+
+test -n "$ac_init_help" && exit $ac_status
+if $ac_init_version; then
+ cat <<\_ACEOF
+configure
+generated by GNU Autoconf 2.61
+
+Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
+2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+This configure script is free software; the Free Software Foundation
+gives unlimited permission to copy, distribute and modify it.
+_ACEOF
+ exit
+fi
+cat >config.log <<_ACEOF
+This file contains any messages produced by compilers while
+running configure, to aid debugging if configure makes a mistake.
+
+It was created by $as_me, which was
+generated by GNU Autoconf 2.61. Invocation command line was
+
+ $ $0 $@
+
+_ACEOF
+exec 5>>config.log
+{
+cat <<_ASUNAME
+## --------- ##
+## Platform. ##
+## --------- ##
+
+hostname = `(hostname || uname -n) 2>/dev/null | sed 1q`
+uname -m = `(uname -m) 2>/dev/null || echo unknown`
+uname -r = `(uname -r) 2>/dev/null || echo unknown`
+uname -s = `(uname -s) 2>/dev/null || echo unknown`
+uname -v = `(uname -v) 2>/dev/null || echo unknown`
+
+/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown`
+/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown`
+
+/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown`
+/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown`
+/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown`
+/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown`
+/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown`
+/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown`
+/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown`
+
+_ASUNAME
+
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ echo "PATH: $as_dir"
+done
+IFS=$as_save_IFS
+
+} >&5
+
+cat >&5 <<_ACEOF
+
+
+## ----------- ##
+## Core tests. ##
+## ----------- ##
+
+_ACEOF
+
+
+# Keep a trace of the command line.
+# Strip out --no-create and --no-recursion so they do not pile up.
+# Strip out --silent because we don't want to record it for future runs.
+# Also quote any args containing shell meta-characters.
+# Make two passes to allow for proper duplicate-argument suppression.
+ac_configure_args=
+ac_configure_args0=
+ac_configure_args1=
+ac_must_keep_next=false
+for ac_pass in 1 2
+do
+ for ac_arg
+ do
+ case $ac_arg in
+ -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;;
+ -q | -quiet | --quiet | --quie | --qui | --qu | --q \
+ | -silent | --silent | --silen | --sile | --sil)
+ continue ;;
+ *\'*)
+ ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
+ esac
+ case $ac_pass in
+ 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;;
+ 2)
+ ac_configure_args1="$ac_configure_args1 '$ac_arg'"
+ if test $ac_must_keep_next = true; then
+ ac_must_keep_next=false # Got value, back to normal.
+ else
+ case $ac_arg in
+ *=* | --config-cache | -C | -disable-* | --disable-* \
+ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \
+ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \
+ | -with-* | --with-* | -without-* | --without-* | --x)
+ case "$ac_configure_args0 " in
+ "$ac_configure_args1"*" '$ac_arg' "* ) continue ;;
+ esac
+ ;;
+ -* ) ac_must_keep_next=true ;;
+ esac
+ fi
+ ac_configure_args="$ac_configure_args '$ac_arg'"
+ ;;
+ esac
+ done
+done
+$as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; }
+$as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export ac_configure_args1; }
+
+# When interrupted or exit'd, cleanup temporary files, and complete
+# config.log. We remove comments because anyway the quotes in there
+# would cause problems or look ugly.
+# WARNING: Use '\'' to represent an apostrophe within the trap.
+# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug.
+trap 'exit_status=$?
+ # Save into config.log some information that might help in debugging.
+ {
+ echo
+
+ cat <<\_ASBOX
+## ---------------- ##
+## Cache variables. ##
+## ---------------- ##
+_ASBOX
+ echo
+ # The following way of writing the cache mishandles newlines in values,
+(
+ for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do
+ eval ac_val=\$$ac_var
+ case $ac_val in #(
+ *${as_nl}*)
+ case $ac_var in #(
+ *_cv_*) { echo "$as_me:$LINENO: WARNING: Cache variable $ac_var contains a newline." >&5
+echo "$as_me: WARNING: Cache variable $ac_var contains a newline." >&2;} ;;
+ esac
+ case $ac_var in #(
+ _ | IFS | as_nl) ;; #(
+ *) $as_unset $ac_var ;;
+ esac ;;
+ esac
+ done
+ (set) 2>&1 |
+ case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #(
+ *${as_nl}ac_space=\ *)
+ sed -n \
+ "s/'\''/'\''\\\\'\'''\''/g;
+ s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p"
+ ;; #(
+ *)
+ sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
+ ;;
+ esac |
+ sort
+)
+ echo
+
+ cat <<\_ASBOX
+## ----------------- ##
+## Output variables. ##
+## ----------------- ##
+_ASBOX
+ echo
+ for ac_var in $ac_subst_vars
+ do
+ eval ac_val=\$$ac_var
+ case $ac_val in
+ *\'\''*) ac_val=`echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
+ esac
+ echo "$ac_var='\''$ac_val'\''"
+ done | sort
+ echo
+
+ if test -n "$ac_subst_files"; then
+ cat <<\_ASBOX
+## ------------------- ##
+## File substitutions. ##
+## ------------------- ##
+_ASBOX
+ echo
+ for ac_var in $ac_subst_files
+ do
+ eval ac_val=\$$ac_var
+ case $ac_val in
+ *\'\''*) ac_val=`echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
+ esac
+ echo "$ac_var='\''$ac_val'\''"
+ done | sort
+ echo
+ fi
+
+ if test -s confdefs.h; then
+ cat <<\_ASBOX
+## ----------- ##
+## confdefs.h. ##
+## ----------- ##
+_ASBOX
+ echo
+ cat confdefs.h
+ echo
+ fi
+ test "$ac_signal" != 0 &&
+ echo "$as_me: caught signal $ac_signal"
+ echo "$as_me: exit $exit_status"
+ } >&5
+ rm -f core *.core core.conftest.* &&
+ rm -f -r conftest* confdefs* conf$$* $ac_clean_files &&
+ exit $exit_status
+' 0
+for ac_signal in 1 2 13 15; do
+ trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal
+done
+ac_signal=0
+
+# confdefs.h avoids OS command line length limits that DEFS can exceed.
+rm -f -r conftest* confdefs.h
+
+# Predefined preprocessor variables.
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_NAME "$PACKAGE_NAME"
+_ACEOF
+
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_TARNAME "$PACKAGE_TARNAME"
+_ACEOF
+
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_VERSION "$PACKAGE_VERSION"
+_ACEOF
+
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_STRING "$PACKAGE_STRING"
+_ACEOF
+
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT"
+_ACEOF
+
+
+# Let the site file select an alternate cache file if it wants to.
+# Prefer explicitly selected file to automatically selected ones.
+if test -n "$CONFIG_SITE"; then
+ set x "$CONFIG_SITE"
+elif test "x$prefix" != xNONE; then
+ set x "$prefix/share/config.site" "$prefix/etc/config.site"
+else
+ set x "$ac_default_prefix/share/config.site" \
+ "$ac_default_prefix/etc/config.site"
+fi
+shift
+for ac_site_file
+do
+ if test -r "$ac_site_file"; then
+ { echo "$as_me:$LINENO: loading site script $ac_site_file" >&5
+echo "$as_me: loading site script $ac_site_file" >&6;}
+ sed 's/^/| /' "$ac_site_file" >&5
+ . "$ac_site_file"
+ fi
+done
+
+if test -r "$cache_file"; then
+ # Some versions of bash will fail to source /dev/null (special
+ # files actually), so we avoid doing that.
+ if test -f "$cache_file"; then
+ { echo "$as_me:$LINENO: loading cache $cache_file" >&5
+echo "$as_me: loading cache $cache_file" >&6;}
+ case $cache_file in
+ [\\/]* | ?:[\\/]* ) . "$cache_file";;
+ *) . "./$cache_file";;
+ esac
+ fi
+else
+ { echo "$as_me:$LINENO: creating cache $cache_file" >&5
+echo "$as_me: creating cache $cache_file" >&6;}
+ >$cache_file
+fi
+
+# Check that the precious variables saved in the cache have kept the same
+# value.
+ac_cache_corrupted=false
+for ac_var in $ac_precious_vars; do
+ eval ac_old_set=\$ac_cv_env_${ac_var}_set
+ eval ac_new_set=\$ac_env_${ac_var}_set
+ eval ac_old_val=\$ac_cv_env_${ac_var}_value
+ eval ac_new_val=\$ac_env_${ac_var}_value
+ case $ac_old_set,$ac_new_set in
+ set,)
+ { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5
+echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;}
+ ac_cache_corrupted=: ;;
+ ,set)
+ { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5
+echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;}
+ ac_cache_corrupted=: ;;
+ ,);;
+ *)
+ if test "x$ac_old_val" != "x$ac_new_val"; then
+ { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5
+echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}
+ { echo "$as_me:$LINENO: former value: $ac_old_val" >&5
+echo "$as_me: former value: $ac_old_val" >&2;}
+ { echo "$as_me:$LINENO: current value: $ac_new_val" >&5
+echo "$as_me: current value: $ac_new_val" >&2;}
+ ac_cache_corrupted=:
+ fi;;
+ esac
+ # Pass precious variables to config.status.
+ if test "$ac_new_set" = set; then
+ case $ac_new_val in
+ *\'*) ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;;
+ *) ac_arg=$ac_var=$ac_new_val ;;
+ esac
+ case " $ac_configure_args " in
+ *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy.
+ *) ac_configure_args="$ac_configure_args '$ac_arg'" ;;
+ esac
+ fi
+done
+if $ac_cache_corrupted; then
+ { echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5
+echo "$as_me: error: changes in the environment can compromise the build" >&2;}
+ { { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5
+echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;}
+ { (exit 1); exit 1; }; }
+fi
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+
+
+
+
+ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+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
+{ echo "$as_me:$LINENO: checking for $ac_word" >&5
+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }
+if test "${ac_cv_prog_CC+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_CC="${ac_tool_prefix}gcc"
+ echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+done
+IFS=$as_save_IFS
+
+fi
+fi
+CC=$ac_cv_prog_CC
+if test -n "$CC"; then
+ { echo "$as_me:$LINENO: result: $CC" >&5
+echo "${ECHO_T}$CC" >&6; }
+else
+ { echo "$as_me:$LINENO: result: no" >&5
+echo "${ECHO_T}no" >&6; }
+fi
+
+
+fi
+if test -z "$ac_cv_prog_CC"; then
+ ac_ct_CC=$CC
+ # Extract the first word of "gcc", so it can be a program name with args.
+set dummy gcc; ac_word=$2
+{ echo "$as_me:$LINENO: checking for $ac_word" >&5
+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }
+if test "${ac_cv_prog_ac_ct_CC+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_CC="gcc"
+ echo "$as_me:$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
+ { echo "$as_me:$LINENO: result: $ac_ct_CC" >&5
+echo "${ECHO_T}$ac_ct_CC" >&6; }
+else
+ { echo "$as_me:$LINENO: result: no" >&5
+echo "${ECHO_T}no" >&6; }
+fi
+
+ if test "x$ac_ct_CC" = x; then
+ CC=""
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ echo "$as_me:$LINENO: WARNING: In the future, Autoconf will not detect cross-tools
+whose name does not start with the host triplet. If you think this
+configuration is useful to you, please write to autoconf@gnu.org." >&5
+echo "$as_me: WARNING: In the future, Autoconf will not detect cross-tools
+whose name does not start with the host triplet. If you think this
+configuration is useful to you, please write to autoconf@gnu.org." >&2;}
+ac_tool_warned=yes ;;
+esac
+ CC=$ac_ct_CC
+ fi
+else
+ CC="$ac_cv_prog_CC"
+fi
+
+if test -z "$CC"; then
+ if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args.
+set dummy ${ac_tool_prefix}cc; ac_word=$2
+{ echo "$as_me:$LINENO: checking for $ac_word" >&5
+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }
+if test "${ac_cv_prog_CC+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_CC="${ac_tool_prefix}cc"
+ echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+done
+IFS=$as_save_IFS
+
+fi
+fi
+CC=$ac_cv_prog_CC
+if test -n "$CC"; then
+ { echo "$as_me:$LINENO: result: $CC" >&5
+echo "${ECHO_T}$CC" >&6; }
+else
+ { echo "$as_me:$LINENO: result: no" >&5
+echo "${ECHO_T}no" >&6; }
+fi
+
+
+ fi
+fi
+if test -z "$CC"; then
+ # Extract the first word of "cc", so it can be a program name with args.
+set dummy cc; ac_word=$2
+{ echo "$as_me:$LINENO: checking for $ac_word" >&5
+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }
+if test "${ac_cv_prog_CC+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ if test -n "$CC"; then
+ ac_cv_prog_CC="$CC" # Let the user override the test.
+else
+ ac_prog_rejected=no
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$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"
+ echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+done
+IFS=$as_save_IFS
+
+if test $ac_prog_rejected = yes; then
+ # We found a bogon in the path, so make sure we never use it.
+ set dummy $ac_cv_prog_CC
+ shift
+ if test $# != 0; then
+ # We chose a different compiler from the bogus one.
+ # However, it has the same basename, so the bogon will be chosen
+ # first if we set CC to just the basename; use the full file name.
+ shift
+ ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@"
+ fi
+fi
+fi
+fi
+CC=$ac_cv_prog_CC
+if test -n "$CC"; then
+ { echo "$as_me:$LINENO: result: $CC" >&5
+echo "${ECHO_T}$CC" >&6; }
+else
+ { echo "$as_me:$LINENO: result: no" >&5
+echo "${ECHO_T}no" >&6; }
+fi
+
+
+fi
+if test -z "$CC"; then
+ if test -n "$ac_tool_prefix"; then
+ for ac_prog in cl.exe
+ do
+ # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args.
+set dummy $ac_tool_prefix$ac_prog; ac_word=$2
+{ echo "$as_me:$LINENO: checking for $ac_word" >&5
+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }
+if test "${ac_cv_prog_CC+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_CC="$ac_tool_prefix$ac_prog"
+ echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+done
+IFS=$as_save_IFS
+
+fi
+fi
+CC=$ac_cv_prog_CC
+if test -n "$CC"; then
+ { echo "$as_me:$LINENO: result: $CC" >&5
+echo "${ECHO_T}$CC" >&6; }
+else
+ { echo "$as_me:$LINENO: result: no" >&5
+echo "${ECHO_T}no" >&6; }
+fi
+
+
+ test -n "$CC" && break
+ done
+fi
+if test -z "$CC"; then
+ ac_ct_CC=$CC
+ for ac_prog in cl.exe
+do
+ # Extract the first word of "$ac_prog", so it can be a program name with args.
+set dummy $ac_prog; ac_word=$2
+{ echo "$as_me:$LINENO: checking for $ac_word" >&5
+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }
+if test "${ac_cv_prog_ac_ct_CC+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_prog_ac_ct_CC="$ac_prog"
+ echo "$as_me:$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
+ { echo "$as_me:$LINENO: result: $ac_ct_CC" >&5
+echo "${ECHO_T}$ac_ct_CC" >&6; }
+else
+ { echo "$as_me:$LINENO: result: no" >&5
+echo "${ECHO_T}no" >&6; }
+fi
+
+
+ test -n "$ac_ct_CC" && break
+done
+
+ if test "x$ac_ct_CC" = x; then
+ CC=""
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ echo "$as_me:$LINENO: WARNING: In the future, Autoconf will not detect cross-tools
+whose name does not start with the host triplet. If you think this
+configuration is useful to you, please write to autoconf@gnu.org." >&5
+echo "$as_me: WARNING: In the future, Autoconf will not detect cross-tools
+whose name does not start with the host triplet. If you think this
+configuration is useful to you, please write to autoconf@gnu.org." >&2;}
+ac_tool_warned=yes ;;
+esac
+ CC=$ac_ct_CC
+ fi
+fi
+
+fi
+
+
+test -z "$CC" && { { echo "$as_me:$LINENO: error: no acceptable C compiler found in \$PATH
+See \`config.log' for more details." >&5
+echo "$as_me: error: no acceptable C compiler found in \$PATH
+See \`config.log' for more details." >&2;}
+ { (exit 1); exit 1; }; }
+
+# Provide some information about the compiler.
+echo "$as_me:$LINENO: checking for C compiler version" >&5
+ac_compiler=`set X $ac_compile; echo $2`
+{ (ac_try="$ac_compiler --version >&5"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compiler --version >&5") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }
+{ (ac_try="$ac_compiler -v >&5"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compiler -v >&5") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }
+{ (ac_try="$ac_compiler -V >&5"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compiler -V >&5") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }
+
+cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+ac_clean_files_save=$ac_clean_files
+ac_clean_files="$ac_clean_files a.out a.exe b.out"
+# Try to create an executable without -o first, disregard a.out.
+# It will help us diagnose broken compilers, and finding out an intuition
+# of exeext.
+{ echo "$as_me:$LINENO: checking for C compiler default output file name" >&5
+echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6; }
+ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'`
+#
+# List of possible output files, starting from the most likely.
+# The algorithm is not robust to junk in `.', hence go to wildcards (a.*)
+# only as a last resort. b.out is created by i960 compilers.
+ac_files='a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out'
+#
+# The IRIX 6 linker writes into existing files which may not be
+# executable, retaining their permissions. Remove them first so a
+# subsequent execution test works.
+ac_rmfiles=
+for ac_file in $ac_files
+do
+ case $ac_file in
+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.o | *.obj ) ;;
+ * ) ac_rmfiles="$ac_rmfiles $ac_file";;
+ esac
+done
+rm -f $ac_rmfiles
+
+if { (ac_try="$ac_link_default"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_link_default") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; then
+ # Autoconf-2.13 could set the ac_cv_exeext variable to `no'.
+# So ignore a value of `no', otherwise this would lead to `EXEEXT = no'
+# in a Makefile. We should not override ac_cv_exeext if it was cached,
+# so that the user can short-circuit this test for compilers unknown to
+# Autoconf.
+for ac_file in $ac_files ''
+do
+ test -f "$ac_file" || continue
+ case $ac_file in
+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.o | *.obj )
+ ;;
+ [ab].out )
+ # We found the default executable, but exeext='' is most
+ # certainly right.
+ break;;
+ *.* )
+ if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no;
+ then :; else
+ ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
+ fi
+ # We set ac_cv_exeext here because the later test for it is not
+ # safe: cross compilers may not add the suffix if given an `-o'
+ # argument, so we may need to know it at that point already.
+ # Even if this section looks crufty: it has the advantage of
+ # actually working.
+ break;;
+ * )
+ break;;
+ esac
+done
+test "$ac_cv_exeext" = no && ac_cv_exeext=
+
+else
+ ac_file=''
+fi
+
+{ echo "$as_me:$LINENO: result: $ac_file" >&5
+echo "${ECHO_T}$ac_file" >&6; }
+if test -z "$ac_file"; then
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+{ { echo "$as_me:$LINENO: error: C compiler cannot create executables
+See \`config.log' for more details." >&5
+echo "$as_me: error: C compiler cannot create executables
+See \`config.log' for more details." >&2;}
+ { (exit 77); exit 77; }; }
+fi
+
+ac_exeext=$ac_cv_exeext
+
+# Check that the compiler produces executables we can run. If not, either
+# the compiler is broken, or we cross compile.
+{ echo "$as_me:$LINENO: checking whether the C compiler works" >&5
+echo $ECHO_N "checking whether the C compiler works... $ECHO_C" >&6; }
+# FIXME: These cross compiler hacks should be removed for Autoconf 3.0
+# If not cross compiling, check that we can run a simple program.
+if test "$cross_compiling" != yes; then
+ if { ac_try='./$ac_file'
+ { (case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_try") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; }; then
+ cross_compiling=no
+ else
+ if test "$cross_compiling" = maybe; then
+ cross_compiling=yes
+ else
+ { { echo "$as_me:$LINENO: error: cannot run C compiled programs.
+If you meant to cross compile, use \`--host'.
+See \`config.log' for more details." >&5
+echo "$as_me: error: cannot run C compiled programs.
+If you meant to cross compile, use \`--host'.
+See \`config.log' for more details." >&2;}
+ { (exit 1); exit 1; }; }
+ fi
+ fi
+fi
+{ echo "$as_me:$LINENO: result: yes" >&5
+echo "${ECHO_T}yes" >&6; }
+
+rm -f a.out a.exe conftest$ac_cv_exeext b.out
+ac_clean_files=$ac_clean_files_save
+# Check that the compiler produces executables we can run. If not, either
+# the compiler is broken, or we cross compile.
+{ echo "$as_me:$LINENO: checking whether we are cross compiling" >&5
+echo $ECHO_N "checking whether we are cross compiling... $ECHO_C" >&6; }
+{ echo "$as_me:$LINENO: result: $cross_compiling" >&5
+echo "${ECHO_T}$cross_compiling" >&6; }
+
+{ echo "$as_me:$LINENO: checking for suffix of executables" >&5
+echo $ECHO_N "checking for suffix of executables... $ECHO_C" >&6; }
+if { (ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_link") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; then
+ # If both `conftest.exe' and `conftest' are `present' (well, observable)
+# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will
+# work properly (i.e., refer to `conftest.exe'), while it won't with
+# `rm'.
+for ac_file in conftest.exe conftest conftest.*; do
+ test -f "$ac_file" || continue
+ case $ac_file in
+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.o | *.obj ) ;;
+ *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
+ break;;
+ * ) break;;
+ esac
+done
+else
+ { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link
+See \`config.log' for more details." >&5
+echo "$as_me: error: cannot compute suffix of executables: cannot compile and link
+See \`config.log' for more details." >&2;}
+ { (exit 1); exit 1; }; }
+fi
+
+rm -f conftest$ac_cv_exeext
+{ echo "$as_me:$LINENO: result: $ac_cv_exeext" >&5
+echo "${ECHO_T}$ac_cv_exeext" >&6; }
+
+rm -f conftest.$ac_ext
+EXEEXT=$ac_cv_exeext
+ac_exeext=$EXEEXT
+{ echo "$as_me:$LINENO: checking for suffix of object files" >&5
+echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6; }
+if test "${ac_cv_objext+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.o conftest.obj
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; then
+ for ac_file in conftest.o conftest.obj conftest.*; do
+ test -f "$ac_file" || continue;
+ case $ac_file in
+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf ) ;;
+ *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'`
+ break;;
+ esac
+done
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+{ { echo "$as_me:$LINENO: error: cannot compute suffix of object files: cannot compile
+See \`config.log' for more details." >&5
+echo "$as_me: error: cannot compute suffix of object files: cannot compile
+See \`config.log' for more details." >&2;}
+ { (exit 1); exit 1; }; }
+fi
+
+rm -f conftest.$ac_cv_objext conftest.$ac_ext
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_objext" >&5
+echo "${ECHO_T}$ac_cv_objext" >&6; }
+OBJEXT=$ac_cv_objext
+ac_objext=$OBJEXT
+{ echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5
+echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6; }
+if test "${ac_cv_c_compiler_gnu+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+int
+main ()
+{
+#ifndef __GNUC__
+ choke me
+#endif
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ ac_compiler_gnu=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_compiler_gnu=no
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ac_cv_c_compiler_gnu=$ac_compiler_gnu
+
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5
+echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6; }
+GCC=`test $ac_compiler_gnu = yes && echo yes`
+ac_test_CFLAGS=${CFLAGS+set}
+ac_save_CFLAGS=$CFLAGS
+{ echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5
+echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6; }
+if test "${ac_cv_prog_cc_g+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ ac_save_c_werror_flag=$ac_c_werror_flag
+ ac_c_werror_flag=yes
+ ac_cv_prog_cc_g=no
+ CFLAGS="-g"
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ ac_cv_prog_cc_g=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ CFLAGS=""
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ :
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_c_werror_flag=$ac_save_c_werror_flag
+ CFLAGS="-g"
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ ac_cv_prog_cc_g=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ ac_c_werror_flag=$ac_save_c_werror_flag
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5
+echo "${ECHO_T}$ac_cv_prog_cc_g" >&6; }
+if test "$ac_test_CFLAGS" = set; then
+ CFLAGS=$ac_save_CFLAGS
+elif test $ac_cv_prog_cc_g = yes; then
+ if test "$GCC" = yes; then
+ CFLAGS="-g -O2"
+ else
+ CFLAGS="-g"
+ fi
+else
+ if test "$GCC" = yes; then
+ CFLAGS="-O2"
+ else
+ CFLAGS=
+ fi
+fi
+{ echo "$as_me:$LINENO: checking for $CC option to accept ISO C89" >&5
+echo $ECHO_N "checking for $CC option to accept ISO C89... $ECHO_C" >&6; }
+if test "${ac_cv_prog_cc_c89+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ ac_cv_prog_cc_c89=no
+ac_save_CC=$CC
+cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <stdarg.h>
+#include <stdio.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */
+struct buf { int x; };
+FILE * (*rcsopen) (struct buf *, struct stat *, int);
+static char *e (p, i)
+ char **p;
+ int i;
+{
+ return p[i];
+}
+static char *f (char * (*g) (char **, int), char **p, ...)
+{
+ char *s;
+ va_list v;
+ va_start (v,p);
+ s = g (p, va_arg (v,int));
+ va_end (v);
+ return s;
+}
+
+/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has
+ function prototypes and stuff, but not '\xHH' hex character constants.
+ These don't provoke an error unfortunately, instead are silently treated
+ as 'x'. The following induces an error, until -std is added to get
+ proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an
+ array size at least. It's necessary to write '\x00'==0 to get something
+ that's true only with -std. */
+int osf4_cc_array ['\x00' == 0 ? 1 : -1];
+
+/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters
+ inside strings and character constants. */
+#define FOO(x) 'x'
+int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1];
+
+int test (int i, double x);
+struct s1 {int (*f) (int a);};
+struct s2 {int (*f) (double a);};
+int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int);
+int argc;
+char **argv;
+int
+main ()
+{
+return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1];
+ ;
+ return 0;
+}
+_ACEOF
+for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \
+ -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__"
+do
+ CC="$ac_save_CC $ac_arg"
+ rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ ac_cv_prog_cc_c89=$ac_arg
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+
+fi
+
+rm -f core conftest.err conftest.$ac_objext
+ test "x$ac_cv_prog_cc_c89" != "xno" && break
+done
+rm -f conftest.$ac_ext
+CC=$ac_save_CC
+
+fi
+# AC_CACHE_VAL
+case "x$ac_cv_prog_cc_c89" in
+ x)
+ { echo "$as_me:$LINENO: result: none needed" >&5
+echo "${ECHO_T}none needed" >&6; } ;;
+ xno)
+ { echo "$as_me:$LINENO: result: unsupported" >&5
+echo "${ECHO_T}unsupported" >&6; } ;;
+ *)
+ CC="$CC $ac_cv_prog_cc_c89"
+ { echo "$as_me:$LINENO: result: $ac_cv_prog_cc_c89" >&5
+echo "${ECHO_T}$ac_cv_prog_cc_c89" >&6; } ;;
+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
+
+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
+ { { echo "$as_me:$LINENO: error: cannot find install-sh or install.sh in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" >&5
+echo "$as_me: error: cannot find install-sh or install.sh in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" >&2;}
+ { (exit 1); exit 1; }; }
+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
+# incompatible versions:
+# SysV /etc/install, /usr/sbin/install
+# SunOS /usr/etc/install
+# IRIX /sbin/install
+# AIX /bin/install
+# AmigaOS /C/install, which installs bootblocks on floppy discs
+# AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag
+# AFS /usr/afsws/bin/install, which mishandles nonexistent args
+# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff"
+# OS/2's system install, which has a completely different semantic
+# ./install, which can be erroneously created by make from ./install.sh.
+{ echo "$as_me:$LINENO: checking for a BSD-compatible install" >&5
+echo $ECHO_N "checking for a BSD-compatible install... $ECHO_C" >&6; }
+if test -z "$INSTALL"; then
+if test "${ac_cv_path_install+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ # Account for people who put trailing slashes in PATH elements.
+case $as_dir/ in
+ ./ | .// | /cC/* | \
+ /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \
+ ?:\\/os2\\/install\\/* | ?:\\/OS2\\/INSTALL\\/* | \
+ /usr/ucb/* ) ;;
+ *)
+ # OSF1 and SCO ODT 3.0 have their own names for install.
+ # Don't use installbsd from OSF since it installs stuff as root
+ # by default.
+ for ac_prog in ginstall scoinst install; do
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; }; then
+ if test $ac_prog = install &&
+ grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then
+ # AIX install. It has an incompatible calling convention.
+ :
+ elif test $ac_prog = install &&
+ grep pwplus "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then
+ # program-specific install script used by HP pwplus--don't use.
+ :
+ else
+ ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c"
+ break 3
+ fi
+ fi
+ done
+ done
+ ;;
+esac
+done
+IFS=$as_save_IFS
+
+
+fi
+ if test "${ac_cv_path_install+set}" = set; then
+ INSTALL=$ac_cv_path_install
+ else
+ # As a last resort, use the slow shell script. Don't cache a
+ # value for INSTALL within a source directory, because that will
+ # break other packages using the cache if that directory is
+ # removed, or if the value is a relative name.
+ INSTALL=$ac_install_sh
+ fi
+fi
+{ echo "$as_me:$LINENO: result: $INSTALL" >&5
+echo "${ECHO_T}$INSTALL" >&6; }
+
+# Use test -z because SunOS4 sh mishandles braces in ${var-val}.
+# It thinks the first close brace ends the variable substitution.
+test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}'
+
+test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}'
+
+test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644'
+
+
+# Make sure we can run config.sub.
+$SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 ||
+ { { echo "$as_me:$LINENO: error: cannot run $SHELL $ac_aux_dir/config.sub" >&5
+echo "$as_me: error: cannot run $SHELL $ac_aux_dir/config.sub" >&2;}
+ { (exit 1); exit 1; }; }
+
+{ echo "$as_me:$LINENO: checking build system type" >&5
+echo $ECHO_N "checking build system type... $ECHO_C" >&6; }
+if test "${ac_cv_build+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&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 &&
+ { { echo "$as_me:$LINENO: error: cannot guess build type; you must specify one" >&5
+echo "$as_me: error: cannot guess build type; you must specify one" >&2;}
+ { (exit 1); exit 1; }; }
+ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` ||
+ { { echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $ac_build_alias failed" >&5
+echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $ac_build_alias failed" >&2;}
+ { (exit 1); exit 1; }; }
+
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_build" >&5
+echo "${ECHO_T}$ac_cv_build" >&6; }
+case $ac_cv_build in
+*-*-*) ;;
+*) { { echo "$as_me:$LINENO: error: invalid value of canonical build" >&5
+echo "$as_me: error: invalid value of canonical build" >&2;}
+ { (exit 1); exit 1; }; };;
+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
+
+
+{ echo "$as_me:$LINENO: checking host system type" >&5
+echo $ECHO_N "checking host system type... $ECHO_C" >&6; }
+if test "${ac_cv_host+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&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` ||
+ { { echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $host_alias failed" >&5
+echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $host_alias failed" >&2;}
+ { (exit 1); exit 1; }; }
+fi
+
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_host" >&5
+echo "${ECHO_T}$ac_cv_host" >&6; }
+case $ac_cv_host in
+*-*-*) ;;
+*) { { echo "$as_me:$LINENO: error: invalid value of canonical host" >&5
+echo "$as_me: error: invalid value of canonical host" >&2;}
+ { (exit 1); exit 1; }; };;
+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
+
+
+{ echo "$as_me:$LINENO: checking target system type" >&5
+echo $ECHO_N "checking target system type... $ECHO_C" >&6; }
+if test "${ac_cv_target+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ if test "x$target_alias" = x; then
+ ac_cv_target=$ac_cv_host
+else
+ ac_cv_target=`$SHELL "$ac_aux_dir/config.sub" $target_alias` ||
+ { { echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $target_alias failed" >&5
+echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $target_alias failed" >&2;}
+ { (exit 1); exit 1; }; }
+fi
+
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_target" >&5
+echo "${ECHO_T}$ac_cv_target" >&6; }
+case $ac_cv_target in
+*-*-*) ;;
+*) { { echo "$as_me:$LINENO: error: invalid value of canonical target" >&5
+echo "$as_me: error: invalid value of canonical target" >&2;}
+ { (exit 1); exit 1; }; };;
+esac
+target=$ac_cv_target
+ac_save_IFS=$IFS; IFS='-'
+set x $ac_cv_target
+shift
+target_cpu=$1
+target_vendor=$2
+shift; shift
+# Remember, the first character of IFS is used to create $*,
+# except with old shells:
+target_os=$*
+IFS=$ac_save_IFS
+case $target_os in *\ *) target_os=`echo "$target_os" | sed 's/ /-/g'`;; esac
+
+
+# The aliases save the names the user supplied, while $host etc.
+# will get canonicalized.
+test -n "$target_alias" &&
+ test "$program_prefix$program_suffix$program_transform_name" = \
+ NONENONEs,x,x, &&
+ program_prefix=${target_alias}-
+
+DEPUTYHOME=`pwd`
+DEFAULT_CIL_MODE=GNUCC
+DEPUTY_VERSION=1.1
+
+CVCLLIB=/usr/local/lib
+CVCLINC=/usr/local/include
+
+YICESLIB=/usr/local/lib
+YICESINC=/usr/local/include
+
+OCAMLINC=/usr/lib/ocaml
+
+# make sure I haven't forgotten to run autoconf
+if test configure -ot configure.ac; then
+ { { echo "$as_me:$LINENO: error: configure is older than configure.ac; you forgot to run autoconf" >&5
+echo "$as_me: error: configure is older than configure.ac; you forgot to run autoconf" >&2;}
+ { (exit 1); exit 1; }; }
+fi
+
+case "$target" in
+ # Linux
+ *86*linux*|*86*openbsd*)
+ { echo "$as_me:$LINENO: result: configuring for $target" >&5
+echo "${ECHO_T}configuring for $target" >&6; }
+ ARCHOS=x86_LINUX
+ ;;
+
+ # FreeBSD
+ *i386*freebsd*|*amd64*freebsd*)
+ if test x"${ARCH}" = x""; then
+ ARCH=`uname -p`
+ fi
+
+ { echo "$as_me:$LINENO: result: configuring for $target" >&5
+echo "${ECHO_T}configuring for $target" >&6; }
+ ARCHOS=${ARCH}_FREEBSD
+ ;;
+
+ # Mac OS X
+ *86*darwin*)
+ { echo "$as_me:$LINENO: result: configuring for $target" >&5
+echo "${ECHO_T}configuring for $target" >&6; }
+ ARCHOS=x86_DARWIN
+ ;;
+
+ # Cygwin
+ *86*cygwin*)
+ { echo "$as_me:$LINENO: result: configuring for $target" >&5
+echo "${ECHO_T}configuring for $target" >&6; }
+ ARCHOS=x86_WIN32
+
+ # override DEPUTYHOME; even on cygwin we want forward slashes
+ # sm: I folded this into what I hope will be the only
+ # case-analysis of machine type
+ # DEPUTYHOME=`cygpath -wa "$DEPUTYHOME" | sed -e "s/\\\\\/\\//g"`
+ # Try to use the Unix paths even on cygwin. The newest versions of make
+ # do not like colons in file names
+ DEPUTYHOME=`cygpath -u "$DEPUTYHOME"`
+ CC=`which $CC`
+ CC=`cygpath -wa "$CC" | sed -e "s/\\\\\/\\//g"`
+ ;;
+
+ *)
+ { { echo "$as_me:$LINENO: error:
+ Unsupported platform $target -- sorry.
+ ./configure supports these platforms:
+ on x86: Linux, Cygwin, FreeBSD, OpenBSD, Darwin
+ " >&5
+echo "$as_me: error:
+ Unsupported platform $target -- sorry.
+ ./configure supports these platforms:
+ on x86: Linux, Cygwin, FreeBSD, OpenBSD, Darwin
+ " >&2;}
+ { (exit 1); exit 1; }; }
+ ;;
+esac
+
+as_ac_File=`echo "ac_cv_file_obj/$ARCHOS" | $as_tr_sh`
+{ echo "$as_me:$LINENO: checking for obj/$ARCHOS" >&5
+echo $ECHO_N "checking for obj/$ARCHOS... $ECHO_C" >&6; }
+if { as_var=$as_ac_File; eval "test \"\${$as_var+set}\" = set"; }; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ test "$cross_compiling" = yes &&
+ { { echo "$as_me:$LINENO: error: cannot check for file existence when cross compiling" >&5
+echo "$as_me: error: cannot check for file existence when cross compiling" >&2;}
+ { (exit 1); exit 1; }; }
+if test -r "obj/$ARCHOS"; then
+ eval "$as_ac_File=yes"
+else
+ eval "$as_ac_File=no"
+fi
+fi
+ac_res=`eval echo '${'$as_ac_File'}'`
+ { echo "$as_me:$LINENO: result: $ac_res" >&5
+echo "${ECHO_T}$ac_res" >&6; }
+if test `eval echo '${'$as_ac_File'}'` = yes; then
+ :
+else
+ { echo "$as_me:$LINENO: result: creating obj/$ARCHOS" >&5
+echo "${ECHO_T}creating obj/$ARCHOS" >&6; };
+ mkdir -p obj/$ARCHOS
+fi
+
+
+
+LINUX_MSG="n/a"
+USE_LINUX="no"
+
+# Check whether --with-linux was given.
+if test "${with_linux+set}" = set; then
+ withval=$with_linux; if test "x$withval" = "x" ; then
+ { { echo "$as_me:$LINENO: error: No Linux kernel path provided" >&5
+echo "$as_me: error: No Linux kernel path provided" >&2;}
+ { (exit 1); exit 1; }; }
+ else
+ if test "x$withval" != "xno" ; then
+ USE_LINUX="yes"
+ LINUX_MSG="$withval"
+ LINUX_DIR="$withval"
+
+ fi
+ fi
+fi
+
+
+
+USE_MINE_OCT="no"
+
+# Check whether --with-mine-oct was given.
+if test "${with_mine_oct+set}" = set; then
+ withval=$with_mine_oct; USE_MINE_OCT="yes"
+fi
+
+
+
+USE_CVCL="no"
+
+# Check whether --with-cvcl was given.
+if test "${with_cvcl+set}" = set; then
+ withval=$with_cvcl; USE_CVCL="yes"
+fi
+
+
+
+USE_YICES="no"
+
+# Check whether --with-yices was given.
+if test "${with_yices+set}" = set; then
+ withval=$with_yices; USE_YICES="yes"
+fi
+
+
+
+USE_SATURN="no"
+
+# Check whether --with-saturn was given.
+if test "${with_saturn+set}" = set; then
+ withval=$with_saturn; if test "x$withval" = "x" ; then
+ { { echo "$as_me:$LINENO: error: No Saturn path provided" >&5
+echo "$as_me: error: No Saturn path provided" >&2;}
+ { (exit 1); exit 1; }; }
+ else
+ if test "x$withval" != "xno" ; then
+ USE_SATURN="yes"
+ SATURNHOME="$withval"
+
+ fi
+ fi
+fi
+
+
+
+#We can't use AC_CONFIG_SUBDIRS because it doesn't support adding new
+#flags (--with-zrapp):
+# AC_CONFIG_SUBDIRS(cil)
+if test -f cil/configure; then
+ { echo "$as_me:$LINENO: Configuring CIL:" >&5
+echo "$as_me: Configuring CIL:" >&6;};
+ cd cil; ./configure --with-zrapp; cd ..
+else
+ { { echo "$as_me:$LINENO: error: Missing the CIL directory" >&5
+echo "$as_me: error: Missing the CIL directory" >&2;}
+ { (exit 1); exit 1; }; }
+fi
+
+
+
+
+
+
+
+
+
+
+# finish the configure script and generate various files; ./configure
+# will apply variable substitutions to <filename>.in to generate <filename>;
+# I find it useful to mark generated files as read-only so I don't
+# accidentally edit them (and them lose my changes when ./configure
+# runs again); I had originally done the chmod after AC_OUTPUT, but
+# the problem is then the chmod doesn't run inside ./config.status
+
+# MY_AC_CONFIG_FILES(filename)
+# do AC_CONFIG_FILES(filename, chmod a-w filename)
+
+
+
+{
+ if test -f Makefile.in; then
+ ac_config_files="$ac_config_files Makefile"
+
+ else
+ true
+ #echo "skipping [Makefile] because it's not in this distribution"
+ fi
+}
+{
+ if test -f test/Makefile.in; then
+ ac_config_files="$ac_config_files test/Makefile"
+
+ else
+ true
+ #echo "skipping [test/Makefile] because it's not in this distribution"
+ fi
+}
+{
+ if test -f doc/index.html.in; then
+ ac_config_files="$ac_config_files doc/index.html"
+
+ else
+ true
+ #echo "skipping [doc/index.html] because it's not in this distribution"
+ fi
+}
+{
+ if test -f doc/header.html.in; then
+ ac_config_files="$ac_config_files doc/header.html"
+
+ else
+ true
+ #echo "skipping [doc/header.html] because it's not in this distribution"
+ fi
+}
+
+cat >confcache <<\_ACEOF
+# This file is a shell script that caches the results of configure
+# tests run on this system so they can be shared between configure
+# scripts and configure runs, see configure's option --config-cache.
+# It is not useful on other systems. If it contains results you don't
+# want to keep, you may remove or edit it.
+#
+# config.status only pays attention to the cache file if you give it
+# the --recheck option to rerun configure.
+#
+# `ac_cv_env_foo' variables (set or unset) will be overridden when
+# loading this file, other *unset* `ac_cv_foo' will be assigned the
+# following values.
+
+_ACEOF
+
+# The following way of writing the cache mishandles newlines in values,
+# but we know of no workaround that is simple, portable, and efficient.
+# So, we kill variables containing newlines.
+# Ultrix sh set writes to stderr and can't be redirected directly,
+# and sets the high bit in the cache file unless we assign to the vars.
+(
+ for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do
+ eval ac_val=\$$ac_var
+ case $ac_val in #(
+ *${as_nl}*)
+ case $ac_var in #(
+ *_cv_*) { echo "$as_me:$LINENO: WARNING: Cache variable $ac_var contains a newline." >&5
+echo "$as_me: WARNING: Cache variable $ac_var contains a newline." >&2;} ;;
+ esac
+ case $ac_var in #(
+ _ | IFS | as_nl) ;; #(
+ *) $as_unset $ac_var ;;
+ esac ;;
+ esac
+ done
+
+ (set) 2>&1 |
+ case $as_nl`(ac_space=' '; set) 2>&1` in #(
+ *${as_nl}ac_space=\ *)
+ # `set' does not quote correctly, so add quotes (double-quote
+ # substitution turns \\\\ into \\, and sed turns \\ into \).
+ sed -n \
+ "s/'/'\\\\''/g;
+ s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p"
+ ;; #(
+ *)
+ # `set' quotes correctly as required by POSIX, so do not add quotes.
+ sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
+ ;;
+ esac |
+ sort
+) |
+ sed '
+ /^ac_cv_env_/b end
+ t clear
+ :clear
+ s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/
+ t end
+ s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/
+ :end' >>confcache
+if diff "$cache_file" confcache >/dev/null 2>&1; then :; else
+ if test -w "$cache_file"; then
+ test "x$cache_file" != "x/dev/null" &&
+ { echo "$as_me:$LINENO: updating cache $cache_file" >&5
+echo "$as_me: updating cache $cache_file" >&6;}
+ cat confcache >$cache_file
+ else
+ { echo "$as_me:$LINENO: not updating unwritable cache $cache_file" >&5
+echo "$as_me: not updating unwritable cache $cache_file" >&6;}
+ fi
+fi
+rm -f confcache
+
+test "x$prefix" = xNONE && prefix=$ac_default_prefix
+# Let make expand exec_prefix.
+test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'
+
+# Transform confdefs.h into DEFS.
+# Protect against shell expansion while executing Makefile rules.
+# Protect against Makefile macro expansion.
+#
+# If the first sed substitution is executed (which looks for macros that
+# take arguments), then branch to the quote section. Otherwise,
+# look for a macro that doesn't take arguments.
+ac_script='
+t clear
+:clear
+s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g
+t quote
+s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g
+t quote
+b any
+:quote
+s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g
+s/\[/\\&/g
+s/\]/\\&/g
+s/\$/$$/g
+H
+:any
+${
+ g
+ s/^\n//
+ s/\n/ /g
+ p
+}
+'
+DEFS=`sed -n "$ac_script" confdefs.h`
+
+
+ac_libobjs=
+ac_ltlibobjs=
+for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue
+ # 1. Remove the extension, and $U if already installed.
+ ac_script='s/\$U\././;s/\.o$//;s/\.obj$//'
+ ac_i=`echo "$ac_i" | sed "$ac_script"`
+ # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR
+ # will be set to the directory where LIBOBJS objects are built.
+ ac_libobjs="$ac_libobjs \${LIBOBJDIR}$ac_i\$U.$ac_objext"
+ ac_ltlibobjs="$ac_ltlibobjs \${LIBOBJDIR}$ac_i"'$U.lo'
+done
+LIBOBJS=$ac_libobjs
+
+LTLIBOBJS=$ac_ltlibobjs
+
+
+
+: ${CONFIG_STATUS=./config.status}
+ac_clean_files_save=$ac_clean_files
+ac_clean_files="$ac_clean_files $CONFIG_STATUS"
+{ echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5
+echo "$as_me: creating $CONFIG_STATUS" >&6;}
+cat >$CONFIG_STATUS <<_ACEOF
+#! $SHELL
+# Generated by $as_me.
+# Run this file to recreate the current configuration.
+# Compiler output produced by configure, useful for debugging
+# configure, is in config.log if it exists.
+
+debug=false
+ac_cs_recheck=false
+ac_cs_silent=false
+SHELL=\${CONFIG_SHELL-$SHELL}
+_ACEOF
+
+cat >>$CONFIG_STATUS <<\_ACEOF
+## --------------------- ##
+## M4sh Initialization. ##
+## --------------------- ##
+
+# Be more Bourne compatible
+DUALCASE=1; export DUALCASE # for MKS sh
+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
+ emulate sh
+ NULLCMD=:
+ # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
+ # is contrary to our usage. Disable this feature.
+ alias -g '${1+"$@"}'='"$@"'
+ setopt NO_GLOB_SUBST
+else
+ case `(set -o) 2>/dev/null` in
+ *posix*) set -o posix ;;
+esac
+
+fi
+
+
+
+
+# PATH needs CR
+# Avoid depending upon Character Ranges.
+as_cr_letters='abcdefghijklmnopqrstuvwxyz'
+as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
+as_cr_Letters=$as_cr_letters$as_cr_LETTERS
+as_cr_digits='0123456789'
+as_cr_alnum=$as_cr_Letters$as_cr_digits
+
+# The user is always right.
+if test "${PATH_SEPARATOR+set}" != set; then
+ echo "#! /bin/sh" >conf$$.sh
+ echo "exit 0" >>conf$$.sh
+ chmod +x conf$$.sh
+ if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then
+ PATH_SEPARATOR=';'
+ else
+ PATH_SEPARATOR=:
+ fi
+ rm -f conf$$.sh
+fi
+
+# Support unset when possible.
+if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then
+ as_unset=unset
+else
+ as_unset=false
+fi
+
+
+# IFS
+# We need space, tab and new line, in precisely that order. Quoting is
+# there to prevent editors from complaining about space-tab.
+# (If _AS_PATH_WALK were called with IFS unset, it would disable word
+# splitting by setting IFS to empty value.)
+as_nl='
+'
+IFS=" "" $as_nl"
+
+# Find who we are. Look in the path if we contain no directory separator.
+case $0 in
+ *[\\/]* ) as_myself=$0 ;;
+ *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break
+done
+IFS=$as_save_IFS
+
+ ;;
+esac
+# We did not find ourselves, most probably we were run as `sh COMMAND'
+# in which case we are not to be found in the path.
+if test "x$as_myself" = x; then
+ as_myself=$0
+fi
+if test ! -f "$as_myself"; then
+ echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
+ { (exit 1); exit 1; }
+fi
+
+# Work around bugs in pre-3.0 UWIN ksh.
+for as_var in ENV MAIL MAILPATH
+do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var
+done
+PS1='$ '
+PS2='> '
+PS4='+ '
+
+# NLS nuisances.
+for as_var in \
+ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \
+ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \
+ LC_TELEPHONE LC_TIME
+do
+ if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then
+ eval $as_var=C; export $as_var
+ else
+ ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var
+ fi
+done
+
+# Required to use basename.
+if expr a : '\(a\)' >/dev/null 2>&1 &&
+ test "X`expr 00001 : '.*\(...\)'`" = X001; then
+ as_expr=expr
+else
+ as_expr=false
+fi
+
+if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then
+ as_basename=basename
+else
+ as_basename=false
+fi
+
+
+# Name of the executable.
+as_me=`$as_basename -- "$0" ||
+$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
+ X"$0" : 'X\(//\)$' \| \
+ X"$0" : 'X\(/\)' \| . 2>/dev/null ||
+echo X/"$0" |
+ sed '/^.*\/\([^/][^/]*\)\/*$/{
+ s//\1/
+ q
+ }
+ /^X\/\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\/\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+
+# CDPATH.
+$as_unset CDPATH
+
+
+
+ as_lineno_1=$LINENO
+ as_lineno_2=$LINENO
+ test "x$as_lineno_1" != "x$as_lineno_2" &&
+ test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || {
+
+ # Create $as_me.lineno as a copy of $as_myself, but with $LINENO
+ # uniformly replaced by the line number. The first 'sed' inserts a
+ # line-number line after each line using $LINENO; the second 'sed'
+ # does the real work. The second script uses 'N' to pair each
+ # line-number line with the line containing $LINENO, and appends
+ # trailing '-' during substitution so that $LINENO is not a special
+ # case at line end.
+ # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the
+ # scripts with optimization help from Paolo Bonzini. Blame Lee
+ # E. McMahon (1931-1989) for sed's syntax. :-)
+ sed -n '
+ p
+ /[$]LINENO/=
+ ' <$as_myself |
+ sed '
+ s/[$]LINENO.*/&-/
+ t lineno
+ b
+ :lineno
+ N
+ :loop
+ s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/
+ t loop
+ s/-\n.*//
+ ' >$as_me.lineno &&
+ chmod +x "$as_me.lineno" ||
+ { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2
+ { (exit 1); exit 1; }; }
+
+ # Don't try to exec as it changes $[0], causing all sort of problems
+ # (the dirname of $[0] is not the place where we might find the
+ # original and so on. Autoconf is especially sensitive to this).
+ . "./$as_me.lineno"
+ # Exit status is that of the last command.
+ exit
+}
+
+
+if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then
+ as_dirname=dirname
+else
+ as_dirname=false
+fi
+
+ECHO_C= ECHO_N= ECHO_T=
+case `echo -n x` in
+-n*)
+ case `echo 'x\c'` in
+ *c*) ECHO_T=' ';; # ECHO_T is single tab character.
+ *) ECHO_C='\c';;
+ esac;;
+*)
+ ECHO_N='-n';;
+esac
+
+if expr a : '\(a\)' >/dev/null 2>&1 &&
+ test "X`expr 00001 : '.*\(...\)'`" = X001; then
+ as_expr=expr
+else
+ as_expr=false
+fi
+
+rm -f conf$$ conf$$.exe conf$$.file
+if test -d conf$$.dir; then
+ rm -f conf$$.dir/conf$$.file
+else
+ rm -f conf$$.dir
+ mkdir conf$$.dir
+fi
+echo >conf$$.file
+if ln -s conf$$.file conf$$ 2>/dev/null; then
+ as_ln_s='ln -s'
+ # ... but there are two gotchas:
+ # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.
+ # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.
+ # In both cases, we have to default to `cp -p'.
+ ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
+ as_ln_s='cp -p'
+elif ln conf$$.file conf$$ 2>/dev/null; then
+ as_ln_s=ln
+else
+ as_ln_s='cp -p'
+fi
+rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
+rmdir conf$$.dir 2>/dev/null
+
+if mkdir -p . 2>/dev/null; then
+ as_mkdir_p=:
+else
+ test -d ./-p && rmdir ./-p
+ as_mkdir_p=false
+fi
+
+if test -x / >/dev/null 2>&1; then
+ as_test_x='test -x'
+else
+ if ls -dL / >/dev/null 2>&1; then
+ as_ls_L_option=L
+ else
+ as_ls_L_option=
+ fi
+ as_test_x='
+ eval sh -c '\''
+ if test -d "$1"; then
+ test -d "$1/.";
+ else
+ case $1 in
+ -*)set "./$1";;
+ esac;
+ case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in
+ ???[sx]*):;;*)false;;esac;fi
+ '\'' sh
+ '
+fi
+as_executable_p=$as_test_x
+
+# Sed expression to map a string onto a valid CPP name.
+as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
+
+# Sed expression to map a string onto a valid variable name.
+as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"
+
+
+exec 6>&1
+
+# Save the log message, to keep $[0] and so on meaningful, and to
+# report actual input values of CONFIG_FILES etc. instead of their
+# values after options handling.
+ac_log="
+This file was extended by $as_me, which was
+generated by GNU Autoconf 2.61. Invocation command line was
+
+ CONFIG_FILES = $CONFIG_FILES
+ CONFIG_HEADERS = $CONFIG_HEADERS
+ CONFIG_LINKS = $CONFIG_LINKS
+ CONFIG_COMMANDS = $CONFIG_COMMANDS
+ $ $0 $@
+
+on `(hostname || uname -n) 2>/dev/null | sed 1q`
+"
+
+_ACEOF
+
+cat >>$CONFIG_STATUS <<_ACEOF
+# Files that config.status was made for.
+config_files="$ac_config_files"
+
+_ACEOF
+
+cat >>$CONFIG_STATUS <<\_ACEOF
+ac_cs_usage="\
+\`$as_me' instantiates files from templates according to the
+current configuration.
+
+Usage: $0 [OPTIONS] [FILE]...
+
+ -h, --help print this help, then exit
+ -V, --version print version number and configuration settings, then exit
+ -q, --quiet do not print progress messages
+ -d, --debug don't remove temporary files
+ --recheck update $as_me by reconfiguring in the same conditions
+ --file=FILE[:TEMPLATE]
+ instantiate the configuration file FILE
+
+Configuration files:
+$config_files
+
+Report bugs to <bug-autoconf@gnu.org>."
+
+_ACEOF
+cat >>$CONFIG_STATUS <<_ACEOF
+ac_cs_version="\\
+config.status
+configured by $0, generated by GNU Autoconf 2.61,
+ with options \\"`echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\"
+
+Copyright (C) 2006 Free Software Foundation, Inc.
+This config.status script is free software; the Free Software Foundation
+gives unlimited permission to copy, distribute and modify it."
+
+ac_pwd='$ac_pwd'
+srcdir='$srcdir'
+INSTALL='$INSTALL'
+_ACEOF
+
+cat >>$CONFIG_STATUS <<\_ACEOF
+# If no file are specified by the user, then we need to provide default
+# value. By we need to know if files were specified by the user.
+ac_need_defaults=:
+while test $# != 0
+do
+ case $1 in
+ --*=*)
+ ac_option=`expr "X$1" : 'X\([^=]*\)='`
+ ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'`
+ ac_shift=:
+ ;;
+ *)
+ ac_option=$1
+ ac_optarg=$2
+ ac_shift=shift
+ ;;
+ esac
+
+ case $ac_option in
+ # Handling of the options.
+ -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
+ ac_cs_recheck=: ;;
+ --version | --versio | --versi | --vers | --ver | --ve | --v | -V )
+ echo "$ac_cs_version"; exit ;;
+ --debug | --debu | --deb | --de | --d | -d )
+ debug=: ;;
+ --file | --fil | --fi | --f )
+ $ac_shift
+ CONFIG_FILES="$CONFIG_FILES $ac_optarg"
+ ac_need_defaults=false;;
+ --he | --h | --help | --hel | -h )
+ echo "$ac_cs_usage"; exit ;;
+ -q | -quiet | --quiet | --quie | --qui | --qu | --q \
+ | -silent | --silent | --silen | --sile | --sil | --si | --s)
+ ac_cs_silent=: ;;
+
+ # This is an error.
+ -*) { echo "$as_me: error: unrecognized option: $1
+Try \`$0 --help' for more information." >&2
+ { (exit 1); exit 1; }; } ;;
+
+ *) ac_config_targets="$ac_config_targets $1"
+ ac_need_defaults=false ;;
+
+ esac
+ shift
+done
+
+ac_configure_extra_args=
+
+if $ac_cs_silent; then
+ exec 6>/dev/null
+ ac_configure_extra_args="$ac_configure_extra_args --silent"
+fi
+
+_ACEOF
+cat >>$CONFIG_STATUS <<_ACEOF
+if \$ac_cs_recheck; then
+ echo "running CONFIG_SHELL=$SHELL $SHELL $0 "$ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6
+ CONFIG_SHELL=$SHELL
+ export CONFIG_SHELL
+ exec $SHELL "$0"$ac_configure_args \$ac_configure_extra_args --no-create --no-recursion
+fi
+
+_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF
+exec 5>>config.log
+{
+ echo
+ sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX
+## Running $as_me. ##
+_ASBOX
+ echo "$ac_log"
+} >&5
+
+_ACEOF
+cat >>$CONFIG_STATUS <<_ACEOF
+_ACEOF
+
+cat >>$CONFIG_STATUS <<\_ACEOF
+
+# Handling of arguments.
+for ac_config_target in $ac_config_targets
+do
+ case $ac_config_target in
+ "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;
+ "test/Makefile") CONFIG_FILES="$CONFIG_FILES test/Makefile" ;;
+ "doc/index.html") CONFIG_FILES="$CONFIG_FILES doc/index.html" ;;
+ "doc/header.html") CONFIG_FILES="$CONFIG_FILES doc/header.html" ;;
+
+ *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5
+echo "$as_me: error: invalid argument: $ac_config_target" >&2;}
+ { (exit 1); exit 1; }; };;
+ esac
+done
+
+
+# If the user did not use the arguments to specify the items to instantiate,
+# then the envvar interface is used. Set only those that are not.
+# We use the long form for the default assignment because of an extremely
+# bizarre bug on SunOS 4.1.3.
+if $ac_need_defaults; then
+ test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files
+fi
+
+# Have a temporary directory for convenience. Make it in the build tree
+# simply because there is no reason against having it here, and in addition,
+# creating and moving files from /tmp can sometimes cause problems.
+# Hook for its removal unless debugging.
+# Note that there is a small window in which the directory will not be cleaned:
+# after its creation but before its name has been assigned to `$tmp'.
+$debug ||
+{
+ tmp=
+ trap 'exit_status=$?
+ { test -z "$tmp" || test ! -d "$tmp" || rm -fr "$tmp"; } && exit $exit_status
+' 0
+ trap '{ (exit 1); exit 1; }' 1 2 13 15
+}
+# Create a (secure) tmp directory for tmp files.
+
+{
+ tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` &&
+ test -n "$tmp" && test -d "$tmp"
+} ||
+{
+ tmp=./conf$$-$RANDOM
+ (umask 077 && mkdir "$tmp")
+} ||
+{
+ echo "$me: cannot create a temporary directory in ." >&2
+ { (exit 1); exit 1; }
+}
+
+#
+# Set up the sed scripts for CONFIG_FILES section.
+#
+
+# No need to generate the scripts if there are no CONFIG_FILES.
+# This happens for instance when ./config.status config.h
+if test -n "$CONFIG_FILES"; then
+
+_ACEOF
+
+
+
+ac_delim='%!_!# '
+for ac_last_try in false false false false false :; do
+ cat >conf$$subs.sed <<_ACEOF
+SHELL!$SHELL$ac_delim
+PATH_SEPARATOR!$PATH_SEPARATOR$ac_delim
+PACKAGE_NAME!$PACKAGE_NAME$ac_delim
+PACKAGE_TARNAME!$PACKAGE_TARNAME$ac_delim
+PACKAGE_VERSION!$PACKAGE_VERSION$ac_delim
+PACKAGE_STRING!$PACKAGE_STRING$ac_delim
+PACKAGE_BUGREPORT!$PACKAGE_BUGREPORT$ac_delim
+exec_prefix!$exec_prefix$ac_delim
+prefix!$prefix$ac_delim
+program_transform_name!$program_transform_name$ac_delim
+bindir!$bindir$ac_delim
+sbindir!$sbindir$ac_delim
+libexecdir!$libexecdir$ac_delim
+datarootdir!$datarootdir$ac_delim
+datadir!$datadir$ac_delim
+sysconfdir!$sysconfdir$ac_delim
+sharedstatedir!$sharedstatedir$ac_delim
+localstatedir!$localstatedir$ac_delim
+includedir!$includedir$ac_delim
+oldincludedir!$oldincludedir$ac_delim
+docdir!$docdir$ac_delim
+infodir!$infodir$ac_delim
+htmldir!$htmldir$ac_delim
+dvidir!$dvidir$ac_delim
+pdfdir!$pdfdir$ac_delim
+psdir!$psdir$ac_delim
+libdir!$libdir$ac_delim
+localedir!$localedir$ac_delim
+mandir!$mandir$ac_delim
+DEFS!$DEFS$ac_delim
+ECHO_C!$ECHO_C$ac_delim
+ECHO_N!$ECHO_N$ac_delim
+ECHO_T!$ECHO_T$ac_delim
+LIBS!$LIBS$ac_delim
+build_alias!$build_alias$ac_delim
+host_alias!$host_alias$ac_delim
+target_alias!$target_alias$ac_delim
+CC!$CC$ac_delim
+CFLAGS!$CFLAGS$ac_delim
+LDFLAGS!$LDFLAGS$ac_delim
+CPPFLAGS!$CPPFLAGS$ac_delim
+ac_ct_CC!$ac_ct_CC$ac_delim
+EXEEXT!$EXEEXT$ac_delim
+OBJEXT!$OBJEXT$ac_delim
+INSTALL_PROGRAM!$INSTALL_PROGRAM$ac_delim
+INSTALL_SCRIPT!$INSTALL_SCRIPT$ac_delim
+INSTALL_DATA!$INSTALL_DATA$ac_delim
+build!$build$ac_delim
+build_cpu!$build_cpu$ac_delim
+build_vendor!$build_vendor$ac_delim
+build_os!$build_os$ac_delim
+host!$host$ac_delim
+host_cpu!$host_cpu$ac_delim
+host_vendor!$host_vendor$ac_delim
+host_os!$host_os$ac_delim
+target!$target$ac_delim
+target_cpu!$target_cpu$ac_delim
+target_vendor!$target_vendor$ac_delim
+target_os!$target_os$ac_delim
+LINUX_DIR!$LINUX_DIR$ac_delim
+USE_LINUX!$USE_LINUX$ac_delim
+USE_MINE_OCT!$USE_MINE_OCT$ac_delim
+USE_CVCL!$USE_CVCL$ac_delim
+USE_YICES!$USE_YICES$ac_delim
+SATURNHOME!$SATURNHOME$ac_delim
+USE_SATURN!$USE_SATURN$ac_delim
+ARCHOS!$ARCHOS$ac_delim
+DEPUTYHOME!$DEPUTYHOME$ac_delim
+DEFAULT_CIL_MODE!$DEFAULT_CIL_MODE$ac_delim
+DEPUTY_VERSION!$DEPUTY_VERSION$ac_delim
+CVCLLIB!$CVCLLIB$ac_delim
+CVCLINC!$CVCLINC$ac_delim
+OCAMLINC!$OCAMLINC$ac_delim
+LIBOBJS!$LIBOBJS$ac_delim
+LTLIBOBJS!$LTLIBOBJS$ac_delim
+_ACEOF
+
+ if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 75; then
+ break
+ elif $ac_last_try; then
+ { { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5
+echo "$as_me: error: could not make $CONFIG_STATUS" >&2;}
+ { (exit 1); exit 1; }; }
+ else
+ ac_delim="$ac_delim!$ac_delim _$ac_delim!! "
+ fi
+done
+
+ac_eof=`sed -n '/^CEOF[0-9]*$/s/CEOF/0/p' conf$$subs.sed`
+if test -n "$ac_eof"; then
+ ac_eof=`echo "$ac_eof" | sort -nru | sed 1q`
+ ac_eof=`expr $ac_eof + 1`
+fi
+
+cat >>$CONFIG_STATUS <<_ACEOF
+cat >"\$tmp/subs-1.sed" <<\CEOF$ac_eof
+/@[a-zA-Z_][a-zA-Z_0-9]*@/!b end
+_ACEOF
+sed '
+s/[,\\&]/\\&/g; s/@/@|#_!!_#|/g
+s/^/s,@/; s/!/@,|#_!!_#|/
+:n
+t n
+s/'"$ac_delim"'$/,g/; t
+s/$/\\/; p
+N; s/^.*\n//; s/[,\\&]/\\&/g; s/@/@|#_!!_#|/g; b n
+' >>$CONFIG_STATUS <conf$$subs.sed
+rm -f conf$$subs.sed
+cat >>$CONFIG_STATUS <<_ACEOF
+:end
+s/|#_!!_#|//g
+CEOF$ac_eof
+_ACEOF
+
+
+# VPATH may cause trouble with some makes, so we remove $(srcdir),
+# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and
+# trailing colons and then remove the whole line if VPATH becomes empty
+# (actually we leave an empty line to preserve line numbers).
+if test "x$srcdir" = x.; then
+ ac_vpsub='/^[ ]*VPATH[ ]*=/{
+s/:*\$(srcdir):*/:/
+s/:*\${srcdir}:*/:/
+s/:*@srcdir@:*/:/
+s/^\([^=]*=[ ]*\):*/\1/
+s/:*$//
+s/^[^=]*=[ ]*$//
+}'
+fi
+
+cat >>$CONFIG_STATUS <<\_ACEOF
+fi # test -n "$CONFIG_FILES"
+
+
+for ac_tag in :F $CONFIG_FILES
+do
+ case $ac_tag in
+ :[FHLC]) ac_mode=$ac_tag; continue;;
+ esac
+ case $ac_mode$ac_tag in
+ :[FHL]*:*);;
+ :L* | :C*:*) { { echo "$as_me:$LINENO: error: Invalid tag $ac_tag." >&5
+echo "$as_me: error: Invalid tag $ac_tag." >&2;}
+ { (exit 1); exit 1; }; };;
+ :[FH]-) ac_tag=-:-;;
+ :[FH]*) ac_tag=$ac_tag:$ac_tag.in;;
+ esac
+ ac_save_IFS=$IFS
+ IFS=:
+ set x $ac_tag
+ IFS=$ac_save_IFS
+ shift
+ ac_file=$1
+ shift
+
+ case $ac_mode in
+ :L) ac_source=$1;;
+ :[FH])
+ ac_file_inputs=
+ for ac_f
+ do
+ case $ac_f in
+ -) ac_f="$tmp/stdin";;
+ *) # Look for the file first in the build tree, then in the source tree
+ # (if the path is not absolute). The absolute path cannot be DOS-style,
+ # because $ac_f cannot contain `:'.
+ test -f "$ac_f" ||
+ case $ac_f in
+ [\\/$]*) false;;
+ *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";;
+ esac ||
+ { { echo "$as_me:$LINENO: error: cannot find input file: $ac_f" >&5
+echo "$as_me: error: cannot find input file: $ac_f" >&2;}
+ { (exit 1); exit 1; }; };;
+ esac
+ ac_file_inputs="$ac_file_inputs $ac_f"
+ done
+
+ # Let's still pretend it is `configure' which instantiates (i.e., don't
+ # use $as_me), people would be surprised to read:
+ # /* config.h. Generated by config.status. */
+ configure_input="Generated from "`IFS=:
+ echo $* | sed 's|^[^:]*/||;s|:[^:]*/|, |g'`" by configure."
+ if test x"$ac_file" != x-; then
+ configure_input="$ac_file. $configure_input"
+ { echo "$as_me:$LINENO: creating $ac_file" >&5
+echo "$as_me: creating $ac_file" >&6;}
+ fi
+
+ case $ac_tag in
+ *:-:* | *:-) cat >"$tmp/stdin";;
+ esac
+ ;;
+ esac
+
+ ac_dir=`$as_dirname -- "$ac_file" ||
+$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$ac_file" : 'X\(//\)[^/]' \| \
+ X"$ac_file" : 'X\(//\)$' \| \
+ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null ||
+echo X"$ac_file" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)[^/].*/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+ { as_dir="$ac_dir"
+ case $as_dir in #(
+ -*) as_dir=./$as_dir;;
+ esac
+ test -d "$as_dir" || { $as_mkdir_p && mkdir -p "$as_dir"; } || {
+ as_dirs=
+ while :; do
+ case $as_dir in #(
+ *\'*) as_qdir=`echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #(
+ *) as_qdir=$as_dir;;
+ esac
+ as_dirs="'$as_qdir' $as_dirs"
+ as_dir=`$as_dirname -- "$as_dir" ||
+$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$as_dir" : 'X\(//\)[^/]' \| \
+ X"$as_dir" : 'X\(//\)$' \| \
+ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||
+echo X"$as_dir" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)[^/].*/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+ test -d "$as_dir" && break
+ done
+ test -z "$as_dirs" || eval "mkdir $as_dirs"
+ } || test -d "$as_dir" || { { echo "$as_me:$LINENO: error: cannot create directory $as_dir" >&5
+echo "$as_me: error: cannot create directory $as_dir" >&2;}
+ { (exit 1); exit 1; }; }; }
+ ac_builddir=.
+
+case "$ac_dir" in
+.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
+*)
+ ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'`
+ # A ".." for each directory in $ac_dir_suffix.
+ ac_top_builddir_sub=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,/..,g;s,/,,'`
+ case $ac_top_builddir_sub in
+ "") ac_top_builddir_sub=. ac_top_build_prefix= ;;
+ *) ac_top_build_prefix=$ac_top_builddir_sub/ ;;
+ esac ;;
+esac
+ac_abs_top_builddir=$ac_pwd
+ac_abs_builddir=$ac_pwd$ac_dir_suffix
+# for backward compatibility:
+ac_top_builddir=$ac_top_build_prefix
+
+case $srcdir in
+ .) # We are building in place.
+ ac_srcdir=.
+ ac_top_srcdir=$ac_top_builddir_sub
+ ac_abs_top_srcdir=$ac_pwd ;;
+ [\\/]* | ?:[\\/]* ) # Absolute name.
+ ac_srcdir=$srcdir$ac_dir_suffix;
+ ac_top_srcdir=$srcdir
+ ac_abs_top_srcdir=$srcdir ;;
+ *) # Relative name.
+ ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix
+ ac_top_srcdir=$ac_top_build_prefix$srcdir
+ ac_abs_top_srcdir=$ac_pwd/$srcdir ;;
+esac
+ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix
+
+
+ case $ac_mode in
+ :F)
+ #
+ # CONFIG_FILE
+ #
+
+ case $INSTALL in
+ [\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;;
+ *) ac_INSTALL=$ac_top_build_prefix$INSTALL ;;
+ esac
+_ACEOF
+
+cat >>$CONFIG_STATUS <<\_ACEOF
+# If the template does not know about datarootdir, expand it.
+# FIXME: This hack should be removed a few years after 2.60.
+ac_datarootdir_hack=; ac_datarootdir_seen=
+
+case `sed -n '/datarootdir/ {
+ p
+ q
+}
+/@datadir@/p
+/@docdir@/p
+/@infodir@/p
+/@localedir@/p
+/@mandir@/p
+' $ac_file_inputs` in
+*datarootdir*) ac_datarootdir_seen=yes;;
+*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*)
+ { echo "$as_me:$LINENO: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5
+echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;}
+_ACEOF
+cat >>$CONFIG_STATUS <<_ACEOF
+ ac_datarootdir_hack='
+ s&@datadir@&$datadir&g
+ s&@docdir@&$docdir&g
+ s&@infodir@&$infodir&g
+ s&@localedir@&$localedir&g
+ s&@mandir@&$mandir&g
+ s&\\\${datarootdir}&$datarootdir&g' ;;
+esac
+_ACEOF
+
+# Neutralize VPATH when `$srcdir' = `.'.
+# Shell code in configure.ac might set extrasub.
+# FIXME: do we really want to maintain this feature?
+cat >>$CONFIG_STATUS <<_ACEOF
+ sed "$ac_vpsub
+$extrasub
+_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF
+:t
+/@[a-zA-Z_][a-zA-Z_0-9]*@/!b
+s&@configure_input@&$configure_input&;t t
+s&@top_builddir@&$ac_top_builddir_sub&;t t
+s&@srcdir@&$ac_srcdir&;t t
+s&@abs_srcdir@&$ac_abs_srcdir&;t t
+s&@top_srcdir@&$ac_top_srcdir&;t t
+s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t
+s&@builddir@&$ac_builddir&;t t
+s&@abs_builddir@&$ac_abs_builddir&;t t
+s&@abs_top_builddir@&$ac_abs_top_builddir&;t t
+s&@INSTALL@&$ac_INSTALL&;t t
+$ac_datarootdir_hack
+" $ac_file_inputs | sed -f "$tmp/subs-1.sed" >$tmp/out
+
+test -z "$ac_datarootdir_hack$ac_datarootdir_seen" &&
+ { ac_out=`sed -n '/\${datarootdir}/p' "$tmp/out"`; test -n "$ac_out"; } &&
+ { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' "$tmp/out"`; test -z "$ac_out"; } &&
+ { echo "$as_me:$LINENO: WARNING: $ac_file contains a reference to the variable \`datarootdir'
+which seems to be undefined. Please make sure it is defined." >&5
+echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir'
+which seems to be undefined. Please make sure it is defined." >&2;}
+
+ rm -f "$tmp/stdin"
+ case $ac_file in
+ -) cat "$tmp/out"; rm -f "$tmp/out";;
+ *) rm -f "$ac_file"; mv "$tmp/out" $ac_file;;
+ esac
+ ;;
+
+
+
+ esac
+
+
+ case $ac_file$ac_mode in
+ "Makefile":F) chmod a-w Makefile ;;
+ "test/Makefile":F) chmod a-w test/Makefile ;;
+ "doc/index.html":F) chmod a-w doc/index.html ;;
+ "doc/header.html":F) chmod a-w doc/header.html ;;
+
+ esac
+done # for ac_tag
+
+
+{ (exit 0); exit 0; }
+_ACEOF
+chmod +x $CONFIG_STATUS
+ac_clean_files=$ac_clean_files_save
+
+
+# configure is writing to config.log, and then calls config.status.
+# config.status does its own redirection, appending to config.log.
+# Unfortunately, on DOS this fails, as config.log is still kept open
+# by configure, so config.status won't be able to write to it; its
+# output is simply discarded. So we exec the FD to /dev/null,
+# effectively closing config.log, so it can be properly (re)opened and
+# appended to by config.status. When coming back to configure, we
+# need to make the FD available again.
+if test "$no_create" != yes; then
+ ac_cs_success=:
+ ac_config_status_args=
+ test "$silent" = yes &&
+ ac_config_status_args="$ac_config_status_args --quiet"
+ exec 5>/dev/null
+ $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false
+ exec 5>>config.log
+ # Use ||, not &&, to avoid exiting from the if with $? = 1, which
+ # would make configure fail if this is the last instruction.
+ $ac_cs_success || { (exit 1); exit 1; }
+fi
+
+
+cat <<EOF
+
+Deputy configuration:
+ Deputy home: $DEPUTYHOME
+ Deputy version: $DEPUTY_VERSION
+ Linux path: $LINUX_MSG
+EOF
--- /dev/null
+# configure.in for Deputy -*- sh -*-
+AC_INIT(src/main.ml)
+AC_PREREQ(2.50)
+
+AC_PROG_CC
+AC_PROG_INSTALL
+
+AC_CANONICAL_SYSTEM
+
+DEPUTYHOME=`pwd`
+DEFAULT_CIL_MODE=GNUCC
+DEPUTY_VERSION=1.1
+
+CVCLLIB=/usr/local/lib
+CVCLINC=/usr/local/include
+
+YICESLIB=/usr/local/lib
+YICESINC=/usr/local/include
+
+OCAMLINC=/usr/lib/ocaml
+
+# make sure I haven't forgotten to run autoconf
+if test configure -ot configure.ac; then
+ AC_MSG_ERROR(configure is older than configure.ac; you forgot to run autoconf)
+fi
+
+case "$target" in
+ # Linux
+ *86*linux*|*86*openbsd*)
+ AC_MSG_RESULT(configuring for $target)
+ ARCHOS=x86_LINUX
+ ;;
+
+ # FreeBSD
+ *i386*freebsd*|*amd64*freebsd*)
+ if test x"${ARCH}" = x""; then
+ ARCH=`uname -p`
+ fi
+
+ AC_MSG_RESULT(configuring for $target)
+ ARCHOS=${ARCH}_FREEBSD
+ ;;
+
+ # Mac OS X
+ *86*darwin*)
+ AC_MSG_RESULT(configuring for $target)
+ ARCHOS=x86_DARWIN
+ ;;
+
+ # Cygwin
+ *86*cygwin*)
+ AC_MSG_RESULT(configuring for $target)
+ ARCHOS=x86_WIN32
+
+ # override DEPUTYHOME; even on cygwin we want forward slashes
+ # sm: I folded this into what I hope will be the only
+ # case-analysis of machine type
+ # DEPUTYHOME=`cygpath -wa "$DEPUTYHOME" | sed -e "s/\\\\\/\\//g"`
+ # Try to use the Unix paths even on cygwin. The newest versions of make
+ # do not like colons in file names
+ DEPUTYHOME=`cygpath -u "$DEPUTYHOME"`
+ CC=`which $CC`
+ CC=`cygpath -wa "$CC" | sed -e "s/\\\\\/\\//g"`
+ ;;
+
+ *)
+ AC_MSG_ERROR([
+ Unsupported platform $target -- sorry.
+ ./configure supports these platforms:
+ on x86: Linux, Cygwin, FreeBSD, OpenBSD, Darwin
+ ])
+ ;;
+esac
+
+AC_CHECK_FILE(obj/$ARCHOS,, AC_MSG_RESULT(creating obj/$ARCHOS);
+ mkdir -p obj/$ARCHOS)
+
+
+LINUX_MSG="n/a"
+USE_LINUX="no"
+AC_ARG_WITH(linux,
+ [ --with-linux[[=PATH]] enable Linux kernel support],
+ [ if test "x$withval" = "x" ; then
+ AC_MSG_ERROR([No Linux kernel path provided])
+ else
+ if test "x$withval" != "xno" ; then
+ USE_LINUX="yes"
+ LINUX_MSG="$withval"
+ LINUX_DIR="$withval"
+ AC_SUBST(LINUX_DIR)
+ fi
+ fi ])
+AC_SUBST(USE_LINUX)
+
+USE_MINE_OCT="no"
+AC_ARG_WITH(mine-oct,
+ [ --with-mine-oct use Mine's Octagon library],
+ [ USE_MINE_OCT="yes"])
+AC_SUBST(USE_MINE_OCT)
+
+USE_CVCL="no"
+AC_ARG_WITH(cvcl,
+ [ --with-cvcl use the CVCL solver],
+ [ USE_CVCL="yes"])
+AC_SUBST(USE_CVCL)
+
+USE_YICES="no"
+AC_ARG_WITH(yices,
+ [ --with-yices use the Yices solver],
+ [ USE_YICES="yes"])
+AC_SUBST(USE_YICES)
+
+USE_SATURN="no"
+AC_ARG_WITH(saturn,
+ [ --with-saturn[[=PATH]] enable use of Saturn analysis],
+ [ if test "x$withval" = "x" ; then
+ AC_MSG_ERROR([No Saturn path provided])
+ else
+ if test "x$withval" != "xno" ; then
+ USE_SATURN="yes"
+ SATURNHOME="$withval"
+ AC_SUBST(SATURNHOME)
+ fi
+ fi ])
+AC_SUBST(USE_SATURN)
+
+#We can't use AC_CONFIG_SUBDIRS because it doesn't support adding new
+#flags (--with-zrapp):
+# AC_CONFIG_SUBDIRS(cil)
+if test -f cil/configure; then
+ AC_MSG_NOTICE(Configuring CIL:);
+ cd cil; ./configure --with-zrapp; cd ..
+else
+ AC_MSG_ERROR(Missing the CIL directory)
+fi
+
+
+AC_SUBST(ARCHOS)
+AC_SUBST(DEPUTYHOME)
+AC_SUBST(DEFAULT_CIL_MODE)
+AC_SUBST(DEPUTY_VERSION)
+AC_SUBST(CVCLLIB)
+AC_SUBST(CVCLINC)
+AC_SUBST(OCAMLINC)
+
+# finish the configure script and generate various files; ./configure
+# will apply variable substitutions to <filename>.in to generate <filename>;
+# I find it useful to mark generated files as read-only so I don't
+# accidentally edit them (and them lose my changes when ./configure
+# runs again); I had originally done the chmod after AC_OUTPUT, but
+# the problem is then the chmod doesn't run inside ./config.status
+
+# MY_AC_CONFIG_FILES(filename)
+# do AC_CONFIG_FILES(filename, chmod a-w filename)
+define([MY_AC_CONFIG_FILES],
+[{
+ if test -f [$1].in; then
+ AC_CONFIG_FILES([$1], chmod a-w [$1])
+ else
+ true
+ #echo "skipping [$1] because it's not in this distribution"
+ fi
+}])
+define([MY_AC_CONFIG_EXE_FILES],
+[{
+ if test -f [$1].in; then
+ AC_CONFIG_FILES([$1], [chmod a-w,a+x $1])
+ else
+ true
+ #echo "skipping [$1] because it's not in this distribution"
+ fi
+}])
+
+MY_AC_CONFIG_FILES(Makefile)
+MY_AC_CONFIG_FILES(test/Makefile)
+MY_AC_CONFIG_FILES(doc/index.html)
+MY_AC_CONFIG_FILES(doc/header.html)
+
+AC_OUTPUT()
+
+cat <<EOF
+
+Deputy configuration:
+ Deputy home: $DEPUTYHOME
+ Deputy version: $DEPUTY_VERSION
+ Linux path: $LINUX_MSG
+EOF
--- /dev/null
+deputy (1.1-1) unstable; urgency=low
+
+ * Initial release.
+
+ -- Jeremy Condit <jcondit@cs.berkeley.edu> Wed, 10 Jan 2007 10:09:09 -0800
+
--- /dev/null
+Source: deputy
+Section: devel
+Priority: optional
+Maintainer: Jeremy Condit <jcondit@cs.berkeley.edu>
+Build-Depends: debhelper (>= 5), autotools-dev, ocaml (>= 3.08)
+Standards-Version: 3.7.2
+
+Package: deputy
+Architecture: any
+Depends: ${shlibs:Depends}, ${misc:Depends}, perl-base (>= 5.6.1), gcc (>= 4)
+Recommends: ocaml-interp (>= 3.08)
+Description: Advanced C compiler for enforcing type and memory safety
+ Advanced C compiler that uses type annotations to enforce type and memory
+ safety in existing C programs. Performs additional static checking, and
+ inserts run-time checks when static checking is insufficient.
--- /dev/null
+This package was debianized by Jeremy Condit <jcondit@cs.berkeley.edu> on
+Wed, 10 Jan 2007 10:09:09 -0800.
+
+It was downloaded from http://deputy.cs.berkeley.edu/
+
+Upstream Author: Jeremy Condit <jcondit@cs.berkeley.edu>
+
+Copyright: 2006-07 by Jeremy Condit, Matthew Harren, Zachary Anderson, and
+George C. Necula.
+
+License:
+
+Copyright (c) 2006-07,
+ Jeremy Condit <jcondit@cs.berkeley.edu>
+ Matthew Harren <matth@cs.berkeley.edu>
+ Zachary Anderson <zra@cs.berkeley.edu>
+ George C. Necula <necula@cs.berkeley.edu>
+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.
+
+
+(See http://www.opensource.org/licenses/bsd-license.php)
--- /dev/null
+deputy_1.1-1_i386.deb devel optional
--- /dev/null
+#!/usr/bin/make -f
+# -*- makefile -*-
+# Sample debian/rules that uses debhelper.
+# This file was originally written by Joey Hess and Craig Small.
+# As a special exception, when this file is copied by dh-make into a
+# dh-make output file, you may use that output file without restriction.
+# This special exception was added by Craig Small in version 0.37 of dh-make.
+
+# Uncomment this to turn on verbose mode.
+#export DH_VERBOSE=1
+
+
+# These are used for cross-compiling and for saving the configure script
+# from having to guess our platform (since we know it already)
+DEB_HOST_GNU_TYPE ?= $(shell dpkg-architecture -qDEB_HOST_GNU_TYPE)
+DEB_BUILD_GNU_TYPE ?= $(shell dpkg-architecture -qDEB_BUILD_GNU_TYPE)
+
+
+CFLAGS = -Wall -g
+
+ifneq (,$(findstring noopt,$(DEB_BUILD_OPTIONS)))
+ CFLAGS += -O0
+else
+ CFLAGS += -O2
+endif
+
+config.status: configure
+ dh_testdir
+ # Add here commands to configure the package.
+ ./configure --host=$(DEB_HOST_GNU_TYPE) --build=$(DEB_BUILD_GNU_TYPE) --prefix=/usr --mandir=\$${prefix}/share/man --infodir=\$${prefix}/share/info CFLAGS="$(CFLAGS)" LDFLAGS="-Wl,-z,defs"
+
+
+build: build-stamp
+
+build-stamp: config.status
+ dh_testdir
+
+ # Add here commands to compile the package.
+ $(MAKE)
+ #docbook-to-man debian/deputy.sgml > deputy.1
+
+ touch $@
+
+clean:
+ dh_testdir
+ dh_testroot
+ rm -f build-stamp
+
+ # Add here commands to clean up after the build process.
+ -$(MAKE) realclean
+ifneq "$(wildcard /usr/share/misc/config.sub)" ""
+ cp -f /usr/share/misc/config.sub config.sub
+endif
+ifneq "$(wildcard /usr/share/misc/config.guess)" ""
+ cp -f /usr/share/misc/config.guess config.guess
+endif
+
+
+ dh_clean
+
+install: build
+ dh_testdir
+ dh_testroot
+ dh_clean -k
+ dh_installdirs
+
+ # Add here commands to install the package into debian/deputy.
+ $(MAKE) prefix=$(CURDIR)/debian/deputy/usr install-base
+
+
+# Build architecture-independent files here.
+binary-indep: build install
+# We have nothing to do by default.
+
+# Build architecture-dependent files here.
+binary-arch: build install
+ dh_testdir
+ dh_testroot
+ dh_installchangelogs
+ dh_installdocs
+ dh_installexamples
+# dh_install
+# dh_installmenu
+# dh_installdebconf
+# dh_installlogrotate
+# dh_installemacsen
+# dh_installpam
+# dh_installmime
+# dh_python
+# dh_installinit
+# dh_installcron
+# dh_installinfo
+ dh_installman doc/deputy.1
+ dh_link
+ dh_strip
+ dh_compress
+ dh_fixperms
+# dh_perl
+# dh_makeshlibs
+ dh_installdeb
+ dh_shlibdeps
+ dh_gencontrol
+ dh_md5sums
+ dh_builddeb
+
+binary: binary-indep binary-arch
+.PHONY: build clean binary-indep binary-arch binary install
--- /dev/null
+# Example watch control file for uscan
+# Rename this file to "watch" and then you can run the "uscan" command
+# to check for upstream updates and more.
+# See uscan(1) for format
+
+# Compulsory line, this is a version 3 file
+version=3
+
+# Uncomment to examine a Webpage
+# <Webpage URL> <string match>
+http://deputy.cs.berkeley.edu/ deputy-(.*)\.tar\.gz
+
+# Uncomment to examine a Webserver directory
+#http://www.example.com/pub/deputy-(.*)\.tar\.gz
+
+# Uncommment to examine a FTP server
+#ftp://ftp.example.com/pub/deputy-(.*)\.tar\.gz debian uupdate
+
+# Uncomment to find new files on sourceforge, for debscripts >= 2.9
+# http://sf.net/deputy/deputy-(.*)\.tar\.gz
+
+
--- /dev/null
+*.mfj
+*.dvi
+*.aux
+*.ps
+*.log
+*.blg
+*.bbl
+*.lof
+*.lot
+*.toc
+*.pdf
+*.png
+*.out
+*.xyc
+*.xyd
+auto
+cil-api.tex
+deputy.version.tex
+deputypp.tex
+deputycode.tmp
+index.html
+header.html
\ No newline at end of file
--- /dev/null
+
+Deputy compiler
+- complain about functions without prototype
+
+
+Deputy run-time checks
+- compile the library with optimizations on (two versions)
+- efficient checking sequences without code-cache pollution
+
+
+Example:
+- in bh I had to turn the union into a struct because fields were used
+differently in different stages of the computation. I should be able to add a
+tag field though.
\ No newline at end of file
--- /dev/null
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Comment.sty version 3.6, October 1999
+%
+% Purpose:
+% selectively in/exclude pieces of text: the user can define new
+% comment versions, and each is controlled separately.
+% Special comments can be defined where the user specifies the
+% action that is to be taken with each comment line.
+%
+% Author
+% Victor Eijkhout
+% Department of Computer Science
+% University of Tennessee
+% 107 Ayres Hall
+% Knoxville TN 37996
+% USA
+%
+% victor@eijkhout.net
+%
+% This program is free software; you can redistribute it and/or
+% modify it under the terms of the GNU General Public License
+% as published by the Free Software Foundation; either version 2
+% of the License, or (at your option) any later version.
+%
+% This program is distributed in the hope that it will be useful,
+% but WITHOUT ANY WARRANTY; without even the implied warranty of
+% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+% GNU General Public License for more details.
+%
+% For a copy of the GNU General Public License, write to the
+% Free Software Foundation, Inc.,
+% 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA,
+% or find it on the net, for instance at
+% http://www.gnu.org/copyleft/gpl.html
+%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% This style can be used with plain TeX or LaTeX, and probably
+% most other packages too.
+%
+% Usage: all text included between
+% \comment ... \endcomment
+% or \begin{comment} ... \end{comment}
+% is discarded.
+%
+% The opening and closing commands should appear on a line
+% of their own. No starting spaces, nothing after it.
+% This environment should work with arbitrary amounts
+% of comment, and the comment can be arbitrary text.
+%
+% Other `comment' environments are defined by
+% and are selected/deselected with
+% \includecomment{versiona}
+% \excludecoment{versionb}
+%
+% These environments are used as
+% \versiona ... \endversiona
+% or \begin{versiona} ... \end{versiona}
+% with the opening and closing commands again on a line of
+% their own.
+%
+% LaTeX users note: for an included comment, the
+% \begin and \end lines act as if they don't exist.
+% In particular, they don't imply grouping, so assignments
+% &c are not local.
+%
+% Special comments are defined as
+% \specialcomment{name}{before commands}{after commands}
+% where the second and third arguments are executed before
+% and after each comment block. You can use this for global
+% formatting commands.
+% To keep definitions &c local, you can include \begingroup
+% in the `before commands' and \endgroup in the `after commands'.
+% ex:
+% \specialcomment{smalltt}
+% {\begingroup\ttfamily\footnotesize}{\endgroup}
+% You do *not* have to do an additional
+% \includecomment{smalltt}
+% To remove 'smalltt' blocks, give \excludecomment{smalltt}
+% after the definition.
+%
+% Processing comments can apply processing to each line.
+% \processcomment{name}{each-line commands}%
+% {before commands}{after commands}
+% By defining a control sequence
+% \def\Thiscomment##1{...} in the before commands the user can
+% specify what is to be done with each comment line.
+% BUG this does not work quite yet BUG
+%
+% Trick for short in/exclude macros (such as \maybe{this snippet}):
+%\includecomment{cond}
+%\newcommand{\maybe}[1]{}
+%\begin{cond}
+%\renewcommand{\maybe}[1]{#1}
+%\end{cond}
+%
+% Basic approach of the implementation:
+% to comment something out, scoop up every line in verbatim mode
+% as macro argument, then throw it away.
+% For inclusions, in LaTeX the block is written out to
+% a file \CommentCutFile (default "comment.cut"), which is
+% then included.
+% In plain TeX (and other formats) both the opening and
+% closing comands are defined as noop.
+%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Changes in version 3.1
+% - updated author's address
+% - cleaned up some code
+% - trailing contents on \begin{env} line is always discarded
+% even if you've done \includecomment{env}
+% - comments no longer define grouping!! you can even
+% \includecomment{env}
+% \begin{env}
+% \begin{itemize}
+% \end{env}
+% Isn't that something ...
+% - included comments are written to file and input again.
+% Changes in 3.2
+% - \specialcomment brought up to date (thanks to Ivo Welch).
+% Changes in 3.3
+% - updated author's address again
+% - parametrised \CommentCutFile
+% Changes in 3.4
+% - added GNU public license
+% - added \processcomment, because Ivo's fix (above) brought an
+% inconsistency to light.
+% Changes in 3.5
+% - corrected typo in header.
+% - changed author email
+% - corrected \specialcomment yet again.
+% - fixed excludecomment of an earlier defined environment.
+% Changes in 3.6
+% - The 'cut' file is now written more verbatim, using \meaning;
+% some people reported having trouble with ISO latin 1, or umlaute.sty.
+% - removed some \newif statements.
+% Has this suddenly become \outer again?
+%
+% Known bugs:
+% - excludecomment leads to one superfluous space
+% - processcomment leads to a superfluous line break
+%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\def\makeinnocent#1{\catcode`#1=12 }
+\def\csarg#1#2{\expandafter#1\csname#2\endcsname}
+\def\latexname{lplain}\def\latexename{LaTeX2e}
+\newwrite\CommentStream
+\def\CommentCutFile{comment.cut}
+
+\def\ProcessComment#1% start it all of
+ {\begingroup
+ \def\CurrentComment{#1}%
+ \let\do\makeinnocent \dospecials
+ \makeinnocent\^^L% and whatever other special cases
+ \endlinechar`\^^M \catcode`\^^M=12 \xComment}
+%\def\ProcessCommentWithArg#1#2% to be used in \leveledcomment
+% {\begingroup
+% \def\CurrentComment{#1}%
+% \let\do\makeinnocent \dospecials
+% \makeinnocent\^^L% and whatever other special cases
+% \endlinechar`\^^M \catcode`\^^M=12 \xComment}
+{\catcode`\^^M=12 \endlinechar=-1 %
+ \gdef\xComment#1^^M{%
+ \expandafter\ProcessCommentLine}
+ \gdef\ProcessCommentLine#1^^M{\def\test{#1}
+ \csarg\ifx{End\CurrentComment Test}\test
+ \edef\next{\noexpand\EndOfComment{\CurrentComment}}%
+ \else \ThisComment{#1}\let\next\ProcessCommentLine
+ \fi \next}
+}
+
+\def\CSstringmeaning#1{\expandafter\CSgobblearrow\meaning#1}
+\def\CSstringcsnoescape#1{\expandafter\CSgobbleescape\string#1}
+{\escapechar-1
+\expandafter\expandafter\expandafter\gdef
+ \expandafter\expandafter\expandafter\CSgobblearrow
+ \expandafter\string\csname macro:->\endcsname{}
+}
+\def\CSgobbleescape#1{\ifnum`\\=`#1 \else #1\fi}
+\def\WriteCommentLine#1{\def\CStmp{#1}%
+ \immediate\write\CommentStream{\CSstringmeaning\CStmp}}
+
+% 3.1 change: in LaTeX and LaTeX2e prevent grouping
+\if 0%
+\ifx\fmtname\latexename
+ 0%
+\else \ifx\fmtname\latexname
+ 0%
+ \else
+ 1%
+\fi \fi
+%%%%
+%%%% definitions for LaTeX
+%%%%
+\def\AfterIncludedComment
+ {\immediate\closeout\CommentStream
+ \input{\CommentCutFile}\relax
+ }%
+\def\TossComment{\immediate\closeout\CommentStream}
+\def\BeforeIncludedComment
+ {\immediate\openout\CommentStream=\CommentCutFile
+ \let\ThisComment\WriteCommentLine}
+\def\includecomment
+ #1{\message{Include comment '#1'}%
+ \csarg\let{After#1Comment}\AfterIncludedComment
+ \csarg\def{#1}{\BeforeIncludedComment
+ \ProcessComment{#1}}%
+ \CommentEndDef{#1}}
+\long\def\specialcomment
+ #1#2#3{\message{Special comment '#1'}%
+ % note: \AfterIncludedComment does \input, so #2 goes here!
+ \csarg\def{After#1Comment}{#2\AfterIncludedComment#3}%
+ \csarg\def{#1}{\BeforeIncludedComment\relax
+ \ProcessComment{#1}}%
+ \CommentEndDef{#1}}
+\long\def\processcomment
+ #1#2#3#4{\message{Lines-Processing comment '#1'}%
+ \csarg\def{After#1Comment}{#3\AfterIncludedComment#4}%
+ \csarg\def{#1}{\BeforeIncludedComment#2\relax
+ \ProcessComment{#1}}%
+ \CommentEndDef{#1}}
+\def\leveledcomment
+ #1#2{\message{Include comment '#1' up to level '#2'}%
+ %\csname #1IsLeveledCommenttrue\endcsname
+ \csarg\let{After#1Comment}\AfterIncludedComment
+ \csarg\def{#1}{\BeforeIncludedComment
+ \ProcessCommentWithArg{#1}}%
+ \CommentEndDef{#1}}
+\else
+%%%%
+%%%%plain TeX and other formats
+%%%%
+\def\includecomment
+ #1{\message{Including comment '#1'}%
+ \csarg\def{#1}{}%
+ \csarg\def{end#1}{}}
+\long\def\specialcomment
+ #1#2#3{\message{Special comment '#1'}%
+ \csarg\def{#1}{\def\ThisComment{}\def\AfterComment{#3}#2%
+ \ProcessComment{#1}}%
+ \CommentEndDef{#1}}
+\fi
+
+%%%%
+%%%% general definition of skipped comment
+%%%%
+\def\excludecomment
+ #1{\message{Excluding comment '#1'}%
+ \csarg\def{#1}{\let\AfterComment\relax
+ \def\ThisComment####1{}\ProcessComment{#1}}%
+ \csarg\let{After#1Comment}\TossComment
+ \CommentEndDef{#1}}
+
+\if 0%
+\ifx\fmtname\latexename
+ 0%
+\else \ifx\fmtname\latexname
+ 0%
+ \else
+ 1%
+\fi \fi
+% latex & latex2e:
+\def\EndOfComment#1{\endgroup\end{#1}%
+ \csname After#1Comment\endcsname}
+\def\CommentEndDef#1{{\escapechar=-1\relax
+ \csarg\xdef{End#1Test}{\string\\end\string\{#1\string\}}%
+ }}
+\else
+% plain & other
+\def\EndOfComment#1{\endgroup\AfterComment}
+\def\CommentEndDef#1{{\escapechar=-1\relax
+ \csarg\xdef{End#1Test}{\string\\end#1}%
+ }}
+\fi
+
+\excludecomment{comment}
+
+\endinput
--- /dev/null
+.\" Hey, EMACS: -*- nroff -*-
+.TH DEPUTY 1 "January 10, 2007"
+.\" Please adjust this date whenever revising the manpage.
+.\"
+.\" Some roff macros, for reference:
+.\" .nh disable hyphenation
+.\" .hy enable hyphenation
+.\" .ad l left justify
+.\" .ad b justify to both left and right margins
+.\" .nf disable filling
+.\" .fi enable filling
+.\" .br insert line break
+.\" .sp <n> insert n+1 empty lines
+.\" for manpage-specific macros, see man(7)
+.SH NAME
+deputy \- Advanced C compiler that enforces type and memory safety
+.SH SYNOPSIS
+.B deputy
+.RI [ options ] " files" ...
+.SH DESCRIPTION
+.\" TeX users may be more comfortable with the \fB<whatever>\fP and
+.\" \fI<whatever>\fP escape sequences to invode bold face and italics,
+.\" respectively.
+Deputy is an advanced C compiler that enforces type and memory safety
+in existing C programs. The programmer must add type annotations that
+describe, for example, the bounds of each pointer in terms of other
+program variables. Deputy uses static analysis and run-time checks to
+enforce safety based on these annotations.
+.PP
+Further information and documentation is available at
+\fBhttp://deputy.cs.berkeley.edu/\fP.
+.SH OPTIONS
+The \fBdeputy\fP command is designed to be a drop-in replacement for
+\fBgcc\fP, so most of the standard options for \fBgcc\fP should work
+as expected. Further information can be found at the URL above and
+by using the following commands:
+.TP
+.B \-h, \-\-help
+Show summary of options.
+.TP
+.B \-v, \-\-version
+Show version of program.
+.SH SEE ALSO
+.BR gcc (1).
+.SH AUTHOR
+Deputy was written by Jeremy Condit <jcondit@cs.berkeley.edu>, Matthew
+Harren <matth@cs.berkeley.edu>, Zachary Anderson <zra@cs.berkeley.edu>,
+and George C. Necula <necula@cs.berkeley.edu>.
+.PP
+This manual page was written by Jeremy Condit <jcondit@cs.berkeley.edu>.
--- /dev/null
+\documentclass{book}
+
+\usepackage{hevea}
+\usepackage{graphicx} % for includegraphics
+
+%\begin{latexonly}
+%\ifx\pdfoutput\undefined
+% \usepackage{hyperref}
+%\else
+% \usepackage[pdftex]{hyperref}
+%\fi
+%\end{latexonly}
+
+\usepackage{color}
+
+% deputy.version.tex is generated automatically to define \deputyversion
+% and \deputyversion
+\include{deputy.version}
+
+\renewcommand\t[1]{{\tt #1}}
+\newcommand\codecolor{\ifhevea\blue\else\fi}
+\renewcommand\c[1]{{\codecolor #1}} % Use for code fragments
+\newcommand\SAFE{\t{SAFE}}
+\newcommand\BND{\t{BND}}
+\newcommand\NTS{\t{NTS}}
+\newcommand\COUNT{\t{COUNT}}
+\newcommand\AUTO{\t{\_\_auto}}
+\newcommand\THIS{\t{\_\_this}}
+
+\newcommand\RTTI{\t{RTTI???}}
+\newcommand\SEQ{\t{SEQ???}}
+\newcommand\FSEQ{\t{FSEQ???}}
+\newcommand\WILD{\t{WILD???}}
+
+\newcommand\TODO[1]{{\ifhevea\red\else\fi TODO: #1}}
+\newcommand\secref[1]{Section~\ref{sec-#1}}
+\newcommand\chref[1]{Chapter~\ref{ch-#1}}
+\newcommand\appref[1]{Appendix~\ref{ch-#1}}
+
+%%% Define an environment for code
+%% Unfortunately since hevea is not quite TeX you have to use this as follows
+%\begin{code}
+% ...
+%\end{verbatim}\end{code}
+\def\code{\begingroup\codecolor\begin{verbatim}}
+\def\endcode{\endgroup}
+
+%
+% \begin{deputycode}...\end{deputycode} is taken care by deputycode.pl
+%
+
+%use this for links to external pages. It will open pages in the
+%top frame.
+\newcommand\ahreftop[2]{{\ahref{javascript:loadTop('#1')}{#2}}}
+
+
+
+% Make sure that most documents show up in the main frame,
+% and define javascript:loadTop for those links that should fill the window.
+% Use BEGIN/END IMAGE to make sure that makeatletter/makeatother
+% appear in the image file too.
+%BEGIN IMAGE
+\makeatletter
+%END IMAGE
+\let\oldmeta=\@meta
+\def\@meta{%
+\oldmeta
+\begin{rawhtml}
+<base target="main">
+<script language="JavaScript">
+<!-- Begin
+function loadTop(url) {
+ parent.location.href= url;
+}
+// -->
+</script>
+\end{rawhtml}}
+%BEGIN IMAGE
+\makeatother
+%END IMAGE
+
+
+\begin{document}
+\begin{latexonly}
+\title{Deputy \deputyversion: User Manual}
+\end{latexonly}
+\maketitle
+
+\chapter{Introduction}
+
+ \emph{This version of the document refers to Deputy {\deputyversion}
+ and was last modified on \today. This document is also available in
+ \ahref{DEPUTY.pdf}{PDF format}}
+
+
+Deputy is a source-to-source translator for C. It analyzes the C program to
+determine the smallest number of run-time checks that must be inserted in the
+program to prevent all memory safety violations. The resulting program is
+memory safe, meaning that it will stop rather than overrun a buffer or
+scribble over memory that it shouldn't touch. ...
+
+ Deputy relies on a lightweight system of annotations on pointer types. The
+programmer must supply the annotations for all global pointers (function
+arguments and returns, structure fields, types of global variables) and Deputy
+will attempt to infer the annotations for local variables and for type casts.
+
+ The Deputy itself is written in Ocaml (a dialect of ML). There is also a
+Perl script, \c{deputy}, that operates as a drop-in replacement for 'gcc', so
+that software packages' existing Makefiles can be used with very minor
+changes.
+
+ Deputy is implemented on top of the \@print{<a target="\_blank"
+href="../cil/index.html">CIL framework</a>}. for analysis and transformation
+of C programs. CIL allows the quick development of program analysis
+modules that works on ANSI C code as well as on code that uses the GNU C
+extensions.
+
+ If you are anxious to see Deputy in action you can try out our
+\@print{<a target="\_blank" href="web/index.html">online demo</a>}.
+
+ In this manual you can find a tutorial on getting started with Deputy
+(\chref{tutorial}), documentation for all of the features (actually some of
+the more researchy features are not yet fully documented) and step-by-step
+accounts on what it takes to use Deputy on several example programs
+(\chref{examples}). We suggest that you read the chapters in order and go to
+the ``Advanced Deputy Features'' only if you need it. The \chref{warn} (Deputy
+Warnings and Errors) will help you figure out if you are running into an error
+that is covered by an advanced feature.
+
+\section{Authors}
+
+ Deputy was developed primarily by
+\ahref{mailto:jcondit@cs.berkeley.edu}{Jeremy Condit},
+\ahref{mailto:matth@cs.berkeley.edu}{Matthew Harren} and
+\ahref{mailto:necula@cs.berkeley.edu}{George Necula}.
+Other people helped with
+various components: ...
+
+ This work was supported in part by the National Science Foundation under
+Grants No. ???, and gifts from Microsoft Research. Any opinions, findings, and
+conclusions or recommendations expressed in this material are those of the
+author(s) and do not necessarily reflect the views of the National Science
+Foundation or the other sponsors.
+
+ \chapter{Installation}\label{ch-start}
+
+ Deputy works on Linux and MS Windows (for now only with cygwin).
+
+ Deputy is somewhat sensitive to the version of the compiler that you are
+using. More precisely, Deputy is sensitive to the format of the system include
+files that you are using. When you install Deputy it will create slightly
+modified copies of some of the system include files. These copies are created
+based on some patches that we distribute with Deputy. If your include files
+are different from those that we used to create the patches then the Deputy
+installation might fail. At the moment we have tested Deputy with the
+following compilers:
+
+\begin{itemize}
+\item On Windows, using \c{cygwin} and \c{gcc} version 3.4.4.
+\item On Linux, using \c{gcc} version 3.4.4
+\end{itemize}
+
+ If you want to use Deputy on Windows then you must get a complete
+installation of \c{cygwin} (make sure you install the development tools such
+as \c{gcc} and \c{ld} as well and the \c{perl} interpreter) and the {\bf
+source-code} Ocaml distribution and compile it yourself using the cygwin tools
+(as opposed to getting the Win32 native-code version of Ocaml). You will need
+Ocaml release 3.08 or higher to build Deputy. If you have not done this before
+then take a look \ahref{../ccured/setup.html}{here}. (Don't need to worry
+about \c{cvs} and \c{ssh} unless you will need to use the master CVS
+repository for Deputy.)
+
+\section{Get the Deputy sources}
+
+ Download the Deputy \ahref{distrib}{distribution} (latest version is
+\ahrefurl{distrib/deputy-\deputyversion.tar.gz}). See the \secref{changes} for
+recent changes to the Deputy distribution.
+
+ If you are one of the Deputy developers you can ask Jeremy Condit
+(\mailto{jcondit@cs.berkeley.edu}) for an account that allows you to use the
+master CVS repository on \c{manju.cs.berkeley.edu}. Assuming you have already
+setup \c{cvs} and \c{ssh} as discussed in \ahrefurl{cvssetup.html}, you can
+check out the sources in a subdirectory \c{deputy} as follows:
+
+\begin{verbatim}
+ % cvs -d :ext:jcondit@manju.cs.berkeley.edu:/home/cvs-repository checkout deputy
+ ^^^^^^^
+ use your username instead
+\end{verbatim}
+
+\section{Configure and Compile Deputy}
+
+ Run the following commands in the top level directory. If you are using
+Windows then at least the \c{configure} command must be run from within
+\c{bash}.
+\begin{verbatim}
+./configure
+make
+make quicktest (optional)
+\end{verbatim}
+
+ The \c{configure} script tries to find appropriate defaults for your system.
+
+ It is possible that you get a configuration error saying that certain patterns
+did not match. This means that your standard include files are different than
+those that we have prepared the distribution for. (See the above discussion.)
+Your recourse in this case is either to install one of the versions of the
+compiler that we tested Deputy for or to extend the patch files so that they
+match your includes. It is not hard, and it is explained in the
+\ahref{../cil/patcher.html}{patcher} documentation.
+
+ After running \c{make} you have built a few executables (in the \c{obj}
+directory) and have configured the \c{bin/deputy} Perl script. If you want to
+move this script to another directory (e.g. to \c{/usr/local/bin}) make sure
+to copy the \c{DeputyConfig.pm} file to the same directory.
+
+ Now you can continue with a tutorial (\chref{tutorial}), or you can jump
+ahead and find out how to run Deputy (\chref{invoke}).
+
+\section{Test Deputy}
+
+ Once you have built Deputy you can run
+\begin{verbatim}
+make quicktest
+\end{verbatim}
+
+ This will run a few small examples. If you want to test Deputy on a large
+part of our own regression suite you need to do the following:
+\begin{itemize}
+\item In the \t{test} directory, run
+\begin{verbatim}
+runtests --run
+\end{verbatim}
+
+ See \secref{regtest} for details on how to use the regression tester.
+
+\end{itemize}
+
+
+\chapter{Deputy Tutorial}\label{ch-tutorial}\cutname{tutorial.html}
+
+ Deputy is an extension of the C programming language that distinguishes among
+various kinds of pointers depending on their usage. The purpose of this
+distinction is to be able to prevent improper usage of pointers and thus to
+guarantee that your programs do not access memory areas they shouldn't access.
+You can continue to write C programs but Deputy will change them slightly so
+that they are type safe. In this chapter we explain in what situations will
+your program be changed and in which way.
+
+ Deputy leaves unchanged code that does not use pointers or arrays. Actually,
+Deputy is implemented on top of the C Intermediate Language (CIL)
+infrastructure, which means that C programs are first translated into a subset
+of the C language that has simple semantic rules. The following are some of
+the transformations that are performed:
+\begin{itemize}
+\item C expressions and statements are separated into expressions (no
+side-effect and no control-flow), instructions (assignments and function
+calls, with one side-effect and no control-flow) and statements (the
+control-flow constructs). This means that CIL serializes the side-effects and
+the control-flow.
+\item All type and structure declarations are moved to the beginning of the
+file.
+\item The scope of variables is resolved and local variables are renamed
+accordingly. All local variables are moved to function-scope and are declared
+at the beginning of the function body. The initialization for such variables
+is done using explicit assignment instructions.
+\item Anonymous structures and unions are given unique names.
+\item All implicit casts and conversion are expressed as explicit casts.
+\item All GNU CC extensions are compiled into regular C code.
+\end{itemize}
+
+ For a complete description of the CIL infrastructure see
+\ahref{../cil/index.html}{the CIL documentation}.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ \section{Deputy Annotations}\label{sec-typeannot}
+
+ The most significant difference between C and Deputy is that Deputy pays
+close attention to how pointers are manipulated and it classifies pointers
+into various kinds according to what you do with them. We'll discuss the
+various kinds starting in the next section but before that we need to
+introduce an important notation that you can use to communicate to Deputy
+which pointer kinds you want for your pointers.
+
+ Deputy uses type attributes to express the kind of pointers. Type attributes
+exist in a limited form in ANSI C (i.e. the \c{volatile}, \c{const} and
+\c{restrict} type qualifiers) and in a richer form in the GCC dialect of C.
+Deputy, just like GCC, allows any attributes to be specified for types, names
+of variables, functions or fields, and for structure or union declarations.
+Unlike GCC, Deputy has precise rules for how attributes are interpreted in a
+declaration (instead GCC relies on knowing the semantics of the attribute in
+order to associate it with the proper element of a declaration). The rule of
+thumb is that the attribute of a pointer type is written immediately {\bf
+following} the \c{*} pointer-type constructor and the attribute of a name is
+written immediately before the semicolon or the \c{=} sign that terminates the
+declaration of the name. Deputy uses pointer-kinds such as \SAFE{}, \NTS{} and
+\BND{} and the corresponding attribute use the same names. For example, in the following declaration:
+\begin{deputycode}[]
+int * NTS * SAFE x;
+\end{deputycode}
+
+ the type of \c{x} is declared to be a \SAFE pointer to a null-terminated C
+string (\NTS). Just like pointer-types in C, attributes are read from
+right-to-left. The \c{SAFE} attribute in this case applies to the pointer-type
+of \c{x}.
+
+ (The complete attribute-parsing rules for CIL are described in the
+\ahref{../cil/attributes.html}{CIL manual}.)
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ \section{\SAFE{} pointers}
+
+ The main action in Deputy concerns the features that endanger type safety in
+C: pointer, arrays, union types, and variable argument functions. Pointers in
+C can be assigned to l-values, dereferenced, subject to pointer arithmetic and
+cast to other pointer or non-pointer types. In contrast, pointers in a typical
+type-safe language (e.g. Java, Basic, ML) cannot be subject to arithmetic or
+(arbitrary) casts. Deputy allows (almost) all the pointer operations that C
+allows but gives preferential treatment to pointers that are not subject to
+arithmetic or to casts. Deputy refers to such pointers as \SAFE{} pointers.
+
+ Consider for example this small code-fragment that computes the length of a
+linked list:
+\begin{deputycode}[]
+struct list {
+ int car;
+ struct list * SAFE cdr;
+};
+
+int length(struct list * SAFE l) {
+ int i = 0;
+ while(l) {
+ l = l->cdr;
+ i ++;
+ }
+ return i;
+}
+\end{deputycode}
+
+ The only pointers used in this code fragment are pointers to list cells and
+they are not subject to arithmetic or to casts. In fact, this code fragment
+can be transcribed literally into Java or C\#. You can see in the output of
+Deputy that the pointer dereferences contain only \TODO{what? There are
+ actually no checks} checks.
+
+\paragraph{Properties of \SAFE{} pointers}
+ The \SAFE{} pointers are the ``best'' kind of pointers, meaning that they
+incur the least amount of run-time cost. Here is a list of the properties of
+\SAFE{} pointers:
+\begin{itemize}
+\item Cannot be subject to pointer arithmetic (adding or subtracting an
+integer from it).
+\item Cannot be cast (except subject to stringent rules which we'll discuss
+below). Note that assignment, passing actual arguments and returning are
+implicit casts.
+\item Can be set to a compile-time constant equal to 0 but not to any other
+integer expression.
+\item Can be cast to an integer and can be subtracted from another pointer.
+This is useful for comparisons.
+\item \SAFE{} pointers are represented using the standard C representation
+using one word.
+\item Every time a \SAFE{} pointer is dereferenced, a null check is inserted
+before the dereference.
+\end{itemize}
+
+ All of these restrictions are such that the following invariant holds for all
+\SAFE{} pointers:
+\begin{center}\bf
+A \SAFE{} pointer to type \c{T} is either 0 or else it points to a valid area
+of memory containing an object of type \c{T}. Furthermore, all other pointers
+to the same area agree on the type \c{T} of the stored object.
+\end{center}
+
+
+% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%5
+% \subsection{Safe Casts}
+%
+% Casting a pointer to an integer is always allowed. Deputy does actually allow
+%certain other casts on \SAFE{} pointers. For example it is safe to cast a
+%pointer to a structure containing two integers into a pointer to integer. In
+%general it is safe to cast a pointer to a long structure into a pointer to a
+%short structure as long as the two structures agree on the types of the
+%elements in the overlapping portion. Deputy is actually quite liberal about
+%these rules and will think of nested combinations of structures and arrays as
+%one big structure with non-structure and non-array fields. This feature is
+%called {\em physical subtyping}. For example, in the code shown below, all of
+%the four casts implicit in the assignments are safe and Deputy will infer that
+%all pointers involved are \SAFE{}.
+%
+%\begin{deputycode}[]
+%struct large {
+% struct small {
+% int * SAFE f1;
+% int * SAFE f2;
+% } a;
+% int * SAFE f3;
+%} x;
+%
+%struct small * SAFE s1 = & x;
+%int * SAFE * SAFE s2 = & x;
+%struct large1 { int * SAFE a1, * SAFE a2, * SAFE a3; } * SAFE s3 = & x;
+%struct large2 { int * SAFE a1, * SAFE a2[2]; } * SAFE s4 = & x;
+%\end{deputycode}
+%
+% Notice that all of the \c{s1}, \c{s2}, \c{s3} and \c{s4} are aliases for the
+%address of \c{x} but they agree on the type of the object pointed to.
+%
+% Following are two examples of casts that are not allowed (for \SAFE{}
+%pointers; you can see that Deputy infers the \WILD{} kind for the pointers
+%involved) \TODO{what we need to say here. Deputy allows this}:
+%\begin{deputycode}[]
+%int y1;
+%int * * x1 = & y1; // Cast an int * to a int * *
+%int y2;
+%struct large { int * a1, a2; } * x2 = &y2;
+%\end{deputycode}
+%
+% If the first cast were allowed then by writing to \c{y1} an arbitrary
+%integer we would be invalidating the assumption that \c{x1} points to a
+%pointer value. The second cast is similar.
+
+
+ %%%%%%%%%%%%%%%%%%%%%%%%%%
+ \subsection{\SAFE{} Function Pointers}
+
+ There is nothing special about function pointers. They can be safe provided
+that they are not cast to incompatible pointer types. A function pointer type
+is compatible only with another function pointer type with the same number and
+type of arguments and the same result type.
+
+ A common problem with function pointers (and functions) in Deputy is if your
+program uses external function without prototypes. This makes Deputy think
+that the function is taking no arguments and returning an integer and every
+time you use it in a different way Deputy behaves as if you are casting the
+function pointer (denoted implicitly by the function's name) to the type
+needed in the cast. Deputy will give errors when you are using
+using functions without
+prototype and we recommend that you fix those problems and try Deputy again.
+
+
+ %%%%%%%%%%%%%%%%%%%%%%%%%\
+ \section{Checks for \SAFE{} Pointers}
+
+ As we mentioned above, every time a \SAFE{} pointer is dereferenced it must be
+checked whether it is null or not. We know from the invariant for \SAFE{}
+pointers that non-null pointers can be dereferenced and we can count that the
+value read through them has the type given by the pointer type.
+
+ A null check appears in the output of Deputy as a call to the function
+\c{CNonNull}. This and other run-time checking functions used by Deputy have a
+name that starts with the prefix \c{C} and are declared in the file
+\ahrefurl{include/deputy/checks.h}. You will see in that file that most of
+these functions are declared inline.
+
+ Checking for null pointers is necessary not just when reading or writing
+through them but also when they are used to compute the address of a subobject
+of the object they point to. For example, in the following code Deputy will
+add a run-time check that \c{s} is not null before computing the value of
+\c{x}. Then again there will be a check that \c{x} is not null before
+dereferencing it.
+\begin{deputycode}[]
+struct str {
+ int a, b;
+};
+
+int getaddr(struct str * SAFE s) {
+ int * SAFE x = & (s->b);
+ return *x;
+}
+\end{deputycode}
+
+ The first check in the code above is necessary to enforce the invariant that
+\SAFE{} pointers are either 0 or else valid pointers. Without that check the
+value of \c{x} would be 4 (on most machines) which would break the invariant
+and would defeat the second null-check\TODO{How come there is no run-time
+ check on *x? We should explain.} thus letting you dereference an invalid
+pointer.
+
+ At this point you are starting to see some of the subtleties in the design of
+Deputy. To ensure that we got everything right we have formalized the type
+system of Deputy and we proved (for a subset of Deputy) that the set of
+run-time checks and invariants achieve memory safety.
+
+ Deputy includes a simple optimizer that tries to eliminate redundant
+checks and checks that cannot possibly fail (such as checking that the address
+of a global variable is non-null). Currently the optimizer is fairly naive.
+For example, it does not know that since \c{s} is a non-null \SAFE{} pointer
+to \c{struct str} then \c{\&(s->b)} is guaranteed to be non-null as well, thus
+the second check is not really necessary.\TODO{It might actually already know
+that.}
+
+ Speaking of too many checks, some of the more experienced C programmers
+will have noticed that our run-time checks prevent a common idiom for computing
+the offset of fields in structures. The typical code for doing that is shown
+below (as is defined as the macro \c{offsetof} in many C libraries):
+\begin{deputycode}[]
+struct str {
+ int a, b;
+};
+
+int get_offset_of_b() {
+ return (int) &(((struct str*)0)->b);
+}
+\end{deputycode}
+
+ Deputy recognizes in this specific case that you are casting the result of
+the \c{\&} operator to an integer, so it avoids the run-time check.\TODO{Does
+ Deputy recognize this? It should.}
+
+
+ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ \section{Pointer Arithmetic}
+
+ So far we have discussed pointers for which we disallow most casts and
+pointer arithmetic. In this section we will generalize \SAFE{} pointers to
+allow pointer arithmetic, while allowing for static and run-time checks
+against buffer overrun. The cost that the programmer pays for using these more
+capable pointers is that each dereference will be accompanied by bounds
+checks.
+
+\TODO{I am trying to add the checks one by one}
+ Consider the following code fragment. The pointer \c{x} cannot be \SAFE{}
+because adding \c{delta} to it is not guaranteed to yield a meaningful result.
+Instead, we declare \c{x} as a pointer to at least 8 integers.
+\begin{deputycode}[]
+int increment(int * COUNT(8) x, int delta) {
+ return (int)(x + delta);
+}
+\end{deputycode}
+
+ You can see in the Deputy output for the above example that Deputy first
+checks that \t{x} is not null, and then adds a series of checks. First, there
+are checks that ensure that \c{x + delta} does not overflow (\c{COverflow}),
+and it remains within the declared bounds (two instances of \c{CUnsignedLE}).
+
+ Deputy also inserts checks on assignment of pointer to buffers:
+\begin{deputycode}[]
+int index(int * COUNT(count) x, int count) {
+ int * COUNT(2) y = x;
+ return *y;
+}
+\end{deputycode}
+
+ We see that Deputy requires that either \c{x} is null, or else \c{x} $\leq$ x
+$\leq$ \c{x + 2} (check \c{CNullOrLE}) to ensure that after the assignment
+\c{y = x} we establish the invariant required for $y$. (The last check in the
+above example is due to the reading from \c{y}; only a null check is needed
+since we know that if \c{y} is not-null it is safe to read from it.)
+
+ Now we can put together the arithmetic check and the coercion check:
+\begin{deputycode}
+int index (int * COUNT(count) x, int count) {
+ int * COUNT(1) y = x + 2;
+ return *y;
+}
+\end{deputycode}
+
+\TODO{How come we do not have an overflow check above? What if x + 2 overflows?}
+
+\subsection{Bounded Pointers}
+
+ The most general form of bounded pointers uses the \BND{} annotation, with
+two expressions denoting the start (inclusive) and the end (exclusive) of the
+memory area pointed-to by a pointer.
+
+ For example, in the following program \t{x} is declared to be either null, or
+ larger or equal to \t{b} and less than \t{b + 8}:
+\begin{deputycode}
+int foo(int * BND(b, b + 8) x, int * b) {
+ return x[3];
+}
+\end{deputycode}
+
+ In fact, the \SAFE{} and \COUNT{} annotations described before are just
+special cases of \BND{} annotations:
+\begin{verbatim}
+#define COUNT(n) BND(__this, __this + (n))
+#define SAFE BND(__this, __this + 1)
+\end{verbatim}
+
+\subsection{Invariants for bounded pointers}
+\begin{itemize}
+\item Cannot be cast (except subject to stringent rules which we'll discuss
+below). Note that assignment, passing actual arguments and returning are
+implicit casts.
+\item Can be subject to pointer arithmetic (adding or subtracting an
+integer from it).
+\item Can be cast to an integer and can be subtracted from another pointer.
+This is useful for comparisons.
+\item Every time a bounded pointer is dereferenced, both a check that the
+pointer is not null and a bounds check are inserted.
+\end{itemize}
+
+\begin{deputycode}
+extern void* (DALLOC(sz) malloc)(unsigned int sz);
+int foo(int x) {
+ int * COUNT(8) p, * COUNT(16) r1, * COUNT(8) r2;
+ int a[8];
+
+ r1 = (int*)malloc(16);
+ r2 = a;
+ p = r1;
+ p = r2;
+ return *(p + x);
+}
+\end{deputycode}
+
+The invariant for a pointer \t{p} with type \t{T * BND(b,e)} is that it is
+either null, or else there exists a valid allocation area starting at \t{a},
+containing \t{n} elements of type \t{T}, and $\t{a} \leq \t{b} \leq \t{p} \leq
+\t{e} \leq \t{a + n}$. Furthermore, \t{b}, \t{p} and \t{e} are aligned with
+respect to the start of the allocation area and the type \t{T}.
+
+\subsection{Run-time checks for bounded pointers}\label{sec-checkseq}
+
+ Every time we dereference a bounded pointer, we must check that it is
+non-null and it is not equal to the declared upper bound.
+
+Also, for a pointer arithmetic operation we check that the pointer is
+non-null and after the operation is stays in the same area as the original
+pointer.
+
+ For example, in the following code we must check that the operation \t{x + i}
+results in a pointer withing the declared bounds of \t{x}.
+\begin{deputycode}
+int foo(int * BND(b, b + 8) x, int * b, int i) {
+ int * BND(b, b + 8) p = x + i;
+ return *p;
+}
+\end{deputycode}
+
+ An interesting situation is when we assign bounded pointers:
+\begin{deputycode}
+int foo(int * BND(b, b + 8) x, int * b, int * e, int i) {
+ int * BND(e, e + 2) p = x + i;
+ return *p;
+}
+\end{deputycode}
+
+
+% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ \section{Auto Bounds}
+
+ Deputy allows the programmer to control a mechanism for inferring the bounds
+of pointers. To invoke this mechanism, you can use the keyword \AUTO{} in
+place of one or both of the arguments of the \BND{} annotation. When seeing
+such an annotation the
+\begin{itemize}
+\item If \AUTO{} appears in the type of a local variable, a formal argument,
+ or a cast, Deputy will create a local variable (or formal argument) for the
+ corresponding bound and will insert code to track its value
+\begin{deputycode}
+int foo(int * COUNT(n) p, int n) {
+ int * x;
+ if(*p) {
+ x = p;
+ } else {
+ x = p + 2;
+ }
+ return *x;
+}
+\end{deputycode}
+
+ This local use of \AUTO{} is entirely safe, and in fact Deputy will use tihs
+ feature for all local variables and casts that do not have bounds
+ annotations.
+
+\item If \AUTO{} appears in the return type of a function, the type of a
+ global variable, the type of a field, or the base type of a pointer type,
+ then the annotated pointer type is transformed into a ``fat'' structure with
+ new fields to carry the necessary data:
+\begin{deputycode}
+struct foo {
+ int * BND(__this, __auto) fseq;
+} p;
+int array[8];
+int main() {
+ p.fseq = & array[2];
+}
+\end{deputycode}
+
+ Here is an example with \AUTO{} in the return type of a function:
+\begin{deputycode}
+int array[8];
+int * BND(__this, __auto) getints(void) {
+ return & array[2];
+}
+\end{deputycode}
+
+Such uses of \AUTO{} are dangerous because they change the representation of
+data in a way that is visible from other functions. To prevent you from
+accidentaly mixing deputized and native versions of the same globals, Deputy
+will change the name of globals (or functions) whose representation (or
+calling convention) changes.
+
+\end{itemize}
+
+
+% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ \section{Default Annotations}
+
+ If a pointer is missing bounds annotations then Deputy will add its own
+ annotation as follows:
+\begin{itemize}
+\item If this is a cast or the type of a local variable it adds \BND(\AUTO,
+ \AUTO), in essence demanding the creation of local variables to track the
+ bounds.
+\item In all other cases, Deputy adds the annotation \SAFE.
+\end{itemize}
+
+% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ \section{String Pointers}
+
+The C idiom of using a character pointer for passing character strings
+is so ubiquitous that Deputy has a specialized kind of pointer qualifier
+for this usage, called \TODO{??}.
+
+
+%Conceptually, a string pointer is just like an \FSEQ{} pointer, except the
+%end-pointer is implicitly stored in the string data itself, rather than
+%alongside the main pointer. In particular, the memory pointed-to is
+%declared to be an array of characters, and is always used in a way
+%consistent with that declaration.
+%
+%String pointers maintain the invariant that (unless \c{NULL}) they always
+%point within a valid array of characters, and there is always a 0 byte
+%just beyond the end of the array.
+%
+% String pointers can be converted to \FSEQ{} pointers using an invocation of
+%the
+%\begin{deputycode}
+%int foo(char __RWSTRING *s) {
+% char * __FSEQ x = s;
+%}
+%\end{deputycode}
+%
+%
+%The 0 byte beyond the end cannot be changed by the program, whether through
+%a string pointer or through another kind of pointer. Other kinds of
+%pointers will have their metadata arranged to prevent writing the 0.
+%Strings are never allowed to overwrite \emph{any} 0 byte they encounter
+%(because it could be the last one).
+%
+%To guarantee the existence and immutability of the 0 byte, every occurrence
+%in the program of the type ``array of characters of length $n$'' is
+%rewritten to be ``array of characters of length $n+1$''. But, this happens
+%after boxing, so all pointer metadata continues to disallow access beyond
+%the $n$th byte, hence the 0 byte is protected. Further, any call
+%to \c{malloc} requesting $n$ bytes gets at least $n+1$ bytes of data, all
+%initialized to zero (a possible improvement is to allocate the extra
+%byte more selectively, only when a string pointer will point to the memory
+%being allocated).
+%
+%One problem with this scheme is the program might ask for the size of an
+%array using \c{sizeof}. Since the length has changed, \c{sizeof} will
+%return $n+1$, which is now an observable consequence of translation. To
+%partially mitigate this, any occurrence of ``\c{sizeof($e$)}'' where $e$ has
+%type ``array of characters'' is rewritten to be ``\c{(sizeof($e$)-1)}''.
+%This rewriting does not look inside structure types, for example, so it does
+%not completely hide the effect. However, it has proven sufficient for
+%the programs translated so far.
+%
+%All of the rewriting described in this section is done by the
+%\c{expandCharArrays} visitor in \c{box.ml}.
+
+
+ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\section{Safe Union Types}\label{sec-union}
+
+Union types are another potential source of unsoundness in C programs.
+Deputy supports {\em tagged unions}, in which a tag value near the
+union denotes which field of the union is ``active''. These
+tags are already present in most C code; Deputy enforces them in a
+type-safe way.
+
+The following example shows the most common form of a tagged union: a
+union and its tag together in a struct. In this program, the tag
+\c{x.tag} is used to determine the active field of union \c{x.data}.
+
+\begin{deputycode}[]
+enum tagValues { ZERO, ONE, TWO, THREE };
+struct twothings { int a; int* p; };
+
+struct variant {
+ enum tagValues tag;
+ union un {
+ int f1 WHEN(tag == ONE);
+ int * SAFE f2 WHEN(tag == TWO);
+ struct twothings f3 WHEN(tag == ZERO || tag == THREE);
+ } data;
+} x;
+
+int foo() {
+ return x.data.f1;
+}
+\end{deputycode}
+
+Tags are defined by annotating each union field with \c{WHEN($exp$)}
+where \c{$exp$} is a boolean expression that is true when the field is
+active. \c{WHEN} conditions can contain integer arithmetic and
+comparisons, and they can depend on one or more names in the same
+context as the union. So if a local variable has union type, its
+\c{WHEN} clauses can depend on other locals, while a union type used
+as a struct field (by far the most common case) can depend on other
+fields of the struct.
+\TODO{Make sure this matches the terminology (e.g. ``contexts'')
+that's used in the discussion of pointer dependencies.}
+
+You must ensure that the \c{WHEN} annotations are disjoint. That is,
+no two fields should be ``selected'' at once. Deputy does not yet check
+this statically, so it's a runtime error to use a tag value that
+selects more than one field.
+
+There are three key rules when using tagged unions:
+\begin{itemize}
+\item Whenever you read from or write to a field, Deputy will check that
+ the tag value(s) satisfy the \c{WHEN} clause for that field.
+\item Whenever you change a tag value, the entire union must first be
+ zeroed. Doing this ensures that the new active field can be
+ immediately read; a pointer field will be \t{NULL}, which is always
+ valid for a pointer type.
+\item You may not take the address of a union field. (This would be
+ unsound, if the pointer to the field was used after the tag changed.)
+\end{itemize}
+
+If you want to change the value of both a union and a tag, you should
+do the following. This is analogous to the procedure for changing
+dependent pointers, in which you must usually zero the pointer before
+changing the length.
+\begin{enumerate}
+\item Zero the entire body of the union (\c{memset} is easiest).
+\item Change the tag(s) as desired.
+\item Set the newly-active union field to the new value.
+\end{enumerate}
+
+\begin{deputycode}[]
+#include <string.h>
+
+enum tagValues { ZERO, ONE, TWO, THREE };
+struct twothings { int a; int* p; };
+
+struct variant {
+ enum tagValues tag;
+ union un {
+ int f1 WHEN(tag == ONE);
+ int * SAFE f2 WHEN(tag == TWO);
+ struct twothings f3 WHEN(tag == ZERO || tag == THREE);
+ } data;
+} x;
+
+int setData(int new_a, int* new_p) {
+
+ memset(&x.data, 0 , sizeof(x.data));
+ //It is now legal to change x.tag to any value
+
+ x.tag = THREE;
+ //x.data.f3 is now the active field of x.data.
+
+ x.data.f3.a = new_a;
+ x.data.f3.p = new_p;
+ return *x.data.f3.p;
+}
+\end{deputycode}
+
+
+
+\subsection{Non-pointer fields}
+
+For the sake of type safety, you must provide a \c{WHEN} annotation
+for a field whose type contains a pointer. But these annotations are
+optional for fields that don't involve pointers. Deputy allows reads
+from unannotated fields regardless of the tag value, which is sound
+because Deputy's type safety invariants apply only to pointers, not
+integers.
+
+This union contains no pointers, so it can be left completely
+unannotated. In fact, the programmer may very well be intending to
+write to one field but read from another.
+\begin{code}
+typedef union _LARGE_INTEGER {
+ struct parts {
+ ULONG LowPart;
+ LONG HighPart;
+ } u;
+ LONGLONG QuadPart;
+} LARGE_INTEGER;
+\end{verbatim}\end{code}
+
+If you want to avoid accidentally confusing the fields of this union,
+you can always choose to annotate it. If \c{WHEN} clauses are used,
+they will be enforced even though memory safety doesn't require it.
+
+One common use of this rule is unions that have both integer and
+pointer fields, where the program may want to write to a pointer field
+but read from the integer field. In this case, you can leave the
+integer field unannotated to indicate that all reads through that
+field are allowed. Of course, it's illegal to write to the unannotated
+field if any annotated field is currently selected.
+
+\begin{deputycode}[]
+enum tagValues { ZERO, ONE, TWO, THREE };
+struct twothings { int a; int* p; };
+extern int hash(int z);
+
+struct variant {
+ enum tagValues tag;
+ union un {
+ int hashcode ; // No WHEN annotation
+ double * SAFE f1 WHEN(tag == ONE);
+ int * SAFE f2 WHEN(tag == TWO);
+ struct twothings f3 WHEN(tag == THREE);
+ } data;
+};
+
+int hash_of_variant(struct variant* x) {
+ // Reading x->data.hashcode is legal no matter which field of
+ // the union is selected.
+ return hash(x->data.hashcode);
+}
+
+void write(struct variant* x) {
+ //This will fail at runtime if x->tag is 1, 2, or 3!
+ x->data.hashcode = 0xdeadbeef;
+}
+\end{deputycode}
+
+\subsection{Trusted unions}
+
+If you want to ignore the unsoundness of a union that contains
+pointers, or if you've convinced yourself that the union is used in a
+sound way, you can mark the union as \c{TRUSTED}. Deputy will do no
+checking of trusted unions, and will allow you to take the address
+of union fields.
+
+You can place the \c{TRUSTED} annotation after either the word
+\c{union} or the closing right brace.
+
+\begin{deputycode}[]
+union TRUSTED afl {
+ double f1;
+ int * SAFE f2;
+} data1;
+
+//This is an equivalent placement of TRUSTED:
+union cio {
+ double f1;
+ int * SAFE f2;
+} TRUSTED data2;
+
+int* SAFE * SAFE intpp;
+
+void unsound() {
+ intpp = &data1.f2;
+ data1.f1 = 3.14159;
+}
+\end{deputycode}
+
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{Not-Yet Documented Features}
+
+\TODO{This section contains only reminders of features to document}
+\begin{itemize}
+\item When you take the address of an element into an array, the inferred
+ pointer type refers to the whole array. In other words ``\& array[idx]''
+ behaves exacly like ``array + idx''.
+\end{itemize}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{Invoking Deputy}\label{ch-invoke}
+
+\TODO{this section}
+
+ Deputy consists of several components: an Ocaml application that does the
+main work, a set of Perl scripts that are used to invoke the Deputy
+application, and a set of header and run-time library files.
+
+ The easiest way to use Deputy is through the \c{bin/deputy} script. This
+script is intended to be used in the same context and with the same
+command-options as either the \c{gcc} compiler or the Microsoft Visual C
+compiler (MSVC). This script is configured at installation time to know where
+the rest of the Deputy installation resides. If you move this script to
+another directory you must also make a copy in the new directory of the
+\c{DeputyConfig.pm} file.
+
+ Since \c{deputy} is a drop-in replacement for \c{gcc}, for most software
+projects you can reuse the regular build-infrastructure:
+\begin{verbatim}
+make mystuff CC="bin/deputy [options]"
+\end{verbatim}
+
+ Here is the sequence of actions that the \c{deputy} script performs:
+\begin{enumerate}
+\item It recognizes among the command-line arguments those that are intended
+for the pre-processor; then, for each source file (i.e. with the extension
+t{.c}), calls the preprocessor and places the result in a file with the
+extension \c{.i} in the same directory as the source file.
+\item For every \c{.i} file that it produces and that must be compiled (i.e.
+the \c{-E} option was not specified to require only preprocessing) \c{ccured}
+will save a copy of the file with the extension \c{.o}, thus ``fooling''
+\c{make} that the object file was actually produced.
+\item Whenever \c{ccured} is invoked to link {\em into a library} a number of
+\c{.o} files that are actually preprocessed sources saved in the previous
+step, the Deputy engine will be invoked to parse all of the files and produce
+a single \c{C} file with the same content but with names of types and
+variables properly renamed. The output is then saved as the resulting library.
+You should use the \c{--mode=AR} argument to Deputy if you want to pass the
+remaining arguments as for the \c{ar} utility. More details about the merging
+stage that Deputy used can be found \ahref{../cil/merger.html}.
+\item Finally, when \c{ccured} is called to link {\em into an executable} a
+number of object files and libraries it will separate from them those that are
+actually saved sources and will merge them all in memory. The resulting file
+is then subject to Deputy type inference followed by the insertion of run-time
+checks. Optionally, an optimizer is invoked to try to clean up some of the
+inserted run-time checks. The result is saved using the full name of the
+desired executable with the suffix \c{ccured.c}. Finally this file is
+preprocessed, compiled and linked using the underlying compiler.
+\end{enumerate}
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%5
+\section{Command-line options}\label{sec-commandline}
+
+\TODO{this section}
+
+ You always run Deputy with the command options of \c{gcc} (e.g., \c{-c} to
+compile only, \c{-o} to specify the output file, etc.). Here are some common
+ways to use invoke Deputy:
+\begin{itemize}
+\item \c{bin/ccured --nocure --nomerge hello1.c hello2.c -o hello.exe}
+\hspace{1cm}- Compiles and links without curing and without merging (still
+uses the CIL front-end)
+\item \c{bin/ccured --nocure hello1.c hello2.c -o hello.exe}
+\hspace{1cm}-Merges using CIL, then compiles and links with \c{gcc}
+\item \c{bin/ccured hello1.c hello2.c -o hello.exe} \hspace{1cm}-Merges using
+CIL, processes with Deputy, the compiles and links with \c{gcc}
+\item \c{bin/ccured -c hello1.c hello2.c} \hspace{1cm}-Just put preprocessed source in the object files
+\item \c{bin/ccured hello1.o hello2.o -o hello.exe} \hspace{1cm}-Take the
+preprocessed source in the object file, merge, cure, gcc.
+\item \c{bin/ccured --mode=AR cr hello.a hello1.o hello2.o} \hspace{1cm}-Merge
+the preprocessed source in the object files into an archive (which itself
+contains source)
+\item \c{bin/ccured hello.a main.c -o hello.exe}\hspace{1cm}-Preprocess the C
+source, merge with the sources in the archive, cure and gcc.
+\end{itemize}
+
+\TODO{I made a pass over the arguments}
+
+ Most of the command-line options that you pass to \c{ccured} will be passed
+along to the underlying preprocessor, compiler or linker. However the
+\c{ccured} script recognizes the following special options:
+\begin{itemize}
+\item General options
+\begin{itemize}
+\item \c{--save-temps}. It tells the Deputy script to save the temporary files
+ (including the output of Deputy).
+\item \c{--mode=MSVC}. Use instead of the Microsoft Visual C compiler
+(\c{cl}). Deputy and the CIL front-end know how to handle the MSVC extensions.
+\item \c{--leavealone=foo}. Deputy will not merge and will not process the
+file whose name starts with foo. Instead it will compile it as usual and will
+link it in when needed. You can put in this file functions that you do not
+want Deputy to see (e.g., if they are really ugly and you are ashamed of
+what you did!). See \secref{trusted} for details.
+\item \c{--stats}. Print some statistics about the inserted checks.
+\item \c{--stages}. Print details about the various stages.
+\item \c{--extrafiles=<xxx>}. Give the name of a text file that contains
+whitespace-separated named of additional files to process (in case your
+command lines are too long).
+\item \c{--keepunused}. Disable the removal of apparently unused elements from
+the file, such as local variables or prototypes.
+\item \c{--noPrintLn}. Turns off the printing of line-number information. This
+way the errors will be referenced to the Cured file not the source file.
+\item \c{--commPrintLn}. Print line-number information as comments. This
+way the errors that Deputy prints at run-time and the debugging information in
+the cured code refer to the cured file, not the original source, but
+you can still figure out from what file this is coming.
+\item \t{--printCilAsIs}. Do not attempt to simplify the program while
+ printing. If this is turned on, then all loops will be printed as
+ ``while(1)'', as they are in the internal language.
+\end{itemize}
+
+\item Options controlling compile-time behaviour
+\begin{itemize}
+\item \c{--deputyverbose}. Print information about what Deputy is doing.
+\item \c{--deputyinferout=foo}. Print in the file \c{foo} a version of the
+ source that contains the information that Deputy has inferred.
+\item \c{--deputyopt=n}. Choose the optimization level:
+ \begin{itemize}
+ \item \c{0} - no optimization. Not recomended because it leads to so
+ many checks that gcc is overwhelmed
+ \item \c{1} - flow-insensitve optimizations.
+ \item \c{2} - flow-sensitive optimizations.
+ \end{itemize}
+\end{itemize}
+
+
+\item Options controlling run-time behaviour
+\begin{itemize}
+\item \c{--deputyAlwaysStopOnError}. Generate code that always stops on error
+ (slightly faster).
+\item \c{--failIsTerse}. Do not print source-file location on failure. This
+ makes your program smaller and faster.
+\end{itemize}
+\end{itemize}
+
+ For most performance you should use the options:
+\begin{verbatim}
+--deputyopt=2 --releaselib --deputyAlwaysStopOnError --failIsTerse
+\end{verbatim}
+
+ All of the other options that start with \c{--} (and are not recognized as
+compiler options) are passed unmodified to the Deputy Ocaml application.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\section{Controlling error handling at run time}\label{sec-errorhandle}
+
+ After you process a program you can run it as usual. If you have used the
+\c{--deputyAlwaysStopOnError} flag to Deputy then the only option you have
+when a check fails is to stop the execution. This assumption allows the
+compiler to generate faster checking code. If you do not use that flag then by
+default the program will print failure messages on standard error and the
+execution will continue as if Deputy has not been used. \TODO{This would be a
+nice property to have. I am not sure we have it though (e.g., unions)}
+
+ Alternatively, you have the option to set the environment variable
+ \c{DEPUTY\_ONERROR} to one of the following values.
+\begin{itemize}
+\item \c{warn} - warning messages are printed and the execution continues.
+ This is as if you did not set the \c{DEPUTY\_ONERROR} variable.
+\item \c{stop} - execution stops on the first error, after printing the error
+ message. This is almost as if you had specified
+ \c{--deputyAlwaysSleepOnError} except that the program might be slightly
+ slower.
+\item \c{ignore} - the failure messages are ignored (not even printed) and the
+ execution continues.
+\item \c{sleep} - the program goes to sleep on an error. When it does so, it
+prints the process id to standard error. You can then connect to it using
+\t{gdb} as follows (replace \t{test} with the name of your executable and
+\t{10343} with the actual process id printed when the process goes to sleep.):
+\begin{itemize}
+\item Start \t{gdb} (preferably from within Emacs)
+\item Type
+\begin{verbatim}
+(gdb) file test
+(gdb) attach 10343
+\end{verbatim}
+\end{itemize}
+
+ This is useful for debugging multi-threaded code or code that
+is started by daemons. This has effect only if the program would actually stop
+there.
+
+ Note that this mode is most useful when you compiled the code with \t{-g} and
+you did not use \t{--releaselib}. I also prefer to use \t{-commPrintLn} so
+that the debugging information refers to the cured file, not the original.
+\end{itemize}
+
+%%%%%%%%%%%%%%%
+%%%%%%%%%%%%%%%
+%%%%%%%%%%%%%%%
+\chapter{Using Deputy}\label{ch-examples}
+
+ In this chapter we describe the typical steps that must be taken to use
+Deputy on a new software package. For each step we give general instructions.
+Then, we look at a few concrete software packages and we describe all the
+steps that were necessary. We describe the warnings and the errors that we ran
+into and how we solved them. Most of these warnings and errors are also
+discussed in \chref{warn}. Take a look there if the explanation here is too
+terse.
+
+\begin{enumerate}
+\item {\bf Regular build} First try to download the sources and build them in
+the regular manner (using \c{gcc}). It might be a good idea to setup a CVS
+repository right after you download the sources, in order to better keep track
+of the changes you are making.
+
+\item {\bf Build using CIL} Next you should try to build the package using CIL
+(the front-end that Deputy uses). This step is optional but is a good idea
+just in case your software package exposes a bug in CIL. To perform this step
+you should edit the Makefile as follows (assuming it uses CC to invoke the
+compiler \emph{and} the linker):
+\begin{verbatim}
+ifdef DEPUTY
+ CC:=/home/necula/ccured/bin/ccured
+endif
+ifdef ONLYCIL
+ CC+= --nodeputy
+endif
+\end{verbatim}
+\TODO{We ought to support CIL-only build mode with the deputy script. This
+ should define away the attributes}
+
+ If your project includes a more complicated setup, you must make the
+necessary changes to use the above commands instead of \c{gcc}.
+
+ Then you can run:
+\begin{verbatim}
+make clean
+make DEPUTY=1 ONLYCIL=1
+\end{verbatim}
+
+ This should build your project as before, except that each source file is
+first preprocessed, then passed through the \c{deputy.asm.exe} executable to
+produce the CIL output (a file with suffix \c{cil.c} that contains the source
+of your program after being processed by the CIL front-end), then preprocessed
+again and then finally passed to \c{gcc}. Here is an example of what you
+should see for the file \c{util.c} from the \c{mathopd} package:
+
+\begin{verbatim}
+/home/necula/deputy/bin/deputy --nodeputy -c -O -Wall -DHAVE_CRYPT_H util.c -o util.o
+gcc -D_GNUCC -E -O -DHAVE_CRYPT_H util.c -o ./util.i
+/home/necula/deputy/obj/x86_LINUX/deputy.asm.exe --cilout ./utilcil.c --nodeputy --warnall ./util.i
+gcc -D_GNUCC -E -O -DHAVE_CRYPT_H -I/home/necula/deputy/include ./util.cil.c -o ./util.cil.i
+gcc -D_GNUCC -c -O -DHAVE_CRYPT_H -Wall -o util.o ./util.cil.i
+\end{verbatim}
+
+ At this point you should ensure that the executable still works as expected.
+If it does not then you have found a bug in the CIL front-end or in the
+\c{deputy} Perl script that tries to impersonate \c{gcc}. CIL has been tested
+extensively, so you can consider yourself truly unfortunate. Please let us know
+about your problem.
+\TODO{Should we explain how to use merging?}
+
+\item {\bf Build with Deputy}
+ Now we start using Deputy:
+\begin{verbatim}
+make clean
+make DEPUTY=1
+\end{verbatim}
+
+Deputy will print information about the stages that it goes through. You
+should watch for warnings and error messages, especially in the ``Inference''
+stage and in the ``Curing'' stage. If you are lucky the above steps are enough
+to build the executable. However, many times Deputy will stop with some error.
+The first thing you should do in that case is to scan the warnings that lead
+to the error and proceed as explained in \chref{warn}.
+
+\item {\bf Run and debug the processed code}
+\TODO{Would be nice to have an attribute to use where we used ``cured'' before}
+ Now that you have build your executable with Deputy you should run it on as
+many examples as possible. Remember that Deputy is engineered to catch the
+majority of the bugs at run-time (it is designed with the philosophy that the
+C programmer is better than the Deputy static analyzer, so Deputy just
+silently inserts run-time checks when it cannot ensure statically that what
+the program is doing is guaranteed to be correct).
+
+ When you get an error message from Deputy you should investigate it to see if
+it is a false alarm or a true bug.
+
+ You can tell Deputy to continue the execution after it encounters an error if
+you set the environment variable \c{DEPUTY\_CONTINUE\_ON\_ERROR}.
+
+\end{enumerate}
+
+ Next we look at concrete examples. If you want to try your hand at using
+Deputy on real code you might want to try it on these packages and then use
+the instructions when you get stuck.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ \section{Example: \t{mathopd} HTTP server}\label{sec-mathopd}
+\TODO{this example}
+
+ \subsection{Step 1: Regular Build}
+
+From the README file: ``This is Mathopd, a fast, lightweight, non-forking HTTP
+ server for UN*X systems.''
+
+ We describe here the steps required for processing the version 1.4-gamma of
+mathopd (a development version). This package contains of 5000 lines of code.
+
+ We download \c{mathopd-1.4-gamma.tar.gz}, unpack, change the Makefile as
+required for Linux and then we try it out:
+\begin{verbatim}
+cd src
+make
+\end{verbatim}
+
+ Next we edit the configuration file (\c{doc/sample.cfg}) so that we can run
+the server on port 8000. Right after the line \c{Server \{} we add \c{Port
+ 8000}. Then we must become root and create a directory for the log:
+\begin{verbatim}
+su root
+mkdir /var/mathopd
+chmod 777 /var/mathopd
+exit
+./mathopd <../doc/sample.cfg
+\end{verbatim}
+
+ Now from another machine (make sure you have ~/public\_html/index.html on the
+ server machine):
+\begin{verbatim}
+explorer http://manju.cs.berkeley.edu:8000/~necula/
+\end{verbatim}
+
+ and we see that it works.
+
+ \subsection{Step 2: Build with CIL}
+
+ Completely uneventful.
+
+ \subsection{Step 3: Build with Deputy}
+
+ For \c{mathopd} we saw the warning:
+\begin{verbatim}
+Warning: Generated automatic vararg descriptor for log_d: struct autoVarargDescr_log_d : char const */* __attribute__((___ptrnode__(922))) */,
+uid_t
+If this is a printf-like function you should declare it!
+\end{verbatim}
+
+ As explained in \chref{warn}, we take a look at the implementation of
+\c{log\_d} (we find it in the merged file \c{mathopd\_comb.c}) to make sure
+Deputy did not miss anything. Sure enough, \c{log\_d} is a printf warning.
+Same thing for \c{die}. We fix this by adding the following pragma in
+\c{main.c} (see \secref{manualvararg} for details):
+\begin{verbatim}
+#pragma ccuredvararg("log_d", printf(1))
+#pragma ccuredvararg("die", printf(2))
+\end{verbatim}
+
+
+ In the process of doing mathopd, we encountered the warning:
+\begin{verbatim}
+/home/necula/ccured/include/netdb_wrappers.h:329: Warning: Solver: changing User Specified SAFE node 1371 (the local variable p_ith_alias) to WILD
+\end{verbatim}
+
+ This turned out to be a bug in the wrapper for the socket functions. We found
+it using the browser (see \secref{browser}).
+
+ Then we saw a warning:
+\begin{verbatim}
+/usr/include/sys/socket.h:156: Warning: sendmsg appears to be external
+ (it has a wrapper), yet it has a mangled name: sendmsg_scsws_.
+ Did you forget to use __ptrof and a version of __mkptr?
+ For more information, consult the online documentation on
+ "Writing Wrappers".
+\end{verbatim}
+
+ This turned out to be due to the same socket wrapper error.
+
+ Another warning you might see when you run Deputy is:
+\begin{verbatim}
+3 incompatible types flow into node void *1127
+ Type struct iovec_LEAN *1178 at /home/necula/ccured/include/socket_wrappers.h:237
+ Type char */* __NODE(1371) __ROSTRING */ *1372 at /home/necula/ccured/include/netdb_wrappers.h:332
+ Type struct iovec_LEAN *1146 at /home/necula/ccured/include/socket_wrappers.h:219
+\end{verbatim}
+
+ This means that a \c{void *} node is cast to several incompatible types. When
+you investigate this (using the browser, for example, or just following the
+line numbers) you discover that the \c{\_\_trusted\_add\_iov} issue is the
+cause of this also.
+
+ Once we fix the above problem we notice that there are no more \WILD{}
+pointers:
+\begin{verbatim}
+ptrkinds: Graph contains 12886 nodes
+ptrkinds: SAFE - 9256 ( 72\%)
+ptrkinds: SEQ - 429 ( 3\%)
+ptrkinds: FSEQ - 3201 ( 25\%)
+\end{verbatim}
+
+ \subsection{Step 4: Write the wrappers}
+
+We see now that there are some missing functions:
+\begin{verbatim}
+mathopd_comb.o: In function `log_request':
+mathopd_comb.o(.text+0x1b02d): undefined reference to `asctime_qs'
+\end{verbatim}
+
+ See \chref{wrapper} for information on how to write this wrapper: Essentially
+this is what we had to add to \c{time\_wrappers.h} file:
+\begin{verbatim}
+#pragma ccuredwrapper("asctime_wrapper", of("asctime"))
+__inline static
+char *asctime_wrapper(const struct tm *timep) {
+ struct tm *thinTimep = __ptrof(timep);
+ char *thinRet = asctime(thinTimep);
+ return __mkptr_string(thinRet);
+}
+\end{verbatim}
+
+ \subsection{Step 5: Run and Debug the cured code}
+
+ We ran the \c{mathopd} server and we get an error right away:
+\begin{verbatim}
+Failure at config.c:924: new_pool(): Ubound
+Aborted
+\end{verbatim}
+
+ We look at the code and we see this code in \c{config.c}:
+\begin{code}
+p->ceiling = t + s;
+\end{verbatim}\end{code}
+
+ This looks like the pointer that is stored in the \c{ceiling} field is
+outside bounds, that that is Ok. This field is never used as a pointer. So, we
+change its type to \c{long} instead. We could change it to \FSEQ{} as well.
+See \chref{warn} for more possible solutions.
+
+ Now mathopd seems to work!! But of course you should be using it for real in
+order to find the bugs.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%55
+ \section{Example: UCSPI TCP Suite}\label{sec-ucspi}
+\TODO{this example}
+
+ \subsection{Step 1: Regular Build}
+
+ This is a package that provides ``tcpserver'' and ``tcpclient''. From their
+web page (\ahreftop{http://cr.yp.to/ucspi-tcp.html}): ``they are easy-to-use
+command-line tools for building TCP client-server applications.'' The package
+also includes a number of clients built using these tools. There are 6700
+lines of code in this package. We actually found one bug in this library.
+
+
+ We downloaded the version 0.88 (as of January 9, 2003). Following the
+instructions:
+\begin{verbatim}
+gunzip ucspi-tcp-0.88.tar
+tar -xf ucspi-tcp-0.88.tar
+cd ucspi-tcp-0.88
+make
+\end{verbatim}
+
+ Before we install it, we edit the file conf\_home to point to the current
+directory (we do not want to mess up the /usr/local). Then we continue:
+\begin{verbatim}
+make setup check
+\end{verbatim}
+
+ And now the big moment:
+\begin{verbatim}
+./http@ www.yahoo.com
+\end{verbatim}
+
+ Bingo!
+
+ \subsection{Step 2: Build with CIL}
+
+ This software package has a strange build interface. The Makefile contains
+things like:
+\begin{verbatim}
+addcr.o: \
+compile addcr.c buffer.h exit.h
+ ./compile addcr.c
+
+compile: \
+warn-auto.sh conf-cc
+ ( cat warn-auto.sh; \
+ echo exec "`head -1 conf-cc`" '-c $${1+"$$@"}' \
+ ) > compile
+ chmod 755 compile
+\end{verbatim}
+
+ What is happening is that the compile script is created from the first line
+of \c{conf-cc} and then used as a compiler. That line contains \c{gcc -O2}
+right now. We change that file to use instead the value of the CC environment variable:
+\begin{verbatim}
+$CC -O2
+\end{verbatim}
+% $
+
+ (You might want to also change warn-auto.sh to add a -v argument to /bin/sh
+ so that you see what is going on.)
+
+ Then we add the stuff to Makefile to define CC (and export it to child
+scripts). It turns out that this file also was missing a clean target, so we
+add that as well:
+\begin{verbatim}
+export CC:=gcc
+ifdef DEPUTY
+ CC:=/home/necula/ccured/bin/ccured
+endif
+ifdef NOCURE
+ CC+= --nocure
+endif
+ifdef NOMERGE
+ CC+= --nomerge
+endif
+
+clean:
+ rm -f *.i *.o *.a
+ rm -f *cil.c *infer.c *comb.c *cured.c
+ rm http@ tcpclient tcpserver
+\end{verbatim}
+
+ Just to test the new setup we make it again and test it again.
+
+ Now we try to make it with CIL.
+\begin{verbatim}
+make clean
+make DEPUTY=1 NOCURE=1 NOMERGE=1
+\end{verbatim}
+
+ Now we get an error:
+\begin{verbatim}
+tcpserver.o: In function `main':
+tcpserver.o(.text+0xa29): undefined reference to `env_get'
+tcpserver.o(.text+0xa50): undefined reference to `env_get'
+\end{verbatim}
+
+ Clearly we have done something wrong. A quick investigation reveals that
+tcpserver.c does need \c{env\_get}, which is defined in env.c, but seems to
+be missing from \c{envcil.c}. This means that the CIL front-end has dropped
+this function. This is an embarrassing CIL bug. Now, when you have things
+disappear then the fault is most often in the algorithm that CIL uses to
+remove ``unnecessary'' things (such as locals or prototypes that are not
+used). To disable that stage, pass the \c{--keepunused} flag to Deputy.
+
+ Anyway, we fix that bug and now everything works. We now have to try the
+merging. For this we must also intervene in the way the Makefile links
+libraries and executables. It uses the scripts \c{makelib} to make a library
+and \c{load} to make an executable.
+
+ For the \c{load} script all we need to change is the \c{conf-ld} to use
+\c{\$CC} instead of \c{gcc}. We do this and we run with merging. We get this
+error:
+\begin{verbatim}
+gcc -D_GNUCC -o tcpserver -s tcpserver_comb.o cdb.a dns.a time.a unix.a byte.a
+cdb.a: could not read symbols: Archive has no index; run ranlib to add one
+\end{verbatim}
+
+ As explained in \chref{warn}, this is because we should not use \c{ar} to
+archive files in the merging mode, but we should use \c{ccured --mode=AR}. We
+achieve this by changing the Makefile, which creates the \c{makelib} script.
+We change it such that the \c{makelib} script uses the environment variable
+\c{AR} instead of \c{ar}. And we defined AR in the Makefile as follows:
+\begin{verbatim}
+export AR:=ar
+ifdef DEPUTY
+ ifndef NOMERGE
+ AR:=/home/necula/ccured/bin/ccured --mode=AR
+ endif
+endif
+
+\end{verbatim}
+
+ We run again in merging mode and now we get:
+\begin{verbatim}
+ranlib: cdb.a: File format not recognized
+\end{verbatim}
+
+ You look at \c{cdb.a} and find that it is a merged source file. You should
+not use \c{ranlib} on such files. We edit the Makefile again and rerun.
+
+ Now we get this error message when trying to merge \c{rblsmtpd} from a number
+of object files and libraries:
+\begin{verbatim}
+/usr/include/sys/socket.h:189: Error: Incompatible declaration for accept (4). Previous was at rblsmtpd.c:103 (0) (different type constructors: void vs. int )
+\end{verbatim}
+
+
+ What happens is that the file \c{rblsmtpd.c} defines its own global \c{accept}
+(luckily, with a different type than the one in the library; otherwise Deputy
+would not have noticed!). Yet, one of the
+other files that are merged (\c{socket\_accept.c}) uses the standard
+library's accept. This looks like a bug. When the linker puts everything
+together the references to the ``accept'' from \c{socket\_accept} will be
+resolved to the ``accept'' from \c{rblsmtpd} (which is clearly not an
+acceptable replacement for the socket function).
+
+ We change the name of the ``accept'' in \c{rblsmtpd} and we rerun and now
+everything works. A result of your work so far is that for all of the utility
+programs that make up this package you have their sources in one source file
+(e.g. \c{tcpclient\_comb.c}. And, we have found a bug even before we started
+to use the actual Deputy!
+
+ \subsection{Step 3: Build with Deputy}
+
+ The first thing we see when we enable Deputy on this package is:
+\begin{verbatim}
+chkshsgr.c:8: Warning: Calling function getgroups without proper prototype: will be WILD.
+ getgroups has type void * __attribute__((___ptrnode__(12))) /* /* missing proto */ */()
+chkshsgr.c:8: Warning: Calling function _exit with 1 arguments when expecting 0: will be WILD.
+ _exit has type void ()
+\end{verbatim}
+
+ Two warnings, both due to missing or incomplete prototypes. In the cast of
+\c{getgroups} it is a missing prototype. We add to \c{chkshgr.c} the following:
+\begin{verbatim}
+#include <unistd.h> // For getgroups
+#include <grp.h> // For setgroups
+\end{verbatim}
+
+ We also exit the prototype of \c{\_exit} in \c{exit.h}:
+
+\begin{verbatim}
+extern void _exit(int); // The "int" was missing
+\end{verbatim}
+
+ Now Deputy succeeds in making this executable and proceeds to make
+\c{tcpserver}. Here we find this one:
+\begin{verbatim}
+tcpserver.c:352: Error: You did not turn on the handling of inline assembly. Better hide this assembly somewhere else!
+\end{verbatim}
+
+ This is interesting! We look at the inline assembly (a good place to look in
+is \c{tcpserver\_comb.c}, you'll see them all in there). One is a use of
+\c{ntohs}, which is harmless because it does not involve pointers. We'll
+leave this alone.
+
+ But the other 5 or 6 such things are uses of the macros \c{FD\_SET} and
+friends from \c{<sys/select.h>}. We investigate and we find that these macros
+are defined in \c{<bits/select.h>}, and luckily that file also provides
+regular C implementation for them, along the following lines:
+\begin{verbatim}
+#if defined __GNUC__ && __GNUC__ >= 2
+
+# define __FD_ZERO(fdsp) \
+ do { \
+ int __d0, __d1; \
+ __asm__ __volatile__ ("cld; rep; stosl" \
+ : "=c" (__d0), "=D" (__d1) \
+ : "a" (0), "0" (sizeof (fd_set) \
+ / sizeof (__fd_mask)), \
+ "1" (&__FDS_BITS (fdsp)[0]) \
+ : "memory"); \
+ } while (0)
+#else /* ! GNU CC */
+# define __FD_ZERO(set) \
+ do { \
+ unsigned int __i; \
+ fd_set *__arr = (set); \
+ for (__i = 0; __i < sizeof (fd_set) / sizeof (__fd_mask); ++__i) \
+ __FDS_BITS (__arr)[__i] = 0; \
+ } while (0)
+
+#endif /* GNU CC */
+\end{verbatim}
+
+ I am going to patch that include file to make the conditional test always
+false and thus ensure that the C version is used always.
+\begin{enumerate}
+\item First, we tell Deputy that \c{<bits/select.h>} is a file that must be
+patched (you can see that it is not patched already because it is not present
+in the directory \c{cil/include/gcc\_2.95.3}; by the time you read this it this
+whole patching business should have been done already). We go into
+\c{cil/Makefile.gcc} and add to the list of \c{PATCH\_SYSINCLUDES} the name
+\c{bits/select.h} (but we do it only in the Linux section).
+\item Then, we specify the patch. We add the following to the file \c{cil/ccured\_GNUCC.patch}:
+\begin{verbatim}
+<<< file=bits/select.h, system=linux
+#if defined __GNUC__ && __GNUC__ >= 2
+===
+#if 0 && defined __GNUC__ && __GNUC__ >= 2
+>>>
+\end{verbatim}
+
+This says that the specified patch should be applied to the file
+ \c{bits/select.h} when Deputy is run on a Linux system. (Not all
+ platforms have bits/select.h.)
+Matching is done whitespace-insensitive. Now you rebuild Deputy (just run
+\c{make}) and you should find the patched file in the
+\c{cil/include/gcc\_2.95.3/bits}. Make sure it is as you need. More information
+about the patcher is at \ahrefurl{../cil/patcher.html}
+\end{enumerate}
+
+ And since we have left one inline assembly in, we must tell Deputy to accept
+it as is. We change the Makefile to pass the \c{--allowInlineAssembly} to
+Deputy.
+
+ Now we find more missing prototype problems:
+\begin{verbatim}
+tcpserver.c:210: Warning: Calling function close with 1 arguments when expecting 0: will be WILD.
+ close has type int ()
+\end{verbatim}
+
+ In fact, \c{close} does not have a prototype at all. Deputy has supplied one
+without arguments while making \c{unix.a}! We add the ``\#include <unistd.h>''
+to \c{tcpserver.c} and go on.
+
+ We add a few more prototypes and then we get:
+\begin{verbatim}
+buffer_get.c:10: Warning: Calling function (*op) with 3 arguments when expecting 0: will be WILD.
+ (*op) has type int ()
+\end{verbatim}
+
+ We find in \c{buffer.h} and \c{buffer\_get} a function pointer type declared
+as ``int (*op)()''. Again the missing argument types. We fill those in.
+
+ Now starts the real fun, chasing away the \WILD{} pointers (see
+\chref{nowild} for general techniques). We see this message:
+\begin{verbatim}
+** 1: Bad cast at cdb_make.c:36 (char *510 ->struct cdb_hplist *1376)
+** 2: Bad cast at pathexec_env.c:42 (char *510 ->char */* __NODE(2537) */ *2538)
+** 3: Bad cast at pathexec_env.c:67 (char */* __NODE(2537) */ *2538 ->char *2553)
+** 4: Bad cast at sig.c:12 (void (int ) *2695 ->void () *2694)
+** 5: Bad cast at sig_catch.c:9 (void () *673 ->void (int ) *2711)
+ptrkinds: Graph contains 4383 nodes
+ptrkinds: SAFE - 3142 ( 72%)
+ptrkinds: SEQ - 15 ( 0%)
+ptrkinds: FSEQ - 127 ( 3%)
+ptrkinds: WILD - 1099 ( 25%)
+535 pointers are void*
+5 bad casts of which 0 involved void* and 2 involved function pointers
+1 (20%) of the bad casts are downcasts
+0 incompatible equivalence classes
+\end{verbatim}
+
+ The casts 4 and 5 are due to missing argument types function types. We edit
+sig.h to add the ``int'' as the argument type for signal handler.
+
+ We investigate cast number 2 and we find something like this:
+\begin{verbatim}
+ e = (char **) alloc((elen + 1) * sizeof(char *));
+\end{verbatim}
+
+ This is a custom allocator. We must declare it (in alloc.h):
+\begin{verbatim}
+extern void *alloc(unsigned int);
+#pragma ccuredalloc("alloc", nozero, sizein(1)) // We added this line
+\end{verbatim}
+
+ We run Deputy again and no more bad casts (it looks like all the others were
+due to \c{alloc}), but still a bunch of \WILD{}:
+pointers:
+\begin{verbatim}
+ptrkinds: Graph contains 4575 nodes
+ptrkinds: SAFE - 3324 ( 73%)
+ptrkinds: SEQ - 41 ( 1%)
+ptrkinds: FSEQ - 150 ( 3%)
+ptrkinds: WILD - 1060 ( 23%)
+579 pointers are void*
+0 bad casts of which 0 involved void* and 0 involved function pointers
+No bad casts, so no downcasts
+2 incompatible types flow into node void *518
+ Type char */* __NODE(2549) */ *2550 at pathexec_env.c:67
+ Type char *102 at dns_transmit.c:63
+2 incompatible equivalence classes
+\end{verbatim}
+
+ Notice that we have more pointers in the program. This is due to the
+allocator, which is now polymorphic and is duplicated several times. But we
+also have incompatible equivalence classes. This is because there is a \c{void
+*} pointer that is used with several incompatible types (in this case \c{char
+*} and \c{char **}). See \secref{poly} for more details on this. This turns
+out to be because the function \c{alloc\_free} with a declared argument of
+type \c{void *} is used in two places with different argument types. We simply
+declare that function to be polymorphic (in \c{alloc.h}):
+\begin{verbatim}
+#pragma ccuredpoly("alloc_free")
+\end{verbatim}
+
+ Finally, Deputy succeeds, with no \WILD{} pointers, but there still is a
+warning that we have not looked at:
+\begin{verbatim}
+pathexec_env.c:42: Warning: Encountered sizeof(char */* __attribute__((___ptrnode__(2595))) */) when type contains pointers. Use sizeof expression. Type has a disconnected node.
+\end{verbatim}
+
+ As explained in \secref{sizeof} we should take a look at the code. We find
+this typical example, and we fix it accordingly:
+\begin{verbatim}
+ e = (char **) alloc((elen + 1) * sizeof(* e)); // Was sizeof(char *)
+\end{verbatim}
+
+
+ \subsection{Step 4: Run and debug the cured code}
+
+
+ We have built the suite of tools and now we run it. Right away we get a
+run-time error, so we set \c{DEPUTY\_CONTINUE\_ON\_ERROR}
+(\secref{errorhandle}) to see them all.
+\begin{verbatim}
+Failure STORE_SP at pathexec_env.c:47: pathexec_qq(): Storing stack address
+...
+Failure STORE_SP at /home/necula/ccured/include/functions/deepcopy_stringarray.h:70: __deepcopy_stringarray_to_compat___0_ssqq(): Storing stack address
+\end{verbatim}
+
+ There are two distinct errors. We'll fix them, but here is a way to silence
+Deputy if you are lazy: we can use
+\c{DEPUTY\_ERROR\_HANDLERS} to specify that we want to ignore all
+\c{STORE\_SP} errors in those two functions. For this we write a text file
+(ucspi.handlers):
+\begin{verbatim}
+ignore STORE_SP at *:*:pathexec_qq
+ignore STORE_SP at *:*:__deepcopy_stringarray_to_compat___0_ssqq
+\end{verbatim}
+
+ Now we run as follows:
+\begin{verbatim}
+DEPUTY_ERROR_HANDLERS=ucspi.handlers ./http@
+\end{verbatim}
+
+ and \t{http@} seems to work.
+
+
+ Let's go back to fixing these errors. These errors are all trying to store
+strings that are obtained from the \c{environ} variable. It turns out that
+those strings are on the stack (allocated before \c{main} is invoked). The
+solution would be to copy those strings on the heap. But right after I saw
+this error I realized that Deputy should not complain if the address that is
+being stored is in the stack frame of \c{main} or at higher addresses. So, I
+added this feature to Deputy and now you will not see these particular errors.
+But if you run \t{http@ www.yahoo.com} you will get:
+\begin{verbatim}
+Failure STORE_SP at dns_transmit.c:213: dns_transmit_start_sqqff(): Storing stack address
+\end{verbatim}
+
+ It does not take much to find that this is due to the following code:
+\begin{verbatim}
+# 5 "dns_resolve.c"
+int dns_resolve(char *q,char qtype[2])
+{
+ struct taia stamp;
+ struct taia deadline;
+ char servers[64];
+
+ if (dns_transmit_start(&dns_resolve_tx,servers,1,q,qtype,"\0\0\0\0") == -1) return -1;
+\end{verbatim}
+
+ \t{dns\_transmit\_start} then stores the address of the array \c{servers}
+into the heap. The solution here is to move the \c{servers} array into the
+heap (or make it a global). We can achieve the former by declaring:
+\begin{verbatim}
+ char servers[64] __HEAPIFY;
+\end{verbatim}
+
+ and Deputy will move it to the heap (see \secref{storeptr}).
+
+ Bingo! It seems to work. Now, you can start measuring performance and, if
+desired, you can try to make Deputy infer better checks for your code.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ \section{Example: PING}
+\TODO{this example}
+
+ In this section I describe what it took to do the \t{ping} utility from
+\t{netkit-base-0.17}.
+
+ We download, compile, test it. Then we setup the Makefiles to use ccured
+instead of \t{gcc} and we test that it works in the \t{--nocure} mode. Then we
+turn on curing.
+
+ First we see two errors pointing out that there is inline assembly in
+\t{ping}. Deputy also prints the instructions and we see that they are just
+bit manipulations. So, we just pass \t{--allowInlineAssembly} to ccured and go
+on.
+
+ Now we get:
+\begin{verbatim}
+Failure UBOUND at ping.c:1303: main(): Ubound
+\end{verbatim}
+
+ To investigate this one we can use \t{DEPUTY\_SLEEP\_ON\_ERROR} (see
+\chref{invoke}). The fragment of code that causes this error is similar to the
+following code:
+\begin{deputycode}[norun]
+struct icmp {
+ int various;
+ char data[1];
+};
+char outpack[65536];
+
+char foo() {
+ // Get the 8th data character
+ return ((struct icmp*)outpack)->data[8];
+}
+\end{deputycode}
+
+ The problem is that once \c{outpack} is cast to a \c{struct icmp *} it looses
+the ability to access most element in the original array. The solution for
+this particular error involves a slight rewrite of the access as:
+\begin{deputycode}[norun]
+char foo() {
+ // Get the offset of the 8th data character
+ int off = (int) & ((struct icmp*)0)->data[8];
+ return outpack[off];
+}
+\end{deputycode}
+
+ We need to fix that problem in all accesses to the \t{data} field. After
+that, we run into another problem:
+\begin{verbatim}
+Failure ALIGNSEQ at ./ping_combcured.c:3923: pinger(): Creating an unaligned sequence
+\end{verbatim}
+
+ This is because at some point we create a sequence pointer whose home area
+does not contain a whole number of elements. See \secref{checkseq} for the
+various ways to address this problem. We choose to simply tell Deputy to allow
+partial elements in structures and to adapt its checks accordingly. To achieve
+this we pass \t{--allowPartialElementsInSequence} to Deputy.
+
+ Now it works, we are done.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ \section{Example: THTTPD Server}
+\TODO{this example}
+
+In this section, we take a look into how to cure thttpd, described by its
+author as ``a simple, small, portable, fast, and secure HTTP server.'' It
+is currently the fifth most popular HTTP server on the net. You can get it
+at \ahreftop{http://www.acme.com/software/thttpd/}. The version I work
+with is 2.23 beta 1.
+
+ \subsection{Step 1: Regular Build}
+
+First, we unpack the files:
+
+\begin{verbatim}
+gunzip thttpd-2.23beta1.tar.gz
+tar -xvf thttpd-2.23beta1.tar
+\end{verbatim}
+
+Look into the directory for the file \c{configure}. We don't want to mess up
+the /usr/local/ folder, so go into \c{configure} and delete the folder path
+from \c{ac\_default\_prefix}. Now Makefile should make thttpd to the folder
+where the source code resides. Run \c{configure}.
+
+\begin{verbatim}
+./configure
+\end{verbatim}
+
+The file should do some work and generate a few files.
+
+There is also another modification we should make to avoid conflicts with any
+existing http servers (e.g. Apache). In \c{config.h}, go-to Line 321 and
+change the default port from 80 to something like 7500.
+
+Now we can run make. The compiler does work and should produce a file named
+\c{thttpd}. Run the program and test the server from another computer. In my
+case, I steered my browser to \c{http://manju.cs.berkeley.edu:7500/~andypang/}.
+
+\begin{verbatim}
+make
+\end{verbatim}
+a few seconds later...
+\begin{verbatim}
+./thttpd
+\end{verbatim}
+
+If you see your homepage, thttpd is working. If not, make sure you have a
+public\_html folder. If you are lazy, there is another way to check if thttpd
+is working. Check whether the site for the server is up at the port you
+specified (e.g. \c{http://manju.cs.berkeley.edu:7500/}). A page with a green
+background should appear notifying you that thttpd is running.
+
+\subsection{Step 2: Build with CIL}
+
+It's time to look into that \c{Makefile.in} that came with thttpd.
+\c{Makefile.in} is the file from which \c{configure} generates \c{Makefile},
+which in turn is used to build the application.
+
+Below the line that says ``You shouldn't need to edit anything below here,''
+we make the same changes to the \c{CC} variable as in the other tutorials.
+
+\begin{verbatim}
+ifdef DEPUTY
+ CC:=/home/andypang/cil/bin/ccured
+endif
+ifdef NOCURE
+ CC+= --nocure
+endif
+ifdef NOMERGE
+ CC+= --nomerge
+endif
+\end{verbatim}
+
+Be sure to insert these ifdefs below the block of variable declarations (below
+line 60). Otherwise, gcc would be used to compile the files.
+
+There will also be more files to clean after CIL/Deputy is run, so I added
+the following to clean up the CIL files and folders that will be generated:
+
+\begin{verbatim}
+CIL = $(SRC:.c=.i) *cil*
+
+COMB = *comb*
+\end{verbatim}
+% $
+
+I modified the variable CLEANFILES to include those files.
+
+\begin{verbatim}
+CLEANFILES = $(ALL) $(OBJ) $(GENSRC) $(GENHDR) $(CIL) $(COMB)
+\end{verbatim}
+
+Now we are ready to compile using CIL. First, we run \c{configure} again to
+update the Makefile.
+
+\begin{verbatim}
+./configure
+make clean
+make DEPUTY=1 NOCURE=1 NOMERGE=1
+\end{verbatim}
+
+Ensure the application still works correctly. It should. Now build with
+merging.
+
+\begin{verbatim}
+make clean
+make DEPUTY=1 NOCURE=1
+\end{verbatim}
+
+Again, check for proper functionality.
+
+\subsection{Step 3: Build with Deputy}
+
+The big moment.
+
+\begin{verbatim}
+make clean
+make DEPUTY=1
+\end{verbatim}
+
+You should see a number of errors and warnings. Many of these will involve
+a warning of a ``malformed format string'' looking something like this:
+
+\begin{verbatim}
+libhttpd.c:226: Warning: Malformed format string [child wait - %m]
+\end{verbatim}
+
+If you take a look at the string, the warning stems from a call to syslog
+with a \%m. This is safe, and can be safely ignored. ***********
+
+
+Now we see a prototyping warning:
+
+\begin{verbatim}
+thttpd.c:437: Warning: Calling function sigset without proper prototype: will be WILD.
+ sigset has type void * __attribute__((___ptrnode__(1666))) /* /* missing proto */ */()
+\end{verbatim}
+
+At this point we realize that some files are read-only. We chmod the thttp folder from its
+parent directory so that we can write to any file in the directory:
+
+\begin{verbatim}
+chmod -R u+w thttpd-2.23beta1
+\end{verbatim}
+
+Back to the problem at hand. If one punches in \c{sigset} on Google, one
+will that it is a function in \c{signal.h}. Add the following \c{thttpd.c}
+to remedy the warning:
+
+\begin{verbatim}
+extern void *sigset(int, void*);
+\end{verbatim}
+
+Although the warning also appeared for the file \c{libhttpd.c}, the
+prototype in \c{thttpd.c} will work for all files in the project.
+
+
+The next most prevalent warning should be a sscanf error, where Deputy
+warns that it does not expect the type \c{char *}. Deputy does not accept
+strings in sscanf because one could potentially read in an unbounded
+string. This characteristic could be used for malicious intentions.
+
+Although \c{\%400[a-zA-Z]} is used and hence strings that are accepted by
+sscanf will be limited to 400 bytes, Deputy currently does not support this.
+This may change in the future, because this method of scanning strings is
+not suspectible to the same problems as simply using \c{\%s}.
+
+To fix this error, use Deputy's sscanf/fscanf functions in place of
+the ones in \c{stdio.h}. Please refer to \secref{scanf-like}
+for more details. As an example, the following is how I modified the code
+at Line 213 in \c{tdate\_parse.c}.
+
+\begin{verbatim}
+ /* DD-mth-YY HH:MM:SS GMT */
+ if (
+ (resetSScanfCount(cp),
+ tm_mday = ccured_fscanf_int(ccured_sscanf_file, "$d-"),
+ ccured_fscanf_string(ccured_sscanf_file, "%400[a-zA-Z]-", str_mon),
+ tm_year = ccured_fscanf_int(ccured_sscanf_file, "$d "),
+ tm_hour = ccured_fscanf_int(ccured_sscanf_file, "$d:"),
+ tm_min = ccured_fscanf_int(ccured_sscanf_file, "$d:"),
+ tm_sec = ccured_fscanf_int(ccured_sscanf_file, "$d GMT"),
+ getScanfCount()) == 6 &&
+ /*
+ sscanf( cp, "%d-%400[a-zA-Z]-%d %d:%d:%d GMT",
+ &tm_mday, str_mon, &tm_year, &tm_hour, &tm_min,
+ &tm_sec ) == 6 &&
+ */
+ scan_mon( str_mon, &tm_mon ) )
+ {
+\end{verbatim}
+% $
+
+
+Then we see several warnings regarding the use of sizeof:
+
+\begin{verbatim}
+libhttpd.c:2782: Warning: Encountered sizeof(char */* __attribute__((___ptrnode__(5491))) */) when type contains pointers. Use sizeof expression. Type has a disconnected node.
+\end{verbatim}
+
+We take a look at this line and find that it is a function call to \c{RENEW}.
+
+\begin{verbatim}
+nameptrs = RENEW( nameptrs, char*, maxnames );
+\end{verbatim}
+
+The definition of \c{RENEW} can be found in \c{libhttpd.h}.
+
+\begin{verbatim}
+#define RENEW(o,t,n) ((t*) realloc( (void*) o, sizeof(t) * (n) ))
+\end{verbatim}
+
+The warning arises from the fact that the Deputy inferencer cannot make
+the connection between \c{nameptrs} and \c{char *}'s. See \secref{sizeof}
+for more details.
+
+To fix the warning, we let Deputy inference the argument in \c{sizeof}
+to \c{nameptr} by modifying the code in the following way:
+
+In libhttpd.c
+\begin{verbatim}
+nameptrs = RENEW( nameptrs, nameptr*, maxnames );
+\end{verbatim}
+
+In libhttpd.h
+\begin{verbatim}
+#define RENEW(o,t,n) (realloc( (void*) o, sizeof(t) * (n) ))
+\end{verbatim}
+
+Now Deputy will know that we are allocating memory based on the size of
+the pointers to \c{nameptr}.
+
+The macro \c{NEW} is defined one line before \c{RENEW}, and we fix a couple
+of calls to \c{NEW} in the same way.
+
+
+We now face a number of warnings of the following form:
+
+\begin{verbatim}
+libhttpd.c:2519: Warning: Solver: changing User Specified SAFE node 5283 (an unnamed location (often an inserted cast)) to FSEQ
+\end{verbatim}
+
+A quick look at \c{libhttpd.c} shows that a call to \c{qsort} is made.
+The wrapper for qsort can be found in \c{stdlib\_wrappers.h}, and there
+appears to be two versions of \c{qsort}. One versions supports polymorphism
+and the other does not. Add \c{-DUSE\_POLYMORPHIC\_QSORT} in \c{Makefile.in}
+after we make the call to \c{cil/bin/ccured}, so that Deputy will know to
+use the polymorphic qsort.
+
+
+This fixes the problems in \c{libhttpd.c} but not \c{tdate\_parse.c}. We go
+to Line 113 and find a call to qsort. At first it looks like a problem with
+sizeof, but fixing the calls to sizeof proves to be fruitless (although still
+a good programming practice).
+
+Let's turn to the browser to track down the bad cast for us. Looking at the
+problematic node will show us that it is in the arguments passed into the
+comparator for qsort. The arguments of the comparator are declared as \c{char *},
+but they are also cast to \c{struct strlong *} in the function. This is a
+bad cast. Change the types of the accepted arguments to \c{void *} and
+the problem is solved.
+
+
+Next we tackle a similar problem in \c{tdate\_parse.c}:
+\begin{verbatim}
+** 1: Bad cast (seq) at tdate_parse.c:202 (struct tm *7100 ->char *7136)
+\end{verbatim}
+
+Once again, we use the browser to track down the problem, and find a cast
+from a \c{struct tm *} to a \c{char *}. We change the \c{char *} to a
+\c{void *} and the bad cast disappears.
+
+\begin{verbatim}
+ (void) memset( (void*) &tm, 0, sizeof(struct tm) );
+\end{verbatim}
+
+
+The last bad cast:
+\begin{verbatim}
+** 1: Bad cast at timers.h:41 (void */* __NODE(346) */ *347 ->long *349)
+\end{verbatim}
+
+Going to Line 41 reveals a union of \c{void *}, \c{int}, and \c{long}. This
+cannot possibly be safe because \c{i} could later be used as a pointer
+with \c{p}. We change this union to a tagged union as instructed in
+\secref{taggedunion}.
+
+\begin{verbatim}
+union ClientData {
+ void* p;
+ int i;
+ long l;
+} __TAGGED;
+typedef union ClientData ClientData;
+\end{verbatim}
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\section{Porting Code from CCured to Deputy}\label{sec-ccuredport}
+One way to determine which pointers will need annotation for Deputy is
+to run CCured's whole-program analysis. The CCured flag
+\c{-{}-listnonsafe} will list the pointers in your program that need
+bounds information.
+
+Using this tool requires that CCured is able to compile your program.
+This itself involves some porting effort, but hopefully many of the
+changes needed for CCured are also needed for Deputy.
+
+This is a simple, unpolished tool. Send suggested improvements to
+\ahref{mailto:matth@cs}{Matt}.
+
+\subsection{Running CCured}
+To use the \c{-{}-listnonsafe} option, make sure each file in your
+program includes \c{deputy/include/ccuredport.h}. This file redefines
+the Deputy macros so that any Deputy annotations you've added are
+translated to CCured annotations. Any pointers that already have
+Deputy annotations are marked so that you won't see additional
+warnings that those nodes need annotations.
+
+Now run \c{ccured -{}-listnonsafe} on your program. You can do this
+from within Emacs' compile-mode so that it's easy to find the
+associated code. You'll see a list of items like this:
+
+\begin{verbatim}
+test.c:36: node (int * __NODE(9) ) in field "y" is Seq/FSeq
+test.c:36: node (int * __NODE(9) ) in field "y" is a void* that CCured has inferred to be a int *
+test.c:28: node (int * __NODE(216) ) in the return value is Seq/FSeq
+test.c:28: node (int * __NODE(217) ) in formal "x" is Seq/FSeq
+test.c:28: node (int * __NODE(217) * __NODE(218) ) in formal "x" is Seq/FSeq
+\end{verbatim}
+
+Currently, you'll be notified of all Seq/FSeq pointers (which need
+bounds information) that are used in the types of fields, formals, and
+return types. With local variables, Deputy's inference will often
+obviate the need for annotations. So for these we don't prompt for
+bounds information unless the type is a pointer to a pointer and the
+inner pointer needs bounds. Finally, you'll also be notified of
+\c{void*} pointers that CCured inferred to have a more specific type.
+If a pointer already has a Deputy annotation on it, it is not listed
+in the output.
+
+\subsection{Limitations}
+
+\begin{itemize}
+\item One requirement of Deputy is that any annotations on a global
+ appear on all declarations of that global (e.g. in .h files).
+ Because CIL's merger combines all declared types into one node,
+ there's no way for CCured to warn about half-missing annotations.
+\item CCured's features don't match Deputy's, so annotations such as
+ \c{\_\_SIZE} in CCured have no exact equivalent in Deputy.
+\item If a function or struct uses CCured-style polymorphism, you'll
+ get several messages that ``\t{foo is a void* that CCured has inferred
+ to be X}'', for various X. For now, you'll probably have to make
+ this node TRUSTED in Deputy.
+\item Types in cast expressions are not reported.
+\end{itemize}
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%5555
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{Advanced Deputy Issues}
+\TODO{this entire chapter}
+
+ In this chapter we discuss a collection of issues having to do with using
+Deputy on real programs. Some of the issues are related to sound handling of
+dark corners of the C programming language (e.g. function pointers,
+initialization of globals, variable argument functions). Other issues are
+related to mechanisms to give hints to the Deputy inferencer.
+
+
+ We recommend that you take a look at the warnings and messages that
+Deputy gives and try to address the bad casts. In this chapter, we describe
+a few tricks that you can use to change the code, and a few features that
+Deputy has to help you do that.
+
+ First, a few notes:
+\begin{itemize}
+\item Do not use functions without prototypes. They will be \WILD{} along with
+their arguments and result values.
+
+\item Fill in the full type of functions and pointers. In C it is technically
+sufficient to leave the argument part of a function type empty, and this
+allows to call the function with whatever arguments you feel like. Deputy will
+accept that but will make the function \WILD{}!
+
+\item If your program has custom memory allocators (generally wrappers around
+\c{malloc} and friend), you must declare them (\secref{malloc}).
+
+\item If you have functions that use pointers polymorphically, make sure those
+pointer types are \c{void *} (not \c{char *} as it was common before ANSI C).
+\end{itemize}
+
+ When it notices bad casts, Deputy will print something like this:
+\begin{verbatim}
+** 1: Bad cast at cdb_make.c:36 (char *510 ->struct cdb_hplist *1376)
+** 2: Bad cast at pathexec_env.c:42 (char *510 ->char */* __NODE(2537) */ *2538)
+** 3: Bad cast at pathexec_env.c:67 (char */* __NODE(2537) */ *2538 ->char *2553)
+** 4: Bad cast at sig.c:12 (void (int ) *2695 ->void () *2694)
+** 5: Bad cast at sig_catch.c:9 (void () *673 ->void (int ) *2711)
+ptrkinds: Graph contains 4383 nodes
+ptrkinds: SAFE - 3142 ( 72%)
+ptrkinds: SEQ - 15 ( 0%)
+ptrkinds: FSEQ - 127 ( 3%)
+ptrkinds: WILD - 1099 ( 25%)
+535 pointers are void*
+5 bad casts of which 0 involved void* and 2 involved function pointers
+1 (20%) of the bad casts are downcasts
+0 incompatible equivalence classes
+\end{verbatim}
+
+ This means that there are 5 bad casts (which contaminate 25\% of your
+pointers). There are no incompatible equivalence classes in this case.
+
+ You can either go directly at the line numbers in which the bad casts are
+reported, or you can use the browser (\secref{browser}).
+
+ Bad cast number 4 and 5 in the example above are clear indications that there
+are some incomplete function types in your program. Go and add the argument
+types.
+
+ The other bad casts are due to an undeclared memory allocator. After we fix
+ those we rerun and we get:
+\begin{verbatim}
+ptrkinds: Graph contains 4575 nodes
+ptrkinds: SAFE - 3324 ( 73%)
+ptrkinds: SEQ - 41 ( 1%)
+ptrkinds: FSEQ - 150 ( 3%)
+ptrkinds: WILD - 1060 ( 23%)
+579 pointers are void*
+0 bad casts of which 0 involved void* and 0 involved function pointers
+No bad casts, so no downcasts
+2 incompatible types flow into node void *518
+ Type char */* __NODE(2549) */ *2550 at pathexec_env.c:67
+ Type char *102 at dns_transmit.c:63
+2 incompatible equivalence classes
+\end{verbatim}
+
+ Notice that we have more pointers in the program. This is due to the
+allocator, which is now polymorphic and is duplicated several times. But we
+also have incompatible equivalence classes. This is because there is a \c{void
+*} pointer that is used with several incompatible types (in this case \c{char
+*} and \c{char **}). See \secref{poly} for more details on this.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ \section{Polymorphism}\label{sec-poly}
+
+% Polymorphism is the ability a program fragment to operate on data of
+%different types. This is a useful thing to be able to do and since C does not
+%have special support for it, each programmer implements polymorphism by
+%extensive use of casting. But not all casts are equal. Consider for example a
+%function that just returns its argument:
+%\begin{code}
+%int identity_bad(int x) { return x; }
+%\end{verbatim}\end{code}
+%
+% This function can be used with any type that fits in an integer, provided the
+%appropriate casts from the type to \c{int} and back are inserted. But as we
+%have already discussed in \secref{castint} this won't work in Deputy because
+%the pointers you get out are not usable.
+%
+% A better way to do this is as follows:
+%\begin{code}
+%void* identity(void* x) { return x; }
+%\end{verbatim}\end{code}
+%
+% It is a common paradigm in C to use \c{void*} for a ``pointer to I don't know
+%what'' type. Deputy supports this view directly by considering each use of
+%\c{void *} in the program as an occurrence of an unknown type. The Deputy
+%inferencer will try to find a replacement type that makes sense in that
+%context. For example, in the following code fragment Deputy will think of both
+%occurrences of \c{void *} as actually being \c{int * *}.
+%\begin{deputycode}
+%void* identity(void* x) { return x; }
+%
+%int main() {
+% int * * p = 0;
+% int * * res = identity(p);
+%}
+%\end{deputycode}
+%
+% This model works for even very complicated code, such as the following
+%fragment that
+%defines a function \c{apply} which applies a function pointer to some
+%arguments (see in the output that all pointers are inferred \SAFE{}):
+%\begin{deputycode}
+%// Applies a function to an argument
+%void * apply(void* (*f)(void*), void *arg) {
+% return f(arg);
+%}
+%
+%// A simple dereference function
+%int * deref(int * * addr) {
+% return *addr;
+%}
+%
+%int main() {
+% int * x = 0;
+% int * res = apply(deref, & x);
+%}
+%\end{deputycode}
+%
+%
+% In the above example there are four occurrences of \c{void *} in the
+%definition of \c{apply}. Based on the actual usage of \c{apply} the first two
+%are mapped to \c{int *} and the latter two are mapped to \c{int * *}.
+%
+% This very flexible scheme breaks down when you have inconsistent usage of a
+%\c{void *} type, such as in the following code:
+%\begin{deputycode}
+%void* identity(void* x) { return x; }
+%
+%int main() {
+% int * p = 0;
+% int * * res_pp = identity(& p);
+% int * res_p = identity(p);
+%}
+%\end{deputycode}
+%
+% In the above code the \c{identity} function is used both with \c{int *} and
+%\c{int **} argument. Since Deputy cannot find any single non-\WILD{} type that
+%is compatible with all contexts in which the \c{void *} is used, it is going
+%to infer that the type of the \c{void *} argument is \WILD{}. And since the
+%argument is assigned to the result (implicitly due to the \c{return}
+%statement) the result type is also \WILD{}. (You can use the browser to see
+%all the different incompatible types that ``flow'' into a \c{void *}). It
+%seems that we need a way to tell Deputy to treat the two invocations
+%separately.
+%
+% Deputy has a crude but effective mechanism for doing just that. First, you
+%have to tell Deputy that a function is polymorphic:
+%\begin{code}
+%#pragma ccuredpoly("identity")
+%\end{verbatim}\end{code}
+%
+% (you can list multiple names in one \c{ccuredpoly} pragma. The pragma can
+% appear anywhere in your program.).
+%
+%If you tell Deputy that a function is polymorphic it will take the following
+%steps:
+%\begin{enumerate}
+%\item For each call site of the function, Deputy will create a copy of the
+%function and it will assign it the name \c{/*15*/identity}, where the number
+%15 is a running counter to ensure that the names are different.
+%\item Then it will perform the usual inference in which case each copy of the
+%\c{identity} function is used only once.
+%\item Finally, for each combination of pointer kinds in the
+%various flavors of \c{identity} Deputy will keep one copy and erase all the
+%others.
+%\end{enumerate}
+%
+% Consider as an example the code from above, in which all pointers are now
+%\SAFE{}. The output contains calls to \c{/*1*/identity} and \c{/*2*/identity}
+%but since they both have the same pointer kinds for the arguments and results,
+%only the body of \c{/*1*/identity} is kept:
+%\begin{deputycode}
+%#pragma ccuredpoly("identity")
+%void* identity(void* x) { return x; }
+%
+%int main() {
+% int * p = 0;
+% int * * res_pp = identity(& p);
+% int * res_p = identity(p);
+%}
+%\end{deputycode}
+%
+% If the copies of the polymorphic function do not all have the same pointer
+%kind then multiple definitions are kept, as in the code below where we have
+%both a \SAFE{} and a \WILD{} copy of the \c{identity} function:
+%\begin{deputycode}
+%#pragma ccuredpoly("identity")
+%void* identity(void* x) { return x; }
+%
+%int main() {
+% int * __WILD p = 0;
+% int * * res_pp = identity(& p);
+% int * res_p = identity(p);
+%}
+%\end{deputycode}
+%
+%% For some reason this does not work anymore
+%% Deputy creates a new instantiation of a polymorphic function also for each
+%%place where the address of the function is taken:
+%%\begin{deputycode}
+%%#pragma ccuredpoly("identity")
+%%void* identity(void* x) { return x; }
+%%
+%%int main() {
+%% int * __WILD p = 0;
+%% int * * (*p_identity)(int * *) = identity; // Take its address
+%% int * * res_pp = p_identity(& p);
+%% int * res_p = identity(p);
+%%}
+%%\end{deputycode}
+%%
+%
+%
+%\paragraph{Polymorphic types}
+%
+%A similar mechanism is also available for types. You can add in the arguments
+%of the \c{ccuredpoly} pragma strings like \c{"struct list"} to say that a copy of
+%\c{struct list} must be created for each occurrence in the program. The
+%inference will then find out which of the copies have to be compatible and at
+%the very end will keep only one copy for each kind. Note however that this
+%form of polymorphism does not have any run-time cost because only types are
+%duplicated. It will however slow down the Deputy type inference.
+%
+% Note: If the polymorphism directives do not seem to take any effect, pass the
+% \t{-verbose} to ccured to see how it parses them.
+%
+% For example, here is how you would write polymorphic list length:
+%\begin{deputycode}
+%#pragma ccuredpoly("length", "struct list")
+%struct list {
+% void *car;
+% struct list *cdr;
+%};
+%
+%int length(struct list *l) {
+% for(int i = 0; l; i ++, l=l->cdr) ;
+%}
+%
+%int main() {
+% struct list list_of_int = { 5, 0 };
+% struct list list_of_wild_ptr = { (int * __WILD)5, 0 };
+% struct list wild_list = { 5 , (struct list * __WILD)0 };
+%
+% int l1 = length(& list_of_int);
+% int l2 = length(& list_of_wild_ptr);
+% int l3 = length(& wild_list);
+%}
+%\end{deputycode}
+%
+% You can see in the browser information that the references to \t{struct list}
+%have been replaced with separate names such as \t{struct /*45*/list}.
+%
+% In the case of recursive structures (whose name is refered directly or
+%indirectly in the name of the fields), the fields use the same version of the
+%structure as the structure itself.
+%
+% Deputy has polymorphism for types and for functions because those are the
+%entities that can be copied legally in C. {\em There is no similar
+%polymorphism for data variables, nor should there be.}.
+%
+% If you have a type name for a polymorphic structure, then Deputy will replace
+% all occurrences of the type name with a reference to the structure itself,
+% meaning that each use of the type name gets its own independent copy.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ \section{User-defined memory allocators}\label{sec-malloc}
+
+% If your program has a user-defined memory allocator that is used to allocate
+%data of different types then its return type will be \WILD{} and so will be
+%all of the pointers you store with the allocated area. Declaring such a
+%function to be polymorphic will likely not help because the function is
+%probably using a global data structure (the allocation buffer) that is shared
+%by all polymorphic copies of the function.
+%
+% Deputy allows you to declare a function to be a user-defined memory allocator
+%using one of the following pragmas:
+%\begin{code}
+%#pragma ccuredalloc("myfunc", <zerospec>, <sizespec>)
+%<zerospec> ::= zero | nozero
+%<sizespec> ::= sizein(k) | sizemul(k1, k2)
+%\end{verbatim}\end{code}
+%
+% The \c{zero} argument means that the allocator zeroes the allocated area.
+%Otherwise Deputy will zero it itself, if it contains pointers. The
+%\c{sizein(k)} argument means that the allocator is being passed the size (in
+%bytes) of the area to be allocated in argument number $k$ (counting starts at
+%1). The \c{sizemul(k1, k2)} argument means that the allocator allocates a
+%number of bytes equal to the product of the arguments number $k1$ and $k2$.
+%
+% For example the following are the pragmas for the standard library allocators
+%\c{malloc} and \c{calloc}:
+%\begin{code}
+%void* malloc(unsigned int size);
+%#pragma ccuredalloc("malloc", nozero, sizein(1))
+%void* calloc(unsigned int nr_elems, unsigned int size);
+%#pragma ccuredalloc("calloc", zero, sizemul(1, 2))
+%\end{verbatim}\end{code}
+%
+% A memory allocator should have return type \c{void *}. In the pre-ANSI C days
+%allocators were written with the type \c{char *}. Once you declare a function
+%to be allocator, its return type will be changed to \c{unsigned long}. At all
+%call sites Deputy will examine what kind of data is being allocated and will
+%construct the metadata for it.
+%
+% Note that declaring a function an allocator has the effect of also making it
+%polymorphic. This means that Deputy will create as many copies of your
+%allocators as you have allocation sites. (After curing only copies with
+%distinct calling convention will be kept, however.)
+%
+% Note that when you declare a custom-memory allocator as such, Deputy will
+%trust that you are not going to re-use the memory area that you return. This
+%means that you can use this feature to write unsafe programs in Deputy. The
+%following program will succeed in trying to dereference the address 5!
+%\begin{deputycode}
+%#pragma curealloc("myalloc", sizein(1), zero)
+%int data[8];
+%void* myalloc(int sz) {
+% return data;
+%}
+%int main() {
+% int ** p = (int **)myalloc(8);
+% data[1] = 5;
+% return *p[1]; // Will dereference 5 !!!
+%}
+%\end{deputycode}
+%
+% Most often the custom-memory allocators are just wrappers around the system
+%\t{malloc}. In that case there is no danger of unsoundness.
+%
+% Note also that Deputy relies on the fact that the result of the custom-memory
+%allocators is assigned to a variable of the right type. It is from the
+%type of the destination of the allocator, or from the type cast with which the
+%allocators is used, that Deputy knows what kind of metadata to create.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ \section{Pointers with Run-Time Type Information}\label{sec-rtti}
+
+% There are many C programs in which \c{void *} pointers are used
+%non-parametrically. An example is a global variable (of type \c{void *}) that
+%is used to store values of different types at different times. Consider for
+%example the following code, where Deputy is forced to infer that the \c{g}
+%pointer has kind \WILD{} because the \c{struct foo} and \c{struct bar} are
+%incompatible:
+%\begin{deputycode}
+%struct foo {
+% int f1;
+%} gfoo;
+%
+%struct bar {
+% int * f1;
+% int f2;
+%} gbar;
+%
+%void * g;
+%
+%int main() {
+% int acc = 0;
+% g = (void *)&gfoo;
+% acc += ((struct foo *)g)->f1;
+% g = (void *)&gbar;
+% acc += ((struct bar *)g)->f2;
+% return acc;
+%}
+%\end{deputycode}
+%
+% In this example \c{g} is used polymorphically but not in a way that could be
+%handled through our support of polymorphism. (This form of polymorphism is
+%called non-parametric polymorphism.) Deputy will consider the casts on \c{g}
+%as bad and will mark those pointers \WILD{}.
+%
+% Deputy contains special support for handling such cases, by tagging the
+%polymorphic values with information about their actual type. To enable this
+%behavior you must use the \RTTI{} pointer kind qualifier on the polymorphic
+%pointer. Consider again the example from before but with a \c{RTTI}
+%annotation:
+%\begin{deputycode}
+%struct foo {
+% int f1;
+%} gfoo;
+%
+%struct bar {
+% int * f1;
+% int f2;
+%} gbar;
+%
+%void * __RTTI g;
+%
+%int main() {
+% int acc = 0;
+% g = (void *)&gfoo;
+% acc += ((struct foo *)g)->f1;
+% g = (void *)&gbar;
+% acc += ((struct bar *)g)->f2;
+% return acc;
+%}
+%\end{deputycode}
+%
+% If you use the browser, you will see that there are no more bad casts and no
+%\WILD{} pointers in this example. If you also look at the Deputy output for
+%the above example you will see that instead the \c{g} variable is now
+%represented using two words, one to store its value and another to store the
+%actual type of the pointer it contains. This type is created when \c{g} is
+%assigned to and is checked when \c{g} is used.
+%
+% Deputy can work with run-time type information only for certain pointer
+%types. We call such types as {\em extensible} and for each type we also
+%construct a name. Specifically, the extensible types are:
+%\begin{itemize}
+%\item \c{void}, named \c{"void"}
+%\item A structure or union type, in which case the name is the letter \c{"S"}
+%followed by the name of the structure or union type. Equivalently it can be a
+%\c{typedef} name for a structure or union type.
+%\item A \c{typedef} (that {\em does not} refer to a structure or union type),
+%in which case the name is the letter \c{"T"} followed by the type name.
+%However, since Deputy eagerly unrolls typedefs, you {\ bf should give the
+%\c{\_\_NOUNROLL} attribute}:
+%\begin{verbatim}
+%typedef int * MY_TYPE_NAME __NOUNROLL;
+%\end{verbatim}
+%\end{itemize}
+%
+% \RTTI{} pointers can be created on by casting from a scalar or a \SAFE{} pointer to an
+%extensible type and can be cast only to scalars and a \SAFE{} pointer to an extensible
+%type. In the example above, \c{struct boo} and \c{struct bar} are extensible
+%pointers and we can cast pointers to these structs to \c{void * RTTI} and
+%back.
+%
+% Deputy also supports the \RTTI{} pointer kind on pointers whose base type is
+%different from \c{void}. Consider the following example:
+%\begin{deputycode}
+%struct foo {
+% int *f1;
+% int f2;
+%} gfoo;
+%
+%struct bar {
+% int *f3;
+% int f4;
+% int f5;
+%} gbar;
+%
+%#pragma ccured_extends("Sbar", "Sfoo")
+%
+%struct foo * __RTTI g;
+%
+%int main() {
+% int acc = 0;
+% g = (struct foo *)&gfoo;
+% acc += g->f2;
+% g = (struct foo *)&gbar;
+% acc += g->f2;
+% acc += ((struct bar *)g)->f5;
+% gfoo.f1 ++; // To make foo.f1 and bar.f3 both FSEQ pointers
+% return acc;
+%}
+%\end{deputycode}
+%
+% Notice that the \RTTI{} pointer kind is used with the base kind \c{struct
+%foo}. An \RTTI{} pointer is strictly more powerful than a \SAFE{} pointer of
+%the same base type. This means that \c{g} in the code above can be used to
+%access the field \c{f1} and \c{f2} without any overhead. This is because
+%Deputy enforces the requirement that an \RTTI{} pointer of base type
+%\c{T} contains only pointer values whose base type {\em extends} \c{T}. The
+%extension relationship is a subset of the physical subtyping relationship: we
+%say that type \c{T} {\em extends} type \c{Q} if:
+%\begin{itemize}
+%\item Both \c{T} and \c{Q} are extensible, and
+%\item Either \c{T} and \c{Q} are the same type, or
+%\item \c{Q} is \c{void}, or
+%\item There exists a pragma \c{ccured\_extends(T, T')} and \c{T'} {\em extends}
+%\c{Q}. In this case Deputy verifies that it is safe to cast a pointer to \c{T}
+%to a pointer to \c{T'}, using the usual physical subtyping relationships.
+%\end{itemize}
+%
+% The \c{ccured\_extends} pragmas use extensible type names to declare a
+%extension hierarchy (similar to a single-inheritance class hierarchy) in which
+%\c{void} is the top. Note that only extensible types can appear in the
+%hierarchy and an extensible type can appear at most once on the left-side of a
+%\c{ccured\_extends} pragma. An \RTTI{} pointer can contain values that are
+%pointers to some extensible base type that extends that of the \RTTI{} pointer
+%itself.
+%
+% The \RTTI{} pointer kind can be applied only to base types that are either
+%\c{void} or non-leaf in the extension hierarchy.
+%
+% For example, in the following code
+%\begin{verbatim}
+%struct foo { int x; }
+%struct bar { int y; int z; }
+%typedef int MY_INT __NOUNROLL;
+%#pragma ccured_extends("Sbar", "Sfoo")
+%#pragma ccured_extends("Sfoo", "TMY_INT")
+%\end{verbatim}
+%
+% we can use the \RTTI{} pointer kind for \c{struct foo *} and \c{MY\_INT *}
+%but not for \c{struct bar}. Notice that in all declared extension
+%relationships physical subtyping is respected.
+%
+% The inferencer will spread the \RTTI{} pointer kind backwards through
+%assignments but only on pointers that can be \RTTI{}. If you want to cut short
+%the propagation of the \RTTI{} pointer king you can use the \SAFE{} pointer
+%kind.
+%
+% To summarize, \RTTI{} pointers can be used with the following constraints:
+%\begin{itemize}
+%\item The \RTTI{} pointer kind is never inferred by the Deputy inferencer. You
+%must specify it on some pointers and then the inferencer will propagate it.
+%
+%\item The \RTTI{} pointer kind is not able to carry bounds information. Thus
+%you cannot use it on pointers that are involved in pointer arithmetic.
+%
+%\item Only pointers to extensible types can be cast to and from \c{RTTI}
+%pointer types. Additionally, you may cast scalars into \c{RTTI} pointers.
+%
+%\item You must use \c{ccured\_extends} pragmas to declare the extension
+%hierarchy.
+%
+%\item \c{void*} polymorphism is turned off for the \_\_RTTI types.
+%\end{itemize}
+%
+% Interestingly enough the \RTTI{} pointer kind can be used to implement in a
+%type-safe way virtual method dispatch, as shown in the example below:
+%\begin{deputycode}
+%typedef struct parent {
+% void * __RTTI * vtbl; // virtual table, with various types of functions
+% int *f1; // some field
+%} Parent;
+%
+%#pragma ccured_extends("Schild", "Sparent")
+%
+%typedef struct child {
+% void * __RTTI * vtbl;
+% int *f2;
+% int f3;
+%} Child;
+%
+%// virtual method foo for class P
+%// notice that the self parameter is an RTTI. It must
+%// be of base type void to ensure that foo_P and foo_C have the
+%// same type
+%int* foo_P(void * __RTTI self_rtti, Parent *x) {
+% Parent * self = (Parent *)self_rtti; // downcast
+% return self->f1;
+%}
+%
+%// virtual method bar for class P
+%int * bar_P(void * __RTTI self_rtti) {
+% Parent * self = (Parent *)self_rtti;
+% return self->f1;
+%}
+%
+%int* foo_C(void * __RTTI self_rtti, Parent *x) {
+% Child * self = (Child *)self_rtti;
+% return self->f2 + self->f3;
+%}
+%
+%// Name the types of the virtual methods, to make them extensible
+%typedef int * FOO_METHOD(void *, Parent *) __NOUNROLL;
+%typedef int * BAR_METHOD(void *) __NOUNROLL;
+%
+%// Now the virtual tables
+%void * vtbl_P[] = { (void*) (FOO_METHOD *)foo_P,
+% (void*) (BAR_METHOD *)bar_P };
+%
+%
+%// child inherits bar_P
+%void * vtbl_C[] = { (void*) (FOO_METHOD *)foo_C,
+% (void*) (BAR_METHOD *)bar_P };
+%
+%
+%int array[8];
+%
+%// Now the constructors
+%void ctor_P(Parent * p) { p->vtbl = vtbl_P; p->f1 = array; }
+%
+%void ctor_C(Child * c) { c->vtbl = vtbl_C; c->f2 = array; c->f3 = 5; }
+%
+%int main() {
+% Parent p;
+% Child c;
+% Parent * pp = &p, * pc = &c;
+% Child * pc1;
+%
+% // Construct
+% ctor_P(&p); ctor_C(&c);
+%
+% // Now try a downcast
+% pc1 = (Child * __RTTI)pc;
+% // Now invoke some virtual methods
+% {
+% FOO_METHOD *pfoo = (FOO_METHOD *) pp->vtbl[0];
+% pfoo((void *)pp, pc);
+% pfoo = (FOO_METHOD *) pc->vtbl[0];
+% pfoo1((void *)pc, pp);
+% }
+%}
+%\end{deputycode}
+%
+% Notice the use of the \c{\_\_NOUNROLL} typedefs for the function types.
+%
+% \subsection{Implementation Details}
+%
+% Deputy collects all extensible types in your program (either those declared
+%using the \c{ccured\_extends} pragma or those that are used in casts to and
+%from \RTTI{} pointers) and constructs the extension hierarchy. An encoding of
+%this hierarchy is dumped in the resulting code in the array \c{RTTI\_ARRAY}.
+%Each entry in the array corresponds to an extensible type and it contains the
+%difference between the entry corresponding to the parent of the extensible
+%entry and the index of th current entry. The root of the extension hierarchy
+%is always at index 0 and that entry contains 0. The function
+%\c{CHECK\_RTTICAST} is used to walk this encoding to verify a cast from a
+%\RTTI{} pointer into a \SAFE{} pointer or another \RTTI{} pointer.
+
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\section{Specifying Trusted Code}\label{sec-trusted}
+\TODO{this section}
+
+ In this section we describe a few mechanisms that you can use to override
+Deputy's reasoning. These are powerful mechanisms but you can use them to
+write unsafe code.
+
+ \subsection{Trusted casts}
+
+ Occasionally there are casts in your program that are judged as bad, yet you
+know that they are sound and it is too inconvenient to change the program to
+expose the soundness to Deputy. In that case, you can use the
+\c{TC} built-in function. In the following example we know that
+the \c{boxedint} type can encode an integer (if odd) or a pointer to a
+\c{boxedint} if even. We could use \RTTI{} pointers to encode this safely in
+Deputy. Or, we can use a trusted cast:
+\begin{deputycode}[fails]
+typedef void * boxedint; // If even, then a pointer to a boxedint
+int unroll(boxedint x) {
+ if((unsigned long)x & 1) return x;
+ return unroll(* (boxedint * SAFE)TC(x));
+}
+\end{deputycode}
+\TODO{Why does this code fail? Fix it, and remove the fails annotation}
+
+ Deputy will not complain if the argument and result type of
+\c{TC} are incompatible. However, it will ensure the following:
+\begin{itemize}
+\item A \c{TC} acts as a cast from the point of view of
+ propagating the \SEQ{} and \FSEQ{} requirement. This means that both the
+ argument and the result type will have the same kind.
+%\item The argument and the result type are compared and in those pointer types
+% in them that correspond, are forced to have the same kind.
+\end{itemize}
+
+ For example, in the following example, the variable \c{q} and the field
+\c{f1} in \c{struct foo} are made \FSEQ{}. The \FSEQ{} constraint propagates
+back through \c{TC} to \c{p}.
+%\begin{deputycode}
+%struct foo {
+% int * f1;
+% int f2;
+%};
+%struct bar {
+% int * f1;
+% int * f2;
+%};
+%int main(struct bar * p) {
+% struct foo * q = TC(p);
+% p->f1 ++; // Make foo.f1 FSEQ
+% return q[1].f2; // Make q FSEQ
+%}
+%\end{deputycode}
+
+ If you look carefully at the above examples you will see one of the potential
+dangers of using \c{TC}: you are on your own to ensure that the
+argument type and the result type match. In the above example, this is not
+true because the field \c{f1} in \c{struct bar} is \SAFE{} while the field
+\c{f1} in \c{struct foo} is \FSEQ{}!
+
+ If you want to prevent a pointer arithmetic operation from generating
+sequence pointers, you can use the \c{TC} function:
+\begin{deputycode}
+int foo(int *p) {
+ int * q = TC(p) + 4;
+ return *q;
+}
+\end{deputycode}
+
+ You can use a \c{TC} to cast an integer into a pointer. This
+works as expected if the type of the resulting pointer is \SAFE{} (as in the
+example with \c{boxedint} earlier in this section). But if it is \FSEQ{} or
+\SEQ{} then you will get exactly the same effect as if the
+\c{TC} was not there: you will obtain a pointer with null
+metadata and thus unusable for memory dereference.
+
+
+ \subsection{Turning off Deputy}
+
+ You can turn the curing off for a fragment of a source file, for a function,
+or for a block statement.
+
+% You can use the \t{cure} pragma to turn curing off for a fragment of a source
+%file (in Deputy pragmas can only appear at global scope and therefore you
+%cannot use this mechanism to turn curing off for part of the definition of a
+%global function):
+%%\begin{deputycode}
+%%int * g; // This is a pointer to several integers
+%% // but we do not want to make it SEQ
+%%#pragma ccured(off)
+%%int foo() {
+%% return g[2]; // Deputy won't see this and will leave g SAFE
+%% // But also Deputy won't check this code
+%%}
+%%#pragma ccured(on)
+%%\end{deputycode}
+%
+% Alternatively, you can add the \t{nocure} attribute to a function to tell
+%Deputy to not cure this function:
+%
+%\begin{deputycode}
+%int * g; // This is a pointer to several integers
+% // but we do not want to make it SEQ
+%
+%// We must put the attribute in a prototype
+%int foo(void) __NOCURE;
+%int foo(void) {
+% return g[2]; // Deputy won't see this and will leave g SAFE
+% // But also Deputy won't check this code
+%}
+%\end{deputycode}
+%
+% At a finer-grained level, you can use the \t{\_\_NOCUREBLOCK} attribute with
+%a block statement:
+%\begin{deputycode}
+%int * g; // This is a pointer to several integers
+% // but we do not want to make it SEQ
+%
+%int foo(void) {
+% int res;
+% { __NOCUREBLOCK
+% res = g[2]; // Deputy won't see this and will leave g SAFE
+% }
+% return res;
+%}
+%\end{deputycode}
+%
+% In all of these cases, the Deputy inferencer does not even look at the
+%non-cured portions of the code. However, Deputy will at least change the
+%non-cured code to access the fat pointers properly. For example, in the
+%following example the global \c{g} is a sequence pointer. While Deputy will
+%not complain about the unsafe cast to \c{int **}, it will make sure that at
+%least the proper component of \c{g} is used:
+%
+%\begin{deputycode}
+%int * g; // This will be FSEQ
+%
+%int ** foo(void) {
+% int res = g[2]; // Make g FSEQ
+% { __NOCUREBLOCK
+% return (int **)g; // But not WILD
+% }
+%}
+%\end{deputycode}
+%
+% Finally, to avoid curing a whole source file (say \t{trusted\_foo.c}), you can
+%use the \t{--leavealone=trusted} argument to Deputy. All source files whose
+%names start with the given ``leave alone'' prefix, are not merged and are not
+%scanned by Deputy at all. Instead they are compiled with \t{gcc} and linked in
+%the final executable.
+
+
+
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ \section{Function Pointers}\label{sec-funptr}
+\TODO{this section}
+
+ One of the signs that a C program is a ``serious'' one is the use of function
+pointers. There would be nothing wrong or unsafe about that if it wasn't also
+the case that most programmers do not feel necessary to use accurate types for
+function pointers, or to even use function prototypes. This is probably due to
+the fact that the syntax for function types in C is terrible. How often have
+you declared your function pointers to have type \c{void (*)()} when you
+actually wanted to say \c{int * (* (* x3))(int x)(float)} (a pointer to a
+function that takes an \c{int} and returns a pointer to a function that takes
+a \c{float} and returns a pointer to an \c{int}).
+
+ Of course, misusing function pointers can lead to the worst kind of errors.
+Fortunately such error rarely go unnoticed in code that is executed.
+
+ Deputy supports two kinds of function pointers. The \SAFE{} function pointers
+can only be invoked with the same number of arguments. If the types of the
+arguments are not right it is the argument that becomes \WILD{} not the
+function pointer. A \SAFE{} function pointer can only be cast to an integer or
+to the same function pointer type. We also have \WILD{} function pointers
+which you can (try to) use as you please. In fact a \WILD{} function pointer
+can be cast to any other \WILD{} pointer type and can be stored in any tagged
+area. For this reason its representation must match that of any \WILD{}
+pointer. However the capabilities of a \WILD{} function pointer are typically
+quite different from those of a regular function pointer. For example, you
+should not be able to read or write from a function pointer.
+
+ Any function whose address is taken and becomes \WILD{}, or that is used
+without a prototype (see the discussion at the end of this section) is a {\em
+tagged function} and has an associated descriptor that encodes the actual code
+to the function and the number of arguments. Here is an example:
+
+%\begin{deputycode}
+%int taggedfun(int anint, int * aptr) {
+% return anint + * aptr;
+%}
+%
+%int main() {
+% int * i = taggedfun; // Bad cast. wildfun becomes tagged
+% // Now we invoke it
+% ((void (*)(int,int*))i)(5, i);
+%}
+%\end{deputycode}
+
+ The structure of a function descriptor is as shown below and a pointer to the
+\c{\_pfun} field is used as the \c{\_b} field whenever the address of the
+function is taken.
+
+\begin{code}
+struct __functionDescriptor {
+ unsigned int _len ; // Always 0
+ void (* _pfun)() ; // Pointer to a function
+ unsigned int _nrargs ; // The number of arguments
+};
+\end{verbatim}\end{code}
+
+ Since the \c{\_len} field is always initialized to zero, whenever this
+\WILD{} pointer is used for a read or a write it would appear that it points
+into a zero-length tagged memory area, so the bounds check will fail. We then
+have to protect against the pointer being subject to arithmetic prior to
+invocation. We do this by storing in the function descriptor the actual
+pointer to the function and checking at the time of a call through a \WILD{}
+function pointer that the \c{\_p} field of the pointer is equal to the
+\c{\_pfun} field in the descriptor.
+
+ Finally we have to ensure that the function is called with the right number
+and kinds of arguments. There is no hope to be able to ensure this statically
+because a \WILD{} function pointer can be used very liberally as any other
+\WILD{} pointer. So, Deputy conservatively forces
+all arguments and the return type to be \WILD{} pointers. This includes
+arguments and return types that are actually scalars (see the example above
+for how integers are wrapped into \WILD{} pointers). This will ensure that the
+types are the same (or compatible) and all we have to check is the right
+number of arguments is passed to the function. To perform these checks we use
+the following run-time support function:
+\begin{code}
+/* Check that a function pointer points to a valid tagged function and check
+ that we are passing enough arguments. We allow the passing of more
+ arguments than the function actually expects */
+__CHECK_FUNCTIONPOINTER(void *_p, /* The _p field of the function pointer */
+ void *_b, /* The _b field */
+ int nrActualArgs); /* The number of actual arguments */
+\end{verbatim}\end{code}
+
+ Also, {\em always use prototypes for the external functions you are using}.
+Otherwise, it will appear to Deputy that you are casting the function pointer
+to various incompatible types corresponding to each use and the function will
+be declared tagged (and pointers to such function to be \WILD{}). You get some
+help from Deputy here because its whole-program merger will construct
+prototypes for the functions that are defined somewhere in your program. But
+when you use even simple things like \c{printf} you must include the proper
+header files.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ \section{Global Initialization}\label{sec-globinit}
+\TODO{this section}
+
+ C has a very rich language of initializers for globals and locals. The
+language is so rich that neither \c{gcc} nor MSVC implement it fully. For a
+discussion of how our front-end handles initialization, please see the \ahref{../cil/index.html}{the CIL documentation}.
+
+ Once programs are presented to Deputy all the initialization for locals is
+turned into assignments, but most initialization code for globals is
+preserved. However, in some cases Deputy must insert some checks related to
+the initializers. These checks are placed in a special function called a {\em
+global initializer}.
+
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%5
+ \section{Casting Integers to Pointers}\label{sec-castint}
+\TODO{this section}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ \section{Variable argument functions}\label{sec-vararg}
+\TODO{this section}
+
+ Variable-argument functions in C are inherently unsafe since there is no
+language-level mechanism to ensure that the actual arguments agree in type and
+number with the arguments that the function will be using. There are several
+ways to implement variable argument functions in C and Deputy supports some of
+them quite well:
+\begin{itemize}
+\item You can try to implement such function by taking the address of a formal
+argument and working your way through the stack frame. If you do this we wish
+you luck and perseverance and you'll need them both while trying to figure out
+why your program does not behave for compilers such as \c{gcc}. Deputy
+certainly cannot allow this because this is exactly the kind of operation that
+viruses would want to perform.
+\item A better alternative is to use the \c{\_\_builtin\_next\_arg} function on
+\c{gcc} and then work your way up the stack. Deputy does not support this
+low-level implementation of variable argument functions, but see next.
+\item You can write your variable argument functions using the standard macros
+in \c{<stdarg.h>} and \c{<vararg.h>}. Deputy supports most such functions with
+minimal programmer intervention.
+\end{itemize}
+
+
+ There are two kinds of variable-argument functions in C:
+\begin{itemize}
+\item Those that take an arbitrary number of arguments following the last
+specified formal (their function type contains \c{...} after the last formal).
+We'll call these functions {\em vararg} functions. An example is \c{printf}:
+\begin{code}
+int printf(const char* format, ...)
+\end{verbatim}\end{code}
+
+\item Those that take as arguments one or more pointers to lists of arguments.
+We'll call these functions {\em valist} functions. An example is \c{vprintf}:
+\begin{code}
+int vprintf(const char* format, va_list args)
+\end{verbatim}\end{code}
+\end{itemize}
+
+ Deputy supports both kinds of functions and will scan the program to find out
+for each function what types of arguments are passed. In \secref{manualvararg}
+we describe how the programmer can prevent this automatic inference by
+specifying the set of types of arguments.
+
+ Deputy redefines the macros in \c{<stdarg.h>} and \c{<vararg.h>} to do
+special bookkeeping. In vararg functions, the macro \c{va\_start} is used to
+initialize an \c{va\_list} variable to point to the trailing arguments. Deputy
+checks that the second argument is the last formal before the \c{...}.
+
+ Both in vararg and valist functions the macro \c{va\_arg} can be used, as
+follows:
+\begin{code}
+ T x = va_arg(args, T)
+\end{verbatim}\end{code}
+
+ \c{args} must be a \c{va\_list} variable and \c{T} must be compatible after
+the usual actual argument promotions (e.g. \c{char} and \c{short} to \c{int}
+and \c{float} to \c{double}) with one of the types in the \c{struct} associated
+with \c{args}. Deputy checks this at run-time.
+
+ The Deputy support for variable argument functions is quite flexible.
+Multiple variable argument lists can be processed in parallel, an argument
+list can be re-initialized with \c{va\_start} and processed multiple times. A
+function can even work with variable argument lists that have different sets
+of types accepted (but for this you need to specify manually the set of types
+of arguments as explained in \secref{manualvararg}). Variable argument lists
+can be passed down but the regular Deputy checks for stack allocated variables
+will prevent the passing of these lists up the call chain and also their
+storing in the heap.
+
+ The main thing that is not supported in Deputy is the fetching of an argument
+with a different type than it was stored. It remains to be seen if this is a
+problem. We have looked at several variable argument functions (including full
+implementations of \c{printf} and \c{sprintf}) and so far we have found that
+Deputy accepts those functions without any change except for the specification
+of the \c{struct} of the accepted argument types (as explained below).
+
+
+ \subsection{Programmer control over vararg functions}
+ \label{sec-manualvararg}
+
+ If you do not want Deputy to find automatically all the types that can be
+passed to a function, you can specify the set of types that can be used for
+arguments. Also, you should not let Deputy infer the argument types for
+\c{printf}-like functions, but you should instead use the special support for
+them, as explained in \secref{printf}.
+
+ You can declare the argument types by declaring a descriptor. This is a
+\c{struct} data type whose fields have the types that can be passed to the
+function. The order and the names of the fields do not matter. For example,
+such a struct for \c{printf} would be the following (this structure is defined
+in \t{ccured.h}):
+\begin{code}
+struct printf_arguments {
+ int f_int;
+ double f_double;
+ char *f_string;
+};
+\end{verbatim}\end{code}
+
+ The simplest way to specify that such a \c{struct} describes the types of
+arguments for a variable argument function is to use a pragma:
+\begin{code}
+#pragma ccuredvararg("myvarargfunction", sizeof(struct printf_arguments))
+\end{verbatim}\end{code}
+
+Notes:
+\begin{itemize}
+\item Since most variable argument functions are \t{printf}-like, Deputy
+ provides special support for them. See \secref{printf} if your function is
+ of this kind.
+
+\item Note that Deputy predefines the \c{struct printf\_arguments} so you do
+not have to redefine it.
+
+\item Like all Deputy pragmas, you can put them anywhere in your project since
+Deputy is going to merge all files into one. However, I typically prefer to
+put such pragmas in header files near the prototype for the function.
+
+\item This method does not work for specifying pointers to variable argument
+ functions. You must use the attribute method described below.
+
+\item The \c{sizeof} operator is there because the syntax of pragmas is pretty
+much that of function calls and thus we cannot use types directly.
+
+\item This pragma can be used with both kinds of
+variable argument functions. In the case of valist functions it specifies that
+{\em all} formals and locals of type \c{va\_list} can hold arguments of the
+given types.
+\end{itemize}
+
+ An equivalent method is to associate the \c{\_\_DEPUTYVARARG(struct
+printf\_arguments)} attribute with the type of the function
+\c{myvarargfunction}:
+\begin{code}
+int (__DEPUTYVARARG(struct printf_arguments) myvarargfunction)(int last, ...);
+\end{verbatim}\end{code}
+
+ You have to use this method if you want to specify that a function pointer is
+variable argument:
+\begin{code}
+int (__DEPUTYVARARG(struct printf_arguments) * myvarargptr)(int last, ...);
+typedef int (_DEPUTYVARARG(struct printf_arguments) fptr)(char *format,...);
+\end{verbatim}\end{code}
+
+ A more fine-grained way to specify the same thing is to use the
+\c{\_\_DEPUTYVARARG} {\em type attributes} for \c{va\_list} every time it appears.
+This allows you to specify different sets of types for different locals:
+\begin{code}
+va_list __DEPUTYVARARG(struct printf_arguments) args1,
+ __DEPUTYVARARG(struct some_other_type) args2;
+\end{verbatim}\end{code}
+
+
+ \subsection{Printf-like functions}\label{sec-printf}
+
+ Since the vast majority of uses of variable argument functions if for
+\c{printf}-like functions, Deputy contains special support for them.
+Specifically if a vararg function is declared to be a \c{printf}-like function
+then all of its invocations in which the format string is a constant will be
+checked statically. For the other invocations a wrapper for printf will be
+called that will check the types of the actuals against the format string
+before calling the real \c{printf} function.
+
+ To declare a function to be \c{printf}-like use the following pragma:
+\begin{code}
+#pragma ccuredvararg("myprintf", printf(1))
+\end{verbatim}\end{code}
+
+ where the last argument is the index of the format argument in the argument
+list (starting with 1). Note that you will get a run-time error if you try to
+use the \c{va\_arg} macro in the implementation of such a function. In those
+implementations you should invoke functions like \c{vprintf} and \c{vsprintf}
+instead.
+
+ GCC already has support for communicating to the compiler that a function is
+\c{printf}-like. This is done as follows:
+\begin{code}
+int myprintf(const char* format, ...) __attribute__((format(printf, 1, 2)))
+\end{verbatim}\end{code}
+
+ where the ``1'' means that the first argument is the format string and the
+``2'' means that we should start checking with the second argument. Deputy
+recognizes this attribute and it considers it equivalent with the
+\c{ccuredvararg} from above. Note that the second argument in the
+\c{format} attribute is ignored in Deputy.
+
+ You can use the \t{format} attribute even for function pointers:
+\begin{code}
+int (__attribute__((format(printf, 1, 2))) *myptr)(char *format, ...);
+\end{verbatim}\end{code}
+
+ Note that Deputy does not currently like passing pointers to \c{printf} with
+the intention of printing the pointer value. You should manually cast those
+pointers to \c{long} when passing them to \c{printf}-like functions.
+
+ Also, you should not let Deputy infer automatically the descriptors for
+\c{printf}-like functions. Otherwise, it is quite likely that the descriptor
+that will be inferred is different than the built-in descriptor
+\c{printf\_arguments} (which the runtime library is using to check the calls
+to \c{printf}-like functions. Deputy will warn you about all automatically
+inferred descriptors and you should manually inspect all the functions
+involved.
+
+
+ As for the regular variable argument functions, the \t{pragma} works only for
+named functions but not for pointers to functions. For that purpose you must
+use attributes:
+
+\begin{code}
+int (__DEPUTYFORMAT(1) * myprintf)(char *format, ...);
+typedef int (_DEPUTYFORMAT(1) fptr)(char *format,...);
+\end{verbatim}\end{code}
+
+
+ \subsection{Scanf-like functions}\label{sec-scanf-like}
+
+ Since it proved too much trouble to handle \c{scanf}-like functions in a safe
+yet transparent way we currently require the programmer to rewrite the
+invocations to \c{scanf} using a number of functions that we provide. For
+example instead of
+\begin{code}
+ int entry; double then; char buffer[6];
+
+ ... fscanf(file, "Entry:%d; Then:%lf; 5 digits:%5[0-9]; useless text.",
+ &entry, &then, buffer) ...
+\end{verbatim}\end{code}
+
+ you should write
+\begin{code}
+ ... (resetScanfCount(),
+ entry = ccured_fscanf_int(file, "Entry:%d"),
+ then = ccured_fscanf_double(file, "; Then:%lf"),
+ ccured_fscanf_string(file, "; 5 digits:%5[0-9]", buffer),
+ ccured_fscanf_nothing(file, "; useless text."), //advance the file pointer.
+ getScanfCount ()) ...
+\end{verbatim}\end{code}
+
+ The functions \c{resetScanfCount} and \c{getScanfCount} are necessary only
+if you use the result of the call to \c{fscanf} in the original code. Note
+that our replacement \c{scanf} functions can be used to return only one result
+at a time, consequently the format string that is passed must contain only one
+format specifier, possibly along with characters to be matched.
+
+ The following are the \c{scanf}-like functions that we currently support:
+\begin{code}
+ extern int ccured_fscanf_int(FILE *, char *format);
+ extern double ccured_fscanf_double(FILE *, char *format);
+ extern void ccured_fscanf_string(FILE *, char *format, char *string);
+ extern void ccured_fscanf_nothing(FILE *, char *format);
+\end{verbatim}\end{code}
+
+ If the original program uses \c{scanf}, just consider that you are using
+\c{fscanf} from \c{stdin}. If instead your program contains \c{sscanf} then
+you can use the function
+\begin{code}
+void resetSScanfCount(char *string);
+\end{verbatim}\end{code}
+
+to dump the string to the temporary file \c{ccured\_sscanf\_file}
+then use the replacement for \c{fscanf} from above. For example,
+
+\begin{code}
+ ... (resetSScanfCount(inputString),
+ entry = ccured_fscanf_int(ccured_sscanf_file, "Entry:%d"),
+ then = ccured_fscanf_double(ccured_sscanf_file, "; Then:%lf"),
+ ccured_fscanf_string(ccured_sscanf_file, "; 5 digits:%5[0-9]", buffer),
+ getScanfCount ()) ... //getScanfCount is required when using resetSScanfCount
+\end{verbatim}\end{code}
+
+ {\bf Note that the current support for \c{scanf} is far from satisfactory and
+ will likely change in the future}
+
+
+ \subsection{Implementation Issues}
+
+ Almost all of the checking for variable-argument functions is done at
+run-time. At the time of a call each actual argument is compared with the
+types in the \c{struct} associated with the vararg function. A global data
+structure is filled with the number of arguments (in the global
+\c{\_\_ccured\_va\_count} and a list of indices describing for each actual
+argument the index within the \c{struct} types (in \c{\_\_ccured\_va\_tags}).
+
+ In the body of a vararg function, a data structure is allocated on the stack
+to hold a copy of the global description of the arguments that was created by
+the caller. The call to \c{va\_start} initializes this data structure and each
+call to \c{va\_arg} checks that we are not reading past the end of the
+actuals and also that the type of the fetched argument matches that of the
+actual argument.
+
+
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ \section{Annotated Lengths}\label{sec-dependent}
+
+Programmers can annotate array pointers with length attributes.
+Deputy will then use the annotated length whenever it needs to do a
+bounds check on that pointer, instead of transforming the pointer into
+a fat pointer. This has two advantages:
+\begin{itemize}
+\item Deputy will not need to change the representation of this
+ pointer, which improves compatibility with precompiled code.
+\item Using a Deputy fat pointer to store the length of a buffer may
+ be redundant if the program already maintains a similar length value
+ near the pointer.
+\end{itemize}
+
+Length annotations are allowed in two situations: struct fields may
+have length annotations that depend on the values of other fields in
+that struct, and function parameters may have lengths that depend on
+other parameters in that function. (NB: but the annotations on
+function parameters are not yet implemented. Coming soon ...)
+% TODO: return values, constant expressions, etc.
+
+Only pointer types may be annotated. The annotation
+\c{\_\_SIZE($exp$)} on a field means that the associated pointer is
+$exp$ bytes long, where the expression $exp$ can involve integer
+constants, arithmetic, \t{sizeof}, and the names of other fields in
+the same struct. So \c{\_\_SIZE(1 + foo)} means that the specified
+pointer has a length that's one greater than the runtime value of
+field foo in the same object.
+
+\c{\_\_COUNT($exp$)} means that the pointer is $exp$ elements long.
+So when annotating a pointer with type \c{T*}, the
+annotation \c{\_\_COUNT($exp$)} is equivalent to \c{\_\_SIZE($exp$ *
+sizeof(T))}.
+
+Any field that is referred to by a \c{\_\_SIZE} or \c{\_\_COUNT}
+annotation is a {\em metadata field}. When a metadata field is
+modified, any pointer fields that depend on it are set to NULL. {\em
+Therefore, when writing both the metadata and pointer fields, programs
+must always modify the metadata first, followed by the pointer.}
+
+ When an annotated pointer field is read, Deputy will read any
+metadata fields as well, and associate that length with the pointer.
+When a pointer field is written, Deputy will check that the buffer's
+length is less than or equal to the length specified by the current
+value of the metadata fields.
+
+\begin{deputycode}
+extern void* (DALLOC(sz) malloc)(int sz);
+
+struct bar {
+ int nrInts;
+ int *ints COUNT(nrInts);
+};
+
+struct foo {
+ int sizeBars;
+ struct bar * bars COUNT(sizeBars);
+};
+
+// Now the function that uses it
+
+void init(struct foo* pFoo) {
+ int nrBars = 5;
+ pFoo->sizeBars = nrBars * sizeof(* pFoo->bars);
+ pFoo->bars = (struct bar*)malloc(pFoo->sizeBars);
+}
+\end{deputycode}
+
+
+In this code, we first overwrite the field \t{pFoo->sizeBars}, which
+automatically sets the field \t{pFoo->bars} to NULL. The next step is
+to write a new pointer to the \t{pFoo->bars} field. During this
+write, Deputy will check that the pointer being written (in this case,
+the result of \t{malloc}) is at least ``pFoo->sizeBars'' bytes long.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ \section{Memory Management}\label{sec-gc}
+\TODO{this section}
+
+ The high order bit: we use the Boehm-Weiser garbage collector.
+
+ TODO : finish this section
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ \section{Deputy Pragmas}\label{sec-pragma}
+\TODO{this section}
+
+% ======================================================================
+\chapter{Deputy Warnings and Errors}\label{ch-warn}
+\TODO{this section}
+
+ As you use Deputy you might encounter various kinds of problems. Most of
+these are due to a combination of aggressive coding practices and Deputy being
+less smart than the programmer. (Note: this section is continuously being
+expanded; if you do not see the answer to your question, or if the answer is
+not helpful, let us know).
+
+
+%%%%%%%%%%%%%%%%%%%%%%%
+\section{Compile-time Errors}\label{sec-warn-compile}
+\begin{itemize}
+\item Type mismatch: If Deputy sees an assignment where the types on the left-
+ and right-hand sides aren't compatible, it will print this error. Either fix
+ the types or insert a trusted cast by putting \c{TC(...)} around the
+ right-hand side.
+
+\item Incorrect allocation type: Deputy expects to be able to infer the type
+of an allocation (e.g., \c{malloc}) from the right-hand side alone. The
+argument to \c{malloc} should be of the form \c{e * sizeof(t)}, where \c{e} is
+an expression containing constants, locals, *, and +. You can omit the
+\c{sizeof(t)} if \c{t} is \c{char}. If \c{t} is void, you'll have to specify
+\c{sizeof(void)} (which is, surprisingly enough, equal to 1). (This could be
+better, I know!) \TODO{this explanation should be in memory allocators}
+
+\item Missing WHEN expression: If Deputy sees a union whose fields are
+unannotated, it will complain. You can add \c{WHEN(e)} to each item, or you
+can choose to trust the union by placing \c{TRUSTED} after the \c{union \{ ...
+\}} definition.
+\end{itemize}
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%55
+%%%%%%%%%%%%%%%%%%%%%%%%%%% RUNNING
+\section{Run-time Errors}\label{sec-warn-run}
+
+ When you run the code you might get run-time errors. Make sure you read the
+\chref{invoke} on ways to control the handling of errors.
+
+\begin{itemize}
+
+\item \TODO{The run-time errors}
+
+\end{itemize}
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%55
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{License}
+
+Copyright (c) 2005-2006,
+\begin{itemize}
+\item Jeremy Condit <jcondit@cs.berkeley.edu>
+\item George Necula <necula@cs.berkeley.edu>
+\end{itemize}
+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.
+
+\chapter{Bug reports}
+
+ If you find a bug in Deputy, please send email to
+\ahref{mailto:jcondit@cs.berkeley.edu}{Jeremy Condit}.
+
+\chapter{Changes}\label{sec-changes}\cutname{changes.html}
+
+ Below are some of the changes in the Deputy system. These are in addition to
+\ahref{../cil/changes.html}
+{changes made to the underlying CIL infrastructure}
+
+\begin{itemize}
+\item {\bf May 1, 2006} First version of this manual.
+\end{itemize}
+
+
+
+\appendix
+
+
+
+% ========================= Regression Tester ========================
+\chapter{Using the Regression Tester}\label{ch-regtest}
+
+ The regression tester is a program that allows you to do two things:
+\begin{itemize}
+\item Run a list of shell commands and capture their standard and error output
+ in a log file, and
+
+\item Analyze such log files and extract various information, among which the
+ most important is which test cases have succeeded and which have failed.
+
+\item Compare results of two runs according to many parameters, such as
+whether the test succeeded or not, how much time Deputy took to process it,
+how many different kinds of pointers were inferred and how fast is the
+resulting program.
+\end{itemize}
+
+ Since the running of the tests and the analysis of the output is separated
+you can easily do things like compare the results on multiple runs, extract
+various reports from a single output (like what tests have succeeded, which
+have failed, plus such information split by test groups). You can also extract
+some data from each test (such as the running time) and make simple reports.
+
+ Test cases can have comments associated with them (such as reminders of why
+it fails) and can be associated with zero or more test groups.
+
+ \section{Running the regression}\label{sec-regtest}
+
+ The regression tester is implemented in Perl as "\t{runtests.pl}", which in
+turn contains simple wrappers for functions provided by the more generic
+\t{RegTest.pm}.
+
+ The regression tester uses relative paths so it must be run in the
+ \t{deputy/test} directory.
+
+ The basic command for running the tests is "\t{runtests --run}". This runs
+all of the test cases, saving the log in the file "\t{runtests.log}". Before
+creating this file, it renames previous versions of this file as
+"\t{runtests.log.<n>}" where n is an integer starting from 1 to a maximum number
+that is configurable.
+
+ The following command line options are useful for running the tests (see
+ "\t{runtests --help}" for a complete list:
+
+\begin{verbatim}
+ --one <testname> : runs only the named test
+ --gory : shows lots of details about the execution of the
+ test, such as the commands executed
+ --dryrun : only pretends to run the test. Useful to see what
+ would be run
+ --log : select the base name of the log file (default
+ "safec.log")
+ --logversions <n> : keep logs up to version <n>. Default is 5.
+ --noremake : runs the commands without trying to remake the safec
+ compiler before each test. Useful if you want to
+ work on the compiler while the tests are running
+ --safecdebug : uses the DEBUG version of the safec compiler and
+ uses the C compiler in debug mode. By default it
+ used the RELEASE version and the optimizing compiler.
+
+
+
+ --group <groupname> : adds all the tests in the named group to the list of
+ tests to be run or to participate in the analysis of
+ the log. (Right now we have NO groups)
+ If no such option is
+ specified then all tests are selected. Multiple such
+ options can be given and are cumulative.
+ --nogroup <groupname> : excludes the tests in the named group from running
+ or from the analysis. Multiple such options can be
+ given and are cumulative. These options are
+ processed after all --group options have
+ been processed.
+
+ --listtests : list the tests that are enabled along with their
+ group membership. This is useful to find out what
+ tests and groups exist.
+
+ --stoponerror : stop at the first error
+ --showoutput : show the output on the console. Normally output is
+ saved in a file.
+\end{verbatim}
+
+ \section{Analyzing the results}
+
+ The basic command for analyzing log files is "\t{runtests}". This will
+prompt the user to select one of the several log files that exist in the
+current directory and then (by default) it will print a list of the failed
+test cases, with a short (user provided) comment and the last error message
+detected in the output for that test case.
+
+ The following commands are useful during analysis:
+\begin{verbatim}
+ --log : select the log file (see above)
+ --group, --nogroup : select groups (see above)
+ --listtests : list tests and groups (see above)
+ --param=<pnames> : show a report about the successes, with the columns
+ being the named parameters (separated by ,). Run
+ "testsafec --help" to see what parameters are
+ available. Use --param=ALL to make a report with
+ all available parameters.
+ --sort=<pnames> : sorts the report by the given parameters.
+\end{verbatim}
+
+ Furthermore, the reports that are generated can be compared. To compare the
+ results of two runs (whose logs are say ``runtests.log.1'' and ``runtests.log.2'',
+ run
+
+\begin{verbatim}
+ test/compare runtests.log.2 runtests.log.1 --group=slow
+\end{verbatim}
+
+ This will compare the results of \t{runtests.log.2} using as reference the
+results in log \t{runtests.log.1}.
+
+ \section{Configuring the regression}
+
+
+ For this you have to edit runtests.pl. You will see a large section in the
+ middle of the file containing lines like:
+
+\begin{verbatim}
+addDeputyTest("foo");
+\end{verbatim}
+
+
+ (check out the definition of \t{addDeputyTest} at the bottom of the file).
+ This adds the test named "\t{foo}", which processes \t{test/small/foo.c}.
+
+
+ To add just one test do:
+
+\begin{verbatim}
+ $TEST->newTest(Name => "mytestname",
+ Dir => "..",
+ Cmd => "make something",
+ Enabled => 1,
+ Comm => "Print this along with the test name",
+ Group => ["mygroup"],
+ Patterns => \%mypatterns);
+\end{verbatim} % $
+ Sometimes you might want to add just a comment or to add one group to a
+ certain test. Use the following simple functions:
+
+ There are some wrappers defined at the end of runtests.pl:
+
+\begin{verbatim}
+ addBadComment("li-box", "bug in box.ml");
+\end{verbatim}%$
+
+
+% ------------------------ automatic tester ------------------
+\section{The Automated Regression Tester}
+
+ Every time you commit a change to the DEPUTY repositories you trigger a
+ regression test and you should be receiving email with the results. If you
+don't then it must be that the automated regression tester is not running or
+it has encountered a problem that it cannot fix.
+
+ The automated regression tester is implemented as a script \t{mk-reports.pl}
+and lives in the home directory of user \t{regtest} on \t{manju}. To see
+whether the tester is running run \t{ps -Af} and look for a line \t{perl
+mk-reports.pl -daemon}. If you do not see any let me know.
+
+ Here are the operations that are performed by the tester:
+
+\begin{enumerate}
+\item A new directory is created under \t{/home/regtest/deputy.nightly}. The name
+of the directory encodes the time of the commit (e.g.
+\t{2001-12-07\_17\_50\_-0800.dir} is the directory for the commit at 17:50 on
+07/12/2001 in the timezone that is 8 hours behind UTC).
+\item A complete copy of DEPUTY is checked out in that directory and
+\t{make} is run in there.
+\item Then in the \t{test} directory we run \t{runtests} but only on the
+groups that are known to terminate quickly. This run takes about 3 minutes. A
+copy of the \t{runtests.log} file generated is saved as \t{/home/regtest/deputy.nightly/2001-12-07\_17\_50\_-0800.runtests.quick.log}.
+\item Then we run \t{runtests} again to produce a report with all available
+parameters. This report is saved as
+\t{/home/regtest/deputy.nightly/2001-12-07\_17\_50\_-0800.report.quick.txt}. In the
+event that any of the previous steps fail this file will be created but with
+zero length.
+\item Then we compare this report both with the previous commit and with a
+reference report and a message is sent to the user who performed the commit.
+This report is also saved as \t{/home/regtest/deputy.nightly/2001-12-07\_17\_50\_-0800.msg.quick.txt}.
+\end{enumerate}
+
+%%%%%%%%%%%%%%%%%
+\chapter{Debugging support}\label{sec-debugger}
+
+ Most of the time we debug our code using the Errormsg module along with the
+pretty printer. But if you want to use the Ocaml debugger here is an easy way
+to do it. Say that you want to debug the invocation of Deputy that arises out
+of the following command:
+\begin{verbatim}
+ccured --separate -c hello.c
+\end{verbatim}
+
+ You must follow the installation \ahref{../ccured/setup.html}{instructions}
+to install the Elist support files for ocaml and to extend your .emacs
+appropriately. Then from within Emacs you do
+\begin{verbatim}
+ALT-X my-camldebug
+\end{verbatim}
+
+ This will ask you for the command to use for running the Ocaml debugger
+(initially the default will be ``ocamldebug'' or the last command you
+introduced). You use the following command:
+\begin{verbatim}
+ccured --ocamldebug -c hello.c
+\end{verbatim}
+
+ This will run \t{ccured} as usual and invoke the Ocaml debugger when the cilly
+engine starts. The advantage of this way of invoking the debugger is that the
+directory search paths are set automatically and the right set or arguments is
+passed to the debugger.
+
+ For the \t{make}-based interface to our regression tests you can pass the
+argument \t{OCAMLDEBUG=1} to \t{make} to achieve the same effect.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{Experimental Features}
+
+\end{document}
+
+
+% LocalWords: unannotated memset
--- /dev/null
+#
+# Preprocesses a text and it changes
+# \begin{deputycode}[comma_separated_options]
+# ...
+# \end{deputycode}
+#
+# The following options are supported:
+# local - the code is generated inside a "main" function. By default the
+# code goes at global scope
+# fails - the processing is expected to fail
+# norun - show just the code, not the Deputy output
+#
+# into the verbatim environment and add the option to see the Deputy output for
+# it.
+# Invoke: deputycode.pl in.tex out.tex
+use strict;
+use Data::Dumper;
+use File::Copy;
+
+open(IN, "<$ARGV[0]") || (&help(), die "Cannot open file \"$ARGV[0]\"");
+open(OUT, ">$ARGV[1]") || (&help(), die "Cannot open file \"$ARGV[1]\"");
+sub help {
+ print "Invoke deputycode.pl in.tex out.tex";
+}
+
+my $doexamples = ! defined($ENV{'NO_EXAMPLES'});
+
+my $testnr = 1;
+my $tmpdir = "deputycode.tmp";
+my $htmloutdir = "examples";
+my $outdir = "html/deputy/$htmloutdir";
+
+my @ccured = ('perl', '../bin/deputy', '--deputyopt=3', '--noPrintLn',
+ '--save-temps');
+
+my $preambleLocal = <<EOF;
+int main(void) {
+\# 1
+EOF
+
+my $preambleGlobal = <<EOF;
+EOF
+
+my $postambleGlobal = "";
+my $postambleLocal = <<EOF;
+}
+EOF
+
+if(! -d $tmpdir) {
+ mkdir $tmpdir || die "Cannot make $tmpdir\n";
+
+}
+my $incode = 0;
+my @opt; # Array of , separated options passed to ccuredcode environment
+
+
+my $lineno = 0;
+while(<IN>) {
+ # Strip extra \n\r at the end
+ if($_ =~ m|^([^\n\r]*)[\n\r]*|) {
+ $_ = "$1\n"; # And add one
+ }
+ $lineno ++;
+ if(! $incode && $_ =~ m|^\\begin{deputycode}(\[(.*)\])?|) {
+ @opt = split(/[ ,]/, $2); # The options
+ $incode = 1;
+ print STDERR "\n***Found Deputy code (ex$testnr) at line $lineno, with options=",
+ join(',',@opt), "\n";
+ if(! grep(/norun/, @opt)) {
+ open(TSTSRC, ">$tmpdir/ex$testnr.c")
+ || die "Cannot create source $testnr";
+ if(grep(/local/, @opt)) {
+ print TSTSRC $preambleLocal;
+ } else {
+ print TSTSRC $preambleGlobal;
+ }
+ }
+ print OUT "\\begin{code}\n";
+ next;
+ }
+ if($incode && $_ =~ m|^\\end{deputycode}|) {
+ $incode = 0;
+ print OUT "\n\\end{verbatim}\\end{code}\n";
+ if(! grep(/norun/, @opt)) {
+ if(grep(/local/, @opt)) {
+ print TSTSRC $postambleLocal;
+ } else {
+ print TSTSRC $postambleGlobal;
+ }
+ close(TSTSRC);
+ if($doexamples) {
+ print OUT "The \\ahref{$htmloutdir/ex${testnr}.deputy.txt}{Deputy output} for this code fragment\n";
+
+ # Now run ccured. Pass all the options that start with --
+ my @ccuredOpt = grep(/^--/, @opt);
+ my $fails =
+ 0 !=
+ system(@ccured, @ccuredOpt,
+ '-c', "$tmpdir/ex$testnr.c",
+ '-o', "$tmpdir/ex$testnr.o",
+ "--save-temps=$tmpdir");
+ my $shouldfail = 0 != grep(/fails/, @opt);
+ if($fails != $shouldfail) {
+ die "Error running Deputy for $tmpdir/ex$testnr.c (fails=$fails, shouldfail=$shouldfail)";
+ }
+ # Now copy the CCured file
+ my $cilfile = "$tmpdir/ex$testnr.cil.c";
+ my $exfile = "$outdir/ex$testnr.deputy.txt";
+ if(! File::Copy::copy($cilfile, $exfile)) {
+ die "Cannot copy $cilfile to $exfile";
+ }
+ # And copy the browser directory
+ # system("cp -r $tmpdir/ex$testnr.browser $outdir");
+ }
+ } else {
+ print OUT "(Code generation was turned off for this document)\n";
+ }
+ $testnr ++;
+ next;
+ }
+ if($incode) {
+ print TSTSRC $_;
+ }
+ print OUT $_;
+}
+
+
--- /dev/null
+% This is FULLPAGE.STY by H.Partl, Version 2 as of 15 Dec 1988.
+% Document Style Option to fill the paper just like Plain TeX.
+
+\typeout{Style Option FULLPAGE Version 2 as of 15 Dec 1988}
+
+\topmargin 0pt
+\advance \topmargin by -\headheight
+\advance \topmargin by -\headsep
+
+\textheight 8.9in
+
+\oddsidemargin 0pt
+\evensidemargin \oddsidemargin
+\marginparwidth 0.5in
+
+\textwidth 6.5in
+
+
+% For users of A4 paper: The above values are suited for american 8.5x11in
+% paper. If your output driver performs a conversion for A4 paper, keep
+% those values. If your output driver conforms to the TeX standard (1in/1in),
+% then you should add the following commands to center the text on A4 paper:
+
+% \advance\hoffset by -3mm % A4 is narrower.
+% \advance\voffset by 8mm % A4 is taller.
+
+\endinput
+
+
--- /dev/null
+<html>
+
+<head>
+<meta http-equiv="Content-Language" content="en-us">
+<meta http-equiv="Content-Type" content="text/html; charset=windows-1252">
+<title>Deputy Documentation (v. @DEPUTY_VERSION@)</title>
+<base target="contents">
+</head>
+
+<body>
+
+<h1 align="center">Deputy - Cool Stuff (v. @DEPUTY_VERSION@)</h1>
+
+</body>
+
+</html>
--- /dev/null
+% hevea : hevea.sty
+% This is a very basic style file for latex document to be processed
+% with hevea. It contains definitions of LaTeX environment which are
+% processed in a special way by the translator.
+% Mostly :
+% - latexonly, not processed by hevea, processed by latex.
+% - htmlonly , the reverse.
+% - rawhtml, to include raw HTML in hevea output.
+% - toimage, to send text to the image file.
+% The package also provides hevea logos, html related commands (ahref
+% etc.), void cutting and image commands.
+\NeedsTeXFormat{LaTeX2e}
+\ProvidesPackage{hevea}[2002/01/11]
+\RequirePackage{comment}
+\newif\ifhevea\heveafalse
+\@ifundefined{ifimagen}{\newif\ifimagen\imagenfalse}
+\makeatletter%
+\newcommand{\heveasmup}[2]{%
+\raise #1\hbox{$\m@th$%
+ \csname S@\f@size\endcsname
+ \fontsize\sf@size 0%
+ \math@fontsfalse\selectfont
+#2%
+}}%
+\DeclareRobustCommand{\hevea}{H\kern-.15em\heveasmup{.2ex}{E}\kern-.15emV\kern-.15em\heveasmup{.2ex}{E}\kern-.15emA}%
+\DeclareRobustCommand{\hacha}{H\kern-.15em\heveasmup{.2ex}{A}\kern-.15emC\kern-.1em\heveasmup{.2ex}{H}\kern-.15emA}%
+\DeclareRobustCommand{\html}{\protect\heveasmup{0.ex}{HTML}}
+%%%%%%%%% Hyperlinks hevea style
+\newcommand{\ahref}[2]{{#2}}
+\newcommand{\ahrefloc}[2]{{#2}}
+\newcommand{\aname}[2]{{#2}}
+\newcommand{\ahrefurl}[1]{\texttt{#1}}
+\newcommand{\footahref}[2]{#2\footnote{\texttt{#1}}}
+\newcommand{\mailto}[1]{\texttt{#1}}
+\newcommand{\imgsrc}[2][]{}
+\newcommand{\home}[1]{\protect\raisebox{-.75ex}{\char126}#1}
+\AtBeginDocument
+{\@ifundefined{url}
+{%url package is not loaded
+\let\url\ahref\let\oneurl\ahrefurl\let\footurl\footahref}
+{}}
+%% Void cutting instructions
+\newcounter{cuttingdepth}
+\newcommand{\tocnumber}{}
+\newcommand{\notocnumber}{}
+\newcommand{\cuttingunit}{}
+\newcommand{\cutdef}[2][]{}
+\newcommand{\cuthere}[2]{}
+\newcommand{\cutend}{}
+\newcommand{\htmlhead}[1]{}
+\newcommand{\htmlfoot}[1]{}
+\newcommand{\htmlprefix}[1]{}
+\newenvironment{cutflow}[1]{}{}
+\newcommand{\cutname}[1]{}
+\newcommand{\toplinks}[3]{}
+%%%% Html only
+\excludecomment{rawhtml}
+\newcommand{\rawhtmlinput}[1]{}
+\excludecomment{htmlonly}
+%%%% Latex only
+\newenvironment{latexonly}{}{}
+\newenvironment{verblatex}{}{}
+%%%% Image file stuff
+\def\toimage{\endgroup}
+\def\endtoimage{\begingroup\def\@currenvir{toimage}}
+\def\verbimage{\endgroup}
+\def\endverbimage{\begingroup\def\@currenvir{verbimage}}
+\newcommand{\imageflush}[1][]{}
+%%% Bgcolor definition
+\newsavebox{\@bgcolorbin}
+\newenvironment{bgcolor}[2][]
+ {\newcommand{\@mycolor}{#2}\begin{lrbox}{\@bgcolorbin}\vbox\bgroup}
+ {\egroup\end{lrbox}%
+ \begin{flushleft}%
+ \colorbox{\@mycolor}{\usebox{\@bgcolorbin}}%
+ \end{flushleft}}
+%%% Style sheets macros, defined as no-ops
+\newcommand{\newstyle}[2]{}
+\newcommand{\addstyle}[1]{}
+\newcommand{\setenvclass}[2]{}
+\newcommand{\getenvclass}[1]{}
+\newcommand{\loadcssfile}[1]{}
+\newenvironment{divstyle}[1]{}{}
+\newenvironment{cellstyle}[2]{}{}
+%%% Postlude
+\makeatother
--- /dev/null
+<html>
+
+<head>
+<base target="main">
+<title>Deputy Documentation (v. @DEPUTY_VERSION@)</title>
+</head>
+
+<frameset rows="64,*">
+ <frame name="banner" scrolling="auto" noresize target="contents"
+ src="header.html">
+ <frameset cols="267,*">
+ <frame name="contents" target="main" src="deputytoc.html" scrolling="auto">
+ <frame name="main" src="deputy001.html" scrolling="auto">
+ </frameset>
+ <noframes>
+ <body>
+
+ <p>This page uses frames, but your browser doesn't support them.</p>
+
+ </body>
+ </noframes>
+</frameset>
+
+</html>
\ No newline at end of file
--- /dev/null
+body {
+ background: #c9cc8e;
+ font-family: 'Palatino-Roman', 'Palatino', 'serif';
+ margin: 30px;
+}
+
+#frame {
+ background: #e9ead5;
+ margin: 0px;
+ padding: 20px;
+ border: 1px;
+ border-style: solid;
+ border-color: black;
+}
+
+h1 {
+ margin-top: 0px;
+}
+
+h2 {
+ margin-top: 0px;
+}
+
+.code {
+ background: #f7f9ed;
+ font-family: 'Courier New', 'Courier', 'monospace';
+ font-size: 9pt;
+ padding: 2px;
+ border: 1px gray solid;
+ white-space: pre;
+}
+
+tt {
+ font-family: 'Courier New', 'Courier', 'monospace';
+}
+
+.nobullet {
+ list-style-type: none;
+}
+
+.annot {
+ color: #0b31ac;
+}
+
+.op {
+ color: #0b31ac;
+}
+
+a:link {
+ color: #2567a4;
+}
+
+a:visited {
+ color: #22099d;
+}
--- /dev/null
+<html>
+
+<head>
+<title>Deputy</title>
+<link rel="stylesheet" type="text/css" href="deputy.css"/>
+</head>
+
+<body>
+<div id="frame">
+
+<h1 align="center">Deputy</h1>
+
+<hr/>
+
+<h3>What is Deputy?</h3>
+
+<p>Deputy is a C compiler that is capable of preventing common C
+programming errors, including out-of-bounds memory accesses as well as
+many other common type-safety errors. It is designed to work on
+real-world code, up to and including the Linux kernel itself.</p>
+
+<p>Deputy allows C programmers to provide simple type annotations that
+describe pointer bounds and other important program invariants. Deputy
+verifies that your program adheres to these invariants through a
+combination of compile-time and run-time checking.</p>
+
+<p>Unlike other tools for checking C code, Deputy provides a flexible
+annotation language that allows you to describe many common programming
+idioms without changing your data structures. As a result, using Deputy
+requires less programmer effort than other tools. In fact, code compiled
+with Deputy can be linked directly with code compiled by other C
+compilers, so you can choose exactly when and where to use Deputy within
+your C project.</p>
+
+<p>Deputy is implemented using the <a
+href="http://hal.cs.berkeley.edu/cil/">CIL</a> infrastructure for C
+program analysis and transformation.</p>
+
+<hr/>
+
+<h3>Download</h3>
+
+<p>Deputy is currently available as a Debian package, an RPM, or a source
+distribution:</p>
+
+<ul>
+<li>Debian: <a href="deputy_1.1-1_i386.deb">deputy_1.1-1_i386.deb</a></li>
+<li>RPM: <a href="deputy-1.1-1.i386.rpm">deputy-1.1-1.i386.rpm</a></li>
+<li>Source: <a href="deputy-1.1.tar.gz">deputy-1.1.tar.gz</a></li>
+</ul>
+
+<p>If you choose to download the source distribution, you will need the <a
+href="http://caml.inria.fr/">OCaml compiler</a> to build Deputy.</p>
+
+<p>Deputy is currently being developed for Linux and Cygwin on x86
+processors. Other platforms and processors should work as well but may
+require additional effort to build. (Please feel free to <a
+href="mailto:deputy@deputy.cs.berkeley.edu">submit</a> comments and/or
+patches for other platforms!)</p>
+
+<hr/>
+
+<h3>Documentation</h3>
+
+<ul>
+<li><a href="quickref.html">Quick Reference</a></li>
+<li><a href="manual.html">Manual</a></li>
+</ul>
+
+<hr/>
+
+<h3>Papers</h3>
+
+<p>Further information about Deputy and its uses can be found in the
+following papers:</p>
+
+<ul>
+
+<li>Feng Zhou, Jeremy Condit, Zachary Anderson, Ilya Bagrak, Rob Ennals,
+Matthew Harren, George Necula, and Eric Brewer. <i>SafeDrive: Safe and
+Recoverable Extensions Using Language-Based Techniques.</i> OSDI 2006.
+[<a href="safedrive-osdi-2006.pdf">pdf</a>]</li>
+
+<li>Jeremy Condit, Matthew Harren, Zachary Anderson, David Gay, and George
+Necula. <i>Dependent Types for Low-Level Programming.</i> ESOP 2007.
+[<a href="deputy-esop-2007.pdf">pdf</a>]</li>
+
+<li>Jeremy Condit, Matthew Harren, Zachary Anderson, David Gay, and George
+Necula. <i>Dependent Types for Low-Level Programming.</i> UC Berkeley
+Technical Report EECS-2006-129. [<a
+href="deputy-tr-2006.pdf">pdf</a>]</li>
+
+</ul>
+
+<hr/>
+
+<h3>Contact</h3>
+
+<p>Please send questions and feedback to the Deputy team at <a
+href="mailto:deputy@deputy.cs.berkeley.edu">deputy@deputy.cs.berkeley.edu</a>.
+We welcome any comments you have about your experience using Deputy and
+your suggestions for improving it!</p>
+
+<p>Deputy was written by Jeremy Condit, Matt Harren, Zach Anderson, and
+George Necula. Many thanks to Feng Zhou, Rob Ennals, David Gay, Ilya
+Bagrak, Bill McCloskey, and Eric Brewer for valuable discussions and
+feedback.</p>
+
+</div>
+
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3.org/TR/html4/strict.dtd">
+<html>
+
+<head>
+<title>Deputy Manual</title>
+<link rel="stylesheet" type="text/css" href="deputy.css"/>
+</head>
+
+<body>
+<div id="frame">
+
+<h2>Deputy Manual</h2>
+
+<hr/>
+
+<h3>Contents</h3>
+
+<ul class="nobullet">
+<li>1. <a href="#what-is-deputy">What is Deputy?</a></li>
+<li>2. <a href="#getting-deputy">Getting Deputy</a></li>
+<li>3. <a href="#basic-usage">Basic Usage</a></li>
+<ul class="nobullet">
+<li>3.1. <a href="#invoking-deputy">Invoking Deputy</a></li>
+<li>3.2. <a href="#edit-compile-debug">Edit, Compile, Debug</a></li>
+</ul>
+<li>4. <a href="#pointer-bounds-annotations">Pointer Bounds Annotations</a></li>
+<ul class="nobullet">
+<li>4.1. <a href="#syntax">Syntax</a></li>
+<li>4.2. <a href="#safe-pointers">Safe Pointers</a></li>
+<li>4.3. <a href="#count-pointers">Count Pointers</a></li>
+<li>4.4. <a href="#general-bounded-pointers">General Bounded Pointers</a></li>
+<li>4.5. <a href="#sentinel-pointers">Sentinel Pointers</a></li>
+<li>4.6. <a href="#null-terminated-pointers">Null-Terminated Pointers</a></li>
+<li>4.7. <a href="#casts">Casts</a></li>
+<li>4.8. <a href="#trusted-code">Trusted Code</a></li>
+</ul>
+<li>5. <a href="#inference">Inference</a></li>
+<ul class="nobullet">
+<li>5.1. <a href="#default-annotations">Default Annotations</a></li>
+<li>5.2. <a href="#automatic-bounds">Automatic Bounds</a></li>
+<li>5.3. <a href="#nt-inference">NT Inference</a></li>
+</ul>
+<li>6. <a href="#union-annotations">Union Annotations</a></li>
+<ul class="nobullet">
+<li>6.1. <a href="#tagged-unions">Tagged Unions</a></li>
+<li>6.2. <a href="#trusted-unions">Trusted Unions</a></li>
+</ul>
+<li>7. <a href="#polymorphism">Polymorphism</a></li>
+<ul class="nobullet">
+<li>7.1. <a href="#polymorphism-in-functions">Polymorphism in Functions</a></li>
+<li>7.2. <a href="#polymorphic-structures">Polymorphic Structures</a></li>
+</ul>
+<li>8. <a href="#special-functions">Special Functions</a></li>
+<ul class="nobullet">
+<li>8.1. <a href="#allocators">Allocators</a></li>
+<li>8.2. <a href="#memset-and-friends">Memset and Friends</a></li>
+</ul>
+<li>9. <a href="#contact-information">Contact Information</a></li>
+</ul>
+
+<hr/>
+
+<a name="what-is-deputy"/>
+<h3>1. What is Deputy?</h3>
+
+<p>Deputy is a C compiler that enforces a stricter typing discipline on
+your C programs. Among other things, it verifies that pointers stay
+within their designated bounds, and it ensures that union fields are used
+safely.</p>
+
+<p>In order to compile your C program with Deputy, you must first supply
+some lightweight type annotations. For the most part, these annotations
+are required on function arguments and return values, structure fields,
+and global variables--that is, the interfaces to each source file.
+Deputy's annotations are designed to reflect common programming idioms;
+for example, you can easily say that a pointer <tt>p</tt> points to an
+array of length <tt>n</tt>, where <tt>n</tt> is another variable in the
+program. Deputy then verifies your program through a combination of
+compile-time and run-time checking. This approach allows us to verify a
+wide range of real-world programs (even Linux device drivers!) in return
+for a slight performance penalty.</p>
+
+<p>Deputy differs from previous tools for safe C compilation in that it
+allows the programmer to specify pointer bounds and union tags using
+<i>dependent types</i>--that is, using annotations that depend on other
+variables or fields in your program. As a result, Deputy requires fewer
+modifications to the original program and makes less invasive changes to
+the program during compilation. Deputy produces object files that can be
+linked directly to object files produced by other compilers; thus, the
+programmer can choose to enable Deputy on a file-by-file basis, and
+programs compiled with Deputy can be linked directly with existing C
+libraries.</p>
+
+<p>Deputy is implemented as a drop-in replacement for existing compilers
+such as <tt>gcc</tt>, and it is therefore easy to integrate Deputy into
+your existing build process. In addition, Deputy uses <tt>gcc</tt> as a
+back-end, which means that all of the optimizations provided by
+<tt>gcc</tt> are still available to your code. Read on to learn how to
+get started!</p>
+
+<hr/>
+
+<a name="getting-deputy"/>
+<h3>2. Getting Deputy</h3>
+
+<p>Deputy can be obtained via the download links at the <a
+href="http://deputy.cs.berkeley.edu/">main page</a>, as a Debian package,
+an RPM, or a source tarball. For access to the Subversion repository,
+send email to <a href="mailto:jcondit@cs.berkeley.edu">Jeremy
+Condit</a>.</p>
+
+<ul>
+
+<li><p>Debian:</p>
+<div class="code">% dpkg -i deputy_1.1-1_i386.deb</div></li>
+
+<li><p>Red Hat / Fedora:</p>
+<div class="code">% rpm -i deputy-1.1-1.i386.rpm</div></li>
+
+<li><p>Source tarball:</p>
+<div class="code">% tar zxvf deputy-1.1.tar.gz
+% cd deputy-1.1
+% ./configure
+% make
+% make quicktest
+% make install
+</div>
+</li>
+
+</ul>
+
+<p>You're all set!</p>
+
+<hr/>
+
+<a name="basic-usage"/>
+<h3>3. Basic Usage</h3>
+
+<a name="invoking-deputy"/>
+<h4>3.1. Invoking Deputy</h4>
+
+<p>Deputy is implemented as a drop-in replacement for <tt>gcc</tt>, so you
+can invoke it in exactly the same way you would invoke <tt>gcc</tt>. For
+example, if you want to compile the C source file <tt>foo.c</tt> to the
+object file <tt>foo.o</tt>, you can use the following command:</p>
+
+<div class="code">% deputy -c -o foo.o foo.c
+</div>
+
+<p>If you're using Deputy on an existing C project, all you need to do is
+to set the <tt>CC</tt> variable in your <tt>Makefile</tt> to the
+<tt>deputy</tt> executable.</p>
+
+<p>The object files produced by Deputy are compatible with object files
+produced by <tt>gcc</tt>, so you can link them with the standard linker.
+However, Deputy-generated object files need to eventually be linked with
+Deputy's runtime library, which has code to handle run-time failures. If
+you use <tt>deputy</tt> as your linker (much as <tt>gcc</tt> is often used
+as the linker), the runtime library will automatically be linked when an
+executable is created. For example, to link <tt>foo.o</tt> and
+<tt>bar.o</tt> to create an executable <tt>foobar</tt>, you can use the
+following command:</p>
+
+<div class="code">% deputy -o foobar foo.o bar.o
+</div>
+
+<a name="edit-compile-debug"/>
+<h4>3.2. Edit, Compile, Debug</h4>
+
+<p>Using Deputy is much like the familiar edit-compile-debug cycle for any
+other compiler. When you run Deputy on a C file, it will emit a number of
+warnings and errors that either suggest annotations or indicate errors.
+Your job as the programmer is to address these warnings and errors by
+adding annotations or changing code.</p>
+
+<p>For example, consider the following code:</p>
+
+<div class="code">int sum(int *data, int length) {
+ int i, sum = 0;
+ for (i = 0; i <= length; i++) {
+ sum += data[i];
+ }
+ return sum;
+}
+</div>
+
+<p>Assuming this code is in a file called <tt>sum.c</tt>, we could compile
+it as follows:</p>
+
+<div class="code">% deputy -c -o sum.o sum.c
+sum.c:1: Warning: Type "int *" in formal "data" of sum needs a bound annotation.
+</div>
+
+<p>We got a warning, but it compiled. Now let's build a program that
+calls the <tt>sum()</tt> function with an array of length 5.</p>
+
+<div class="code">% gcc -c -o test-sum.o test-sum.c
+% deputy -o test-sum test-sum.o sum.o
+</div>
+
+<p>Note that we compiled the test code with <tt>gcc</tt>, since the
+resulting object files can be linked directly with the ones produced by
+<tt>deputy</tt>. Note also that we linked with <tt>deputy</tt> so that we
+get Deputy's runtime library.</p>
+
+<p>Now let's run this program:</p>
+
+<div class="code">% ./test-sum
+sum.c:4: sum: Assertion failed in upper bound check:
+ data + i + 1 <= data + 1 (with no overflow)
+Execution aborted.
+</div>
+
+<p>The reason for this assertion is that Deputy assumed that the
+<tt>data</tt> argument to <tt>sum()</tt> pointed to a single integer, not
+an array of integers. When the <tt>sum()</tt> function attempted to
+access integers beyond the first element of this array, a Deputy run-time
+error was triggered. Note that the warning provided by Deputy at compile
+time indicated that something about this code was fishy.</p>
+
+<p>We can fix this error by adding an annotation to the <tt>int*</tt>
+type, as follows:</p>
+
+<div class="code">int sum(int * <span class="annot">COUNT(length)</span> data, int length) {
+ int i, sum = 0;
+ for (i = 0; i <= length; i++) {
+ sum += data[i];
+ }
+ return sum;
+}
+</div>
+
+<p>This annotation tells Deputy that <tt>length</tt> stores the length of
+<tt>data</tt>. Now if we compile and run the above program, we will see
+no warnings or errors:</p>
+
+<div class="code">% deputy -c -o sum.o sum.c
+% gcc -c -o test-sum.o test-sum.c
+% deputy -o test-sum test-sum.o sum.o
+% ./test-sum
+</div>
+
+<p>Deputy provides many such annotations to describe common programming
+idioms. In the following sections, we will discuss Deputy's pointer
+annotations in detail.</p>
+
+<hr/>
+
+<a name="pointer-bounds-annotations"/>
+<h3>4. Pointer Bounds Annotations</h3>
+
+<a name="syntax"/>
+<h4>4.1. Syntax</h4>
+
+<p>Most Deputy annotations are written as type annotations that are
+written immediately after the type to which they are attached. For
+example:</p>
+
+<div class="code">int * <span class="annot">SAFE</span> p;</div>
+
+<p>This code declares a variable <tt>p</tt> of type <tt>int * SAFE</tt>.
+In this example, <tt>SAFE</tt> is a Deputy annotation attached to the
+pointer type <tt>int *</tt>. In general, any annotations appearing after
+a <tt>*</tt> apply to that pointer type.</p>
+
+<p>Here is another example:</p>
+
+<div class="code">int main(int argc, char * <span class="annot">NTS</span> * <span class="annot">NT COUNT(argc)</span> argv);</div>
+
+<p>This example shows the Deputy annotations for <tt>main</tt>. The
+<tt>NTS</tt> annotation applies to the first pointer (the inner <tt>char
+*</tt>), and the <tt>NT</tt> and <tt>COUNT(argc)</tt> annotations apply to
+the second pointer (the outer <tt>char **</tt>). Overall, this annotation
+says that <tt>argv</tt> is a null-terminated sequence with a minimum
+length of <tt>argc</tt>. Each element of this sequence is a
+null-terminated string. (These annotations will be discussed in detail
+below!)</p>
+
+<a name="safe-pointers"/>
+<h4>4.2. Safe Pointers</h4>
+
+<p>The first Deputy annotation that we will introduce is the "safe"
+pointer. Safe pointers are possibly-null pointers to a single object of
+their base type. For example:</p>
+
+<div class="code">struct foo * <span class="annot">SAFE</span> p;</div>
+
+<p>This code declares a pointer <tt>p</tt> that is either null or points
+to a single object of type <tt>struct foo</tt>.</p>
+
+<p>Safe pointers are typically used much like Java references: they can be
+passed around and dereferenced, but they are not used in pointer
+arithmetic. Such pointers are by far the most common kind of pointers in
+C programs.</p>
+
+<p>When you dereference a safe pointer, Deputy will insert a null check
+(or its equivalent). However, if your code has already checked this
+pointer to ensure that it is non-null, Deputy's optimizer will most likely
+remove the Deputy-inserted null check. Deputy's will also issue
+compile-time errors for obviously-incorrect code such as <tt>p[1]</tt>.</p>
+
+<p>If you are sure that the pointer is never null, you can add the
+<tt>NONNULL</tt> annotation. For example:</p>
+
+<div class="code">struct foo * <span class="annot">SAFE NONNULL</span> p;</div>
+
+<p>Since this pointer is annotated as both <tt>SAFE</tt> and
+<tt>NONNULL</tt>, it can typically be dereferenced at zero run-time
+cost.</p>
+
+<a name="count-pointers"/>
+<h4>4.3. Count Pointers</h4>
+
+<p>Of course, many C programs use pointers to point to <em>arrays</em> of
+objects. Such pointers can be annotated as "count" pointers:</p>
+
+<div class="code">struct foo * <span class="annot">COUNT(5)</span> p;</div>
+
+<p>This annotation says that <tt>p</tt> is either null or it points to an
+array of five valid objects of type <tt>struct foo</tt>. For the visually
+inclined, the memory layout is as follows, where each blue box represents
+an object of type <tt>struct foo</tt>:</p>
+
+<div align="center">
+<img src="count-5.png"/>
+</div>
+
+<p>Note that the <tt>SAFE</tt> annotation introduced earlier is actually
+equivalent to <tt>COUNT(1)</tt>. Also note that this annotation can be
+written as <tt>CT</tt> instead of <tt>COUNT</tt> if you prefer terse
+annotations.</p>
+
+<p>In addition to using the count annotation with constants, the count
+annotation can also refer to other variables in the same
+scope or to more complex expressions. For example:</p>
+
+<div class="code">int n, m;
+struct foo * <span class="annot">COUNT(n * m)</span> p;
+</div>
+
+<p>Here, we've declared that <tt>p</tt> is a pointer to an array of <tt>n
+* m</tt> objects of type <tt>struct foo</tt> (a two-dimensional array,
+perhaps). Visually, we have the following memory layout:</p>
+
+<div align="center">
+<img src="count-nm.png"/>
+</div>
+
+<p>If we refer to an element <tt>p[i]</tt> of this array, Deputy
+will verify that <tt>p</tt> is non-null and that <tt>0 <= i < n *
+m</tt>.
+
+<p>When count annotations refer to variables, they may refer only to
+variables in the immediately enclosing scope. For example, annotations on
+local variables may only refer to other local variables, and annotations
+on structure fields may only refer to other structure fields.
+Furthermore, these annotations may not include memory dereferences or
+function calls. These restrictions allow Deputy to efficiently verify
+that a variable's type annotation is valid for the duration of that
+variable's lifetime.</p>
+
+<p>Finally, note that count annotations (and indeed, all Deputy
+annotations) must be valid throughout the variable's lifetime. Thus, in
+the previous example, Deputy will prevent you from incrementing <tt>n</tt>
+or <tt>m</tt>, since this change might invalidate the annotation on
+<tt>p</tt>. Furthermore, <tt>p</tt> cannot be incremented, because then
+<tt>p</tt> would no longer point to an array of <tt>n * m</tt> elements.
+(If you're worried that this sounds too restrictive, bear with me until
+the section on automatic bounds!)</p>
+
+<a name="general-bounded-pointers"/>
+<h4>4.4. General Bounded Pointers</h4>
+
+<p>The most general annotation provided by Deputy is the "bound"
+annotation, which is written as follows:</p>
+
+<div class="code">struct foo * <span class="annot">BOUND(b, e)</span> p;</div>
+
+<p>This annotation says that <tt>p</tt> is either null or points into
+an array of objects of type <tt>struct foo</tt> with bounds <tt>b</tt> and
+<tt>e</tt>. All of these pointers (<tt>p</tt>, <tt>b</tt>, and
+<tt>e</tt>) must be aligned with respect to the size of <tt>struct
+foo</tt>. Visually, the memory layout is:</p>
+
+<div align="center">
+<img src="bnd-be.png"/>
+</div>
+
+<p>As with the count annotation, the arguments <tt>b</tt> and <tt>e</tt>
+can actually be expressions that refer to other variables or fields in the
+same scope. The same restrictions that apply to count pointers apply here
+as well. As with the count annotation, you can write <tt>BND</tt> as the
+terse form of <tt>BOUND</tt>.</p>
+
+<p>In this annotation, the expressions <tt>b</tt> and <tt>e</tt> can make use of
+the special variable <tt>__this</tt>, which refers to the variable, field,
+or expression to which this type is attached. So, for example, the
+annotation <tt>BOUND(__this, __this + n)</tt> says that the bounds of the
+associated pointer are the pointer itself and the pointer plus <tt>n</tt>
+elements. In fact, this is precisely how <tt>COUNT(n)</tt> is
+defined!</p>
+
+<a name="sentinel-pointers"/>
+<h4>4.5. Sentinel Pointers</h4>
+
+<p>One final pointer annotation to be discussed is the sentinel pointer.
+In Deputy, the sentinel annotation, written <tt>SNT</tt>, indicates that a
+pointer is used only for comparisons and not for dereference. Such
+pointers are useful mainly for indicating the bounds of other pointers.
+They are also useful for C idioms where the program computes the address
+of the end of an array.</p>
+
+<p>In terms of the general bounded pointer, a sentinel pointer is
+equivalent to <tt>BOUND(__this, __this)</tt>--that is, the pointer is both
+its upper and lower bound.</p>
+
+<a name="null-terminated-pointers"/>
+<h4>4.6. Null-Terminated Pointers</h4>
+
+<p>The annotations introduced thus far allow you to specify pointer bounds
+by referring to other nearby variables. However, bounds for arrays are
+sometimes indicated using null termination instead.</p>
+
+<p>Deputy handles null-termination with an additional annotation,
+<tt>NT</tt>, that can be used <em>in addition to</em> the
+previously-discussed bounds annotations. In other words, you have the
+option of specifying <tt>NT</tt> in addition to <tt>BOUND</tt> or one of its
+shorthands (<tt>SAFE</tt>, <tt>COUNT</tt>, and <tt>SNT</tt>).</p>
+
+<p>The meaning of this annotation is that the <em>upper</em> bound given
+by the <tt>BOUND</tt> annotation is the beginning of a null-terminated
+sequence. So, the annotation <tt>NT COUNT(5)</tt> describes an array of
+five elements followed by a null-terminated sequence (or, in other words,
+a null-terminated sequence of at least five elements). This annotation
+allows the null element to be read but not overwritten with a non-zero
+value. A sequence with no known bounds (e.g., a standard C string) is
+written as <tt>NT COUNT(0)</tt>, which can be abbreviated as
+<tt>NTS</tt>.</p>
+
+<p>In its most general form, the annotation <tt>NT BOUND(b, e)</tt>
+corresponds to the following memory layout:</p>
+
+<div align="center">
+<img src="bnd-be-nt.png"/>
+</div>
+
+<p>Note that the initial portion of the array is laid out in the same way
+as <tt>BOUND(b, e)</tt>; the only difference is that we have a
+null-terminated sequence (shown as the pink boxes) at the end.</p>
+
+<p>This hybrid design is important in ensuring that bounded sequences and
+null-terminated sequences interact cleanly. For example, C programs often
+have stack-allocated arrays that have a known size and are
+null-terminated. If we did not mark it as null-terminated, we would not
+be able to call <tt>strlen()</tt> and its like on this buffer. If we
+marked it as null-terminated only, then we would not be able to insert
+null elements in this buffer without cutting off access to the remainder
+of the buffer.</p>
+
+<p>Note that it is always legal to cast away the <tt>NT</tt> flag; for
+example, a <tt>NT COUNT(5)</tt> sequence can safely be considered to be a
+<tt>COUNT(5)</tt> sequence, although you lose access to the
+null-terminated portion of the array. This operation can be performed
+with the <tt>NTDROP(e)</tt> function.</p>
+
+<p>One complication with <tt>NTDROP</tt> is that you lose a lot of bounds
+information. For example, strings are typically annotated <tt>char *
+NTS</tt>, and calling <tt>NTDROP</tt> on such a value results in a value
+of type <tt>char * COUNT(0)</tt>, which is not very useful. Thus, we also
+provide <tt>NTEXPAND(e)</tt>, which expands the bounds of the expression
+<tt>e</tt> dynamically. So, <tt>NTDROP(NTEXPAND(e))</tt> yields a
+non-null-terminated type with the largest legal bounds.</p>
+
+<a name="casts"/>
+<h4>4.7. Casts</h4>
+
+<p>Deputy has stricter checking of type casts than C itself. First,
+Deputy checks to make sure that the bounds of the type being cast are
+correct. For example, a <tt>COUNT(5)</tt> pointer could be cast to a
+<tt>COUNT(4)</tt> pointer, but not the other way around. When necessary,
+Deputy will insert run-time checks to verify that such casts are safe.
+Since all the bounds annotations are special cases of <tt>BOUND</tt>, they
+can all be cast freely from one to the other.</p>
+
+<p>Deputy also ensures that the <tt>NT</tt> flag is either present or
+absent on both sides of the cast. (In fact, Deputy infers the <tt>NT</tt>
+flag in these situations, as we will discuss in the next section.) The
+only way to drop the <tt>NT</tt> flag is to use the <tt>NTDROP</tt>
+function discussed above. The <tt>NT</tt> flag can never be added by a
+cast; it must be present from the point of allocation forward.</p>
+
+<p>Finally, Deputy checks the base types of pointers involved in a cast.
+For example, you are not allowed to blindly cast an <tt>int **</tt> to an
+<tt>int *</tt>, since otherwise you could overwrite a pointer with an
+integer. Similarly, you are not allowed to cast a non-pointer type to a
+pointer. However, when casting between pointers to non-pointer data
+(e.g., <tt>int *</tt> to <tt>char *</tt>), Deputy will allow the cast.</p>
+
+<a name="trusted-code"/>
+<h4>4.8. Trusted Code</h4>
+
+<p>If you must use a cast that Deputy doesn't like, you can use the
+<tt>TC(e)</tt> function to perform a trusted cast from an expression
+<tt>e</tt> to some new type. For example, the following cast will be
+accepted by Deputy:</p>
+
+<div class="code">int * <span class="annot">SAFE</span> * <span class="annot">SAFE</span> pp = ...;
+int * <span class="annot">SAFE</span> p = (int * <span class="annot">SAFE</span>) <span class="op">TC</span>(pp);
+</div>
+
+<p>Alternatively, any pointer can be labelled as trusted by using the
+<tt>TRUSTED</tt> annotations. Trusted pointers can be cast to any other
+pointer without compile-time or run-time checks. Similarly, these
+pointers can be incremented or decremented without restriction. (In fact,
+the <tt>TC</tt> operation is implemented as a cast to a <tt>TRUSTED</tt>
+pointer of the same type.)</p>
+
+<hr/>
+
+<a name="inference"/>
+<h3>5. Inference</h3>
+
+<p>Deputy has several inference features that reduce the number of
+annotations required for type checking. Most of these features operate
+behind the scenes, but it is important for the programmer to be aware of
+what they do.</p>
+
+<a name="default-annotations"/>
+<h4>5.1. Default Annotations</h4>
+
+<p>Any types that may be visible by code outside the current compilation
+unit are given the default annotation of <tt>SAFE</tt>. These types
+include the types of global variables, function arguments, function return
+values, structure fields, and the base types of other pointers. This
+annotation is correct in the vast majority of cases, so it is quite useful
+for the programmer to be able to omit it.</p>
+
+<p>However, it is important to note that this assumption is <em>not</em>
+safe and is provided only for convenience. For example, imagine that your
+code calls a function <tt>foo(char *p)</tt> in another module. If this
+function expects a null-terminated string and we assume a <tt>SAFE</tt>
+annotation, then Deputy would allow you to pass a pointer to a single
+character when a string was expected. Fortunately, such errors will be
+detected when running Deputy on the code for <tt>foo()</tt> itself;
+furthermore, header files for standard libraries should soon be fully
+annotated. In the near future, we will include an option to warn the
+programmer about such assumptions.</p>
+
+<a name="automatic-bounds"/>
+<h4>5.2. Automatic Bounds</h4>
+
+<p>For the types of local variables and types appearing in casts, Deputy
+can do a bit more to help the programmer. In these situations, Deputy
+assumes that unannotated types have the annotation <tt>BOUND(__auto,
+__auto)</tt>. In this context, <tt>__auto</tt> is a special keyword that
+instructs Deputy to generate a new variable to hold and track the
+appropriate bound. For example, say we have the following
+declaration:</p>
+
+<div class="code">int a[10];
+int * <span class="annot">BOUND(__auto, __auto)</span> p;
+p = a;
+</div>
+
+<p>After preprocessing, this code becomes:</p>
+
+<div class="code">int a[10];
+int * <span class="annot">SNT</span> pb;
+int * <span class="annot">SNT</span> pe;
+int * <span class="annot">BOUND(pb, pe)</span> p;
+pb = a;
+pe = a + 10;
+p = a;
+</div>
+
+<p>Note that we have introduced two new bounds variables to track the
+bounds of <tt>p</tt>, and we updated these bounds variables when
+<tt>p</tt> was updated.</p>
+
+<p>These automatic bounds variables are very useful beyond their ability
+to reduce the annotation burden. In many cases, programmers wish to
+explicitly introduce new bounds variables when existing code is not
+amenable to annotation. As mentioned earlier, <tt>COUNT</tt> pointers
+cannot be incremented; however, if you copy a <tt>COUNT</tt> pointer into
+an unannotated pointer, then this unannotated pointer can be incremented,
+since its bounds are stored in two fresh variables.</p>
+
+<a name="nt-inference"/>
+<h4>5.3. NT Inference</h4>
+
+<p>In addition to the above inference, Deputy also infers <tt>NT</tt>
+annotations using somewhat more traditional means. Essentially, any
+pointer that is casted to/from or assigned to/from an <tt>NT</tt> pointer
+becomes <tt>NT</tt> itself. Of course, this inference algorithm
+understands the <tt>NTDROP</tt> function and does not propagate
+<tt>NT</tt> across this operation.</p>
+
+<p>This feature reduces the burden of <tt>NT</tt> annotation dramatically,
+but it can also infer unintended <tt>NT</tt> annotations. In most cases,
+this problem results from a common function like <tt>memset()</tt>. If an
+<tt>NT</tt> pointer is inadvertendly passed to <tt>memset()</tt> without
+using <tt>NTDROP</tt>, the <tt>NT</tt> flag will be propagated to
+<tt>memset()</tt>'s argument and from there to all other pointers passed
+to <tt>memset()</tt>, most of which are not <tt>NT</tt>. To solve this
+problem, search for common functions like <tt>memset()</tt> and make sure
+to use <tt>NTDROP</tt> when appropriate.</p>
+
+<hr/>
+
+<a name="union-annotations"/>
+<h3>6. Union Annotations</h3>
+
+<a name="tagged-unions"/>
+<h4>6.1. Tagged Unions</h4>
+
+<p>In addition to pointer bounds errors, unions provide another source of
+unsafety in C programs. As with pointer bounds, Deputy provides a way to
+annotate common idioms used to ensure the safety of unions.</p>
+
+<p>In Deputy, each union field must be annotated with a predicate
+indicating the condition that must hold when that field of the union is
+currently active. For example, consider the following annotated C
+code:</p>
+
+<div class="code">struct foo {
+ int tag;
+ union {
+ int n <span class="annot">WHEN(tag == 1)</span>;
+ int *p <span class="annot">WHEN(tag == 2)</span>;
+ } u;
+}
+</div>
+
+<p>Without any checking, this union is potentially unsafe, because a
+program could write an aribtary integer to the field <tt>u.n</tt> and then
+read it out as a pointer by reading <tt>u.p</tt>. The <tt>WHEN</tt>
+annotations indicate that the <tt>n</tt> field can only be accessed when
+<tt>tag</tt> is 1, and the <tt>p</tt> field can only be accessed when
+<tt>tag</tt> is 2. When changing the tag, the contents of the union must
+be zero, which is assumed to be a valid value for all data types.</p>
+
+<p>There are a few differences between the usage of this annotation and
+the usage of the pointer bounds annotations. First, if the <tt>WHEN</tt>
+fields refer to variables, they must be variables in the same scope as the
+union, not fields of the union itself. (In the above example, we refer to
+<tt>tag</tt> as opposed to <tt>n</tt> and <tt>p</tt>.) Second, these
+annotations are placed on the union fields themselves, not on their
+types--that is, they appear <em>after</em> the field name. The reason for
+these differences is that the <tt>WHEN</tt> fields are conceptually
+annotations on the union type, not on the fields of the union.</p>
+
+<a name="trusted-unions"/>
+<h4>6.2. Trusted Unions</h4>
+
+<p>As with bounded pointers, unions can be trusted when the tag
+annotations are insufficient. To do so, simply place the <tt>TRUSTED</tt>
+annotation on the union itself. For example:</p>
+
+<div class="code">union {
+ int n;
+ int *p;
+} <span class="annot">TRUSTED</span> u;
+</div>
+
+<hr/>
+
+<a name="polymorphism"/>
+<h3>7. Polymorphism</h3>
+
+<p>C programmers typically use <tt>void *</tt> in cases where a number of
+different types may be used. However, casts to and from this <tt>void
+*</tt> are not checked for safety. Deputy provides parametric
+polymorphism to handle some of these cases.</p>
+
+<a name="polymorphism-in-functions"/>
+<h4>7.1. Polymorphism in Functions</h4>
+
+<p>Function arguments can be treated as polymorphic. Instead of writing
+<tt>void *</tt>, use the type <tt>TV(t)</tt>, which stands for "type
+variable named <tt>t</tt>". Any occurrences of this type that have the
+same name <tt>t</tt> must be the same type for any particular call to this
+function. For example:</p>
+
+<div class="code">void apply(void (*fn)(<span class="annot">TV(t)</span> data), <span class="annot">TV(t)</span> data);
+void callback_int(int data);
+void callback_ptr(int *data);
+
+int i;
+apply(callback_int, i); // TV(t) == int
+apply(callback_ptr, &i); // TV(t) == int *
+</div>
+
+<p>In Deputy, the above code is well-typed. Note that apply can safely be
+instantiated on two different types, but those types must be used
+consistently for any particular call to <tt>apply</tt>. Note also that
+you can use several distinct type variables if you give them different
+names (i.e., change <tt>t</tt> to something else).</p>
+
+<p>For practical reasons, Deputy requires that <tt>TV(t)</tt> is only
+instantiated to types that can fit in a machine word, like an integer or
+pointer--basically, anything that you were previously casting to/from a
+<tt>void *</tt>.</p>
+
+<p>Within a polymorphic function, you may not make any assumptions about
+data whose type is a type variable. All you can do is copy this data to
+other variables with the same type variable type. The body of
+<tt>apply</tt> would look like this:</p>
+
+<div class="code">void apply(void (*fn)(<span class="annot">TV(t)</span> data), <span class="annot">TV(t)</span> data) {
+ fn(data);
+}
+</div>
+
+<p>This call to <tt>fn</tt> is only legal because <tt>data</tt> and the
+first argument to <tt>fn</tt> both have type <tt>TV(t)</tt>.</p>
+
+<a name="polymorphic-structures"/>
+<h4>7.2. Polymorphic Structures</h4>
+
+<p>You can also use polymorphism within a structure. In our current
+implementation, structures may only have one type variable, which must be
+named <tt>t</tt>. (These restrictions will be lifted in a future
+version.) When using such a structure, you must use the annotation
+<tt>TP</tt> to specify the type on which it is instantiated. For
+example:</p>
+
+<div class="code">struct list {
+ <span class="annot">TV(t)</span> data;
+ struct list <span class="annot">TP(TV(t))</span> *next;
+};
+
+struct list <span class="annot">TP(int)</span> *int_list;
+struct list <span class="annot">TP(int *)</span> *ptr_list;
+
+int i;
+int_list->next->data = i; // data has type int
+ptr_list->next->data = &i; // data has type int *
+</div>
+
+<p>Here we declare two lists, one a list of <tt>int</tt> and one a list
+of <tt>int *</tt>, as specified by <tt>TP</tt>. Within the declaration of
+<tt>struct list</tt>, we say that this type is the type of the
+<tt>data</tt> element, and that the <tt>next</tt> pointer points to
+another list cell that is instantiated on the <em>same</em> type.</p>
+
+<p>Note that the <tt>TP</tt> annotation goes on the structure type itself,
+not the pointer; therefore, it appears before the <tt>*</tt> when
+declaring a pointer to a polymorphic structure.</p>
+
+<hr/>
+
+<a name="special-functions"/>
+<h3>8. Special Functions</h3>
+
+<p>Several standard C functions require special handling. This section
+discusses the annotations used to identify those functions.</p>
+
+<a name="allocators"/>
+<h4>8.1. Allocators</h4>
+
+<p>Deputy requires the programmer to annotate any functions that behave as
+allocators or deallocators. These annotations identify arguments that
+hold the size of the requested block as well as arguments that are
+(directly) deallocated by the function. These annotations allow Deputy to
+make sense of the <tt>void *</tt> types typically used for allocator
+results and deallocator arguments.</p>
+
+<p>The standard allocation functions are annotated as follows:</p>
+
+<div class="code">void * (<span class="annot">DALLOC(size)</span> malloc)(int size);
+void * (<span class="annot">DREALLOC(p, size)</span> realloc)(void *p, int size);
+void (<span class="annot">DFREE(p)</span> free)(void *p);
+</div>
+
+<p>First note that these annotations are placed on the function type using
+the parenthetical syntax shown above. The <tt>DALLOC</tt> annotation takes
+an expression indicating the size of the allocated block. (This argument
+is a full expression, so <tt>calloc</tt> can be annotated by multiplying
+the two arguments.) The <tt>DREALLOC</tt> annotations indicates the name
+of the argument that is freed as well as the size of the reallocated
+block, as above. The <tt>DFREE</tt> annotation indicates the name of the
+argument that is freed.</p>
+
+<p>Deputy currently does not ensure that the allocated block is zeroed.
+This feature will soon be implemented for <tt>malloc</tt>, but it is
+difficult to implement for <tt>realloc</tt>, since Deputy does not know
+the size of the original allocated block. Changing the implementations of
+<tt>malloc</tt> and <tt>realloc</tt> may be appropriate in the long
+run.</p>
+
+<a name="memset-and-friends"/>
+<h4>8.2. Memset and Friends</h4>
+
+<p>Functions such as <tt>memset</tt>, <tt>memcmp</tt>, and <tt>memcpy</tt>
+have annotations similar to the allocator annotations above. Deputy has
+special handling for these functions that allows many different types to
+be used with the <tt>void *</tt> arguments as long as they are used
+appropriately.</p>
+
+<p>These annotations are subject to change soon and are therefore not
+documented here. Examples can be found in the header files!</p>
+
+<hr/>
+
+<a name="contact-information"/>
+<h3>9. Contact Information</h3>
+
+<p>We welcome any and all feedback regarding Deputy. If you have any
+comments, suggestions, or bug reports, please send them to the <a
+href="mailto:deputy@deputy.cs.berkeley.edu">Deputy team</a>.
+
+</div>
+</body>
+</html>
--- /dev/null
+<html>
+
+<head>
+<title>Deputy Quick Reference</title>
+<link rel="stylesheet" type="text/css" href="deputy.css"/>
+</head>
+
+<body>
+<div id="frame">
+
+<h2>Deputy Quick Reference</h2>
+
+<hr/>
+
+<h3>Getting Started</h3>
+
+<p>Download and install one of the available packages. If you get the
+source distribution, do the usual <tt>./configure</tt>, <tt>make</tt>, and
+<tt>make install</tt>. (Try running <tt>make quicktest</tt>
+to verify that the build succeeded.) You can now run the <tt>deputy</tt>
+executable, which uses the same command-line options as <tt>gcc</tt>.</p>
+
+<p>Run <tt>deputy</tt> on a C file in place of <tt>gcc</tt>. (In many
+cases, this is as simple as changing <tt>CC</tt> in your makefile.) You
+will probably see a number of type errors, beginning with a series of
+warnings that suggest annotations. You can fix these errors by inserting
+annotations listed below. Hairier parts of the code can be skipped using
+the "trusted" annotations below. Once your file compiles, you'll need to
+use <tt>deputy</tt> for the linker as well so that Deputy can link in its
+(small) runtime library.</p>
+
+<p>Now run and test your program. You will probably see some run-time
+errors due to insufficient or incorrect annotations. Fix these errors and
+you're good to go!</p>
+
+<hr/>
+
+<h3>Pointer and Array Bounds</h3>
+
+<p>Pointer annotations are placed after the <tt>*</tt> in the pointer
+type. Array annotations are placed immediately before the name of the
+array, using parentheses. For example, the <tt>COUNT(42)</tt> annotation
+can be placed as follows:</p>
+
+<div class="code">int * COUNT(42) ptr;
+int (COUNT(42) array)[]:
+</div>
+
+<p>The basic Deputy bounds annotations are given in the following table.
+The type checker assumes that every pointer and array in the program is
+annotated with one of these annotations. Deputy will provide a suitable
+default for each unannotated pointer.</p>
+
+<table>
+
+<tr>
+<td width="100"><tt>BOUND(b, e)</tt><br/>
+<tt>BND(b, e)</tt></td>
+<td>The pointer is either null or it points to an array of objects of the
+base type with bounds given by the local expressions <tt>b</tt> and
+<tt>e</tt>. This pointer must be aligned with respect to both <tt>b</tt>
+and <tt>e</tt>. The keyword <tt>__this</tt> refers to the variable or
+expression to which this type is attached. To use automatic bounds,
+specify <tt>__auto</tt> in place of <tt>b</tt> and/or <tt>e</tt>.</td>
+</tr>
+
+<tr>
+<td><tt>COUNT(n)</tt>
+<tt>CT(n)</tt></td>
+<td>The pointer is either null or it points to an array of <tt>n</tt>
+objects of the base type. Equivalent to <tt>BOUND(__this, __this +
+n)</tt>. This annotation is the default for arrays with declared size
+<tt>n</tt>.</td>
+</tr>
+
+<tr>
+<td><tt>SAFE</tt></td>
+<td>The pointer is either null or it bounds to a single object of the base
+type. Equivalent to <tt>COUNT(1)</tt> and <tt>BOUND(__this, __this +
+1)</tt>. This annotation is the default for global variables, structure
+fields, and function arguments and return values.</td>
+</tr>
+
+<tr>
+<td><tt>SNT</tt></td>
+<td>This pointer is used only for comparison and never for dereference.
+Mostly equivalent to <tt>COUNT(0)</tt> and <tt>BOUND(__this, __this)</tt>,
+but currently carries an extra attribute that allows it to be incremented
+and decremented freely.</td>
+</tr>
+
+<tr>
+<td><tt>SEQ</tt></td>
+<td>A shorthand for <tt>BOUND(__auto, __auto)</tt>. Deputy will insert
+automatic bounds variables for both bounds. Note that this annotation
+must be used with care on any externally-visible data! This annotation is
+the default for local variables.</td>
+</tr>
+
+<tr>
+<td><tt>FSEQ</tt></td>
+<td>A shorthand for <tt>BOUND(__this, __auto)</tt>. Deputy will insert
+an automatic bounds variable for the upper bound, and the lower bound is
+assumed to be the pointer itself. As with <tt>SEQ</tt>, this annotation
+must be used with care on any externally-visible data!</td>
+</tr>
+
+</table>
+
+<p>You may also indicate whether a pointer is non-null with the following
+annotations:</p>
+
+<table>
+
+<tr>
+<td width="100"><tt>NONNULL</tt></td>
+<td>Indicates that a pointer must be non-null.</td>
+</tr>
+
+<tr>
+<td><tt>OPT</tt></td>
+<td>Indicates that a pointer may be null. This annotation is the default
+on all pointers.</td>
+</tr>
+
+</table>
+
+<hr/>
+
+<h3>Null-Terminated Pointers and Arrays</h3>
+
+<p>In addition to the bounds annotations provided above, you may also
+indicate that a pointer or array is null-terminated by using one of the
+following annotations:</p>
+
+<table>
+
+<tr>
+<td width="100"><tt>NT</tt></td>
+<td>Indicates that the upper bound of the pointer (as given by
+<tt>BOUND</tt> or one of its relatives) is the beginning of a
+null-terminated sequence of elements.</td>
+</tr>
+
+<tr>
+<td><tt>NTS</tt></td>
+<td>A shorthand for <tt>NT COUNT(0)</tt>--think "null-terminated string".
+This annotation is often used for <tt>char *</tt> pointers that represent
+null-terminated strings. Note that because it includes a <tt>COUNT</tt>
+annotation, it is provided in place of (rather than in addition to) the
+bounds annotations in the previous section.</td>
+</tr>
+
+</table>
+
+<p>There are two operations that allow you to convert between
+null-terminated and regular pointers:</p>
+
+<table>
+
+<tr>
+<td width="100"><tt>NTDROP(e)</tt></td>
+<td>Converts a null-terminated pointer <tt>e</tt> with type <tt>NT BOUND(b,
+e)</tt> into a standard pointer with bounds <tt>BOUND(b, e)</tt>. Because
+the null terminator lies outside of the specified bounds, this operation
+is safe; however, the null element (and any other elements outside the
+specified bounds) may no longer be accessible.</td>
+</tr>
+
+<tr>
+<td><tt>NTEXPAND(e)</tt></td>
+<td>Expands the upper bound of <tt>e</tt> up to the null element. For
+example, if <tt>e</tt> has type <tt>NT COUNT(0)</tt> but points to a
+string with 5 characters (plus a null character), then
+<tt>NTEXPAND(e)</tt> will have type <tt>NT COUNT(5)</tt>. This operation
+is often used immediately before an <tt>NTDROP</tt> in order to preserve
+access to all elements except for the null terminator itself.</td>
+</tr>
+
+</table>
+
+<hr/>
+
+<h3>Union Annotations</h3>
+
+<p>Unions are annotated by indicating when each field is active. For
+example:</p>
+
+<div class="code">struct foo {
+ int tag;
+ union foo {
+ int *p WHEN(tag == 0);
+ int n WHEN(tag == 1);
+ } u;
+};
+</div>
+
+<p>Note that the annotation is placed after the name of each field, not on
+the type of each field. The annotation is defined as follows:</p>
+
+<table>
+
+<tr>
+<td width="100"><tt>WHEN(e)</tt></td>
+<td>Indicates that the associated union field is selected when the local
+expression <tt>e</tt> evaluates to a non-zero value. The expression
+<tt>e</tt> is local with respect to the union itself, so it can refer to
+other names at the same level as the union. At most one field may be
+selected at any given time.</td>
+</tr>
+
+</table>
+
+<hr/>
+
+<h3>Special Function Annotations</h3>
+
+<p>Deputy provides annotations that identify several common C functions
+that require special treatment. These annotations are placed on the
+function type by writing them before the name of the function, in
+parentheses. For example:</p>
+
+<p><tt>void * (DALLOC(sz) malloc)(size_t sz);</tt></p>
+
+<p>These annotations are as follows:</p>
+
+<table>
+
+<tr>
+<td width="100"><tt>DALLOC(e)</tt></td>
+<td>This annotation indicates a function that acts as an allocator. The
+expression <tt>e</tt> indicates the size of the allocated block (in bytes)
+in terms of the function's formal parameters. The type of the allocation
+is determined by the pointer to which the result of this call is assigned,
+and the size is used to check (or set, in the case of automatic bounds)
+the bounds of the resulting pointer.</td>
+</tr>
+
+<tr>
+<td width="100"><tt>DFREE(p)</tt></td>
+<td>This annotation indicates a function that frees memory. The argument
+<tt>p</tt> is the name of the formal parameter for the pointer being
+freed.</td>
+</tr>
+
+<tr>
+<td width="100"><tt>DREALLOC(p, e)</tt></td>
+<td>This annotation indicates a function that acts as a reallocator; the
+arguments <tt>p</tt> and <tt>e</tt> function as specified in the previous
+two annotations. Note that newly-allocated portions of the array are
+<em>not</em> automatically zeroed by Deputy.</td>
+</tr>
+
+<tr>
+<td>
+<tt>DMEMCPY(x, y, z)</tt><br/>
+<tt>DMEMSET(x, y, z)</tt><br/>
+<tt>DMEMCMP(x, y, z)</tt>
+</td>
+<td>These annotations specify that the function behaves like
+<tt>memcpy</tt>, <tt>memset</tt>, or <tt>memcmp</tt>. The three arguments
+<tt>x</tt>, <tt>y</tt>, and <tt>z</tt> are meant to indicate the indices
+of the arguments that behave like the corresponding arguments for the
+original function; however, they are ignored by the current
+implementation. When Deputy sees a call to a function with one of these
+annotations, it verifies the bounds of the pointers passed to these
+functions, and when data is being written, it verifies that the data
+written has the correct type. In the case of <tt>memset</tt>, we allow
+arrays containing pointers to be initialized to zero (assuming, of course,
+that those pointers are not non-null).</td>
+</tr>
+
+</table>
+
+<hr/>
+
+<h3>Trusted Annotations</h3>
+
+<p>Deputy allows the user to trust code in cases where Deputy annotations
+cannot easily be provided. There are several ways to indicate trusted
+code:</p>
+
+<p>First, you may specify trusted blocks of code. If you place
+<tt>TRUSTEDBLOCK</tt> after the opening brace of a block, Deputy will not
+attempt to check any code contained therein. If this block reads
+variables with automatic bounds, Deputy will adjust the code as necessary
+to allow the read to occur. However, writes to variables with automatic
+bounds are not allowed.</p>
+
+<p>Second, you may use the <tt>TRUSTED</tt> annotation, which can appear
+in three places:</p>
+
+<ul>
+
+<li>On a pointer, the <tt>TRUSTED</tt> annotation causes Deputy to trust
+any casts into or out of that pointer as well as any arithmetic operations
+on that pointer. When casting from a trusted pointer to a non-trusted
+pointer, the bounds on the non-trusted pointer must be given explicitly.
+(Automatic bounds can still be used as long as they are explicitly
+requested with an annotation such as <tt>SEQ</tt>.)</li>
+
+<li>On a union, the <tt>TRUSTED</tt> annotation causes Deputy to suppress
+any tag checks assocated with that union. This annotation can be placed
+after the <tt>union</tt> keyword or after the closing brace of the
+union.</li>
+
+<li>On a function, the <tt>TRUSTED</tt> annotation tells Deputy not to
+process the local variables or the function body. As with
+<tt>TRUSTEDBLOCK</tt>, Deputy will adjust reads of variables with
+automatic bounds appropriately but will disallow writes to such
+variables.</li>
+
+</ul>
+
+<p>For convenience, you can use the macro <tt>TC(e)</tt> to convert a
+pointer expression <tt>e</tt> to a trusted version of the same pointer.
+This macro is very useful for performing trusted casts from one pointer
+type to another.</p>
+
+</div>
+</body>
+</html>
--- /dev/null
+gcc_*
\ No newline at end of file
--- /dev/null
+//Use this file with "ccured --listnonsafe" to hide Deputy's annotations
+//from CCured.
+// "ANNOTATED" means that "ccured --listnonsafe" should suppress the warning,
+// since this code is already Deputy-ready.
+
+#ifdef CCURED
+# define ANNOTATED __attribute__((annotated))
+# define BND(b,e) ANNOTATED
+# define COUNT(c) ANNOTATED __COUNT(c)
+# define SIZE(c) ANNOTATED
+# define SAFE ANNOTATED __SAFE
+# define SNT ANNOTATED
+# define NT ANNOTATED
+# define NTS ANNOTATED
+# define NULLTERM ANNOTATED
+# define POLY ANNOTATED
+# define TRUSTED ANNOTATED
+# define TC(x) __trusted_cast(x)
+# define WHEN(c) ANNOTATED
+
+# define DMEMSET(x,y,z)
+# define DMEMCPY(x,y,z)
+# define DMEMCMP(x,y,z)
+# define DALLOC(x)
+#endif //ndef DEPUTY
+
--- /dev/null
+#ifndef ANNOT_H
+#define ANNOT_H
+
+#define DEPUTY 1
+
+#define BOUND(lo, hi) __attribute__((bounds((lo),(hi))))
+#define COUNT(n) BND(__this, __this + (n))
+#define SIZE(n) COUNT(n)
+#define SAFE COUNT(1)
+#define SNT COUNT(0) __attribute__((sentinel))
+
+#define BND(lo, hi) BOUND(lo, hi)
+#define CT(n) COUNT(n)
+#define SZ(n) SIZE(n)
+
+#define EFAT BND(__this, __auto)
+#define FAT BND(__auto, __auto)
+
+#define NULLTERM __attribute__((nullterm))
+#define NT NULLTERM
+#define NTS NULLTERM COUNT(0)
+#define NTC(n) NULLTERM COUNT(n-1)
+
+#define NTDROPATTR __attribute__((ntdrop))
+#define NTEXPANDATTR __attribute__((ntexpand))
+
+#define NULLABLE
+#define OPT NULLABLE
+#define NONNULL __attribute__((nonnull))
+
+#define TRUSTED __attribute__((trusted))
+#define TRUSTEDBLOCK __blockattribute__((trusted))
+
+#define POLY TRUSTED
+
+#define COPYTYPE __attribute__((copytype))
+
+//specifies that Deputy's typechecker (but not optimizer) should assume
+//that this lvalue is constant. (unsound)
+#define ASSUMECONST __attribute__((assumeconst))
+
+#define WHEN(e) __attribute__((when(e)))
+
+#define DMEMCPY(x, y, z) __attribute__((dmemcpy((x),(y),(z))))
+#define DMEMSET(x, y, z) __attribute__((dmemset((x),(y),(z))))
+#define DMEMCMP(x, y, z) __attribute__((dmemcmp((x),(y),(z))))
+
+#define DALLOC(x) __attribute__((dalloc(x)))
+#define DREALLOC(x, y) __attribute__((drealloc((x), (y))))
+#define DFREE(x) __attribute__((dfree(x)))
+
+#define DVARARG(x) __attribute__((dvararg(x)))
+#define DPRINTF(x) DVARARG(printf(x))
+
+#define NTDROP(x) ((void * COUNT(0) NTDROPATTR COPYTYPE)(x))
+#define NTEXPAND(x) ((void * COUNT(0) NTEXPANDATTR COPYTYPE)(x))
+
+#define TC(x) ((void * TRUSTED COPYTYPE)(x))
+
+#define TVATTR(x) __attribute__((tyvar(x)))
+#define TPATTR(x) __attribute__((typaram(sizeof(x))))
+
+#define TV(x) void * TVATTR(x)
+#define TP(x) TPATTR(x)
+
+//Deputy will replace this with the number of checks that were inserted into
+//the file. Small regression tests use this to ensure that all checks that
+//that should be optimized away actually are. Since we regularly change the
+//way checks are implemented, this is really only useful for small tests with
+//few or no checks added.
+extern const int DEPUTY_NUM_CHECKS_ADDED;
+
+#endif // ANNOT_H
--- /dev/null
+// Runtime checks for Deputy programs.
+
+// This file is included in deputy_lib and also at the start of every
+// Deputy output file. Before this file is included you must define
+// DEPUTY_ALWAYS_STOP_ON_ERROR if you want to optimize the checks.
+
+// Note "volatile": We currently use volatile everywhere so that these
+// checks work on any kind of pointer. In the future, we may want to
+// investigate the performance impact of this annotation in the common
+// (non-volatile) case.
+
+// Use inline even when not optimizing for speed, since it prevents
+// warnings that would occur due to unused static functions.
+#ifdef DEPUTY_ALWAYS_STOP_ON_ERROR
+ #define INLINE inline __attribute__((always_inline))
+#else
+ #define INLINE inline
+#endif
+
+#define __LOCATION__ __FILE__, __LINE__, __FUNCTION__
+#define __LOCATION__FORMALS const char* file, int line, const char* func
+#define __LOCATION__ACTUALS file, line, func
+
+#ifndef asmlinkage
+#define asmlinkage __attribute__((regparm(0)))
+#endif
+
+#ifndef noreturn
+#define noreturn __attribute__((noreturn))
+#endif
+
+#if defined(__KERNEL__) && defined(DEPUTY_KERNEL_COVERAGE)
+INLINE static
+unsigned int read_pc()
+TRUSTED {
+ unsigned int pc;
+
+ asm("movl %%ebp, %0" : "=r"(pc));
+
+ return *((unsigned int *)pc + 1);
+}
+
+extern void checkBitArrayAdd(unsigned int addr);
+#endif
+
+extern asmlinkage
+void deputy_fail_mayreturn(const char *check, const char *text,
+ __LOCATION__FORMALS);
+
+extern asmlinkage noreturn
+void deputy_fail_noreturn(const char *check, const char *text,
+ __LOCATION__FORMALS);
+
+extern asmlinkage noreturn
+void deputy_fail_noreturn_fast(void);
+
+/* Search for a NULL starting at e and return its index */
+extern asmlinkage
+int deputy_findnull(const void *e1, unsigned int sz);
+
+//Define deputy_memset, which we use to initialize locals
+//FIXME: We should set __deputy_memset = __builtin_memset to take advantage
+//of optimizations. How do we do that in a portable way?
+#if defined(memset) && !defined(IN_DEPUTY_LIBRARY)
+#define __deputy_memset memset
+#else
+extern asmlinkage
+void *__deputy_memset(void *s, int c, unsigned int n);
+#endif
+
+#if defined(DEPUTY_FAST_CHECKS)
+ #define deputy_fail(x, y, z) deputy_fail_noreturn_fast()
+#elif defined(DEPUTY_ALWAYS_STOP_ON_ERROR)
+ #define deputy_fail deputy_fail_noreturn
+#else
+ #define deputy_fail deputy_fail_mayreturn
+#endif
+
+
+/* Check that there is no NULL between e .. e+len-1. "bytes" is the size of
+ * an element */
+INLINE static asmlinkage
+int deputy_nullcheck(const volatile void *e, unsigned int len,
+ unsigned int bytes) {
+#define NULLCHECK(type) \
+ do { \
+ type *p1 = (type*) e; \
+ type *p2 = ((type*) e) + len; \
+ while (p1 < p2 && *p1 != 0) { \
+ p1++; \
+ } \
+ success = (p1 >= p2); \
+ } while (0)
+
+ int success = 0;
+
+ switch (bytes) {
+ case 1:
+ NULLCHECK(char);
+ break;
+ case 2:
+ NULLCHECK(short);
+ break;
+ case 4:
+ NULLCHECK(long);
+ break;
+ default:
+ deputy_fail("Bug: Invalid byte size for nullcheck.\n",
+ "", __LOCATION__);
+ }
+ return success;
+#undef NULLCHECK
+}
+
+#if defined(__KERNEL__) && defined(KRECOVER) && !defined(NO_INJECTION)
+extern int kr_failure_injected(void);
+#define INJECTED_FAILURE() (kr_failure_injected())
+#else
+#define INJECTED_FAILURE() 0
+#endif
+
+// what : a boolean that ought to be true
+// checkName: the name of the check
+// checkWhat: a string that explains what goes wrong
+#if defined(__KERNEL__) && defined(DEPUTY_KERNEL_COVERAGE)
+#define DEPUTY_ASSERT_TEXT(what,text,checkName)\
+ checkBitArrayAdd(read_pc());\
+ if (!(what) || INJECTED_FAILURE()) { \
+ deputy_fail(checkName, text, __LOCATION__ACTUALS); \
+ }
+
+#define DEPUTY_ASSERT(what, checkName) \
+ checkBitArrayAdd(read_pc());\
+ DEPUTY_ASSERT_TEXT(what, text, checkName)
+#else
+#define DEPUTY_ASSERT_TEXT(what, text, checkName) \
+ if (!(what) || INJECTED_FAILURE()) { \
+ deputy_fail(checkName, text, __LOCATION__ACTUALS); \
+ }
+
+#define DEPUTY_ASSERT(what, checkName) \
+ DEPUTY_ASSERT_TEXT(what, text, checkName)
+#endif
+
+INLINE static void CNonNull(const volatile void* p,
+ const char *text, __LOCATION__FORMALS) {
+ DEPUTY_ASSERT(p != 0, "non-null check");
+}
+
+INLINE static void CEq(const volatile void* e1, const volatile void* e2,
+ const char *why,
+ const char *text, __LOCATION__FORMALS) {
+ DEPUTY_ASSERT(e1 == e2, why);
+}
+
+INLINE static void CMult(int i1, int i2,
+ const char *text, __LOCATION__FORMALS) {
+ DEPUTY_ASSERT((i2 % i1) == 0, "alignment check");
+}
+
+/* Check that p + sz * e does not overflow that remains within [lo..hi). It
+ * is guaranteed on input that lo <= p <= hi, with p and h aligned w.r.t. lo
+ * and size sz. */
+INLINE static void CPtrArith(const volatile void* lo, const volatile void* hi,
+ const volatile void* p, int e, unsigned int sz,
+ const char *textlo, const char *texthi,
+ __LOCATION__FORMALS) {
+ if (e >= 0) {
+ DEPUTY_ASSERT_TEXT(e <= (hi - p) / sz, texthi, "upper bound check");
+ } else {
+ DEPUTY_ASSERT_TEXT(-e <= (p - lo) / sz, textlo, "lower bound check");
+ }
+}
+
+INLINE static void CPtrArithNT(const volatile void* lo, const volatile void* hi,
+ const volatile void* p, int e, unsigned int sz,
+ const char *textlo, const char *texthi,
+ __LOCATION__FORMALS) {
+ if (e >= 0) {
+ unsigned int len = (hi - p) / sz;
+ if (e > len) {
+ DEPUTY_ASSERT_TEXT(deputy_nullcheck(hi, e - len, sz),
+ texthi, "nullterm upper bound check");
+ }
+ } else {
+ DEPUTY_ASSERT_TEXT(-e <= (p - lo) / sz, textlo, "lower bound check");
+ }
+}
+
+INLINE static void CPtrArithAccess(const volatile void* lo,
+ const volatile void* hi,
+ const volatile void* p,
+ int e, unsigned int sz,
+ const char* textlo, const char *texthi,
+ __LOCATION__FORMALS) {
+ if (e >= 0) {
+ DEPUTY_ASSERT_TEXT(e + 1 <= (hi - p) / sz, texthi, "upper bound check");
+ } else {
+ DEPUTY_ASSERT_TEXT(-e <= (p - lo) / sz, textlo, "lower bound check");
+ }
+}
+
+INLINE static void CLeqInt(unsigned int e1, unsigned int e2,
+ const char* why,
+ const char* text, __LOCATION__FORMALS) {
+ DEPUTY_ASSERT(e1 <= e2, why);
+}
+
+INLINE static void CLeq(const volatile void* e1, const volatile void* e2,
+ const char* why,
+ const char* text, __LOCATION__FORMALS) {
+ DEPUTY_ASSERT(e1 <= e2, why);
+}
+
+/* Used to set the upped bounds of an NT string to e1, when we know that e2
+ * is a safe upper bound. Test that e1 <= e2 OR there is no NULL between
+ * e2...e1-1. */
+INLINE static void CLeqNT(const volatile void* e1, const volatile void* e2,
+ unsigned int sz, const char* why,
+ const char* text, __LOCATION__FORMALS) {
+ if (e1 > e2) {
+ DEPUTY_ASSERT(deputy_nullcheck(e2, (e1 - e2) / sz, sz), why);
+ }
+}
+
+INLINE static void CNullOrLeq(const volatile void* e,
+ const volatile void* e1, const volatile void* e2,
+ const char* why,
+ const char* text, __LOCATION__FORMALS) {
+ if (e) {
+ DEPUTY_ASSERT(e1 <= e2, why);
+ }
+}
+
+/* Check that e is NULL, or e1 <= e2, or there is no NULL from e2 to e1 */
+INLINE static void CNullOrLeqNT(const volatile void* e,
+ const volatile void* e1,
+ const volatile void* e2,
+ unsigned int sz, const char* why,
+ const char* text, __LOCATION__FORMALS) {
+ if (e && e1 > e2) {
+ DEPUTY_ASSERT(deputy_nullcheck(e2, (e1 - e2) / sz, sz), why);
+ }
+}
+
+
+INLINE static void CWriteNT(const volatile void* p,
+ const volatile void* hi,
+ int what, unsigned int sz,
+ const char* text, __LOCATION__FORMALS) {
+ if (p == hi) {
+ int isNull = 0;
+ switch (sz) {
+ case 1: isNull = (*((const volatile char *) p) == 0); break;
+ case 2: isNull = (*((const volatile short *) p) == 0); break;
+ case 4: isNull = (*((const volatile int *) p) == 0); break;
+ }
+ DEPUTY_ASSERT(!isNull || what == 0, "nullterm write check");
+ }
+}
+
+INLINE static void CNullUnionOrSelected(const volatile void* p,
+ unsigned int size,
+ int sameFieldSelected,
+ const char* text, __LOCATION__FORMALS) {
+ if (!sameFieldSelected) {
+ const volatile char* pp = (const volatile char*)p;
+ const volatile char* pend = pp + size;
+ while (pp < pend) {
+ DEPUTY_ASSERT(0 == *pp++, "null union check");
+ }
+ }
+}
+
+INLINE static void CSelected(int what,
+ const char* text, __LOCATION__FORMALS) {
+ if (!(what)) {
+ deputy_fail("check that union field is selected",
+ text, __LOCATION__ACTUALS); }
+}
+
+INLINE static void CNotSelected(int what,
+ const char* text, __LOCATION__FORMALS) {
+ if ((what)) {
+ deputy_fail("check that union field is not selected",
+ text, __LOCATION__ACTUALS); }
+}
+
+#define deputy_max(x, y) ((x) > (y) ? (x) : (y))
+
+#undef DEPUTY_ASSERT
--- /dev/null
+__inline static int atoi(char const *__nptr) __attribute__((CTaint(*$1,$0)));
+long atol(const char *nptr) __attribute__((CTaint(*$1,$0)));
+long long atoll(const char *nptr) __attribute__((CTaint(*$1,$0)));
+long long atoq(const char *nptr) __attribute__((CTaint(*$1,$0)));
+int fscanf(void *, const char *, ...) __attribute__((ScanTaint(2)));
+int scanf(const char *, ...) __attribute__((ScanTaint(1)));
+int _IO_getc(void *) __attribute__((Taint($0,1,1)));
+int fgetc(void *) __attribute__((Taint($0,1,1)));
+char fgets(char *,int,void *) __attribute__((Taint(*$1,1,$2)));
+unsigned int read(int,void *,unsigned int) __attribute__((Taint(*$2,1,$3)));
--- /dev/null
+/* Copyright (C) 2004-2006 Henry Cejtin, Matthew Fluet, Suresh
+ * Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+/* Can't use _TYPES_H_ because MSVCRT uses it. So, we use _MLTON_TYPES_H_. */
+
+#ifndef _MLTON_TYPES_H_
+#define _MLTON_TYPES_H_
+
+/* We need these because in header files for exported SML functions, types.h is
+ * included without platform.h.
+ */
+#ifndef _ISOC99_SOURCE
+#define _ISOC99_SOURCE
+#endif
+#if defined(_AIX) || (defined(__hpux__) || defined (__OpenBSD__))
+#include <inttypes.h>
+#elif (defined (__sun__))
+#include <sys/int_types.h>
+#else
+#include <stdint.h>
+#endif
+
+typedef int8_t Int8;
+typedef int16_t Int16;
+typedef int32_t Int32;
+typedef int64_t Int64;
+typedef char *Pointer;
+typedef Pointer pointer;
+typedef float Real32;
+typedef double Real64;
+typedef uint8_t Word8;
+typedef uint16_t Word16;
+typedef uint32_t Word32;
+typedef uint64_t Word64;
+
+typedef Int8 WordS8;
+typedef Int16 WordS16;
+typedef Int32 WordS32;
+typedef Int64 WordS64;
+
+typedef Word8 WordU8;
+typedef Word16 WordU16;
+typedef Word32 WordU32;
+typedef Word64 WordU64;
+
+/* !!! this stuff is all wrong: */
+typedef Int32 Int;
+typedef Real64 Real;
+typedef Word8 Char;
+typedef Word32 Word;
+typedef Int64 Position;
+
+typedef Int Bool;
+typedef Word Cpointer;
+typedef Word Cstring;
+typedef Word CstringArray;
+typedef Word Dirstream;
+typedef Int Fd;
+typedef Word Flag;
+typedef Word Gid;
+typedef Word Mode;
+typedef Word NullString;
+typedef Int Pid;
+typedef Int Resource;
+typedef Word Rlimit;
+typedef Int Signal;
+typedef Int Size;
+typedef Int Speed;
+typedef Int Ssize;
+typedef Int Status;
+typedef Int Syserror;
+typedef Pointer Thread;
+typedef Word Uid;
+
+#endif /* _MLTON_TYPES_H_ */
+
+void process_instrs (Pointer x0, Int32 x1, Int32 x2);
--- /dev/null
+
+#ifndef _SML_INSTRUMENTER_H_
+#define _SML_INSTRUMENTER_H_
+
+#include <deputy/lwcalls.h>
+
+typedef unsigned int u32;
+
+
+/* XXX: Add codes for each instr type, interpret in SML code */
+#define INSTR_WIDTH 15
+#define INSTR_MAX 2200000
+
+#define ASSIGNBASIC 0
+#define ASSIGNBOP 10
+#define ASSIGNUOP 20
+#define ASSIGNCAST 30
+#define RETBASIC 40
+#define RETBOP 50
+#define RETUOP 60
+#define RETVOID 70
+#define IFBASIC 80
+#define IFBOP 90
+#define IFUOP 100
+#define SWITCHBASIC 110
+#define SWITCHBOP 120
+#define SWITCHUOP 130
+
+#define PUSHARG 140
+#define POPARG 150
+#define FUNSTART 160
+#define RETPOP 170
+#define RETNORET 180
+
+#define UNREGLOCAL 190
+
+#define TAINT 200
+#define CONDT 210
+
+#define CLEQCODE 220
+
+#define CLEQSUM 230
+#define CSUMLEQ 240
+
+struct funInstrList {
+ u32 *instrs;
+ u32 next;
+ u32 max;
+};
+
+#define BOP_PLUSA 0
+#define BOP_PLUSPI 1
+#define BOP_INDEXPI 2
+#define BOP_MINUSA 3
+#define BOP_MINUSPI 4
+#define BOP_MINUSPP 5
+#define BOP_MULT 6
+#define BOP_DIV 7
+#define BOP_MOD 8
+#define BOP_SHIFTL 9
+#define BOP_SHIFTR 10
+#define BOP_LT 11
+#define BOP_GT 12
+#define BOP_LE 13
+#define BOP_GE 14
+#define BOP_EQ 15
+#define BOP_NE 16
+#define BOP_BAND 17
+#define BOP_BXOR 18
+#define BOP_BOR 19
+#define BOP_LAND 20
+#define BOP_LOR 21
+
+#define UOP_NEG 0
+#define UOP_BNOT 1
+#define UOP_LNOT 2
+
+
+#ifndef IN_GLOB_STATE_C
+
+#define NULL (void *)0;
+#define INLINE inline __attribute__((always_inline))
+//#define INLINE
+
+extern struct funInstrList fil;
+
+#define APPARGS1 u32 a1
+#define APPARGS2 APPARGS1, u32 a2
+#define APPARGS3 APPARGS2, u32 a3
+#define APPARGS4 APPARGS3, u32 a4
+#define APPARGS5 APPARGS4, u32 a5
+#define APPARGS6 APPARGS5, u32 a6
+#define APPARGS7 APPARGS6, u32 a7
+#define APPARGS8 APPARGS7, u32 a8
+#define APPARGS9 APPARGS8, u32 a9
+#define APPARGS10 APPARGS9, u32 a10
+#define APPARGS11 APPARGS10, u32 a11
+#define APPARGS12 APPARGS11, u32 a12
+#define APPARGS13 APPARGS12, u32 a13
+#define APPARGS14 APPARGS13, u32 a14
+#define APPARGS15 APPARGS14, u32 a15
+
+#define FILLINSTR1 fil.instrs[ri] = a1
+#define FILLINSTR2 FILLINSTR1; fil.instrs[ri+1] = a2
+#define FILLINSTR3 FILLINSTR2; fil.instrs[ri+2] = a3
+#define FILLINSTR4 FILLINSTR3; fil.instrs[ri+3] = a4
+#define FILLINSTR5 FILLINSTR4; fil.instrs[ri+4] = a5
+#define FILLINSTR6 FILLINSTR5; fil.instrs[ri+5] = a6
+#define FILLINSTR7 FILLINSTR6; fil.instrs[ri+6] = a7
+#define FILLINSTR8 FILLINSTR7; fil.instrs[ri+7] = a8
+#define FILLINSTR9 FILLINSTR8; fil.instrs[ri+8] = a9
+#define FILLINSTR10 FILLINSTR9; fil.instrs[ri+9] = a10
+#define FILLINSTR11 FILLINSTR10; fil.instrs[ri+10] = a11
+#define FILLINSTR12 FILLINSTR11; fil.instrs[ri+11] = a12
+#define FILLINSTR13 FILLINSTR12; fil.instrs[ri+12] = a13
+#define FILLINSTR14 FILLINSTR13; fil.instrs[ri+13] = a14
+#define FILLINSTR15 FILLINSTR14; fil.instrs[ri+14] = a15
+
+#define FUNINSTRLISTAPP(N) \
+INLINE static void funInstrListApp##N(APPARGS##N)\
+{\
+ int ri;\
+ if (fil.next == fil.max) {\
+ process_instrs(fil.instrs,fil.max,INSTR_WIDTH);\
+ fil.next = 0;\
+ }\
+ ri = fil.next * INSTR_WIDTH;\
+ FILLINSTR##N;\
+ fil.next++;\
+ return;\
+}
+
+FUNINSTRLISTAPP(1);
+FUNINSTRLISTAPP(2);
+FUNINSTRLISTAPP(3);
+FUNINSTRLISTAPP(4);
+FUNINSTRLISTAPP(5);
+FUNINSTRLISTAPP(6);
+FUNINSTRLISTAPP(7);
+FUNINSTRLISTAPP(8);
+FUNINSTRLISTAPP(9);
+FUNINSTRLISTAPP(10);
+FUNINSTRLISTAPP(11);
+FUNINSTRLISTAPP(12);
+FUNINSTRLISTAPP(13);
+FUNINSTRLISTAPP(14);
+FUNINSTRLISTAPP(15);
+
+/*
+INLINE static void
+funInstrListPush()
+{
+ struct funInstrList *new = malloc(sizeof(struct funInstrList));
+ new->instrs = malloc(100000 * sizeof(u32) * INSTR_WIDTH);
+ new->max = 100000;
+ new->next = 0;
+ new->lnext = fil_stack;
+ fil_stack = new;
+ return;
+}
+
+INLINE static void
+funInstrListPop()
+{
+ struct funInstrList *tmp = fil_stack;
+ if (tmp) {
+ if (tmp->instrs) {
+ process_instrs(tmp->instrs, tmp->next, INSTR_WIDTH);
+ free(tmp->instrs);
+ }
+ fil_stack = tmp->lnext;
+ free(tmp);
+ }
+ return;
+}
+*/
+
+#define BOP_PLUSA 0
+#define BOP_PLUSPI 1
+#define BOP_INDEXPI 2
+#define BOP_MINUSA 3
+#define BOP_MINUSPI 4
+#define BOP_MINUSPP 5
+#define BOP_MULT 6
+#define BOP_DIV 7
+#define BOP_MOD 8
+#define BOP_SHIFTL 9
+#define BOP_SHIFTR 10
+#define BOP_LT 11
+#define BOP_GT 12
+#define BOP_LE 13
+#define BOP_GE 14
+#define BOP_EQ 15
+#define BOP_NE 16
+#define BOP_BAND 17
+#define BOP_BXOR 18
+#define BOP_BOR 19
+#define BOP_LAND 20
+#define BOP_LOR 21
+
+#define UOP_NEG 0
+#define UOP_BNOT 1
+#define UOP_LNOT 2
+
+/************** Printing */
+
+static void print_bop(unsigned int bop)
+{
+ switch(bop) {
+ case BOP_PLUSA:
+ case BOP_PLUSPI:
+ case BOP_INDEXPI: printf(" + "); break;
+ case BOP_MINUSA:
+ case BOP_MINUSPI:
+ case BOP_MINUSPP: printf(" - "); break;
+ case BOP_MULT: printf(" * "); break;
+ case BOP_DIV: printf(" / "); break;
+ case BOP_MOD: printf(" \% "); break;
+ case BOP_SHIFTL: printf(" << "); break;
+ case BOP_SHIFTR: printf(" >> "); break;
+ case BOP_LT: printf(" < "); break;
+ case BOP_GT: printf(" > "); break;
+ case BOP_LE: printf(" <= "); break;
+ case BOP_GE: printf(" >= "); break;
+ case BOP_EQ: printf(" == "); break;
+ case BOP_NE: printf(" != "); break;
+ case BOP_BAND: printf(" & "); break;
+ case BOP_BXOR: printf(" ^ "); break;
+ case BOP_BOR: printf(" | "); break;
+ case BOP_LAND: printf(" && "); break;
+ case BOP_LOR: printf(" || "); break;
+ default: printf(" ?? "); break;
+ }
+}
+
+static void print_uop(unsigned int uop)
+{
+ switch(uop) {
+ case UOP_NEG: printf(" - "); break;
+ case UOP_BNOT: printf(" ~ "); break;
+ case UOP_LNOT: printf(" ! "); break;
+ default: printf(" ?? "); break;
+ }
+}
+
+
+#define VOIDARGS0
+#define VOIDARGS1 unsigned int a1
+#define VOIDARGS2 VOIDARGS1, unsigned int a2
+#define VOIDARGS3 VOIDARGS2, unsigned int a3
+#define VOIDARGS4 VOIDARGS3, unsigned int a4
+#define VOIDARGS5 VOIDARGS4, unsigned int a5
+#define VOIDARGS6 VOIDARGS5, unsigned int a6
+#define VOIDARGS7 VOIDARGS6, unsigned int a7
+#define VOIDARGS8 VOIDARGS7, unsigned int a8
+#define VOIDARGS9 VOIDARGS8, unsigned int a9
+#define VOIDARGS10 VOIDARGS9, unsigned int a10
+#define VOIDARGS11 VOIDARGS10, unsigned int a11
+#define VOIDARGS12 VOIDARGS11, unsigned int a12
+#define VOIDARGS13 VOIDARGS12, unsigned int a13
+#define VOIDARGS14 VOIDARGS13, unsigned int a14
+#define VOIDARGS15 VOIDARGS14, unsigned int a15
+#define VOIDARGS16 VOIDARGS15, unsigned int a16
+#define VOIDARGS17 VOIDARGS16, unsigned int a17
+
+#define DINSTRFun(name, args) INLINE static void DINSTR_##name(VOIDARGS##args)
+
+INLINE static unsigned int
+negate_bop(unsigned int bop)
+{
+ switch(bop) {
+ case BOP_LT: return BOP_GE;
+ case BOP_GT: return BOP_LE;
+ case BOP_LE: return BOP_GT;
+ case BOP_GE: return BOP_LT;
+ default: return bop;
+ }
+}
+
+
+/*
+INLINE static in isNeg(struct exp *e)
+{
+ return (e != NULL) && (e->type == BASICTYP) && (e->e.basic->neg == 1);
+}
+*/
+
+DINSTRFun(Assign,5)
+{
+
+ funInstrListApp6(ASSIGNBASIC,a1,a2,a3,a4,a5);
+ return;
+}
+
+
+DINSTRFun(Bop,10)
+{
+ funInstrListApp11(ASSIGNBOP,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10);
+ return;
+}
+
+DINSTRFun(Uop,6)
+{
+ funInstrListApp7(ASSIGNUOP,a1,a2,a3,a4,a5,a6);
+ return;
+}
+
+
+DINSTRFun(PushArg,4)
+{
+ funInstrListApp5(PUSHARG,a1,a2,a3,a4);
+ return;
+}
+
+DINSTRFun(PopArg,1)
+{
+ funInstrListApp2(POPARG,a1);
+ return;
+}
+
+DINSTRFun(UnRegLocal,3)
+{
+ funInstrListApp4(UNREGLOCAL,a1,a2,a3);
+ return;
+}
+
+DINSTRFun(FunStart,1)
+{
+ funInstrListApp2(FUNSTART,a1);
+ return;
+}
+
+/* a1 - symbolic op
+ * a2 - type(pointer/scalar)
+ * a3 - size
+ */
+DINSTRFun(RegisterField, 3)
+{
+ return;
+}
+
+/* make sure memory range [p,p+sz] is all zero */
+INLINE static unsigned int
+DINSTR_IsNull(unsigned int p, unsigned int sz)
+{
+ char *c = (char *)p;
+ int i = 0;
+ while(c < p + sz) {
+ if(*c) return 0;
+ c++;
+ }
+ return 1;
+}
+
+/*
+ * a1 - start address
+ * a2 - element size
+ * a3 - number of elements. -1 => Nullterm
+ * a4 - pointer to element registration function
+ */
+DINSTRFun(RegisterArray, 4)
+{
+ return;
+}
+
+DINSTRFun(Cast,5)
+{
+ funInstrListApp6(ASSIGNCAST,a1,a2,a3,a4,a5);
+ return;
+}
+
+DINSTRFun(RetBasic,4)
+{
+ funInstrListApp5(RETBASIC,a1,a2,a3,a4);
+ return;
+}
+
+DINSTRFun(RetBop,9)
+{
+ funInstrListApp10(RETBOP,a1,a2,a3,a4,a5,a6,a7,a8,a9);
+ return;
+}
+
+DINSTRFun(RetUop,5)
+{
+ funInstrListApp6(RETUOP,a1,a2,a3,a4,a5);
+ return;
+}
+
+DINSTRFun(RetVoid,0)
+{
+ funInstrListApp1(RETVOID);
+ return;
+}
+
+
+DINSTRFun(RetPop,5)
+{
+ funInstrListApp6(RETPOP,a1,a2,a3,a4,a5);
+ return;
+}
+
+DINSTRFun(RetNoRet,1)
+{
+ funInstrListApp2(RETNORET,a1);
+ return;
+}
+
+DINSTRFun(IfBasic,6)
+{
+ funInstrListApp7(IFBASIC,a1,a2,a3,a4,a5,a6);
+ return;
+}
+
+DINSTRFun(IfBop,11)
+{
+ funInstrListApp12(IFBOP,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11);
+ return;
+}
+
+DINSTRFun(IfUop,7)
+{
+ funInstrListApp8(IFUOP,a1,a2,a3,a4,a5,a6,a7);
+ return;
+}
+
+DINSTRFun(SwitchBasic,5)
+{
+ funInstrListApp6(SWITCHBASIC,a1,a2,a3,a4,a5);
+ return;
+}
+
+DINSTRFun(SwitchBop,10)
+{
+ funInstrListApp11(SWITCHBOP,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10);
+ return;
+}
+
+DINSTRFun(SwitchUop,6)
+{
+ funInstrListApp7(SWITCHUOP,a1,a2,a3,a4,a5,a6);
+ return;
+}
+
+DINSTRFun(CNonNull,4) {return;}
+DINSTRFun(CEq,8) {return;}
+DINSTRFun(CMult,8) {return;}
+DINSTRFun(CPtrArith,17){return;}
+DINSTRFun(CPtrArithNT,17) {return;}
+DINSTRFun(CPtrArithAccess,17) {return;}
+DINSTRFun(CLeqInt,8) {return;}
+DINSTRFun(CLeq,10)
+{
+ funInstrListApp11(CLEQCODE,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10);
+ return;
+}
+
+DINSTRFun(CLeqSum,14)
+{
+ funInstrListApp15(CLEQSUM,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14);
+ return;
+}
+DINSTRFun(CSumLeq,14)
+{
+ funInstrListApp15(CSUMLEQ,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14);
+ return;
+}
+DINSTRFun(CLeqNT,9) {return;}
+DINSTRFun(CNullOrLeq,12) {return;}
+DINSTRFun(CNullOrLeqNT,13) {return;}
+DINSTRFun(CWriteNT,13) {return;}
+DINSTRFun(CNullUnionOrSelected,8) {return;}
+DINSTRFun(CSelected,4) {return;}
+DINSTRFun(CNotSelected,4) {return;}
+
+DINSTRFun(taint,5)
+{
+ funInstrListApp6(TAINT,a1,a2,a3,a4,a5);
+ return;
+}
+
+DINSTRFun(ctaint,8)
+{
+ funInstrListApp9(CONDT,a1,a2,a3,a4,a5,a6,a7,a8);
+ return;
+}
+
+DINSTRFun(Argv,4)
+{
+ int argc = a1, i;
+ char **argv = a2;
+
+ for(i = 0; i < argc; i++)
+ funInstrListApp6(TAINT,argv[i],1,strlen(argv[i])+1,a3,a4);
+
+ return;
+}
+
+INLINE static void DINSTR_init()
+{
+ fil.instrs = malloc(INSTR_MAX * sizeof(u32) * INSTR_WIDTH);
+ fil.max = INSTR_MAX;
+ fil.next = 0;
+ return;
+}
+
+INLINE static void DINSTR_end()
+{
+ process_instrs(fil.instrs,fil.next,INSTR_WIDTH);
+ free(fil.instrs);
+ return;
+}
+INLINE static void DINSTR_nop() { return; }
+
+#endif
+#endif /* _SML_INSTRUMENTER_H_ */
--- /dev/null
+// glibc_patch.h
+//
+// This file contains the libc patch for Deputy. Annotations on the
+// functions below will be patched into the libc headers when Deputy runs.
+// In this file, void types are treated as wildcards, so any types that
+// are irrelevant to the patch can be changed to void.
+
+// Typedefs for types that appear below but are irrelevant to the patch.
+
+typedef void __gid_t;
+typedef void __uid_t;
+typedef unsigned long size_t;
+typedef signed long ssize_t;
+typedef void socklen_t;
+typedef void __socklen_t;
+typedef void mode_t;
+typedef void dev_t;
+typedef void time_t;
+typedef void FILE;
+typedef void DIR;
+typedef void __gnuc_va_list;
+
+#define __SSIZE_T ssize_t
+#define __SIZE_T size_t
+#define __SOCKLEN_T socklen_t
+#define __MODE_T mode_t
+#define __DEV_T dev_t
+
+#define __SOCKADDR_ARG struct sockaddr *
+#define __CONST_SOCKADDR_ARG struct sockaddr *
+
+// Some handy macros for the types below.
+
+#define OPTSTRING char * NTS OPT
+#define STRING char * NTS NONNULL
+#define STRINGBUF(n) char * NT COUNT(n) NONNULL
+
+// assert.h
+
+void __assert_fail(const STRING __assertion, const STRING __file,
+ unsigned int __line, const STRING __function);
+
+#if __GNUC__ < 4
+void __assert(const STRING what, int exp, const STRING extra);
+#endif
+
+// Darwin
+void __assert_rtn(const char * NTS, const char * NTS, int, const char * NTS);
+void __eprintf(const char * NTS, const char * NTS, unsigned, const char * NTS);
+
+// crypt.h
+
+STRING crypt(const STRING key, const char * COUNT(2) NONNULL salt);
+void setkey(STRING key);
+
+// ctype.h
+
+// gcc 3.4.4
+extern const char (COUNT(256) _ctype_)[256];
+
+// gcc 4
+const unsigned short * COUNT(256) * __ctype_b_loc();
+const signed int * COUNT(256) * __ctype_tolower_loc();
+const signed int * COUNT(256) * __ctype_toupper_loc();
+
+// fcntl.h
+
+int open(const STRING file, int mode, ...);
+int create(const STRING file, mode_t mode);
+
+// glob.h
+
+typedef struct {
+ char * NTS * COUNT(gl_pathc) NT gl_pathv;
+} glob_t;
+
+int glob(const char * NTS pattern, int flags,
+ int errfunc(const char * NTS epath, int eerrno),
+ glob_t * SAFE pglob);
+
+// grp.h
+
+struct group {
+ char * NTS NONNULL gr_name;
+ char * NTS NONNULL gr_passwd;
+ char * NTS * NTS gr_mem;
+};
+
+struct group * SAFE getgrnam(const STRING name);
+int initgroups(char * NTS __user, __gid_t __group);
+int getgrouplist(char * NTS __user, __gid_t __group, __gid_t *__groups,
+ int *__ngroups);
+
+// malloc.h
+
+void * OPT (DALLOC(size) malloc)(int size);
+void * OPT (DALLOC(nmemb * size) calloc)(size_t nmemb, size_t size);
+void * OPT (DREALLOC(p, size) realloc)(void *p, size_t size);
+void (DFREE(p) free)(void *p);
+
+// netdb.h
+
+struct hostent {
+ const char * NTS h_name;
+ char * NTS * NTS h_aliases;
+ // We ought to say h_length instead of 4 there
+ char * COUNT(4) * NTS h_addr_list;
+};
+
+struct netent {
+ char * NTS n_name;
+ char * NTS * NTS n_aliases;
+};
+
+struct servent {
+ char * NTS s_name;
+ char * NTS * NTS s_aliases;
+ char * NTS s_proto;
+};
+
+struct protoent {
+ char * NTS p_name;
+ char * NTS * NTS p_aliases;
+};
+
+struct rpcent {
+ char * NTS r_name;
+ char * NTS * NTS r_aliases;
+};
+
+struct sockaddr_un {
+ char (NT sun_path)[108];
+};
+
+struct hostent *gethostbyaddr(const void * COUNT(__len),
+ __socklen_t __len, int);
+
+int gethostbyaddr_r(void * COUNT(__len) __addr, __socklen_t __len,
+ int __type, struct hostent *__result_buf,
+ char * COUNT(__buflen) __buf, size_t __buflen,
+ struct hostent * SAFE * SAFE __result, int *__h_errnop);
+
+struct hostent *gethostbyname(const STRING);
+int gethostbyname_r(char * NTS __name, struct hostent *__result_buf,
+ char * COUNT(__buflen) __buf, size_t __buflen,
+ struct hostent * SAFE * SAFE __restrict, int *__h_errnop);
+
+struct netent *getnetbyname(const STRING);
+struct protoent *getprotobyname(const STRING);
+
+struct servent *getservbyname (const STRING, const STRING);
+struct servent *getservbyport (int, const STRING);
+
+int getservent_r(struct servent *__result_buf,
+ char * COUNT(__buflen) __buf, size_t __buflen,
+ struct servent **__result);
+
+int getservbyname_r(const STRING __name, const STRING __proto,
+ struct servent *__result_buf,
+ char * COUNT(__buflen) __buf, size_t __buflen,
+ struct servent **__result);
+
+int getservbyport_r(int __port, const STRING __proto,
+ struct servent *__result_buf,
+ char * COUNT(__buflne) __buf, size_t __buflen,
+ struct servent **__result);
+
+struct rpcent *getrpcbyname(const STRING);
+
+void herror(const STRING);
+
+int getaddrinfo(char * NTS __name, char * NTS __service,
+ struct addrinfo *__req, struct addrinfo **__pai);
+
+int getnameinfo(struct sockaddr *__sa, socklen_t __salen,
+ char * NT COUNT(__hostlen - 1) __host, socklen_t __hostlen,
+ char * NT COUNT(__servlen-1) __serv,
+ socklen_t __servlen, unsigned int __flags);
+
+// pwd.h
+
+struct passwd {
+ char * NTS NONNULL pw_name;
+ char * NTS NONNULL pw_passwd;
+ char * NTS NONNULL pw_comment;
+ char * NTS NONNULL pw_class;
+ char * NTS NONNULL pw_gecos;
+ char * NTS NONNULL pw_dir;
+ char * NTS NONNULL pw_shell;
+};
+
+struct passwd *getpwnam(const STRING);
+
+// socket.h
+
+int setsockopt(int __s, int __level, int __optname,
+ void const * COUNT(__optlen) optval, __SOCKLEN_T __optlen);
+
+// TODO: Indicate that optval is as big as *__optlen.
+// TODO: Say something about __addrlen.
+int getsockopt(int s, int level, int optname,
+ void* optval, __SOCKLEN_T * __optlen);
+int bind(int sockfd, __CONST_SOCKADDR_ARG __my_addr, __SOCKLEN_T __addrlen);
+int connect(int sockfd, __CONST_SOCKADDR_ARG __my_addr, __SOCKLEN_T __addrlen);
+int accept(int s, __SOCKADDR_ARG __peer, __SOCKLEN_T *addrlen);
+int getpeername(int s, __SOCKADDR_ARG __peer, __SOCKLEN_T *namelen);
+int getsockname(int s, __SOCKADDR_ARG name, __SOCKLEN_T *namelen);
+
+__SSIZE_T sendto(int s, const void * NONNULL COUNT(len) msg,
+ __SIZE_T len, int flags,
+ __CONST_SOCKADDR_ARG __addr, __SOCKLEN_T __addr_len);
+
+__SSIZE_T recvfrom(int s, void * NONNULL COUNT(__n) buf,
+ __SIZE_T __n, int flags,
+ __SOCKADDR_ARG __addr, __SOCKLEN_T * __addr_len);
+
+__SSIZE_T recv(int s, void * NONNULL COUNT(__n) buf,
+ __SIZE_T __n, int flags);
+
+__SSIZE_T send(int s, const void * NONNULL COUNT(__n) msg,
+ __SIZE_T __n, int flags);
+
+// stat.h
+
+int chmod(const STRING __path, __MODE_T __mode);
+int mkdir(const STRING __path, __MODE_T __mode);
+int mkfifo(const STRING __path, __MODE_T __mode);
+int stat(const STRING __path, struct stat * SAFE NONNULL __sbuf);
+
+int lstat(const STRING __path, struct stat * SAFE NONNULL __sbuf);
+int _stat(const STRING __path, struct stat * SAFE NONNULL __sbuf);
+
+int __xstat(int __ver, const STRING __path, struct stat * SAFE NONNULL __sbuff);
+int __lxstat(int __ver, const STRING __path, struct stat * SAFE NONNULL __sbuf);
+
+int mknod(const STRING __path, __MODE_T __mode, __DEV_T __dev);
+
+// stdio.h
+
+int (DPRINTF(2) fprintf) (FILE * SAFE __stream, char * NTS __format, ...);
+int (DPRINTF(1) printf) (char * NTS __format, ...);
+int (DPRINTF(2) sprintf) (char * TRUSTED __s, char * NTS __format, ...);
+int (DPRINTF(3) snprintf)(char * NT COUNT(__maxlen-1) __s, size_t __maxlen,
+ char * NTS __restrict __format, ...);
+int (DPRINTF(2) vfprintf)(FILE * SAFE __s, char * NTS __format,
+ __gnuc_va_list __arg);
+int (DPRINTF(1) vprintf) (char * NTS __format, __gnuc_va_list __arg);
+int (DPRINTF(2) vsprintf)(char * TRUSTED __s, __const char * NTS __format,
+ __gnuc_va_list __arg);
+
+int fscanf(FILE * SAFE NONNULL, const char * NTS, ...);
+int scanf(const char * NTS, ...);
+int sscanf(const char * TRUSTED, const char * NTS, ...);
+
+char * NTS fgets(char * NT COUNT(__n-1) NONNULL __s, int __n,
+ FILE * NONNULL __stream);
+
+FILE * fdopen(int filedes, const char * NTS NONNULL mode);
+
+int fputs(const char * NTS NONNULL s, FILE * SAFE NONNULL fl);
+int puts(const char* NTS NONNULL s);
+
+size_t fread(void * COUNT(_size * _n) NONNULL, size_t _size,
+ size_t _n, FILE * SAFE NONNULL);
+size_t fwrite(const void * COUNT(_size *_n) NONNULL,
+ size_t _size, size_t _n, FILE * SAFE NONNULL);
+
+extern void perror(const char * NTS NONNULL);
+
+FILE * SAFE NULLABLE fopen(const char * NTS NONNULL _name,
+ const char * NTS NONNULL _type);
+
+int fseek(FILE * SAFE NONNULL, long, int);
+
+int remove(const char * NTS NONNULL);
+int rename(const char * NTS NONNULL, const char * NTS NONNULL);
+
+// Darwin
+extern FILE (COUNT(3) __sF)[];
+
+// stdlib.h
+
+double atof(char * NTS);
+int atoi(char * NTS);
+long int atol(char * NTS);
+long long atoll(char * NTS);
+
+double __strtod_internal (char * NTS, char * NTS *, int);
+float __strtof_internal (char * NTS, char * NTS *, int);
+long double __strtold_internal(char * NTS, char * NTS *, int);
+long int __strtol_internal (char * NTS, char * NTS *, int, int);
+long long int __strtoll_internal (char * NTS, char * NTS *, int, int);
+
+double strtod(const STRING str, OPTSTRING * SAFE endptr);
+long strtol(const STRING str, OPTSTRING * SAFE endptr, int base);
+long long strtoll(const STRING str, OPTSTRING * SAFE endptr, int base);
+
+OPTSTRING getenv(const STRING str);
+int putenv(char *NTS);
+int unsetenv(char *NTS);
+
+int system(const OPTSTRING str);
+
+// string.h
+
+unsigned int strlen(const STRING s);
+
+void * (DMEMSET(1, 2, 3) memset)(void* p, int what, size_t sz);
+int (DMEMCMP(1, 2, 3) memcmp)(void* s1, void* s2, size_t sz);
+void * (DMEMCPY(1, 2, 3) memcpy)(void* dst, void* src, size_t sz);
+void * (DMEMCPY(1, 2, 3) memmove)(void *dst, void* src, size_t sz);
+
+void bzero(void * COUNT(size) buff, unsigned int size);
+
+STRING strncpy(STRINGBUF(n) dest, const STRING src, size_t n);
+STRING __builtin_strncpy(STRINGBUF(n) dest, const STRING src, size_t n);
+
+int strcmp(const STRING s1, const STRING s2);
+int __builtin_strcmp(const STRING s1, const STRING s2);
+
+int strncmp(const STRING s1, const STRING s2, size_t n);
+int __builtin_strncmp(const STRING s1, const STRING s2, size_t n);
+
+size_t strlcpy(STRINGBUF(siz-1) dst, const STRING src, size_t siz);
+
+STRING strncat(STRINGBUF(n) dest, const STRING src, size_t n);
+STRING __builtin_strncat(STRINGBUF(n) dest, const STRING src, size_t n);
+
+size_t strlcat(STRINGBUF(n-1) dest, const STRING src, size_t n);
+
+OPTSTRING strchr(const STRING s, int chr);
+OPTSTRING __builtin_strchr(const STRING s, int chr);
+
+OPTSTRING strrchr(const STRING s, int chr);
+OPTSTRING strdup(const STRING s);
+OPTSTRING __strdup(const STRING s);
+OPTSTRING strpbrk(const STRING str, const STRING accept_arg);
+OPTSTRING __builtin_strpbrk(const STRING str, const STRING accept_arg);
+OPTSTRING __strpbrk_c2 (__const STRING str, int __accept1, int __accept2);
+OPTSTRING strsep(char * NTS * NT stringp, const STRING delim);
+
+size_t strspn(const STRING str, const STRING charset);
+size_t __builtin_strspn(const STRING str, const STRING charset);
+
+size_t __strspn_c1(const STRING str, int accept1);
+size_t __strspn_c2(const STRING str, int accept1, int accept2);
+size_t __strspn_c3(const STRING str, int accept1, int accept2, int accept3);
+
+size_t strcspn(const STRING str, const STRING charset);
+size_t __builtin_strcspn(const STRING str, const STRING charset);
+
+size_t __strcspn_c1(const STRING str, int reject1);
+size_t __strcspn_c2(const STRING str, int reject1, int reject2);
+size_t __strcspn_c3(const STRING str, int reject1, int reject2, int reject3);
+
+int strcasecmp(const STRING s1, const STRING s2);
+int strncasecmp(const STRING s1, const STRING s2, size_t n);
+
+OPTSTRING strtok(OPTSTRING str, const STRING delim);
+
+OPTSTRING strerror(int errnum);
+OPTSTRING strstr(const STRING __haystack, const STRING __needle);
+
+// time.h
+
+extern STRING ctime(const time_t *timer);
+extern STRING asctime(const struct tm *timep);
+
+//similar to gethostname - null term is not guarenteed to exist
+
+size_t strftime(char * NONNULL COUNT(max) s, size_t max, const STRING format,
+ const struct tm * SAFE tm);
+
+
+// sys/uio.h
+
+struct iovec {
+ void * COUNT(iov_len) iov_base;
+ size_t iov_len;
+};
+
+int readv(int fd, const struct iovec * COUNT(__count), int __count);
+int writev(int fd, const struct iovec * COUNT(__count), int __count);
+
+// unistd.h
+
+void read (int __fd, void * COUNT(__nbytes) __buf, void __nbytes);
+void write (int __fd, const void * COUNT(__n) __buf, void __n);
+
+int access(const char * NTS path, int amode);
+int execv(const char * NTS NONNULL path, char * NTS * NTS argv);
+int execvp(const char * NTS NONNULL path, char * NTS * NTS argv);
+int execve(const char * NTS NONNULL path, char * NTS * NTS argv,
+ char * NTS * NTS envp);
+
+char * NTS getlogin(void);
+char * NTS ttyname(int filedes);
+
+int getopt(int argc, char * NTS * NT COUNT(argc) argv,
+ const char * NTS optstring);
+
+extern char *NTS optarg;
+
+char * NTS getusershell(void);
+
+int chdir(const char * NTS NONNULL);
+int unlink(const char * NTS NONNULL __path);
+int rmdir(char * NTS __path);
+
+//modified as not guarenteed to be NT
+//this function is not type-safe per se
+//We need to wrap around it
+int gethostname (char * NONNULL COUNT(__len) __name, size_t __len);
+
+int chown(char * NTS __file, __uid_t __owner, __gid_t __group);
+int link(char * NTS __from, char * NTS __to);
+int chroot(char * NTS __path);
+
+int readlink (char *NTS, char *NTS, size_t);
+
+OPTSTRING getcwd (STRINGBUF(__size) __buf, size_t __size);
+
+// reent.h
+
+#ifdef __CYGWIN__
+// Take care of the union in reent.h (on cygwin)
+// This union is not actually used, so we can use WHEN
+// clauses to enable only the used field.
+struct _reent {
+ union {
+ void _reent WHEN(1);
+ void _unused WHEN(0);
+ } _new;
+};
+#endif
+
+// siginfo.h
+
+// Trust the sigval union--there is no way to know what it is (in bits).
+typedef union TRUSTED sigval {
+ int sival_int;
+ void *sival_ptr;
+} sigval_t;
+
+#define SIGILL 4
+#define SIGBUS 7
+#define SIGFPE 8
+#define SIGKILL 9
+#define SIGSEGV 11
+#define SIGALRM 14
+#define SIGCHLD 17
+#define SIGPOLL SIGIO
+#define SIGIO 29
+
+struct siginfo {
+ union {
+ void _kill WHEN(si_signo == SIGKILL);
+ void _timer WHEN(si_signo == SIGALRM);
+ void _rt WHEN(0); // TODO: When is this used?
+ void _sigchld WHEN(si_signo == SIGCHLD);
+ void _sigfault WHEN(si_signo == SIGILL || si_signo == SIGFPE ||
+ si_signo == SIGSEGV || si_signo == SIGBUS);
+ void _sigpoll WHEN(si_signo == SIGPOLL);
+ } _sifields;
+};
+
+// sigaction.h
+
+#define SA_SIGINFO 4
+
+typedef void __sighandler_t;
+typedef void siginfo_t;
+
+struct sigaction {
+ union {
+ /* Used if SA_SIGINFO is not set. */
+ __sighandler_t sa_handler
+ WHEN (!(sa_flags & SA_SIGINFO));
+ /* Used if SA_SIGINFO is set. */
+ void (*sa_sigaction)(int, siginfo_t *, void *)
+ WHEN(sa_flags & SA_SIGINFO);
+ } __sigaction_handler;
+};
+
+// syslog.h
+
+void openlog(char *NTS, int, int);
+void syslog(int, char * NTS, ...);
+
+// resolv.h
+
+struct __res_state {
+ char *NTS (NT dnsrch)[0];
+ char (NT defdname)[0];
+ union {
+ void pad WHEN(0);
+ void _ext WHEN(1);
+ } _u;
+};
+
+// sys/utsname.h
+
+struct utsname {
+ char (NT sysname)[0];
+ char (NT nodename)[0];
+ char (NT release)[0];
+ char (NT version)[0];
+ char (NT machine)[0];
+ char (NT domainname)[0];
+ char (NT __domainname)[0];
+};
+
+// net/if.h
+
+struct ifreq {
+ union {
+ char (NT ifrn_name)[0];
+ } ifr_ifrn;
+ union TRUSTED {
+ } ifr_ifru;
+};
+
+struct ifconf {
+ union TRUSTED {
+ char * NTS ifcu_buf;
+ } ifc_ifcu;
+};
+
+// sys/statfs.h
+
+int statvfs(char * NTS, struct statvfs *);
+int statvfs64(char * NTS, struct statvfs64 *);
+int statfs(char * NTS, struct statfs *);
+int statfs64(char * NTS, struct statfs64 *);
+
+// db.h
+
+typedef void DB_ENV;
+typedef void DB_INFO;
+typedef void DBTYPE;
+typedef void DB;
+typedef unsigned int u_int32_t;
+
+int db_appinit(const char * NTS, char * NTS const *, DB_ENV *, u_int32_t);
+int db_appexit(DB_ENV *);
+int db_jump_set(void *, int);
+int db_open(const char * NTS, DBTYPE, u_int32_t, int,
+ DB_ENV *, DB_INFO *, DB **);
+int db_value_set(int, int);
+char *db_version(int *, int *, int *);
+int db_xa_open(const char * NTS, DBTYPE, u_int32_t, int, DB_INFO *, DB **);
+
+// dirent.h
+
+struct dirent {
+ char (NT d_name)[256];
+};
+
+struct dirent64 {
+ char (NT d_name)[256];
+};
+
+DIR *opendir(char * NTS);
--- /dev/null
+#!/bin/sh
+#
+# install - install a program, script, or datafile
+# This comes from X11R5 (mit/util/scripts/install.sh).
+#
+# Copyright 1991 by the Massachusetts Institute of Technology
+#
+# Permission to use, copy, modify, distribute, and sell this software and its
+# documentation for any purpose is hereby granted without fee, provided that
+# the above copyright notice appear in all copies and that both that
+# copyright notice and this permission notice appear in supporting
+# documentation, and that the name of M.I.T. not be used in advertising or
+# publicity pertaining to distribution of the software without specific,
+# written prior permission. M.I.T. makes no representations about the
+# suitability of this software for any purpose. It is provided "as is"
+# without express or implied warranty.
+#
+# Calling this script install-sh is preferred over install.sh, to prevent
+# `make' implicit rules from creating a file called install from it
+# when there is no Makefile.
+#
+# This script is compatible with the BSD install script, but was written
+# from scratch. It can only install one file at a time, a restriction
+# shared with many OS's install programs.
+
+
+# set DOITPROG to echo to test this script
+
+# Don't use :- since 4.3BSD and earlier shells don't like it.
+doit="${DOITPROG-}"
+
+
+# put in absolute paths if you don't have them in your path; or use env. vars.
+
+mvprog="${MVPROG-mv}"
+cpprog="${CPPROG-cp}"
+chmodprog="${CHMODPROG-chmod}"
+chownprog="${CHOWNPROG-chown}"
+chgrpprog="${CHGRPPROG-chgrp}"
+stripprog="${STRIPPROG-strip}"
+rmprog="${RMPROG-rm}"
+mkdirprog="${MKDIRPROG-mkdir}"
+
+transformbasename=""
+transform_arg=""
+instcmd="$mvprog"
+chmodcmd="$chmodprog 0755"
+chowncmd=""
+chgrpcmd=""
+stripcmd=""
+rmcmd="$rmprog -f"
+mvcmd="$mvprog"
+src=""
+dst=""
+dir_arg=""
+
+while [ x"$1" != x ]; do
+ case $1 in
+ -c) instcmd="$cpprog"
+ shift
+ continue;;
+
+ -d) dir_arg=true
+ shift
+ continue;;
+
+ -m) chmodcmd="$chmodprog $2"
+ shift
+ shift
+ continue;;
+
+ -o) chowncmd="$chownprog $2"
+ shift
+ shift
+ continue;;
+
+ -g) chgrpcmd="$chgrpprog $2"
+ shift
+ shift
+ continue;;
+
+ -s) stripcmd="$stripprog"
+ shift
+ continue;;
+
+ -t=*) transformarg=`echo $1 | sed 's/-t=//'`
+ shift
+ continue;;
+
+ -b=*) transformbasename=`echo $1 | sed 's/-b=//'`
+ shift
+ continue;;
+
+ *) if [ x"$src" = x ]
+ then
+ src=$1
+ else
+ # this colon is to work around a 386BSD /bin/sh bug
+ :
+ dst=$1
+ fi
+ shift
+ continue;;
+ esac
+done
+
+if [ x"$src" = x ]
+then
+ echo "install: no input file specified"
+ exit 1
+else
+ true
+fi
+
+if [ x"$dir_arg" != x ]; then
+ dst=$src
+ src=""
+
+ if [ -d $dst ]; then
+ instcmd=:
+ chmodcmd=""
+ else
+ instcmd=mkdir
+ fi
+else
+
+# Waiting for this to be detected by the "$instcmd $src $dsttmp" command
+# might cause directories to be created, which would be especially bad
+# if $src (and thus $dsttmp) contains '*'.
+
+ if [ -f $src -o -d $src ]
+ then
+ true
+ else
+ echo "install: $src does not exist"
+ exit 1
+ fi
+
+ if [ x"$dst" = x ]
+ then
+ echo "install: no destination specified"
+ exit 1
+ else
+ true
+ fi
+
+# If destination is a directory, append the input filename; if your system
+# does not like double slashes in filenames, you may need to add some logic
+
+ if [ -d $dst ]
+ then
+ dst="$dst"/`basename $src`
+ else
+ true
+ fi
+fi
+
+## this sed command emulates the dirname command
+dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'`
+
+# Make sure that the destination directory exists.
+# this part is taken from Noah Friedman's mkinstalldirs script
+
+# Skip lots of stat calls in the usual case.
+if [ ! -d "$dstdir" ]; then
+defaultIFS='
+'
+IFS="${IFS-${defaultIFS}}"
+
+oIFS="${IFS}"
+# Some sh's can't handle IFS=/ for some reason.
+IFS='%'
+set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'`
+IFS="${oIFS}"
+
+pathcomp=''
+
+while [ $# -ne 0 ] ; do
+ pathcomp="${pathcomp}${1}"
+ shift
+
+ if [ ! -d "${pathcomp}" ] ;
+ then
+ $mkdirprog "${pathcomp}"
+ else
+ true
+ fi
+
+ pathcomp="${pathcomp}/"
+done
+fi
+
+if [ x"$dir_arg" != x ]
+then
+ $doit $instcmd $dst &&
+
+ if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi &&
+ if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi &&
+ if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi &&
+ if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi
+else
+
+# If we're going to rename the final executable, determine the name now.
+
+ if [ x"$transformarg" = x ]
+ then
+ dstfile=`basename $dst`
+ else
+ dstfile=`basename $dst $transformbasename |
+ sed $transformarg`$transformbasename
+ fi
+
+# don't allow the sed command to completely eliminate the filename
+
+ if [ x"$dstfile" = x ]
+ then
+ dstfile=`basename $dst`
+ else
+ true
+ fi
+
+# Make a temp file name in the proper directory.
+
+ dsttmp=$dstdir/#inst.$$#
+
+# Move or copy the file name to the temp name
+
+ $doit $instcmd $src $dsttmp &&
+
+ trap "rm -f ${dsttmp}" 0 &&
+
+# and set any options; do chmod last to preserve setuid bits
+
+# If any of these fail, we abort the whole thing. If we want to
+# ignore errors from any of these, just make sure not to ignore
+# errors from the above "$doit $instcmd $src $dsttmp" command.
+
+ if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi &&
+ if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi &&
+ if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi &&
+ if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi &&
+
+# Now rename the file to the real destination.
+
+ $doit $rmcmd -f $dstdir/$dstfile &&
+ $doit $mvcmd $dsttmp $dstdir/$dstfile
+
+fi &&
+
+
+exit 0
--- /dev/null
+#
+#
+# Copyright (c) 2001-2002,
+# George C. Necula <necula@cs.berkeley.edu>
+# Scott McPeak <smcpeak@cs.berkeley.edu>
+# Wes Weimer <weimer@cs.berkeley.edu>
+# 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 package is used from an environment when CilConfig.pm has been loaded
+package Deputy;
+use strict;
+
+use Cilly;
+
+# NOTE: If perl chokes, complaining about 'our', or
+# "Array found where operator expected", it's because
+# you need perl version 5.6.0 or later.
+our @ISA = qw(Cilly);
+
+sub new {
+ my ($proto, @args) = @_;
+ my $class = ref($proto) || $proto;
+ my $self = Cilly->new(@args);
+
+ # Select the directory containing Deputy's executables. We look in
+ # both places in order to accomodate the build and distribution
+ # directory layouts.
+ my $bin;
+ my $lib;
+ if (-x "$::deputyhome/obj/$::archos/deputy.asm.exe") {
+ $bin = "$::deputyhome/obj/$::archos";
+ $lib = "$::deputyhome/obj/$::archos";
+ } elsif (-x "$::deputyhome/bin/deputy.asm.exe") {
+ $bin = "$::deputyhome/bin";
+ $lib = "$::deputyhome/lib";
+ } else {
+ die "Couldn't find directory containing Deputy executables.\n" .
+ "Please ensure that Deputy is compiled and installed properly.\n";
+ }
+
+ # Select the most recent executable
+ my $mtime_asm = int((stat("$bin/deputy.asm.exe"))[9]);
+ my $mtime_byte = int((stat("$bin/deputy.byte.exe"))[9]);
+ my $use_debug =
+ grep(/--bytecode/, @args) ||
+ grep(/--ocamldebug/, @args) ||
+ ($mtime_asm < $mtime_byte);
+ if ($use_debug) {
+ $ENV{"OCAMLRUNPARAM"} = "b" . $ENV{"OCAMLRUNPARAM"}; # Print back trace
+ }
+
+ # New variables for Deputy
+ $self->{COMPILER} = "$bin/deputy" . ($use_debug ? ".byte.exe" : ".asm.exe");
+ $self->{LIBBASE} = $lib;
+
+ # Override Cilly's default
+ $self->{SEPARATE} = 1;
+
+ bless $self, $class;
+}
+
+# Use the debug library if necessary
+sub deputyLib {
+ my ($self) = @_;
+ return ("$self->{LIBBASE}/deputy_" .
+ ($self->{LINUX} ? "linux" : "libc") .
+ ".$self->{OBJEXT}");
+}
+
+sub instrLib {
+ my ($self) = @_;
+ return ("$::deputyhome/lib/lwcalls.mlb",
+ "$self->{LIBBASE}/instr_glob_state.$self->{OBJEXT}")
+}
+
+sub instrLink {
+ my ($self) = @_;
+ return ("-lm","-lcurses","-lpthread");
+}
+
+sub setDefaultArguments {
+ my ($self) = @_;
+ $self->{TRACE_COMMANDS} = 0;
+ return $self->SUPER::setDefaultArguments;
+}
+
+sub collectOneArgument {
+ my ($self, $arg, $pargs) = @_;
+ my $res = 1;
+ if ($self->compilerArgument($self->{OPTIONS}, $arg, $pargs)) {
+ # do nothing
+ } elsif ($arg eq "--help" || $arg eq "-help") {
+ $self->printVersion();
+ $self->printHelp();
+ exit 0;
+ } elsif ($arg eq "--version" || $arg eq "-version") {
+ $self->printVersion();
+ exit 0;
+ } elsif ($arg eq "--linux") {
+ $self->{LINUX} = 1;
+ } elsif ($arg eq "--trace") {
+ $self->{TRACE_COMMANDS} = 1;
+ } elsif ($arg eq "--nolib") {
+ $self->{NOLIB} = 1;
+ } elsif ($arg eq "--bytecode") {
+ $self->{NATIVECAML} = 0;
+ } elsif ($arg =~ m|--save-temps=(.+)$|) {
+ if (! -d $1) {
+ die "Cannot find directory $1";
+ }
+ $self->{SAVE_TEMPS} = $1;
+ } elsif ($arg eq '--save-temps') {
+ $self->{SAVE_TEMPS} = '.';
+ } elsif ($arg =~ m|--includedir=(.+)$|) {
+ push @{$self->{INCLUDEDIR}}, $1;
+ } elsif ($arg =~ m|^--out=(\S+)$|) {
+ # Intercept the --out argument
+ $self->{CILLY_OUT} = $1;
+ push @{$self->{CILARGS}}, "--out", $1;
+ } elsif ($arg eq "--instrument") {
+ $self->{INSTRUMENT} = 1;
+ push @{$self->{CILARGS}}, "--instrument";
+ } elsif ($arg =~ m|^--|) {
+ # All other arguments starting with -- are passed to CIL
+ # Split the ==
+ if ($arg =~ m|^(--\S+)=(.+)$|) {
+ push @{$self->{CILARGS}}, $1, $2;
+ } else {
+ push @{$self->{CILARGS}}, $arg;
+ }
+ } else {
+ # We fail!
+ $res = 0;
+ }
+ return $res;
+}
+
+sub preprocess_before_cil {
+ my($self, $src, $dest, $ppargs) = @_;
+ my @args = @{$ppargs};
+ unshift @args,
+ $self->forceIncludeArg("$::deputyhome/include/deputy/annots.h");
+ unshift @args, $self->{INCARG} . $::deputyhome . "/include";
+ return $self->SUPER::preprocess_before_cil($src, $dest, \@args);
+}
+
+
+## We do not preprocess after CIL, to save time and files
+sub preprocessAfterOutputFile {
+ my ($self, $src) = @_;
+ return $src; # Do not preprocess after CIL
+}
+
+sub preprocess_after_cil {
+ my ($self, $src, $dest, $ppargs) = @_;
+ if($src ne $dest) { die "I thought we are not preprocessing after CIL";}
+ return $dest;
+}
+
+sub compile_cil {
+ my ($self, $src, $dest, $ppargs, $ccargs) = @_;
+ my @args = @{$ppargs};
+ push @args, "$self->{INCARG}$::deputyhome/include";
+ return $self->SUPER::compile_cil($src, $dest, \@args, $ccargs);
+}
+
+
+sub link_after_cil {
+ my ($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_;
+ my @srcs = @{$psrcs};
+ my @libs = @{$ldargs};
+ my @cargs = @{$ccargs};
+ my ($instrlibs, $instrcargs);
+ if (scalar @srcs == 0) {
+ print STDERR "deputy: no input files\n";
+ return 0;
+ } else {
+ push @srcs, $self->deputyLib() unless $self->{NOLIB};
+ #push @srcs, $self->instrLib() unless $self->{INSTRUMENT} != 1;
+ #push @libs, $self->instrLink() unless $self->{INSTRUMENT} != 1;
+ if ($self->{INSTRUMENT} == 1) {
+ $self->{LD} = ['mlton','-profile','alloc','-runtime','max-heap 1.5g','-runtime','gc-summary','-default-ann',"allowFFI true"];
+ $self->{OUTEXE} = '-output';
+ push @{$ccargs},("-I /usr/local/include","-I /usr/local/include/oct");
+ push @libs, ("-lgmp","-loct_iag");
+ unshift @srcs, $self->instrLib();
+ if (scalar @{$ppargs} != 0 || scalar @{$ccargs} != 0) {
+ $instrcargs = join(" ",@{$ppargs},@{$ccargs});
+ #$instrcargs = join(" ","-cc-opt","\"$instrcargs\"");
+ @cargs = ("-cc-opt",$instrcargs);
+ }
+ if (scalar @libs != 0) {
+ $instrlibs = join(" ",@libs);
+ #$instrlibs = join(" ","-link-opt","\"$instrlibs\"");
+ push @cargs, ("-link-opt",$instrlibs);
+ @libs = ();
+ }
+ $ppargs = [];
+ }
+ return $self->SUPER::link_after_cil(\@srcs, $dest, $ppargs,
+ \@cargs, \@libs);
+ }
+}
+
+sub linktolib {
+ my ($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_;
+ my @srcs = @{$psrcs};
+ if (scalar @srcs == 0) {
+ print STDERR "deputy: no input files\n";
+ return 0;
+ } else {
+ push @srcs, $self->deputyLib() unless $self->{NOLIB};
+ return $self->SUPER::linktolib(\@srcs, $dest, $ppargs,
+ $ccargs, $ldargs);
+ }
+}
+
+sub CillyCommand {
+ my ($self, $ppsrc, $dest) = @_;
+
+ my @cmd = ($self->{COMPILER});
+ my $aftercil = $self->cilOutputFile($dest, 'cil.c');
+ return ($aftercil, @cmd, '--out', $aftercil);
+}
+
+sub printVersion {
+ #system ($self->{COMPILER}, '--version');
+}
+
+sub printHelp {
+ my ($self) = @_;
+ my @cmd = ($self->{COMPILER}, '-help');
+ $self->runShell(@cmd);
+ print <<EOF;
+
+Front end:
+
+ --linux Use the Linux runtime library.
+ --trace Print commands invoked by the front end.
+ --nolib Don't link the runtime library.
+ --bytecode Use the bytecode version of Deputy.
+ --save-temps Save intermediate files (target directory optional).
+ --includedir Add the specified directory to the beginning of
+ the include path.
+EOF
+}
+
+1;
--- /dev/null
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#ifdef _GNUCC
+ #include <unistd.h> /* sleep, getpid */
+#endif
+
+#define IN_DEPUTY_LIBRARY
+
+#include "deputy/checks.h"
+
+// If Deputy fails, it checks to see if you have specified special handling
+// for failed checks.
+enum handlerKind {
+ HANDLE_DEFAULT, // no handler specified
+ HANDLE_IGNORE, // ignore
+ HANDLE_STOP, // warn and stop
+ HANDLE_WARN, // warn but do not stop
+ HANDLE_SLEEP, // sleep and wait for the the debugger
+};
+
+static enum handlerKind deputyErrorHandler = HANDLE_DEFAULT;
+
+static int deputyInited = 0;
+static void deputyInitOnFirstFailure(void) {
+ // Cache the result of environment lookup
+ char *onerror = getenv("DEPUTY_ONERROR");
+ deputyErrorHandler = HANDLE_DEFAULT;
+ if (onerror) {
+ if (!strcasecmp(onerror, "stop")) {
+ deputyErrorHandler = HANDLE_STOP;
+ } else if (!strcasecmp(onerror, "ignore")) {
+ deputyErrorHandler = HANDLE_IGNORE;
+ } else if (!strcasecmp(onerror, "warn")) {
+ deputyErrorHandler = HANDLE_WARN;
+ } else if (!strcasecmp(onerror, "sleep")) {
+ deputyErrorHandler = HANDLE_SLEEP;
+ } else {
+ fprintf(stderr, "Unexpected value for env var DEPUTY_ONERROR\n");
+ }
+ }
+}
+
+// This function is called directly from the checks unless the code was
+// compiled with --deputyAlwaysStopOnError . It is also called from
+// deputy_fail_noreturn to do the real work.
+asmlinkage
+void deputy_fail_mayreturn(const char *check, const char *text,
+ __LOCATION__FORMALS) {
+ if (!deputyInited) {
+ deputyInitOnFirstFailure(); deputyInited = 1;
+ }
+ if (deputyErrorHandler != HANDLE_IGNORE) {
+ fprintf(stderr, "%s:%d: %s: Assertion failed in %s:\n %s\n",
+ __LOCATION__ACTUALS, check, text);
+ }
+ // Now look whether we should return or not
+ switch (deputyErrorHandler) {
+ case HANDLE_DEFAULT:
+ case HANDLE_STOP:
+ fprintf(stderr, "Execution aborted.\n");
+ exit(1);
+ case HANDLE_SLEEP:
+#if defined(_MSVC)
+ // On Windows, this will fire the just-in-time debugger.
+ _asm { int 3 }
+#else
+ // Pause for debugging multithreaded code.
+ // (Trick due to Ben Liblit, via Dan Wilkerson.)
+ {
+ volatile int stopped = 1;
+
+ fprintf(stderr, "Execution paused for debugging (pid = %d).\n",
+ getpid());
+ fflush(stderr);
+
+ while (stopped) {
+ // 1. Execution will stop here.
+ sleep(1);
+ }
+
+ // 2. Set breakpoint here, and set stopped to 0.
+ // (This statement exists so we have a place to put
+ // that breakpoint.)
+ stopped ++;
+ }
+#endif
+ break;
+ default:
+ break;
+ }
+}
+
+// This function must NOT return. This is the function that is called
+// by the checks if we compiled with --alwaysStopOnError
+asmlinkage noreturn
+void deputy_fail_noreturn(const char *check, const char *text,
+ __LOCATION__FORMALS) {
+ deputy_fail_mayreturn(check, text, __LOCATION__ACTUALS);
+ fprintf(stderr, "Deputy check failed; execution aborted.\n");
+ exit(1);
+}
+
+// This function must NOT return. This is the function that is called
+// by the checks if we compiled with --alwaysStopOnError and --deputyFastChecks
+asmlinkage noreturn
+void deputy_fail_noreturn_fast(void) {
+ fprintf(stderr, "Deputy check failed; execution aborted.\n");
+ fprintf(stderr, "Detailed error report suppressed (--deputyFastChecks).\n");
+ exit(1);
+}
+
+/* Search for a NULL starting at e and return its index */
+asmlinkage
+int deputy_findnull(const void *e, unsigned int bytes) {
+#define NULLCHECK(type) \
+ do { \
+ type *p = (type*) e; \
+ while (*p != 0) { \
+ p++; \
+ } \
+ length = (p - (type*) e); \
+ } while (0)
+
+ int length = 0;
+
+ switch (bytes) {
+ case 1:
+ NULLCHECK(char);
+ break;
+ case 2:
+ NULLCHECK(short);
+ break;
+ case 4:
+ NULLCHECK(long);
+ break;
+ default:
+ fprintf(stderr, "Invalid byte size for nullcheck.\n");
+ exit(1);
+ }
+
+ return length;
+#undef NULLCHECK
+}
+
+asmlinkage
+void *__deputy_memset(void *s, int c, unsigned int n) {
+ return memset(s, c, n);
+}
--- /dev/null
+#include <linux/config.h> /* has to be first! */
+#include <linux/init.h>
+#include <linux/module.h>
+#ifdef CONFIG_KRECOVER
+#include <linux/krecover.h>
+#endif
+
+#define IN_DEPUTY_LIBRARY
+
+#include "deputy/checks.h"
+
+asmlinkage
+void deputy_fail_mayreturn(const char *check, const char *text,
+ __LOCATION__FORMALS) {
+ printk(KERN_ALERT
+ "%s:%d: %s: Assertion failed in %s: %s\n",
+ __LOCATION__ACTUALS, check, text);
+ dump_stack();
+#ifdef CONFIG_KRECOVER
+ /* This will trigger real krecover recovery */
+ if (kr_recovery_enabled)
+ kr_trigger_fault();
+#endif
+}
+
+asmlinkage noreturn
+void deputy_fail_noreturn_fast(void) {
+ panic("Deputy assertion failure\n");
+}
+
+int deputy_strlen(const char *str) {
+ return strlen(str);
+}
+
+char *deputy_strcpy(char *dest, const char *src) {
+ char *tmp = dest;
+ while ((*dest++ = *src++) != '\0') {
+ // do nothing
+ }
+ return tmp;
+}
+
+char *deputy_strncpy(char *dest, const char *src, size_t count) {
+ char *tmp = dest;
+ int c = count;
+ while (c >= 0) {
+ if ((*tmp = *src) != 0) src++;
+ tmp++;
+ c--;
+ }
+ return dest;
+}
+
+/* Search for a NULL starting at e and return its index */
+int deputy_findnull(const void *e, unsigned int bytes) {
+#define NULLCHECK(type) \
+ do { \
+ type *p = (type*) e; \
+ while (*p != 0) { \
+ p++; \
+ } \
+ length = (p - (type*) e); \
+ } while (0)
+
+ int length = 0;
+
+ switch (bytes) {
+ case 1:
+ NULLCHECK(char);
+ break;
+ case 2:
+ NULLCHECK(short);
+ break;
+ case 4:
+ NULLCHECK(long);
+ break;
+ default:
+ printk(KERN_ALERT "Invalid byte size for nullcheck.\n");
+ break;
+ }
+
+ return length;
+#undef NULLCHECK
+}
+
+void *__deputy_memset(void *s, int c, unsigned int n) {
+ return memset(s, c, n);
+}
--- /dev/null
+/*
+ * instr_glob_state.c
+ *
+ * global state for the instrumenter.
+ *
+ */
+
+#define IN_GLOB_STATE_C
+
+#include <oct/oct.h>
+#include <deputy/sml_instrumenter.h>
+
+struct funInstrList fil;
+
+#define CAST(t,sz,e) ((t) == 0 ? ((sz) == 8 ? ((unsigned char)e) :\
+ ((sz) == -8 ? ((char)e) :\
+ ((sz) == 16 ? ((unsigned short)e) :\
+ ((sz) == -16 ? ((short)e) :\
+ ((sz) == 32 ? ((unsigned int)e) :\
+ ((sz) == -32 ? ((int)e) :\
+ ((sz) == 64 ? ((unsigned long long)e) :\
+ ((sz) == -64 ? ((long long)e) : (e))))))))) :\
+ (e))
+
+#define SCALE(sz,e) ((sz)*(e))
+
+unsigned int
+c_eval_bop(unsigned int bop,
+ unsigned int o1, unsigned int t1, unsigned int sz1,
+ unsigned int o2, unsigned int t2, unsigned int sz2)
+{
+ switch(bop) {
+ case BOP_PLUSA: return CAST(t1,sz1,o1) + CAST(t2,sz2,o2);
+ case BOP_PLUSPI: return o1 + SCALE(sz1,CAST(t2,sz2,o2));
+ case BOP_INDEXPI: return o1 + SCALE(sz1,CAST(t2,sz2,o2));
+ case BOP_MINUSA: return CAST(t1,sz1,o1) - CAST(t2,sz2,o2);
+ case BOP_MINUSPI: return o1 - SCALE(sz1,CAST(t2,sz2,o2));
+ case BOP_MINUSPP: return o1 - o2;
+ case BOP_MULT: return CAST(t1,sz1,o1) * CAST(t2,sz2,o2);
+ case BOP_DIV: return CAST(t1,sz1,o1) / CAST(t2,sz2,o2);
+ case BOP_MOD: return CAST(t1,sz1,o1) % CAST(t2,sz2,o2);
+ case BOP_SHIFTL: return CAST(t1,sz1,o1) << CAST(t2,sz2,o2);
+ case BOP_SHIFTR: return CAST(t1,sz1,o1) >> CAST(t2,sz2,o2);
+ case BOP_LT: return CAST(t1,sz1,o1) < CAST(t2,sz2,o2);
+ case BOP_GT: return CAST(t1,sz1,o1) > CAST(t2,sz2,o2);
+ case BOP_LE: return CAST(t1,sz1,o1) <= CAST(t2,sz2,o2);
+ case BOP_GE: return CAST(t1,sz1,o1) >= CAST(t2,sz2,o2);
+ case BOP_EQ: return CAST(t1,sz1,o1) == CAST(t2,sz2,o2);
+ case BOP_NE: return CAST(t1,sz1,o1) != CAST(t2,sz2,o2);
+ case BOP_BAND: return CAST(t1,sz1,o1) & CAST(t2,sz2,o2);
+ case BOP_BXOR: return CAST(t1,sz1,o1) ^ CAST(t2,sz2,o2);
+ case BOP_BOR: return CAST(t1,sz1,o1) | CAST(t2,sz2,o2);
+ case BOP_LAND: return CAST(t1,sz1,o1) && CAST(t2,sz2,o2);
+ case BOP_LOR: return CAST(t1,sz1,o1) || CAST(t2,sz2,o2);
+ default: return -1;
+ }
+}
+
+unsigned int
+c_eval_uop(unsigned int uop, unsigned int op, unsigned int t, unsigned int sz)
+{
+ switch(uop) {
+ case UOP_NEG: return -CAST(t,sz,op);
+ case UOP_BNOT: return ~CAST(t,sz,op);
+ case UOP_LNOT: return !CAST(t,sz,op);
+ default: return -1;
+ }
+}
+
+unsigned int
+c_int32_hash(unsigned int w, unsigned int mask)
+{
+ w = (w+0x7ed55d16) + (w<<12);
+ w = (w^0xc761c23c) ^ (w>>19);
+ w = (w+0x165667b1) + (w<<5);
+ w = (w+0xd3a2646c) ^ (w<<9);
+ w = (w+0xfd7046c5) + (w<<3);
+ w = (w^0xb55a4f09) ^ (w>>16);
+ return w & mask;
+}
+
+void
+c_print_loc(const char *file, unsigned int line)
+{
+ printf("%s:%d",file,line);
+ fflush((void *)0);
+ return;
+}
+
+/* From here down are wrappers for Mine's octagon library */
+
+int c_oct_init() {return oct_init();}
+oct_t *c_oct_empty(unsigned int n) {return oct_empty(n);}
+oct_t *c_oct_universe(unsigned int n) {return oct_universe(n);}
+oct_t *c_oct_copy(oct_t *o) {return oct_copy(o);}
+void c_oct_print(oct_t *o) {oct_print(o);return;}
+void c_oct_free(oct_t *o) {oct_free(o);return;}
+unsigned int c_oct_dimension(oct_t *o) {return oct_dimension(o);}
+unsigned int c_oct_is_empty(oct_t *o) {return oct_is_empty(o);}
+unsigned int c_oct_is_universe(oct_t *o) {return oct_is_universe(o);}
+unsigned int c_oct_is_included_in(oct_t *o1, oct_t *o2)
+ {return oct_is_included_in(o1,o2);}
+unsigned int c_oct_is_equal(oct_t *o1, oct_t *o2)
+ {return oct_is_equal(o1,o2);}
+
+oct_t *c_oct_add_constraint(oct_t *o, unsigned int *coefs, unsigned int nb)
+{
+ int i;
+ oct_t *newo;
+
+ num_t *ncs = new_n(num_t,nb);
+ num_init_n(ncs,nb);
+
+ for (i = 0; i < nb; i++) {
+ num_set_int(&ncs[i],coefs[i]);
+ }
+
+ newo = oct_add_constraint(o, ncs, true);
+ oct_mm_free(ncs);
+
+ return newo;
+}
+
+void c_oct_get_box(oct_t *o, int *box, int *valid)
+{
+ int i;
+ int dim = oct_dimension(o);
+ num_t *nbox = oct_get_box(o);
+
+ if (!nbox) {
+ for (i = 0; i < 2 * dim; i++)
+ valid[i] = 0;
+ return;
+ }
+
+ for (i = 0; i < 2 * dim; i++) {
+ if (num_fits_int(&nbox[i])) {
+ box[i] = num_get_int(&nbox[i]);
+ valid[i] = 1;
+ }
+ else
+ valid[i] = 0;
+ }
+
+ oct_mm_free(nbox);
+ return;
+}
+
+oct_t *c_oct_add_dimension(oct_t *o, unsigned int num)
+{
+ return oct_add_dimensions_and_embed(o, num, true);
+}
+
+
+#undef IN_GLOB_STATE_C
--- /dev/null
+(*
+ * This is an SML backend for Deputy instrumentation
+ *
+ * lwcalls.sml
+ *
+ *
+ *
+ *)
+
+structure IHT = IntHashTable
+structure HT = HashTable
+
+
+(* Interval Map for storing taint data *)
+fun interval_compare (lo1,hi1,_) (lo2,hi2,_) =
+ if Word.<(hi1,lo2) then LESS else
+ if Word.<(hi2,lo1) then GREATER else
+ EQUAL
+
+structure IntervalMap = RedBlackMapFn (
+ struct
+ type ord_key = word * word
+ fun compare((lo1,hi1),(lo2,hi2)) =
+ interval_compare (lo1,hi1,0wx0) (lo2,hi2,0wx0)
+ end)
+
+structure LocationSet = RedBlackSetFn (
+ struct
+ type ord_key = word * word
+ fun compare((f1:word,l1:word),(f2:word,l2:word)) =
+ if f1 < f2 orelse (f1 = f2 andalso l1 < l2) then LESS else
+ if f2 < f1 orelse (f1 = f2 andalso l2 < l2) then GREATER else
+ EQUAL
+ end)
+
+(* Expression tree data structures *)
+datatype uop =
+ Neg
+ | BNot
+ | LNot
+ | UKUop
+
+datatype bop =
+ PlusA
+ | PlusPI
+ | IndexPI
+ | MinusA
+ | MinusPI
+ | MinusPP
+ | Mult
+ | Div
+ | Mod
+ | ShiftL
+ | ShiftR
+ | Lt
+ | Gt
+ | Le
+ | Ge
+ | Eq
+ | Ne
+ | BAnd
+ | BXor
+ | BOr
+ | LAnd
+ | LOr
+ | UKBop
+
+
+fun bopToWord (b : bop) : word = case b of
+ PlusA => Word.fromInt 0
+ | PlusPI => Word.fromInt 1
+ | IndexPI => Word.fromInt 2
+ | MinusA => Word.fromInt 3
+ | MinusPI => Word.fromInt 4
+ | MinusPP => Word.fromInt 5
+ | Mult => Word.fromInt 6
+ | Div => Word.fromInt 7
+ | Mod => Word.fromInt 8
+ | ShiftL => Word.fromInt 9
+ | ShiftR => Word.fromInt 10
+ | Lt => Word.fromInt 11
+ | Gt => Word.fromInt 12
+ | Le => Word.fromInt 13
+ | Ge => Word.fromInt 14
+ | Eq => Word.fromInt 15
+ | Ne => Word.fromInt 16
+ | BAnd => Word.fromInt 17
+ | BXor => Word.fromInt 18
+ | BOr => Word.fromInt 19
+ | LAnd => Word.fromInt 20
+ | LOr => Word.fromInt 21
+ | UKBop => Word.fromInt 37
+
+fun bop_eq (b1 : bop) (b2 : bop) : bool =
+ (bopToWord b1) = (bopToWord b2)
+
+fun bopToString (b : bop) : string = case b of
+ PlusA => "+"
+ | PlusPI => "+"
+ | IndexPI => "+"
+ | MinusA => "-"
+ | MinusPI => "-"
+ | MinusPP => "-"
+ | Mult => "*"
+ | Div => "/"
+ | Mod => "%"
+ | ShiftL => "<<"
+ | ShiftR => ">>"
+ | Lt => "<"
+ | Gt => ">"
+ | Le => "<="
+ | Ge => ">="
+ | Eq => "=="
+ | Ne => "!="
+ | BAnd => "&"
+ | BXor => "^"
+ | BOr => "|"
+ | LAnd => "&&"
+ | LOr => "||"
+ | UKBop => "??"
+
+fun print_bop (b : bop) : unit =
+ print(bopToString b)
+
+fun negate_bop (b : bop) : bop = case b of
+ Lt => Ge
+ | Gt => Le
+ | Le => Gt
+ | Ge => Lt
+ | Eq => Ne
+ | Ne => Eq
+ | _ => b
+
+fun wordToUop (w : word) : uop = case (Word.toInt w) of
+ 0 => Neg
+ | 1 => BNot
+ | 2 => LNot
+ | _ => UKUop
+
+fun uopToWord (u : uop) : word = case u of
+ Neg => Word.fromInt 0
+ | BNot => Word.fromInt 1
+ | LNot => Word.fromInt 2
+ | UKUop => Word.fromInt 37
+
+fun uop_eq (u1 : uop) (u2 : uop) : bool =
+ (uopToWord u1) = (uopToWord u2)
+
+fun uopToString (u : uop) : string = case u of
+ Neg => "-"
+ | BNot => "~"
+ | LNot => "!"
+ | UKUop => "??"
+
+fun print_uop (u : uop) : unit =
+ print(uopToString u)
+
+type constdata = {
+ value : word, (* The bits *)
+ typ : word, (* The type *)
+ sz : word (* The size *)
+}
+
+fun const_eq (c1 : constdata) (c2 : constdata) : bool =
+ (#value c1) = (#value c2) andalso
+ (#typ c1) = (#typ c2) andalso
+ (#sz c1) = (#sz c2)
+
+type inputdata = {
+ addr : word, (* The original address in memory *)
+ fnres : word, (* Function result address if needed *)
+ fnaddr : word, (* The function if needed *)
+ uid : word, (* unique ids to distinguish logically different inputs *)
+ cval : word, (* The concrete value *)
+ typ : word, (* The type *)
+ sz : word, (* The size *)
+ file : word, (* source file location *)
+ line : word (* source line number *)
+}
+
+fun input_eq((i1 : inputdata),(i2 : inputdata)) : bool =
+ (#addr i1) = (#addr i2) andalso
+ (#fnres i1) = (#fnres i2) andalso
+ (#fnaddr i1) = (#fnaddr i2) andalso
+ (#uid i1) = (#uid i2) andalso
+ (#cval i1) = (#cval i2) andalso
+ (#typ i1) = (#typ i2) andalso
+ (#sz i1) = (#sz i2)
+
+fun input_hash (id : inputdata) : word =
+ Word.xorb((#addr id),
+ Word.xorb((#fnres id),
+ Word.xorb((#fnaddr id),(#uid id))))
+
+fun print_input (id : inputdata) : unit =
+ print("Input("^(Word.toString (#addr id))^","
+ ^(Word.toString (#cval id))^")")
+
+(* Datatype for symbolic expressions *)
+datatype exp =
+ BinOp of bop * exp * exp
+ | UnOp of uop * exp
+ | Const of constdata
+ | Input of inputdata
+
+type int64 = Int64.int
+
+type canonexp = {
+ ct : int64,
+ cf : (int64 * exp) list
+}
+
+fun mkConst(v,t,s) = Const{value=v,typ=t,sz=s}
+fun mkInput(a,fr,fa,u,v,t,s,fl,ln) =
+ let
+ val id = {addr=a,fnres=fr,fnaddr=fa,uid=u,cval=v,typ=t,sz=s,file=fl,line=ln}
+ in
+ (*print_input id;*)
+ Input id
+ end
+
+fun print_exp (e : exp) : unit = case e of
+ BinOp(bop,e1,e2) =>
+ (print("BinOp("^(bopToString bop)^",");
+ print_exp e1;print ",";print_exp e2;print ")")
+| UnOp(uop,e) =>
+ (print("UnOp("^(uopToString uop)^",");
+ print_exp e; print ")")
+| Const c => (print(Word.toString (#value c)))
+| Input id => print_input id
+
+
+fun print_canexp (c : canonexp) : unit =
+ let
+ fun ppair((f,e),()) =
+ (print("+"^(Int64.toString f)^"*");
+ print_exp e)
+ in
+ print(Int64.toString (#ct c));
+ foldl ppair () (#cf c)
+ end
+
+fun exp_eq (e1 : exp) (e2 : exp) : bool =
+ case (e1,e2) of
+ (BinOp(b1,e11,e12),BinOp(b2,e21,e22)) =>
+ (bop_eq b1 b2) andalso (exp_eq e11 e21) andalso (exp_eq e12 e22)
+ | (UnOp(u1,e1),UnOp(u2,e2)) =>
+ (uop_eq u1 u2) andalso (exp_eq e1 e2)
+ | (Const cd1, Const cd2) => const_eq cd1 cd2
+ | (Input id1, Input id2) => input_eq(id1,id2)
+ | _ => false
+
+fun wordToBop (w : word) : bop = case (Word.toInt w) of
+ 0 => PlusA
+ | 1 => PlusPI
+ | 2 => IndexPI
+ | 3 => MinusA
+ | 4 => MinusPI
+ | 5 => MinusPP
+ | 6 => Mult
+ | 7 => Div
+ | 8 => Mod
+ | 9 => ShiftL
+ | 10 => ShiftR
+ | 11 => Lt
+ | 12 => Gt
+ | 13 => Le
+ | 14 => Ge
+ | 15 => Eq
+ | 16 => Ne
+ | 17 => BAnd
+ | 18 => BXor
+ | 19 => BOr
+ | 20 => LAnd
+ | 21 => LOr
+ | _ => UKBop
+
+fun wordToUop (w : word) : uop = case (Word.toInt w) of
+ 0 => Neg
+ | 1 => BNot
+ | 2 => LNot
+ | _ => UKUop
+
+
+fun mkCanInt (f : int64) : canonexp = {ct = f, cf = []}
+fun mkCanAtomic (f : int64) (e : exp) : canonexp =
+ if f = 0 then {ct = 0, cf = []}
+ else {ct = 0, cf = [(f,e)]}
+val mkCanZero = mkCanInt 0
+fun mkCanWAdd (w1 : int64) (c1 : canonexp) (cacc : canonexp) : canonexp =
+ let
+ fun insert (w : int64) (e : exp) (fel : (int64 * exp) list) =
+ case fel of
+ [] => if w = 0 then [] else [(w,e)]
+ | (w',e') :: rst =>
+ if exp_eq e e' then
+ if w + w' = 0 then
+ rst
+ else (w + w',e') :: rst
+ else (w',e') :: (insert w e rst)
+ fun folder((w,e),acc) = insert (w1*w) e acc
+ in
+ {ct = w1 * (#ct c1) + (#ct cacc),
+ cf = foldl folder (#cf cacc) (#cf c1)}
+ end
+fun mkCanAdd (c1 : canonexp) (c2 : canonexp) : canonexp =
+ mkCanWAdd 1 c1 c2
+fun mkCanSub (c1 : canonexp) (c2 : canonexp) : canonexp =
+ mkCanWAdd (~1) c2 c1
+fun mkCanMult (c : canonexp) (n : int64) : canonexp =
+ mkCanWAdd n c mkCanZero
+fun mkCanAddConst (c : canonexp) (n : int64) : canonexp =
+ {ct = n + (#ct c), cf = (#cf c)}
+
+
+fun max x y = if x > y then x else y
+
+fun typeOfExp (e : exp) : word * word = case e of
+ Const c => ((#typ c),(#sz c))
+ | Input i => ((#typ i),(#sz i))
+ | UnOp(_,e) => typeOfExp e
+ | BinOp(_,e1,e2) =>
+ let
+ val (t1,sz1) = typeOfExp e1
+ val (t2,sz2) = typeOfExp e2
+ in
+ case (t1,t2) of
+ (0wx0,0wx0) => (0wx0,max sz1 sz2)
+ | (0wx1,0wx0) => (0wx1,sz1)
+ | (0wx0,0wx1) => (0wx1,sz2)
+ | (0wx1,0wx1) => (0wx1,0wx1)
+ | _ => (0wx1,0wx1)
+ end
+
+fun wordToInt64 (w : word) (signed : bool) : int64 =
+ (if signed
+ then (Int64.fromLarge o Word.toLargeIntX) w
+ else (Int64.fromLarge o Word.toLargeInt) w)
+ handle Overflow =>
+ (print("wordToInt64: Overflow: "^(Word.toString w)^"\n");
+ raise Overflow)
+
+fun int64ToInt (i : int64) : int =
+ ((Int.fromLarge o Int64.toLarge) i)
+ handle Overflow =>
+ (print "Overflow in conversion from int64 to int\n";
+ raise Overflow)
+
+fun canonExp (f : int64) (e : exp) : canonexp =
+ (case e of
+ Const c => mkCanInt (f * (wordToInt64 (#value c) (Word.toIntX (#sz c) < 0)))
+ | BinOp(PlusA,e1,e2) =>
+ mkCanAdd (canonExp f e1) (canonExp f e2)
+ | BinOp(PlusPI,e1,e2) =>
+ let
+ val (t1,sz1) = typeOfExp e1
+ val (t2,sz2) = typeOfExp e2
+ in
+ case (t1,t2) of
+ (0wx0,0wx0) =>
+ mkCanAdd (canonExp f e1) (canonExp f e2)
+ | (0wx1,0wx0) =>
+ mkCanAdd (canonExp f e1) (canonExp (f*(wordToInt64 sz1 false)) e2)
+ | (0wx0,0wx1) =>
+ mkCanAdd (canonExp (f*(wordToInt64 sz2 false)) e1) (canonExp f e2)
+ | (0wx1,0wx1) =>
+ mkCanAdd (canonExp f e1) (canonExp f e2)
+ | _ =>
+ mkCanAdd (canonExp f e1) (canonExp f e2)
+ end
+ | BinOp(IndexPI,e1,e2) =>
+ let
+ val (t1,sz1) = typeOfExp e1
+ val (t2,sz2) = typeOfExp e2
+ in
+ case (t1,t2) of
+ (0wx0,0wx0) =>
+ mkCanAdd (canonExp f e1) (canonExp f e2)
+ | (0wx1,0wx0) =>
+ mkCanAdd (canonExp f e1) (canonExp (f*(wordToInt64 sz1 false)) e2)
+ | (0wx0,0wx1) =>
+ mkCanAdd (canonExp (f*(wordToInt64 sz2 false)) e1) (canonExp f e2)
+ | (0wx1,0wx1) =>
+ mkCanAdd (canonExp f e1) (canonExp f e2)
+ | _ =>
+ mkCanAdd (canonExp f e1) (canonExp f e2)
+ end
+ | BinOp(MinusA,e1,e2) =>
+ mkCanAdd (canonExp f e1) (canonExp (~f) e2)
+ | BinOp(MinusPI,e1,e2) =>
+ let
+ val (t1,sz1) = typeOfExp e1
+ val (t2,sz2) = typeOfExp e2
+ in
+ case (t1,t2) of
+ (0wx0,0wx0) =>
+ mkCanAdd (canonExp f e1) (canonExp (~f) e2)
+ | (0wx1,0wx0) =>
+ mkCanAdd (canonExp f e1) (canonExp (~f*(wordToInt64 sz1 false)) e2)
+ | (0wx0,0wx1) =>
+ mkCanAdd (canonExp (f*(wordToInt64 sz2 false)) e1) (canonExp (~f) e2)
+ | (0wx1,0wx1) =>
+ mkCanAdd (canonExp f e1) (canonExp (~f) e2)
+ | _ =>
+ mkCanAdd (canonExp f e1) (canonExp (~f) e2)
+ end
+ | BinOp(MinusPP,e1,e2) =>
+ mkCanAdd (canonExp f e1) (canonExp (~f) e2)
+ | BinOp(Mult,e1,Const c) =>
+ mkCanAtomic (f * (wordToInt64 (#value c) (Word.toIntX (#sz c) < 0))) e1
+ | BinOp(Mult,Const c, e2) =>
+ mkCanAtomic (f * (wordToInt64 (#value c) (Word.toIntX (#sz c) < 0))) e2
+ | _ => mkCanAtomic f e)
+ handle Overflow =>
+ (print "canonExp: Overflow\n"; raise Overflow)
+
+exception Not_found
+
+fun incr (i : int ref) : unit = i := (!i) + 1
+fun decr (i : int ref) : unit = i := (!i) - 1
+
+fun fst (a,b) = a
+
+type taintdata = {
+ uid : word,
+ file : word,
+ line : word
+}
+
+fun mkTaint (uid : word) (file : word) (line : word) : taintdata =
+ {uid=uid,file=file,line=line}
+
+(* Functions for manipulating the taint map *)
+val taintMap : taintdata IntervalMap.map ref = ref IntervalMap.empty
+
+fun taintSetRm (s : word) (e : word) : unit =
+ (taintMap := fst(IntervalMap.remove(!taintMap,(s,e))))
+ handle NotFound => ()
+
+fun taintSetAdd (s : word) (esz : word) (ecnt : word)
+ (file : word) (line : word)
+ : unit
+ =
+ let
+ val e = s + esz * ecnt
+ in
+ case IntervalMap.find(!taintMap,(s,e)) of
+ NONE =>
+ let val td = mkTaint 0wx0 file line in
+ taintMap := IntervalMap.insert(!taintMap,(s,e),td)
+ end
+ | SOME td =>
+ let val td = mkTaint ((#uid td)+0wx1) file line in
+ taintMap := IntervalMap.insert(!taintMap,(s,e),td)
+ end
+ end
+
+fun taintSetFind (s : word) (e : word) : (word * word * taintdata) option =
+ case IntervalMap.find(!taintMap,(s,e)) of
+ NONE => NONE
+ | SOME td => SOME(s,e,td)
+
+
+(* Functions for manipulating the symbolic state *)
+val symStateShift = Word.fromInt 18
+val symStateSize = Word.<<((Word.fromInt 1), symStateShift)
+val symStateMask = symStateSize - (Word.fromInt 1)
+(* Global hash table for symbolic state *)
+(*WHash.mkTable(131072,Not_found)*)
+val symState : exp option array = Array.array(Word.toInt symStateSize,NONE)
+val c_int32_hash = _import "c_int32_hash": word * word -> int;
+fun symStateHash (w : word) : int =
+ (*c_int32_hash(w,symStateMask)*)
+ Word.toInt (Word.andb(w, symStateMask))
+val collisions : int ref = ref 0
+fun symStateAdd (sop : word) (e : exp) : unit =
+ ((*print("Adding: "^(Word.toString sop)^" -> ");
+ print_exp e; print "\n";*)
+ (case Array.sub(symState,symStateHash sop) of
+ NONE => Array.update(symState, (symStateHash sop), (SOME e))
+ | SOME _ => (Array.update(symState, (symStateHash sop), (SOME e)))))
+fun symStateLookup (sop : word) : exp option =
+ Array.sub(symState, (symStateHash sop))
+fun symStateRm (sop : word) : unit =
+ Array.update(symState, (symStateHash sop), NONE)
+
+(* Stuff for maintaining a mapping from inputs to sets of locations where those
+ inputs are checked *)
+
+val c_print_loc = _import "c_print_loc":
+ word * word -> unit;
+
+val inpChecks : LocationSet.set IHT.hash_table =
+ IHT.mkTable (100, Not_found)
+
+fun addInpCheck (vid : int) (file,line) : unit =
+ case IHT.find inpChecks vid of
+ NONE =>
+ IHT.insert inpChecks (vid,LocationSet.singleton(file,line))
+ | SOME s =>
+ IHT.insert inpChecks (vid,LocationSet.add(s,(file,line)))
+
+fun getInpChecks (vid : int) : LocationSet.set =
+ case IHT.find inpChecks vid of
+ NONE => LocationSet.empty
+ | SOME s => s
+
+fun printInpChecks (vid : int) : unit =
+ let
+ val set = getInpChecks vid
+ fun printer((file,line),()) =
+ c_print_loc(file,line)
+ in
+ if LocationSet.isEmpty set then
+ print "No Checks"
+ else
+ LocationSet.foldl printer () set
+ end
+
+(* Octagon stuff *)
+
+type oct_t = word
+
+val c_oct_init = _import "c_oct_init":
+ unit -> int;
+val c_oct_add_constraint = _import "c_oct_add_constraint":
+ oct_t * int array * int -> oct_t;
+val c_oct_add_dimension = _import "c_oct_add_dimension":
+ oct_t * word -> oct_t;
+val c_oct_empty = _import "c_oct_empty":
+ word -> oct_t;
+val c_oct_universe = _import "c_oct_universe":
+ word -> oct_t;
+val c_oct_copy = _import "c_oct_copy":
+ oct_t -> oct_t;
+val c_oct_print = _import "c_oct_print":
+ oct_t -> unit;
+val c_oct_free = _import "c_oct_free":
+ oct_t -> unit;
+val c_oct_dimension = _import "c_oct_dimension":
+ oct_t -> int;
+val c_oct_is_empty = _import "c_oct_is_empty":
+ oct_t -> bool;
+val c_oct_is_universe = _import "c_oct_is_universe":
+ oct_t -> bool;
+val c_oct_is_included_in = _import "c_oct_is_included_in":
+ oct_t * oct_t -> bool;
+val c_oct_is_equal = _import "c_oct_is_equal":
+ oct_t * oct_t -> bool;
+val c_oct_get_box = _import "c_oct_get_box":
+ oct_t * int array * int array -> unit;
+
+type octagon = {
+ oct : oct_t ref,
+ maxvars : int ref,
+ numvars : int ref
+}
+
+fun mkOct () : octagon =
+ {oct = ref (c_oct_universe 0wx5), maxvars = ref 5, numvars = ref 0}
+fun copyOct (oct : octagon) : octagon =
+ {oct = ref (c_oct_copy (!(#oct oct))),
+ maxvars = ref (!(#maxvars oct)),
+ numvars = ref (!(#numvars oct))}
+fun printOct (oct : octagon) : unit =
+ c_oct_print (!(#oct oct))
+
+
+val cOctagon : octagon = (ignore(c_oct_init()); mkOct())
+
+val inpOVarHash : (inputdata,int) HT.hash_table =
+ HT.mkTable (input_hash,input_eq) (100,Not_found)
+val oVarInpHash : inputdata IHT.hash_table =
+ IHT.mkTable (100,Not_found)
+
+fun addOctConstraint (oct : octagon) (cl : int array) : unit =
+ (#oct oct) := c_oct_add_constraint(!(#oct oct),cl,Array.length cl);
+fun addOctVar (oct : octagon) (id : inputdata) : int =
+ (if !(#numvars oct) = !(#maxvars oct) then
+ ((#oct oct) := c_oct_add_dimension(!(#oct oct),0wx5);
+ (#maxvars oct) := !(#maxvars oct) + 5)
+ else ();
+ HT.insert inpOVarHash (id, !(#numvars oct));
+ IHT.insert oVarInpHash (!(#numvars oct),id);
+ !(#numvars oct) before (incr (#numvars oct)))
+fun getOctVar (oct : octagon) (id : inputdata) : int =
+ case HT.find inpOVarHash id of
+ NONE => addOctVar oct id
+ | SOME i => i
+
+(* Convert a canonexp into a list of coefficients and octVar IDs.
+ If the expression doesn't have the right form, return NONE *)
+exception BadConExp
+fun getCoefIdList (oct : octagon) (c : canonexp) : (int64 * int) list option =
+ let
+ fun handleTerm (f,e) : (int64 * int) = case e of
+ Input id => (f, getOctVar oct id)
+ | _ => raise BadConExp
+ in
+ ((*print "trying to add: ";
+ print_canexp c; print "\n";*)
+ SOME(map handleTerm (#cf c))(* before
+ print "constraint added\n"*)
+ ) handle BadConExp => NONE
+ end
+
+fun maxVID ipl m = case ipl of
+ [] => m
+| (f,id) :: rst =>
+ if id > m then maxVID rst id else maxVID rst m
+
+(* Adds the constraint c >= 0 to the octagon *)
+fun addCEToOct (oct : octagon) (c : canonexp)
+ (file : word) (line : word)
+ : unit
+ =
+ case getCoefIdList oct c of
+ NONE => ()
+ | SOME ipl =>
+ let
+ val dim = c_oct_dimension (!(#oct oct))
+ val coefs = Array.array ((dim + 1),0)
+ fun adder ((f, id),()) : unit =
+ (Array.update (coefs,id,int64ToInt f);
+ if file <> 0wx0 then addInpCheck id (file,line) else ())
+ in
+ (foldl adder () ipl;
+ Array.update (coefs,dim,int64ToInt (#ct c));
+ addOctConstraint oct coefs)
+ handle Overflow => ()
+ | Subscript => ()
+ end
+
+fun addBopToOct (oct : octagon) (b : bop) (e1 : exp) (e2 : exp)
+ (file : word) (line : word)
+ : unit
+ =
+ let
+ val e1 = canonExp 1 e1
+ val e2 = canonExp 1 e2
+ val one = mkCanInt 1
+ in
+ case b of
+ Lt => addCEToOct oct (mkCanSub e2 (mkCanAdd e1 one)) file line
+ | Gt => addCEToOct oct (mkCanSub e1 (mkCanAdd e2 one)) file line
+ | Le => addCEToOct oct (mkCanSub e2 e1) file line
+ | Ge => addCEToOct oct (mkCanSub e1 e2) file line
+ | _ => ()
+ end
+
+(* structures for dealing with call/return semantics *)
+val call_depth = ref 0
+val arg_stack : (word * word * word * word) array =
+ Array.array(20,(0wx0,0wx0,0wx0,0wx0))
+val arg_stack_top = ref 0
+val ret_val : exp option ref = ref NONE
+
+fun arg_stack_push wt =
+ (Array.update(arg_stack, !arg_stack_top, wt);
+ incr arg_stack_top)
+
+fun arg_stack_pop () =
+ (decr arg_stack_top;
+ if !arg_stack_top < 0 then
+ (arg_stack_top := 0; NONE)
+ else let val res = Array.sub(arg_stack,!arg_stack_top) in
+ SOME res
+ end)
+
+(* Functions for handling two-dimensional C arrays *)
+type cArray = {
+ arr : MLton.Pointer.t,
+ cols : int,
+ rows : int
+}
+
+fun cArray2Sub (iaa : cArray) (m : int) (n : int) : Word32.word =
+ let val rowstart = m*(#cols iaa) in
+ MLton.Pointer.getWord32 (#arr iaa, rowstart + n)
+ end
+
+(* This is used for pattern matching all the different Pluses and Minuses.
+ Ocaml is much better in this regard *)
+datatype stupidBop = Plus | Minus | Normal of bop
+
+fun bopToSBop bop = case bop of
+ PlusA => Plus
+| PlusPI => Plus
+| IndexPI => Plus
+| MinusA => Minus
+| MinusPI => Minus
+| MinusPP => Minus
+| _ => Normal bop
+
+datatype visitAction = DoChildren | ChangeTo of exp
+
+fun visitExp (f : exp -> visitAction) (e : exp) : exp =
+ let
+ fun visitChildren (e : exp) : exp = case e of
+ BinOp(bop,e1,e2) => BinOp(bop,visitExp f e1, visitExp f e2)
+ | UnOp(bop,e) => UnOp(bop,visitExp f e)
+ | _ => e
+ in
+ case f e of
+ DoChildren => visitChildren e
+ | ChangeTo e => e
+ end
+
+fun symResolve (cop : word) (sop : word) (typ : word) (sz : word) : exp =
+ if sop = 0wx0 then mkConst(cop,typ,sz) else
+ case (symStateLookup sop, taintSetFind sop sop) of
+ (NONE, NONE) => mkConst(cop,typ,sz)
+ | (NONE, SOME(_,_,{uid,file,line})) =>
+ mkInput(sop,0wx0,0wx0,uid,cop,typ,sz,file,line)
+ | (SOME e,_) => e
+
+(* Functions imported from C *)
+val cMain = _import "cMain": int * string vector -> int;
+
+val c_eval_bop = _import "c_eval_bop":
+ word * word * word * word * word * word * word
+ -> word;
+
+val c_eval_uop = _import "c_eval_uop":
+ word * word * word * word
+ -> word;
+
+fun assignBasic (dest : word)
+ (cop : word) (sop : word) (typ : word) (sz : word)
+ : unit
+ =
+ if sop = 0wx0
+ then symStateRm dest
+ else case symStateLookup sop of
+ NONE => (symStateRm dest;
+ case taintSetFind sop sop of
+ NONE => ()
+ | SOME(l,h,{uid,file,line}) =>
+ symStateAdd dest (mkInput(sop,0wx0,0wx0,uid,cop,typ,sz,file,line)))
+ | SOME e => symStateAdd dest e
+
+datatype side = Left | Right
+
+fun assocConst (ib : bop) (ob : bop) (e1 : exp) (e2 : exp)
+ (cop,sop,typ,sz) (s : side)
+ : exp
+ =
+ case (bopToSBop ib, bopToSBop ob, e1, e2) of
+ (Plus, Plus, _, Const{value=cop2,typ=typ2,sz=sz2}) =>
+ let val c = c_eval_bop(bopToWord ob,cop2,typ2,sz2,cop,typ,sz) in
+ BinOp(ib,e1,mkConst(c,typ2,sz2))
+ end
+ | (Plus, Plus, Const{value=cop1,typ=typ1,sz=sz1}, _) =>
+ let val c = c_eval_bop(bopToWord ob,cop1,typ1,sz1,cop,typ,sz) in
+ BinOp(ib,mkConst(c,typ1,sz1),e2)
+ end
+ | (Minus, Minus, _, Const{value=cop2,typ=typ2,sz=sz2}) =>
+ let val c = c_eval_bop(bopToWord PlusA,cop2,typ2,sz2,cop,typ,sz) in
+ case s of
+ Right => BinOp(ib,e1,mkConst(c,typ2,sz2))
+ | Left => BinOp(ib,mkConst(c,typ2,sz2),e1)
+ end
+ | (Normal(Mult), Normal(Mult), _, Const{value=cop2,typ=typ2,sz=sz2}) =>
+ let val c = c_eval_bop(bopToWord ob,cop2,typ2,sz2,cop,typ,sz) in
+ BinOp(ib,e1,mkConst(c,typ2,sz2))
+ end
+ | (Normal(Mult), Normal(Mult), Const{value=cop1,typ=typ1,sz=sz1}, _) =>
+ let val c = c_eval_bop(bopToWord ob,cop1,typ1,sz1,cop,typ,sz) in
+ BinOp(ib,mkConst(c,typ1,sz1),e2)
+ end
+ | (Plus, Normal(Mult), Const{value=cop1,typ=typ1,sz=sz1}, _) =>
+ let val c = c_eval_bop(bopToWord ob,cop1,typ1,sz1,cop,typ,sz) in
+ BinOp(ib,mkConst(c,typ1,sz1), BinOp(ob,e2,mkConst(cop, typ, sz)))
+ end
+ | (Minus, Normal(Mult), Const{value=cop1,typ=typ1,sz=sz1}, _) =>
+ let val c = c_eval_bop(bopToWord ob,cop1,typ1,sz1,cop,typ,sz) in
+ BinOp(ib,mkConst(c,typ1,sz1), BinOp(ob,e2,mkConst(cop, typ, sz)))
+ end
+ | (Plus, Normal(Mult), _, Const{value=cop2,typ=typ2,sz=sz2}) =>
+ let val c = c_eval_bop(bopToWord ob,cop2,typ2,sz2,cop,typ,sz) in
+ BinOp(ib,BinOp(ob,e1,mkConst(cop, typ, sz)), mkConst(c,typ2,sz2))
+ end
+ | (Minus, Normal(Mult), _, Const{value=cop2,typ=typ2,sz=sz2}) =>
+ let val c = c_eval_bop(bopToWord ob,cop2,typ2,sz2,cop,typ,sz) in
+ BinOp(ib,BinOp(ob,e1,mkConst(cop, typ, sz)),mkConst(c,typ2,sz2))
+ end
+ | (_, _, _, _) =>
+ (
+ case s of
+ Right => BinOp(ob,BinOp(ib,e1,e2),mkConst(cop, typ, sz))
+ | Left => BinOp(ob,mkConst(cop, typ, sz),BinOp(ib,e1,e2)))
+
+fun simplBop (b : bop)
+ (cop1 : word) (sop1 : word) (typ1 : word) (sz1 : word)
+ (cop2 : word) (sop2 : word) (typ2 : word) (sz2 : word)
+ : exp option
+ =
+ case (symStateLookup sop1, symStateLookup sop2) of
+ (NONE, NONE) =>
+ (case (taintSetFind sop1 sop1, taintSetFind sop2 sop2) of
+ (NONE,NONE) => NONE
+ | (SOME(_,_,{uid,file,line}),NONE) =>
+ SOME(BinOp(b,mkInput(sop1,0wx0,0wx0,uid,cop1,typ1,sz1,file,line),
+ mkConst(cop2,typ2,sz2)))
+ | (NONE,SOME(_,_,{uid,file,line})) =>
+ SOME(BinOp(b,mkConst(cop1,typ1,sz1),
+ mkInput(sop2,0wx0,0wx0,uid,cop2,typ2,sz2,file,line)))
+ | (SOME(_,_,{uid=i1,file=f1,line=l1}),SOME(_,_,{uid=i2,file=f2,line=l2})) =>
+ SOME(BinOp(b,mkInput(sop1,0wx0,0wx0,i1,cop1,typ1,sz1,f1,l1),
+ mkInput(sop2,0wx0,0wx0,i2,cop2,typ2,sz2,f2,l2))))
+ | (SOME(oe1 as BinOp(ib,e1,e2)), NONE) =>
+ (case taintSetFind sop2 sop2 of
+ NONE =>
+ SOME(assocConst ib b e1 e2 (cop2,sop2,typ2,sz2) Right)
+ | SOME(_,_,{uid,file,line}) =>
+ SOME(BinOp(b,oe1,mkInput(sop2,0wx0,0wx0,uid,cop2,typ2,sz2,file,line))))
+ | (SOME e, NONE) =>
+ (case taintSetFind sop2 sop2 of
+ NONE =>
+ SOME(BinOp(b,e,mkConst(cop2,typ2,sz2)))
+ | SOME(_,_,{uid,file,line}) =>
+ SOME(BinOp(b,e,mkInput(sop2,0wx0,0wx0,uid,cop2,typ2,sz2,file,line))))
+ | (NONE, SOME(oe2 as BinOp(ib,e1,e2))) =>
+ (case taintSetFind sop1 sop1 of
+ NONE =>
+ SOME(assocConst ib b e1 e2 (cop1,sop1,typ1,sz1) Left)
+ | SOME(_,_,{uid,file,line}) =>
+ SOME(BinOp(b,mkInput(sop1,0wx0,0wx0,uid,cop1,typ1,sz1,file,line),oe2)))
+ | (NONE, SOME e) =>
+ (case taintSetFind sop1 sop1 of
+ NONE =>
+ SOME(BinOp(b,mkConst(cop1,typ1,sz1),e))
+ | SOME(_,_,{uid,file,line}) =>
+ SOME(BinOp(b,mkInput(sop1,0wx0,0wx0,uid,cop1,typ1,sz1,file,line),e)))
+ (*| (SOME(BinOp(ib1,e11,e12)), SOME(BinOp(ib1,e21,e22))) =>*)
+ | (SOME e1, SOME e2) => SOME(BinOp(b,e1,e2))
+
+fun assignBop (dest : word) (bop : word)
+ (cop1 : word) (sop1 : word) (typ1 : word) (sz1 : word)
+ (cop2 : word) (sop2 : word) (typ2 : word) (sz2 : word)
+ : unit
+ =
+ if sop1 = (Word.fromInt 0) andalso sop2 = (Word.fromInt 0)
+ then symStateRm dest
+ else let
+ val res = simplBop (wordToBop bop) cop1 sop1 typ1 sz1 cop2 sop2 typ2 sz2
+ in
+ case res of
+ NONE => symStateRm dest
+ | SOME res => symStateAdd dest res
+ end
+
+fun simplUop (u : uop)
+ (cop : word) (sop : word) (typ : word) (sz : word)
+ : exp option
+ =
+ case symStateLookup sop of
+ NONE => NONE
+ | SOME e => SOME(UnOp(u,e))
+
+fun assignUop (dest : word) (uop : word)
+ (cop : word) (sop : word) (typ : word) (sz : word)
+ : unit
+ =
+ if sop = (Word.fromInt 0)
+ then symStateRm dest
+ else let
+ val res = simplUop (wordToUop uop) cop sop typ sz
+ in
+ case res of
+ NONE => symStateRm dest
+ | SOME res => symStateAdd dest res
+ end
+
+fun assignCast (dest : word)
+ (cop : word) (sop : word) (typ : word) (sz : word)
+ : unit
+ = assignBasic dest cop sop typ sz
+
+(*fun forget_locals () : unit =
+ let
+ fun forget (sop,_) : unit =
+ (symStateRm sop;
+ if taintSetExists sop sop then taintSetRm sop sop else ())
+ in
+ (case (!locals_stack) of
+ [] => ()
+ | x :: rst => (foldl forget () x;
+ locals_stack := rst))
+ end*)
+
+fun retBasic (cop : word) (sop : word) (typ : word) (sz : word) : unit =
+ case symStateLookup sop of
+ NONE =>
+ (case taintSetFind sop sop of
+ NONE => ret_val := NONE
+ | SOME(l,h,{uid,file,line}) =>
+ (print "retBasic: making Input\n";
+ ret_val := SOME(mkInput(sop,0wx0,0wx0,uid,cop,typ,sz,file,line))))
+ | SOME e => ret_val := SOME e
+
+fun retBop (bop : word)
+ (cop1 : word) (sop1 : word) (typ1 : word) (sz1 : word)
+ (cop2 : word) (sop2 : word) (typ2 : word) (sz2 : word)
+ : unit
+ =
+ case simplBop (wordToBop bop) cop1 sop1 typ1 sz1 cop2 sop2 typ2 sz2 of
+ NONE =>
+ ret_val := NONE
+ | SOME e => ret_val := SOME e
+
+fun retUop (uop : word)
+ (cop : word) (sop : word) (typ : word) (sz : word)
+ : unit
+ =
+ case simplUop (wordToUop uop) cop sop typ sz of
+ NONE => ret_val := NONE
+ | SOME e => ret_val := SOME e
+
+fun retVoid () : unit = ()
+
+fun ifBasic (cop : word) (sop : word) (typ : word) (sz : word)
+ (file : word) (line : word)
+ : unit
+ = ()
+
+fun ifBop (bop : word)
+ (cop1 : word) (sop1 : word) (typ1 : word) (sz1 : word)
+ (cop2 : word) (sop2 : word) (typ2 : word) (sz2 : word)
+ (file : word) (line : word)
+ : unit
+ =
+ case simplBop (wordToBop bop) cop1 sop1 typ1 sz1 cop2 sop2 typ2 sz2 of
+ NONE => ()
+ | SOME(BinOp(bop,e1,e2)) =>
+ let val b = c_eval_bop(bopToWord bop,cop1,typ1,sz1,cop2,typ2,sz2)
+ val bop = if b = 0wx0 then negate_bop bop else bop in
+ ((*print "Branch: ";
+ print_canexp (canonExp 1 e1);
+ print " ";
+ print_bop bop;*)
+ addBopToOct cOctagon bop e1 e2 file line(*;
+ print " ";
+ print_canexp (canonExp 1 e2);
+ print "\n"*))
+ end
+ | SOME e => (print_exp e; print "\n")
+
+fun ifUop (uop : word)
+ (cop : word) (sop : word) (typ : word) (sz : word)
+ (file : word) (line : word)
+ : unit
+ = ()
+
+fun switchBasic (c : word)
+ (cop : word) (sop : word) (typ : word) (sz : word)
+ : unit
+ = ()
+
+fun switchBop (c : word) (bop : word)
+ (cop1 : word) (sop1 : word) (typ1 : word) (sz1 : word)
+ (cop2 : word) (sop2 : word) (typ2 : word) (sz2 : word)
+ : unit
+ = ()
+
+fun switchUop (c : word) (uop : word)
+ (cop : word) (sop : word) (typ : word) (sz : word)
+ : unit
+ = ()
+
+fun pushArg (cop : word) (sop : word) (typ : word) (sz : word) : unit =
+ arg_stack_push (cop,sop,typ,sz)
+
+fun unRegLocal (sop : word) (typ : word) (sz : word) : unit =
+ symStateRm sop
+
+fun popArg (dest : word) : unit =
+ let val argo = arg_stack_pop () in
+ case argo of
+ NONE => ()
+ | SOME(cop,sop,typ,sz) =>
+ assignBasic dest cop sop typ sz
+ end
+
+fun funStart (nargs : word) : unit =
+ incr call_depth
+
+fun retPop (cop : word) (sop : word) (typ : word) (sz : word) (nargs : word)
+ : unit
+ =
+ (arg_stack_top := 0;
+ case !ret_val of
+ NONE => symStateRm sop
+ | SOME e => symStateAdd sop e)
+
+fun retNoRet (nargs : word) : unit =
+ (arg_stack_top := 0)
+
+
+fun addTaint (start : word) (esz : word) (ecnt : word)
+ (file : word) (line : word)
+ : unit
+ =
+ taintSetAdd start esz ecnt file line
+
+fun addCondTaint (src : word) (dst : word) (f : word)
+ (cop : word) (typ : word) (sz : word)
+ (file: word) (line : word)
+ : unit
+ =
+ case taintSetFind src src of
+ NONE =>
+ (case symStateLookup src of
+ SOME(Input id) =>
+ symStateAdd dst (mkInput((#addr id),dst,f,(#uid id),cop,typ,sz,file,line))
+ | _ => print("Not Adding CTaint: "^(Word.toString dst)^"\n"))
+ | SOME(_,_,{uid,...}) =>
+ (print("Adding CTaint: "^(Word.toString dst)^"\n");
+ symStateAdd dst (mkInput(src,dst,f,uid,cop,typ,sz,file,line)))
+
+
+(* See if the octagon has enough information to prove that
+ (e1 bop e2) is true *)
+fun checkAssertion (b : bop) (e1 : exp) (e2 : exp) : unit =
+ let
+ val newoct = copyOct cOctagon
+ in
+ addBopToOct newoct b e1 e2 0wx0 0wx0;
+ (if c_oct_is_included_in (!(#oct cOctagon),!(#oct newoct)) andalso
+ not(c_oct_is_empty (!(#oct newoct))) andalso
+ not(c_oct_is_universe (!(#oct newoct)))
+ then
+ print "program checks sufficient!\n"
+ else
+ print "program checks NOT sufficient!\n");
+ c_oct_free (!(#oct newoct))
+ end
+
+datatype cex = Lower of int | Upper of int | Both of (int * int)
+
+fun print_cex (bnd : cex) : unit =
+ case bnd of
+ Lower l =>
+ print((Int.toString l)^" <= input")
+ | Upper u =>
+ print("input <= "^(Int.toString u))
+ | Both(l,u) =>
+ print((Int.toString l)^" <= input <= "^(Int.toString u))
+
+fun warnAboutCE (bnd : cex) (vid : int) (file : word) (line : word) : unit =
+ case IHT.find oVarInpHash vid of
+ NONE => ()
+ | SOME id =>
+ let
+ val ifile = (#file id)
+ val iline = (#line id)
+ in
+ print "For input from: ";
+ c_print_loc(ifile,iline);
+ print "\n";
+ print "The check(s): ";
+ printInpChecks vid;
+ print "\n";
+ print "Must be strengthened because the memory op at: ";
+ c_print_loc(file,line);
+ print "\n";
+ print "Will fail when: ";
+ print_cex bnd;
+ print "\n"
+ end
+
+fun printCounterExample (newoct : octagon) (oldoct : octagon)
+ (file : word) (line : word)
+ : unit
+ =
+ let
+ val newdim = !(#maxvars newoct)
+ val newbox = Array.array (2*newdim, 0)
+ val newvalid = Array.array (2*newdim, 0)
+ val olddim = !(#maxvars oldoct)
+ val oldbox = Array.array (2*olddim, 0)
+ val oldvalid = Array.array (2*olddim, 0)
+ fun loop (i : int) : unit =
+ if i >= newdim then () else let
+ val newlowo =
+ if Array.sub(newvalid,2*i+1) = 0
+ then NONE else
+ SOME(Array.sub(newbox,2*i + 1))
+ val newhio =
+ if Array.sub(newvalid,2*i) = 0
+ then NONE else
+ SOME(Array.sub(newbox,2*i))
+ val oldlowo =
+ if i >= olddim orelse Array.sub(oldvalid,2*i+1) = 0
+ then NONE else
+ SOME(Array.sub(oldbox,2*i+1))
+ val oldhio =
+ if i >= olddim orelse Array.sub(oldvalid,2*i) = 0
+ then NONE else
+ SOME(Array.sub(oldbox,2*i))
+ in
+ (case (newlowo,newhio) of
+ (NONE, NONE) => ()
+ | (SOME lo, NONE) =>
+ if newlowo = oldlowo then () else
+ warnAboutCE (Lower (~lo)) i file line
+ | (NONE, SOME hi) =>
+ if newhio = oldhio then () else
+ warnAboutCE (Upper hi) i file line
+ | (SOME lo, SOME hi) =>
+ if newlowo = oldlowo andalso newhio = oldhio then () else
+ warnAboutCE (Both(~lo,hi)) i file line);
+ loop (i+1)
+ end
+ in
+ c_oct_get_box(!(#oct newoct),newbox,newvalid);
+ c_oct_get_box(!(#oct oldoct),oldbox,oldvalid);
+ (*print "Check will fail when\n";*)
+ (loop 0) handle Subscript =>
+ (print "Subscript raised in printCounterExample\n";
+ raise Subscript)
+ end
+
+(* Find values for inputs allowed by the octagon that
+ that cause (e1 bop e2) to be false *)
+fun findCounterExamples (b : bop) (e1 : exp) (e2 : exp)
+ (file : word) (line : word)
+ : unit
+ =
+ let
+ val newoct = copyOct cOctagon
+ in
+ addBopToOct newoct (negate_bop b) e1 e2 0wx0 0wx0;
+ (if c_oct_is_empty (!(#oct newoct))
+ then ()
+ (*print "There are NO counterexamples!\n"*)
+ else
+ (print "There are counterexamples!\n";
+ printCounterExample newoct cOctagon file line));
+ c_oct_free (!(#oct newoct))
+ end
+
+
+(* Check functions! *)
+fun cLeq (cop1 : word) (sop1 : word) (typ1 : word) (sz1 : word)
+ (cop2 : word) (sop2 : word) (typ2 : word) (sz2 : word)
+ (file : word) (line : word)
+ : unit
+ =
+ case simplBop Le cop1 sop1 typ1 sz1 cop2 sop2 typ2 sz2 of
+ SOME(BinOp(bop,e1,e2)) =>
+ ((*checkAssertion bop e1 e2;*)
+ findCounterExamples bop e1 e2 file line)
+ | _ => ()
+
+(* assert(op1 <= op2 + op3) *)
+fun cLeqSum (cop1 : word) (sop1 : word) (typ1 : word) (sz1 : word)
+ (cop2 : word) (sop2 : word) (typ2 : word) (sz2 : word)
+ (cop3 : word) (sop3 : word) (typ3 : word) (sz3 : word)
+ (file : word) (line : word)
+ : unit
+ =
+ let
+ val low = symResolve cop1 sop1 typ1 sz1
+ in
+ case simplBop PlusPI cop2 sop2 typ2 sz2 cop3 sop3 typ3 sz3 of
+ NONE => (case low of Const _ => () | _ =>
+ let val c = c_eval_bop(bopToWord PlusPI,cop2,typ2,sz2,cop3,typ3,sz3) in
+ (*checkAssertion Le low (mkConst(c,typ2,sz2));*)
+ findCounterExamples Le low (mkConst(c,typ2,sz2)) file line
+ end)
+ | SOME e =>
+ ((*checkAssertion Le low e;*)
+ findCounterExamples Le low e file line)
+ end
+
+(* assert(op1 + op2 <= op3) *)
+fun cSumLeq (cop1 : word) (sop1 : word) (typ1 : word) (sz1 : word)
+ (cop2 : word) (sop2 : word) (typ2 : word) (sz2 : word)
+ (cop3 : word) (sop3 : word) (typ3 : word) (sz3 : word)
+ (file : word) (line : word)
+ : unit
+ =
+ let
+ val hi = symResolve cop3 sop3 typ3 sz3
+ in
+ case simplBop PlusPI cop1 sop1 typ1 sz1 cop2 sop2 typ2 sz2 of
+ NONE => (case hi of Const _ => () | _ =>
+ let val c = c_eval_bop(bopToWord PlusPI,cop1,typ1,sz1,cop2,typ2,sz2) in
+ (*checkAssertion Le (mkConst(c,typ1,sz1)) hi;*)
+ findCounterExamples Le (mkConst(c,typ1,sz1)) hi file line
+ end)
+ | SOME e =>
+ ((*checkAssertion Le e hi;*)
+ findCounterExamples Le e hi file line)
+ end
+
+val instr_count = ref (Word64.fromInt 0)
+fun instrDispatch (iaa : cArray) (row : int) : unit =
+ (instr_count := (Word64.fromInt 1) + (!instr_count);
+ let fun lu (c : int) = cArray2Sub iaa row c in
+ (case (Word32.toInt (lu 0)) of
+ 0 => assignBasic (lu 1) (lu 2) (lu 3) (lu 4) (lu 5)
+ | 10 => assignBop (lu 1) (lu 2) (lu 3) (lu 4) (lu 5)
+ (lu 6) (lu 7) (lu 8) (lu 9) (lu 10)
+ | 20 => assignUop (lu 1) (lu 2) (lu 3) (lu 4) (lu 5) (lu 6)
+ | 30 => assignCast (lu 1) (lu 2) (lu 3) (lu 4) (lu 5)
+ | 40 => retBasic (lu 1) (lu 2) (lu 3) (lu 4)
+ | 50 => retBop (lu 1) (lu 2) (lu 3) (lu 4) (lu 5)
+ (lu 6) (lu 7) (lu 8) (lu 9)
+ | 60 => retUop (lu 1) (lu 2) (lu 3) (lu 4) (lu 5)
+ | 70 => retVoid ()
+ | 80 => ifBasic (lu 1) (lu 2) (lu 3) (lu 4) (lu 5) (lu 6)
+ | 90 => ifBop (lu 1) (lu 2) (lu 3) (lu 4) (lu 5)
+ (lu 6) (lu 7) (lu 8) (lu 9) (lu 10) (lu 11)
+ | 100 => ifUop (lu 1) (lu 2) (lu 3) (lu 4) (lu 5) (lu 6) (lu 7)
+ | 110 => switchBasic (lu 1) (lu 2) (lu 3) (lu 4) (lu 5)
+ | 120 => switchBop (lu 1) (lu 2) (lu 3) (lu 4) (lu 5)
+ (lu 6) (lu 7) (lu 8) (lu 9) (lu 10)
+ | 130 => switchUop (lu 1) (lu 2) (lu 3) (lu 4) (lu 5) (lu 6)
+ | 140 => pushArg (lu 1) (lu 2) (lu 3) (lu 4)
+ | 150 => popArg (lu 1)
+ | 160 => funStart (lu 1)
+ | 170 => retPop (lu 1) (lu 2) (lu 3) (lu 4) (lu 5)
+ | 180 => retNoRet (lu 1)
+ | 190 => unRegLocal (lu 1) (lu 2) (lu 3)
+ | 200 => addTaint (lu 1) (lu 2) (lu 3) (lu 4) (lu 5)
+ | 210 => addCondTaint (lu 1) (lu 2) (lu 3) (lu 4) (lu 5)
+ (lu 6) (lu 7) (lu 8)
+ | 220 => cLeq (lu 1) (lu 2) (lu 3) (lu 4) (lu 5)
+ (lu 6) (lu 7) (lu 8) (lu 9) (lu 10)
+ | 230 => cLeqSum (lu 1) (lu 2) (lu 3) (lu 4) (lu 5) (lu 6)
+ (lu 7) (lu 8) (lu 9) (lu 10) (lu 11) (lu 12)
+ (lu 13) (lu 14)
+ | 240 => cSumLeq (lu 1) (lu 2) (lu 3) (lu 4) (lu 5) (lu 6)
+ (lu 7) (lu 8) (lu 9) (lu 10) (lu 11) (lu 12)
+ (lu 13) (lu 14)
+ | _ => ()) handle Overflow =>
+ (print("instrDispatch: Overflow\n");
+ raise Overflow)
+ end)
+
+
+(* Function exported to C *)
+val e = _export "process_instrs": (MLton.Pointer.t * int * int -> unit) -> unit;
+fun at ((iaa : MLton.Pointer.t),(m : int),(n : int)) : unit =
+ let val carr = {arr = iaa, cols = n, rows = m} in
+ let fun loop (i:int) =
+ if i >= m then () else
+ (instrDispatch carr i;
+ loop (i+1))
+ in
+ (loop 0)
+ end
+ end
+val _ = e at
+
+val arg_list = (CommandLine.name())::(CommandLine.arguments())
+val arg_list = map (fn s => s^"\000") arg_list
+val arg_vec = vector arg_list
+val exit_code = cMain (length (CommandLine.arguments())+1, arg_vec)
--- /dev/null
+Summary: Deputy
+Name: deputy
+Version: 1.1
+Release: 1
+Source0: %{name}-%{version}.tar.gz
+License: BSD
+Group: Development/Languages
+BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}
+AutoReq: no
+AutoProv: no
+Requires: perl >= 5.6.1, perl(FindBin), gcc >= 4
+Provides: deputy = 1.1
+%description
+Deputy is an advanced C compiler that enforces memory and type safety in C
+programs using annotations supplied by the programmer.
+%prep
+%setup -q
+%build
+./configure
+make
+%install
+rm -rf $RPM_BUILD_ROOT
+make install DESTDIR=$RPM_BUILD_ROOT
+make install-man DESTDIR=$RPM_BUILD_ROOT
+%clean
+rm -rf $RPM_BUILD_ROOT
+%files
+%defattr(-,root,root)
+/usr/local/bin/deputy
+/usr/local/lib/deputy/bin/deputy
+/usr/local/lib/deputy/bin/deputy.asm.exe
+/usr/local/lib/deputy/bin/deputy.byte.exe
+/usr/local/lib/deputy/lib/CilConfig.pm
+/usr/local/lib/deputy/lib/Cilly.pm
+/usr/local/lib/deputy/lib/Deputy.pm
+/usr/local/lib/deputy/lib/KeptFile.pm
+/usr/local/lib/deputy/lib/TempFile.pm
+/usr/local/lib/deputy/lib/OutputFile.pm
+/usr/local/lib/deputy/lib/deputy_libc.o
+/usr/local/lib/deputy/include/libc_patch.i
+/usr/local/lib/deputy/include/deputy/annots.h
+/usr/local/lib/deputy/include/deputy/checks.h
+%doc %attr(0444,root,root) /usr/local/man/man1/deputy.1.gz
--- /dev/null
+(*
+ *
+ * Copyright (c) 2004,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 Expcompare
+open Pretty
+open Doptions
+open Dutil
+
+module E = Errormsg
+module H = Hashtbl
+module IH = Inthash
+module VS = Usedef.VS
+
+let getZeroOneAttr (names: string list) (attrs: attributes) : attribute option =
+ let filter =
+ List.filter (fun (Attr (name, _)) -> List.mem name names) attrs
+ in
+ match filter with
+ | [attr] -> Some attr
+ | [] -> None
+ | _ -> E.s (error "Too many attributes: %a." (docList text) names)
+
+let getOneAttr (names: string list) (attrs: attributes) : attribute =
+ match getZeroOneAttr names attrs with
+ | Some attr -> attr
+ | None -> E.s (bug "Couldn't find attribute: %a." (docList text) names)
+
+let isNullterm (t: typ) : bool =
+ match unrollType t with
+ | TPtr (_, a)
+ | TArray (_, _, a) -> hasAttribute "nullterm" a
+ | TInt _ -> false (* Treat integer type like void*. *)
+ | _ -> E.s (bug "Expected pointer type: %a" d_type t)
+
+let isNulltermDrop (t: typ) : bool =
+ match unrollType t with
+ | TPtr (_, a) -> hasAttribute "ntdrop" a
+ | _ -> false
+
+let isNulltermExpand (t: typ) : bool =
+ match unrollType t with
+ | TPtr (_, a) -> hasAttribute "ntexpand" a
+ | _ -> false
+
+let isSizePtr (t: typ) : bool =
+ match unrollType t with
+ | TPtr (_, a) -> hasAttribute "size" a || hasAttribute "fancysize" a
+ | _ -> false
+
+let isTrustedAttr (attr: attributes) : bool =
+ hasAttribute "trusted" attr
+
+let isTrustedType (t: typ) : bool =
+ isTrustedAttr (typeAttrs t)
+
+let isTrustedComp (ci: compinfo) : bool =
+ isTrustedAttr ci.cattr
+
+let isNonnullType (t:typ) : bool =
+ hasAttribute "nonnull" (typeAttrs t)
+
+let isHiddenVar (vi: varinfo) : bool =
+ vi.vdescr <> nil ||
+ hasAttribute "hidden" vi.vattr
+
+let rec typeContainsNonnull (t: typ) : bool =
+ (isNonnullType t) ||
+ (match t with
+ | TPtr _
+ | TFun _
+ | TBuiltin_va_list _
+ | TVoid _
+ | TInt _
+ | TFloat _
+ | TEnum _ -> false
+ | TArray (bt, _, _) -> typeContainsNonnull bt
+ | TNamed (ti, _) -> typeContainsNonnull ti.ttype
+ | TComp (ci, _) ->
+ not ci.cdefined ||
+ List.exists (fun fld -> typeContainsNonnull fld.ftype) ci.cfields)
+
+(* Keyword in bounds attributes representing the current value *)
+let thisKeyword = "__this"
+
+(* Keyword in bounds attributes representing the automatic bounds *)
+let autoKeyword = "__auto"
+
+(* Note that we use PlusA here instead of PlusPI in order to match actual
+ * annotations as parsed by CIL. *)
+let countAttr (a: attrparam) : attribute =
+ Attr ("bounds", [ACons (thisKeyword, []);
+ ABinOp (PlusA, ACons (thisKeyword, []), a)])
+
+let count0Attr : attribute =
+ countAttr (AInt 0)
+
+let sizeAttr (a: attrparam) : attribute =
+ Attr ("size", [a])
+
+let safeAttr : attribute =
+ countAttr (AInt 1)
+
+let nulltermAttr : attribute =
+ Attr ("nullterm", [])
+
+let autoAttr : attribute =
+ Attr ("bounds", [ACons (autoKeyword, []); ACons (autoKeyword, [])])
+
+let autoEndAttr : attribute =
+ Attr ("bounds", [ACons (thisKeyword, []); ACons (autoKeyword, [])])
+
+(* NTS == NULLTERM COUNT(0) *)
+let stringAttrs : attributes =
+ addAttribute nulltermAttr [count0Attr]
+
+let trustedAttr : attribute =
+ Attr ("trusted", [])
+
+let sentinelAttr : attribute =
+ Attr ("sentinel", [])
+
+let hiddenAttr : attribute =
+ Attr ("hidden", [])
+
+(* SNT == COUNT(0) + the "sentinel" qualifier *)
+let sentinelAttrs : attributes =
+ addAttribute sentinelAttr [count0Attr]
+
+let isSentinelType (t:typ): bool =
+ let res = hasAttribute "sentinel" (typeAttrs t) in
+ if res && not (isPointerType t) then
+ (error "SNT attribute on a non-pointer type %a.\n" d_type t);
+ res
+
+let isConstType (t:typ): bool =
+ hasAttribute "assumeconst" (typeAttrs t)
+
+(* This attr means that the ptr was an unannotated global/field/etc
+ that we assumed to be SAFE/NTS, as opposed to those that are annotated
+ SAFE/NTS *)
+let missingAnnotAttr : attribute = Attr ("missing_annot", [])
+let hasDefaultAnnot (a:attributes) : bool =
+ hasAttribute "missing_annot" a
+
+let isAllocator (t: typ) : bool =
+ let attrs = typeAttrs t in
+ hasAttribute "dalloc" attrs || hasAttribute "drealloc" attrs
+
+let isMemset (t: typ) : bool =
+ hasAttribute "dmemset" (typeAttrs t)
+
+let isMemcpy (t: typ) : bool =
+ hasAttribute "dmemcpy" (typeAttrs t)
+
+let isMemcmp (t: typ) : bool =
+ hasAttribute "dmemcmp" (typeAttrs t)
+
+(* Is this a function with special handling in the typechecker? *)
+let isSpecialFunction (t:typ): bool =
+ (isAllocator t) || (isMemset t) || (isMemcpy t) || (isMemcmp t)
+
+(**************************************************************************)
+
+
+let allGlobalVars : varinfo list ref = ref []
+
+(** constGlobalVars is the subset of allGlobalVars which have constant
+ types. We allow anything to depend on these values.
+ FIXME: this is unsound, since const is not enforced. *)
+let constGlobalVars : varinfo list ref = ref []
+
+let registerGlobal (vi:varinfo): unit =
+ assert(vi.vglob);
+ allGlobalVars := vi :: !allGlobalVars;
+ if isConstType vi.vtype then
+ constGlobalVars := vi :: !constGlobalVars;
+ ()
+
+let isGlobalArray (name:string): bool =
+ List.exists (fun vi -> vi.vname = name && isArrayType vi.vtype)
+ !allGlobalVars
+
+(* If the user passes --deputyglobaldeps to Deputy, we'll allow non-static
+ globals to depend on each other. This is unsound unless all files see
+ all relevant dependencies. *)
+let globalsEnv (vi:varinfo) : varinfo list =
+ assert (vi.vglob);
+(* if !allowAllGlobalDeps then *)
+ !allGlobalVars
+(* else if vi.vstorage = Static then *)
+(* !staticGlobalVars *)
+(* else *)
+(* [vi] (\* can depend only on itself *\) *)
+
+
+(**************************************************************************)
+
+
+(* remember complicated bounds expressions *)
+let boundsTable : exp IH.t = IH.create 13
+let boundsTableCtr : int ref = ref 0
+
+(* expectedType is the type of the pointer that depends on this
+ expression. We'll cast to this type so that pointer arithmetic works. *)
+let addBoundsExp ~(expectedType:typ) (e: exp) : int =
+ (* First, cast the bound expression e to the expected type *)
+ let e': exp =
+ let boundType = typeOf e in
+ if compareTypes ~ignoreSign:false boundType expectedType
+ || isArrayType expectedType then
+ (* no cast needed *)
+ e
+ else if (isPtrOrArray boundType) && (isPointerType expectedType) then
+ begin
+ let boundBase = baseType "addBoundsExp" boundType in
+ let ptrBase = baseType "addBoundsExp" expectedType in
+ if compareTypes ~ignoreSign:false boundBase ptrBase then
+ (* no cast needed *)
+ e
+ else if ( (not (typeContainsPointers boundBase))
+ && (not (typeContainsPointers ptrBase)))
+ || (bitsSizeOf boundBase) = (bitsSizeOf ptrBase) then
+ begin
+ (* Cast the bound to the pointer's type *)
+ mkCastT ~e:e ~oldt:boundType ~newt:expectedType
+ end
+ else begin
+ (* Maybe we should do this check in checkType? *)
+ error "The base type of a pointer differs from the base type of its bound expressions.";
+ e
+ end
+ end
+ else begin
+ (* Cast between an integer and a pointer. Is it okay to use
+ an int as the bound of a pointer? *)
+ mkCastT ~e:e ~oldt:boundType ~newt:expectedType
+ end
+ in
+ incr boundsTableCtr;
+ if !verbose then
+ E.log "%a: fancybounds(%d) = %a.\n" d_loc !currentLoc
+ !boundsTableCtr d_exp e';
+ IH.add boundsTable !boundsTableCtr e';
+ !boundsTableCtr
+
+let getBoundsExp (n: int) : exp =
+ try
+ IH.find boundsTable n
+ with Not_found ->
+ E.s (bug "Couldn't look up expression in bounds table")
+
+let clearBoundsTable () : unit =
+ IH.clear boundsTable;
+ boundsTableCtr := 0
+
+type paramkind =
+| PKNone
+| PKThis
+| PKOffset of attrparam
+
+let rec checkParam (ap: attrparam) : paramkind =
+ match ap with
+ | ACons (name, []) when name = thisKeyword -> PKThis
+ | ABinOp (PlusA, a1, a2) when checkParam a1 = PKThis ->
+ if a2 = AInt 0 then PKThis else PKOffset a2
+ | _ -> PKNone
+
+class deputyPrinterClass ~(showBounds: bool) ~(enable: bool) : descriptiveCilPrinter =
+object (self)
+ inherit descriptiveCilPrinterClass enable as super
+
+ method pExp () (e: exp) : doc =
+ let truncate s =
+ if String.length s > 40 then
+ "\"" ^ String.sub s 0 36 ^ "\" ..."
+ else
+ "\"" ^ s ^ "\""
+ in
+ match e with
+ | Const (CStr s) ->
+ text (truncate (Escape.escape_string s))
+ | Const (CWStr s) ->
+ let s' =
+ List.fold_left
+ (fun acc elt ->
+ let elt' =
+ if (elt >= Int64.zero &&
+ elt <= (Int64.of_int 255)) then
+ Escape.escape_char (Char.chr (Int64.to_int elt))
+ else
+ Printf.sprintf "\\x%LX\" \"" elt
+ in acc ^ elt')
+ "" s
+ in
+ text ("L" ^ truncate s')
+ | _ -> super#pExp () e
+
+ method pAttr (Attr (an, args) : attribute) : doc * bool =
+ match an, args with
+ | "fancybounds", [AInt i1; AInt i2] ->
+ if showBounds then
+ dprintf "BND(%a, %a)" self#pExp (getBoundsExp i1)
+ self#pExp (getBoundsExp i2), false
+ else
+ text "BND(...)", false
+ | "bounds", [a1; a2] ->
+ begin
+ match checkParam a1, checkParam a2 with
+ | PKThis, PKThis ->
+ text "COUNT(0)", false
+ | PKThis, PKOffset (AInt 1) ->
+ text "SAFE", false
+ | PKThis, PKOffset a ->
+ if showBounds then
+ dprintf "COUNT(%a)" self#pAttrParam a, false
+ else
+ text "COUNT(...)", false
+ | _ ->
+ if showBounds then
+ dprintf "BND(%a, %a)" self#pAttrParam a1
+ self#pAttrParam a2, false
+ else
+ text "BND(...)", false
+ end
+ | "fancysize", [AInt i] ->
+ dprintf "SIZE(%a)" self#pExp (getBoundsExp i), false
+ | "size", [a] ->
+ dprintf "SIZE(%a)" self#pAttrParam a, false
+ | "fancywhen", [AInt i] ->
+ dprintf "WHEN(%a)" self#pExp (getBoundsExp i), false
+ | "when", [a] ->
+ dprintf "WHEN(%a)" self#pAttrParam a, false
+ | "nullterm", [] ->
+ text "NT", false
+ | "assumeconst", [] ->
+ text "ASSUMECONST", false
+ | "trusted", [] ->
+ text "TRUSTED", false
+ | "copytype", [] ->
+ text "COPYTYPE", false
+ | "typaram", [ASizeOf t] ->
+ dprintf "TP(%a)" (self#pType None) t, false
+ | "sentinel", [] ->
+ text "SNT", false
+ | "nonnull", [] ->
+ text "NONNULL", false
+ | "dalloc", [a] ->
+ dprintf "DALLOC(%a)" self#pAttrParam a, false
+ | "dmemset", [AInt i1; AInt i2; AInt i3] ->
+ dprintf "DMEMSET(%d, %d, %d)" i1 i2 i3, false
+ | "dmemcpy", [AInt i1; AInt i2; AInt i3] ->
+ dprintf "DMEMCPY(%d, %d, %d)" i1 i2 i3, false
+ | "dmemcmp", [AInt i1; AInt i2; AInt i3] ->
+ dprintf "DMEMCMP(%d, %d, %d)" i1 i2 i3, false
+ | "_ptrnode", [AInt n] ->
+ if !Doptions.emitGraphDetailLevel >= 3 && showBounds then
+ dprintf "NODE(%d)" n, false
+ else
+ nil, false
+ | "missing_annot", _-> (* Don't bother printing thess *)
+ nil, false
+ | "ntdrop", [] ->
+ text "NTDROP", false
+ | ("always_inline" | "section" | "format" |
+ "noreturn" | "regparm" | "aligned"), _ ->
+ nil, false
+ | _ ->
+ super#pAttr (Attr (an, args))
+
+ method pType (nameOpt: doc option) () (t: typ) : doc =
+ match unrollType t with
+ | TPtr (TVoid _, attrs) when hasAttribute "tyvar" attrs ->
+ let name =
+ match nameOpt with
+ | Some name -> text " " ++ name
+ | None -> nil
+ in
+ let tyvar =
+ match filterAttributes "tyvar" attrs with
+ | Attr ("tyvar", [ACons (s, [])]) :: _ -> s
+ | _ -> E.s (bug "Unexpected attribute.")
+ in
+ dprintf "TV(%s)%a" tyvar insert name
+ | _ ->
+ super#pType nameOpt () t
+end
+
+let deputyFilePrinter = new deputyPrinterClass ~showBounds:true ~enable:false
+let deputyPrinter = new deputyPrinterClass ~showBounds:true ~enable:true
+
+let dx_type () (t: typ) : doc =
+ deputyPrinter#pType None () t
+
+let dx_exp () (e: exp) : doc =
+ deputyPrinter#pExp () e
+
+let dx_lval () (lv: lval) : doc =
+ deputyPrinter#pLval () lv
+
+let dx_instr () (i : instr) : doc =
+ deputyPrinter#pInstr () i
+
+let dx_global () (g : global) : doc =
+ deputyPrinter#pGlobal () g
+
+let dx_temps () : doc =
+ deputyPrinter#pTemps ()
+
+let startTemps () : unit =
+ deputyPrinter#startTemps ()
+
+let stopTemps () : unit =
+ deputyPrinter#stopTemps ()
+
+let deputyTypePrinter = new deputyPrinterClass ~showBounds:false ~enable:true
+
+let dt_type () (t: typ) : doc =
+ deputyTypePrinter#pType None () t
+
+let dt_exp () (e: exp) : doc =
+ deputyTypePrinter#pExp () e
+
+let dt_lval () (lv: lval) : doc =
+ deputyTypePrinter#pLval () lv
+
+let dt_instr () (i : instr) : doc =
+ deputyTypePrinter#pInstr () i
+
+(** Terse printing: strip some casts from the expression.
+ We use this to make runtime errors more legible. *)
+let dc_exp () e =
+ dx_exp () (deputyStripCastsForPtrArith e)
+
+
+let addTempInfoSet (vi: varinfo) (e: exp) : unit =
+ vi.vdescr <- (dx_exp () e);
+ vi.vdescrpure <- true
+
+let addTempInfoCall (vi: varinfo) (fn: exp) (args: exp list) : unit =
+ vi.vdescr <- (dprintf "%a(%a)" dx_exp fn
+ (docList ~sep:(text ", ") (dx_exp ())) args);
+ vi.vdescrpure <- false
+
+(* Don't print leading or trailing underscores on attributes *)
+class deputyPatchPrinterClass : cilPrinter = object (self)
+ inherit defaultCilPrinterClass as super
+
+ method pAttr (a: attribute) : doc * bool =
+ let (d, b) = super#pAttr a in
+ let s = sprint ~width:1000 d in
+ let s = if String.length s >= 2 &&
+ String.sub s 0 2 = "__"
+ then String.sub s 2 ((String.length s) - 2)
+ else s
+ in
+ let s = if String.length s >= 2 &&
+ String.sub s ((String.length s) - 2) 2 = "__"
+ then String.sub s 0 ((String.length s) - 2)
+ else s
+ in
+ text s, b
+end
+
+let deputyPatchPrinter = new deputyPatchPrinterClass
+
+let dp_global () (g : global) : doc =
+ printGlobal deputyPatchPrinter () g
+
+
+
+(**************************************************************************)
+
+
+(* remember complicated WHEN expressions. For each union in each context,
+ we have a whenMap, which maps fields to the expanded when condition for that
+ field in the context. *)
+type whenMap = (fieldinfo * exp) list
+let whenTable : whenMap IH.t = IH.create 13
+let whenTableCtr : int ref = ref 0
+let d_whenMap () (wm:whenMap) : doc =
+ Pretty.align ++
+ docList ~sep:line
+ (fun (f,e) -> text f.fname ++ text ": " ++ dx_exp () e)
+ () wm
+ ++ Pretty.unalign
+
+let addWhenMap (wm:whenMap) : int =
+ incr whenTableCtr;
+ if !verbose then
+ E.log "%a: fancywhen(%d) = [%a].\n" d_loc !currentLoc
+ !whenTableCtr d_whenMap wm;
+ IH.add whenTable !whenTableCtr wm;
+ !whenTableCtr
+
+let getWhenMap (n: int) : whenMap =
+ try
+ IH.find whenTable n
+ with Not_found ->
+ E.s (E.bug "couldn't look up %d in when table\n" n)
+
+(** If possible, determine statically which field is selected by this map. *)
+let getSelectedField (wm:whenMap) : fieldinfo option =
+ let rec loop : (fieldinfo * exp) list -> fieldinfo option = function
+ (f, e)::rest -> begin
+ match isInteger (constFold true e) with
+ Some 0L -> (* constant false. *)
+ loop rest
+ | Some _ -> (* constant true. If every selector in rest is false,
+ we've found the field we're looking for. *)
+ let ensureSelectorIsFalse (f',e): bool =
+ match isInteger (constFold true e) with
+ Some 0L -> true (* okay *)
+ | Some _ ->
+ (* Fields f and f' are both selected. Warn the user.
+ This is an error unless the union is nulled. *)
+ warn "Setting this tag makes two fields active: %s and %s.\n"
+ f'.fname f.fname;
+ false
+ | None ->
+ (* We don't know whether this field is selected.
+ Be conservative. *)
+ false
+ in
+ let allFalse = List.for_all ensureSelectorIsFalse rest in
+ if allFalse then Some f else None
+ | None -> None (* not a constant *)
+ end
+ | [] -> None
+ in
+ loop wm
+
+
+(**************************************************************************)
+
+let rec getDeps (a: attrparam) : string list =
+ match a with
+ | AInt k -> []
+ | ASizeOf t -> []
+ | ASizeOfE e -> []
+ | ACons(name, []) ->
+ if isGlobalArray name then
+ [] (* This is really a depenency on a static address (StartOf name),
+ not a runtime value *)
+ else if List.exists (fun vi -> vi.vname = name) !constGlobalVars then
+ [] (* We don't count dependencies on const locations here,
+ because this global need not be in the context. *)
+ else
+ [name]
+ | ABinOp (_, e1, e2) -> (getDeps e1) @ (getDeps e2)
+ | AAddrOf a -> getDeps a (* matth: this is too conservative.
+ &name depends on nothing, but for other
+ values of a there could be dependencies *)
+ | AIndex (a1, a2) -> (getDeps a1) @ (getDeps a2)
+ | AUnOp(_, e1) -> getDeps e1
+ | _ -> E.s (error "Cannot get dependencies for %a" d_attrparam a)
+
+
+(** Gets the names on which the bounds of this type depends.
+ The type argument is just for error reporting. *)
+let rec depsOfAttrs ~(missingBoundsOkay:bool)
+ (t:typ) (a: attributes) : string list =
+ let checkrest rest =
+ if hasAttribute "bounds" rest ||
+ hasAttribute "fancybounds" rest ||
+ hasAttribute "size" rest ||
+ hasAttribute "fancysize" rest then
+ E.s (error "Type has duplicate bounds attributes: \"%a\"" dx_type t)
+ in
+ match a with
+ | Attr ("bounds", [lo; hi]) :: rest ->
+ checkrest rest;
+ (getDeps lo) @ (getDeps hi)
+ | Attr ("bounds", _) :: rest ->
+ E.s (error "Illegal bounds annotations on \"%a\"" dx_type t)
+ | Attr ("fancybounds", _) :: rest ->
+ E.s (bug "Can't get dependencies for fancybounds annotations")
+ | Attr ("size", [n]) :: rest ->
+ checkrest rest;
+ getDeps n
+ | Attr ("size", _) :: rest ->
+ E.s (error "Illegal size annotation on \"%a\"" dx_type t)
+ | Attr ("fancysize", _) :: rest ->
+ E.s (bug "Can't get dependencies for fancysize annotations")
+ | Attr _ :: rest ->
+ depsOfAttrs ~missingBoundsOkay t rest
+ | [] ->
+ if missingBoundsOkay then
+ []
+ else
+ E.s (bug "Missing bounds information on \"%a\"" dx_type t)
+
+let rec getWhen (a: attributes) : attrparam =
+ let checkrest rest =
+ if hasAttribute "when" rest then
+ E.s (error "Field has more than one WHEN attribute")
+ in
+ match a with
+ | Attr ("when", [e]) :: rest ->
+ checkrest rest;
+ e
+ | Attr ("when", _) :: rest ->
+ E.s (error "Illegal when annotations.")
+ | Attr _ :: rest ->
+ getWhen rest
+ | [] ->
+ raise Not_found
+
+let depsOfWhenAttrs (a: attributes) : string list =
+ let w = getWhen a in
+ getDeps w
+
+let depsOfField (fld: fieldinfo) : string list =
+ try depsOfWhenAttrs fld.fattr
+ with Not_found -> []
+
+let depsOfType ?(missingBoundsOkay=false) (t: typ) : string list =
+ match unrollType t with
+ | TPtr (_, a) -> depsOfAttrs ~missingBoundsOkay t a
+ | TArray (_, _, a) when isOpenArray t -> depsOfAttrs ~missingBoundsOkay t a
+ | TComp (ci,_) when not ci.cstruct ->
+ List.fold_left
+ (fun acc fld -> (depsOfField fld) @ acc)
+ [] ci.cfields
+ | _ -> []
+
+(* Determine whether other variables/fields depend on a given name. *)
+let hasExternalDeps (lv: lval) : bool =
+ let hasDeps (n: string) (vars: (string * typ) list) : bool =
+ List.fold_left
+ (fun acc (name, t) ->
+ acc || (name <> n && List.mem n (depsOfType t)))
+ false
+ vars
+ in
+ let lv', off = removeOffsetLval lv in
+ match off with
+ | NoOffset ->
+ begin
+ match fst lv with
+ | Var vi ->
+ let env =
+ if not vi.vglob then
+ !curFunc.slocals @ !curFunc.sformals
+ else
+ globalsEnv vi
+ in
+ let vars = List.map (fun vi -> vi.vname, vi.vtype) env in
+ hasDeps vi.vname vars
+ | Mem e ->
+ false
+ end
+ | Field (fld, NoOffset) ->
+ let vars =
+ List.map (fun fld -> fld.fname, fld.ftype) fld.fcomp.cfields
+ in
+ hasDeps fld.fname vars
+ | Index (_, NoOffset) ->
+ (* No one depends on array elements.
+ FIXME: what about arrays inside null-terminated arrays? *)
+ false
+ | _ -> E.s (bug "Unexpected result from removeOffset")
+
+(* A context maps variable/field names to the corresponding CIL expr.
+ * We also add a boolean indicating whether this string corresponds
+ * to a temporary (for error reporting purposes). *)
+type context = (string * bool * exp) list
+
+(* Print the names in a context, separated by commas *)
+let d_ctx: unit -> context -> doc =
+ docList ~sep:(text ", ") (fun (s, _, _) -> text s)
+
+let d_ctx_simple () (ctx: context) : doc =
+ d_ctx () (List.filter (fun (_, b, _) -> not b) ctx)
+
+let formalsContext (f:fundec) : context =
+ List.fold_left
+ (fun acc v -> (v.vname, isHiddenVar v, Lval (var v)) :: acc)
+ []
+ f.sformals
+
+let localsContext (f:fundec) : context =
+ List.fold_left
+ (fun acc v -> (v.vname, isHiddenVar v, Lval (var v)) :: acc)
+ (formalsContext f)
+ f.slocals
+
+(* A subset of localsContext. It includes only the vars in the given set. *)
+let liveLocalsContext (vars: VS.t) : context =
+ VS.fold
+ (fun v acc -> (v.vname, isHiddenVar v, Lval (var v)) :: acc)
+ vars
+ []
+
+let globalsContext (vi:varinfo) : context =
+ List.fold_left
+ (fun acc v -> (v.vname, isHiddenVar v, Lval (var v)) :: acc)
+ []
+ (globalsEnv vi)
+
+let structContext (lv: lval) (ci: compinfo) : context =
+ List.fold_left
+ (fun acc fld ->
+ (fld.fname, false, Lval (addOffsetLval (Field (fld, NoOffset)) lv))
+ :: acc)
+ []
+ ci.cfields
+
+let allContext () : context =
+ List.fold_left
+ (fun acc v -> (v.vname, isHiddenVar v, Lval (var v)) :: acc)
+ []
+ (!allGlobalVars @
+ !curFunc.sformals @ !curFunc.slocals)
+
+
+(**************************************************************************)
+
+
+(** The dependent types are expressed using attributes. We compile an
+ * attribute given a mapping from names to lvals. Returns the names of
+ * meta values that this annotation depends on, and the expression.
+ *
+ * This is a helper for both fields and formals. *)
+let rec compileAttribute
+ ?(deputyAttrsOnly=true)(* Allow only Deputy's "local" dependencies. If
+ false, we allow star to appear in the annotation.*)
+ (ctx: context) (* Should include a mapping for thisKeyword *)
+ (a: attrparam)
+ : string list * exp =
+ let rec compile (a: attrparam) =
+ match a with
+ AInt k -> [], integer k
+ | ASizeOf t -> [], SizeOf t
+ | ASizeOfE e ->
+ let _, e' = compileAttribute (allContext ()) e in
+ [], SizeOfE e'
+ | ACons(name, []) -> begin
+ try begin
+ let _, _, e = List.find (fun (n, _, _) -> n = name) ctx in
+ (* Perhaps this is an array name. Turn it into StartOf *)
+ match unrollType (typeOf e) with
+ | TArray (bt, _, _) -> begin
+ match stripNopCasts e with
+ Lval lv -> [name], StartOf lv
+ | _ -> E.s (bug "Array dependency %s (%a) is not an lval"
+ name dx_exp e)
+ end
+ | TPtr (TVoid _, _) ->
+ [name], mkCast e (TPtr (charType, sentinelAttrs))
+ | _ -> [name], e
+ end with Not_found -> begin
+ if isGlobalArray name then
+ let vi = List.find (fun vi -> vi.vname = name) !allGlobalVars in
+ [], StartOf (var vi)
+ else if List.exists (fun vi -> vi.vname=name) !constGlobalVars then
+ (* a constant global. *)
+ let vi = List.find (fun vi -> vi.vname = name) !constGlobalVars in
+ [], Lval (var vi)
+ else
+ E.s (error
+ ("Cannot compile the dependency %a: " ^^
+ "Cannot find %s in the context.")
+ d_attrparam a
+ name)
+ end
+ end
+ | AIndex (aa, ai) -> begin
+ let lva, ea = compile aa in
+ let lvi, ei = compile ai in
+ (* ea must be an array. It was turned into a StartOf *)
+ match ea with
+ StartOf lvala ->
+ lva @ lvi, Lval (addOffsetLval (Index(ei, NoOffset)) lvala)
+ | _ -> E.s (error "Cannot compile the dependency %a. Index used on a non-array" d_attrparam a)
+ end
+
+ | AAddrOf aa -> begin
+ let lva, ea = compile aa in
+ match ea with
+ Lval lv -> lva, mkAddrOrStartOf lv
+ | _ -> E.s (error "Cannot compiler the dependency %a. Address-of used on a non-lvalue" d_attrparam a)
+ end
+ | ABinOp (bop, e1, e2) ->
+ let lv1', e1' = compile e1 in
+ let lv2', e2' = compile e2 in
+ (* now that we know the types of these expressions,
+ fix any MinusA/PlusA that should be pointer arithmetic. *)
+ let bop' = match bop, isPointer e1', isPointer e2' with
+ MinusA, true, true -> MinusPP
+ | MinusA, true, false -> MinusPI
+ | PlusA, true, false -> PlusPI
+ | _ -> bop
+ in
+ let t' = typeAddAttributes sentinelAttrs (typeOf e1') in
+ lv1' @ lv2', BinOp(bop', e1', e2', t')
+ | AUnOp (uop, e1) ->
+ let lv1', e1' = compile e1 in
+ let t = match uop with
+ Neg | BNot -> typeOf e1'
+ | LNot -> intType
+ in
+ lv1', UnOp(uop, e1', t)
+ | AStar(e1) when not deputyAttrsOnly ->
+ let lv1', e1' = compile e1 in
+ let res = mkMem ~addr:e1' ~off:NoOffset in
+ lv1', Lval(res)
+ | _ -> E.s (error "Cannot compile the dependency %a" d_attrparam a)
+ in
+ compile a
+
+(* Bounds attribute *)
+
+type bounds =
+| BSimple of attrparam * attrparam
+| BFancy of exp * exp
+
+let rec getBounds (a: attributes) : bounds =
+ let checkrest rest =
+ if hasAttribute "bounds" rest ||
+ hasAttribute "fancybounds" rest then
+ E.s (error "Type has duplicate bounds attributes: %a" d_attrlist a)
+ in
+ match a with
+ | Attr ("bounds", [lo; hi]) :: rest ->
+ checkrest rest;
+ BSimple (lo, hi)
+ | Attr ("fancybounds", [AInt lo; AInt hi]) :: rest ->
+ checkrest rest;
+ BFancy (getBoundsExp lo, getBoundsExp hi)
+ | Attr _ :: rest ->
+ getBounds rest
+ | [] ->
+ E.s (bug "Missing bounds information")
+
+let boundsOfAttrs (ctx: context) (a: attributes) : exp * exp =
+ match getBounds a with
+ | BSimple (lo, hi) ->
+ (* Compile lo, hi into expressions *)
+ let lodeps, lo' = compileAttribute ctx lo in
+ let hideps, hi' = compileAttribute ctx hi in
+ lo', hi'
+ | BFancy _ ->
+ E.s (error "Found fancybounds instead of bounds annotations")
+
+let fancyBoundsOfAttrs (a: attributes) : exp * exp =
+ match getBounds a with
+ | BSimple (lo, hi) ->
+ E.s (error "Found bounds instead of fancybounds annotations")
+ | BFancy (lo, hi) ->
+ lo, hi
+
+let fancyBoundsOfType (t: typ) : exp * exp =
+ match unrollType t with
+ | TPtr (_, a)
+ | TArray (_, _, a) -> fancyBoundsOfAttrs a
+ | _ -> E.s (error "Expected pointer or array type")
+
+let makeFancyBoundsAttr ~(expectedType:typ) (lo: exp) (hi: exp) : attribute =
+ Attr ("fancybounds",
+ [AInt (addBoundsExp ~expectedType lo); AInt (addBoundsExp ~expectedType hi)])
+
+let makeFancyPtrType ?(nullterm:bool=false) (bt: typ) (lo: exp) (hi: exp)
+ : typ =
+ let boundsAttr =
+ [makeFancyBoundsAttr ~expectedType:(TPtr (bt, sentinelAttrs)) lo hi] in
+ let attrs = if nullterm then
+ addAttribute nulltermAttr boundsAttr
+ else
+ boundsAttr
+ in
+ TPtr (bt, attrs)
+
+(* Size attribute *)
+
+type size =
+| SSimple of attrparam
+| SFancy of exp
+
+let rec getSize (a: attributes) : size =
+ let checkrest rest =
+ if hasAttribute "size" rest ||
+ hasAttribute "fancysize" rest then
+ E.s (error "Type has duplicate size attributes: %a" d_attrlist a)
+ in
+ match a with
+ | Attr ("size", [n]) :: rest ->
+ checkrest rest;
+ SSimple n
+ | Attr ("fancysize", [AInt n]) :: rest ->
+ checkrest rest;
+ SFancy (getBoundsExp n)
+ | Attr _ :: rest ->
+ getSize rest
+ | [] ->
+ E.s (bug "Missing size information")
+
+let sizeOfAttrs (ctx: context) (a: attributes) : exp =
+ match getSize a with
+ | SSimple n ->
+ snd (compileAttribute ctx n)
+ | SFancy _ ->
+ E.s (error "Found fancysize instead of size annotations")
+
+let fancySizeOfAttrs (a: attributes) : exp =
+ match getSize a with
+ | SSimple _ ->
+ E.s (error "Found size instead of fancysize annotations")
+ | SFancy n ->
+ n
+
+let fancySizeOfType (t: typ) : exp =
+ match unrollType t with
+ | TPtr (_, a) -> fancySizeOfAttrs a
+ | _ -> E.s (error "Expected pointer type")
+
+let fancyBoundsOfSizeType (toType: typ) (fromType: typ) (e: exp) : exp * exp =
+ let n = fancySizeOfType fromType in
+ let elts = BinOp (Div, n, SizeOf (baseType "size type" toType), typeOf n) in
+ let toType' =
+ typeAddAttributes sentinelAttrs
+ (typeRemoveAttributes ["bounds"] toType)
+ in
+ let lo = mkCast e toType' in
+ let hi = BinOp (PlusPI, lo, elts, toType') in
+ lo, hi
+
+let makeFancySizeAttr ~(expectedType:typ) (n: exp) : attribute =
+ Attr ("fancysize", [AInt (addBoundsExp ~expectedType n)])
+
+(* When attribute *)
+
+let whenOfAttrs (ctx: context) (a: attributes) : exp =
+ let w = getWhen a in
+ let deps, e = compileAttribute ctx w in
+ e
+
+let makeFancyWhenAttr (wm: whenMap) : attribute =
+ Attr ("fancywhen", [AInt (addWhenMap wm)])
+
+let fancyWhenOfType (t: typ) : whenMap =
+ match unrollType t with
+ | TComp (_, a) -> begin
+ match filterAttributes "fancywhen" a with
+ [Attr("fancywhen", [AInt i])] -> getWhenMap i
+ | _ -> E.s (bug "missing (or malformed) fancywhen: %a" d_attrlist a)
+ end
+ | _ -> E.s (E.bug "Expected union type")
+
+(* Replace the names in type t with the corresponding expressions in ctx *)
+let substType (ctx: context) (t: typ) : typ =
+ if !verbose then
+ E.log "%a: substType %a\n" d_loc !currentLoc dx_type t;
+ match unrollType t with
+ | TVoid a when hasAttribute "tyvar" a ->
+ let tyvar =
+ match filterAttributes "tyvar" a with
+ | [Attr ("tyvar", [ACons (tyvar, [])])] -> tyvar
+ | [_] -> E.s (bug "Malformed tyvar attribute.")
+ | [] -> E.s (bug "Couldn't find tyvar attribute.")
+ | _ -> E.s (error "Too many tyvar attributes.")
+ in
+ begin
+ try
+ match List.find (fun (n, _, _) -> n = "'" ^ tyvar) ctx with
+ | _, _, SizeOf t -> t
+ | _ -> E.s (bug "Couldn't look up type for tyvar %s." tyvar)
+ with Not_found ->
+ t
+ end
+ | TPtr (bt, a) when hasAttribute "size" a ->
+ let n = sizeOfAttrs ctx a in
+ let a' = addAttribute (makeFancySizeAttr ~expectedType:intType n)
+ (dropAttribute "size" a) in
+ TPtr (bt, a')
+ | TPtr (bt, a) when hasAttribute "bounds" a ->
+ let lo, hi = boundsOfAttrs ctx a in
+ let t' = typeAddAttributes [sentinelAttr] t in
+ let a' = addAttribute (makeFancyBoundsAttr ~expectedType:t' lo hi)
+ (dropAttribute "bounds" a) in
+ TPtr (bt, a')
+ | TPtr _ ->
+ E.s (bug "Missing bounds information")
+ | TArray (bt, eo, a) when hasAttribute "bounds" a ->
+ let lo, hi = boundsOfAttrs ctx a in
+ let t' = typeAddAttributes [sentinelAttr] t in
+ let a' = addAttribute (makeFancyBoundsAttr ~expectedType:t' lo hi)
+ (dropAttribute "bounds" a) in
+ TArray (bt, eo, a')
+ | TArray _ ->
+ E.s (bug "Missing bounds information")
+ | TComp (ci, a) when not ci.cstruct && not (isTrustedComp ci) ->
+ (* a union. Create a fancywhen attr for the when clauses of each field.*)
+ let doField (acc:whenMap) (fld:fieldinfo) : whenMap =
+ try
+ let e : exp = whenOfAttrs ctx fld.fattr in (* may raise Not_found *)
+ (fld, e) :: acc
+ with Not_found ->
+ if typeContainsPointers fld.ftype then begin
+ E.s (error "Missing WHEN annotation on field %s.\n" fld.fname)
+ end else
+ (* Allow missing WHEN clauses for scalars. *)
+ acc
+ in
+ let wm = List.fold_left doField [] ci.cfields in
+ let a' = addAttribute (makeFancyWhenAttr wm) a in
+ TComp (ci, a')
+ | _ ->
+ t
+
+let emptyContext : context = []
+
+(* Add to the current context a binding for "__this".
+ t is the static type of this location, so we'll map __this to (t)e.
+ This is for the sake of pointer arithmetic that uses __this. *)
+let addThisBinding (ctx:context) (t:typ) (e:exp) : context =
+ (* First, strip dependent attributes from t.
+ We only care about the base type, so that pointer arithmetic
+ is done correctly. *)
+ let t = stripDepsFromType t in
+ let oldt = stripDepsFromType (typeOf e) in
+ let e' =
+ if isArrayType oldt || compareTypes t oldt then e
+ else mkCast ~e ~newt:t
+ in
+ (thisKeyword, true, e')::ctx
+
+let addTypeBinding (ctx:context) (name:string) (t:typ) : context =
+ ("'" ^ name, false, SizeOf t)::ctx
+
+(* Add to the current context a binding from name to e *)
+let addBinding (ctx:context) (name:string) (e:exp) : context =
+ (name, false, e)::ctx
+
+(* Check whether a binding exists. *)
+let hasBinding (ctx:context) (name:string) : bool =
+ List.exists (fun (n, _, _) -> n = name) ctx
+let hasBindings (ctx:context) (names : string list) : bool =
+ List.for_all (hasBinding ctx) names
+
+(* Visitor for replacing names in bound attributes *)
+let substTypeNameVisitor (map: (string * string) list) = object (self)
+ inherit nopCilVisitor
+
+ method vattrparam ap =
+ match ap with
+ | ACons (name, []) when List.mem_assoc name map ->
+ ChangeTo (ACons (List.assoc name map, []))
+ | _ ->
+ DoChildren
+end
+
+(* Replace the names in type t with new names *)
+let substTypeName (map: (string * string) list) (t: typ) : typ =
+ visitCilType (substTypeNameVisitor map) t
+
+(* Replace all argument types with canonical ones for the purpose of
+ * type comparisons. Warning: We don't update names of arguments, so
+ * the results of this function should only be used for type comparisons! *)
+let normalizeTypeNamesVisitor = object (self)
+ inherit nopCilVisitor
+
+ method vtype t =
+ match t with
+ | TFun (ret, argInfo, _, _) ->
+ (* TODO: Write fold_right_index instead. *)
+ let map = ref [] in
+ iter_index
+ (fun (aname, _, _) i ->
+ if aname <> "" then
+ map := (aname, "arg" ^ (string_of_int i)) :: !map)
+ (argsToList argInfo);
+ ChangeDoChildrenPost (substTypeName !map t, (fun t -> t))
+ | _ -> DoChildren
+end
+
+(* Runs the visitor above--see comment there. *)
+let normalizeTypeNames (t: typ) : typ =
+ visitCilType normalizeTypeNamesVisitor t
+
+(* If the last field of the comp is an open array, return the field with
+ * its length. *)
+let getOpenArrayLength (t: typ) : (fieldinfo * typ) option =
+ match unrollType t with
+ | TComp (ci, _) when List.length ci.cfields > 0 ->
+ let last = List.nth ci.cfields (List.length ci.cfields - 1) in
+ if isOpenArray last.ftype then begin
+ let lo, hi =
+ match getBounds (typeAttrs last.ftype) with
+ | BSimple (lo, hi) -> lo, hi
+ | BFancy _ -> E.s (bug "Expected simple bounds")
+ in
+ let len =
+ match lo, hi with
+ | ACons (this1, []),
+ ABinOp (PlusA, ACons (this2, []), ACons (name, []))
+ when this1 = thisKeyword && this2 = thisKeyword ->
+ begin
+ try
+ List.find (fun fld -> fld.fname = name) ci.cfields
+ with Not_found ->
+ E.s (bug "Invalid field name %s" name)
+ end
+ | _ ->
+ E.s (error ("Open arrays must use annotations of the form " ^^
+ "COUNT(n) for some variable n."))
+ in
+ Some (len, last.ftype)
+ end else
+ None
+ | _ -> None
+
+(* We use this for isRoot in Rmtmps. We preserve anything that CIL normally
+ would, plus globals that are named in dependencies. *)
+let treatAsRoot (f:file) : global -> bool =
+ let keepers = H.create 20 in
+ let preserveName (s: string) : unit = H.add keepers s () in
+ let doGlobal (g: global) : unit =
+ match g with
+ GVarDecl(vi, _)
+ | GVar (vi, _, _) ->
+ if not (isTrustedType vi.vtype) then
+ List.iter preserveName (depsOfType ~missingBoundsOkay:true vi.vtype);
+ | _ -> ()
+ in
+ iterGlobals f doGlobal;
+ (* Also keep strncpy so that we can transform strcpy. *)
+ preserveName "strncpy";
+ (* Now return the function that Rmtmps calls *)
+ (fun g ->
+ Rmtmps.isDefaultRoot g ||
+ (match g with
+ GVarDecl(vi, _)
+ | GVar (vi, _, _) -> H.mem keepers vi.vname || isConstType vi.vtype
+ | _ -> false))
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2006,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * Matthew Harren <matth@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 getZeroOneAttr : string list -> Cil.attributes -> Cil.attribute option
+val getOneAttr : string list -> Cil.attributes -> Cil.attribute
+val isNullterm : Cil.typ -> bool
+val isNulltermDrop : Cil.typ -> bool
+val isNulltermExpand : Cil.typ -> bool
+val isSizePtr : Cil.typ -> bool
+val isTrustedAttr : Cil.attributes -> bool
+val isTrustedType : Cil.typ -> bool
+val isTrustedComp : Cil.compinfo -> bool
+val isNonnullType : Cil.typ -> bool
+val isHiddenVar : Cil.varinfo -> bool
+val typeContainsNonnull : Cil.typ -> bool
+val thisKeyword : string
+val autoKeyword : string
+val countAttr : Cil.attrparam -> Cil.attribute
+val count0Attr : Cil.attribute
+val sizeAttr : Cil.attrparam -> Cil.attribute
+val safeAttr : Cil.attribute
+val nulltermAttr : Cil.attribute
+val autoAttr : Cil.attribute
+val autoEndAttr : Cil.attribute
+val stringAttrs : Cil.attributes
+val trustedAttr : Cil.attribute
+val sentinelAttrs : Cil.attributes
+val hiddenAttr : Cil.attribute
+val isSentinelType : Cil.typ -> bool
+val isConstType : Cil.typ -> bool
+val missingAnnotAttr : Cil.attribute
+val hasDefaultAnnot : Cil.attributes -> bool
+val isAllocator : Cil.typ -> bool
+val isMemset : Cil.typ -> bool
+val isMemcpy : Cil.typ -> bool
+val isMemcmp : Cil.typ -> bool
+val isSpecialFunction : Cil.typ -> bool
+val allGlobalVars : Cil.varinfo list ref
+val registerGlobal : Cil.varinfo -> unit
+val globalsEnv : Cil.varinfo -> Cil.varinfo list
+val clearBoundsTable : unit -> unit
+type paramkind =
+ PKNone
+ | PKThis
+ | PKOffset of Cil.attrparam
+val checkParam : Cil.attrparam -> paramkind
+class deputyPrinterClass : showBounds:bool -> enable:bool -> Cil.descriptiveCilPrinter
+val deputyFilePrinter : deputyPrinterClass
+val deputyPrinter : deputyPrinterClass
+val dx_type : unit -> Cil.typ -> Pretty.doc
+val dx_exp : unit -> Cil.exp -> Pretty.doc
+val dx_lval : unit -> Cil.lval -> Pretty.doc
+val dx_instr : unit -> Cil.instr -> Pretty.doc
+val dx_global : unit -> Cil.global -> Pretty.doc
+val dx_temps : unit -> Pretty.doc
+val dc_exp : unit -> Cil.exp -> Pretty.doc
+val startTemps : unit -> unit
+val stopTemps : unit -> unit
+val dt_type : unit -> Cil.typ -> Pretty.doc
+val dt_exp : unit -> Cil.exp -> Pretty.doc
+val dt_lval : unit -> Cil.lval -> Pretty.doc
+val dt_instr : unit -> Cil.instr -> Pretty.doc
+class deputyPatchPrinterClass : Cil.cilPrinter
+val deputyPatchPrinter : deputyPatchPrinterClass
+val dp_global : unit -> Cil.global -> Pretty.doc
+val addTempInfoSet : Cil.varinfo -> Cil.exp -> unit
+val addTempInfoCall : Cil.varinfo -> Cil.exp -> Cil.exp list -> unit
+type whenMap = (Cil.fieldinfo * Cil.exp) list
+val getSelectedField : whenMap -> Cil.fieldinfo option
+val depsOfWhenAttrs : Cil.attributes -> string list
+val depsOfType : ?missingBoundsOkay:bool -> Cil.typ -> string list
+val hasExternalDeps : Cil.lval -> bool
+type context = (string * bool * Cil.exp) list
+val d_ctx : unit -> context -> Pretty.doc
+val d_ctx_simple : unit -> context -> Pretty.doc
+val formalsContext : Cil.fundec -> context
+val localsContext : Cil.fundec -> context
+val liveLocalsContext : Usedef.VS.t -> context
+val globalsContext : Cil.varinfo -> context
+val structContext : Cil.lval -> Cil.compinfo -> context
+val allContext : unit -> context
+val compileAttribute : ?deputyAttrsOnly:bool -> context -> Cil.attrparam -> string list * Cil.exp
+type bounds =
+ BSimple of Cil.attrparam * Cil.attrparam
+ | BFancy of Cil.exp * Cil.exp
+val getBounds : Cil.attributes -> bounds
+val boundsOfAttrs : context -> Cil.attributes -> Cil.exp * Cil.exp
+val fancyBoundsOfType : Cil.typ -> Cil.exp * Cil.exp
+val makeFancyPtrType :
+ ?nullterm: bool -> Cil.typ -> Cil.exp -> Cil.exp -> Cil.typ
+type size =
+ SSimple of Cil.attrparam
+ | SFancy of Cil.exp
+val fancySizeOfType : Cil.typ -> Cil.exp
+val fancyBoundsOfSizeType : Cil.typ -> Cil.typ -> Cil.exp -> Cil.exp * Cil.exp
+val fancyWhenOfType : Cil.typ -> whenMap
+val substType : context -> Cil.typ -> Cil.typ
+val emptyContext : context
+val addThisBinding : context -> Cil.typ -> Cil.exp -> context
+val addTypeBinding : context -> string -> Cil.typ -> context
+val addBinding : context -> string -> Cil.exp -> context
+val hasBinding : context -> string -> bool
+val hasBindings : context -> string list -> bool
+val substTypeName : (string * string) list -> Cil.typ -> Cil.typ
+val normalizeTypeNames : Cil.typ -> Cil.typ
+val getOpenArrayLength : Cil.typ -> (Cil.fieldinfo * Cil.typ) option
+
+
+(* For Rmtmps *)
+val treatAsRoot: Cil.file -> Cil.global -> bool
--- /dev/null
+(*
+ *
+ * Copyright (c) 2004,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 Expcompare
+open Pretty
+open Dattrs
+open Doptions
+open Dutil
+open Dcheckdef
+open Dpoly
+
+module DO = Doptimmain
+module E = Errormsg
+module H = Hashtbl
+module IH = Inthash
+module S = Stats
+module VS = Usedef.VS
+
+module DPF = Dprecfinder
+module DCE = Dcanonexp
+
+(**************************************************************************)
+
+
+let exemptLocalVars : varinfo list ref = ref []
+
+(* Assign to each statement a unique ID. *)
+let nextStmtId : int ref = ref 0
+let assignID (s:stmt) : unit =
+ (* Make sure that no one else has assigned ID numbers *)
+ if !optLevel < 2 && s.sid <> -1 then
+ E.s (bug "Stmt already has an sid: %a\n" d_stmt s);
+ s.sid <- !nextStmtId;
+ incr nextStmtId;
+ ()
+
+(* Convert instruction lists into individual statements, and give each
+ stmt a unique id. *)
+let rec fixStmt ?(giveID : bool = true) (s:stmt) : unit =
+ if giveID then assignID s;
+ match s.skind with
+ Instr [] -> ()
+ | Instr [i] -> ()
+ | Instr il -> (* Two or more instructions *)
+ let sl = List.map mkStmtOneInstr il in
+ List.iter fixStmt sl;
+ s.skind <- Block (mkBlock sl);
+ ()
+ | If(_,b1,b2,_) ->
+ fixBlock b1;
+ fixBlock b2
+ | Switch(_,b,_,_) ->
+ fixBlock b
+ | Loop(b,_,_,_) ->
+ fixBlock b
+ | Block b -> fixBlock b
+ | TryFinally(b1,b2,_) ->
+ fixBlock b1;
+ fixBlock b2
+ | TryExcept(b1,_,b2,_) ->
+ fixBlock b1;
+ fixBlock b2
+ | _ -> ()
+
+and fixBlock ?(giveID : bool = true) (b : block) : unit =
+ List.iter (fixStmt ~giveID:giveID) b.bstmts
+
+(* Calls typeOf on an expression, but adds type attributes in appropriate
+ * cases. This allows the checker to use typeOf in a context that expects
+ * all types to be annotated. *)
+let deputyTypeOf (e: exp) : typ =
+ let t =
+ match e with
+ | AddrOf _ -> typeAddAttributes [safeAttr] (typeOf e)
+ | Const (CStr _)
+ | Const (CWStr _) -> typeAddAttributes stringAttrs (typeOf e)
+ (* StartOf should correctly inherit the array's attributes,
+ so we don't need to handle it specially. *)
+ | _ -> typeOf e
+ in
+ if isPointerType t && not (hasAttribute "bounds" (typeAttrs t)) then
+ E.s (bug "deputyTypeOf did not add attrs to %a at %a" dx_type t dx_exp e);
+ t
+
+let reportPolyFieldError (lv: lval) (fi: fieldinfo) : 'a =
+ E.s (error ("Field \"%s\" has generic type, but its containing " ^^
+ "structure has not been instantiated properly. " ^^
+ "Use the TP(...) annotation on the structure's type.\n" ^^
+ " struct type: %a\n" ^^
+ " field type: %a\n" ^^
+ " exp: %a")
+ fi.fname dx_type (TComp (fi.fcomp, []))
+ dx_type fi.ftype dx_lval lv)
+
+let reportPolyArgError (aname: string) (atype: typ) (arg: exp) : 'a =
+ E.s (error ("Formal parameter \"%s\" has generic type, but an " ^^
+ "appropriate instantiation could not be found.\n" ^^
+ " formal type: %a\n" ^^
+ " arg type: %a\n" ^^
+ " exp: %a")
+ aname dx_type atype dx_type (typeOf arg) dx_exp arg)
+
+let reportPolyRetError (fn: exp) : 'a =
+ let ret =
+ match typeOf fn with
+ | TFun (ret, _, _, _) -> ret
+ | _ -> E.s (bug "Expected function type.")
+ in
+ E.s (error ("Return type has generic type, but an appropriate " ^^
+ "instantiation could not be found.\n" ^^
+ " ret type: %a\n" ^^
+ " function: %a")
+ dx_type ret dx_exp fn)
+
+
+(**************************************************************************)
+
+
+(* Here we store extra instructions that have been inserted during the
+ * checking process. These instructions include both run-time checks
+ * and actual code. The allowChecks flag indicates whether checks should
+ * be added at this time. *)
+let allowChecks : bool ref = ref false
+let extraInstrs = ref []
+
+let startExtraInstrs () : unit =
+ if !extraInstrs <> [] then
+ E.s (bug "Extra instruction queue is not empty!")
+
+let endExtraInstrs () : instr list =
+ let extras = !extraInstrs in
+ extraInstrs := [];
+ List.rev extras
+
+let addInstr (i: instr) : unit =
+ extraInstrs := i :: !extraInstrs
+
+let addTmpSet (e: exp) : varinfo =
+ let tmp = makeTempVar !curFunc
+ (typeRemoveAttributes ["nonnull"] (deputyTypeOf e)) in
+ addTempInfoSet tmp e;
+ addInstr (Set (var tmp, e, !currentLoc));
+ tmp
+
+let addTmpCall (t: typ) (fn: exp) (args: exp list) : varinfo =
+ (* TODO: Derive t from type of fn? *)
+ let tmp = makeTempVar !curFunc
+ (typeRemoveAttributes ["nonnull"; "warn_unused_result"] t) in
+ addTempInfoCall tmp fn args;
+ addInstr (Call (Some (var tmp), fn, args, !currentLoc));
+ tmp
+
+let addCheck (c: check) : unit =
+ if !verbose then
+ log "--> %a" dn_instr (checkToInstr c);
+ if !allowChecks then
+ addInstr (checkToInstr c)
+
+let addArithChecks (lo: exp) (ptr: exp) (off : exp) (hi : exp) : unit =
+ addCheck (CNonNull ptr);
+ let t = typeOf ptr in
+ let sz = baseSize t in
+ if isNullterm t then
+ addCheck (CPtrArithNT (lo, hi, ptr, off, sz))
+ else
+ addCheck (CPtrArith (lo, hi, ptr, off, sz))
+
+(* Returns ceiling(x / n) *)
+let divCeiling (x:exp) (n:int) : exp =
+ if not (isIntegralType (typeOf x)) then
+ error "Expecting an integer, got %a" dt_exp x;
+ (* return the expression (x + n-1)/n *)
+ BinOp(Div,
+ BinOp(PlusA, x, integer (n-1), !upointType),
+ integer n,
+ !upointType)
+
+
+let addSizeChecks (t: typ) (e: exp) (bytes: exp) : unit =
+ let lo, hi = fancyBoundsOfType t in
+ if isNullterm t then begin
+ (* We need to leave the type of e alone so that CPtrArithNT can
+ work its magic. Note that divCeiling will effectively round the
+ size up to the next multiple of (baseSize t). This could cause
+ false positives in the reletively uncommon case where bytes is
+ not a multiple of (baseSize t). *)
+ let numElements = divCeiling bytes (baseSize t) in
+ addArithChecks lo e numElements hi
+ end
+ else begin
+ (* Just treat e as a char pointer *)
+ let cp e = mkCast e charPtrType in
+ addArithChecks (cp lo) (cp e) bytes (cp hi)
+ end
+
+let addCoercionCheck (lo_from: exp) (lo_to: exp) (e: exp)
+ (hi_to: exp) (hi_from: exp) (tFrom: typ) : unit =
+ (* If the lower bound has changed, do an lbound check.
+ * (we already know that lo_from <= e, so if lo_from=lo_to,
+ * we don't have to check that lo_to <= e)
+ *)
+ if !optLevel = 0 || not (DCE.canonCompareExp(*StripCasts*) lo_from lo_to) then begin
+ addCheck (CNullOrLeq(e, lo_from, lo_to, "lower bound coercion"));
+ addCheck (CNullOrLeq(e, lo_to, e, "lower bound check"));
+ end;
+ if !optLevel = 0 || not (DCE.canonCompareExp(*StripCasts*) hi_from hi_to) then begin
+ addCheck (CNullOrLeq(e, e, hi_to, "upper bound check"));
+ if isNullterm tFrom then
+ addCheck (CNullOrLeqNT(e, hi_to, hi_from, baseSize tFrom,
+ "nullterm upper bound coercion"))
+ else
+ addCheck (CNullOrLeq(e, hi_to, hi_from, "upper bound coercion"));
+ end;
+ ()
+
+
+(**************************************************************************)
+
+
+let rec expToAttr (e: exp) : attrparam option =
+ match stripNopCasts e with
+ | Lval (Var vi, NoOffset) -> Some (ACons (vi.vname, []))
+ | Const _ ->
+ begin
+ match isInteger e with
+ | Some i -> Some (AInt (to_int i))
+ | None -> None
+ end
+ | BinOp ((MinusA | PlusA) as op, e1, e2, _) ->
+ begin
+ match expToAttr e1, expToAttr e2 with
+ | Some a1, Some a2 -> Some (ABinOp (op, a1, a2))
+ | _ -> None
+ end
+ | _ -> None
+
+(* If this function frees an argument, it returns the index of that
+ * argument and its type. *)
+let getFreeArg (fnType: typ) : int option =
+ let fnAttrs = typeAttrs fnType in
+ match getZeroOneAttr ["drealloc"; "dfree"] fnAttrs with
+ | Some (Attr ("dfree", [ACons (name, [])]))
+ | Some (Attr ("drealloc", [ACons (name, []); _])) ->
+ let _, argInfo, _, _ = splitFunctionType fnType in
+ let rec getIndex lst index =
+ match lst with
+ | (argName, _, _) :: rest ->
+ if name = argName then Some index else getIndex rest (index + 1)
+ | [] -> None
+ in
+ getIndex (argsToList argInfo) 1
+ | Some (Attr ("dfree", _)) -> E.s (error "Malformed free annotation.")
+ | Some (Attr ("drealloc", _)) -> E.s (error "Malformed realloc annotation.")
+ | Some (Attr _) -> E.s (bug "Unexpected attribute.")
+ | None -> None
+
+(* Returns an expression that evaluates to the number of objects of type
+ * retType that can fit in the allocated area, as well as an expression
+ * that evaluates to the raw number of bytes allocated. *)
+let getAllocationExp (retType: typ) (fnType: typ) (args: exp list) : exp * exp =
+ let fnAttrs = typeAttrs fnType in
+ let size =
+ match getOneAttr ["dalloc"; "drealloc"] fnAttrs with
+ | Attr ("dalloc", [a])
+ | Attr ("drealloc", [_; a]) ->
+ let formals =
+ match fnType with
+ | TFun (_, argInfo, _, _) -> argsToList argInfo
+ | _ -> E.s (bug "Expected function type")
+ in
+ let ctx =
+ List.fold_right2
+ (fun (name, _, _) arg acc ->
+ if name <> "" then addBinding acc name arg else acc)
+ formals args emptyContext
+ in
+ snd (compileAttribute ctx a)
+ | Attr ("dalloc", _) -> E.s (error "Malformed alloc annotation.")
+ | Attr ("drealloc", _) -> E.s (error "Malformed realloc annotation.")
+ | Attr _ -> E.s (bug "Unexpected attribute.")
+ in
+ let retBaseType =
+ match unrollType retType with
+ | TPtr (bt, _) -> bt
+ | TInt _ -> voidType (* Treat integer types like void*. *)
+ | _ -> E.s (error "Left-hand side of allocation is not a pointer type.")
+ in
+ let count =
+ if isOpenArrayComp retBaseType then
+ one
+ else
+ let baseSize =
+ if isVoidType retBaseType then one else SizeOf retBaseType
+ in
+ let count = BinOp (Div, size, baseSize, !upointType) in
+ if isNullterm retType then
+ BinOp (MinusA, count, one, !upointType)
+ else
+ count
+ in
+ count, size
+
+let maxFunction = mkFun "deputy_max" !upointType [!upointType; !upointType]
+
+let callMax (e1: exp) (e2: exp) : exp =
+ let t =
+ typeAddAttributes (nulltermAttr :: sentinelAttrs)
+ (typeRemoveAttributes ["bounds"] (typeOf e1))
+ in
+ Lval (var (addTmpCall t maxFunction [e1; e2]))
+
+let isUpcast (btFrom: typ) (btTo: typ) : bool =
+ match unrollType btFrom with
+ | TComp (ci, _) ->
+ begin
+ try
+ compareTypes (List.hd ci.cfields).ftype btTo
+ with Failure "hd" ->
+ false
+ end
+ | _ -> false
+
+let normalizeCompareTypes (t1: typ) (t2: typ) : bool =
+ compareTypes (normalizeTypeNames t1) (normalizeTypeNames t2)
+
+let checkUnionWhen (ctx:context) (fld:fieldinfo) : unit =
+ if not (isTrustedComp fld.fcomp) then
+ try
+ let deps = depsOfWhenAttrs fld.fattr in (* may raise Not_found *)
+ let deps' = List.filter (fun n -> n <> thisKeyword) deps in
+ if not (hasBindings ctx deps) then
+ E.s (error ("Field %s of union %s depends on names " ^^
+ "that are not in scope.\n" ^^
+ " dependencies: {%a}\n" ^^
+ " names in scope: {%a}")
+ fld.fname fld.fcomp.cname
+ (docList ~sep:(text ", ") text) deps'
+ d_ctx_simple ctx)
+ with Not_found ->
+ (* Allow missing WHEN clauses for scalars. *)
+ if typeContainsPointers fld.ftype then
+ E.s (error "Missing WHEN annotation on field %s of union %s."
+ fld.fname fld.fcomp.cname)
+
+(* Determine whether a type is well-formed.
+ If this returns false, it's an error. So try to give a useful reason
+ to return false.
+ It's not necessary for ctx to contain __this. We'll add a binding for
+ __this here. *)
+let rec checkType (ctx: context) (t: typ) (where: doc) : unit =
+ let ctx = addThisBinding ctx t zero in
+ let checkPtrArrayAttrs (t: typ) : unit =
+ (* TODO: check whether base types for bounds match? *)
+ let bt =
+ match unrollType t with
+ | TPtr (bt, _)
+ | TArray (bt, _, _) -> bt
+ | _ -> E.s (bug "Expected pointer or array type")
+ in
+ let deps = if isTrustedType t then [] else depsOfType t in
+ let deps' = List.filter (fun n -> n <> thisKeyword) deps in
+ if not (hasBindings ctx deps) then begin
+ E.s (error ("Type of %a depends on names that are not in scope.\n" ^^
+ " type: %a\n" ^^
+ " dependencies: {%a}\n" ^^
+ " names in scope: {%a}")
+ insert where dx_type t
+ (docList ~sep:(text ", ") text) deps' d_ctx_simple ctx);
+ end;
+ checkType emptyContext bt where
+ in
+ match t with
+ | TPtr _ ->
+ checkPtrArrayAttrs t
+ | TArray (_, _, a) ->
+ if isOpenArray t then begin
+ if not (hasAttribute "bounds" a) && not (isTrustedAttr a) then
+ E.s (error "In %a, open array requires bounds information."
+ insert where);
+ if hasAttribute "nullterm" a then
+ E.s (error "In %a, open array cannot be nullterm."
+ insert where)
+ end;
+ checkPtrArrayAttrs t
+ | TFun (ret, argInfo, _, _) ->
+ let ctxFun =
+ List.fold_left
+ (fun acc (name, _, _) -> addBinding acc name zero)
+ emptyContext
+ (argsToList argInfo)
+ in
+ checkType ctxFun ret where;
+ List.iter
+ (fun (_, t, _) -> checkType ctxFun t where)
+ (argsToList argInfo)
+ | TComp (ci, _) when not ci.cstruct -> (* union *)
+ List.iter
+ (fun fld ->
+ (* Check union fields in the context ["__this"; fieldname].
+ * These are redundant ... I'm only including the field
+ * name because that's how we did it in the paper. *)
+ let ctxField = addBinding emptyContext fld.fname zero in
+ checkType ctxField fld.ftype
+ (dprintf "field %s of union %s" fld.fname ci.cname);
+ (* Now check the when clause. *)
+ checkUnionWhen ctx fld)
+ ci.cfields
+
+ (* Structs and typedefs are checked when defined. *)
+ | TComp _
+ | TNamed _
+ (* The following types are always well-formed. *)
+ | TVoid _
+ | TInt _
+ | TFloat _
+ | TEnum _
+ | TBuiltin_va_list _ -> ()
+
+(* Add checks for a coercion of e from tFrom to tTo.
+ Both tFrom and tTo must have fancy bounds. *)
+let rec coerceType (e: exp) ~(tFrom: typ) ~(tTo: typ) : unit =
+ if isNonnullType tTo
+ && not (isNonnullType tFrom)
+ && not (isTrustedType tFrom) then begin
+ addCheck (CNonNull e);
+ end;
+ match unrollType tFrom, unrollType tTo with
+ | t1, t2 when isTrustedType t1 || isTrustedType t2 ->
+ markLocationTrusted ();
+ ()
+ | (TInt _ | TPtr _), (TPtr _ as t2) when isZero e || isSentinelType t2 ->
+ (* Coerce NULL to pointer. Do we need to do any well-formedness checks
+ here? *)
+ ()
+
+ | TPtr _, TPtr _ when isSentinelType tFrom && not (isSentinelType tTo) ->
+ (* Sentinel pointers need not be in bounds, so it's illegal to cast
+ away the sentinel qualifier. *)
+ errorwarn "A sentinel pointer may not be cast to an ordinary pointer."
+
+ | TPtr _, TPtr _ when isSizePtr tFrom && isSizePtr tTo ->
+ let nFrom = fancySizeOfType tFrom in
+ let nTo = fancySizeOfType tTo in
+ addCheck (CLeqInt (nTo, nFrom, "pointer size coercion"))
+
+ | TPtr (btFrom, _), TPtr _ when not (isSizePtr tFrom) && isSizePtr tTo ->
+ if typeContainsPointers btFrom then
+ errorwarn "Cast from pointer containing pointers to sized type: %a"
+ dx_exp e;
+ if typeContainsNonnull btFrom then
+ errorwarn "Cast from pointer containing nonnull to sized type: %a"
+ dx_exp e;
+ let n = fancySizeOfType tTo in
+ addSizeChecks tFrom e n
+
+ | TPtr (btFrom, _), TPtr (btTo, _) when isSizePtr tFrom &&
+ not (isSizePtr tTo) ->
+ let lo, hi = fancyBoundsOfSizeType tTo tFrom e in
+ let tFrom' = makeFancyPtrType btFrom lo hi in
+ coerceType e ~tFrom:tFrom' ~tTo
+
+ | TPtr (bt1, _), TPtr (bt2, _) when normalizeCompareTypes bt1 bt2 ->
+ if isNullterm tTo && not (isNullterm tFrom) then
+ errorwarn "Cast from ordinary pointer to nullterm: %a" dx_exp e;
+ let loFrom, hiFrom = fancyBoundsOfType tFrom in
+ let loTo, hiTo = fancyBoundsOfType tTo in
+ addCoercionCheck loFrom loTo e hiTo hiFrom tFrom
+
+ (* Allow upcasts. *)
+ | TPtr (bt1, _), TPtr (bt2, _) when isUpcast bt1 bt2 ->
+ if isNullterm tTo || isNullterm tFrom then
+ errorwarn "Upcasts not allowed on nullterm sequences: %a" dx_exp e;
+ (* Check that the source has at least one element. *)
+ let loFrom, hiFrom = fancyBoundsOfType tFrom in
+ let loTo, hiTo = loFrom, BinOp (PlusPI, loFrom, one, typeOf loFrom) in
+ addCoercionCheck loFrom loTo e hiTo hiFrom tFrom;
+ (* Check that the destination has at most one element. *)
+ let loTo, hiTo = fancyBoundsOfType tTo in
+ let loFrom, hiFrom = loTo, BinOp (PlusPI, loTo, one, typeOf loTo) in
+ addCoercionCheck loFrom loTo e hiTo hiFrom tTo
+
+ (** Cast between two pointers to different base types *)
+ | TPtr (bt1, _), TPtr (bt2, _) when not (typeContainsPointers bt1) &&
+ not (typeContainsPointers bt2) ->
+ if isNullterm tTo && not (isNullterm tFrom) then
+ errorwarn "Cast from ordinary pointer to nullterm: %a" dx_exp e;
+
+ if isNullterm tTo || isNullterm tFrom then
+ E.s (unimp ("Nullterm cast with different base types:\n" ^^
+ " from: %a\n" ^^
+ " to: %a\n" ^^
+ " exp: %a")
+ dt_type tFrom dt_type tTo dx_exp e);
+ let loFrom, hiFrom = fancyBoundsOfType tFrom in
+ let loTo, hiTo = fancyBoundsOfType tTo in
+ addCoercionCheck loFrom loTo e hiTo hiFrom tFrom
+
+ (* Same as above, but for arrays--used for assigning to the length
+ * of an open array. *)
+ | TArray (bt1, _, _), TArray (bt2, _, _) when normalizeCompareTypes bt1 bt2 ->
+ if isNullterm tTo && not (isNullterm tFrom) then
+ errorwarn "Cast from ordinary pointer to nullterm: %a" dx_exp e;
+ let loFrom, hiFrom = fancyBoundsOfType tFrom in
+ let loTo, hiTo = fancyBoundsOfType tTo in
+ let e' =
+ match e with
+ | Lval lv -> StartOf lv
+ | _ -> E.s (bug "Expected lval")
+ in
+ addCoercionCheck loFrom loTo e' hiTo hiFrom tFrom
+
+ | (TInt _ | TEnum _ | TPtr _ | TFloat _ ), (TInt _ | TEnum _) ->
+ (* These are all totally safe. *)
+ ()
+ | (TInt _ | TFloat _ | TEnum _ ), TFloat _ ->
+ ()
+ | TComp (ci, _), TComp (ci', _) when ci == ci' && not ci.cstruct ->
+ let whenFrom = fancyWhenOfType tFrom in
+ let whenTo = fancyWhenOfType tTo in
+ (* If the when maps differ, it's because a WHEN clause depends on
+ something in the context that has changed, so we should ensurer the
+ union has been zeroed. *)
+ if not (Util.equals whenFrom whenTo) then begin
+ let lv = match e with Lval lv -> lv
+ | _ -> E.s (bug "union expression must be an lval.")
+ in
+ (* Maybe we know statically that a field f will be the (only) selected
+ field after the coercion. If f was also selected before the
+ coercion, then there's been no change in the selected field,
+ and we don't need to check that the union is null. *)
+ let sameFieldIsSelected =
+ match getSelectedField whenTo with
+ Some f ->
+ List.assq f whenFrom
+ | None ->
+ (* No field is selected, or we don't know which field is
+ selected. So require that the union be filled with 0. *)
+ zero
+ in
+ (* Check that either sameFieldSelected is true, or that the union
+ is filled with zeros. *)
+ addCheck (CNullUnionOrSelected(lv, sameFieldIsSelected))
+ end
+ | _ ->
+ if not (normalizeCompareTypes tFrom tTo) then
+ errorwarn ("Type mismatch in coercion:\n" ^^
+ " from: %a\n" ^^
+ " to: %a\n" ^^
+ " exp: %a")
+ dt_type tFrom dt_type tTo dx_exp e
+
+type whyExp =
+| ForInt (* This expression will be cast to an integer. *)
+| ForDeref (* This expression will be dereferenced. *)
+| ForAnything (* The catch-all case. *)
+
+type whyLval =
+| ForRead (* Reading this lval. *)
+| ForAddrOf (* Taking the address of this lval *)
+| ForWrite of exp (* Writing the specified value. Call checkExp on
+ * this exp before calling checkLval *)
+| ForCall (* Assigning the result of a call.
+ * We don't have an expression representing the new value,
+ * so we have to be more conservative *)
+
+(* Calls checkExp e, then calls coerceType to make sure that
+ e can be coerced to tTo. tTo must have fancy bounds. *)
+let rec coerceExp (e: exp) (tTo: typ) : unit =
+ (* If we're casting to a sentinel type, we omit many checks.
+ Pretend we're casting to long instead.*)
+ let tTo = if isSentinelType tTo then !upointType else tTo in
+ (* If we're casting to an int or a sentinel, do less-strict checking of e. *)
+ let why = if isIntegralType tTo then ForInt else ForAnything in
+
+ let tFrom = checkExp ~why e in
+ coerceType e ~tFrom ~tTo
+
+
+and checkExp ?(why: whyExp = ForAnything) (e: exp) : typ =
+ match e with
+ | UnOp (op, e', t) -> coerceExp e' t; t
+ | BinOp ((PlusPI | IndexPI),
+ BinOp((PlusPI | IndexPI) as op2,pe,e1,t1), e2, t2) ->
+ (* reassociate and try again *)
+ let ne = BinOp(op2,pe,BinOp(PlusA,e1,e2,typeOf e1),t1) in
+ checkExp ~why:why ne
+ | BinOp (MinusPI,
+ BinOp((PlusPI | IndexPI) as op2,pe,e1,t1), e2, t2) ->
+ (* reassociate and try again *)
+ let ne = BinOp(op2,pe,BinOp(MinusA,e1,e2,typeOf e1),t1) in
+ checkExp ~why:why ne
+ | BinOp ((PlusPI | IndexPI),
+ BinOp(MinusPI,pe,e1,t1), e2,t2) ->
+ (* reassociate and try again *)
+ let ne = BinOp(MinusPI,pe,BinOp(MinusA,e1,e2,typeOf e1),t1) in
+ checkExp ~why:why ne
+ | BinOp (MinusPI,
+ BinOp(MinusPI,pe,e1,t1), e2, t2) ->
+ (* reassociate and try again *)
+ let ne = BinOp(MinusPI,pe,BinOp(PlusA,e1,e2,typeOf e1),t1) in
+ checkExp ~why:why ne
+ | BinOp ((PlusPI | IndexPI | MinusPI) as op, e1, e2, t) ->
+ let t1 = checkExp ~why e1 in
+ (* FIXME: __this can appear in t, so we ignore it for now.
+ At some point, we should check it! *)
+ (* coerceExp e1 (substType ... t); *)
+ coerceExp e2 !upointType;
+ if isTrustedType t1 then
+ markLocationTrusted ()
+ else begin
+ let lo, hi = fancyBoundsOfType t1 in
+ let e2' =
+ match op with
+ | MinusPI -> UnOp (Neg, e2, typeOf e2)
+ | PlusPI | IndexPI -> e2
+ | _ -> E.s (bug "Unexpected operation")
+ in
+ if why = ForInt then
+ (* We're casting e to a sentinel or integer. We permit
+ sentinels to point anywhere, so skip the bounds checks. *)
+ ()
+ else if isAbstractPtr t1 then
+ E.s (error "Arithmetic on abstract pointer type %a." dx_type t1)
+ else
+ addArithChecks lo e1 e2' hi
+ end;
+ if isNullterm t1 then
+ let lo, hi = fancyBoundsOfType t1 in
+ let hi' = callMax e hi in
+ typeAddAttributes [Attr ("nullterm", [])]
+ (makeFancyPtrType (baseType "nullterm arith" t1) lo hi')
+ else
+ t1
+ | BinOp (op, e1, e2, t) -> (* Includes MinusPP *)
+ ignore (checkExp e1);
+ ignore (checkExp e2);
+ t
+ | Lval lv -> checkLval ForRead lv
+ | CastE (t, e') ->
+ if isNulltermDrop t then
+ let t' = checkExp e' in
+ let lo, hi = fancyBoundsOfType t' in
+ let bt = baseType "cast to NT" t' in
+ makeFancyPtrType bt (mkCast lo t) (mkCast hi t)
+ else begin
+ let ctx = addThisBinding (localsContext !curFunc) t e in
+ let t' = substType ctx t in
+ coerceExp e' t';
+ t'
+ end
+ | SizeOfE _
+ | AlignOfE _ ->
+ (* We don't check the inner expr because it doesn't get executed. *)
+ unrollType (typeOf e)
+
+ (* Treat "&((T* )0)->field" as an integer, and don't insert any checks. *)
+ | AddrOf (Mem (CastE(TPtr(bt, _), z)), off)
+ | StartOf (Mem (CastE(TPtr(bt, _), z)), off) when isZero z ->
+ !typeOfSizeOf
+ | AddrOf lv -> begin
+ (* Look first for the special case when the lv is an array element. *)
+ match removeOffsetLval lv with
+ | lv', Index (idx, NoOffset) ->
+ (* Turn it into StartOf array + index, so the we account for the
+ * array bounds *)
+ checkExp ~why (BinOp (PlusPI, StartOf lv', idx, typeOf (StartOf lv')))
+ | _ -> begin
+ (* There should be some shared code in checking the StartOf and
+ * AddrOf *)
+ ignore (checkLval ForAddrOf lv);
+ let bt = typeOfLval lv in
+ if List.exists (fun n -> n <> thisKeyword) (depsOfType bt) then
+ error "Cannot take address of lval (%a) that has dependencies" d_lval lv;
+ if hasExternalDeps lv then
+ error "Cannot take address of lval (%a) with external dependencies" d_lval lv;
+ (* If this is the address of an element inside an array, then take the
+ * whole array as the bounds *)
+ let lo = mkAddrOrStartOf lv in
+ let hi = BinOp (PlusPI, lo, one, typeOf lo) in
+ makeFancyPtrType bt lo hi
+ end
+ end
+ | StartOf lv ->
+ let whyLval =
+ match why with
+ | ForDeref -> ForRead
+ | _ -> ForAddrOf
+ in
+ let bt, attrs =
+ match checkLval whyLval lv with
+ | TArray (bt, _, attrs) -> bt, attrs
+ | _ -> E.s (bug "Expected array type")
+ in
+ let attrs' =
+ List.filter
+ (fun (Attr (name, _)) ->
+ name = "fancybounds" || name = "nullterm" || name = "trusted")
+ attrs
+ in
+ TPtr (bt, attrs')
+ | Const (CStr s) -> (* String literal *)
+ let len = String.length s in
+ let lo = e in
+ let hi = BinOp (PlusPI, lo, integer len, typeOf lo) in
+ makeFancyPtrType ~nullterm:true charType lo hi
+ | Const _
+ | SizeOf _
+ | SizeOfStr _
+ | AlignOf _ -> unrollType (typeOf e)
+
+and checkLval (why: whyLval) (lv: lval) : typ =
+ let lv', off = removeOffsetLval lv in
+ match off with
+ | NoOffset ->
+ assert (snd lv' = NoOffset);
+ let ctx, t =
+ match fst lv' with
+ | Mem e ->
+ let t = checkExp ~why:ForDeref e in
+ if isTrustedType t then
+ markLocationTrusted ()
+ else begin
+ if isSizePtr t then
+ error "Illegal dereference of a size pointer";
+ if isSentinelType t then
+ errorwarn "Illegal dereference of a sentinel pointer";
+ let lo, hi = fancyBoundsOfType t in
+ addCheck (CNonNull e);
+ let addUBoundChecks (): unit =
+ (* FIXME: Add overflow checking here. *)
+ (* addCheck (COverflow (e, one)); *)
+ let ePlusOne = BinOp (PlusPI, e, one, t) in
+ addCheck (CLeq (ePlusOne, hi, "pointer access check"))
+ in
+ match why with
+ | ForRead ->
+ if not (isNullterm t) then
+ addUBoundChecks ()
+ | ForAddrOf ->
+ (* check e != hi even if this is nullterm, because
+ * otherwise we could create a pointer with bounds hi,hi+1. *)
+ addUBoundChecks ()
+ | ForCall ->
+ (* Conservatively forbid assignment of a call result
+ * when e=hi. *)
+ addUBoundChecks ()
+ | ForWrite what ->
+ if isNullterm t then begin
+ if bitsSizeOf (baseType "mem write" t) > 32 then
+ unimp "Nullterm writes for base type larger than 32 bits";
+ addCheck (CWriteNT (e, hi, mkCast what intType, baseSize t))
+ end else
+ addUBoundChecks ()
+ end;
+ let bt =
+ match unrollType t with
+ | TPtr (bt, _) -> bt
+ | _ -> E.s (bug "Expected pointer type.")
+ in
+ emptyContext, bt
+ | Var vi ->
+ let ctx =
+ if not vi.vglob then
+ localsContext !curFunc
+ else
+ globalsContext vi
+ in
+ ctx, vi.vtype
+ in
+ let ctx' = addThisBinding ctx t (Lval lv) in
+ substType ctx' t
+ | Field (fld, NoOffset) ->
+ let compType =
+ (* If why = ForWrite, then we are writing to a field or element of
+ * lv'. It doesn't make sense to say that we are writing "e" to the
+ * entire lval, so use the more conservative ForCall instead. *)
+ let why' = match why with
+ | ForWrite e -> ForCall
+ | _ -> why
+ in
+ unrollType (checkLval why' lv')
+ in
+ let ftype' =
+ try
+ polySubst (polyCompMap compType) fld.ftype
+ with PolyError ->
+ reportPolyFieldError lv fld
+ in
+ if fld.fcomp.cstruct then begin
+ let ctx = structContext lv' fld.fcomp in
+ let ctx' = addThisBinding ctx ftype' (Lval lv) in
+ substType ctx' ftype'
+ end else begin (* Union *)
+ (* check the field access *)
+ if isTrustedComp fld.fcomp then
+ markLocationTrusted ()
+ else
+ checkUnionAccess why compType fld;
+ (* now do the type of the field itself *)
+ let value = Lval lv in
+ let ctx = addBinding emptyContext fld.fname value in
+ let ctx' = addThisBinding ctx ftype' value in
+ substType ctx' ftype'
+ end
+ | Index (index, NoOffset) ->
+ (* Convert to pointer arithmetic for checking. *)
+ let p = StartOf lv' in
+ checkLval why (Mem (BinOp (PlusPI, p, index, typeOf p)), NoOffset)
+ | _ -> E.s (bug "Unexpected result from removeOffset")
+
+and checkUnionAccess (why:whyLval) (compType: typ) (fld:fieldinfo): unit =
+ if (why = ForAddrOf) then
+ E.s (error "Can't take the address of a union field");
+ let wm = fancyWhenOfType compType in
+ (* Check the selector for the current field. *)
+ (try
+ let s = List.assq fld wm in
+ addCheck (CSelected s)
+ with Not_found -> () (* a scalar field without a WHEN *)
+ );
+ if why <> ForRead then begin
+ (* Check that the other selectors are 0 *)
+ List.iter
+ (fun (f,s) -> if f != fld then
+ addCheck (CNotSelected s))
+ wm
+ end;
+ ()
+
+let checkSetEnv (ctx: context) (x: 'a) (e: exp) (env: 'a list)
+ (expOf: 'a -> exp) (nameOf: 'a -> string)
+ (typeOf: 'a -> typ) : unit =
+ (* Cast e to its new type, so that we do arithmetic correctly. *)
+ let eCast = mkCast ~e ~newt:(typeOf x) in
+ let xName = nameOf x in
+ List.iter
+ (fun y ->
+ let yName = nameOf y in
+ let yType = typeOf y in
+ if xName = yName ||
+ isUnionType yType ||
+ List.mem xName (depsOfType yType) then begin
+ let yExp = expOf y in
+ (* ySubst is the new value of y after the assignment.
+ * ySubstCast is ySubst with a cast to its new type, for use in
+ * the enviroment. Without the cast, case cast3 of cast9.c
+ * incorrectly passes because the arithmetic is wrong. *)
+ let ySubst, ySubstCast =
+ if xName <> yName then
+ yExp, yExp
+ else
+ e, eCast
+ in
+ let ctx' =
+ addBinding (addThisBinding ctx yType ySubstCast) xName eCast
+ in
+ coerceExp ySubst (substType ctx' yType)
+ end)
+ env
+
+let checkSet (varsInScope: VS.t) (lv: lval) (e: exp) : unit =
+ (* log "checkSet for %a := %a\n" d_lval lv dx_exp e; *)
+ let t = checkLval (ForWrite e) lv in
+ if isConstType t then
+ warn "Assigning to an ASSUMECONST value. Make sure there are no live values that depend on it.";
+ let off1, off2 = removeOffset (snd lv) in
+ begin
+ match off2 with
+ | NoOffset ->
+ begin
+ match fst lv with
+ | Var x ->
+ let ctx, env =
+ if not x.vglob then begin
+ (* Add x to the scope. Even if it hasn't been initialized
+ earlier, we'll want to start checking it now.
+ Also add anything that x depends on, so that we can compile the
+ type of x.*)
+ let varsInScope' = VS.union (Dlocals.localDependsOn x)
+ (VS.add x varsInScope) in
+ liveLocalsContext varsInScope', VS.elements varsInScope'
+ end else
+ globalsContext x, globalsEnv x
+ in
+ checkSetEnv ctx x e env
+ (fun vi -> Lval (var vi))
+ (fun vi -> vi.vname)
+ (fun vi -> vi.vtype)
+ | Mem addr ->
+ let t = typeOfLval lv in
+ let ctx = addThisBinding emptyContext t e in
+ coerceExp e (substType ctx t)
+ end
+ | Field (x, NoOffset) when x.fcomp.cstruct -> (* struct *)
+ let baseLval = fst lv, off1 in
+ let ctx = structContext baseLval x.fcomp in
+ let env = x.fcomp.cfields in
+ let map = polyCompMap (typeOfLval baseLval) in
+ checkSetEnv ctx x e env
+ (fun fi -> Lval (addOffsetLval (Field (fi, NoOffset)) baseLval))
+ (fun fi -> fi.fname)
+ (fun fi ->
+ try
+ polySubst map fi.ftype
+ with PolyError ->
+ reportPolyFieldError lv fi)
+ | Field (x, NoOffset) -> (* Union *)
+ (* union fields don'
+t depend on each other. *)
+ ()
+ | Index (_, NoOffset) ->
+ let ctx = addThisBinding emptyContext (typeOfLval lv) e in
+ coerceExp e (substType ctx (typeOfLval lv))
+ | _ -> E.s (bug "Unexpected result from removeOffset")
+ end;
+ addInstr (Set (lv, e, !currentLoc))
+
+(* Check the right-hand side of a call instruction. The result is an
+ * _unchecked_ lval temporary representing the result of the call. The
+ * arguments are the same as for checkCall, although the lval option
+ * has been changed to a type option for said lval, since this function
+ * is not supposed to do any checking on the left-hand side. The result
+ * of this call is Some _ iff lvTypeOpt is Some _. *)
+let checkCallRhs (lvTypeOpt: typ option) (fnType: typ) (func: exp)
+ (args: exp list) (exempt: int list) : lval option =
+ let returnType, argInfo, varargs, fnAttrs =
+ match fnType with
+ | TFun (returnType, argInfo, varargs, fnAttrs) ->
+ returnType, argInfo, varargs, fnAttrs
+ | _ -> E.s (error "Expected function type at call: %a" dx_exp func)
+ in
+
+ (* CIL uses the missingproto attribute to signal that the function
+ * was used before being declared. *)
+ if hasAttribute "missingproto" fnAttrs then
+ errorwarn "Calling function that has no prototype: %a" dx_exp func;
+
+ let returnDeps = if lvTypeOpt <> None then depsOfType returnType else [] in
+
+ let formals : (string * typ * attributes) list = argsToList argInfo in
+ let numFormals = List.length formals in
+ let numActuals = List.length args in
+
+ (* Check number of arguments. If there aren't enough actuals, we bail;
+ * if there aren't enough formals, we can still proceed. *)
+ if numActuals < numFormals then
+ E.s (error "Function call has too few arguments")
+ else if numFormals < numActuals && not varargs then
+ errorwarn "Function call has too many arguments";
+
+ (* Split the actuals between those that match the formals, and the ones
+ * that match the ... *)
+ let actualsMain, actualsVararg = split args numFormals in
+
+ (* Set up polymorphism. First we match up argument types and formals in
+ * order to figure out which types are used with which type variables.
+ * Then we pick a type from among these (or complain if none is to be
+ * found). Finally, we substitute in the types of formals. *)
+ polyStart ();
+
+ List.iter2
+ (fun (_, ftype, _) arg -> polyMakeSubst ftype (deputyTypeOf arg))
+ formals actualsMain;
+
+ polyResolve ();
+
+ let formals =
+ List.map2
+ (fun (fname, ftype, fattrs) arg ->
+ try
+ fname, polySubst polyMap ftype, fattrs
+ with PolyError ->
+ reportPolyArgError fname ftype arg)
+ formals actualsMain
+ in
+
+ (* Build the context for the call: the formals mapped to actuals.
+ * When needed for the return value, we introduce a temporary to capture
+ * the value of the actuals before the call. The results are:
+ * . actualsMain': The new list of actuals (using temporaries).
+ * . ctxCall: The context mapping formals to actuals.
+ * . tmpMapping: A mapping of formals to temporary locals, used for
+ * any formals that the return type depends upon.
+ *)
+ let actualsMain', ctxCall, tmpMapping =
+ try
+ List.fold_right2
+ (fun (argName, argType, _) arg (actualsAcc, ctxAcc, mapAcc) ->
+ if argName <> "" then
+ let arg', mapAcc' =
+ if List.mem argName returnDeps then
+ (* Optimization: Before inserting a temporary, check to
+ * see whether we already have a local var. In some cases,
+ * preprocessing has already placed a temporary here. *)
+ let vi =
+ match arg with
+ | Lval (Var vi, NoOffset)
+ when (not vi.vaddrof) && (not vi.vglob) -> vi
+ | _ -> addTmpSet arg
+ in
+ Lval (var vi), (argName, vi.vname) :: mapAcc
+ else
+ arg, mapAcc
+ in
+ (arg' :: actualsAcc,
+ addBinding ctxAcc argName (mkCast arg' argType),
+ mapAcc')
+ else
+ (arg :: actualsAcc, ctxAcc, mapAcc))
+ formals
+ actualsMain
+ ([], emptyContext, [])
+ with Invalid_argument _ ->
+ E.s (bug "Expected lists with same length")
+ in
+
+ (* First check any "free" arguments, which are basically trusted. *)
+ let exempt, freeTypeOpt =
+ match getFreeArg fnType with
+ | Some n ->
+ begin
+ try
+ n :: exempt, Some (checkExp (List.nth actualsMain' (n - 1)))
+ with Failure "nth" ->
+ E.s (bug "Could not get argument %d." n)
+ end
+ | None -> exempt, None
+ in
+
+ (* Check the actuals that have matching formals. *)
+ begin
+ try
+ iter2_index
+ (fun (argName, argType, _) arg i ->
+ if not (List.mem i exempt) then
+ let ctxCall' = addThisBinding ctxCall argType arg in
+ let argType' = substType ctxCall' argType in
+ coerceExp arg argType')
+ formals
+ actualsMain'
+ with Invalid_argument _ ->
+ E.s (bug "Expected lists with same length")
+ end;
+
+ (* Check the actuals that match the ... *)
+ iter_index
+ (fun arg i ->
+ if not (List.mem (i + numFormals) exempt) then
+ ignore (checkExp arg))
+ actualsVararg;
+
+ let args' = actualsMain' @ actualsVararg in
+
+ (* Update the return type based on the substitutions we've accumulated
+ * while checking the arguments. We can then forget all the info about
+ * polymorphism for this call. *)
+ let returnType =
+ try
+ polySubst polyMap returnType
+ with PolyError ->
+ reportPolyRetError func
+ in
+
+ polyClear ();
+
+ (* Now insert the call itself, with the return placed in a temporary. *)
+ match lvTypeOpt with
+ | Some lvType ->
+ (* If we're allocating, we adjust the type of the return value
+ * to indicate the number of objects allocated, and we need to do
+ * some initialization. *)
+ if isAllocator fnType then
+ (* Get the base type. *)
+ let lvBaseType =
+ match unrollType lvType with
+ | TPtr (bt, _) -> bt
+ | TInt _ -> voidType (* Treat integer types like void*. *)
+ | _ -> E.s (error ("Left-hand side of allocation " ^^
+ "is not a pointer type."))
+ in
+ (* If freeTypeOpt <> None, we're reallocing. Make sure the freed
+ * type is the same as the realloced type. *)
+ begin
+ match freeTypeOpt with
+ | Some freeType ->
+ begin
+ match unrollType freeType with
+ | TPtr (freeBaseType, _) ->
+ if not (compareTypes freeBaseType lvBaseType) then
+ error ("Reallocator changes type of memory area.\n" ^^
+ " from: %a\n" ^^
+ " to: %a")
+ dx_type lvType dx_type freeType
+ | _ -> error ("Expected pointer type for freed argument.\n" ^^
+ " type: %a\n") dx_type freeType
+ end
+ | None -> ()
+ end;
+ (* Get the size of the array. If we're handling an open array,
+ * treat "extra" space as the open array, *not* as additional
+ * malloced objects. *)
+ let openArrayLen = getOpenArrayLength lvBaseType in
+ let count, size = getAllocationExp lvType fnType actualsMain' in
+ if openArrayLen <> None then begin
+ addCheck (CLeqInt (SizeOf lvBaseType, size,
+ "open array allocation test"))
+ end;
+ let newAttr =
+ if openArrayLen <> None then
+ safeAttr
+ else
+ let countVar = addTmpSet count in
+ countAttr (ACons (countVar.vname, []))
+ in
+ let returnType' =
+ typeAddAttributes [newAttr]
+ (typeRemoveAttributes ["bounds"; "size"; "nonnull"] lvType)
+ in
+ let returnVar = addTmpCall returnType' func args' in
+ (* Now do some initialization. *)
+ if typeContainsNonnull (baseType "allocation" returnType') then
+ error "Allocation of a buffer containing non-null values";
+ if typeContainsPtrOrNullterm lvBaseType && freeTypeOpt = None then begin
+ (* If the type contains pointers or nullterm, just zero out
+ * the whole thing. *)
+ (* TODO: We exclude realloc'ed memory, because we don't want
+ * to overwrite the existing data! Fix this somehow! *)
+ addInstr (Call (None, Lval (var memset),
+ [Lval (var returnVar); zero; size],
+ !currentLoc))
+ end else if isNullterm lvType then begin
+ (* We don't need to zero the whole thing, but we do need to
+ * zero the last element. *)
+ let last = BinOp (PlusPI, Lval (var returnVar), count, returnType') in
+ addInstr (Set ((Mem last, NoOffset), zero, !currentLoc))
+ end;
+ (* Set the size of the open array, if necessary. *)
+ begin
+ match openArrayLen with
+ | Some (fld, atype) ->
+ let bt =
+ match unrollType atype with
+ | TArray (bt, _, _) -> bt
+ | _ -> E.s (bug "Expected array type.")
+ in
+ let loc = Mem (Lval (var returnVar)), Field (fld, NoOffset) in
+ let count =
+ BinOp (Div,
+ BinOp (MinusA, size, SizeOf lvBaseType, !upointType),
+ SizeOf bt, !upointType)
+ in
+ addInstr (Set (loc, count, !currentLoc))
+ | None -> ()
+ end;
+ Some (var returnVar)
+ else
+ (* If we're not allocating, create a temporary with the declared
+ * return value. *)
+ let returnType' =
+ substTypeName tmpMapping (typeRemoveAttributes ["nonnull"] returnType)
+ in
+ let returnVar = addTmpCall returnType' func args' in
+ Some (var returnVar)
+ | None ->
+ addInstr (Call (None, func, args', !currentLoc));
+ None
+
+(* Check a call instruction. Arguments are the same as for a call
+ * instruction with the addition of the exempt list. The exempt list
+ * contains integers indicating which arguments should _not_ be checked.
+ * Arguments are numbered starting with 1; the return value is indicated
+ * in this list by 0. *)
+let checkCall (varsInScope: VS.t) (lvOpt: lval option) (fnType: typ) (func: exp)
+ (args: exp list) (exempt: int list) : unit =
+ let lvTypeOpt =
+ match lvOpt with
+ | Some lv -> Some (typeOfLval lv)
+ | None -> None
+ in
+ match lvOpt, checkCallRhs lvTypeOpt fnType func args exempt with
+ | Some lv, Some lvTmp ->
+ let e = Lval (lvTmp) in
+ if not (List.mem 0 exempt) then
+ checkSet varsInScope lv e
+ else
+ addInstr (Set (lv, e, !currentLoc));
+ if isPointerType (typeOfLval lvTmp) then
+ addInstr (Set (lvTmp, zero, !currentLoc))
+ | None, None -> ()
+ | _ -> E.s (bug "Unexpected result from checkCallRhs")
+
+(* FIXME: with all of these special functions, we should pay attention
+ to the argument numbers in the annotations (e.g. dmemset(1,2,3)).
+ So far, we assume args are in the usual order. *)
+let checkMemset (varsInScope: VS.t)
+ (lvOpt: lval option) (fnType: typ) (func:exp) (args: exp list)
+ : unit =
+ match args with
+ | [(AddrOf lv1 | StartOf lv1); e2; e3]
+ when (isZero e2) && (isCorrectSizeOf e3 lv1) ->
+ (* Special case: if we're overwriting a complete lval with 0, we
+ don't need to check for dependencies within lv1. We still
+ check to make sure nothing outside of lv1 depends on lv1.
+
+ We need this when lv1 is a union. It's okay to zero a union, but it's
+ not normally okay to take the address of a union, since it
+ depends on its context.
+ *)
+ ignore (checkLval ForAddrOf lv1);
+ if hasExternalDeps lv1 then
+ E.s (error
+ "Memset: cannot take address of lval with external dependencies");
+ if typeContainsNonnull (typeOfLval lv1) then begin
+ error "memset on a type containing a nonnull pointer.\n"
+ end;
+ checkCall varsInScope lvOpt fnType func [mkAddrOrStartOf lv1; e2; e3] [1]
+ | [e1; e2; e3] ->
+ let e1Type = checkExp e1 in
+ let e1BaseType =
+ match unrollType e1Type with
+ | TPtr (bt, _) -> bt
+ | _ -> E.s (error "First arg to memset is not a pointer")
+ in
+ if isTrustedType e1Type then
+ markLocationTrusted ()
+ else begin
+ addSizeChecks e1Type e1 e3;
+ if typeContainsPointers e1BaseType then begin
+ addCheck (CEq (e2, zero, "memset argument", []));
+ addCheck (CMult (SizeOf e1BaseType, e3))
+ end;
+ if typeContainsNonnull e1BaseType then
+ errorwarn "Calling memset on a type containing a nonnull pointer";
+ end;
+ checkCall varsInScope lvOpt fnType func [e1; e2; e3] [1]
+ | _ -> E.s (error "Expected three args to memset")
+
+let checkMemcpy (varsInScope: VS.t)
+ (lvOpt: lval option) (fnType: typ) (func:exp) (args: exp list)
+ : unit =
+ match args with
+ | [e1; e2; e3] ->
+ let e1Type = checkExp e1 in
+ let e2Type = checkExp e2 in
+ let e1BaseType =
+ match unrollType e1Type with
+ | TPtr (bt, _) -> bt
+ | _ -> E.s (error "First arg to memcpy is not a pointer")
+ in
+ let e2BaseType =
+ match unrollType e2Type with
+ | TPtr (bt, _) -> bt
+ | _ -> E.s (error "Second arg to memcpy is not a pointer")
+ in
+ if isTrustedType e1Type then
+ markLocationTrusted ()
+ else begin
+ addSizeChecks e1Type e1 e3;
+ if typeContainsPointers e1BaseType then begin
+ if not (compareTypes e1BaseType e2BaseType) then
+ errorwarn "Calling memcpy on arrays with different base types";
+ addCheck (CMult (SizeOf e1BaseType, e3))
+ end;
+ end;
+ if isTrustedType e2Type then
+ markLocationTrusted ()
+ else
+ addSizeChecks e2Type e2 e3;
+ checkCall varsInScope lvOpt fnType func [e1; e2; e3] [1; 2]
+ | _ -> E.s (error "Expected three args to memcpy")
+
+let checkMemcmp (varsInScope: VS.t)
+ (lvOpt: lval option) (fnType: typ) (func:exp) (args: exp list)
+ : unit =
+ match args with
+ | [e1; e2; e3] ->
+ let e1Type = checkExp e1 in
+ let e2Type = checkExp e2 in
+ if isTrustedType e1Type then markLocationTrusted ()
+ else
+ addSizeChecks e1Type e1 e3;
+ if isTrustedType e2Type then markLocationTrusted ()
+ else
+ addSizeChecks e2Type e2 e3;
+ checkCall varsInScope lvOpt fnType func [e1; e2; e3] [1; 2]
+ | _ -> E.s (error "Expected three args to memcmp")
+
+(* Check only the right-hand side of an instruction. Used when generating
+ * automatic bounds for the left-hand side. Returns an expression
+ * representing the right-hand side, the type of that expression, and
+ * a list of clean-up instructions to be executed after the expression
+ * has been used. *)
+let checkInstrRhs (instr: instr) : exp * typ * instr list =
+ let e, instrs =
+ match instr with
+ | Call (Some lv, fn, args, _) ->
+ begin
+ match checkCallRhs (Some (typeOfLval lv)) (typeOf fn) fn args [] with
+ | Some lv -> Lval lv, [Set (lv, zero, !currentLoc)]
+ | None -> E.s (bug "Unexpected result from checkCallRhs")
+ end
+ | Call (None, _, _, _) ->
+ E.s (bug "Expected call with return lval")
+ | Set (_, e, _) ->
+ e, []
+ | Asm _ ->
+ E.s (bug "Expected call or set")
+ in
+ e, checkExp e, instrs
+
+(* Check one instruction.
+ varsInScope is the set of local variables that have been initialized: i.e.
+ are live or have had their addresses taken.
+ We'll use this set as the context in checkSetEnv (the Hoare rule).
+ If we write to any variables, add them to the in-scope set and return the
+ new set. *)
+let checkInstr (varsInScope: VS.t) (instr : instr) : VS.t =
+ currentLoc := get_instrLoc instr;
+ markLocationChecked ();
+ if !verbose then
+ log "INSTR: %a" dn_instr instr;
+ let addToScope (lv:lval) : VS.t =
+ (* We've written to an lval that could be a local var.
+ Update varsInScope. Also include any vars that vi
+ depends on, so that we can compile vi's dependencies. *)
+ match lv with
+ Var vi,_ when not vi.vglob -> VS.union
+ (Dlocals.localDependsOn vi)
+ (VS.add vi varsInScope)
+ | _ -> varsInScope
+ in
+ let addToScopeOpt (lvo:lval option) : VS.t =
+ match lvo with
+ Some lv -> addToScope lv
+ | None -> varsInScope
+ in
+ match instr with
+ | Call (lvOpt, Lval (Var vf, NoOffset), args, _)
+ when vf.vname = "strcpy" || vf.vname = "strcat" ->
+ (* Without this check, users get a rather cryptic error message when
+ using strcpy. We need a better way to forbid use of certain bad
+ API functions. *)
+ warn "Calls to %s are unsafe; use newer string functions instead."
+ vf.vname;
+ addInstr instr;
+ addToScopeOpt lvOpt
+ | Call (lvOpt, fn, _, _) when fn == maxFunction ->
+ (* Ignore the max function for now. *)
+ addInstr instr;
+ addToScopeOpt lvOpt
+ | Call (lvOpt, fn, args, _) ->
+ let fnType = checkExp fn in
+ if isMemset fnType then
+ checkMemset varsInScope lvOpt fnType fn args
+ else if isMemcpy fnType then
+ checkMemcpy varsInScope lvOpt fnType fn args
+ else if isMemcmp fnType then
+ checkMemcmp varsInScope lvOpt fnType fn args
+ else if isVarargOperator fn then begin
+ (* skip va_start, va_arg, and family *)
+ if !warnVararg then
+ warn "Ignoring vararg operator %a" dx_exp fn;
+ addInstr instr
+ end
+ else
+ checkCall varsInScope lvOpt fnType fn args [];
+ addToScopeOpt lvOpt
+ | Set ((Var vi, NoOffset) as lv, _, _) when List.memq vi !exemptLocalVars ->
+ addInstr instr;
+ addToScope lv
+ | Set (lv, e, _) ->
+ checkSet varsInScope lv e;
+ addToScope lv
+ | Asm _ ->
+ markLocationTrusted ();
+ if !warnAsm then
+ warn "Ignoring asm";
+ addInstr instr;
+ varsInScope
+
+let returnCtx : context ref = ref []
+
+let checkReturn (eo : exp option) : unit =
+ let returnType =
+ match !curFunc.svar.vtype with
+ | TFun (returnType, _, _, _) -> returnType
+ | _ -> E.s (bug "Expected function type")
+ in
+ match eo with
+ | Some e ->
+ if !verbose then
+ log "RETURN: %a" dx_exp e;
+ let ctx = addThisBinding !returnCtx returnType e in
+ coerceExp e (substType ctx returnType)
+ | None ->
+ if !verbose then
+ log "RETURN: [void]";
+ if not (isVoidType returnType) then
+ errorwarn "Return type of function is not void"
+
+let rec checkStmt (s : stmt) : unit =
+ curStmt := s.sid;
+ currentLoc := get_stmtLoc s.skind;
+ markLocationChecked ();
+ let varsInScope = Dlocals.liveAtStmtStart s in
+ if !verbose then
+ log "STMT %d. Live vars: %a\n" s.sid
+ (docList (fun v -> text v.vname)) (VS.elements varsInScope);
+ let mkBlockMaybe (instrs: instr list) (sk: stmtkind) =
+ if instrs <> [] then
+ Block (mkBlock [mkStmt (Instr instrs); mkStmt sk])
+ else
+ sk
+ in
+ let sk' =
+ match s.skind with
+ | Instr instrs ->
+ startExtraInstrs ();
+ ignore (List.fold_left checkInstr varsInScope instrs);
+ Instr (endExtraInstrs ())
+ | Return (eo, _) ->
+ startExtraInstrs ();
+ checkReturn eo;
+ mkBlockMaybe (endExtraInstrs ()) s.skind
+ | If (e, b1, b2, _) ->
+ startExtraInstrs ();
+ coerceExp e intType;
+ let extras = endExtraInstrs () in
+ checkBlock b1;
+ checkBlock b2;
+ mkBlockMaybe extras s.skind
+ | Switch (e, b, _, _) ->
+ startExtraInstrs ();
+ coerceExp e intType;
+ let extras = endExtraInstrs () in
+ checkBlock b;
+ mkBlockMaybe extras s.skind
+ | Loop (b, _, _, _)
+ | Block b ->
+ checkBlock b;
+ s.skind
+ | Goto _
+ | Break _
+ | Continue _ ->
+ s.skind
+ | TryFinally _
+ | TryExcept _ -> E.s (E.unimp "exceptions not supported\n")
+ in
+ s.skind <- sk'
+
+and checkBlock (b : block) : unit =
+ if isTrustedAttr b.battrs then
+ markTrustedBlock b
+ else
+ List.iter
+ (fun s ->
+ if !multipleErrors then
+ try checkStmt s with E.Error -> ()
+ else
+ checkStmt s)
+ b.bstmts
+
+let checkTypedef (ti: typeinfo) : unit =
+ checkType emptyContext ti.ttype (dprintf "typedef %s" ti.tname)
+
+let checkStruct (ci: compinfo) : unit =
+ let ctx =
+ List.fold_left
+ (fun acc fld -> addBinding acc fld.fname zero)
+ emptyContext
+ ci.cfields
+ in
+ List.iter
+ (fun fld -> checkType ctx fld.ftype
+ (dprintf "field %s of struct %s" fld.fname ci.cname))
+ ci.cfields
+
+let checkVar (vi: varinfo) (init: initinfo) : unit =
+ checkType (globalsContext vi) vi.vtype (dprintf "global %s" vi.vname)
+
+let makeCFG (fd : fundec) : unit =
+ Cfg.clearCFGinfo fd; (* zra *)
+ let cnt = Cfg.cfgFun fd in
+ Cfg.start_id := cnt + !Cfg.start_id
+
+let checkFundec (fd : fundec) : unit =
+ if !verbose then
+ log "Starting function %s" fd.svar.vname;
+ curFunc := fd;
+ clearBoundsTable ();
+ markLocationChecked ();
+ (* Check types of formals. *)
+ let ctxFormals = formalsContext fd in
+ List.iter
+ (fun vi -> checkType ctxFormals vi.vtype
+ (dprintf "formal parameter %s" vi.vname))
+ fd.sformals;
+ (* Check types of locals. *)
+ let ctxLocals = localsContext fd in
+ List.iter
+ (fun vi -> checkType ctxLocals vi.vtype
+ (dprintf "local variable %s" vi.vname))
+ fd.slocals;
+ (* Check type of return value. *)
+ let returnType =
+ match fd.svar.vtype with
+ | TFun (returnType, _, _, _) -> returnType
+ | _ -> E.s (bug "Expected function type")
+ in
+ checkType ctxFormals returnType (text "return type");
+ (* Now find out which variables the return type depends upon. Save the
+ * values of these variables so that we can check the return type later. *)
+ let returnDeps = depsOfType returnType in
+ startExtraInstrs ();
+ returnCtx :=
+ List.fold_right
+ (fun name acc ->
+ if name <> thisKeyword then
+ let vi =
+ try
+ List.find (fun vi -> vi.vname = name) fd.sformals
+ with Not_found ->
+ E.s (bug "Expected formal named %s" name)
+ in
+ addBinding acc name (Lval (var (addTmpSet (Lval (var vi)))))
+ else
+ acc)
+ returnDeps
+ emptyContext;
+ let instrs = endExtraInstrs () in
+ (* We add the instrs to the beginning of the function. We also add an
+ * empty list to the beginning so that Dlocals.doLiveness can add
+ * initialization instructions to the first statement without messing up
+ * the CFG. *)
+ fd.sbody.bstmts <- mkStmt (Instr []) :: mkStmt (Instr instrs) ::
+ fd.sbody.bstmts;
+ (* fix block, see if cfg should be used, check block *)
+ fixBlock fd.sbody;
+ makeCFG fd; (* formerly done only if !optLevel >= 2 *)
+ Stats.time "Liveness" Dlocals.doLiveness fd;
+ checkBlock fd.sbody;
+ (* Clean up. *)
+ curFunc := dummyFunDec;
+ curStmt := -1;
+ returnCtx := emptyContext;
+ Dlocals.clearLiveness ();
+ ()
+
+
+(** Check the functions in a file. *)
+let checkFile (f: file) (globinit: fundec) (fdat : DPF.functionData) : unit =
+ if !verbose then
+ log "Using optimization level %d" !optLevel;
+ allowChecks := true;
+ iterGlobals f
+ (fun global ->
+ match global with
+ | GType (ti, _) -> checkTypedef ti
+ | GCompTag (ci, _) when ci.cstruct -> checkStruct ci
+ | GVar (vi, init, _) -> checkVar vi init
+ | GFun (fd, loc) ->
+ if isTrustedType fd.svar.vtype then
+ markTrustedBlock fd.sbody
+ else begin
+ checkFundec fd;
+ DO.optimFunction fd loc fdat;
+ end
+ | _ -> ());
+ ()
--- /dev/null
+(*
+ *
+ * Copyright (c) 2006,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * Matthew Harren <matth@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 fixBlock : ?giveID:bool -> Cil.block -> unit
+val exemptLocalVars : Cil.varinfo list ref
+val startExtraInstrs : unit -> unit
+val endExtraInstrs : unit -> Cil.instr list
+val checkInstrRhs : Cil.instr -> Cil.exp * Cil.typ * Cil.instr list
+val checkInstr : Usedef.VS.t -> Cil.instr -> Usedef.VS.t
+val checkFundec : Cil.fundec -> unit
+val checkFile : Cil.file -> Cil.fundec -> Dprecfinder.functionData -> unit
--- /dev/null
+(*
+ *
+ * Copyright (c) 2004,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 Pretty
+open Expcompare
+open Dutil
+open Dattrs
+
+module E = Errormsg
+module DCE = Dcanonexp
+
+type check =
+ CNonNull of exp (** e != 0 *)
+ | CEq of exp * exp * string * doc list
+ (** e1 == e2 *)
+ | CMult of exp * exp (** e1 * k == e2 for some int k *)
+ | CPtrArith of exp * exp * exp * exp * int
+ (** e3 + (e4 * size) does not overflow, and
+ * e1 <= e3 + (e4 * size) <= e2. *)
+ | CPtrArithNT of exp * exp * exp * exp * int
+ (** e3 + (e4 * size) does not overflow, and
+ * e1 <= e3 + (e4 * size) <= (e2 + sizeof(e2)). *)
+ | CPtrArithAccess of exp * exp * exp * exp * int
+ (** e3 + ((e4+1) * size) does not overflow, and
+ * e1 <= e3 + ((e4+1) * size) <= e2. *)
+ | CLeqInt of exp * exp * string
+ (** e1 <= e2, unsigned.
+ * Also remember why this check was added. *)
+ | CLeq of exp * exp * string
+ (** e1 <= e2, unsigned.
+ * Also remember why this check was added. *)
+ | CLeqNT of exp * exp * int * string
+ (** e1 <= (e2 + sizeof(e2)), unsigned.
+ * The int is the size of the base type.
+ * Also remember why this check was added. *)
+ | CNullOrLeq of exp * exp * exp * string
+ (** e1 == 0 || e2 <= e3.
+ * Also remember why this check was added. *)
+ | CNullOrLeqNT of exp * exp * exp * int * string
+ (** e1 == 0 || e2 <= (e3 + sizeof(e3)).
+ * The int is the size of the base type.
+ * Also remember why this check was added. *)
+ | CWriteNT of exp * exp * exp * int
+ (** (e1 == e2) ==> (e3 = 0)
+ * The int is the size of the base type. *)
+ | CNullUnionOrSelected of lval * exp
+ (** lv = \vec{0} || e.
+ Here, e is a shortcut saying that if the
+ newly-active field is the same as the old
+ active field, we don't check for the union
+ equalling zero.*)
+ (* These two are redundant with CNonNull and CEq, but having separate
+ checks for unions gives better error messages: *)
+ | CSelected of exp (** e != 0 *)
+ | CNotSelected of exp (** e == 0 *)
+(* Other checks will be needed, such as nullterm checks and checks for when
+ part of one of the above checks can be proved statically. *)
+
+
+(* These aren't real variables. In the output, they'll show up as
+ __LOCATION__, which is a macro defined in deputy/checks.h. We use them
+ for calling runtime check functions. *)
+let locationToken : exp =
+ let vi = makeGlobalVar "__LOCATION__" charPtrType in
+ Lval (var vi)
+
+let mkFun (name: string) (rt:typ) (args: typ list) : exp =
+ let fdec = emptyFunction name in
+ let args = List.map (fun t -> ("", t, [])) args in
+ fdec.svar.vtype <- TFun(rt, Some args, false, []);
+ Lval (var fdec.svar)
+
+let mkCheckFun (name: string) (n: int) : exp =
+ (* A check function takes n void* parameters, a location *)
+ let args = Util.list_init n (fun _ -> voidPtrType) in
+ let args' = args @ [charPtrType] in
+ mkFun name voidType args'
+
+let cnonnull = mkCheckFun "CNonNull" 1
+let ceq = mkCheckFun "CEq" 3
+let cmult = mkCheckFun "CMult" 2
+let cptrarith = mkCheckFun "CPtrArith" 5
+let cptrarithaccess = mkCheckFun "CPtrArithAccess" 5
+let cptrarithnt = mkCheckFun "CPtrArithNT" 5
+let cleqint = mkCheckFun "CLeqInt" 3
+let cleq = mkCheckFun "CLeq" 3
+let cleqnt = mkCheckFun "CLeqNT" 4
+let cnullorleq = mkCheckFun "CNullOrLeq" 4
+let cnullorleqnt = mkCheckFun "CNullOrLeqNT" 5
+let cwritent = mkCheckFun "CWriteNT" 4
+let cnullunion = mkCheckFun "CNullUnionOrSelected" 3
+let cselected = mkCheckFun "CSelected" 1
+let cnotselected = mkCheckFun "CNotSelected" 1
+
+let unmkString (e: exp) : string =
+ match e with
+ | Const (CStr s) -> s
+ | _ -> E.s (bug "Expected string constant")
+
+let toInt (e:exp) : int =
+ match isInteger e with
+ Some i64 -> to_int i64
+ | None ->
+ E.s (bug "expected a constant int for the size param in this check.")
+
+let checkFunctions : exp list =
+ [ cnonnull; ceq; cmult; cptrarith; cptrarithnt; cleqint;
+ cleq; cleqnt; cnullorleq; cnullorleqnt; cwritent; cnullunion;
+ cselected; cnotselected; cptrarithaccess ]
+
+(* This function gives a high-level reason for each check. The text here
+ * should mirror the text in the runtime library, where possible. *)
+let checkWhy (c: check) : string =
+ match c with
+ | CNonNull _ -> "non-null check"
+ | CEq (_, _, why, _) -> why
+ | CMult _ -> "alignment check"
+ | CPtrArithAccess _ -> "pointer arithmetic and dereference check"
+ | CPtrArith _ -> "pointer arithmetic check"
+ | CPtrArithNT _ -> "nullterm pointer arithmetic check"
+ | CLeqInt (_, _, why) -> why
+ | CLeq (_, _, why) -> why
+ | CLeqNT (_, _, _, why) -> why
+ | CNullOrLeq (_, _, _, why) -> why
+ | CNullOrLeqNT (_, _, _, _, why) -> why
+ | CWriteNT _ -> "nullterm write check"
+ | CNullUnionOrSelected _ -> "null union check"
+ | CSelected _ -> "check that union field is selected"
+ | CNotSelected _ -> "check that union field is not selected"
+
+(* This function gives a textual representation of a given check for
+ * error-reporting purposes. *)
+let checkText (c: check) : doc list =
+ startTemps ();
+ let docs =
+ match c with
+ | CNonNull (e) ->
+ [dprintf "%a != 0%t" dc_exp e dx_temps]
+ | CEq (e1,e2,why,docs) ->
+ if docs <> [] then
+ docs
+ else
+ [dprintf "%a == %a%t" dc_exp e1 dc_exp e2 dx_temps]
+ | CMult (e1,e2) ->
+ [dprintf "%a %% %a == 0%t" dc_exp e2 dc_exp e1 dx_temps]
+ | CPtrArithAccess(e1,e2,e3,e4,e5) ->
+ [dprintf "%a <= %a + %a + 1 (with no overflow)%t"
+ dc_exp e1 dc_exp e3 dc_exp e4 dx_temps;
+ dprintf "%a + %a + 1 <= %a (with no overflow)%t"
+ dc_exp e3 dc_exp e4 dc_exp e2 dx_temps]
+ | CPtrArith (e1,e2,e3,e4,e5) ->
+ [dprintf "%a <= %a + %a (with no overflow)%t"
+ dc_exp e1 dc_exp e3 dc_exp e4 dx_temps;
+ dprintf "%a + %a <= %a (with no overflow)%t"
+ dc_exp e3 dc_exp e4 dc_exp e2 dx_temps]
+ | CPtrArithNT (e1,e2,e3,e4,e5) ->
+ [dprintf "%a <= %a + %a (with no overflow)%t"
+ dc_exp e1 dc_exp e3 dc_exp e4 dx_temps;
+ dprintf "%a + %a <= %a + len(%a) (with no overflow)%t"
+ dc_exp e3 dc_exp e4 dc_exp e2 dc_exp e2 dx_temps]
+ | CLeqInt (e1,e2,why) ->
+ [dprintf "%a <= %a%t" dc_exp e1 dc_exp e2 dx_temps]
+ | CLeq (e1,e2,why) ->
+ [dprintf "%a <= %a%t" dc_exp e1 dc_exp e2 dx_temps]
+ | CLeqNT (e1,e2,e3,why) ->
+ [dprintf "%a <= %a + len(%a)%t" dc_exp e1 dc_exp e2 dc_exp e2 dx_temps]
+ | CNullOrLeq (e1,e2,e3,why) ->
+ [dprintf "%a == 0 || %a <= %a%t" dc_exp e1 dc_exp e2 dc_exp e3 dx_temps]
+ | CNullOrLeqNT (e1,e2,e3,e4,why) ->
+ [dprintf "%a == 0 || %a <= %a + len(%a)%t"
+ dc_exp e1 dc_exp e2 dc_exp e3 dc_exp e3 dx_temps]
+ | CWriteNT (p,hi,what,sz) ->
+ [dprintf "%a != %a || *(%a) != 0 || %a == 0%t"
+ dc_exp p dc_exp hi dc_exp p dc_exp what dx_temps]
+ | CNullUnionOrSelected (lv, sameFieldSelected) ->
+ [dprintf "%a || iszero(%a)%t"
+ dc_exp sameFieldSelected dx_lval lv dx_temps]
+ | CSelected (e) ->
+ [dprintf "%a%t" dc_exp e dx_temps]
+ | CNotSelected (e) ->
+ [dprintf "! %a%t" dc_exp e dx_temps]
+ in
+ stopTemps ();
+ docs
+
+let instrToCheck (instr: instr) : check option =
+ match instr with
+ | Call (None, fn, args, _) when List.exists (compareExp fn) checkFunctions ->
+ let c =
+ match args with
+ | [e;_;_] when compareExp fn cnonnull ->
+ CNonNull e
+ | [e1;e2;why;doc;_] when compareExp fn ceq ->
+ CEq (e1,e2,unmkString why,[text (unmkString doc)])
+ | [e1;e2;_;_] when compareExp fn cmult ->
+ CMult (e1,e2)
+ | [e1;e2;e3;e4;e5;_;_;_] when compareExp fn cptrarith ->
+ CPtrArith (e1,e2,e3,e4,toInt e5)
+ | [e1;e2;e3;e4;e5;_;_;_] when compareExp fn cptrarithaccess ->
+ CPtrArithAccess (e1,e2,e3,e4,toInt e5)
+ | [e1;e2;e3;e4;e5;_;_;_] when compareExp fn cptrarithnt ->
+ CPtrArithNT (e1,e2,e3,e4,toInt e5)
+ | [e1;e2;why;_;_] when compareExp fn cleqint ->
+ CLeqInt (e1,e2,unmkString why)
+ | [e1;e2;why;_;_] when compareExp fn cleq ->
+ CLeq (e1,e2,unmkString why)
+ | [e1;e2;e3;why;_;_] when compareExp fn cleqnt ->
+ CLeqNT (e1,e2,toInt e3,unmkString why)
+ | [e1;e2;e3;why;_;_] when compareExp fn cnullorleq ->
+ CNullOrLeq (e1,e2,e3,unmkString why)
+ | [e1;e2;e3;e4;why;_;_] when compareExp fn cnullorleqnt ->
+ CNullOrLeqNT (e1,e2,e3,toInt e4,unmkString why)
+ | [p;hi;what;sz;_;_] when compareExp fn cwritent ->
+ CWriteNT (p,hi,what,toInt sz)
+ | [AddrOf lv;_;e;_;_] when compareExp fn cnullunion ->
+ CNullUnionOrSelected (lv, e)
+ | [e;_;_] when compareExp fn cselected ->
+ CSelected (e)
+ | [e;_;_] when compareExp fn cnotselected ->
+ CNotSelected (e)
+ | _ ->
+ E.s (bug "Check instruction not recognized: %a" d_instr instr)
+ in
+ Some c
+ | _ -> None
+
+let checkToInstr (c:check) : instr =
+ let call f args docs =
+ (* Append the file and line to the end of the args *)
+ let extraArgs =
+ List.fold_right
+ (fun doc acc -> Const (CStr (sprint 1000000 doc)) :: acc)
+ docs [locationToken]
+ in
+ Call (None, f, args @ extraArgs, !currentLoc)
+ in
+ let docs = checkText c in
+ (* Use dc_exp instead of dx_exp so we don't print so many casts in the
+ "why" messages of checks. *)
+ let i =
+ match c with
+ | CNonNull (e) ->
+ call cnonnull [e] docs
+ | CEq (e1,e2,why,_) ->
+ call ceq [e1;e2;mkString why] docs
+ | CMult (e1,e2) ->
+ call cmult [e1;e2] docs
+ | CPtrArithAccess(e1,e2,e3,e4,e5) ->
+ call cptrarithaccess [e1;e2;e3;e4;integer e5] docs
+ | CPtrArith (e1,e2,e3,e4,e5) ->
+ call cptrarith [e1;e2;e3;e4;integer e5] docs
+ | CPtrArithNT (e1,e2,e3,e4,e5) ->
+ call cptrarithnt [e1;e2;e3;e4;integer e5] docs
+ | CLeqInt (e1,e2,why) ->
+ call cleqint [e1;e2;mkString why] docs
+ | CLeq (e1,e2,why) ->
+ call cleq [e1;e2;mkString why] docs
+ | CLeqNT (e1,e2,e3,why) ->
+ call cleqnt [e1;e2;integer e3;mkString why] docs
+ | CNullOrLeq (e1,e2,e3,why) ->
+ call cnullorleq [e1;e2;e3;mkString why] docs
+ | CNullOrLeqNT (e1,e2,e3,e4,why) ->
+ call cnullorleqnt [e1;e2;e3;integer e4;mkString why] docs
+ | CWriteNT (p,hi,what,sz) ->
+ call cwritent [p;hi;what;integer sz] docs
+ | CNullUnionOrSelected (lv, sameFieldSelected) ->
+ let sz = sizeOf (typeOfLval lv) in
+ call cnullunion [mkAddrOf lv; sz; sameFieldSelected] docs
+ | CSelected (e) ->
+ call cselected [e] docs
+ | CNotSelected (e) ->
+ call cnotselected [e] docs
+ in
+ (* For the optimizer to work properly, we must be able to convert instrs
+ * back to the original check. As a sanity check, we verify here that
+ * this is possible for each instr we generate. *)
+ if instrToCheck i = None then
+ E.s (bug "checkToInstr not invertible");
+ i
+
+let checks_equal c1 c2 =
+let ce = (*deputyStripAndCompareExp*) DCE.canonCompareExp in
+match c1, c2 with
+| CEq(e11,e12,_,_), CEq(e21,e22,_,_)
+| CMult(e11,e12), CMult(e21, e22)
+| CLeqInt(e11,e12,_), CLeqInt(e21,e22,_)
+| CLeq(e11,e12,_), CLeq(e21,e22,_) ->
+ (ce e11 e21) &&
+ (ce e12 e22)
+| CLeqNT(e11,e12,sz1,_), CLeqNT(e21,e22,sz2,_) ->
+ (ce e11 e21) &&
+ (ce e12 e22) &&
+ sz1 = sz2
+| CNullOrLeq(e11,e12,e13,_), CNullOrLeq(e21,e22,e23,_) ->
+ (ce e11 e21) &&
+ (ce e12 e22) &&
+ (ce e13 e23)
+| CNullOrLeqNT(e11,e12,e13,sz1,_), CNullOrLeqNT(e21,e22,e23,sz2,_)
+| CWriteNT(e11,e12,e13,sz1),CWriteNT(e21,e22,e23,sz2) ->
+ (ce e11 e21) &&
+ (ce e12 e22) &&
+ (ce e13 e23) &&
+ sz1 = sz2
+| CPtrArithAccess(e11,e12,e13,e14,sz1), CPtrArithAccess(e21,e22,e23,e24,sz2) ->
+ (ce e11 e21) &&
+ (ce e12 e22) &&
+ (ce e13 e23) &&
+ (ce e14 e24) &&
+ sz1 = sz2
+| CPtrArith(e11,e12,e13,e14,sz1), CPtrArith(e21,e22,e23,e24,sz2)
+| CPtrArithNT(e11,e12,e13,e14,sz1), CPtrArithNT(e21,e22,e23,e24,sz2) ->
+ (ce e11 e21) &&
+ (ce e12 e22) &&
+ (ce e13 e23) &&
+ (ce e14 e24) &&
+ sz1 = sz2
+| CNullUnionOrSelected(l1, e1), CNullUnionOrSelected(l2, e2) ->
+ (compareLval l1 l2) &&
+ (ce e1 e2)
+| CSelected e1, CSelected e2
+| CNotSelected e1, CNotSelected e2
+| CNonNull e1, CNonNull e2 ->
+ ce e1 e2
+| _ -> false
+
+
+let isDeputyFunctionLval (e:exp) : bool =
+ List.exists (compareExp e) checkFunctions ||
+ match e with
+ | Lval(Var vf,NoOffset) -> begin
+ vf.vname = "deputy_findnull" ||
+ vf.vname = "deputy_max"
+ end
+ | _ -> false
+
+(*
+ * Return true if i is a deputy
+ * runtime check.
+ *)
+let is_check_instr i =
+ match instrToCheck i with
+ None -> false
+ | Some _ -> true
+
+let is_deputy_fun i = match i with
+ Call(_,Lval(Var vf,NoOffset),_,_) ->
+ vf.vname = "deputy_findnull" ||
+ vf.vname = "deputy_max"
+ | _ -> false
+
+let alloc_names = [
+ "malloc";
+ "calloc";
+ "realloc";
+ "xmalloc";
+ "__builtin_alloca";
+ "alloca";
+ "kmalloc"
+]
+
+let libc_no_side_effects = [
+ "printf";
+] @ alloc_names
+
+let is_alloc_fun i =
+ match i with
+ | Call(_,Lval(Var vf,NoOffset),_,_) ->
+ List.mem vf.vname alloc_names
+ | _ -> false
+
+let isLibcNoSideEffects i =
+ match i with
+ | Call(_,Lval(Var vf,NoOffset),_,_) ->
+ List.mem vf.vname libc_no_side_effects ||
+ (hasAttribute "pure" vf.vattr) ||
+ (hasAttribute "pure" (typeAttrs vf.vtype))
+ | _ -> false
+
+let lvNoSideEffects lve =
+ List.mem lve checkFunctions ||
+ match lve with
+ | Lval(Var vf, NoOffset) ->
+ List.mem vf.vname libc_no_side_effects ||
+ (hasAttribute "pure" vf.vattr) ||
+ (hasAttribute "pure" (typeAttrs vf.vtype))
+ | _ -> false
+
+(*
+ * Return true if i is any
+ * instruction that deputy added.
+ *)
+let is_deputy_instr i =
+ match instrToCheck i with
+ Some _ -> true
+ | None -> is_deputy_fun i
--- /dev/null
+(*
+ *
+ * Copyright (c) 2006,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * Matthew Harren <matth@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+type check =
+ CNonNull of Cil.exp
+ | CEq of Cil.exp * Cil.exp * string * Pretty.doc list
+ | CMult of Cil.exp * Cil.exp
+ | CPtrArith of Cil.exp * Cil.exp * Cil.exp * Cil.exp * int
+ | CPtrArithNT of Cil.exp * Cil.exp * Cil.exp * Cil.exp * int
+ | CPtrArithAccess of Cil.exp * Cil.exp * Cil.exp * Cil.exp * int
+ | CLeqInt of Cil.exp * Cil.exp * string
+ | CLeq of Cil.exp * Cil.exp * string
+ | CLeqNT of Cil.exp * Cil.exp * int * string
+ | CNullOrLeq of Cil.exp * Cil.exp * Cil.exp * string
+ | CNullOrLeqNT of Cil.exp * Cil.exp * Cil.exp * int * string
+ | CWriteNT of Cil.exp * Cil.exp * Cil.exp * int
+ | CNullUnionOrSelected of Cil.lval * Cil.exp
+ | CSelected of Cil.exp
+ | CNotSelected of Cil.exp
+val checks_equal : check -> check -> bool
+val mkFun : string -> Cil.typ -> Cil.typ list -> Cil.exp
+val checkWhy : check -> string
+val checkText : check -> Pretty.doc list
+val instrToCheck : Cil.instr -> check option
+val checkToInstr : check -> Cil.instr
+val isDeputyFunctionLval : Cil.exp -> bool
+val is_check_instr : Cil.instr -> bool
+val is_deputy_instr : Cil.instr -> bool
+val is_deputy_fun : Cil.instr -> bool
+val is_alloc_fun : Cil.instr -> bool
+val isLibcNoSideEffects : Cil.instr -> bool
+val lvNoSideEffects : Cil.exp -> bool
--- /dev/null
+
+(** Process the global initializer *)
+open Cil
+open Pretty
+open Dattrs
+open Doptions
+open Dutil
+open Dcheckdef
+
+module E = Errormsg
+module IH = Inthash
+
+(*** PREPROCESSING **)
+
+(* Make a function that contains all the assignments that would be needed to
+ * initialize the globals. We expect the checker to add the necessary checks,
+ * and the optimizers to remove ALL of them. We'll check this later. Call
+ * this then the global initializers have been finished, but before inserting
+ * checks. *)
+let prepareGlobalInitializers (f: file) : fundec =
+ (* Create a function at the end of the file *)
+ let fd = emptyFunction "__deputy_global_initializers" in
+ fd.svar.vstorage <- Static;
+ setFunctionType fd (TFun(voidType, Some [], false, []));
+ (* We do not insert it in the file *)
+
+ (* Now scan all global data defined in this file. *)
+ let instrs : instr list ref = ref [] in
+
+ let rec doInit (lv: lval) (i: init) : unit =
+ let addi (lv': lval) (e': exp) : unit =
+ instrs := (Set(lv', e', !currentLoc)) :: !instrs
+ in
+ let doSubInit () : unit =
+ match i with
+ CompoundInit (ct, initl) ->
+ foldLeftCompound ~implicit:true
+ ~doinit:(fun off' i' t' acc ->
+ if not (isOpenArray t') then
+ doInit (addOffsetLval off' lv) i')
+ ~ct:ct
+ ~initl:initl
+ ~acc:()
+
+ | _ -> ()
+ in
+ match unrollType (typeOfLval lv), i with
+ | TPtr _, SingleInit e -> (* All pointers are checked *)
+ addi lv e
+
+ (* For arrays whose base type contains pointers or null-term, we
+ * check the whole array *)
+ | TArray(bt, _, a), _ when typeContainsPtrOrNullterm bt ->
+ doSubInit ()
+
+ (* For arrays whose base type does not contain pointers or nullterm,
+ * but are nullterm themselves, we check the last element only *)
+ | (TArray(_, _, a) as arrt),
+ CompoundInit (_, initl) when hasAttribute "nullterm" a ->
+ begin
+ (* Scan all (including implicit initializers) and remember the last*)
+ let last : (offset * init) option ref = ref None in
+ foldLeftCompound
+ ~implicit:true
+ ~doinit:(fun off' i' t acc -> last := Some (off', i'))
+ ~ct:arrt
+ ~initl:initl
+ ~acc:();
+ match !last with
+ | Some (off', SingleInit e') ->
+ addi (addOffsetLval off' lv) e'
+ | Some (_, CompoundInit _) ->
+ unimp ("Cannot initialize a global nullterm " ^^
+ "array of arrays or structs.")
+ | None -> E.s (bug "Missing implicit initializer for %a." d_lval lv)
+ end
+
+ (* For structs that contain pointers of null-term we check the whole
+ * thing *)
+ | TComp _ as t, _ when typeContainsPtrOrNullterm t -> doSubInit ()
+
+ (* For other things we do not need to check anything *)
+ | _, _ -> ()
+ in
+
+ iterGlobals f
+ (function
+ GVar(gvi, {init = inito}, l)
+ when not (isTrustedAttr (typeAttrs gvi.vtype)) ->
+ let init' =
+ match inito with
+ None -> makeZeroInit gvi.vtype
+ | Some init' -> init'
+ in
+ doInit (var gvi) init'
+ | _ -> ());
+
+ fd.sbody <- mkBlock [mkStmt (Instr (List.rev !instrs))];
+
+
+ fd
+
+
+(** Call this function after you inserted the checks, to perform the
+ * optimization of the global initializer. Return true if we still have
+ * residual checks. *)
+let checkGlobinit (f: file)
+ (gi: fundec)
+ (check: fundec -> unit)
+ (optim: fundec -> location -> unit) : bool =
+ (* Before optimization we replace all the references to global data with the
+ * actual data in the initializer. *)
+ if !verbose then
+ log "checkGlobinit\n";
+
+ (* insert the checks *)
+ check gi;
+
+ if !verbose then
+ log "prepare global initializer for optimizations\n";
+
+ (* First, create a hash-table with the initializers for each global,
+ * indexed by the vid *)
+ let globinits : init IH.t = IH.create 13 in
+ iterGlobals f
+ (function
+ GVar(gvi, { init = Some i }, _) -> IH.add globinits gvi.vid i
+ | _ -> ());
+
+ let replaceGlobalsVisitor = object (self)
+ inherit nopCilVisitor
+ method vtype (t: typ) = SkipChildren
+
+ method vexpr (e: exp) =
+ match e with
+ | Lval (Var g, off) when g.vglob && not (isFunctionType g.vtype) &&
+ g.vname <> "__LOCATION__" -> begin
+ let off' = visitCilOffset (self :> cilVisitor) off in
+ (* Now fetch the value of this lval from the globinits *)
+ let i: init =
+ try IH.find globinits g.vid
+ with Not_found -> makeZeroInit g.vtype
+ in
+ (*
+ ignore (log "Find init for %a in %a\n"
+ d_lval (Var g, off)
+ d_init i);
+ *)
+ let rec findInit (i: init) (off: offset) : exp =
+ match off, i with
+ NoOffset, SingleInit e -> e (* We found it *)
+ | Index(idx, off'), CompoundInit (ct, inits) -> begin
+ let expToInt (e: exp) : int =
+ match isInteger (constFold true e) with
+ Some i -> to_int i
+ | None -> E.s (unimp "Integer index %a not a constant"
+ d_exp e)
+ in
+ let idxi : int = expToInt idx in
+ (* Find the field in the inits *)
+ let found : init option ref = ref None in
+ (try
+ foldLeftCompound
+ ~implicit:true
+ ~doinit:(fun off i t () ->
+ match off with
+ Index(thisidx, _) ->
+ let thisi = expToInt thisidx in
+ if thisi = idxi then begin
+ found := Some i;
+ raise Not_found (* Skip the rest *)
+ end
+ | _ -> assert false)
+ ~ct:ct
+ ~initl:inits
+ ~acc:()
+ with Not_found ->());
+
+ match !found with
+ Some i -> findInit i off'
+ | None ->
+ E.s (unimp "Cannot find initializer for %a"
+ d_lval (Var g, off))
+ end
+
+ | Field(fld, off'), CompoundInit (ct, inits) -> begin
+ (* Find the field in the inits *)
+ try
+ match List.find (function (Field(fld', _), _) -> fld' == fld
+ | _ -> assert false)
+ inits with
+ Field(_, _), fi -> findInit fi off'
+ | _ -> assert false
+ with Not_found ->
+ E.s (unimp "Cannot find initializer for field %s" fld.fname)
+ end
+ | _, SingleInit _ ->
+ E.s (unimp "SingleInit for compound value (%a)"
+ (d_offset (text g.vname)) off)
+ | NoOffset, CompoundInit _ ->
+ E.s (unimp "global initializer reads CompoundInit")
+ in
+ ChangeTo (findInit i off')
+ end
+ | SizeOfE _ | AlignOfE _ ->
+ (* Skip size/align because these may contain large array values.
+ * See small/global8. *)
+ SkipChildren
+ | _ -> DoChildren
+
+ method vinst (i: instr) =
+ (* Drop the instructions that initialize the initializers. Hopefully we
+ * do not drop other instructios too *)
+ match i with
+ Set _ -> ChangeTo []
+ | _ -> DoChildren
+
+ end in
+ gi.sbody <- visitCilBlock replaceGlobalsVisitor gi.sbody;
+
+ if !verbose then
+ log "optimize the global initializer\n";
+
+ (* Now we optimize *)
+ optim gi locUnknown;
+
+ let suppressGlobalInitWarnings = ref false in
+
+ (** Now check the global initializers, after the optimizations. Return true
+ * if we have residual checks for global initializer. *)
+ (* The global initializer function must be empty. Give an error message for
+ * each check in the file *)
+ let hadErrors = ref false in
+ let reportChecksVisitor = object (self)
+ inherit nopCilVisitor
+
+ method vexpr (e: exp) = SkipChildren
+
+ method vinst (i: instr) =
+ if (instrToCheck i) <> None then begin
+ hadErrors := true;
+ if not !suppressGlobalInitWarnings then begin
+ (* Doptions.strictGlobInit chooses whether this should be an
+ error or a warning. FIXME: always make it an error (bug?)
+ once we're sure we've covered all of the cases. *)
+ if !Doptions.strictGlobInit then
+ error "Undischarged check for global initializer:\n%a\n"
+ dn_instr i
+ else
+ ignore (warn "Undischarged check for global initializer:\n%a\n"
+ dn_instr i);
+ (* suppressGlobalInitWarnings := true; *)
+ end;
+ end;
+ SkipChildren
+
+ end in
+ suppressGlobalInitWarnings := false; (* We give one warning for each file *)
+ ignore (visitCilBlock (reportChecksVisitor :> cilVisitor) gi.sbody);
+
+ !hadErrors
--- /dev/null
+(*
+ *
+ * Copyright (c) 2006,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * Matthew Harren <matth@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 prepareGlobalInitializers : Cil.file -> Cil.fundec
+val checkGlobinit :
+ Cil.file -> Cil.fundec -> (Cil.fundec -> unit) ->
+ (Cil.fundec -> Cil.location -> unit) -> bool
--- /dev/null
+(*
+ *
+ * Copyright (c) 2004,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 Expcompare
+open Pretty
+open Dattrs
+open Doptions
+open Dutil
+open Dcheckdef
+open Dcheck
+
+module E = Errormsg
+module DC = Dcheck
+module DO = Doptimmain
+module S = Stats
+module N = Ptrnode
+module H = Hashtbl
+
+(**************************************************************************)
+
+
+(* Get the base type and attributes of a pointer type.
+ * If this is a void* type, see if we've inferred a better type for it. *)
+let getPointerType (t: typ) (where: string) : typ * attributes =
+ match unrollType t with
+ | TPtr (bt, a) when isVoidType bt -> begin
+ (* This is a void*. Have we inferred a better type for it?*)
+ match N.nodeOfAttrlist a with
+ Some n when not (isVoidType (N.get_rep n).N.btype) ->
+ (* we have a better type *)
+ let rep = N.get_rep n in
+ if hasAttribute "trusted" a || hasAttribute "ntexpand" a then begin
+ (* Don't replace *)
+ bt, a
+ end
+ else if (hasAttribute "bounds" a || hasAttribute "size" a)
+ && not (hasDefaultAnnot a) then
+ begin
+ (* Don't replace if this void* has an explicit annotation. *)
+ if !verbose then
+ log ("Not replacing %a in %s with a true type because "^^
+ "it has an annotation.\n")
+ dx_type t where;
+ bt, a
+ end
+ else begin
+ if !verbose then
+ log "Replacing %a in %s with %a."
+ dx_type t where dx_type (TPtr(rep.N.btype,a));
+ rep.N.btype, a
+ end
+ | _ -> (* No better type, so keep the void* *)
+ bt, a
+ end
+ | TPtr (bt, a) ->
+ bt, a
+ | _ -> E.s (error "Expected pointer type in %s" where)
+
+
+(**************************************************************************)
+
+let debugAuto = false
+
+
+let findnull = mkFun "deputy_findnull" intType
+ [typeAddAttributes [count0Attr; trustedAttr] voidPtrType; intType]
+
+let hasBoundsAttr (t: typ) : bool =
+ hasAttribute "bounds" (typeAttrs t)
+
+let getBoundsAttr (t: typ) : attrparam list =
+ match filterAttributes "bounds" (typeAttrs t) with
+ | [Attr ("bounds", aps)] -> aps
+ | [] -> E.s (bug "Expected bound attribute")
+ | _ -> E.s (error "Type has more than one bound attribute: \"%a\""
+ dx_type t)
+
+let setBoundsAttr (t: typ) (aps: attrparam list) : typ =
+ typeAddAttributes [Attr ("bounds", aps)] (typeRemoveAttributes ["bounds"] t)
+
+let hasAutoBounds (t: typ) : bool =
+ isPointerType t &&
+ hasBoundsAttr t &&
+ match getBoundsAttr t with
+ | [ACons (n, []); _] when n = autoKeyword -> true
+ | [_; ACons (n, [])] when n = autoKeyword -> true
+ | [_; _] -> false
+ | _ -> E.s (bug "Bounds attribute does not have two arguments")
+
+let mapBounds (fn: attrparam -> string -> attrparam) (aps: attrparam list)
+ : attrparam list =
+ match aps with
+ | [b; e] -> [fn b "b"; fn e "e"]
+ | _ -> E.s (bug "Bounds attribute does not have two arguments")
+
+(* The name of a fat structure, based on base type and the meta fields. We
+ * must differentiate in the name all attributes of types that we do not want
+ * to conflate. *)
+let fatStructName (bt: typ) (metafields: (string * typ) list) =
+ let rec btname = function
+ | TNamed (t, _) -> t.tname
+ | TBuiltin_va_list _ -> "va_list"
+ | TVoid(_) -> "void"
+ | TInt(IInt,_) -> "int"
+ | TInt(IUInt,_) -> "uint"
+ | TInt(IShort,_) -> "short"
+ | TInt(IUShort,_) -> "ushort"
+ | TInt(IChar,_) -> "char"
+ | TInt(IUChar,_) -> "uchar"
+ | TInt(ISChar,_) -> "schar"
+ | TInt(ILong,_) -> "long"
+ | TInt(IULong,_) -> "ulong"
+ | TInt(ILongLong,_) -> "llong"
+ | TInt(IULongLong,_) -> "ullong"
+ | TFloat(FFloat,_) -> "float"
+ | TFloat(FDouble,_) -> "double"
+ | TFloat(FLongDouble,_) -> "ldouble"
+ | TEnum (enum, _) -> "e_" ^ enum.ename
+ | TComp (comp, _) ->
+ let su = if comp.cstruct then "s_" else "u_" in
+ su ^ comp.cname
+ | TFun _ -> "fun"
+ | TPtr(t, a) ->
+ let atn =
+ if hasAttribute "nullterm" a then
+ "n"
+ else
+ ""
+ in
+ "p" ^ atn ^ "_" ^ btname t
+ | TArray(t, sz, _) -> "a_" ^ btname t
+ in
+ List.fold_left
+ (fun acc (s, _) ->
+ (* We assume that s starts with __ *)
+ acc ^
+ (if String.length s > 2 then
+ String.sub s 2 (String.length s - 2) else s))
+ ((btname bt) ^ "_")
+ metafields
+
+(** Keep a list of the fat structs, indexed by their name *)
+let fatStructs: (string, typ) H.t = H.create 13
+
+(** Keep a list of global declarations that we must add, in reverse order *)
+let preAutoDecls: global list ref = ref []
+
+(** Make a fat struct. Each field is described with a name and type. We
+ * assume that the names are of the form "__x", where "x" a suffix (either
+ * "b" or "e" for now). The main field is called __p and is always the first
+ * one. *)
+let makeFatStruct (dt: typ) (* type of the data field *)
+ (metafields: (string * typ) list) : typ =
+ (* Get the name of the fat struct, based on base type and suffixes *)
+ let fn = fatStructName dt metafields in
+ try H.find fatStructs fn
+ with Not_found -> begin
+ let fatci =
+ mkCompInfo true fn
+ (fun ci ->
+ (* Prepend the data field *)
+ ("__p", dt, None, [], !currentLoc) ::
+ List.map (fun (fn, ft) -> (fn, ft, None, [], !currentLoc))
+ metafields)
+ []
+ in
+ preAutoDecls := GCompTag(fatci, !currentLoc) :: !preAutoDecls;
+ let tfat = TComp(fatci, []) in
+ H.add fatStructs fn tfat;
+ tfat
+ end
+
+(** Test if a type is a fat structure *)
+let isFatStructType (t: typ) =
+ match unrollType t with
+ TComp(ci, _) when H.mem fatStructs ci.cname -> true
+ | _ -> false
+
+(** Get the data and meta fields of a fat compinfo. For each meta field we
+ * also have the suffix. *)
+let getFieldsOfFatComp (ci: compinfo) : fieldinfo * (string * fieldinfo) list =
+ match ci.cfields with
+ fdata :: fmetas when fdata.fname = "__p" ->
+ let metas: (string * fieldinfo) list =
+ List.map
+ (fun fm ->
+ (* We assume that the field name is __e, etc *)
+ let suff =
+ if String.length fm.fname > 2 then
+ String.sub fm.fname 2 (String.length fm.fname - 2)
+ else
+ fm.fname
+ in
+ (suff, fm))
+ fmetas
+ in
+ fdata, metas
+
+ | _ -> E.s (bug "The data field is not the first one in %s\n" ci.cname)
+
+(** Get the data and meta fields of a fat compinfo. *)
+let getFieldsOfFat (t: typ) : (fieldinfo * (string * fieldinfo) list) option =
+ match unrollType t with
+ TComp(ci, _) when H.mem fatStructs ci.cname ->
+ Some (getFieldsOfFatComp ci)
+
+ | _ -> None
+
+
+(* Split a fat lval into the data one and the meta lvals, each one with the
+ * suffix. Return None if not a fat struct lval. *)
+let splitFatLval (lv: lval) : (lval * (string * lval) list) option =
+ let lvt = typeOfLval lv in
+ let lvbase, lvoff = lv in
+ match unrollType lvt with
+ TComp(ci, _) when H.mem fatStructs ci.cname -> begin
+ let fdata, fmeta = getFieldsOfFatComp ci in
+ Some ((lvbase, addOffset (Field(fdata, NoOffset)) lvoff),
+ List.map (fun (suff, fm) ->
+ (suff, (lvbase, addOffset (Field(fm, NoOffset)) lvoff))) fmeta)
+
+ end
+ | _ -> None
+
+
+(** Get the data field, if any, from a fat struct lval *)
+let getDataFromFatLval (lv: lval) : lval =
+ match getFieldsOfFat (typeOfLval lv) with
+ None -> lv
+ | Some (fdata, _) -> begin
+ let reslv = addOffsetLval (Field(fdata, NoOffset)) lv in
+ reslv
+ end
+
+
+(** Get an lval denoting the whole fat value, from a data value. Return
+ * the input lval if not a data lval *)
+let getFatFromDataLval (lv: lval) : lval =
+ match removeOffsetLval lv with
+ lv', Field(fdata, NoOffset) -> begin
+ try
+ if H.mem fatStructs fdata.fcomp.cname &&
+ fdata == List.nth fdata.fcomp.cfields 0 then
+ lv'
+ else
+ lv
+ with _ -> lv
+ end
+
+ | _ -> lv
+
+
+(** Get an expression denoting the whole fat value, from a data value. Return
+ * the input expression if not a data expression *)
+let getFatFromDataExp (e: exp) : exp =
+ match e with
+ Lval lv -> begin
+ let lv' = getFatFromDataLval lv in
+ if lv' != lv then
+ Lval lv'
+ else
+ e
+ end
+ | _ -> e
+
+
+let makeHiddenVar (fdec: fundec) (name: string) (t: typ) : varinfo =
+ let vi = makeLocalVar fdec name t in
+ vi.vattr <- addAttribute hiddenAttr vi.vattr;
+ vi
+
+(* This visitor is responsible for converting "__auto" in bounds annotation
+ * into fresh variables and fat structures that have properly-assigned
+ * bounds. *)
+let autoVisitor = object (self)
+ inherit nopCilVisitor
+
+ (** Map a variable name to a list of new bound variables added for it, each
+ * with the suffix "b" or "e" and the variable name. Use find_all to get
+ * all the bounds. *)
+ val varBounds : (string, (string * varinfo)) Hashtbl.t =
+ Hashtbl.create 7
+
+ (** The current return type of the function, already processed *)
+ val mutable currentReturnType = intType
+
+ (** Indicates whether we are currently processing trusted code. *)
+ val mutable trustedCode = false
+
+ val mutable curIndex = 0
+ method private makeName (base: string) =
+ curIndex <- curIndex + 1;
+ base ^ (string_of_int curIndex)
+
+ (* Get the fancybounds of this expression, for the purposes of
+ * setting automatic bound variables. *)
+ method private getPointerBounds (toType: typ) (fromType: typ) (e: exp) =
+ let lo, hi =
+ if hasAttribute "fancysize" (typeAttrs fromType) then
+ fancyBoundsOfSizeType toType fromType e
+ else
+ fancyBoundsOfType fromType
+ in
+ (* We expand the range of nullterms with deputy_findnull (like strlen)
+ * when NTEXPAND is used, or when we cast from something with
+ * fixed bounds to a local/cast with automatic bounds. *)
+ let doExpandNullterm: bool =
+ isNulltermExpand toType ||
+ (isNullterm fromType && not (isNullterm toType))
+ in
+ if doExpandNullterm then
+ let tmp = makeHiddenVar !curFunc (self#makeName "deplength") intType in
+ let sz =
+ match unrollType fromType with
+ | TPtr (bt, _) -> bitsSizeOf bt / 8
+ | _ -> E.s (error "Expected pointer type")
+ in
+ let instrs =
+ [Call (Some (var tmp), findnull, [hi; integer sz], !currentLoc)]
+ in
+ let hi' = BinOp (PlusPI, hi, Lval (var tmp), typeOf hi) in
+ instrs, lo, hi'
+ else
+ [], lo, hi
+
+ (* Get the upper and lower bounds for an expression e when assigning to
+ * a variable of type toType. Also two lists of instructions that
+ * must be inserted into the program before and after using the
+ * expressions. *)
+ method private getBounds (instr: instr) (toType: typ)
+ : instr list * exp * exp * exp * instr list =
+ DC.startExtraInstrs ();
+ let e, t, endInstrs = DC.checkInstrRhs instr in
+ let beginInstrs = DC.endExtraInstrs () in
+ if isPointerType t then
+ let instrs', lo, hi = self#getPointerBounds toType t e in
+ beginInstrs @ instrs', e, lo, hi, endInstrs
+ else
+ beginInstrs, e, e, e, endInstrs
+
+ (* Given a type t whose bounds contain the "__auto" keyword, create
+ * fresh variables with the given base name. The global flag indicates
+ * whether the new variables should be globals. Returns the new type
+ * with the fresh variables substituted, along with a list of the new
+ * variables for each bound (given as strings "b" and "e"). *)
+ method private makeNewVars (t: typ) (baseName: string)
+ : typ * (string * string * typ) list =
+ let addedVars : (string * string * typ) list ref = ref [] in
+ let bounds = getBoundsAttr t in
+ let bounds' =
+ mapBounds
+ (fun ap suffix ->
+ match ap with
+ | ACons (n, []) when n = autoKeyword ->
+ let name = baseName ^ "__" ^ suffix in
+ let t' =
+ typeAddAttributes sentinelAttrs
+ (typeRemoveAttributes ["bounds"] t)
+ in
+ addedVars := (suffix, name, t') :: !addedVars;
+ ACons (name, [])
+ | _ -> ap)
+ bounds
+ in
+ setBoundsAttr t bounds', !addedVars
+
+
+ (* Given a list of suffix/type pairs, where the suffix "b" or "e"
+ * indicates the purpose of the type, create a list of expressions that
+ * can be used to set these variables of this type to the given low and
+ * high bounds appropriately. *)
+ method private makeSetExps (addedTypes: (string * typ) list)
+ (lo: exp) (hi: exp) : exp list =
+ List.fold_right
+ (fun (suffix, rhs) acc ->
+ if List.mem_assoc suffix addedTypes then
+ (stripNopCasts rhs) :: acc
+ else
+ acc)
+ [("b", lo); ("e", hi)]
+ []
+
+ (* Given a list of suffix/lval pairs, where the suffix "b" or "e"
+ * indicates the purpose of the lval, create a list of instructions that
+ * set these variables to the given low and high bounds appropriately. *)
+ method private makeSetInstrs (addedLvals: (string * lval) list)
+ (lo: exp) (hi: exp) : instr list =
+ List.fold_right
+ (fun (suffix, rhs) acc ->
+ try
+ let lv = List.assoc suffix addedLvals in
+ Set (lv, (stripNopCasts rhs), !currentLoc) :: acc
+ with Not_found ->
+ acc)
+ [("b", lo); ("e", hi)]
+ []
+
+
+ (** Process a type. This is done w.r.t a function that can process new
+ * names. If the function is not given then we use fat pointers (the
+ * default case) *)
+ val mutable typeProcessMeta :
+ (string (* base name for makeVars *) *
+ (string * string * typ -> unit) (* function to process a meta, with
+ * suffix, name, and type. *)
+ ) option = None
+ method vtype (t: typ) =
+ (* Save the processor as we see this type *)
+ let savedProcessor = typeProcessMeta in
+ (* Turn off the processor for nested types, always *)
+ typeProcessMeta <- None;
+
+ match unrollType t with
+ TPtr(bt, a) as t' -> begin
+ let bt' = visitCilType (self :> cilVisitor) bt in
+ if not (hasAutoBounds t') then
+ if bt' == bt then SkipChildren else ChangeTo (TPtr(bt', a))
+ else
+ match savedProcessor with
+ None ->
+ (* We just generate the names for the fields *)
+ let t'', addedNames = self#makeNewVars (TPtr(bt', a)) "" in
+ (* make the structure *)
+ let fat : typ = makeFatStruct t''
+ (List.map (fun (_, n, t) -> (n, t)) addedNames) in
+ ChangeTo fat
+
+ | Some (basename, process) ->
+ let t'', addedNames = self#makeNewVars t' basename in
+ (* process them *)
+ List.iter process addedNames;
+ ChangeTo t''
+ end
+
+ | TArray (bt, leno, a) ->
+ let bt' = visitCilType (self :> cilVisitor) bt in
+ let leno' =
+ match leno with
+ None -> None
+ | Some len -> Some (visitCilExpr (self :> cilVisitor) len)
+ in
+ if bt == bt' && leno == leno' then
+ SkipChildren
+ else
+ ChangeTo (TArray(bt', leno', a))
+
+ (* Process the function type. This is only invoked for prototypes and
+ * pointers to functions. For function definitions we do the same thing
+ * indirectly by processing the formals *)
+ | TFun (rt, formals, isva, a) -> begin
+ (* Do the return type *)
+ let rt' = visitCilType (self :> cilVisitor) rt in
+ (* Do the formals in expanded form *)
+
+ let formals' =
+ match formals with
+ None -> None
+ | Some formals -> begin
+ (* Add the formals in the right order, first the data and then
+ * the meta fields. *)
+ let formals' : (string * typ * attributes) list ref = ref [] in
+ (* Specify after how many to add. Use negative number for end *)
+ let addFormal (after: int) f =
+ let rec loop after = function
+ | rest when after = 0 -> f :: rest
+ | [] -> [f]
+ | f1 :: rest -> f1 :: loop (after - 1) rest
+ in
+ formals' := loop after !formals'
+ in
+
+ List.iter
+ (fun (fName, fType, fAttrs) ->
+ (* We never leave the formals in fat form *)
+ let formalMetaProcessor (suff, mname, mtype) =
+ (* We get here because we have a formal *)
+ (* We better have a name for this formal *)
+ if fName = "" then
+ E.s (error "Formal with auto-bounds must have name");
+ (* Always add meta formals at end of list *)
+ addFormal (-1) (mname, mtype, []);
+ in
+ typeProcessMeta <- Some (fName, formalMetaProcessor);
+ (* Process the type and add the meta formals *)
+ let placeForDataFormal = List.length !formals' in
+ let fType' = visitCilType (self :> cilVisitor) fType in
+ typeProcessMeta <- None;
+ (* Add the data formal *)
+ addFormal placeForDataFormal (fName, fType', []);
+ )
+
+ formals;
+
+ Some !formals'
+ end
+ in
+
+ ChangeTo (TFun(rt', formals', isva, a))
+ end
+ | _ -> DoChildren
+
+
+ (* Process expressions. Normally all expressions that would end up as fat,
+ * are transformed to refer to the data element. This is mostly achieved by
+ * vlval, but we need some special cases done here. *)
+ method vexpr e =
+ let ve e = visitCilExpr (self :> cilVisitor) e in
+ let vt t = visitCilType (self :> cilVisitor) t in
+ let vl l = visitCilLval (self :> cilVisitor) l in
+
+ let te e =
+ let saveTrustedCode = trustedCode in
+ trustedCode <- true;
+ let e' = ve e in
+ trustedCode <- saveTrustedCode;
+ e'
+ in
+
+ match e with
+ | SizeOfE e' ->
+ (* We process sizeof in fat mode, since we want the size of the
+ * actual structure, if relevant. We use 'te' in order to turn
+ * on the trusted flag--this code will not actually be executed! *)
+ let e2 = getFatFromDataExp (te e') in
+ if e2 != e' then ChangeTo (SizeOfE e2) else SkipChildren
+
+ | AlignOfE e' ->
+ (* Same as sizeof. *)
+ let e2 = getFatFromDataExp (te e') in
+ if e2 != e' then ChangeTo (AlignOfE e2) else SkipChildren
+
+ | BinOp ((PlusPI | IndexPI | MinusPI) as bop, e1, e2, t) ->
+ (* We must not do the t, or else vtype will change it. *)
+ let e1' = ve e1 in
+ let e2' = ve e2 in
+ (* Ordinarily, we would SkipChildren unless e1 != e1' or e2 != e2'.
+ * However, we need to make sure that we set the type properly,
+ * eliminating __auto, even if the expressions themselves haven't
+ * changed. See small/auto9. *)
+ ChangeTo (BinOp (bop, e1', e2', typeOf e1'))
+
+ | BinOp (bop, e1, e2, t) ->
+ if isPointerType t then
+ E.s (bug "Unexpected pointer type in non-pointer binop");
+ DoChildren
+
+ (* When we take the address of, we take the address of the fat thing *)
+ | StartOf lv
+ | AddrOf lv ->
+ let lv' = vl lv in
+ let lvFat = getFatFromDataLval lv' in
+ if lvFat != lv' && trustedCode then
+ E.s (error ("In trusted code, you may not take the address of "
+ ^^"%a, which has auto bounds.") dx_lval lv);
+ if lvFat != lv then
+ ChangeTo (mkAddrOrStartOf lvFat)
+ else
+ SkipChildren
+
+ | CastE (t, e') when trustedCode ->
+ (* In trusted code, we make no changes to casts. We still need to
+ * process the expression in case reads of auto globals need
+ * expansion. *)
+ ChangeTo (CastE (t, ve e'))
+
+ (* Handle automatic bounds in casts. We create fresh variables and
+ * assign them based on the expression to be cast. *)
+ | CastE (t, e') when hasAutoBounds t -> begin
+ if !curFunc == dummyFunDec then
+ E.s (error "Casts in global initializers may not have auto bounds");
+ let t = (* FIXME: NTEXPAND macro should set the type *)
+ if isNulltermExpand t then
+ setTypeAttrs (typeOf e') (nulltermAttr :: typeAttrs t)
+ else
+ t
+ in
+ (* Do the type. If it has auto bounds, we make new local variables
+ * for them *)
+ let boundLocals: (string * lval) list ref = ref [] in
+ let castTypeProcessor (suff, mname, mtype) =
+ let lv = makeHiddenVar !curFunc mname mtype in
+ boundLocals := (suff, var lv) :: !boundLocals
+ in
+ typeProcessMeta <- Some ((self#makeName "cbound"), castTypeProcessor);
+ let t' = vt t in
+ typeProcessMeta <- None;
+ let e2 = ve e' in
+ (* We must create assignments *)
+ (* make an instruction, to get the bounds *)
+ let instr = Set ((Mem zero, NoOffset), e2, !currentLoc) in
+ let begini, e3, lo, hi, endi = self#getBounds instr t' in
+ if endi <> [] then
+ E.s (unimp "Post-instructions when processing cast");
+ let boundType =
+ typeAddAttributes sentinelAttrs (typeRemoveAttributes ["bounds"] t')
+ in
+ let il =
+ self#makeSetInstrs !boundLocals
+ (mkCast lo boundType) (mkCast hi boundType)
+ in
+ self#queueInstr (begini @ il);
+ ChangeTo (CastE (t', e3))
+ end
+
+ | _ -> DoChildren (* The rest are known to be non fat already, because
+ * all fat have been taken care by vlval *)
+
+ (* Get the data field of lvals *)
+ method vlval (lv: lval) =
+ ChangeDoChildrenPost (lv, getDataFromFatLval)
+
+
+
+ method vinst i =
+ (* We first process the children and then we cleanup, first the calls,
+ * then the Set instructions *)
+
+
+ let processCall (instr: instr) : instr list (* some preamble, already
+ * processed *)
+ * instr (* replacement instruction *)
+ =
+ match instr with
+ Call(retlv, func, args, l) -> begin
+ let rett, formals =
+ match typeOf func with
+ | TFun (rett, argInfo, _, _) -> rett, (argsToList argInfo)
+ | _ -> E.s (bug "Expected function type")
+ in
+ (* Deal with the arguments *)
+ let (beginInstrs: instr list), (args': exp list) =
+ let rec loopArgs (formals: (string * typ * attributes) list)
+ (actuals: exp list) : instr list * exp list =
+ if formals = [] then
+ (* We ran out of formals, a vararg *)
+ [], actuals
+ else if actuals = [] then
+ (* We ran out of actuals *)
+ E.s (error "Function call has too few arguments")
+ else begin
+ let (fn: string), (ft: typ), restformals =
+ match formals with
+ (fn, ft, _) :: restformals -> fn, ft, restformals
+ | _ -> assert false
+ in
+ (** See if we have some meta formals that follow *)
+ let (metaFormals: (string * typ) list), restformals' =
+ let rec loopFormals = function
+ [] -> [], []
+ | ((fn1, ft1, _) :: rest) as formals ->
+ let meta', rest' = loopFormals rest in
+ (* If fn1 is fn__b or fn__e then it is ours *)
+ if fn1 = fn ^ "__b" then
+ (("b", ft1) :: meta'), rest'
+ else if fn1 = fn ^ "__e" then
+ (("e", ft1) :: meta'), rest'
+ else
+ [], formals
+ in
+ loopFormals restformals
+ in
+ let arg, restactuals' =
+ match actuals with
+ arg :: restactuals -> arg, restactuals
+ | _ -> assert false
+ in
+
+ (* Process the rest now *)
+ let instrs', actuals'' = loopArgs restformals' restactuals' in
+
+ if metaFormals = [] then begin
+ (* Not an auto formal *)
+ instrs', arg :: actuals''
+ end else if trustedCode then begin
+ error ("Calling function %a from trusted code. Trusted code"
+ ^^" is not modified by Deputy, so it may not use"
+ ^^" functions that have auto bounds.") dx_exp func;
+ instrs', arg :: actuals''
+ end else begin
+ (* It was an auto formal. Get the bounds *)
+ (* Dummy instr; the bogus lval will be ignored. *)
+ let instr = Set ((Mem zero, NoOffset), arg, !currentLoc) in
+ let beginInstrs, arg', lo, hi, endInstrs =
+ self#getBounds instr ft
+ in
+ if endInstrs <> [] then
+ E.s (bug "Expected empty endInstrs");
+ beginInstrs @ instrs',
+ arg' :: self#makeSetExps metaFormals lo hi @ actuals''
+ end
+ end
+ in
+ loopArgs formals args
+ in
+ (* If the return type of the function is fat, then we introduce a
+ * temporary variable *)
+ if isFatStructType rett && retlv != None then begin
+ let tmp = makeHiddenVar !curFunc (self#makeName "ret") rett in
+ let retlv: lval =
+ match retlv with Some retlv -> retlv | _ -> assert false
+ in
+ beginInstrs @ [Call(Some (var tmp), func, args', l)],
+ (* Turn the instruction into something that you would get from
+ * preprocessing a set instruction *)
+ Set (getDataFromFatLval retlv,
+ Lval (getDataFromFatLval (var tmp)), l)
+ end else
+ beginInstrs, Call (retlv, func, args', l)
+ end
+ | _ -> [], instr
+ in
+
+ (* Helpers for processLhs, below. *)
+ let makeInstrs ~(isALocal:bool)
+ (addedLvals: (string * lval) list)
+ (instr: instr) (lv: lval) : instr list =
+ assert (not trustedCode); (* Don't modify trusted blocks *)
+ let lvType = typeOfLval lv in
+ let beginInstrs, e, lo, hi, endInstrs = self#getBounds instr lvType in
+ (* We don't need to zero locals; liveness handles this issue for us *)
+ let zeroInstrs =
+ if isALocal then [] else [Set (lv, zero, !currentLoc)] in
+ let setInstrs = self#makeSetInstrs addedLvals lo hi in
+ let instr' = Set (lv, e, !currentLoc) in
+ beginInstrs @ zeroInstrs @ setInstrs @ [instr'] @ endInstrs
+ in
+
+ (* If we're setting a variable with automatic bounds, get the bounds
+ * from the RHS and assign the automatic bounds variables. *)
+ let processLhs (instr: instr) : instr list =
+ (* If lv is a local split variable *)
+ let getSplitMetas lv: (string * varinfo) list =
+ match lv with
+ (Var vi, NoOffset) when not vi.vglob ->
+ H.find_all varBounds vi.vname
+ | _ -> []
+ in
+ let lvHasAuto lv: bool =
+ ((getSplitMetas lv) <> [])
+ || ((splitFatLval (getFatFromDataLval lv)) <> None)
+ in
+ match instr with
+ | Set (lv, _, _)
+ | Call (Some lv, _, _, _) -> begin
+ (* If lv is a local split variable *)
+ let splitMetas = getSplitMetas lv in
+ if splitMetas <> [] then begin
+ if trustedCode then
+ E.s (error ("Trusted block assigns to \"%a\", which has auto"
+ ^^" bounds. Trusted blocks are not modified by Deputy,"
+ ^^" so they may not use variables that have auto bounds.")
+ dx_lval lv);
+ makeInstrs ~isALocal:true
+ (List.map (fun (suff, vil) -> (suff, var vil)) splitMetas)
+ instr
+ lv
+ end else begin
+ (* See if it this is the data of a fat type *)
+ let lvfat = getFatFromDataLval lv in
+ match splitFatLval lvfat with
+ None -> (* Not a fat lval, must be regular lval *)
+ [instr]
+ | Some (lvdata, lvmeta) ->
+ if trustedCode then
+ E.s (error
+ ("Trusted code assigns to \"%a\", which has auto "
+ ^^"bounds. Trusted code is not modified by Deputy, "
+ ^^"so it may not use lvalues that have auto bounds.")
+ dx_lval lv);
+ (* Change the instruction to use lvdata instead *)
+ let instr' =
+ match instr with
+ Set (lv, e, l) -> Set (lvdata, e, l)
+ | Call (Some lv, func, args, l) ->
+ Call (Some lvdata, func, args, l)
+ | _ -> assert false
+ in
+ makeInstrs ~isALocal:false lvmeta instr' lvdata
+ end
+ end
+ | Call(None, _, _, _) ->
+ [instr]
+ | Asm(_,_,outputs,_,_,_) ->
+ List.iter
+ (fun (_,_,lv) ->
+ if lvHasAuto lv then begin
+ (* Inline asm modifies something with Deputy-controlled
+ metadata. This will cause runtime problems.*)
+ error
+ "Inline assembly modifies \"%a\", which has auto bounds."
+ dx_lval lv
+ end)
+ outputs;
+ [instr]
+ in
+
+ (* Process the LHS and the RHS separately. For the RHS, we need to
+ * adjust calls whose arguments involve automatic bounds. For the
+ * LHS, we need to handle cases where the LHS of a call or set has
+ * automatic bounds. *)
+ let postProcessInstrs (instrs: instr list) : instr list =
+ match instrs with
+ | [] -> []
+ | [instr] ->
+ let beginInstrs, instr' = processCall instr in
+ beginInstrs @ processLhs instr'
+ | _ -> E.s (bug "Expected at most one instruction")
+ in
+ ChangeDoChildrenPost([i], postProcessInstrs)
+
+ method vstmt (s: stmt) =
+ match s.skind with
+ Return (Some rv, l) ->
+ (* If the return type is fat, then create a new fat local and we copy
+ * the return value in there before we return *)
+ if trustedCode then begin
+ if isFatStructType currentReturnType then
+ E.s (error "Trusted block contains return of fat type");
+ DoChildren
+ end else if isFatStructType currentReturnType then begin
+ (* If the type is fat then we make a new local with the fat type *)
+ let newl = makeHiddenVar !curFunc (self#makeName "ret")
+ currentReturnType in
+ let newlv = (Var newl, NoOffset) in
+ (* make an instruction to assign to the new local *)
+ let instr = Set (newlv, rv, !currentLoc) in
+ (* process the instruction *)
+ let il = visitCilInstr (self :> cilVisitor) instr in
+ self#queueInstr il;
+ (* Now we want to return the whole fat thing *)
+ s.skind <- Return (Some (Lval (getFatFromDataLval newlv)), l);
+ SkipChildren
+ end else
+ DoChildren
+
+ | _ -> DoChildren
+
+ method vblock (b: block) =
+ let saveTrustedCode = trustedCode in
+ trustedCode <- saveTrustedCode || isTrustedAttr b.battrs;
+ let postProcessBlock (b: block) =
+ trustedCode <- saveTrustedCode;
+ b
+ in
+ ChangeDoChildrenPost (b, postProcessBlock)
+
+ (* Handle locals with automatic bounds. Here we create the new
+ * variables and update the type of the corresponding local variable. *)
+ method vfunc fd =
+ Hashtbl.clear varBounds;
+ curFunc := fd;
+ trustedCode <- isTrustedType fd.svar.vtype;
+
+ (* We process the formals first. This will fix the type of the function
+ * also. *)
+ let where : string ref = ref "" in (* Where to add the formal *)
+ List.iter (fun vi ->
+ let metaForFormal (suff, varName, varType) =
+ if vi.vaddrof then
+ E.s (unimp "You cannot take the address of a formal (%s) with auto-bounds. Use a copy\n" vi.vname);
+
+ (* We make the formal, and we put it in all places *)
+ let vif = makeFormalVar !curFunc ~where:!where varName varType in
+ H.add varBounds vi.vname (suff, vif);
+ where := vif.vname
+ in
+ typeProcessMeta <- Some (vi.vname, metaForFormal);
+ where := vi.vname; (* Add the first one right after this one *)
+ vi.vtype <- visitCilType (self :> cilVisitor) vi.vtype;
+ typeProcessMeta <- None)
+
+ fd.sformals;
+
+ if not trustedCode then begin
+ (* Now take care of the locals *)
+ List.iter
+ (fun vi ->
+ (* If we take the address of this one, or involved in return, we
+ * leave if fat *)
+ let metaForLocal: (string * (string * string * typ -> unit)) option=
+ if vi.vaddrof then
+ None
+ else
+ Some (vi.vname,
+ fun (vSuff, vName, vType) ->
+ let vil = makeHiddenVar !curFunc vName vType in
+ H.add varBounds vi.vname (vSuff, vil))
+ in
+ typeProcessMeta <- metaForLocal;
+ let t' = visitCilType (self :> cilVisitor) vi.vtype in
+ typeProcessMeta <- None;
+ vi.vtype <- t')
+ fd.slocals;
+
+ (* Process the return type *)
+ (match fd.svar.vtype with
+ TFun(rt, args, isva, l) ->
+ typeProcessMeta <- None;
+ let rt' = visitCilType (self :> cilVisitor) rt in
+ currentReturnType <- rt';
+ fd.svar.vtype <- TFun(rt', args, isva, l)
+ | _ -> assert false);
+ end;
+
+
+ let cleanup x =
+ Hashtbl.clear varBounds;
+ curFunc := dummyFunDec;
+ trustedCode <- false;
+ x
+ in
+ ChangeDoChildrenPost (fd, cleanup)
+
+
+ (** process the initializers *)
+ method vinit (forg: varinfo) (off: offset) (i: init) =
+ (* The initializers have already been processed. We must turn SingleInit
+ * for fat into CompoundInit *)
+ let postInit (i: init) =
+ match i with
+ SingleInit e -> begin
+ let expected_t = typeOffset forg.vtype off in
+ match getFieldsOfFat expected_t with
+ None -> (* Not a fat type *) i
+ | Some (fdata, fmetas) ->
+ (* Dummy instr; the bogus lval will be ignored. *)
+ let instr = Set ((Mem zero, NoOffset), e, !currentLoc) in
+ let beginInstrs, arg', lo, hi, endInstrs =
+ self#getBounds instr fdata.ftype
+ in
+ if beginInstrs <> [] || endInstrs <> [] then
+ E.s (unimp "Processing initializer %a (for %s) requires instructions" d_exp e forg.vname);
+ (* Prepare the fmetas for makeSetExps *)
+ let addedTypes : (string * typ) list =
+ List.map (fun (suff, f) -> (suff, f.ftype)) fmetas in
+ let addedInits: exp list = self#makeSetExps addedTypes lo hi in
+ (* Now package the list of initializers *)
+ CompoundInit (expected_t,
+ (Field(fdata, NoOffset), SingleInit e) ::
+ (List.map2
+ (fun (_, fm) i ->
+ (Field(fm, NoOffset), SingleInit i))
+ fmetas
+ addedInits))
+ end
+ | CompoundInit _ -> i
+ in
+ ChangeDoChildrenPost (i, postInit)
+
+ method vvdec (vi: varinfo) =
+ (* We preprocess first, to get the new type *)
+ let postVar (vi: varinfo) : varinfo =
+ (* see if a type contains or refers to fat pointers *)
+ let containsAutoType (t: typ) : bool =
+ existsType
+ (function
+ TComp (ci, _) when H.mem fatStructs ci.cname -> ExistsTrue
+ | _ -> ExistsMaybe)
+ t
+ in
+ if vi.vglob && vi.vstorage <> Static then begin
+ (* Perhaps the name is already changed *)
+ let vil = String.length vi.vname in
+ if vil > 7 && String.sub vi.vname (vil - 8) 8 = "__deputy" then
+ (* We already have the mangled name *)
+ ()
+ else if containsAutoType vi.vtype then
+ vi.vname <- vi.vname ^ "__deputy"
+ end;
+ vi
+ in
+ ChangeDoChildrenPost(vi, postVar)
+
+ (* Handle functions, globals, and structures with automatic bounds. *)
+ method vglob g =
+ preAutoDecls := [];
+ ChangeDoChildrenPost([g],
+ (fun x -> (List.rev !preAutoDecls) @ x))
+end
+
+
+(**************************************************************************)
+
+
+let needsAnnot (t: typ) : bool =
+ isPointerType t &&
+ let attrs = typeAttrs t in
+ not (hasAttribute "bounds" attrs) &&
+ not (hasAttribute "size" attrs)
+
+let isCharPtr (t: typ) : bool =
+ match unrollTypeDeep t with
+ | TPtr (TInt ((IChar | ISChar | IUChar), _), _) -> true
+ | _ -> false
+
+let isCharArray (t: typ) : bool =
+ match unrollTypeDeep t with
+ | TArray (TInt ((IChar | ISChar | IUChar), _), _, _) -> true
+ | _ -> false
+
+(* This visitor is responsible for inferring bound and nullterm
+ * annotations when not otherwise provided by the programmer. We use the
+ * results from CCured's inference for locals, and we guess annotations
+ * for globals, function parameters, and structure fields. *)
+let inferVisitor = object (self)
+ inherit nopCilVisitor
+
+ (* Keep track of vars that didn't have a programmer-supplied anntoation. *)
+ val mutable unannotatedVars : varinfo list = []
+
+ (* Builtins can appear in the code without a preceding declaration,
+ * so we make sure to check out their types too. *)
+ method vvrbl v =
+ v.vtype <- visitCilType self v.vtype;
+ DoChildren
+
+ (* This is the catchall case. If a type has not otherwise been assigned
+ * a type (e.g., by CCured inference), then guess. *)
+ method vtype t =
+ let postProcessType (t: typ) =
+ if needsAnnot t then
+ let newAnnots =
+ if !assumeString && isCharPtr t then
+ stringAttrs
+ else
+ [safeAttr]
+ in
+ typeAddAttributes (missingAnnotAttr :: newAnnots) t
+ else if isArrayType t then
+ match unrollType t with
+ | TArray (_, Some e, a) ->
+ let n =
+ match isInteger (constFold true e) with
+ | Some n -> to_int n
+ | None -> E.s (bug "Array length could not be determined")
+ in
+ let n' =
+ if isNullterm t then
+ if n = 0 then begin
+ error "Cannot have nullterm array with zero length.";
+ 0
+ end else
+ n - 1
+ else
+ n
+ in
+ if not (hasAttribute "bounds" a) || n' > 0 then
+ typeAddAttributes [countAttr (AInt n')]
+ (typeRemoveAttributes ["bounds"] t)
+ else
+ t
+ | TArray (_, None, a) ->
+ if not (hasAttribute "bounds" a) then
+ typeAddAttributes [count0Attr] t
+ else
+ t
+ | _ -> E.s (bug "Expected array type")
+ else
+ t
+ in
+ ChangeDoChildrenPost (t, postProcessType)
+
+ (* Infer annotations for types in casts. *)
+ method vexpr e =
+ (* Assign string constants to a temporary variable that is exempt from
+ * Deputy checks. The reason is that two identical string constants
+ * may not always evaluate to the same address; thus, when adding
+ * checks on such variables, we need to make sure that we refer to the
+ * same address in all parts of the check. *)
+ let fixStr (t: typ) (length: int) : exp =
+ (* Add a temp with annotation NT COUNT(stringlen) *)
+ let lengthAttr = countAttr (AInt length) in
+ let t = typeAddAttributes [lengthAttr; nulltermAttr] t in
+ let tmp = makeTempVar !curFunc t in
+ addTempInfoSet tmp e;
+ DC.exemptLocalVars := tmp :: !DC.exemptLocalVars;
+ self#queueInstr [Set (var tmp, e, locUnknown)];
+ Lval (var tmp)
+ in
+ let e' =
+ match e with
+ | Const (CStr str) when !curFunc != dummyFunDec ->
+ (* JC: We use charPtrType instead of (typeOf e) because the
+ * latter results in lots of warnings relating to const casts. *)
+ fixStr charPtrType (String.length str)
+ | Const (CWStr wchars) when !curFunc != dummyFunDec ->
+ fixStr (TPtr (!wcharType, [])) (List.length wchars)
+
+ (* All trusted types are converted to auto types. This change is
+ * necessary because the TC macro uses typeof(), which can
+ * otherwise introduce invalid annotations. *)
+ | CastE (t, e') when isPointerType t && isTrustedType t &&
+ !curFunc != dummyFunDec ->
+ let t' =
+ typeAddAttributes [autoAttr] (typeRemoveAttributes ["bounds"] t)
+ in
+ CastE (t', e')
+
+ | CastE (t, e') when isNulltermExpand t && !curFunc != dummyFunDec ->
+ let bt, a = getPointerType t "the cast" in
+ let a = dropAttribute "bounds" a in
+ mkCast e' (TPtr (bt, addAttribute autoEndAttr a))
+ | CastE (t, e') when needsAnnot t && !curFunc != dummyFunDec ->
+ (* Make sure we're not casting from a trusted pointer. *)
+ if isTrustedType (typeOf e') then
+ error ("Target of trusted cast must have user-supplied bounds:\n" ^^
+ " from: %a\n" ^^
+ " to: %a\n" ^^
+ " exp: %a")
+ dt_type (typeOf e') dt_type t dx_exp e';
+ (* First adjust the type for void* polymorphism. *)
+ let bt, a = getPointerType t "the cast" in
+ let a = dropAttribute "bounds" a in
+ (* Now see if we need to add an annotation. *)
+ let kind, _ = N.inferredKindOf a in
+ let a =
+ if N.kindIsNullterm kind && not (hasAttribute "nullterm" a) then
+ addAttribute nulltermAttr a
+ else
+ a
+ in
+ begin
+ match kind with
+ | N.Safe when not (isVoidPtrType (typeOf e')) &&
+ not (isTrustedType t) ->
+ mkCast e' (TPtr (bt, addAttribute safeAttr a))
+
+ | N.Sentinel ->
+ mkCast e' (TPtr (bt, addAttribute count0Attr a))
+ | N.String when not (isNulltermExpand t) ->
+ mkCast e' (TPtr (bt, addAttribute count0Attr a))
+ | N.FSeq | N.FSeqN ->
+ mkCast e' (TPtr (bt, addAttribute autoEndAttr a))
+ | _ ->
+ mkCast e' (TPtr (bt, addAttribute autoAttr a))
+ end
+ | _ -> e
+ in
+ ChangeDoChildrenPost (e', (fun e -> e))
+
+ (* Make sure the left-hand side of a TC is fully annotated. *)
+ method vinst i =
+ let check (vi: varinfo) (t: typ) : unit =
+ if List.memq vi unannotatedVars && isTrustedType t then
+ error "Target \"%s\" of trusted cast must have user-supplied bounds"
+ vi.vname
+ in
+ begin
+ match i with
+ | Set ((Var vi, NoOffset), e, _) -> check vi (typeOf e)
+ | Call (Some (Var vi, NoOffset), fn, _, _) ->
+ begin
+ match typeOf fn with
+ | TFun (t, _, _, _) -> check vi t
+ | _ -> E.s (bug "Expected function with non-void return value")
+ end
+ | _ -> ()
+ end;
+ DoChildren
+
+ (* Infer annotations for local variables. *)
+ method vfunc fd =
+ assert (unannotatedVars = []);
+ if isTrustedType fd.svar.vtype then begin
+ (* Visit the return type and formals. This is mostly just to get SAFE
+ added in the right places. *)
+ fd.svar.vtype <- visitCilType self fd.svar.vtype;
+
+ let newformals = mapNoCopy (visitCilVarDecl self) fd.sformals in
+ (* Make sure the type reflects the formals *)
+ setFormals fd newformals;
+
+ SkipChildren
+ end
+ else begin
+ curFunc := fd;
+ List.iter
+ (fun vi ->
+ if isPointerType vi.vtype then begin
+ (* First adjust the type for void* polymorphism. *)
+ let bt, a = getPointerType vi.vtype vi.vname in
+ vi.vtype <- TPtr (bt, a);
+ (* Now see if we need to add an annotation. *)
+ let kind, _ = N.inferredKindOf a in
+ if hasAttribute "bounds" a || hasAttribute "size" a then begin
+ if N.kindIsNullterm kind &&
+ not (hasAttribute "nullterm" a) &&
+ not (hasAttribute "sentinel" a) then begin
+ warn "Marking variable %s as null-terminated" vi.vname;
+ vi.vtype <- TPtr (bt, addAttribute nulltermAttr a)
+ end
+ end else begin
+ if not (isTrustedType vi.vtype) then
+ unannotatedVars <- vi :: unannotatedVars;
+ let a =
+ if N.kindIsNullterm kind && not (hasAttribute "nullterm" a) then
+ addAttribute nulltermAttr a
+ else
+ a
+ in
+ match kind with
+ | N.Safe -> (* No bound vars needed. *)
+ vi.vtype <- TPtr (bt, addAttribute safeAttr a)
+ | N.String | N.Sentinel -> (* No bound vars needed. *)
+ vi.vtype <- TPtr (bt, addAttribute count0Attr a)
+ | N.FSeq | N.FSeqN -> (* Automatic bounds for end only. *)
+ vi.vtype <- TPtr (bt, addAttribute autoEndAttr a)
+ | N.Seq | N.SeqN -> (* Automatic bounds for base and end. *)
+ vi.vtype <- TPtr (bt, addAttribute autoAttr a)
+ | N.Unknown | N.UnknownN ->
+ (bug "bad kind returned by inferredKindOf for %a"
+ dx_type vi.vtype);
+ ()
+ end
+ end else if isArrayType vi.vtype then begin
+ (* For arrays, we infer nullterm if one of two conditions holds:
+ * 1. It's a char array and we're assuming all such arrays are
+ * null-terminated, or
+ * 2. It was inferred nullterm by the inference engine *)
+ let a = typeAttrs vi.vtype in
+ if ((!assumeString && isCharArray vi.vtype) ||
+ N.kindIsNullterm (fst (N.inferredKindOf a))) &&
+ not (hasAttribute "nullterm" a) then
+ vi.vtype <- typeAddAttributes [nulltermAttr] vi.vtype
+ end)
+ fd.slocals;
+ List.iter
+ (fun vi ->
+ if isPointerType vi.vtype &&
+ not (hasAttribute "bounds" (typeAttrs vi.vtype)) then begin
+ match getZeroOneAttr ["arraylen"] (typeAttrs vi.vtype) with
+ | Some (Attr (_, [a])) ->
+ vi.vtype <- typeAddAttributes [countAttr a] vi.vtype
+ | Some _ -> errorwarn "Malformed arraylen attribute."
+ | None -> ()
+ end)
+ fd.sformals;
+ let cleanup fd =
+ curFunc := dummyFunDec;
+ unannotatedVars <- [];
+ fd
+ in
+ ChangeDoChildrenPost (fd, cleanup)
+ end
+end
+
+
+(**************************************************************************)
+
+let strncpy_proto: varinfo option ref = ref None
+
+(* This visitor does some simple pre-processing prior to inference and
+ * type checking. *)
+let preProcessVisitor = object (self)
+ inherit nopCilVisitor
+
+ method vglob g =
+ (* Look for a strncpy prototype *)
+ (match g with
+ GVarDecl(vi, _)
+ | GFun({svar = vi}, _) when vi.vname = "strncpy" ->
+ strncpy_proto := Some vi
+ | _ -> ()
+ );
+ DoChildren
+
+ method vtype t =
+ let t' = unrollType t in
+ let attrs = typeAttrs t' in
+ if (hasAttribute "bound" attrs || hasAttribute "nullterm" attrs) &&
+ not (isPointerType t') && not (isArrayType t') then
+ E.s (error "Deputy annotations cannot be placed on this type");
+ match t with
+ | TNamed (ti, a) ->
+ (* Unroll unannotated typedefs. *)
+ if hasAttribute "bounds" (typeAttrs ti.ttype) then
+ DoChildren
+ else
+ ChangeTo t'
+ | _ -> DoChildren
+
+ method vexpr e =
+ let post e : exp =
+ match e with
+ | AddrOf lv ->
+ (* Change AddrOf of an array to a StartOf,
+ and optimize &*e to e. *)
+ mkAddrOrStartOf lv
+ | _ -> e
+ in
+ ChangeDoChildrenPost(e, post)
+
+ (* If the RHS of an instruction refers to a variable that is modified in
+ * the LHS, introduce a temporary. Later, autoVisitor will assume that
+ * a variable appearing on the LHS does not also appear on the RHS.
+ * We also spread the trusted attribute to CIL-introduced temporaries
+ * on the LHS of a call (see trusted12.c). *)
+ method vinst i =
+ let postProcessInstr (instrs: instr list) : instr list =
+ List.fold_right
+ (fun instr acc ->
+ let needsTemp (instr: instr) : bool =
+ match instr with
+ | Call _ ->
+ (* Processing the call will introduce a temporary, so an
+ * additional one is not needed. *)
+ false
+ | Set ((Var vi, NoOffset), e, _) ->
+ (* We only need a temp if we might have automatic bounds
+ * and if the RHS refers to the variable. *)
+ isPointerType vi.vtype && expRefersToVar vi.vname e
+ | Set (lv, _, _) ->
+ (* For an LHS other than a variable, automatic bounds
+ * must already be indicated by the programmer. *)
+ let t = typeOfLval lv in
+ hasAttribute "bounds" (typeAttrs t) && hasAutoBounds t
+ | Asm _ ->
+ false
+ in
+ let needsTrusted (instr: instr) : bool =
+ match instr with
+ | Call (Some (Var vi, NoOffset), fn, _, _) ->
+ let rtype =
+ match unrollType (typeOf fn) with
+ | TFun (rtype, _, _, _) -> rtype
+ | _ -> E.s (bug "Expected function type.")
+ in
+ vi.vdescr <> nil && isTrustedType rtype
+ | _ -> false
+ in
+ let getLhs (instr: instr) : lval =
+ match instr with
+ | Set (lv, _, _) -> lv
+ | Call (Some lv, _, _, _) -> lv
+ | Call (None, _, _, _) -> E.s (bug "Expected return for call")
+ | Asm _ -> E.s (bug "Unexpected asm instruction")
+ in
+ let setLhs (instr: instr) (lv: lval) : instr =
+ match instr with
+ | Set (_, e, l) -> Set (lv, e, l)
+ | Call (Some _, fn, args, l) -> Call (Some lv, fn, args, l)
+ | Call (None, _, _, _) -> E.s (bug "Expected return for call")
+ | Asm _ -> E.s (bug "Unexpected asm instruction")
+ in
+ let getRhsType (instr: instr) : typ =
+ match instr with
+ | Set (_, e, _) -> typeOf e
+ | Call (_, fn, _, _) ->
+ begin
+ match typeOf fn with
+ | TFun (t, _, _, _) -> t
+ | _ -> E.s (bug "Expected function type")
+ end
+ | Asm _ -> E.s (bug "Unexpected asm instruction")
+ in
+ if needsTemp instr then
+ let lv = getLhs instr in
+ let t = typeRemoveAttributes
+ ["bounds"; "nonnull"; "warn_unused_result"]
+ (typeOfLval lv) in
+ let t' =
+ if isTrustedType (getRhsType instr) then
+ typeAddAttributes [Attr ("trusted", [])] t
+ else
+ t
+ in
+ let tmp = makeTempVar !curFunc t' in
+ begin
+ match instr with
+ | Set (_, e, _) -> addTempInfoSet tmp e
+ | Call (_, fn, args, _) -> addTempInfoCall tmp fn args
+ | Asm _ -> E.s (bug "Unexpected asm instruction")
+ end;
+ (setLhs instr (var tmp)) ::
+ Set (lv, Lval (var tmp), !currentLoc) ::
+ Set (var tmp, zero, !currentLoc) ::
+ acc
+ else begin
+ if needsTrusted instr then begin
+ match getLhs instr with
+ | Var vi, NoOffset ->
+ vi.vtype <- typeAddAttributes [trustedAttr] vi.vtype
+ | _ -> E.s (bug "Unexpected LHS.")
+ end;
+ instr :: acc
+ end)
+ instrs
+ []
+ in
+ let i' : instr list =
+ match i with
+ (* strcpy is not permitted in Deputy programs.
+ * Here, we transform strcpy(dest, "literal") into
+ *
+ * strncpy(dest, "literal", len);
+ * dest[len] = 0;
+ * where len = (sizeof("literal")-1)
+ * TODO: Maybe we should do this for non-literals as well? But
+ * there's a perf cost to calling strlen. For now, we'll only do it
+ * for literals. *)
+ | Call (lvo, Lval (Var vf, NoOffset), [dest; src], loc)
+ when vf.vname = "strcpy" -> begin
+ match stripNopCasts src with
+ Const(CStr s) -> begin
+ let len = integer(String.length s) in
+ let last_ptr = BinOp (PlusPI,
+ mkCast dest charPtrType,
+ len,
+ charPtrType) in
+ let last_lv = (Mem last_ptr), NoOffset in
+ match !strncpy_proto with
+ Some strncpy ->
+ [Call(lvo, Lval(var strncpy), [dest; src; len], loc);
+ Set(last_lv, zero, loc)
+ ]
+ | None ->
+ warn ("Could not transform strcpy() to strncpy() " ^^
+ "because strncpy() declaration was not found.");
+ [i]
+ end
+ | _ ->
+ (* The source is not a literal. Leave it alone;
+ this is reported as an error later. *)
+ [i];
+ end
+ | _ -> [i]
+ in
+ match i with
+ Call(_, f, _, _) when isVarargOperator f ->
+ (* Don't mess with the arguments to e.g. __builtin_va_arg *)
+ SkipChildren
+ | _ ->
+ ChangeDoChildrenPost (i', postProcessInstr)
+
+ method vfunc fd =
+ curFunc := fd;
+ let cleanup fd =
+ curFunc := dummyFunDec;
+ fd
+ in
+ ChangeDoChildrenPost (fd, cleanup)
+end
+
+
+(***************************************************************)
+
+
+(* This visitor makes array type declarations consistent. Empty array
+ * bounds in extern globals are converted to zeros. Zero array bounds at
+ * the end of a structure are converted to empty bounds. All other
+ * appearances of empty array bounds are illegal.
+ *
+ * From this point forward, the only empty array bounds should be an
+ * indication of an open array at the end of a structure. *)
+let flexibleArrayVisitor = object (self)
+ inherit nopCilVisitor
+
+ method vtype t =
+ match t with
+ | TArray (_, None, _) -> E.s (error "Illegal use of flexible array")
+ | _ -> DoChildren
+
+ method vglob g =
+ match g with
+ (* Rewrite bounds for structures ending in a zero-length array. *)
+ | GVarDecl (vi, _) when vi.vstorage = Extern ->
+ begin
+ match unrollType vi.vtype with
+ | TArray (bt, None, a) ->
+ (* This is always an error; if the array were unused then
+ * Rmtmps would have deleted it.
+ * Without this, we get unhelpful errors about
+ * arrays with length 0 or -1. *)
+ if not (hasBoundsAttr vi.vtype)
+ && not (isTrustedType vi.vtype) then
+ error ("Global array %s needs a length annotation "
+ ^^"(e.g. COUNT or NTS)") vi.vname;
+ let e = if isNullterm vi.vtype then one else zero in
+ vi.vtype <- TArray (bt, Some e, a);
+ DoChildren
+ | _ -> DoChildren
+ end
+ (* Rewrite bounds for extern globals with emtpy bounds. *)
+ | GCompTag (ci, _) when List.length ci.cfields > 1 ->
+ let _, fi = remove_last ci.cfields in
+ let fixup bt a g = fi.ftype <- TArray (bt, None, a); g in
+ begin
+ match unrollType fi.ftype with
+ | TArray (bt, Some z, a) when isZero z ->
+ (* Fix the type on the way up so as not to trigger the
+ * "illegal use" warning above. *)
+ ChangeDoChildrenPost ([g], fixup bt a)
+ | TArray (bt, None, a) ->
+ (* Change the type temporarily so as not to trigger the
+ * "illegal use" warning above. Fix it on the way up. *)
+ fi.ftype <- TArray (bt, Some zero, a);
+ ChangeDoChildrenPost ([g], fixup bt a)
+ | _ -> DoChildren
+ end
+ | _ -> DoChildren
+end
+
+
+(***************************************************************)
+
+
+(* This visitor handles the copytype attribute, which says that the
+ * associated void* should be changed to hold the type of the source
+ * for this cast expression. This feature is used to implement the
+ * TC, NTDROP, and NTEXPAND macros. *)
+let copyTypeVisitor = object (self)
+ inherit nopCilVisitor
+
+ method vexpr e =
+ let postProcessExpr e =
+ match e with
+ | CastE (TPtr (TVoid [], a), e') when hasAttribute "copytype" a ->
+ let bt =
+ match unrollType (typeOf e') with
+ | TPtr (bt, _) -> bt
+ | _ -> TVoid []
+ in
+ CastE (TPtr (bt, dropAttribute "copyType" a), e')
+ | _ -> e
+ in
+ ChangeDoChildrenPost (e, postProcessExpr)
+end
+
+
+(***************************************************************)
+(* Combine the prepasses *)
+(***************************************************************)
+
+
+let preProcessFile (f : file) =
+ let doPreprocess () =
+ if !verbose then
+ log "preprocess file (dinfer)";
+
+ (* Create a decl for "__deputy_memset". *)
+ f.globals <- GVarDecl(memset, locUnknown) :: f.globals;
+
+ List.iter
+ (fun global ->
+ match global with
+ | GVar (vi, _, _)
+ | GVarDecl (vi, _) when not (isFunctionType vi.vtype)->
+ if not (List.memq vi !allGlobalVars) then begin
+ registerGlobal vi
+ end
+ | _ -> ())
+ f.globals;
+ if !verbose then
+ log "preprocess visitor (dinfer)";
+ visitCilFileSameGlobals copyTypeVisitor f;
+ visitCilFileSameGlobals flexibleArrayVisitor f;
+ visitCilFileSameGlobals preProcessVisitor f;
+ in
+ Stats.time "preprocessing" doPreprocess ()
+
+let preProcessFileAfterMarking (f : file) =
+ let doPreprocess () =
+ if !verbose then
+ log "infer visitor (dinfer)";
+ visitCilFileSameGlobals inferVisitor f;
+
+ H.clear fatStructs;
+ if !verbose then
+ log "auto visitor (dinfer)";
+ visitCilFile autoVisitor f;
+ H.clear fatStructs;
+
+ if !verbose then
+ log "finished preprocessing (dinfer)";
+ in
+ Stats.time "preprocessing" doPreprocess ()
+
+
+(**************************************************************************)
+(* Post pass *)
+(**************************************************************************)
+
+let numChecksAdded: int ref = ref 0
+let numChecksAddedVar: varinfo option ref = ref None
+
+let postPassVisitor = object (self)
+ inherit nopCilVisitor
+
+ method vinst i =
+ (match instrToCheck i with
+ Some _ -> incr numChecksAdded
+ | None -> ());
+ DoChildren
+
+ method vglob g =
+ match g with
+ GVarDecl(vi, _) when vi.vname = "DEPUTY_NUM_CHECKS_ADDED" ->
+ numChecksAddedVar := Some vi;
+ DoChildren
+ | GVarDecl(vi, _) when vi == memset ->
+ (* Filter out the decl of __deputy_memset. This is declared in
+ checks.h *)
+ ChangeTo []
+ | _ -> DoChildren
+
+
+ (* Remove any "bounds" or "fancybounds" annotations. *)
+ method vattr a =
+ if isDeputyAttr a then
+ ChangeTo []
+ else
+ DoChildren
+
+ (* Replace gratuitous blocks and instruction sequences *)
+ (* matth: only move statements with no labels. If you want to clean up blocks
+ with labels, you must patch up goto statements. See r9295 and earlier
+ for the version of this code that moved labels around correctly but
+ did not patch gotos. *)
+ method vblock (b: block) : block visitAction =
+ (* See if there are nested Blocks *)
+ let postProcessBlock b =
+ let rec loop (bl: stmt list) : stmt list =
+ match bl with
+ | [] -> []
+ | {skind=Block b';labels=[]} :: brest when b'.battrs == [] -> begin
+ (* Move the labels from the statement into the first statement *)
+ loop (Util.list_append b'.bstmts brest)
+ end
+ | {skind=Instr [];labels=[]} :: brest ->
+ loop brest
+
+ | ({skind=Switch(e,b,sl,loc); labels=[]} as s) :: brest -> begin
+ let slp = loop b.bstmts in
+ b.bstmts <- slp;
+ s.skind <- Switch(e,b,sl,loc);
+
+ (s :: (loop brest))
+ end
+
+ | s :: brest ->
+ let brest' = loop brest in
+ if brest' == brest then
+ bl
+ else
+ (s :: brest')
+ in
+ b.bstmts <- loop b.bstmts;
+ b
+ in
+ ChangeDoChildrenPost (b, postProcessBlock)
+
+end
+
+
+(**************************************************************************)
+
+
+
+let postProcessFile (f : file) =
+ (* Turn the check datastructure into explicit checks, so that they show up
+ in the output. *)
+ if !verbose then
+ log "postprocess file (dinfer)";
+ if !optLevel >= 3 then
+ S.time "deadcode-elim" DO.deadCodeElim f;
+ visitCilFile postPassVisitor f;
+ let numChecksAddedGlobal = match !numChecksAddedVar with
+ (* Was DEPUTY_NUM_CHECKS_ADDED declared in this file? If so, replace
+ the declaration with a definition. (If the var is missing, that's
+ because it was unused and CIL deleted it.) *)
+ Some vi ->
+ vi.vstorage <- Static;
+ GVar(vi, {init = Some (SingleInit(integer !numChecksAdded))}, vi.vdecl)
+ | None -> GText ""
+ in
+ f.globals <- (GText ((if !alwaysStopOnError then "#define" else "#undef") ^
+ " DEPUTY_ALWAYS_STOP_ON_ERROR")) ::
+ (GText ((if !fastChecks then "#define" else "#undef") ^
+ " DEPUTY_FAST_CHECKS")) ::
+ numChecksAddedGlobal ::
+ (GText "#include <deputy/checks.h>\n\n")::f.globals;
+ (*if not(Check.checkFile [] f) then
+ E.s(error "Check.checkFile failed!");*)
+ (* this is done in main.ml:
+ if !Doptions.stats then S.print stdout "optimizer-stats:" *)
+ ()
--- /dev/null
+(*
+ *
+ * Copyright (c) 2006,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * Matthew Harren <matth@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 findnull : Cil.exp
+val preProcessFile : Cil.file -> unit
+val preProcessFileAfterMarking : Cil.file -> unit
+val postPassVisitor : Cil.nopCilVisitor
+val postProcessFile : Cil.file -> unit
--- /dev/null
+(*
+ *
+ * Copyright (c) 2004,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 Pretty
+open Dattrs
+open Doptions
+open Dutil
+
+module E = Errormsg
+module IH = Inthash
+module VS = Usedef.VS
+module DF = Dataflow
+
+(* Liveness analysis for local vars.
+ *
+ * This has two uses:
+ * 1) Any local that's live at the start of the func is used without being initialized.
+ * This is a warning/error.
+ * 2) We'll say that variables are only in scope once if they're live.
+ * This reduces the number of variables in the context, and it fixes issues
+ * such as small/locals1 that are caused by CIL moving all locals to the same scope.
+ *
+ * A variable is live if
+ * a) it is live in the usual sense, or
+ * b) a live variable depends on it.
+ *)
+
+
+(* A map from variables to the list of variables that the first
+ * variable depends on. This is closed under transitivity,
+ * but it excludes self-dependencies. *)
+let dependsOn: VS.t IH.t = IH.create 40
+
+(* Update a variable set "start" based on the variables defined and used
+ * by the current instruction. Ensures that the result is closed w.r.t.
+ * the dependsOn relation. *)
+let handleDefUse (start: VS.t) (def: VS.t) (use: VS.t): VS.t =
+ let addDeps (v:varinfo) (acc: VS.t): VS.t =
+ VS.union (IH.find dependsOn v.vid) acc
+ in
+ (* Subtract anything in the Def set. Note that acc is no longer closed! *)
+ let acc = VS.diff start def in
+ (* Add anything that was Used. *)
+ let acc = VS.union use acc in
+ (* Add anything that the Def set depends on, because we'll need these
+ * to check the assignment. *)
+ let acc = VS.fold addDeps def acc in
+ (* Finally, make sure acc is closed. *)
+ let acc = VS.fold addDeps acc acc in
+ acc
+
+
+(* The variables that are live at the start of each stmt of this function.
+ This is always closed under dependsOn. *)
+let liveAtStart: VS.t IH.t = IH.create 50
+
+(* This is copied from liveness.ml, with some extra Deputy magic. *)
+module LiveFlow = struct
+ let name = "Liveness"
+ let debug = ref false
+ type t = VS.t
+
+ let pretty () vs =
+ (VS.fold
+ (fun vi d ->
+ d ++ text "name: " ++ text vi.vname
+ ++ text " id: " ++ num vi.vid ++ text " ")
+ vs nil) ++ line
+
+ let stmtStartData = liveAtStart
+
+ let funcExitData = VS.empty
+
+ let combineStmtStartData (stm:stmt) ~(old:t) (now:t) =
+ if not(VS.compare old now = 0)
+ then Some(VS.union old now)
+ else None
+
+ let combineSuccessors = VS.union
+
+ let doStmt stmt =
+ if !debug then log "looking at: %a" d_stmt stmt;
+ let handle_stm vs = match stmt.skind with
+ Instr _ -> vs
+ | s -> let u, d = Usedef.computeUseDefStmtKind s in
+ handleDefUse vs d u
+ in
+ DF.Post handle_stm
+
+ let doInstr i vs =
+ let transform vs' =
+ let u,d = Usedef.computeUseDefInstr i in
+ handleDefUse vs' d u
+ in
+ DF.Post transform
+
+ let filterStmt stm1 stm2 = true
+
+end
+
+module L = DF.BackwardsDataFlow(LiveFlow)
+
+
+(* What variables does a local depend on? *)
+let varDepsOfType (localsList: varinfo list) (t: typ) : VS.t =
+ let deps = depsOfType t in
+ if deps = [] then VS.empty
+ else begin
+ List.fold_left
+ (fun acc v ->
+ if List.mem v.vname deps then VS.add v acc
+ else acc)
+ VS.empty
+ localsList
+ end
+
+(* Finds the (transitive) dependencies of a variable, and adds them to acc *)
+let getDepsOf (localsList: varinfo list) (v:varinfo): VS.t =
+ let rec helper (v:varinfo) (acc: VS.t): VS.t =
+ let deps = varDepsOfType localsList v.vtype in
+ let newvars = VS.diff deps acc in
+ (* Add in deps *)
+ let acc = VS.union acc newvars in
+ (* And add in any vars that those vars depend on. *)
+ VS.fold helper newvars acc
+ in
+ let deps = helper v VS.empty in
+ (* Finally, remove any self-dependency. *)
+ VS.remove v deps
+
+
+let extraUsesOfExpr (localsList: varinfo list) : (exp -> VS.t) =
+ function
+ (* If a cast has an annotation that refers to locals,
+ add those locals to the USE set *)
+ CastE(t, _) -> varDepsOfType localsList t
+ | _ -> VS.empty
+
+
+(* Check for "memset(&v,_,sizeof(v))".
+ This is a definition of v, not a use. *)
+let interceptMemset (func:exp) (args: exp list): VS.t * VS.t * exp list =
+ (* the default response: process the args as normal. *)
+ let default = (VS.empty, VS.empty, args) in
+ if isMemset (typeOf func) then begin
+ match args with
+ | [(AddrOf lv1 | StartOf lv1); e2; e3]
+ when (isCorrectSizeOf e3 lv1) -> begin
+ (* We're memsetting the entire lval. Consider this a def. *)
+ match lv1 with
+ Var vi, NoOffset when not vi.vglob ->
+ VS.empty, (* no extra uses *)
+ VS.singleton vi, (* consider vi to be defined *)
+ [e2;e3] (* process the last two args as usual *)
+ | _ ->
+ default
+ end
+ | _ -> default
+ end
+ else
+ default
+
+(**** Set some hooks for Usedef: ****)
+
+let setHooks (f:fundec) : unit =
+ (* Exclude globals: *)
+ let notGlobal (v:varinfo): bool = not v.vglob in
+ Usedef.considerVariableUse := notGlobal;
+ Usedef.considerVariableDef := notGlobal;
+ Usedef.considerVariableAddrOfAsUse := notGlobal;
+
+ Usedef.onlyNoOffsetsAreDefs := true;
+
+ Usedef.extraUsesOfExpr := extraUsesOfExpr (f.sformals @ f.slocals);
+ Usedef.getUseDefFunctionRef := interceptMemset;
+ ()
+
+let unsetHooks () : unit =
+ Usedef.considerVariableUse := (fun v -> true);
+ Usedef.considerVariableDef := (fun v -> true);
+ Usedef.considerVariableAddrOfAsUse := (fun v -> true);
+ Usedef.onlyNoOffsetsAreDefs := false;
+ Usedef.extraUsesOfExpr := (fun e -> VS.empty);
+ Usedef.getUseDefFunctionRef := (fun f args -> (VS.empty, VS.empty, args));
+ ()
+
+
+
+(***************************************************************)
+
+
+(* Initialize locals to 0, if needed. Some of this initialization may be
+ wrong (e.g. initializing NONNULL values), but we should catch that later
+ during type checking.*)
+let rec initLval (lv: lval) (t: typ) (acc: instr list) : instr list =
+ let t = unrollType t in
+ match t with
+ TInt _ | TEnum _ | TFloat _ | TVoid _ -> acc
+ | TBuiltin_va_list _ ->
+ if !Doptions.warnVararg then
+ warn "Vararg variables not handled.";
+ acc
+ | TPtr _ -> Set(lv, zero, !currentLoc) :: acc
+ | TArray (bt, _, a) when typeContainsPtrOrNullterm bt ->
+ (* for arrays whose elements contain pointers or nullterminated
+ * arrays, we just memset the whole thing *)
+ Call(None, Lval (var memset),
+ [mkAddrOrStartOf lv; zero; SizeOf t],
+ !currentLoc)::acc
+ | TArray(_, sz, a) when hasAttribute "nullterm" a ->
+ (* For arrays whose elements have no pointers, but that are
+ * nullterminated, we just write the last element *)
+ let szn =
+ match sz with
+ Some sz -> sz
+ | _ -> E.s (unimp "Cannot initialize local null-terminated array with no size")
+ in
+ Set(addOffsetLval (Index(increm szn (-1), NoOffset)) lv,
+ zero, !currentLoc) :: acc
+
+ | TArray _ -> acc
+
+ | TComp (comp, _) when not (typeContainsPtrOrNullterm t) -> acc
+
+ (* For performance it would be better to go over structs field by
+ field, but these assignments might be in the wrong order w.r.t
+ dependencies. We should either move this until after dcheck, or
+ replace the memset with individual assignments during
+ optimization. *)
+(* | TComp(comp, _) when comp.cstruct -> *)
+(* List.fold_left *)
+(* (fun acc f -> *)
+(* initLval (addOffsetLval (Field(f, NoOffset)) lv) *)
+(* f.ftype *)
+(* acc) *)
+(* acc *)
+(* comp.cfields *)
+
+ | TComp (comp, _) ->
+ (* Zero it all *)
+ Call(None, Lval (var memset),
+ [mkAddrOf lv; zero; SizeOf t],
+ !currentLoc)::acc
+
+ | TNamed _ -> assert false
+ | TFun _ -> assert false
+
+
+let initOneVar (funcLoc: location) (vi: varinfo) (acc: instr list): instr list
+ =
+ currentLoc := if vi.vdecl == locUnknown then funcLoc else vi.vdecl;
+
+ (* First, report warnings or errors for this var. Then call initLval *)
+ if vi.vaddrof then
+ (* It's common to take the address of an uninitialized variable
+ and pass it somewhere to be initialized. Don't warn about this,
+ just fix it. *)
+ ()
+ else begin
+ match unrollType vi.vtype with
+ | TInt _ | TEnum _ | TFloat _ ->
+ (* a scalar is used without being defined. Give a warning. *)
+ warn "Variable %s may be used without being defined." vi.vname
+ | TPtr _ ->
+ (* a pointer is used without being defined. *)
+ (* Should we add a command-line flag that makes this a warning? *)
+ error "Pointer variable %s may be used without being defined." vi.vname
+ | TBuiltin_va_list _ -> () (* we warn about this in initLval *)
+ | TComp (comp, _) when not comp.cstruct ->
+ warn ("Union \"%s\" may be used without being defined. Therefore, we "
+ ^^"also treat its tags as being used before definition.")
+ vi.vname
+
+ | TArray _ | TComp _ ->
+ (* Don't warn, because we're not good at deciding when
+ compound structures have been initialized. *)
+ ()
+ | TNamed _ | TFun _ | TVoid _ ->
+ E.s (bug "bad type for local %s: %a" vi.vname dx_type vi.vtype)
+ end;
+ initLval (var vi) vi.vtype acc
+
+let initVars (func: fundec) : unit =
+ let savedLoc = !currentLoc in
+ let firstStmt: stmt =
+ match func.sbody.bstmts with
+ s::rest -> s
+ | [] -> E.s (bug "function has no body")
+ in
+ (* Are any vars live on input? These need initialization,
+ unless they're formals. *)
+ let vars = IH.find liveAtStart firstStmt.sid in
+ if !verbose then
+ log "%s: Live on input: %a\n" func.svar.vname
+ (docList (fun vi -> text vi.vname)) (VS.elements vars);
+ let locals = VS.filter
+ (fun vi -> not (List.memq vi func.sformals))
+ vars in
+ let init: instr list =
+ VS.fold (initOneVar savedLoc) locals []
+ in
+ currentLoc := savedLoc;
+ (* Now add init to the function body. *)
+ match firstStmt.skind with
+ (* The first statement should be an instr statement.
+ Modify the first statement in place, so that we don't have to
+ recompute the CFG. *)
+ Instr il ->
+ let il' = Util.list_append init il in
+ firstStmt.skind <- Instr il'
+ | _ ->
+ E.s (bug "The first statement of %s should have been an Instr."
+ func.svar.vname)
+
+
+(*** This interface is exported to Dcheck: ******************)
+
+let doLiveness (f:fundec) : unit =
+ assert ((IH.length liveAtStart) = 0);
+ assert ((IH.length dependsOn) = 0);
+ let savedLoc = !currentLoc in
+ setHooks f;
+ let localsList = f.sformals @ f.slocals in
+ List.iter (fun v -> IH.add dependsOn v.vid (getDepsOf localsList v))
+ localsList;
+
+ let all_stmts, _ = DF.find_stmts f in
+ List.iter (fun s ->
+ IH.add liveAtStart s.sid VS.empty) all_stmts;
+ L.compute all_stmts;
+ currentLoc := savedLoc;
+
+ unsetHooks ();
+
+ initVars f;
+ ()
+
+
+let clearLiveness () : unit =
+ IH.clear liveAtStart;
+ IH.clear dependsOn;
+ ()
+
+let liveAtStmtStart (s:stmt): VS.t =
+ IH.find liveAtStart s.sid
+
+(* What variables does this local depend on? *)
+let localDependsOn (v:varinfo): VS.t =
+ IH.find dependsOn v.vid
--- /dev/null
+(*
+ *
+ * Copyright (c) 2006,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * Matthew Harren <matth@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 doLiveness : Cil.fundec -> unit
+val clearLiveness : unit -> unit
+val liveAtStmtStart : Cil.stmt -> Usedef.VS.t
+val localDependsOn : Cil.varinfo -> Usedef.VS.t
--- /dev/null
+(*
+ *
+ * Copyright (c) 2004,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+module C = Cil
+module RD = Reachingdefs
+module AE = Availexps
+module Z = Zrapp
+
+let outFile : string ref = ref ""
+let debug : bool ref = ref false
+let verbose : bool ref = ref false
+let trustAll : bool ref = ref false
+let stats: bool ref = ref false
+let optLevel : int ref = ref 3
+let parseFile : string ref = ref ""
+let inferFile : string ref = ref ""
+let assumeString : bool ref = ref false
+let alwaysStopOnError : bool ref = ref false
+let fastChecks : bool ref = ref false
+let multipleErrors : bool ref = ref false
+let inferKinds: bool ref = ref true
+let saturnLogicPath : string ref = ref ""
+let findNonNull: bool ref = ref false
+let findPreconditions : bool ref = ref false
+let propPreconditions : bool ref = ref false
+let htmlOutDir : string ref = ref ""
+let instrument : bool ref = ref false
+let taintflow : bool ref = ref false
+let doPtrAnalysis : bool ref = ref false
+let warnAsm: bool ref = ref false
+let warnVararg: bool ref = ref false
+let strictGlobInit: bool ref = ref false
+let countTrustedLines: bool ref = ref false
+let inferBlocking = ref ""
+let patches = ref []
+let checkCilInvariants = ref false
+
+(** How much detail to print. -1 means do not print the graph *)
+let emitGraphDetailLevel : int ref = ref (-1)
+
+
+let rec options = [
+ (* General *)
+ "", Arg.Unit (fun () -> ()), "General:";
+ "--out", Arg.Set_string outFile,
+ "Output file";
+ "--warnall", Arg.Unit (fun _ -> Errormsg.warnFlag := true),
+ "Show all warnings";
+ "--verbose", Arg.Set verbose,
+ "Enable verbose output for Deputy";
+ "--stats", Arg.Set stats,
+ "Output optimizer execution time stats";
+ "--help", Arg.Unit (fun () -> Arg.usage (align options) ""; exit 0),
+ "Show this help message";
+ "-help", Arg.Unit (fun () -> Arg.usage (align options) ""; exit 0),
+ "Show this help message";
+
+ (* Preprocessing and inference *)
+ "", Arg.Unit (fun () -> ()), "Preprocessing and inference:";
+ "--patch", Arg.String (fun s -> patches := s :: !patches),
+ "Specify a patch file containing extra annotations";
+ "--parse-out", Arg.Set_string parseFile,
+ "File in which to place Deputy parsing results, before preprocessing";
+ "--no-infer", Arg.Clear inferKinds,
+ ("Don't use CCured-style interprocedural analysis to determine kinds " ^
+ "for unannotated pointers.");
+ "--infer-out", Arg.Set_string inferFile,
+ ("File in which to place the results of Deputy's preprocessing, " ^
+ "including inference results.");
+ "--infer-out-detail", Arg.Set_int emitGraphDetailLevel,
+ ("Dump the inference graph with the specified level " ^
+ "of detail, with n=0 being the most terse and n=3 the most " ^
+ "verbose. Has no effect unless --infer-out " ^
+ "and the interprocedural inference are both used.");
+ "--find-nonnull", Arg.Set findNonNull,
+ ("Find parameters to functions that should be annotated as NONNULL");
+ "--find-preconditions", Arg.Set findPreconditions,
+ ("Find function preconditions, and add them to the patch file");
+ "--prop-preconditions", Arg.Set propPreconditions,
+ ("Make use of Precondition attributes");
+ "--html-out-dir", Arg.String (fun s -> htmlOutDir := s),
+ ("Directory in which to put html files");
+ "--do-ptr-analysis", Arg.Set doPtrAnalysis,
+ ("Use the results of a pointer analysis during optimization");
+ "--saturn-logic-path", Arg.String (fun s -> saturnLogicPath := s),
+ ("Specify where to look for the results of Saturn analysis");
+
+ (* Typechecking *)
+ "", Arg.Unit (fun () -> ()), "Typechecking:";
+ "--multiple-errors", Arg.Set multipleErrors,
+ "Attempt to continue processing on error";
+ "--trust", Arg.Set trustAll,
+ "Trust all bad casts by default";
+ "--assume-string", Arg.Set assumeString,
+ ("Assume all char arrays, and all unannotated char*s in function " ^
+ "types, are NT.");
+ "--warn-asm", Arg.Set warnAsm,
+ "Show warnings when assembly is ignored";
+ "--warn-vararg", Arg.Set warnVararg,
+ "Show warnings when vararg operators are ignored";
+ (* FIXME: make this the default *)
+ "--strict-global-init", Arg.Set strictGlobInit,
+ ("Report an error, instead of a warning, if global initializer code " ^
+ "can't be proved statically safe.");
+ "--count-trusted-lines", Arg.Set countTrustedLines,
+ "Report how many source lines contain an operation that is TRUSTED.";
+
+ (* Code gen and optimizations *)
+ "", Arg.Unit (fun () -> ()), "Codegen:";
+ "--opt", Arg.Set_int optLevel,
+ ("Control deputy optimizations:\n" ^
+ " 0: no optimization\n" ^
+ " 1: flow-insensitive optimization\n" ^
+ " 2: some flow-sensitive optimization\n"^
+ " 3: all optimizations (default)\n"^
+ " 4: use Mine's octagon analysis");
+ "--fail-stop", Arg.Set alwaysStopOnError,
+ "Optimize checks assuming that we stop on error";
+ "--fast-checks", Arg.Set fastChecks,
+ ("Optimize checks assuming that we stop on error without printing " ^
+ "specifics about the failure");
+ "--zrapp",
+ Arg.Unit (fun n -> C.lineDirectiveStyle := None;
+ C.printerForMaincil := Z.zraCilPrinter;
+ Z.doElimTemps := true),
+ "Use Zach Anderson's pretty printer";
+ "--instrument", Arg.Set instrument,
+ ("Add instrumentation suitable for runtime analysis");
+ "--taintflow", Arg.Set taintflow,
+ ("Perform a static taint analysis");
+
+ (* Analyses not related to the Deputy type system *)
+ "", Arg.Unit (fun () -> ()), "Additional analyses:";
+ "--blocking-analysis", Arg.Set_string inferBlocking,
+ ("Infer the BLOCKING attribute on functions, and put the results in the"^
+ " specified file.");
+
+ (* Things end users usually won't need *)
+ "", Arg.Unit (fun () -> ()), "Advanced (for debugging Deputy):";
+ "--debug-optim", Arg.Unit (fun n -> Z.debug := true; RD.debug := true;
+ AE.debug := true; debug := true),
+ "Have the optimizer output lots of debugging info";
+ "--internal-line-nums",
+ Arg.Unit (fun _ -> Cil.lineDirectiveStyle := Some Cil.LineComment;
+ Cprint.printLnComment := true),
+ "Do not map line numbers back to the original source file";
+ "--check-cil-invariants", Arg.Set checkCilInvariants,
+ "Ensure Deputy generates well-formed CIL code.";
+]
+
+and align (options: (string * Arg.spec * string) list) =
+ (* Get the width of the left column, which contains argument names. *)
+ let left =
+ try
+ List.hd (List.sort (fun a b -> - (compare a b))
+ (List.map (fun (arg, _, _) -> String.length arg) options))
+ with Not_found ->
+ 0
+ in
+ (* Add extra for left and right margin. *)
+ let left = left + 4 in
+ (* Now get the width of the description column. *)
+ let width = 78 - left in
+ (* Helper function to wrap strings. *)
+ let rec wrap str =
+ if String.length str <= width then
+ str
+ else
+ (* Find the point to break the string--first newline or last space. *)
+ let break, skip =
+ try
+ let break = String.rindex_from str width ' ' in
+ try
+ String.index (String.sub str 0 break) '\n', 1
+ with Not_found ->
+ break, 1
+ with Not_found ->
+ width, 0
+ in
+ (* Split the string and keep wrapping. *)
+ let lstr, rstr =
+ String.sub str 0 break,
+ String.sub str (break + skip) (String.length str - break - skip)
+ in
+ lstr ^ "\n" ^ String.make left ' ' ^ wrap rstr
+ in
+ (* Now update all the descriptions. *)
+ List.map
+ (fun (arg, action, str) ->
+ if arg = "" then
+ arg, action, "\n" ^ str ^ "\n"
+ else
+ let pre = String.make (left - String.length arg - 3) ' ' in
+ arg, action, pre ^ wrap str)
+ options
--- /dev/null
+(*
+ *
+ * Copyright (c) 2006,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * Matthew Harren <matth@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 outFile : string ref
+val debug : bool ref
+val verbose : bool ref
+val trustAll : bool ref
+val stats : bool ref
+val optLevel : int ref
+val parseFile : string ref
+val inferFile : string ref
+val assumeString : bool ref
+val alwaysStopOnError : bool ref
+val fastChecks : bool ref
+val multipleErrors : bool ref
+val inferKinds : bool ref
+val saturnLogicPath : string ref
+val findNonNull : bool ref
+val findPreconditions : bool ref
+val propPreconditions : bool ref
+val htmlOutDir : string ref
+val instrument : bool ref
+val taintflow : bool ref
+val doPtrAnalysis : bool ref
+val warnAsm : bool ref
+val warnVararg : bool ref
+val strictGlobInit : bool ref
+val countTrustedLines: bool ref
+val emitGraphDetailLevel : int ref
+val inferBlocking : string ref
+val patches : string list ref
+val checkCilInvariants : bool ref
+
+val options : (string * Arg.spec * string) list
+val align : (string * Arg.spec * string) list -> (string * Arg.spec * string) list
--- /dev/null
+(*
+ *
+ * Copyright (c) 2006,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 Dattrs
+open Dutil
+
+module E = Errormsg
+module F = Frontc
+module H = Hashtbl
+
+exception PatchFailed
+
+(* Determine whether a struct/union is an anonymous one named by CIL. *)
+let isAnonStruct (ci: compinfo) : bool =
+ try
+ String.sub ci.cname 0 6 = "__anon"
+ with Invalid_argument _ ->
+ false
+
+(* Apply the specified mapping to translate names in a list of attribute
+ * parameters. This is used to adjust types in function parameters so
+ * that they refer to the correct function parameter names. *)
+let patchAttrParamsVisitor (map: (string, string) H.t) = object (self)
+ inherit nopCilVisitor
+
+ method vattrparam ap =
+ try
+ begin
+ match ap with
+ | ACons (name, []) -> ChangeTo (ACons (H.find map name, []))
+ | _ -> DoChildren
+ end
+ with Not_found ->
+ DoChildren
+end
+
+(* Apply the above visitor to attributes. *)
+let patchAttrParamsInAttrs (map: (string, string) H.t)
+ (attrs: attributes) : attributes =
+ visitCilAttributes (patchAttrParamsVisitor map) attrs
+
+(* Apply the above visitor to a type. *)
+let patchAttrParamsInType (map: (string, string) H.t) (t: typ) : typ =
+ visitCilType (patchAttrParamsVisitor map) t
+
+(* Add the relevant attributes from extra to orig to make a patched
+ * attribute list. *)
+let patchAttrs (orig: attributes) (extra: attributes) : attributes =
+ let filter a =
+ isDeputyAttr a &&
+ match a with
+ | Attr (name, _) -> not (hasAttribute name orig)
+ in
+ addAttributes (List.filter filter extra) orig
+
+(* Given a type orig and a type extra, take the Deputy attributes from
+ * extra and merge them into orig. *)
+let rec patchType (orig: typ) (extra: typ) (name : string) : typ =
+ match orig, extra with
+ | TPtr (origBase, origAttrs), TPtr (extraBase, extraAttrs) ->
+ let origBase' = patchType origBase extraBase name in
+ TPtr (origBase', patchAttrs origAttrs extraAttrs)
+ | TArray (origBase, len, origAttrs), TArray (extraBase, _, extraAttrs) ->
+ let origBase' = patchType origBase extraBase name in
+ TArray (origBase', len, patchAttrs origAttrs extraAttrs)
+ | TFun (_, _, _, origAttrs), TFun _
+ when hasAttribute "missingproto" origAttrs ->
+ orig
+ | TFun (origRet, origArgInfo, origVar, origAttrs),
+ TFun (extraRet, extraArgInfo, extraVar, extraAttrs)
+ when origVar = extraVar &&
+ (* The patch must either omit the args, or have the correct
+ number of args *)
+ (extraArgInfo=None ||
+ (List.length (argsToList origArgInfo) =
+ List.length (argsToList extraArgInfo))) ->
+ let map = H.create 5 in
+ let origArgInfo' =
+ match origArgInfo, extraArgInfo with
+ | None, _ -> None
+ | Some origArgs, None ->
+ (* The patch had no arguments, so leave the args alone *)
+ origArgInfo
+ | Some origArgs, Some extraArgs ->
+ let origArgNames = List.map (fun (name, _, _) -> name) origArgs in
+ let rec uniquify name =
+ if not (List.mem name origArgNames) then
+ name
+ else
+ uniquify (name ^ "_")
+ in
+ let renamedArgs =
+ List.map2
+ (fun (origName, origArg, origAttrs) (extraName, _, _) ->
+ if extraName <> "" then begin
+ let origName' =
+ if origName <> "" then
+ origName
+ else
+ uniquify extraName
+ in
+ H.replace map extraName origName';
+ (origName', origArg, origAttrs)
+ end else
+ (origName, origArg, origAttrs))
+ origArgs extraArgs
+ in
+ let patchedArgs =
+ List.map2
+ (fun (origName, origArg, origAttrs) (_, extraArg, _) ->
+ let extraArg' = patchAttrParamsInType map extraArg in
+ (origName, patchType origArg extraArg' name, origAttrs))
+ renamedArgs extraArgs
+ in
+ Some patchedArgs
+ in
+ let extraRet' = patchAttrParamsInType map extraRet in
+ let origRet' = patchType origRet extraRet' name in
+ let extraAttrs' = patchAttrParamsInAttrs map extraAttrs in
+ TFun (origRet', origArgInfo', origVar,
+ patchAttrs origAttrs extraAttrs')
+ | TNamed (origDef, _), TNamed (extraDef, _) ->
+ if origDef.tname = extraDef.tname || isVoidType (unrollType extra) then
+ orig
+ else begin
+ ignore(E.log ("Mismatched typedefs in patch:\n" ^^
+ " original: %s\n" ^^
+ " patch: %s\n") origDef.tname extraDef.tname);
+ raise PatchFailed
+ end
+ | TNamed (origDef, al), _ ->
+ patchType (typeAddAttributes al origDef.ttype) extra name
+ | _, TNamed (extraDef, al) ->
+ patchType orig (typeAddAttributes al extraDef.ttype) name
+ | TComp (origComp, _), TComp (extraComp, _)
+ when isAnonStruct origComp && isAnonStruct extraComp -> begin
+ patchComp origComp extraComp;
+ orig
+ end
+ | TComp (origComp, _), TComp (extraComp, _)
+ when origComp.cname = extraComp.cname ->
+ orig
+ | TEnum (origEnum, _), TEnum (extraEnum, _)
+ when origEnum.ename = extraEnum.ename ->
+ orig
+ | TFloat _, TFloat _
+ | TInt _, TInt _
+ | TBuiltin_va_list _, TBuiltin_va_list _
+ | _, TVoid _ -> orig
+ | _, _ -> begin
+ ignore(E.log ("Mismatched types in patch for %s:\n" ^^
+ " original: %a\n" ^^
+ " patch: %a\n") name dx_type orig dx_type extra);
+ raise PatchFailed
+ end
+
+(* Given an original compinfo and an extra (patch) compinfo, mege the
+ * annotations from the extra fields into the corresponding original
+ * fields. *)
+and patchComp (origComp: compinfo) (extraComp: compinfo) : unit =
+ let patchCompField extraField =
+ try
+ List.iter
+ (fun origField ->
+ if origField.fname = extraField.fname then
+ origField.ftype <- patchType origField.ftype
+ extraField.ftype
+ origComp.cname)
+ origComp.cfields
+ with Not_found ->
+ ()
+ in
+ List.iter patchCompField extraComp.cfields
+
+(* For a given global in the patch file (extraGlob), find the
+ * corresponding global in the original file (if any) and patch its
+ * attributes. *)
+let patchGlobal (origFile: file) (extraGlob: global) : unit =
+ currentLoc := get_globalLoc extraGlob;
+ try
+ List.iter
+ (fun g ->
+ match g, extraGlob with
+ | GFun (fd, _), GVarDecl (vi2, _)
+ when fd.svar.vname = vi2.vname -> begin
+ try
+ fd.svar.vattr <- patchAttrs fd.svar.vattr vi2.vattr;
+ let newt = patchType fd.svar.vtype vi2.vtype vi2.vname in
+ (*ignore(E.log "merging %s: %a + %a = %a\n" fd.svar.vname
+ dx_type fd.svar.vtype dx_type vi2.vtype dx_type newt);*)
+ setFunctionType fd newt
+ with PatchFailed -> ()
+ end
+ | (GVar (vi1, _, _) | GVarDecl (vi1, _)), GVarDecl (vi2, _)
+ when vi1.vname = vi2.vname -> begin
+ try
+ vi1.vattr <- patchAttrs vi1.vattr vi2.vattr;
+ let newt = patchType vi1.vtype vi2.vtype vi1.vname in
+ (*ignore(E.log "merging %s: %a + %a = %a\n" vi1.vname
+ dx_type vi1.vtype dx_type vi2.vtype dx_type newt);*)
+ vi1.vtype <- newt
+ with PatchFailed -> ()
+ end
+ | GCompTag (ci1, _), GCompTag (ci2, _)
+ when ci1.cname = ci2.cname && not (isAnonStruct ci1) -> begin
+ try
+ patchComp ci1 ci2
+ with PatchFailed -> ()
+ end
+ | GType (ti1, _), GType (ti2, _)
+ when ti1.tname = ti2.tname -> begin
+ try
+ ti1.ttype <- patchType ti1.ttype ti2.ttype ti1.tname;
+ with PatchFailed -> ()
+ end
+ | _ -> ())
+ origFile.globals
+ with Not_found ->
+ ()
+
+(* We may have added annotations to the base type of a pointer during
+ * patching. If this pointer was used to create the type of a temporary,
+ * we'll get a type mismatch during type checking. Here, we patch any
+ * temporaries introduced by CIL in order to avoid this problem. We
+ * detect temporaries by looking at the vdescr field of varinfo, which
+ * is a bit of a hack. *)
+let patchTempsVisitor = object (self)
+ inherit nopCilVisitor
+
+ method vinst i =
+ let patchBase orig extra name =
+ match orig, extra with
+ | TPtr (origBase, origAttrs), TPtr (extraBase, _) -> begin
+ try
+ TPtr (patchType origBase extraBase name, origAttrs)
+ with PatchFailed -> orig
+ end
+ | _ -> orig
+ in
+ begin
+ match i with
+ | Set ((Var vi, NoOffset), e, _) when vi.vdescr <> Pretty.nil ->
+ vi.vtype <- patchBase vi.vtype (typeOf e) vi.vname
+ | Call (Some (Var vi, NoOffset), fn, _, _) when vi.vdescr <> Pretty.nil ->
+ let rtype =
+ match unrollType (typeOf fn) with
+ | TFun (rtype, _, _, _) -> rtype
+ | _ -> E.s (E.bug "Expected function type %a" d_exp fn)
+ in
+ vi.vtype <- patchBase vi.vtype rtype vi.vname
+ | _ -> ()
+ end;
+ DoChildren
+end
+
+(* Apply the named patch to the source. *)
+let applyPatch (origFile: file) (extraName: string) : unit =
+ Cabs2cil.cacheGlobals := false;
+ let extra =
+ try
+ F.parse extraName ()
+ with Frontc.ParseError _ ->
+ E.s (E.error "Error parsing patch file %s\n" extraName)
+ in
+ List.iter (patchGlobal origFile) extra.globals;
+ visitCilFileSameGlobals patchTempsVisitor origFile
--- /dev/null
+(*
+ *
+ * Copyright (c) 2006,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 patchAttrParamsInAttrs : (string, string) Hashtbl.t ->
+ Cil.attributes -> Cil.attributes
+val patchAttrParamsInType : (string, string) Hashtbl.t -> Cil.typ -> Cil.typ
+val applyPatch : Cil.file -> string -> unit
+val patchType : Cil.typ -> Cil.typ -> string -> Cil.typ
--- /dev/null
+(*
+ *
+ * Copyright (c) 2006,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 Expcompare
+
+open Dattrs
+open Dutil
+
+module E = Errormsg
+module H = Hashtbl
+
+exception PolyError
+
+type map = (string, typ) H.t
+
+let polyTypes: (string, typ list) H.t = H.create 5
+let polyMap: map = H.create 5
+
+let polyStart () : unit =
+ if H.length polyMap > 0 || H.length polyTypes > 0 then
+ E.s (bug "Polymorphism info was not cleared appropriately.")
+
+let polyClear () : unit =
+ H.clear polyMap;
+ H.clear polyTypes
+
+let getPoly (t: typ) : string =
+ match filterAttributes "tyvar" (typeAttrs t) with
+ | [Attr ("tyvar", [ACons (tv, [])])] -> tv
+ | [] -> raise Not_found
+ | _ -> E.s (error "Too many type variable attributes.")
+
+let isPoly (t: typ) : bool =
+ hasAttribute "tyvar" (typeAttrs t)
+
+let rec polyMakeSubst (tTo: typ) (tFrom: typ) : unit =
+ let addSubst tyvar t =
+ let oldList =
+ try
+ H.find polyTypes tyvar
+ with Not_found ->
+ []
+ in
+ H.replace polyTypes tyvar (t :: oldList)
+ in
+ match unrollType tTo, unrollType tFrom with
+ | _ when isPoly tTo ->
+ addSubst (getPoly tTo) tFrom
+ | TPtr (bt1, _), TPtr (bt2, _)
+ | TArray (bt1, _, _), TArray (bt2, _, _) ->
+ polyMakeSubst bt1 bt2
+ | TComp (_, attrs1), TComp (_, attrs2) ->
+ if hasAttribute "typaram" attrs1 <> hasAttribute "typaram" attrs2 then
+ error ("Type parameter mismatch in coercion:\n" ^^
+ " from: %a\n" ^^
+ " to: %a") dx_type tFrom dx_type tTo
+ else begin
+ match filterAttributes "typaram" attrs1,
+ filterAttributes "typaram" attrs2 with
+ | [Attr (_, [ASizeOf t1])], [Attr (_, [ASizeOf t2])] ->
+ if isPoly t1 then
+ addSubst (getPoly t1) t2
+ | [Attr (_, _)], [Attr (_, _)] ->
+ error "Malformed type parameter attribute."
+ | _ :: _, _ | _, _ :: _ ->
+ error "Too many type parameter attributes."
+ | [], [] ->
+ () (* Okay--no type parameters on either. *)
+ end
+ | _ -> ()
+
+let polyResolve () : unit =
+ H.iter
+ (fun tyvar types ->
+ let fancy, basic =
+ List.partition
+ (fun t -> hasAttribute "fancybounds" (typeAttrs t))
+ types
+ in
+ let canonical =
+ match basic with
+ | t :: rest -> t
+ | [] -> E.s (error "No non-fancy substitution discovered.")
+ in
+ List.iter
+ (fun t ->
+ if not (compareTypes canonical t) then
+ E.s (error "Cannot unify types %a and %a."
+ dx_type canonical dx_type t))
+ basic;
+ let canonical' = typeRemoveAttributes ["bounds"] canonical in
+ List.iter
+ (fun t ->
+ let t' = typeRemoveAttributes ["fancybounds"] t in
+ if not (compareTypes canonical' t') then
+ E.s (error "Cannot unify types %a and %a."
+ dx_type canonical' dx_type t'))
+ fancy;
+ H.replace polyMap tyvar canonical)
+ polyTypes
+
+let polyCompMap (t: typ) : map =
+ let attrs =
+ match unrollType t with
+ | TComp (_, a) -> a
+ | _ -> E.s (error "Bad field offset on type %a" dx_type t)
+ in
+ let map = H.create 5 in
+ begin
+ match filterAttributes "typaram" attrs with
+ | [] -> ()
+ | [Attr ("typaram", [ASizeOf t])] -> H.replace map "t" t
+ | [_] -> E.s (error "Invalid type parameter on structure.")
+ | _ -> E.s (error "Too many type parameters on structure.")
+ end;
+ map
+
+let polySubstVisitor (map: map) = object (self)
+ inherit nopCilVisitor
+
+ method vtype t =
+ if isPoly t then
+ let tyvar = getPoly t in
+ try
+ ChangeTo (H.find map tyvar)
+ with Not_found ->
+ raise PolyError
+ else
+ DoChildren
+end
+
+let polySubst (map: map) (t: typ) : typ =
+ visitCilType (polySubstVisitor map) t
--- /dev/null
+(*
+ *
+ * Copyright (c) 2006,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * Matthew Harren <matth@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+exception PolyError
+type map
+val polyMap : map
+val polyStart : unit -> unit
+val polyClear : unit -> unit
+val polyMakeSubst : Cil.typ -> Cil.typ -> unit
+val polyResolve : unit -> unit
+val polyCompMap : Cil.typ -> map
+val polySubst : map -> Cil.typ -> Cil.typ
--- /dev/null
+(*
+ * dsolverfront.ml
+ *
+ * Translate Doptim.absState and Doptim.Can.t
+ * into a conjunction of constraints.
+ *
+ *
+ *)
+
+open Cil
+open Expcompare
+open Pretty
+open Dutil
+
+module H = Hashtbl
+(*module DFS = Dflowsens*)
+module DCE = Dcanonexp
+module Can = DCE.Can
+
+(*
+type absState = DFS.absState
+let emptyAbsState = DFS.top
+*)
+
+type 'a translator =
+{
+ mkTrue : unit -> 'a;
+ mkFalse : unit -> 'a;
+
+ mkAnd : 'a -> 'a -> 'a;
+ mkOr : 'a -> 'a -> 'a;
+ mkNot : 'a -> 'a;
+ mkIte : 'a -> 'a -> 'a -> 'a;
+ mkImp : 'a -> 'a -> 'a;
+
+ mkEq : 'a -> 'a -> 'a;
+ mkNe : 'a -> 'a -> 'a;
+ mkLt : 'a -> 'a -> 'a;
+ mkLe : 'a -> 'a -> 'a;
+ mkGt : 'a -> 'a -> 'a;
+ mkGe : 'a -> 'a -> 'a;
+
+ mkPlus : 'a -> 'a -> 'a;
+ mkTimes : 'a -> 'a -> 'a;
+ mkMinus : 'a -> 'a -> 'a;
+ mkDiv : 'a -> 'a -> 'a;
+ mkMod : 'a -> 'a -> 'a;
+ mkLShift : 'a -> 'a -> 'a;
+ mkRShift : 'a -> 'a -> 'a;
+ mkBAnd : 'a -> 'a -> 'a;
+ mkBXor : 'a -> 'a -> 'a;
+ mkBOr : 'a -> 'a -> 'a;
+
+ mkNeg : 'a -> 'a;
+ mkCompl : 'a -> 'a;
+
+ mkVar : string -> 'a;
+ mkConst : int -> 'a;
+
+ isValidWithAssumptions : 'a list -> 'a -> (bool * (string * int) list);
+ isValid : 'a -> (bool * (string * int) list);
+}
+
+let baseFVarName = "FV"
+
+let nameMakerMaker base =
+ let c = ref 0 in
+ (fun () ->
+ incr c;
+ base^(Int32.to_string (Int32.of_int !c)))
+
+let fvNameMaker = nameMakerMaker baseFVarName
+
+(* map expressions that we can't
+ * translate to variable names *)
+(*let unkExpHash = H.create 100*)
+
+(* if e isn't mapped to a fv then
+ * make one for it and return it *)
+(*
+let mkUnk t (e:exp) =
+ try H.find unkExpHash e
+ with Not_found -> begin
+ let fv = t.mkVar (fvNameMaker()) in
+ H.add unkExpHash e fv;
+ fv
+ end
+*)
+
+exception NYI
+
+let transUnOp t op e =
+ match op with
+ | Neg -> t.mkNeg e
+ | BNot -> t.mkCompl e
+ | _ -> raise NYI
+
+let transBinOp t op e1 e2 =
+ match op with
+ | PlusA | PlusPI | IndexPI -> t.mkPlus e1 e2
+ | MinusA | MinusPI | MinusPP -> t.mkMinus e1 e2
+ | Mult -> t.mkTimes e1 e2
+ | Div -> t.mkDiv e1 e2
+ | Mod -> t.mkMod e1 e2
+ | Shiftlt -> t.mkLShift e1 e2
+ | Shiftrt -> t.mkRShift e1 e2
+ | Lt -> t.mkLt e1 e2
+ | Gt -> t.mkGt e1 e2
+ | Le -> t.mkLe e1 e2
+ | Ge -> t.mkGe e1 e2
+ | Eq -> t.mkEq e1 e2
+ | Ne -> t.mkNe e1 e2
+ | BAnd -> t.mkBAnd e1 e2
+ | BXor -> t.mkBXor e1 e2
+ | BOr -> t.mkBOr e1 e2
+ | LAnd -> t.mkAnd e1 e2
+ | LOr -> t.mkOr e1 e2
+
+
+let rec transCilExp t (e:exp) =
+ (*ignore(E.log "DSF.transCilExp: %a\n" d_exp e);*)
+ match e with
+ | Const(CInt64(v,k,so)) -> t.mkConst (Int64.to_int v)
+ | Const _ -> raise NYI
+ | Lval(Var vi,NoOffset) when vi.vname = "_ZERO_" ->
+ t.mkConst 0
+ | Lval l -> t.mkVar (sprint 80 (d_lval () l))
+ | UnOp(op,e,_) ->
+ let e = transCilExp t e in
+ transUnOp t op e
+ | BinOp(op,e1,e2,_) ->
+ let e1 = transCilExp t e1 in
+ let e2 = transCilExp t e2 in
+ transBinOp t op e1 e2
+ | SizeOf typ -> t.mkConst ((bitsSizeOf typ)/8)
+ | SizeOfE e -> transCilExp t (SizeOf(typeOf e))
+ | SizeOfStr s -> t.mkConst (1 + String.length s)
+ | AlignOf typ -> t.mkConst (alignOf_int typ)
+ | AlignOfE e -> transCilExp t (AlignOf(typeOf e))
+ | CastE(typ,e) -> transCilExp t e
+ (* Cast should check if signed type, and if so, make an ite term *)
+ | AddrOf lv -> t.mkVar (sprint 80 (d_exp () e))
+ | StartOf lv -> t.mkVar (sprint 80 (d_exp () e))
+
+
+(* 'a translator -> Doptim.Can.t -> 'a *)
+let transCan t (cane: Can.t) =
+ let cExp = t.mkConst (Int64.to_int cane.Can.ct) in
+ List.fold_left (fun (te,ce) (c, ue) ->
+ let f = t.mkConst (Int64.to_int c) in
+ let ue' = transCilExp t ue in
+ let tc =
+ match typeOf ue with
+ | TInt(ku,_) -> t.mkLe (t.mkConst 0) ue'
+ | TPtr(_,_) -> t.mkLe (t.mkConst 0) ue'
+ | _ -> t.mkTrue ()
+ in
+ let tm = t.mkTimes f ue' in
+ (t.mkPlus te tm,t.mkAnd ce tc)) (cExp,t.mkTrue()) cane.Can.cf
+
+(* 'a translator -> Doptim.absState -> 'a *)
+(*
+let transAbsState t (state: DFS.absState) =
+ List.fold_left (fun e (x,c,y,_) ->
+ let xe = transCilExp t (Lval x) in
+ let ye = transCilExp t (Lval y) in
+ let ce = t.mkConst (Int64.to_int c) in
+ let te =
+ match typeOf(Lval x), typeOf(Lval y) with
+ | TInt(kx,_), TInt(ky,_) ->
+ if not(isSigned kx) && not(isSigned ky)
+ then t.mkAnd (t.mkLe (t.mkConst 0) ye) (t.mkLe (t.mkConst 0) xe)
+ else t.mkTrue ()
+ | TPtr(_,_), TPtr(_,_) ->
+ t.mkAnd (t.mkLe (t.mkConst 0) ye) (t.mkLe (t.mkConst 0) xe)
+ | _,_ -> t.mkTrue ()
+ in
+ t.mkAnd te (t.mkAnd e (t.mkLe (t.mkPlus xe ce) ye)))
+ (t.mkTrue()) state.DFS.ineqs
+
+let valid t (state: absState)
+ (op: binop)
+ (cane1: Can.t)
+ (cane2: Can.t)
+ =
+ let state = transAbsState t state in
+ let (cane1,c1) = transCan t cane1 in
+ let (cane2,c2) = transCan t cane2 in
+ let cs = t.mkAnd state (t.mkAnd c1 c2) in
+ let e = t.mkImp cs (transBinOp t op cane1 cane2) in
+ t.isValid e
+*)
--- /dev/null
+(*
+ *
+ * Copyright (c) 2004,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 Pretty
+open Doptions
+(*open Dattrs*)
+open Expcompare
+
+module E = Errormsg
+module GA = GrowArray
+module H = Hashtbl
+
+let curFunc : fundec ref = ref dummyFunDec
+let curStmt : int ref = ref (-1)
+
+(**************************************************************************)
+(* Error/log messages *)
+
+type 'a myformat = ('a, unit, doc, unit) format4
+
+let warningQueue : (location * string) list ref = ref []
+let errorQueue : (location * string) list ref = ref []
+
+let outputQueue (queue: (location * string) list) : unit =
+ let compareMsgs (l1, s1) (l2, s2) =
+ let fileResult = compare l1.file l2.file in
+ if fileResult != 0 then
+ fileResult
+ else
+ let lineResult = compare l1.line l2.line in
+ if lineResult != 0 then
+ lineResult
+ else
+ compare s1 s2
+ in
+ let sorted = List.sort compareMsgs queue in
+ let unique =
+ List.fold_right
+ (fun msg acc ->
+ try
+ if msg = List.hd acc then acc else msg :: acc
+ with Failure "hd" ->
+ msg :: acc)
+ sorted []
+ in
+ List.iter (fun (l, s) -> ignore (eprintf "%a: %s" d_loc l s)) unique;
+ flush !E.logChannel
+
+let outputAll () : unit =
+ outputQueue !warningQueue;
+ outputQueue !errorQueue
+
+let output (isError: bool) (label: string) (coda: string) (msg: doc) : unit =
+ if isError then E.hadErrors := true;
+ let d = dprintf "%s%a@!%s@!" label insert msg coda in
+ (* We output log messages immediately; all others are delayed for sorting. *)
+ if label = "" then begin
+ ignore (eprintf "%a: %a" d_loc !currentLoc insert d);
+ flush !E.logChannel
+ end else begin
+ let item = (!currentLoc, sprint 1000000 d) in
+ if isError then
+ errorQueue := item :: !errorQueue
+ else
+ warningQueue := item :: !warningQueue
+ end
+
+let bug (fmt: 'a myformat) : 'a =
+ let coda = "Please tell the Deputy team about this error.\n" in
+ Pretty.gprintf (output true "Internal error: " coda) fmt
+
+let error (fmt: 'a myformat) : 'a =
+ Pretty.gprintf (output true "Error: " "") fmt
+
+let unimp (fmt: 'a myformat) : 'a =
+ Pretty.gprintf (output true "Unimplemented: " "") fmt
+
+let warn (fmt: 'a myformat) : 'a =
+ Pretty.gprintf (output false "Warning: " "") fmt
+
+let log (fmt: 'a myformat) : 'a =
+ Pretty.gprintf (output false "" "") fmt
+
+let errorwarn (fmt: 'a myformat) : 'a =
+ let f d =
+ if !trustAll then
+ warn "%a" insert d
+ else
+ error "%a" insert d
+ in
+ Pretty.gprintf f fmt
+
+(**************************************************************************)
+(* Miscellaneous utility functions *)
+
+let isPointer (e: exp) : bool =
+ isPointerType (typeOf e)
+
+let isPtrOrArray (t: typ) : bool =
+ match unrollType t with
+ | TPtr (bt, _)
+ | TArray (bt, _, _) -> true
+ | _ -> false
+
+let isUnionType (t: typ) : bool =
+ match unrollType t with
+ | TComp (ci, _) when not ci.cstruct -> true
+ | _ -> false
+
+let isOpenArray (t: typ) : bool =
+ match unrollType t with
+ | TArray (_, None, _) -> true
+ | TArray (_, Some e, _) -> isZero e
+ | _ -> false
+
+let isOpenArrayComp (t: typ) : bool =
+ match unrollType t with
+ | TComp (ci, _) when List.length ci.cfields > 0 ->
+ let last = List.nth ci.cfields (List.length ci.cfields - 1) in
+ isOpenArray last.ftype
+ | _ -> false
+
+let rec typeContainsPointers (t: typ) : bool =
+ match t with
+ | TPtr _
+ | TFun _
+ | TBuiltin_va_list _ -> true
+ | TVoid _
+ | TInt _
+ | TFloat _
+ | TEnum _ -> false
+ | TArray (bt, _, _) -> typeContainsPointers bt
+ | TNamed (ti, _) -> typeContainsPointers ti.ttype
+ | TComp (ci, _) ->
+ not ci.cdefined (* If we don't know the contents of the struct,
+ conservatively assume it has pointers. *)
+ ||
+ (List.exists typeContainsPointers
+ (List.map (fun fld -> fld.ftype) ci.cfields))
+
+(** We test if a value of the given type contains as an element a pointer or
+ * a nullterminated array. This is used to decide whether to initialize with
+ * 0 an element *)
+let typeContainsPtrOrNullterm (t: typ) : bool =
+ existsType
+ (function
+ TPtr _ -> ExistsTrue
+ | TBuiltin_va_list _ -> ExistsTrue
+ | TComp (ci, _) when not ci.cdefined -> ExistsTrue (* be conservative *)
+ | TArray (_, _, a) when hasAttribute "nullterm" a -> ExistsTrue
+ | _ -> ExistsMaybe)
+ t
+
+(* Is this an undefined struct? *)
+let isAbstractType (t: typ) : bool =
+ match unrollType t with
+ | TComp (ci, _) when ci.cstruct && not ci.cdefined -> true
+ | _ -> false
+
+(* Is this a pointer to an undefined struct? *)
+let isAbstractPtr (t: typ) : bool =
+ match unrollType t with
+ | TPtr(bt, _) -> isAbstractType bt
+ | _ -> false
+
+(* Return the base type of a pointer or array*)
+let baseType (where: string) (t: typ) : typ =
+ match unrollType t with
+ | TPtr (bt, _)
+ | TArray (bt, _, _) -> bt
+ | TInt _ -> voidType (* Treat integer type like void*. *)
+ | _ -> E.s (bug "Expected pointer/array type for %s, got %a" where d_type t)
+
+(* Return the size of the base type of a pointer or array, in bytes *)
+let baseSize (t: typ) : int=
+ try
+ bitsSizeOf (baseType "(sizeof base type)" t) / 8
+ with
+ | Cil.SizeOfError (s, _) -> E.s (bug "Computed size of %s" s)
+ | e -> raise e
+
+(* Be careful when converting int64 to int. Int64.to_int
+ treats 2^31 the same as 0 *)
+let 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.error "Int constant too large: %Ld\n" i)
+
+(* Interpret this integer as a signed 32-bit number. This means we'll
+ convert 0xFFFFFFFF to -1 instead of 4294967295. *)
+let to_signedint (i:int64) : int =
+ let (<=%) = (fun x y -> (Int64.compare x y) <= 0) in
+ if -0x80000000L <=% i && i <=% 0xffffffffL then begin
+ (* If 0x80000000 <= i <= 0xFFFFFFFF, subtract 2^32 from i. *)
+ if 0x80000000L <=% i then
+ Int64.to_int (Int64.sub i 0x1_0000_0000L)
+ else
+ Int64.to_int i
+ end
+ else
+ E.s (E.error "Int constant too large: %Ld\n" i)
+
+(* Like iter, but passes an int indicating the current index in the list. *)
+let iter_index (fn: 'a -> int -> unit) (a: 'a list) : unit =
+ let rec helper a n =
+ match a with
+ | [] -> ()
+ | a1 :: arest -> fn a1 n; helper arest (n + 1)
+ in
+ helper a 1
+
+(* Like iter2, but passes an int indicating the current index in the lists. *)
+let iter2_index (fn: 'a -> 'b -> int -> unit) (a: 'a list) (b: 'b list) : unit =
+ let rec helper a b n =
+ match a, b with
+ | [], [] -> ()
+ | a1 :: arest, b1 :: brest -> fn a1 b1 n; helper arest brest (n + 1)
+ | _ -> raise (Invalid_argument "iter2index")
+ in
+ helper a b 1
+
+(* Removes the last element of a list. *)
+let rec remove_last (a: 'a list) : 'a list * 'a =
+ match a with
+ | [] -> raise (Failure "remove_last")
+ | [x] -> [], x
+ | x :: rest ->
+ let y, last = remove_last rest in
+ x :: y, last
+
+(* Splits a list into two lists consisting of the first n elements
+ * and the remainder. *)
+let rec split (l: 'a list) (n: int) : 'a list * 'a list =
+ match l with
+ | elt :: rest when n > 0 ->
+ let x, y = split rest (n - 1) in
+ elt :: x, y
+ | _ -> [], l
+
+
+
+(**************************************************************************)
+
+(* Return a list of vars referenced by an expression, and a boolean
+ * saying whether memory is referenced.
+ *
+ * We remember whether the expressions that we track
+ * during optimization involve a memory reference,
+ * and what local vars they contain. This makes it easier to kill facts. *)
+type referenced = {
+ varsRead: varinfo list;
+ memRead: bool;
+}
+
+let varsOfExp (e:exp) : referenced =
+ let readsVars = ref [] in
+ let readsMem = ref false in
+ let rec loop : exp -> unit = function
+ BinOp(_, e1, e2, _) -> loop e1; loop e2
+ | UnOp (_, e1, _) -> loop e1
+ | CastE(_, e1) -> loop e1
+ | Const _
+ | SizeOf _ | SizeOfE _ | SizeOfStr _
+ | AlignOf _ | AlignOfE _ -> ()
+ | StartOf lv | AddrOf lv | Lval lv ->
+ let lh, off = lv in
+ loopLh lh;
+ loopOff off
+ and loopLh: lhost -> unit =function
+ Mem _ -> readsMem := true
+ | Var vi -> if not (List.memq vi !readsVars) then
+ readsVars := vi::!readsVars
+ and loopOff: offset -> unit =function
+ NoOffset -> ()
+ | Field(_, off) -> loopOff off
+ | Index(e, off) -> loop e; loopOff off
+ in
+ loop e;
+ {varsRead = !readsVars; memRead = !readsMem}
+
+let d_referenced () (r:referenced) : doc =
+ dprintf "vars: %a. mem: %s"
+ (docList (fun vi -> text vi.vname)) r.varsRead
+ (if r.memRead then "true" else "false")
+
+(**************************************************************************)
+
+let rec expRefersToVar (name: string) (e: exp) : bool =
+ match e with
+ | Lval lv -> lvalRefersToVar name lv
+ | AddrOf lv -> lvalRefersToVar name lv
+ | StartOf lv -> lvalRefersToVar name lv
+ | SizeOfE e' -> expRefersToVar name e'
+ | AlignOfE e' -> expRefersToVar name e'
+ | UnOp (_, e', _) -> expRefersToVar name e'
+ | BinOp (_, e1, e2, _) -> expRefersToVar name e1 || expRefersToVar name e2
+ | CastE (_, e') -> expRefersToVar name e'
+ | Const _
+ | SizeOf _
+ | SizeOfStr _
+ | AlignOf _ -> false
+
+and lvalRefersToVar (name: string) ((host, offset): lval) : bool =
+ let rec offsetRefersToVar (offset: offset) =
+ match offset with
+ | Field (fld, offset') -> offsetRefersToVar offset'
+ | Index (e, offset') -> expRefersToVar name e || offsetRefersToVar offset'
+ | NoOffset -> false
+ in
+ match host with
+ | Var vi -> vi.vname = name || offsetRefersToVar offset
+ | Mem e -> expRefersToVar name e || offsetRefersToVar offset
+
+
+(* CIL treats these functions specially and uses & in the arguments
+ lists for its own reasons.*)
+let isVarargOperator (f:exp) : bool =
+ let varargOperators = [
+ "__builtin_va_arg";
+ "__builtin_stdarg_start";
+ "__builtin_va_start";
+ "__builtin_next_arg";
+ ]
+ in
+ match f with
+ | Lval(Var vi, NoOffset) -> List.mem vi.vname varargOperators
+ | _ -> false
+
+(* Is "size" the correct size of the given lval?
+ We use this when checking calls to memset. *)
+let isCorrectSizeOf (size: exp) (lv: lval) : bool =
+ (* return true if size is an expression for the size of lv. *)
+ let actualSize : int = (bitsSizeOf (typeOfLval lv)) / 8 in
+ let size' : int64 option = isInteger (constFold true size) in
+ size' = Some (Int64.of_int actualSize)
+
+
+let memset: varinfo =
+ (* Create a decl for "__deputy_memset". This is identical to memset,
+ but we give it its own name to avoid conflicts. We add this to the file
+ in dinfer. *)
+ let memsetType = TFun(voidPtrType, Some [("p", voidPtrType, []);
+ ("what", intType, []);
+ ("sz", ulongType, [])],
+ false,
+ [Attr("dmemset", [AInt 1; AInt 2; AInt 3])]) in
+ makeGlobalVar "__deputy_memset" memsetType
+
+(******************************************************************************)
+(* Expression comparison and cast stripping *)
+
+(* Is this a signed comparison? *)
+let rec isSignedType (t:typ) : bool =
+ match unrollType t with
+ | TInt(ik,_) -> isSigned ik
+ | TEnum _ -> true
+ | TPtr _ -> false
+ | TArray _ -> false
+ | _ -> E.s (bug "expecting an int or ptr in isSignedType, got %a" d_type t)
+
+(* A complete list of Deputy attributes. During postprocessing,
+ we'll delete all of these attributes from the file so that the output is
+ gcc-ready. *)
+let isDeputyAttr (a:attribute): bool =
+ match a with
+ Attr(("bounds" | "fancybounds" | "nullterm" | "trusted" | "copytype"
+ | "size" | "fancysize"
+ | "when" | "fancywhen" | "sentinel" | "nonnull" | "hidden"
+ | "dalloc" | "drealloc" | "dfree"
+ | "dmemset" | "dmemcpy" | "dmemcmp" | "dvararg"
+ | "tyvar" | "typaram"
+ | "_ptrnode" | "missing_annot" | "assumeconst" | "Preconditions"
+ | "blocking" | "noblocking" | "blockingunless" | "irq_restore"
+ | "irq_save"
+ | "Modifies" | "Taint" | "CTaint" | "ScanTaint"
+ | "tainted" ), _) -> true
+ | _ -> false
+
+
+let hasDeputyAttr (t:typ): bool =
+ List.exists isDeputyAttr (typeAttrs t)
+
+let stripDepsFromType (t:typ) : typ =
+ let t' = unrollType t in
+ typeRemoveAttributes ["bounds"; "size"; "when"] t'
+
+
+(* type signature w/o Deputy attrs *)
+let typeSigNC (t : typ) : typsig =
+ let attrFilter (a : attribute) =
+ not(isDeputyAttr a)
+ in
+ typeSigWithAttrs ~ignoreSign:true (List.filter attrFilter) t
+
+
+(* Two types are equal iff their typeSigs w/o Deputy attrs are equal *)
+let deputyCompareTypes (t1 : typ) (t2 : typ) : bool =
+ (typeSigNC t1) = (typeSigNC t2)
+
+
+(* Checks that two types have the same non-Deputy attributes *)
+let sameAttrs (t1 : typ) (t2 : typ) : bool =
+ let a1 = typeSigAttrs (typeSigNC (unrollType t1)) in
+ let a2 = typeSigAttrs (typeSigNC (unrollType t2)) in
+ List.filter (fun a -> not(List.mem a a2)) a1 = [] &&
+ List.filter (fun a -> not(List.mem a a1)) a2 = []
+
+
+let rec findInnermostNonCast (e : exp) : exp =
+ match e with
+ | CastE(t, e) -> findInnermostNonCast e
+ | _ -> e
+
+
+(* Strip casts among pointers where the non-Deputy attributes are the same and
+ * the size of the base types are the same.
+ * Also, strip casts among integer types of equal bitwidth *)
+let rec deputyStripCastsForPtrArith (e:exp): exp =
+ if !debug then ignore(E.log "deputyStripCastsForPtrArith %a\n" d_exp e);
+ match e with
+ | CastE(t, e') (*when not(isTypeVolatile t)*) -> begin
+ let e' = deputyStripCastsForPtrArith e' in
+ match unrollType (typeOf e'), unrollType t with
+ | TPtr (TVoid _, _), TPtr (bt2, _) when not (isVoidType bt2) ->
+ CastE(t,e')
+ | TPtr(bt1, a1), TPtr(bt2, a2) -> begin
+ try
+ if bitsSizeOf bt1 = bitsSizeOf bt2 &&
+ sameAttrs (typeOf e') t
+ then e'
+ else CastE(t,e')
+ with SizeOfError _ -> CastE(t,e')
+ end
+ (* remove casts among integer types of equal bitwidth *)
+ | (TInt _ as t1), (TInt _ as t2)
+ when bitsSizeOf t1 = bitsSizeOf t2 ->
+ if sameAttrs t1 t2 then e' else CastE(t, e')
+ | (TPtr _ as t1), (TInt(ik,_) as t2)
+ when bitsSizeOf t1 = bitsSizeOf t2 && not (isSigned ik) ->
+ if sameAttrs t1 t2 then e' else CastE(t, e')
+ | _, _ -> CastE(t, e')
+ end
+ | UnOp(op,e,t) ->
+ let e = deputyStripCastsForPtrArith e in
+ UnOp(op, e, t)
+ | BinOp(MinusPP,e1,e2,t) ->
+ let e1 = deputyStripCastsForPtrArith e1 in
+ let e2 = deputyStripCastsForPtrArith e2 in
+ 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)
+ | BinOp(op,e1,e2,t) ->
+ let e1 = deputyStripCastsForPtrArith e1 in
+ let e2 = deputyStripCastsForPtrArith e2 in
+ BinOp(op,e1,e2,t)
+ | Lval lv -> Lval(deputyStripCastsForPtrArithLval lv)
+ | AddrOf lv -> AddrOf(deputyStripCastsForPtrArithLval lv)
+ | StartOf lv -> StartOf(deputyStripCastsForPtrArithLval lv)
+ | _ -> e
+
+
+and deputyStripCastsForPtrArithLval (lv : lval) : lval =
+ match lv with
+ | (Var vi, off) -> (Var vi, deputyStripCastsForPtrArithOff off)
+ | (Mem e, off) ->
+ let e = deputyStripCastsForPtrArith e in
+ let off = deputyStripCastsForPtrArithOff off in
+ (Mem e, off)
+
+
+and deputyStripCastsForPtrArithOff (off : offset ) : offset =
+ match off with
+ | NoOffset -> NoOffset
+ | Field(fi, off) -> Field(fi, deputyStripCastsForPtrArithOff off)
+ | Index(e, off) ->
+ let e = deputyStripCastsForPtrArith e in
+ let off = deputyStripCastsForPtrArithOff off in
+ Index(e, off)
+
+
+let rec deputyCompareExp (e1 : exp) (e2 : exp) : bool =
+ if !debug then ignore(E.log "deputyCompareExp:\n\t%a =\n\t%a\n"
+ d_plainexp e1 d_plainexp e2);
+ e1 == e2 ||
+ match e1, e2 with
+ | (Lval lv1|StartOf lv1), (Lval lv2|StartOf lv2)
+ (*| StartOf lv1, StartOf lv2*)
+ | AddrOf lv1, AddrOf lv2 -> deputyCompareLval lv1 lv2
+ | BinOp(op1, l1, r1, _), BinOp(op2, l2, r2, _) ->
+ op1 = op2 && (deputyCompareExp l1 l2) && (deputyCompareExp r1 r2)
+ | UnOp(op1, e1, _), UnOp(op2, e2, _) ->
+ op1 = op2 && (deputyCompareExp e1 e2)
+ | SizeOfE e1, SizeOfE e2
+ | AlignOfE e1, AlignOfE e2 -> deputyCompareExp e1 e2
+ | CastE(t1, e1), CastE(t2, e2) when deputyCompareTypes t1 t2 ->
+ deputyCompareExp e1 e2
+ | _, _ -> begin
+ match isInteger (constFold true e1), isInteger (constFold true e2) with
+ | Some i1, Some i2 -> i1 = i2
+ | _ -> false
+ end
+
+and deputyCompareLval (lv1 : lval) (lv2 : lval) : bool =
+ let rec compareOffset (off1: offset) (off2: offset) : bool =
+ match off1, off2 with
+ | Field (fld1, off1'), Field (fld2, off2') ->
+ fld1 == fld2 && compareOffset off1' off2'
+ | Index (e1, off1'), Index (e2, off2') ->
+ deputyCompareExp e1 e2 && compareOffset off1' off2'
+ | NoOffset, NoOffset -> true
+ | _ -> false
+ in
+ if !debug then ignore(E.log "deputyCompareLval:\n\t%a = \n\t%a\n"
+ d_lval lv1 d_lval lv2);
+ lv1 == lv2 ||
+ match lv1, lv2 with
+ | (Var vi1, off1), (Var vi2, off2) ->
+ vi1 == vi2 && compareOffset off1 off2
+ | (Mem e1, off1), (Mem e2, off2) ->
+ deputyCompareExp e1 e2 && compareOffset off1 off2
+ | _ -> false
+
+
+let deputyStripAndCompareExp (e1 : exp) (e2 : exp) : bool =
+ if !debug then ignore(E.log "deputyStripAndCompareExp\n");
+ let e1' = deputyStripCastsForPtrArith e1 in
+ let e2' = deputyStripCastsForPtrArith e2 in
+ let res = deputyCompareExp e1' e2' in
+ if res then begin
+ if !debug then ignore(E.log "%a -> %a == %a <- %a\n"
+ d_plainexp e1 d_plainexp e1' d_plainexp e2' d_plainexp e2);
+ res
+ end else begin
+ if !debug then ignore(E.log "%a -> %a != %a <- %a\n"
+ d_plainexp e1 d_plainexp e1' d_plainexp e2' d_plainexp e2);
+ res
+ end
+
+
+(*****************************************************************)
+(* Count the lines containing trusted code. *)
+
+(* programLocs is the set of lines where we do at least some checking.
+ trustedLocs (a subset of programLocs) is the set of lines where we've
+ skipped some check.
+
+ "check" here includes compile-time type checking in addition to the
+ runtime checks.
+
+ These counts are approximate.
+ *)
+let programLocs : (location, unit) H.t = H.create 50
+let trustedLocs : (location, unit) H.t = H.create 50
+
+(* Call this at each location that is checked. Uses !currentLoc *)
+let markLocationChecked () : unit =
+ if !Doptions.countTrustedLines && !currentLoc != locUnknown then
+ H.replace programLocs !currentLoc ()
+
+(* Call this at each location where a check was skipped due to TRUSTED *)
+let markLocationTrusted () : unit =
+ if !Doptions.countTrustedLines && !currentLoc != locUnknown then begin
+ H.replace trustedLocs !currentLoc ()
+ end
+
+let locationVisitor = object(self)
+ inherit nopCilVisitor
+ method vstmt s =
+ markLocationChecked ();
+ markLocationTrusted ();
+ DoChildren
+ method vinst i =
+ markLocationChecked ();
+ markLocationTrusted ();
+ SkipChildren
+ method vexpr e = SkipChildren
+ method vtype t = SkipChildren
+end
+
+let markTrustedBlock (b: block) : unit =
+ if !Doptions.countTrustedLines then
+ ignore (visitCilBlock locationVisitor b)
+
+let reportTrustedLines () : unit =
+ assert(!Doptions.countTrustedLines);
+ currentLoc := locUnknown;
+ begin
+ (* Sanity check: is programLocs a superset of trustedLocs? If not,
+ then we aren't adding enough locations to programLocs. *)
+ H.iter (fun l () ->
+ if not (H.mem programLocs l) then
+ bug "Location %a not in programLocs" d_loc l)
+ trustedLocs
+ end;
+ let numLines = H.length programLocs in
+ let trustedLines = H.length trustedLocs in
+ E.log ("The file contains %d non-trivial lines, including %d lines that"^^
+ " contain\n a trusted operation.\n") numLines trustedLines;
+ ()
--- /dev/null
+(*
+ *
+ * Copyright (c) 2006,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * Matthew Harren <matth@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 curFunc : Cil.fundec ref
+val curStmt : int ref
+val memset : Cil.varinfo
+val outputAll : unit -> unit
+val bug : ('a, unit, Pretty.doc, unit) format4 -> 'a
+val error : ('a, unit, Pretty.doc, unit) format4 -> 'a
+val unimp : ('a, unit, Pretty.doc, unit) format4 -> 'a
+val warn : ('a, unit, Pretty.doc, unit) format4 -> 'a
+val log : ('a, unit, Pretty.doc, unit) format4 -> 'a
+val errorwarn : ('a, unit, Pretty.doc, unit) format4 -> 'a
+val isPointer : Cil.exp -> bool
+val isPtrOrArray: Cil.typ -> bool
+val isUnionType : Cil.typ -> bool
+val isOpenArray : Cil.typ -> bool
+val isOpenArrayComp : Cil.typ -> bool
+val typeContainsPointers : Cil.typ -> bool
+val typeContainsPtrOrNullterm : Cil.typ -> bool
+val isAbstractType : Cil.typ -> bool
+val isAbstractPtr : Cil.typ -> bool
+val baseType : string -> Cil.typ -> Cil.typ
+val baseSize : Cil.typ -> int
+val to_int : int64 -> int
+val to_signedint : Int64.t -> int
+val iter_index : ('a -> int -> unit) -> 'a list -> unit
+val iter2_index : ('a -> 'b -> int -> unit) -> 'a list -> 'b list -> unit
+val remove_last : 'a list -> 'a list * 'a
+val split : 'a list -> int -> 'a list * 'a list
+type referenced = { varsRead : Cil.varinfo list; memRead : bool }
+val varsOfExp : Cil.exp -> referenced
+val d_referenced : unit -> referenced -> Pretty.doc
+val expRefersToVar : string -> Cil.exp -> bool
+val lvalRefersToVar : string -> Cil.lval -> bool
+val isVarargOperator : Cil.exp -> bool
+val isCorrectSizeOf : Cil.exp -> Cil.lval -> bool
+
+val isSignedType : Cil.typ -> bool
+val isDeputyAttr : Cil.attribute -> bool
+val hasDeputyAttr : Cil.typ -> bool
+val stripDepsFromType: Cil.typ -> Cil.typ
+val deputyCompareTypes: Cil.typ -> Cil.typ -> bool
+val deputyCompareExp: Cil.exp -> Cil.exp -> bool
+val deputyCompareLval: Cil.lval -> Cil.lval -> bool
+val deputyStripCastsForPtrArith : Cil.exp -> Cil.exp
+val deputyStripAndCompareExp : Cil.exp -> Cil.exp -> bool
+
+val markLocationChecked: unit -> unit
+val markLocationTrusted: unit -> unit
+val markTrustedBlock: Cil.block -> unit
+val reportTrustedLines: unit -> unit
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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 Pretty
+open Dattrs
+open Dutil
+
+module E = Errormsg
+
+(* Process a printf-like vararg function. Each argument gets a cast
+ * to its expected type so that later type-checking phases work properly. *)
+let processVarargs (args: exp list) (nrFormals: int) (formidx: int) : exp list =
+ (* Return the index of the next descriptor *)
+ let findNextDescr (s: string) (from: int) : char * int =
+ try
+ let i = String.index_from s from '%' in
+ let rec parseConversionSpec (start: int) : char * int =
+ match Char.lowercase s.[start] with
+ | 'e' | 'f' | 'g' (* double arg *)
+ | 'a' -> (* double arg *)
+ 'f', start + 1
+ | 'd' | 'i' (* signed int arg *)
+ | 'o' | 'u' | 'x' (* unsigned int arg *)
+ | 'c' (* unsigned char *)
+ | 'p' -> (* void pointer treated as int *)
+ 'd', start + 1
+ | 's' -> 's', start + 1 (* char pointer *)
+ | 'n' -> 'n', start + 1
+ | '%' ->
+ let i' = String.index_from s (start + 1) '%' in
+ parseConversionSpec (i' + 1)
+ | _ -> parseConversionSpec (start+1)
+ in
+ parseConversionSpec (i + 1)
+ with _ ->
+ '_', -1
+ in
+
+ let getDescrType (descr: char) : typ =
+ match descr with
+ | 'f' -> doubleType
+ | 'd' -> intType
+ | 'n' -> intPtrType
+ | 's' -> typeAddAttributes Dattrs.stringAttrs charPtrType
+ | _ -> E.s (bug "Unexpected vararg descr %c." descr)
+ in
+
+ let rec checkFormatArgs (form: string) (idx: int) (args: exp list)
+ : exp list =
+ let descr, idx' = findNextDescr form idx in
+ match descr, args with
+ | '_', [] -> []
+ | '_', _ ->
+ warn "Too many arguments to printf-like vararg function.";
+ args
+ | _, [] ->
+ errorwarn "Too few arguments to printf-like vararg function.";
+ args
+ | _, arg :: rest ->
+ (* TODO: This cast may change the behavior of the program; for
+ * example, casting a pointer to an integer for %d may convert
+ * a 64-bit pointer to a 32-bit integer on some architectures.
+ * Is there a better way? *)
+ mkCast arg (getDescrType descr) :: (checkFormatArgs form idx' rest)
+ in
+
+ if formidx <= 0 || formidx > nrFormals then
+ E.s (error "Expected the format string to be the %dth argument." formidx);
+ if List.length args < nrFormals then
+ E.s (error "Too few arguments to vararg function.");
+
+ match List.nth args (formidx - 1) with
+ | Const (CStr form) ->
+ let preArgs, vaArgs = split args nrFormals in
+ preArgs @ (checkFormatArgs form 0 vaArgs)
+ | _ ->
+ warn "Cannot check varargs due to non-literal format string.";
+ args
+
+
+(* Returns a pair containing the number of formal arguments and the index
+ * of the format string. *)
+let getVarargData (func: exp) : int * int =
+ match unrollType (typeOf func) with
+ | TFun (_, Some forms, _, a) ->
+ begin
+ match filterAttributes "dvararg" a with
+ | Attr (_, [ACons("printf", [AInt fidx])]) :: _ ->
+ List.length forms, fidx
+ | a -> raise Not_found
+ end
+ | _ -> assert false
+
+
+(* Prepare the arguments in a call to a vararg function. *)
+let prepareVarargArguments
+ ~(mkTempVar: typ -> varinfo) (* how to make a temporary variable *)
+ ~(func: exp) (* the called function *)
+ ~(nrformals: int) (* how many formals *)
+ ~(args: exp list) : exp list =
+
+ try
+ let forms, fidx = getVarargData func in
+ processVarargs args forms fidx
+ with Not_found -> begin
+ if !Doptions.warnVararg then
+ warn "Call to vararg function %a not fully checked." d_exp func;
+ args
+ end
+
+
+(* Turn the gcc format attribute into our own notation. Returns a type
+ * that may have a new attribute but which is otherwise the same. *)
+let processFormatAttribute (funType: typ) : typ =
+ match filterAttributes "format" (typeAttrs funType) @
+ filterAttributes "__format__" (typeAttrs funType)
+ with
+ | [Attr (_, [ACons (name, []); AInt format_idx; AInt _])] ->
+ if name = "printf" || name = "__printf__" then begin
+ match funType with
+ | TFun (rt, forms, isva, a) ->
+ TFun (rt, forms, isva,
+ addAttribute
+ (Attr("dvararg", [ACons("printf", [AInt format_idx])])) a)
+ | _ -> assert false
+ end else if name = "scanf" || name = "__scanf__" ||
+ name = "strftime" || name = "__strftime__" ||
+ name = "strfmon" || name = "__strfmon" then begin
+ (* Ignore these for now. *)
+ funType
+ end else begin
+ warn "Did not understand %s format attribute." name;
+ funType
+ end
+
+ | [] -> funType
+ | al -> warn "Malformed format attribute."; funType
--- /dev/null
+(*
+ *
+ * Copyright (c) 2006,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * Matthew Harren <matth@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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 prepareVarargArguments :
+ mkTempVar:(Cil.typ -> Cil.varinfo) -> func:Cil.exp -> nrformals:int ->
+ args:Cil.exp list -> Cil.exp list
+val processFormatAttribute : Cil.typ -> Cil.typ
--- /dev/null
+(*
+ *
+ * Copyright (c) 2006,
+ * Matt Harren <matth@cs.berkeley.edu>
+ * 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 file does three things: a call-graph analysis, a points-to
+ * analysis of function pointers for the sake of building the call
+ * graph, and an analysis of blocking functions in the Linux kernel.
+ *
+ * The points-to analysis could be extended to all lvalues, if that
+ * were useful. *)
+
+open Cil
+open Pretty
+open Dutil
+
+module E = Errormsg
+module IH = Inthash
+module H = Hashtbl
+module DF = Dataflow
+
+open Ptrnode
+let (=?) = Util.equals
+
+let verbose = false
+let assumeTypesafeFunctionCalls = true
+
+let contextForCall (ftype:typ) (args: exp list): Dattrs.context =
+ let _,formals',_,_ = splitFunctionType ftype in
+ let formals = argsToList formals' in
+ let numFormals = List.length formals in
+ let actualsMain, actualsVararg = split args numFormals in
+
+ (* This is a simplified version of the code in dcheck.ml *)
+ let ctx =
+ try
+ List.fold_right2
+ (fun (argName, argType, _) arg ctxAcc ->
+ if argName <> "" then
+ (Dattrs.addBinding ctxAcc argName (deputyStripCastsForPtrArith arg))
+ else
+ ctxAcc)
+ formals
+ actualsMain
+ Dattrs.emptyContext
+ with Invalid_argument _ ->
+ E.s (bug "Expected lists with same length")
+ in
+ ctx
+
+
+let compileLvalAttribute ctx (annot:attrparam): lval =
+ let deps, res = Dattrs.compileAttribute ~deputyAttrsOnly:false ctx annot
+ in
+ match res with
+ Lval lv -> lv
+ | _ -> E.s (error "IRQ_SAVE/RESTORE argument must be an lvalue")
+
+
+(* Function attributes can depend on the parameters.
+ Here, take an attribute and compile it with respect to the actual argument. *)
+let compileFunctionAttribute (ftype:typ) (args: exp list) ~(reto:lval option)
+ (annot:attrparam): lval =
+ let ctx = contextForCall ftype args in
+ let ctx' =
+ match reto with
+ Some lv -> Dattrs.addBinding ctx "__ret" (Lval lv)
+ | None -> ctx
+ in
+ compileLvalAttribute ctx' annot
+
+(****************************************************************************
+ ** Part 1: Points-to analysis for function pointers **
+ ** **
+ ** Using the graph built by the solver, we push around the set of **
+ ** functions that a node could point to. **
+ ** **
+****************************************************************************)
+
+module VarinfoSet =
+ Set.Make(struct
+ type t = varinfo
+ let compare v1 v2 = Pervasives.compare v1.vid v2.vid
+ end)
+
+
+(* The functions to which a node could point. *)
+let funcsOfNode: VarinfoSet.t IH.t = IH.create 49
+
+let getFuncs (n: node) : VarinfoSet.t =
+ try
+ let res = IH.find funcsOfNode n.id in
+(* log "Node %d can point to %a\n" n.id *)
+(* (docList (fun v -> text v.vname)) (VarinfoSet.elements res); *)
+ res
+ with Not_found ->
+(* log "Node %d currently points nowhere.\n" n.id; *)
+ VarinfoSet.empty
+
+
+let doPTA (f: file) : unit =
+ flush !E.logChannel;
+ (* The worklist is a set of nodes for whom funcsOfNode has recently
+ changed.*)
+ let worklist = Queue.create () in
+
+ (* Step 1: initialize the nodes for the addresses of functions. *)
+ let initOneFunc vf : unit =
+ let n = match nodeOfAttrlist vf.vattr with
+ Some n -> n
+ | _ -> E.s (bug "Function %s is missing a node." vf.vname)
+ in
+ IH.add funcsOfNode n.id (VarinfoSet.singleton vf);
+ Queue.add n worklist;
+ ()
+ in
+ iterGlobals f
+ (function GFun(fn, _) -> initOneFunc fn.svar
+ | GVarDecl(vf,_) when isFunctionType vf.vtype -> initOneFunc vf
+ | _ -> () );
+
+ (* Step 2: push stuff around. *)
+ while not (Queue.is_empty worklist) do
+ let n = Queue.pop worklist in
+ let funcs = getFuncs n in
+
+ let considerNode n2: unit =
+ (* Ensure (getFuncs n) is a subset of (getFuncs n2) *)
+ let funcs2 = getFuncs n2 in
+ if not (VarinfoSet.subset funcs funcs2) then begin
+ IH.replace funcsOfNode n2.id
+ (VarinfoSet.union funcs funcs2);
+ Queue.push n2 worklist
+ end
+ in
+
+
+ (* Successor edges: n-->n2 implies that (getFuncs n) should be a subset
+ of (getFuncs n2) *)
+ let doSucc e =
+ match e.ekind with
+ ECast _
+ | ECompat _ -> considerNode e.eto
+ | _ -> ()
+ in
+ List.iter doSucc n.succ;
+
+ (* For predecessor edges, consider only ECompat edges. *)
+ let doPred e =
+ match e.ekind with
+ ECompat _ -> considerNode e.efrom
+ | _ -> ()
+ in
+ List.iter doPred n.pred
+ done;
+ ()
+
+
+
+(****************************************************************************
+ ** Part 2: Build the flow-insensitive call graph **
+ ****************************************************************************)
+
+type calltype = Direct | Indirect
+
+(** A call is a function being called and a list of arguments. *)
+type call = varinfo * exp list * calltype * location
+
+
+let d_call () c : doc =
+ let vf,args,direct,loc = c in
+ dprintf "%s(%a) %a at %a" vf.vname (docList (d_exp ())) args
+ insert (if direct= Indirect then text "(Indirect)" else nil)
+ d_loc loc
+
+
+(* A map from each function (using the varinfo id) to
+ the calls that it might makes *)
+let callgraph: call list IH.t = IH.create 49
+
+let callgraphLookup (f:varinfo): call list =
+ try
+ IH.find callgraph f.vid
+ with Not_found ->
+ (* Probably an external function *)
+ warn "Call graph information has not been computed for function %s"
+ f.vname;
+ []
+
+
+(* Return the "call" info for this call.
+ A direct call returns one item; an indirect may return many *)
+let getCalls (f:exp) (args:exp list) (loc:location) : call list =
+ match f with
+ Lval(Var vf, NoOffset) ->
+ [vf,args,Direct,loc]
+ | Lval(Mem pf, NoOffset) when not !Doptions.inferKinds ->
+ [] (* We've already warned about this. *)
+ | Lval(Mem pf, NoOffset) ->
+ let n = match nodeOfAttrlist (typeAttrs (typeOf pf)) with
+ Some n -> n
+ | n -> E.s (bug "Can't get the node of %a" d_exp pf)
+ in
+ let funcs =
+ if assumeTypesafeFunctionCalls then begin
+ (* Filter the list of functions, considering only those
+ who have the same number of formals as we provide
+ actuals. Assume Deputy rules out other cases. *)
+ let numActualArgs = List.length args in
+ VarinfoSet.filter
+ (fun (f:varinfo) ->
+ match unrollType f.vtype with
+ TFun(_, Some formals, false, _) ->
+ numActualArgs = List.length formals
+ | TFun _ -> (* vararg function or no formals specified. *)
+ true (* conservative *)
+ | _ -> E.s (bug "expecting TFun"))
+ (getFuncs n)
+ end
+ else
+ (getFuncs n)
+ in
+ let numFuncs = VarinfoSet.cardinal funcs in
+ if numFuncs <= 0 && !Doptions.inferKinds then
+ warn ("Function pointer %a (node %d) doesn't seem to point to any"
+ ^^" functions.\nYou should only use --blocking-analysis with"
+ ^^" the whole program.")
+ d_exp pf n.id;
+ (* If there is exactly one function that pf can point to,
+ consider this a direct call. *)
+ let isDirect = if numFuncs = 1 then begin
+ (* E.log "%a: treating indirect jump as a direct call\n" d_loc loc; *)
+ Direct
+ end else
+ Indirect
+ in
+ List.map (fun vf -> (vf,args,isDirect,loc))
+ (VarinfoSet.elements funcs)
+ | _ ->
+ E.s (bug "Bad Call instruction.")
+
+
+class findCallsVisitor (funcName: string) (callList: call list ref)
+ = object (self)
+ inherit nopCilVisitor
+
+ method vinst i =
+ (match i with
+ Call(_, f, args, loc) ->
+ let addOne c: unit =
+ if not (List.mem c !callList) then
+ callList := c::!callList
+ in
+ List.iter addOne (getCalls f args loc)
+ | Asm _ | Set _ -> ()
+ );
+ SkipChildren
+
+ method vexpr e = SkipChildren
+ method vtype t = SkipChildren
+
+end
+
+let buildCallGraph (f:file) : unit =
+ if !Doptions.inferKinds then
+ doPTA f
+ else
+ Dutil.warn "Because the whole-file solver was not used, points-to information is unavailable. Therefore, indirect function calls will be ignored.\n";
+
+ let doOneFunc (fn: fundec): unit =
+ let callList = ref [] in
+ let visitor = new findCallsVisitor fn.svar.vname callList in
+ ignore(visitCilFunction visitor fn);
+ (* if verbose then *) begin
+ E.log "\n%s may call:\n" fn.svar.vname;
+ List.iter
+ (fun c -> E.log " %a\n" d_call c)
+ !callList;
+ end;
+ if IH.mem callgraph fn.svar.vid then
+ bug "computed the callgraph twice";
+ IH.add callgraph fn.svar.vid !callList
+ in
+ let doOneGlobal: global -> unit = function
+ GFun(fn,_) -> doOneFunc fn
+ | _ -> ()
+ in
+ iterGlobals f doOneGlobal;
+ ()
+
+let isLeaf (vf:varinfo): bool =
+ try
+ [] = (IH.find callgraph vf.vid)
+ with Not_found ->
+ E.s (bug "Function %s missing from the call graph." vf.vname)
+
+(* A map from each function (using the varinfo id) to
+ the functions that might call it *)
+let buildInversecallgraph (f:file) : fundec list IH.t =
+ let inversecallgraph: fundec list IH.t = IH.create (IH.length callgraph) in
+
+ let doOneFunc fn: unit =
+ let addCall (c:call): unit =
+ let target,_,_,_ = c in
+ let oldCallersOfTarget =
+ try
+ IH.find inversecallgraph target.vid
+ with Not_found -> []
+ in
+ if not (List.memq fn oldCallersOfTarget) then begin
+(* if verbose then *)
+(* E.log "%s calls %s\n" vf.vname target.vname; *)
+ IH.replace inversecallgraph target.vid (fn::oldCallersOfTarget)
+ end
+ in
+ List.iter addCall (callgraphLookup fn.svar)
+ in
+ iterGlobals f
+ (function GFun(fn, _) -> doOneFunc fn
+ | _ -> () );
+ inversecallgraph
+
+
+
+(****************************************************************************
+ ** Part 3: A whole-program, flow-sensitive blocking analysis: **
+ ****************************************************************************)
+
+(* Sources of unsoundness:
+ * o IRQ_SAVE/IRQ_RESTORE functions are assumed to do nothing but save/restore.
+ * If they do more than that, the blocking analysis may miss it.
+ * o We don't check for writes that would clobber saved flags.
+ * o ...
+ * *)
+
+type interruptBit =
+ Disabled
+ | Enabled
+ | Unchanged
+ | UnchangedEnabled (* We have discovered that Unchanged==Enabled on this path *)
+ | Top (* Top *)
+ | IrqRestore (* A special placeholder value used to ensure
+ that IRQ_RESTORE functions behave as advertized *)
+
+
+type whyType =
+ | BlockAnnotation (** Annotated as a blocking function *)
+ | JoinWithEnabled of location
+ (** The function joins unchanged and enabled, so Unchanged should equal
+ Enabled. *)
+
+(* Why did the analysis say that interupts should be enabled?
+ This is one of the reasons above, plus a call chain leading to it. *)
+type mustEnable =
+ call list * whyType
+
+(* State of the analysis.
+ * For preEnabled, all that matters is the difference between Some and None.
+ * The exact contents of preEnabled are only used for error reporting.
+ *
+ * Locally:
+ * This is a lattice where the top element is
+ * { interruptState = Top; precondition = Some _; savedFlags = [] }
+ *
+ * Interprocedurally:
+ * Top isn't used (we just report an error and save Unchanged in the summary).
+ * savedFlags is also unused. Therefore the top element is
+ * { interruptState = Unchanged; preEnabled = Some _; }
+ * Also, preEnabled is ignored if there's a BLOCKING annotation on the function.
+ *
+ *)
+type blockingState = {
+ interruptState: interruptBit; (* Postcondition *)
+ precondition: mustEnable option; (* If a blocking function might be called without
+ first enabling interrupts, this is a call chain
+ demonstrating that. *)
+ savedFlags: (lval * interruptBit) list;
+}
+
+
+let d_bit (): interruptBit -> doc =
+ (function Disabled -> text "disabled"
+ | Enabled -> text "enabled"
+ | Unchanged -> text "unchanged"
+ | UnchangedEnabled -> text "unchanged, but enabled"
+ | IrqRestore -> text "restore_saved_flags"
+ | Top -> text "Top")
+let d_blockingState () s : doc =
+ (if s.precondition <> None then
+ text "May block; "
+ else nil)
+ ++
+ d_bit () s.interruptState
+ ++ text "; " ++
+ docList ~sep:(text "::")
+ (fun (lv,b) -> dprintf "(%a -> %a)" d_lval lv d_bit b)
+ ()
+ s.savedFlags
+
+let d_whyType (): whyType -> doc = function
+ BlockAnnotation -> text "which is annotated as blocking"
+ | JoinWithEnabled loc ->
+ text "which enables interrupts along only one path at "
+ ++ d_loc () loc
+
+
+(* The state/summary of a function that does nothing *)
+let emptySummary =
+ { interruptState = Unchanged;
+ precondition = None;
+ savedFlags = [] }
+
+(* Merge two precondition values. If both could block, choose the best
+ (e.g shortest) of them *)
+let shorter r1 r2 =
+ let (l1,wt1) = r1 in
+ let (l2,wt2) = r2 in
+ (* return the shorter list.
+ But give priority to annotations over bad joins *)
+ if wt1 = wt2 then begin
+ if (List.length l1) <= (List.length l2) then r1 else r2
+ end
+ else if wt1 = BlockAnnotation then r1 else r2
+let betterMayBlock mb1 mb2 =
+ match mb1, mb2 with
+ None, None -> None
+ | Some l1, Some l2 -> Some (shorter l1 l2)
+ | Some l, None
+ | None, Some l -> Some l
+
+
+(****************************************************************************
+ ** Part 3.1: Blocking annotations and stuff **
+ ****************************************************************************)
+
+let assertIntsEnabledFun = "__deputyAssertIntEnabled"
+
+class blockingPrinterClass : descriptiveCilPrinter = object (self)
+ inherit Dattrs.deputyPrinterClass ~showBounds:true ~enable:false as super
+
+ method pAttr (Attr (an, args) : attribute) : doc * bool =
+ match an, args with
+ | ("blocking"), [] ->
+ text "BLOCKING", false
+ | ("noblocking"), [] ->
+ text "NOBLOCKING", false
+ | "blockingunless", [AInt arg; AInt mask] ->
+ dprintf "BLOCKINGUNLESS(%d,%d)" arg mask, false
+ | _ ->
+ super#pAttr (Attr (an, args))
+end
+
+
+(* Does Callee block? If so, change the precondition field of state to Some [] *)
+let handleBlockingAnnotations summary
+ ~(curstate:interruptBit) ~(caller:varinfo) ~(call:call)
+ : blockingState =
+ let callee, args, _, _ = call in
+ let alwaysBlocks () =
+ {summary with precondition = Some ([], BlockAnnotation)}
+ in
+ let neverBlocks () =
+ {summary with precondition = None}
+ in
+ let conditionallyBlocks () =
+ (* Calls e.g. kmalloc with a variable flags argument,
+ and the caller has a blockingunless annotation.
+ FIXME: UNSOUND: make sure this is the same arg that was
+ passed to the caller. *)
+ match curstate with
+ Enabled | Unchanged | UnchangedEnabled -> summary
+ | Disabled | Top ->
+ Dutil.warn "%s called with a variable flags argument when interrupts might be disabled." callee.vname;
+ alwaysBlocks ()
+ | IrqRestore -> E.s (unimp "call a conditionally-blocking function from an IRQ_RESTORE function.")
+
+ in
+ if (hasAttribute "blocking" callee.vattr) then
+ alwaysBlocks ()
+ else if (hasAttribute "noblocking" callee.vattr) then
+ neverBlocks ()
+ else match filterAttributes "blockingunless" callee.vattr with
+ [] ->
+ (* There is no annotation *)
+ summary
+ | [Attr("blockingunless", [AInt arg; AInt mask])] -> begin
+ let value: exp =
+ try
+ List.nth args (arg-1)
+ with Failure _ ->
+ E.s (Dutil.bug "too few args in call to %s" callee.vname)
+ in
+ (* The function blocks if (value&mask) is zero *)
+ match isInteger (constFold true value) with
+ Some value' ->
+ let blocks = 0 = ((i64_to_int value') land mask) in
+ if blocks then begin
+ (* Dutil.log "call to %s blocks here." vf.vname; *)
+ alwaysBlocks ()
+ end
+ else begin
+ (* Dutil.log "call to %s is non-blocking." vf.vname; *)
+ neverBlocks ()
+ end
+ | None ->
+ (* The flags argument is a variable *)
+ if not (hasAttribute "blockingunless" caller.vattr) then begin
+ Dutil.warn "%s called with a variable flags argument."
+ callee.vname;
+ alwaysBlocks ()
+ end else
+ conditionallyBlocks ()
+ end
+ | _ -> E.s (Dutil.error "Bad BLOCKINGUNLESS attr")
+
+
+(****************************************************************************
+ ** Part 3.2: The rest of the analysis **
+ ****************************************************************************)
+
+let curFunc = ref Cil.dummyFunDec
+let curFuncSummary : blockingState option ref = ref None
+let functionSummaries: (blockingState * int) IH.t = IH.create 50
+
+(* A list of places that call blocking functions after explicitly disabling
+ interrupts *)
+let blockingErrors: ((location*fundec*interruptBit), mustEnable) H.t =
+ H.create 10
+
+exception AddPrecondition of mustEnable
+
+(********* Functions that update the state ********)
+let enableInterrupts s : blockingState =
+ {s with interruptState = Enabled}
+let disableInterrupts s : blockingState =
+ {s with interruptState = Disabled}
+
+let assertInterruptsEnabled calleename s : blockingState =
+ match s.interruptState with
+ Enabled | UnchangedEnabled -> s
+ | Unchanged -> { s with interruptState = UnchangedEnabled }
+ | Disabled ->
+ error "Call to %s will always fail." calleename;
+ { s with interruptState = Enabled }
+ | Top -> { s with interruptState = Enabled }
+ | IrqRestore ->
+ (* E.s (unimp "Call to %s in an IRQ_RESTORE function" calleename) *)
+ s
+
+
+let restoreInterrupts s lv : blockingState =
+ try
+ {s with interruptState = List.assoc lv s.savedFlags}
+ with Not_found ->
+ Dutil.warn "Blocking error: restoring the interrupt state from %a, which I don't recognize. State is \"%a\"\n"
+ d_lval lv d_blockingState s;
+ {s with interruptState = Top}
+let saveInterrupts s lv : blockingState =
+ if List.mem (lv,s.interruptState) s.savedFlags then
+ s (* nothing to do *)
+ else begin
+ (* Delete any previous bindings for lv *)
+ let different (lv',_) = not (lv' =? lv) in
+ let others =
+ if List.for_all different s.savedFlags then s.savedFlags
+ else List.filter different s.savedFlags
+ in
+ { s with savedFlags = (lv,s.interruptState)::others }
+ end
+
+(* Handle the precondition part of summary. *)
+let callFunctionHandleMayBlock s call : blockingState =
+ let (f:varinfo),_,_,_ = call in
+ let summary,_ =
+ try
+ IH.find functionSummaries f.vid
+ with Not_found ->
+ emptySummary,0
+ in
+ (* If there are BLOCKING or NOBLOCKING annotations, those take precedence *)
+ let summary = handleBlockingAnnotations summary
+ ~curstate:s.interruptState ~caller:(!curFunc).svar ~call in
+ (* E.log "Calling %s, summary is %a\n" f.vname d_blockingState summary; *)
+ match summary.precondition with
+ | None -> s
+ | Some (chain, wt) -> begin
+ let chain' = call::chain, wt in
+
+ match s.interruptState with
+ | Top
+ | Disabled ->
+ (* This is an error!
+ Report only one error per line *)
+ begin
+ let where = (!currentLoc, !curFunc, s.interruptState) in
+ try
+ let old = H.find blockingErrors where in
+ H.replace blockingErrors where (shorter old chain')
+ with Not_found ->
+ (* First error on this line *)
+ H.add blockingErrors where chain'
+ end;
+ s
+ | Enabled | UnchangedEnabled ->
+ s
+ | IrqRestore ->
+ E.s (unimp
+ "Calling a blocking function from an IRQ_RESTORE function")
+ | Unchanged ->
+ (* since call has a precondition that interrupts be enabled,
+ the current function now does as well. *)
+ if s.precondition = None then
+ raise (AddPrecondition chain')
+ else
+ (* The precondition already existed; choose the shorter reason. *)
+ { s with precondition = betterMayBlock s.precondition (Some chain') }
+ end
+
+(* call this after callFunctionHandleMayBlock *)
+let callFunctionSetNewIntState s call : blockingState =
+ let (callee:varinfo),_,_,_ = call in
+ let summary,_ =
+ try
+ IH.find functionSummaries callee.vid
+ with Not_found ->
+ emptySummary,0
+ in
+ if summary.interruptState = Unchanged then
+ s
+ else if summary.interruptState =? s.interruptState then
+ s
+ else if summary.interruptState = UnchangedEnabled then
+ assertInterruptsEnabled callee.vname s
+ else if (hasAttribute "noblocking" callee.vattr) then
+ s (* We trust this function. *)
+ else begin
+ if summary.interruptState = Top then
+ log "setting interrupt state = Top because of call to %s\n" callee.vname;
+ {s with interruptState = summary.interruptState}
+ end
+
+(******* Flow functions **********)
+
+(* State at each statement *)
+let stateMap : blockingState IH.t = IH.create 50
+
+
+let doInstr (i:instr) (old: blockingState) : blockingState =
+ match i with
+ | Asm(_,["sti" | "sti; hlt"],_,_,_,_) ->
+ enableInterrupts old
+ | Asm(_,["cli"],_,_,_,_) ->
+ disableInterrupts old
+
+ | Asm(_,["pushfl ; popl %0"],[None,_,lv],_,_,_) ->
+ saveInterrupts old lv
+ | Asm(_,["pushfl ; popl %0 ; cli"],[None,_,lv],_,_,_) ->
+ let s = saveInterrupts old lv in
+ disableInterrupts s
+ | Asm(_,["pushl %0 ; popfl"],_,[None,_,Lval lv],_,_) ->
+ restoreInterrupts old lv
+ | Asm(_,["pushfl ; popl %0"|"pushfl ; popl %0 ; cli"|"pushl %0 ; popfl"],
+ _,_,_,_) ->
+ E.s (error "Bad arguments to assembly %a" d_instr i)
+
+ | Asm(_,_,_,_,_,_) ->
+(* E.log "%a: Unknown assembly %a\n" d_loc !currentLoc d_instr i; *)
+ old
+
+ (* This call only returns if interrupts are enabled *)
+ | Call(_,Lval(Var vf, NoOffset),_,_) when vf.vname = assertIntsEnabledFun ->
+ assertInterruptsEnabled vf.vname old
+
+ | Call(reto,Lval(Var vf, NoOffset),args,_) when
+ (hasAttribute "irq_restore" vf.vattr)
+ || (hasAttribute "irq_save" vf.vattr) ->
+ (* Maybe this function has an irq_save/irq_restore annotation on it.
+ FIXME: if so, we consider only the annotation and ignore the summary*)
+ if hasAttribute "irq_restore" vf.vattr then begin
+ match filterAttributes "irq_restore" vf.vattr with
+ | [Attr("irq_restore", [what])] ->
+ if hasAttribute "irq_save" vf.vattr then
+ E.s (unimp "irq_save and irq_restore on the same function");
+ let what' = compileFunctionAttribute vf.vtype args ~reto what in
+ restoreInterrupts old what'
+ | _ -> E.s (error "bad irq_restore attribute on function")
+ end
+ else begin
+ match filterAttributes "irq_save" vf.vattr with
+ | [Attr("irq_save", [what])] ->
+ let lv = compileFunctionAttribute vf.vtype args ~reto what in
+ saveInterrupts old lv
+ | _ -> E.s (error "bad irq_save attribute on function")
+ end
+
+ | Call(_,f,args,loc) ->
+ (* For an indirect call, we may get many possible calls.
+ Handle them in parallel: first, check the precondition summaries,
+ then check the interruptState summaries. *)
+ let calls = getCalls f args loc in
+ let s' =
+ List.fold_left callFunctionHandleMayBlock
+ old
+ calls
+ in
+ let s'' = List.fold_left callFunctionSetNewIntState
+ s'
+ calls
+ in
+ s''
+
+ | Set _ ->
+ old
+
+let joinInterruptBit olds news where: interruptBit =
+ if olds =? news then olds
+ else match olds, news with
+(* Unchanged, Enabled *)
+(* | Enabled, Unchanged -> *)
+(* if old.precondition <> None || newa.precondition <> None then *)
+(* E.s (bug "Has precondition = enabled, but has state = Unchanged."); *)
+(* (\* record this as a precondition and restart the function. *\) *)
+(* Dutil.warn "Blocking analysis: join of %a and %a means that %s has the precondition that interrupts are enabled." *)
+(* d_bit old.interruptState d_bit newa.interruptState *)
+(* (!curFunc).svar.vname; *)
+(* raise (AddPrecondition ([], JoinWithEnabled !currentLoc)) *)
+ | Unchanged, UnchangedEnabled
+ | UnchangedEnabled, Unchanged ->
+ (* Along one path, we asserted that interrupts were enabled. *)
+ Unchanged
+ | Enabled, UnchangedEnabled
+ | UnchangedEnabled, Enabled ->
+ Enabled
+ | Enabled, Unchanged
+ | Unchanged, Enabled ->
+ (* Hack to reduce the number of false positives.
+ Assume that the join of Unchanged and Enabled is Unchanged.
+ This is sound, since at most we will underestimate
+ the locations at which interrupts are enabled.
+ If we ever wanted to do e.g. a locking analysis, we'd have
+ to remove this case *)
+ Unchanged
+ | _ -> begin
+ if olds = Top || news = Top then
+ (* Don't bother warning; we've already complained that the state
+ is Top *)
+ ()
+ else
+ Dutil.warn
+ "inconsistent interrupt state%a: %a vs %a"
+ insert where d_bit olds d_bit news;
+ Top
+ end
+
+let joinStates ~old ~newa : blockingState option =
+ if newa =? old then None
+ else begin
+ let interruptState =
+ joinInterruptBit old.interruptState newa.interruptState nil
+ in
+ let savedFlags =
+ if newa.savedFlags =? old.savedFlags then
+ old.savedFlags
+ else begin
+ (* FIXME: reenable this notice *)
+ (* Dutil.log "Blocking analysis: possible inconsistent saving of flags."; *)
+ (* return the intersection of the lists *)
+ List.fold_left
+ (fun acc save ->
+ if List.mem save old.savedFlags then save::acc else acc)
+ []
+ newa.savedFlags
+ end
+ in
+ let precondition = (* if preconditionEnabled then Some [] else *)
+ (* It's okay for the precondition values to differ *)
+ betterMayBlock old.precondition newa.precondition
+ in
+ (* if we were already at top and precondition hasn't changed, no need to keep
+ exploring. We've already warned about any problems. *)
+ if (old.interruptState = interruptState) && old.precondition =? precondition then
+ None
+ else
+ Some { interruptState = interruptState;
+ precondition = precondition;
+ savedFlags = savedFlags }
+ end
+
+let recordSummary (state: blockingState) : unit =
+ (* Don't put IrqRestore in summaries *)
+ let interruptSummary =
+ if state.interruptState = IrqRestore then Unchanged
+ else state.interruptState
+ in
+ match !curFuncSummary with
+ None ->
+ curFuncSummary := Some { interruptState = interruptSummary;
+ precondition = state.precondition;
+ savedFlags = []};
+ | Some oldSummary ->
+ let interruptSummary =
+ joinInterruptBit oldSummary.interruptState interruptSummary
+ (text " at function return")
+ in
+ curFuncSummary := Some { interruptState = interruptSummary;
+ precondition = betterMayBlock
+ oldSummary.precondition
+ state.precondition;
+ savedFlags = []}
+
+
+(* When an annotated function returns, ensure that it has done as the annotation
+ promised.*)
+let checkReturn (state: blockingState) ~(reto:exp option) : unit =
+ if hasAttribute "irq_restore" (!curFunc).svar.vattr then begin
+ if state.interruptState <> IrqRestore then
+ E.s (error "irq_restore function does not restore the flags")
+ end;
+ begin
+ match filterAttributes "irq_save" (!curFunc).svar.vattr with
+ [] -> ()
+ | [Attr("irq_save", [what])] ->
+ (* Assert state includes what->Unchanged, indicating the initial value
+ was saved in what. *)
+ let ctx = Dattrs.formalsContext !curFunc in
+ let ctx' = match reto with
+ Some e -> Dattrs.addBinding ctx "__ret" e
+ | None -> ctx
+ in
+ let what' = compileLvalAttribute ctx' what in
+ if not (List.mem (what', Unchanged) state.savedFlags) then
+ E.s (error "irq_save function does not save the flags correctly")
+ | _ -> E.s (error "bad irq_save attribute on function")
+ end
+
+module InterruptsFlow = struct
+ let name = "InterruptsEnabled"
+ let debug = ref false
+ type t = blockingState
+ let copy x = x
+ let stmtStartData : t IH.t = stateMap
+ let pretty = d_blockingState
+ let computeFirstPredecessor s a = a
+
+ let combinePredecessors s ~(old:t) newa =
+ if !debug then
+ E.log " Joining %a and %a at %d.\n"
+ d_blockingState old d_blockingState newa s.sid;
+ joinStates ~old ~newa
+
+ let doInstr a i =
+ DF.Done (doInstr a i)
+
+ let doStmt s a =
+ (* on Return, merge all of the states (interruptState and precondition only)
+ into a summary *)
+ (match s.skind with
+ Return (reto,_) ->
+ checkReturn a ~reto;
+ recordSummary a
+ | _ -> ());
+ DF.SDefault
+
+ let doGuard e a =
+ DF.GDefault
+
+ let filterStmt s = true
+end
+module FlowEngine = DF.ForwardsDataFlow (InterruptsFlow)
+
+
+let initialInterruptState (fd:fundec) oldSummary: blockingState =
+ (* If this is an IRQ_RESTORE function, initialize the state to the
+ exp that should be restored *)
+ let savedFlags =
+ match filterAttributes "irq_restore" fd.svar.vattr with
+ | [] -> [] (* The common case *)
+ | [Attr("irq_restore", [what])] ->
+ if hasAttribute "irq_save" fd.svar.vattr then
+ E.s (unimp "irq_save and irq_restore on the same function");
+ let what' = compileLvalAttribute (Dattrs.formalsContext fd) what in
+ (* When the function returns, we will check that the interrupt
+ state has been set to this magic "IrqRestore" value that is only
+ created here. *)
+ [what',IrqRestore]
+ | _ -> E.s (error "bad irq_restore attribute on function")
+ in
+ let interruptState =
+ if oldSummary.precondition = None then Unchanged
+ else Enabled
+ in
+ { interruptState = interruptState;
+ precondition = oldSummary.precondition;
+ savedFlags = savedFlags;
+ }
+
+
+let doBlockingAnalysis (f:file) : unit =
+ Stats.time "Cfg.computeFileCFG" Cfg.computeFileCFG f;
+
+ let worklist : fundec list ref = ref [] in
+ let addToWorklist (fn:fundec) : unit =
+ if not (List.memq fn !worklist) then
+ worklist := fn::!worklist
+ in
+ let inversecallgraph = buildInversecallgraph f in
+
+ (* Returns true if the summary has changed. *)
+ let rec doOneFunc (fd:fundec) : bool =
+ let oldSummary, numPasses =
+ try
+ let state, numPrevPasses = IH.find functionSummaries fd.svar.vid in
+ state, numPrevPasses+1
+ with Not_found ->
+ (* If a function is not in the table, we use "emptySummary" as its
+ summary. So compare the analysis results to emptySummary.
+ If they are equivalent, we don't need to reanalyze functions that
+ call this one. *)
+ emptySummary, 1
+ in
+ E.log "Starting %s. Pass %d\n" fd.svar.vname numPasses;
+ try begin
+ IH.clear stateMap;
+ curFunc := fd;
+ curFuncSummary := None;
+ if (isLeaf fd.svar) && (numPasses >= 2) then
+ E.s (bug "recomputing the summary for a leaf function.");
+ let fst = List.hd fd.sbody.bstmts in
+ IH.add stateMap fst.sid (initialInterruptState fd oldSummary);
+ (* InterruptsFlow.debug := (fd.svar.vname = "ide_spin_wait_hwgroup"); *)
+ Stats.time "DF.ForwardsDataFlow" FlowEngine.compute [fst];
+ IH.clear stateMap;
+ let cfs = !curFuncSummary in
+ curFunc := dummyFunDec;
+ curFuncSummary := None;
+
+ (* Now look at the new summary *)
+ match cfs with
+ | None ->
+ if not (hasAttribute "noreturn" fd.svar.vattr) then
+ warn "Function has no reachable return statement. Should it be labeled noreturn?";
+ false
+ | Some newSummary ->
+ E.log " Done with %s. Summary: %a\n"
+ fd.svar.vname d_blockingState newSummary;
+
+ (* Save the new summary. Even if there is no official change,
+ there may be a shorter precondition error. *)
+ IH.replace functionSummaries fd.svar.vid (newSummary,numPasses);
+ (* Has the summary changed? *)
+ let oldmayblock = oldSummary.precondition <> None in
+ let newmayblock = newSummary.precondition <> None in
+ (* It's possible that we may change from a summary that blocks
+ to one that doesn't, because of the discovery that it calls
+ a function that enables interrupts before calling the blocking
+ function. *)
+(* if oldmayblock && not newmayblock then *)
+(* E.s (bug "analysis is broken"); *)
+ (oldSummary.interruptState <> newSummary.interruptState)
+ || (oldmayblock <> newmayblock)
+ end
+ with
+ | Failure "hd" ->
+ false
+ | AddPrecondition pre ->
+ (* Add a precondition to a function summary that doesn't already
+ have one. *)
+ if oldSummary.precondition <> None then
+ E.s (bug "loop in AddPrecondition.");
+ let newSummary = {emptySummary with precondition = Some pre} in
+ IH.replace functionSummaries fd.svar.vid (newSummary,numPasses);
+ (* Start over with the new precondition. *)
+ ignore (doOneFunc fd);
+ true (* This summary has changed even if the second call to doOneFunc
+ has no changes. *)
+ in
+
+ (* Step 1: add everything to the worklist *)
+ let leafFunctions: fundec list ref = ref [] in
+ iterGlobals f
+ (function GFun(fn, _) ->
+ if isLeaf fn.svar then
+ leafFunctions := fn::!leafFunctions
+ else
+ addToWorklist fn
+ | _ -> () );
+ (* Put leaf functions first in the worklist so we can
+ make fewer passes over non-leaf functions.
+ Also, reverse the worklist in the hopes that callers are usually placed
+ after callees.
+ Note: this isn't really needed now that we have the defer list below,
+ but it can't hurt.
+ *)
+ worklist := Util.list_append !leafFunctions (List.rev !worklist);
+ if (!worklist = []) then
+ E.s (error "No functions to do the blocking analysis on.");
+
+ (* Step 2: iterate *)
+
+ (* At first, we only analyze a function if everything it calls
+ (except itself) has already been analyzed. *)
+ let shouldDefer fd : bool =
+ let dependencies = callgraphLookup fd.svar in
+ not (List.for_all
+ (fun (vf,_,_,_) -> vf == fd.svar || IH.mem functionSummaries vf.vid)
+ dependencies)
+ in
+ let defer: fundec list ref = ref [] in
+ let doWorklist (okayToDefer:bool) : unit =
+ while !worklist <> [] do
+ let fd = List.hd !worklist in
+ worklist := List.tl !worklist;
+ if okayToDefer && (shouldDefer fd) then
+ defer := fd::!defer
+ else begin
+ let changed = Stats.time "Blocking.doOneFunc" doOneFunc fd in
+ if changed then begin
+ let callers =
+ try IH.find inversecallgraph fd.svar.vid
+ with Not_found -> []
+ in
+ List.iter addToWorklist callers
+ end;
+ end
+ done
+ in
+
+ (* Start with non-recursive and simply-recursive functions.
+ (doWorklist true) will empty the worklist, but it may move some functions
+ to defer. Keep moving functions from defer back to the worklist.*)
+ let rec loop (oldNumDeferred:int) =
+ E.log "Beginning a pass over the worklist. %d funcs in worklist.\n"
+ (List.length !worklist);
+ assert (!defer = [] && !worklist <> []);
+ doWorklist true;
+ assert (!worklist = []);
+
+ (* Now take things in the deferred list, and move them back to th
+ worklist *)
+ let numDeferred = List.length !defer in
+ if numDeferred > oldNumDeferred then
+ E.s (bug "infinite loop.");
+ worklist := List.rev !defer;
+ defer := [];
+
+ if numDeferred = 0 then
+ () (* all done *)
+ else if numDeferred = oldNumDeferred then begin
+ E.log "The iteration algorithm is stuck; now processing all functions\n";
+ (* We're stuck. There must be mutually recursive functions in
+ the graph *)
+ doWorklist false (* No more procrastinating ... do every function now *)
+ end
+ else begin
+ (* We're making progress, but we're not there yet. Keep going. *)
+ loop numDeferred
+ end
+ in
+ loop max_int;
+
+ (* Step 3: report errors *)
+ let reportOneError (loc,fd,st) (reason:mustEnable) : unit =
+ currentLoc := loc;
+ let callChain, wt = reason in
+ Dutil.error "Blocking error: when the interrupt state is %a, %s calls a function that requires them to be enabled. Call trace:\n %a\n %a\n"
+ d_bit st
+ fd.svar.vname
+ (docList ~sep:(text "\n ") (d_call ())) callChain
+ d_whyType wt
+ ;
+ ()
+ in
+ H.iter reportOneError blockingErrors;
+ E.log "\nDone with the blocking analysis\n";
+ flush !E.logChannel;
+
+ Cfg.clearFileCFG f;
+ ()
+
+
+
+(****************************************************************************
+ ** Part omega: Cleanup and entrypoint **
+ ****************************************************************************)
+
+let cleanup (): unit =
+ IH.clear callgraph;
+ IH.clear funcsOfNode;
+ IH.clear functionSummaries;
+ H.clear blockingErrors;
+ IH.clear stateMap;
+ ()
+
+
+
+let blockingAnalysis (f:file) : unit =
+ Stats.time "Compute the call graph" buildCallGraph f;
+(* Stats.time "Gc.full_major" Gc.full_major (); *)
+(* Gc.print_stat !E.logChannel; *)
+(* Ptrnode.initialize (); (\* Clear the state to free memory. *\) *)
+(* Stats.time "Gc.full_major" Gc.full_major (); *)
+(* Gc.print_stat !E.logChannel; *)
+(* flush !E.logChannel; *)
+ Stats.time "Infer blocking functions" doBlockingAnalysis f;
+ cleanup ();
+ ()
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2006,
+ * Matt Harren <matth@cs.berkeley.edu>
+ * 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 Pretty
+open Dutil
+open Dattrs
+
+module E = Errormsg
+module IH = Inthash
+module H = Hashtbl
+
+module N = Ptrnode
+
+(* similar to examineType, but for listGlobalAnnotations instead of
+ printGlobalAnnotations. *)
+let rec examineNode (where: string) (t:typ): unit =
+ let reportNodeDoc (what:doc): unit =
+ warn "Type \"%a\" in %s %a" dx_type t where insert what
+ in
+ let reportNode (what:string): unit =
+ reportNodeDoc (text what)
+ in
+ match unrollType t with
+ TVoid _
+ | TBuiltin_va_list _
+ | TInt _
+ | TFloat _
+ | TEnum _ -> ()
+
+ | TPtr (bt, a)
+ | TArray (bt, _, a) when hasAttribute "trusted" a ->
+ ()
+
+ | TPtr (bt, a) ->
+ examineNode where bt;
+ let k, _ = N.inferredKindOf a in
+ let needsBounds =
+ N.kindNeedsBounds k &&
+ not (hasAttribute "bounds" a) &&
+ not (hasAttribute "size" a)
+ in
+ let needsNT =
+ N.kindIsNullterm k &&
+ not (hasAttribute "nullterm" a)
+ in
+ begin
+ match needsBounds, needsNT with
+ | _, true -> reportNode "should be annotated NT."
+ | true, false -> reportNode "needs a bound annotation."
+ | false, false -> ()
+ end
+ | TArray (bt, lo, a) ->
+ examineNode where bt;
+ let k, _ = N.inferredKindOf a in
+ if N.kindIsNullterm k && not (hasAttribute "nullterm" a) then
+ reportNode "should be annotated NT.";
+ if isOpenArray t && not (hasAttribute "bounds" a) then begin
+ reportNode "contains an open array."
+ end
+ | TFun (rt, args, isva, a) ->
+ examineNode "<function pointer return type>" rt;
+ List.iter (fun (n, t, _) ->
+ examineNode ("<function pointer formal "^n^">") t)
+ (argsToList args)
+ | TComp _ -> () (* We visit these separately. *)
+ | TNamed _ -> E.s (bug "unrollType")
+
+
+let reportNeededAnnotations (f: file) : unit =
+ let oldPCI = !print_CIL_Input in
+ print_CIL_Input := true;
+
+ let totKind : (N.opointerkind, int ref) H.t = H.create 17 in
+ let totalNodes : int ref = ref 0 in
+ (* Collect stats on the kinds of every local or cast that might
+ need inferred bounds *)
+ let visitLocalOrCast (t:typ): unit =
+ match unrollType t with
+ TPtr(_,a) ->
+ incr totalNodes;
+ let k,_ = N.inferredKindOf a in
+ N.addToHisto totKind 1 k
+ | _ -> ()
+ in
+ let visitAllCasts (fd: fundec) : unit =
+ let castVisitor = object (self)
+ inherit nopCilVisitor
+ method vexpr e =
+ (match e with
+ CastE(t, _) -> visitLocalOrCast t
+ | _ -> ());
+ DoChildren
+ end
+ in
+ ignore(visitCilBlock castVisitor fd.sbody)
+ in
+
+ (* Maintain a map from globals to the location of their first declaration.
+ If a var has no location (probably because it's Poly), use the
+ location of it's declaration. *)
+ let declarations: location IH.t = IH.create 50 in
+ let setLoc vi: unit =
+ if !currentLoc == locUnknown then begin
+ if IH.mem declarations vi.vid then
+ currentLoc := IH.find declarations vi.vid
+ end else
+ if not (IH.mem declarations vi.vid) then
+ IH.add declarations vi.vid !currentLoc
+ in
+ let globalsVisited: unit IH.t = IH.create 50 in
+ let doGlobal g: unit =
+ match g with
+ GVarDecl (vi, l)
+ when Dattrs.isTrustedType vi.vtype
+ || Dattrs.isSpecialFunction vi.vtype ->
+ ()
+ | GVarDecl (vi, l) when isFunctionType vi.vtype
+ && not (IH.mem globalsVisited vi.vid) ->
+ currentLoc := l;
+ setLoc vi;
+ let rt, formals, _, _ = splitFunctionType vi.vtype in
+ examineNode ("the return value of "^vi.vname) rt;
+ List.iter (fun (n,t,_) ->
+ examineNode ("formal \""^n^"\" of "^vi.vname) t)
+ (argsToList formals);
+ IH.add globalsVisited vi.vid ()
+
+ | GFun (fdec, l)
+ when Dattrs.isTrustedType fdec.svar.vtype
+ || Dattrs.isSpecialFunction fdec.svar.vtype ->
+ ()
+ | GFun (fdec, l) ->
+ currentLoc := l;
+ setLoc fdec.svar;
+ if not (IH.mem globalsVisited fdec.svar.vid) then begin
+ (* Examine the prototype, since we haven't already seen a
+ declaration of this func: *)
+ IH.add globalsVisited fdec.svar.vid ();
+ let rt, formals, _, _ = splitFunctionType fdec.svar.vtype in
+ examineNode ("the return value of "^fdec.svar.vname) rt;
+ List.iter (fun vi -> examineNode
+ ("formal \""^vi.vname^"\" of "^fdec.svar.vname)
+ vi.vtype)
+ fdec.sformals;
+ end;
+ (* Regardless of whether we've seen an earlier declaration, examine
+ locals and casts. *)
+ (* Locals are mostly covered by inference. But base types of
+ pointers may need annotating. *)
+ List.iter (fun vi ->
+ match unrollType vi.vtype with
+ TPtr (bt, a) as t->
+ visitLocalOrCast t;
+ examineNode ("local \""^vi.vname^"\"") bt
+ | TArray (bt, _, a) ->
+ visitLocalOrCast bt;
+ examineNode ("local \""^vi.vname^"\"") bt
+ | _ -> ())
+ fdec.slocals;
+ visitAllCasts fdec
+
+ | GVarDecl (vi, l)
+ | GVar (vi, _, l) when not (IH.mem globalsVisited vi.vid) ->
+ currentLoc := l;
+ setLoc vi;
+ IH.add globalsVisited vi.vid ();
+ examineNode ("global \""^vi.vname^"\"") vi.vtype
+ | GCompTag (ci, l) ->
+ currentLoc := l;
+ List.iter
+ (fun fi -> examineNode ("field \""^fi.fname^"\"") fi.ftype)
+ ci.cfields
+ | _ -> ()
+ in
+ iterGlobals f doGlobal;
+ print_CIL_Input := oldPCI;
+ ()
+
+(* The entry point from Deputy. Calls Markptr, Solver *)
+let inferKinds (f: file) : file =
+ if f.globinit <> None then
+ (* CCured has special handling of globinit, but we can't use that
+ strategy because main may not be in this file. *)
+ ignore (E.warn "Inference: skipping global initializers.\n");
+
+ let marked = Stats.time "markptr" Markptr.markFile f in
+
+ begin
+ try
+ Stats.time "solver" (Solver.solve marked) Ptrnode.idNode
+ with _ ->
+ ()
+ end;
+
+ reportNeededAnnotations marked;
+
+ marked
--- /dev/null
+
+(* The entry point from Deputy. Calls Markptr, Solver *)
+val inferKinds: Cil.file -> Cil.file
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2006,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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 Pretty
+
+module H = Hashtbl
+module IH = Inthash
+module E = Errormsg
+
+module N = Ptrnode
+
+(* We will accumulate the marked globals in here *)
+let theFile: global list ref = ref []
+
+let lu = locUnknown
+let verbose = Doptions.verbose
+
+let currentFile = ref dummyFile
+let currentFunction: fundec ref = ref dummyFunDec
+let currentResultType = ref voidType
+
+let noStackOverflowChecks = ref false
+
+(* Remember the structures we have marked already. This way we detect forward
+ * references *)
+let markedCompInfos: unit IH.t = IH.create 17
+
+(* Remember the nodes for which the PointsTo information is unreliable
+ * because they point to forward-declared structures *)
+let mustRecomputePointsTo: N.node IH.t = IH.create 17
+
+let callId = ref (-1) (* Each call site gets a new ID *)
+
+let allocFunctions: (string, unit) H.t = H.create 17
+
+(* weimer: utility function to ease the transition between our flag formats *)
+let setPosArith n why = N.setFlag n N.pkPosArith why
+let setArith n why = N.setFlag n N.pkArith why
+let setUpdated n why = N.setFlag n N.pkUpdated why
+let setIntCast n why = N.setFlag n N.pkIntCast why
+let setInterface n why = N.setFlag n N.pkInterface why
+let setNoProto n why = N.setFlag n N.pkNoPrototype why
+let setString n why = N.setFlag n N.pkString why
+let setReferenced n why = N.setFlag n N.pkReferenced why
+let setEscape n why = N.setFlag n N.pkEscape why
+let setStack n why = N.setFlag n N.pkStack why
+let default_why () = N.ProgramSyntax(!currentLoc)
+
+(* We keep track of a number of type that we should not unroll *)
+let dontUnrollTypes : (string, bool) H.t = H.create 19
+
+let rec mustUnrollTypeInfo (ti: typeinfo) : bool =
+ (not (H.mem dontUnrollTypes ti.tname)) &&
+ (match ti.ttype with
+ | TPtr _ -> true
+ | TArray _ -> true
+ | TFun _ -> true
+ | TNamed (ti', _) -> mustUnrollTypeInfo ti'
+ | _ -> false)
+
+
+(* if some enclosing context [like the attributes for a field] says that
+ * this array should be sized ... we do not want to forget it! *)
+let addArraySizedAttribute arrayType enclosingAttr =
+ if filterAttributes "sized" enclosingAttr <> [] then
+ typeAddAttributes [Attr("sized",[])] arrayType
+ else
+ if hasAttribute "safeunion" enclosingAttr then
+ typeAddAttributes [Attr("safeunion",[])] arrayType
+ else
+ arrayType
+
+(* Grab the node from the attributs of a type. Returns dummyNode if no such
+ * node *)
+let nodeOfType : typ -> N.node =
+ (fun t ->
+ match unrollType t with
+ TPtr(_, a) -> begin
+ match N.nodeOfAttrlist a with
+ Some n -> n
+ | None -> N.dummyNode
+ end
+ | _ -> N.dummyNode)
+
+(* Pass also the place and the next index within the place. Returns the
+ * modified type and the next ununsed index *)
+let rec doType (t: typ) (p: N.place)
+ (nextidx: int) : typ * int =
+ match t with
+ (TVoid _ | TInt _ | TFloat _ | TEnum _ ) -> t, nextidx
+ | TBuiltin_va_list _ -> t,nextidx
+ | TPtr (bt, a) -> begin
+ match N.nodeOfAttrlist a with
+ Some n -> TPtr (bt, a), nextidx (* Already done *)
+ | None ->
+ let bt', i' = doType bt p (nextidx + 1) in
+ let n = N.getNode p nextidx bt' a in
+ (* See if the bt is a forward referenced TComp *)
+ (match unrollType bt with
+ TComp(ci, _) when not (IH.mem markedCompInfos ci.ckey) ->
+ IH.add mustRecomputePointsTo n.N.id n
+
+ | _ -> ());
+ TPtr (bt', n.N.attr), i'
+ end
+ | TArray (bt, len, a) -> begin
+ (* wes: we want a node for the array, just like we have a node for
+ * each pointer *)
+ match N.nodeOfAttrlist a with
+ Some n -> TArray (bt, len, a), nextidx (* Already done *)
+ | None ->
+ let bt', i' = doType bt p (nextidx + 1) in
+ let n = N.getNode p nextidx bt' a in
+ n.N.is_array <- true;
+ TArray (bt', len, n.N.attr), i'
+ end
+
+ | TComp (c, at) ->
+ t, nextidx (* A reference to a regular composite type, leave alone *)
+
+ (* Strip the type names so that we have less sharing of nodes. However,
+ * we do not need to do it if the named type is a structure, and we get
+ * nicer looking programs. We also don't do it for base types *)
+ | TNamed (bt, a) ->
+ if mustUnrollTypeInfo bt then begin
+ let t = typeAddAttributes a bt.ttype in
+ let t', nextidx' = doType t p nextidx in
+ t', nextidx'
+ end else
+ (* A type reference. Leave alone. We'll handle the type inside when
+ * we do the GType *)
+ t, nextidx
+
+ | TFun (restyp, args, isva, a) ->
+ let noproto = hasAttribute "missingproto" a in
+ let restyp =
+ if noproto && not (isPointerType restyp) then
+ voidPtrType
+ else restyp
+ in
+ let restyp', i0 = doType restyp p nextidx in
+ let args', i' = match args with
+ None -> None, i0
+ | Some argl ->
+ let argl', i' =
+ List.fold_left
+ (fun (args', nidx) (an, at, aa) ->
+ let t', i' = doType at p nidx in
+ ((an,t',aa) :: args', i')) ([], i0) argl
+ in
+ Some (List.rev argl'), i'
+ in
+ let newtp = TFun(restyp', args', isva, a) in
+ let newtp' = Dvararg.processFormatAttribute newtp in
+ newtp', i'
+
+and doField (f: fieldinfo) : N.node =
+ let fftype = addArraySizedAttribute f.ftype f.fattr in
+ let t', i' = doType fftype (N.PField f) 1 in
+ (* Now create the node corresponding to the address of the field *)
+ let nd = N.newNode (N.PField f) 0 t' f.fattr in
+ f.fattr <- addAttributes f.fattr nd.N.attr ;
+ f.ftype <- t';
+ nd
+
+
+(** This is called once for each compinfo DEFINITION. Do not call for
+ * declarations. It will process the fields and will add the nodes
+ * corresponding to the address of the fields. *)
+and markCompInfo (comp: compinfo) (comptagloc: location) : unit =
+ (* We must do its fields *)
+ List.iter (fun f -> ignore (doField f)) comp.cfields;
+ (* Keep track of the compinfo we have done. We do this after we have done
+ * the fields, just in case some of the fields refer to the whole structure.
+ *)
+ IH.add markedCompInfos comp.ckey ()
+
+(* Create a field successor. Just get the node from the field attributes.
+ * Also add an EOFFSET edge from the pointer to struct to pointer to field. *)
+let fieldOfNode (n: N.node) (fi: fieldinfo) : N.node =
+ if N.useOffsetNodes then begin
+ (* Make a new node *)
+ let fieldn = N.getNode (N.POffset (n.N.id, fi.fname)) 0 fi.ftype [] in
+ (* And add the ESafe edge *)
+ let _ = N.addEdge n fieldn N.EOffset (Some !currentLoc) in
+ fieldn
+ end else begin
+ (* In the original scheme we have one node for the address of a field.
+ * The problem with this is that it is shared to much and contributes to
+ * the spreading of WILDness *)
+ match N.nodeOfAttrlist fi.fattr with
+ Some fieldn ->
+ (* Add an EOffset edge from n to fieldn *)
+ let _ = N.addEdge n fieldn N.EOffset (Some !currentLoc) in
+ fieldn
+
+ | None ->
+ (* We should have created nodes for all fieldinfo *)
+ E.s (bug "Field %s.%s does not have a node"
+ (compFullName fi.fcomp) fi.fname)
+ end
+
+let startOfNode (n: N.node) : N.node =
+ match unrollType n.N.btype with
+ TArray (bt, len, a) ->
+ let next =
+ match N.nodeOfAttrlist a with
+ Some oldn -> oldn
+ | _ -> E.s (bug "Array type does not have a node")
+ in
+ let _ = N.addEdge n next N.EIndex (Some !currentLoc) in
+ next
+
+ | _ -> n (* It is a function *)
+
+
+
+(* Compute the sign of an expression. Extend this to a real constant folding
+ * + the sign rule *)
+type sign = SPos | SNeg | SAny | SLiteral of int64
+
+let rec signOf = function
+ Const(CInt64(n, _, _)) -> SLiteral n
+ | Const(CChr c) -> signOf (Const (charConstToInt c))
+ | SizeOf _ -> SPos (* We do not compute it now *)
+ | UnOp (Neg, e, _) -> begin
+ match signOf e with
+ SPos -> SNeg
+ | SLiteral n -> SLiteral (Int64.neg n)
+ | SNeg -> SNeg
+ | _ -> SAny
+ end
+ | UnOp (LNot, e, _) -> SPos
+ | BinOp (PlusA, e1, e2, _) -> begin
+ match signOf e1, signOf e2 with
+ SPos, SPos -> SPos
+ | SLiteral n, SPos when n >= Int64.zero -> SPos
+ | SPos, SLiteral n when n >= Int64.zero -> SPos
+ | SLiteral n1, SLiteral n2 -> SLiteral (Int64.add n1 n2)
+ | SNeg, SNeg -> SNeg
+ | SLiteral n, SNeg when n <= Int64.zero -> SNeg
+ | SNeg, SLiteral n when n <= Int64.zero -> SNeg
+ | _ -> SAny
+ end
+ | BinOp (MinusA, e1, e2, _) -> begin
+ match signOf e1, signOf e2 with
+ SPos, SNeg -> SPos
+ | SLiteral n, SNeg when n >= Int64.zero -> SPos
+ | SPos, SLiteral n when n <= Int64.zero -> SPos
+ | SLiteral n1, SLiteral n2 -> SLiteral (Int64.sub n1 n2)
+ | SNeg, SPos -> SNeg
+ | SLiteral n, SPos when n <= Int64.zero -> SNeg
+ | SNeg, SLiteral n when n >= Int64.zero -> SNeg
+ | _ -> SAny
+ end
+ | _ -> SAny
+
+
+(* Handle Deputy's allocator annotation. *)
+let doAlloc (vi : varinfo) : unit =
+ let attrs = typeAttrs vi.vtype in
+ if hasAttribute "dalloc" attrs || hasAttribute "drealloc" attrs then
+ H.add allocFunctions vi.vname ()
+
+(* Handle Deputy's memcpy, memset, and memcmp annotations. We need to add
+ * appropriate kinds for these for the inference to work properly. *)
+let doMemcpy (varAttrs : attributes) (varType : typ) : unit =
+ match unrollType varType with
+ | TFun (_, Some args, _, attrs) ->
+ if hasAttribute "dmemcpy" attrs ||
+ hasAttribute "dmemcmp" attrs ||
+ hasAttribute "dmemset" attrs then
+ List.iter
+ (fun (_, argType, _) ->
+ match N.nodeOfAttrlist (typeAttrs argType) with
+ | Some n ->
+ n.N.kind <- N.FSeq;
+ n.N.why_kind <- N.UserSpec
+ | None -> ())
+ args
+ | _ -> ()
+
+(* Do varinfo. We do the type and for all variables we also generate a node
+ * that will be used when we take the address of the variable (or if the
+ * variable contains an array) *)
+let doVarinfo (vi: varinfo) : unit =
+ (* Compute a place for it *)
+ let original_location = !currentLoc in (* weimer: better places *)
+ if vi.vdecl != locUnknown then
+ currentLoc := vi.vdecl;
+ let place =
+ if vi.vglob then
+ if vi.vstorage = Static then
+ N.PStatic (!currentFile.fileName, vi.vname)
+ else
+ N.PGlob vi.vname
+ else
+ N.PLocal (!currentFile.fileName, !currentFunction.svar.vname, vi.vname)
+ in
+ let vi_vtype = addArraySizedAttribute vi.vtype vi.vattr in
+ (* Do the type of the variable. Start the index at 1 *)
+ let t', _ = doType vi_vtype place 1 in
+ vi.vtype <- t';
+ (* Associate a node with the variable itself. Use index = 0 *)
+ let n = N.getNode place 0 vi.vtype vi.vattr in
+
+ (* Add this to the variable attributes. Note that this node might have been
+ * created earlier. Merge the attributes and make sure we get the _ptrnode
+ * attribute *)
+ vi.vattr <- addAttributes vi.vattr n.N.attr;
+
+ (* Add appropriate kinds for arguments of memcpy and friends. *)
+ doAlloc vi;
+ doMemcpy vi.vattr vi.vtype;
+
+ currentLoc := original_location
+
+(* Do an expression. Return an expression, a type and a node. The node is
+ * only meaningful if the type is a TPtr _. In that case the node is also
+ * refered to from the attributes of TPtr. Otherwise the node is N.dummyNode *)
+let rec doExp ?(inSizeof:bool = false) (e: exp): exp * typ * N.node =
+ let markAddrOfLocal lv lvn : unit =
+ (* when taking the address of an lvalue, check whether we're taking the
+ address of a local var. *)
+ let locals = (!currentFunction).slocals in
+ let formals = (!currentFunction).sformals in
+ (match lv with
+ Var vi, _ when List.mem vi locals || List.mem vi formals ->
+ (* Taking the address of a local variable*)
+ setStack lvn (default_why ())
+ | _ -> ())
+ in
+ match e with
+ Lval lv ->
+ let lv', lvn = doLvalue lv false in
+ (* We are reading from it, so mark it as referenced *)
+ setReferenced lvn (default_why ());
+ Lval lv', lvn.N.btype, nodeOfType lvn.N.btype
+
+ | AddrOf lv ->
+ let lv', lvn = doLvalue lv false in
+ markAddrOfLocal lv lvn;
+ AddrOf lv', TPtr(lvn.N.btype, lvn.N.attr), lvn
+
+ | StartOf lv ->
+ let lv', lvn = doLvalue lv false in
+ let next = startOfNode lvn in
+ markAddrOfLocal lv next;
+ StartOf lv', TPtr(next.N.btype, next.N.attr), next
+
+ | UnOp (uo, e, tres) -> (* tres is an arithmetic type *)
+ UnOp(uo, doExpAndCast e tres, tres), tres, N.dummyNode
+
+ | SizeOf (t) ->
+ let t', _ = doType t (N.anonPlace()) 1 in
+ SizeOf (t'), !typeOfSizeOf, N.dummyNode
+
+ | SizeOfE (e) ->
+ let e', et', en' = doExp ~inSizeof:true e in
+ SizeOfE(e'), !typeOfSizeOf , N.dummyNode
+
+ | SizeOfStr (s) ->
+ e, !typeOfSizeOf, N.dummyNode
+
+ | AlignOf (t) ->
+ let t', _ = doType t (N.anonPlace()) 1 in
+ AlignOf (t'), !typeOfSizeOf, N.dummyNode
+
+ | AlignOfE (e) ->
+ let e', et', en' = doExp ~inSizeof:true e in
+ AlignOfE(e'), !typeOfSizeOf , N.dummyNode
+
+ (* pointer subtraction. do the subexpressions *)
+ | BinOp (MinusPP, e1, e2, tres) ->
+ let e1', _, _ = doExp e1 in
+ let e2', _, _ = doExp e2 in
+ BinOp(MinusPP, e1', e2', tres), tres, N.dummyNode
+
+ (* non-pointer arithmetic *)
+ | BinOp (((PlusA|MinusA|Mult|Div|Mod|Shiftlt|Shiftrt|
+ Lt|Gt|Le|Ge|Eq|Ne|BAnd|BXor|BOr|LAnd|LOr) as bop),
+ e1, e2, tres) ->
+ BinOp(bop, doExpAndCast e1 tres,
+ doExpAndCast e2 tres, tres), tres, N.dummyNode
+
+ (* pointer arithmetic *)
+ | BinOp (((PlusPI|MinusPI|IndexPI) as bop), e1, e2, tres) ->
+ let e1', e1t, e1n = doExp e1 in
+ let sign =
+ signOf
+ (match bop with PlusPI|IndexPI -> e2 | _ -> UnOp(Neg, e2, intType))
+ in
+ (match sign with
+ SLiteral z ->
+ if z < Int64.zero then setArith e1n (default_why ()) else
+ if z > Int64.zero then setPosArith e1n (default_why ()) else
+ ()
+
+ | SPos -> setPosArith e1n (default_why ())
+
+ | _ ->
+ if bop = IndexPI then (* Was created from p[e] *)
+ setPosArith e1n (default_why ())
+ else
+ setArith e1n (default_why ()) );
+ if sign = SLiteral Int64.zero then
+ e1', e1t, e1n
+ else
+ BinOp (bop, e1', doExpAndCast e2 intType, e1t), e1t, e1n
+
+
+ | CastE (newt, e) ->
+ let newt', _ = doType newt (N.anonPlace ()) 1 in
+ let e' =
+ if Dattrs.isTrustedType newt then begin
+ (* Trusted Cast. Do not insert an edge. *)
+ let e', _, _ = doExp e in
+ e'
+ end else if Dattrs.isNulltermDrop newt then begin
+ (* An NTDROP. Don't propagate pkString across the edge. *)
+ doExpAndCast ~castKind:N.EEK_stringdrop e newt'
+ end else
+ (* Ordinary cast *)
+ doExpAndCast e newt'
+ in
+ CastE (newt', e'), newt', nodeOfType newt'
+
+ | Const (CStr s) as e ->
+ let n = N.getNode N.PStr 1 charType Dattrs.stringAttrs in
+ (e, typeOf e, n)
+ | Const (CWStr s) as e ->
+ let n = N.getNode N.PWStr 1 !wcharType Dattrs.stringAttrs in
+ (e, typeOf e, n)
+
+ | Const _ -> (e, typeOf e, N.dummyNode)
+
+
+
+(* Do initializers. *)
+and doInit (vi: varinfo) (i: init) (l: location) : init * typ =
+
+ (* Baseoff is the offset to the current compound *)
+ let rec doOne (baseoff: offset) off (what: init) : init * typ =
+ let off' = addOffset off baseoff in
+ match what with
+ | SingleInit ei -> begin
+ (* Fake an assignment *)
+ let lv', ei' = doSet (Var vi, off') ei l in
+ SingleInit ei', typeOfLval lv'
+ end
+ | CompoundInit (t, initl) ->
+ let t', _ = doType t (N.anonPlace ()) 1 in
+ let initl' =
+ foldLeftCompound
+ ~implicit:false
+ ~doinit:(fun newoff what t acc ->
+ let what', _ = doOne off' newoff what in
+ (newoff, what') :: acc)
+ ~ct:t' ~initl:initl ~acc:[] in
+ CompoundInit (t', List.rev initl'), t'
+
+ in
+ doOne NoOffset NoOffset i
+
+
+and doSet (lv: lval) (e: exp) (l: location) : lval * exp =
+ let lv', lvn = doLvalue lv true in
+ (* We are writing to it, so mark it as referenced *)
+ setReferenced lvn (N.ProgramSyntax(l)) ;
+ let e' = doExpAndCast e lvn.N.btype in
+ (* sg: If assigning thru a pointer or to a global, mark adresses in e'
+ * as pkEscape. The former is a conservative approximation since
+ * depending on where lv can point, the value may probably not escape *)
+ (match lv' with
+ Mem _, _ -> expMarkEscape e' (* thru a pointer *)
+ | Var vi, _ ->
+ if vi.vglob then expMarkEscape e' else () ); (* to a global *)
+ lv', e'
+
+and expMarkEscape (e: exp) : unit =
+ match e with
+
+ Lval lv ->
+ let lvnode = nodeOfType (typeOfLval lv) in
+ setEscape lvnode (default_why ())
+
+ | StartOf lv ->
+ let lvnode = (* like typeOf, but keeps attrs of arrays *)
+ match unrollType (typeOfLval lv) with
+ TArray (t,_,al) -> nodeOfType (TPtr(t, al))
+ | _ -> E.s (E.bug "expMarkEscape: StartOf on a non-array")
+ in
+ setEscape lvnode(default_why ())
+
+ | AddrOf lv ->
+ let _, alvnode = doLvalue lv false (* gets node for &lv *)
+ in setEscape alvnode(default_why ())
+
+ | CastE(_, e1) -> expMarkEscape e1
+ | UnOp((Neg|BNot), e1, _) -> expMarkEscape e1
+
+ | BinOp( (Lt|Gt|Le|Ge|Eq|Ne(*|LtP|GtP|LeP|GeP|EqP|NeP*)), _, _, _) -> ()
+ | BinOp(_, e1, e2, _) -> expMarkEscape e1; expMarkEscape e2
+ | _ -> ()
+
+
+(* Do an lvalue. We assume conservatively that this is for the purpose of
+ * taking its address. Return a modifed lvalue and a node that stands for &
+ * lval. Just ignore the node and get its base type if you do not want to
+ * take the address of. *)
+and doLvalue ((base, off) : lval) (iswrite: bool) : lval * N.node =
+ let base', startNode =
+ match base with
+ Var vi -> begin
+ let vn =
+ match N.nodeOfAttrlist vi.vattr with
+ Some n -> n
+ | _ -> N.dummyNode
+ in
+ (* Now grab the node for it *)
+ base, vn
+ end
+ | Mem e ->
+ let e', et, ne = doExp e in
+ if iswrite then
+ setUpdated ne (default_why ());
+ Mem e', ne
+ in
+ let newoff, newn = doOffset off startNode in
+ (base', newoff), newn
+
+(* Now do the offset. Base types are included in nodes. *)
+and doOffset (off: offset) (n: N.node) : offset * N.node =
+ match off with
+ NoOffset -> off, n
+
+ | Field(fi, resto) ->
+ let nextn = fieldOfNode n fi in
+ let newo, newn = doOffset resto nextn in
+ Field(fi, newo), newn
+
+ | Index(e, resto) -> begin
+ let nextn = startOfNode n in
+ setPosArith nextn (default_why ()) ;
+ let newo, newn = doOffset resto nextn in
+ let e', et, _ = doExp e in
+ Index(e', newo), newn
+ end
+
+
+(* Now model an assignment of a processed expression into a type *)
+and expToType ?(castKind=N.EEK_cast) (e,et,en) t (callid: int) : exp =
+ let debugExpToType = false in
+ if not (Dattrs.isTrustedType et) && not (Dattrs.isTrustedType t) then begin
+ let destn = nodeOfType t in
+ if debugExpToType then
+ ignore (E.log "expToType e=%a (NS=%d) -> TD=%a (ND=%d)\n"
+ d_plainexp e en.N.id d_plaintype t destn.N.id);
+ match en == N.dummyNode, destn == N.dummyNode with
+ true, true -> e (* scalar -> scalar *)
+ | false, true -> e (* Ignore casts of pointer to non-pointer *)
+ | false, false -> (* pointer to pointer *)
+ if debugExpToType then
+ ignore (E.log "Setting %a : %a (%d -> %d)\n"
+ d_plainexp e d_plaintype et en.N.id destn.N.id);
+ ignore (N.addEdge en destn (N.ECast castKind) (Some !currentLoc));
+ e
+
+ | true, false -> (* scalar -> pointer *)
+ (* Check for zero *)
+ if isZero e then
+ () (* setNull destn *)
+ else begin
+ if isPointerType et then
+ E.s (Dutil.bug "Casting %a to pointer type %a, but it has no node."
+ Dattrs.dx_exp e Dattrs.dx_type t);
+ setIntCast destn (default_why ())
+ end;
+ e
+ end else
+ e
+
+
+and doExpAndCast ?(castKind: N.extra_edge_kind option) e t =
+ expToType ?castKind (doExp e) t (-1)
+
+and doExpAndCastCall e t callid =
+ expToType (doExp e) t callid
+
+
+
+
+
+(*****************************************************************)
+
+
+let rec doBlock blk =
+ if not (hasAttribute "trusted" blk.battrs) then
+ List.iter doStmt blk.bstmts;
+ blk
+
+and doStmt (s: stmt) : unit =
+ match s.skind with
+ Goto _ | Break _ | Continue _ -> ()
+ | Return (None, _) -> ()
+ | Return (Some e, l) ->
+ currentLoc := l;
+ let e' = doExpAndCast e !currentResultType in
+ expMarkEscape e';
+ s.skind <- Return (Some e', l)
+ | Instr il ->
+ s.skind <- Instr (mapNoCopyList doInstr il)
+ | Loop (b, l, lb1, lb2) ->
+ currentLoc := l;
+ s.skind <- Loop (doBlock b, l, lb1, lb2)
+ | Block b -> s.skind <- Block (doBlock b)
+ | If(e, b1, b2, l) ->
+ currentLoc := l;
+ s.skind <- If (doExpAndCast e intType, doBlock b1, doBlock b2, l)
+ | Switch (e, b, cases, l) ->
+ currentLoc := l;
+ s.skind <- Switch(doExpAndCast e intType, doBlock b, cases, l)
+ | TryFinally (b, h, l) ->
+ currentLoc := l;
+ s.skind <- TryFinally(doBlock b, doBlock h, l)
+ | TryExcept (b, (il, e), h, l) ->
+ currentLoc := l;
+ s.skind <- TryExcept(doBlock b, (mapNoCopyList doInstr il,
+ doExpAndCast e intType),
+ doBlock h, l)
+
+and doInstr (i:instr) : instr list =
+ match i with
+ | Asm (attrs, tmpls, outs, ins, clob, l) ->
+ currentLoc := l;
+ let outs' =
+ List.map
+ (fun (i,n, o) ->
+ let o', lvn = doLvalue o true in
+ setReferenced lvn (default_why ());
+ (i,n, o'))
+ outs
+ in
+ let ins' =
+ List.map
+ (fun (i,n, e) ->
+ let e', _, _ = doExp e in
+ (i,n, e'))
+ ins
+ in
+ [Asm(attrs, tmpls, outs', ins', clob, l)]
+
+ | Set (lv, e,l) ->
+ currentLoc := l;
+ let lv', e' = doSet lv e l in
+ [Set(lv', e',l)]
+
+ | Call (reso, orig_func, args, l) -> begin
+ currentLoc := l;
+ Stats.time "doFunctionCall" (doFunctionCall reso orig_func args) l
+ end
+
+and doFunctionCall
+ (reso: lval option)
+ (func: exp)
+ (args: exp list)
+ (l: location) =
+ incr callId; (* A new call id *)
+
+ (* Do the function itself *)
+ let func', pfuncn =
+ match func with
+ Lval lv ->
+ let lv', lvn = doLvalue lv false in
+ setReferenced lvn (default_why ());
+ Lval lv', lvn
+ | _ -> E.s (Dutil.bug "Called function is not an lvalue")
+ in
+ let (rt, formals, isva, attrs) =
+ match unrollType (typeOf func') with
+ TFun(rt, formals, isva, attrs) ->
+ rt, argsToList formals, isva, attrs
+ | _ -> E.s (Dutil.bug "Call to a non-function")
+ in
+ let args' =
+ if isva then
+ (* This might add prototypes to theFile *)
+ Dvararg.prepareVarargArguments
+ (fun t ->
+ let vi = makeTempVar !currentFunction t in
+ doVarinfo vi;
+ vi)
+ func' (List.length formals) args
+ else
+ args
+ in
+ let freeArg =
+ match Dattrs.getZeroOneAttr ["dfree"; "drealloc"] attrs with
+ | Some (Attr ("dfree", [ACons (name, [])]))
+ | Some (Attr ("drealloc", [ACons (name, []); _])) -> Some name
+ | _ -> None
+ in
+ (* Now check the arguments *)
+ let rec loopArgs formals args =
+ match formals, args with
+ [], [] -> []
+ | [], a :: args ->
+ (* We ran out of formals. This is either in a vararg functions or
+ * else this is bad, so we make sure to mark that the argument is
+ * used in a function without prototypes *)
+ (* Do the arguments because they might contain pointer types *)
+ let a', _, an = doExp a in
+ if an != N.dummyNode && not isva then
+ Dutil.warn "Calling function %a with too many args."
+ d_exp func;
+ a' :: loopArgs [] args
+
+ | (fn, ft, _) :: formals, a :: args ->
+ let a' =
+ if Some fn <> freeArg then
+ doExpAndCastCall a ft !callId
+ else
+ let a', _, _ = doExp a in a'
+ in
+ a' :: loopArgs formals args
+
+ | _ :: _, [] ->
+ E.s (Dutil.error "Calling function %a with too few args."
+ d_exp func)
+ in
+ (* Now scan the arguments again and add EArgs edges *)
+ let args'' = loopArgs formals args' in
+ List.iter (fun a' ->
+ let a'n = nodeOfType (typeOf a') in
+ if a'n != N.dummyNode then
+ ignore (N.addEdge pfuncn a'n N.EArgs (Some l))) args'';
+
+ let reso' =
+ (* Now check the return value *)
+ match reso, unrollType rt with
+ None, TVoid _ -> None
+ | Some _, TVoid _ ->
+ ignore (warn "void value is assigned.");
+ None
+
+ | None, _ -> None (* "Call of function is not assigned" *)
+ | Some dest, _ -> begin
+ (* Do the lvalue, just so that the type is done *)
+ let dest', destn = doLvalue dest true in
+ (* We are using the pointer, so mark it referenced. *)
+ setReferenced destn (default_why ());
+ (* Add the cast from the return type to the destination of the call.
+ * Make up a phony expression and a node so that we can call
+ * expToType. *)
+ let dest't = typeOfLval dest' in
+ (* Also add an EArgs edge *)
+ let dest'n = nodeOfType dest't in
+ if dest'n != N.dummyNode then
+ ignore (N.addEdge pfuncn dest'n N.EArgs (Some l));
+ (* For allocation functions do not connect the returned value to the
+ * result because the returned value is an integer *)
+ (match func' with
+ Lval(Var f, NoOffset) when H.mem allocFunctions f.vname -> ()
+ | _ ->
+ ignore (expToType (CastE(rt, mkString ("<a call return>")),
+ rt, nodeOfType rt) dest't
+ !callId));
+ Some dest'
+ end
+ in
+ [Call(reso', func', args'', l)]
+
+
+let doFormals (fdec: fundec) =
+ currentFunction := fdec;
+ (* Go through the formals and copy their type and attributes from
+ * the type of the function. Then add the nodes for the address of the
+ * formals. Then restore the sharing with the function type. *)
+ let rt, targs, isva, fa = splitFunctionTypeVI fdec.svar in
+ let rec scanFormals targs sformals =
+ match targs, sformals with
+ [], [] -> ()
+ | (tan, tat, taa) :: targs, sf :: sformals ->
+ sf.vtype <- tat;
+ let n =
+ N.getNode (N.PLocal(!currentFile.fileName,
+ !currentFunction.svar.vname, tan))
+ 0 tat taa in
+ sf.vattr <- addAttributes taa n.N.attr;
+ scanFormals targs sformals
+ | _ -> E.s (bug "scanFormals(%s) non-matching formal lists"
+ fdec.svar.vname)
+ in
+ scanFormals (argsToList targs) fdec.sformals;
+ (* Restore the sharing by writing the type *)
+ setFormals fdec fdec.sformals;
+ ()
+
+let doFunctionBody (fdec: fundec) =
+ currentFunction := fdec;
+ let rt,_,_,_ = splitFunctionTypeVI fdec.svar in
+ currentResultType := rt;
+ (* Do the other locals *)
+ List.iter doVarinfo fdec.slocals;
+ (* Do the body *)
+ fdec.sbody <- doBlock fdec.sbody
+
+
+
+(* Now do the globals *)
+let doGlobal (g: global) : global =
+ match g with
+ | GPragma _ | GText _ | GAsm _
+ | GEnumTag _ | GCompTagDecl _ | GEnumTagDecl _ -> g
+
+ (* We process here only those types that we must not unroll.
+ * The others we'll process as we see them used.*)
+ | GType (t, l) ->
+ currentLoc := l;
+ (* See if we have the "nounroll" attribute *)
+ if hasAttribute "nounroll" (typeAttrs t.ttype) then
+ H.add dontUnrollTypes t.tname true;
+ if not (mustUnrollTypeInfo t) then begin
+ let t', _ = doType t.ttype (N.PType t.tname) 1 in
+ t.ttype <- t';
+ g
+ end else
+ if !N.printVerboseOutput then
+ GText ("// Definition of unrolled type "^t.tname^" was removed")
+ else
+ GText ("//")
+
+ | GCompTag (comp, l) ->
+ currentLoc := l;
+ markCompInfo comp l;
+ g
+
+ | GVarDecl (vi, l) ->
+ currentLoc := l;
+ Stats.time "global doVarinfo" doVarinfo vi;
+ g
+
+ | GVar (vi, init, l) ->
+ currentLoc := l;
+ Stats.time "global doVarinfo" doVarinfo vi;
+ (match init.init with
+ None -> ()
+ | Some i ->
+ let i', _ = Stats.time "doInit" (doInit vi i) l in
+ init.init <- Some i');
+ g
+
+ | GFun (fdec, l) ->
+ currentLoc := l;
+ Stats.time "global doVarinfo" doVarinfo fdec.svar;
+ Stats.time "doFormals" doFormals fdec;
+ let dobox = not (Dattrs.isTrustedType fdec.svar.vtype) in
+ if dobox then
+ Stats.time "doFunctionBody" doFunctionBody fdec;
+ g
+
+
+(********************************************************)
+
+
+(* Now do the file *)
+let markFile fl =
+ currentFile := fl;
+
+ N.initialize ();
+ IH.clear mustRecomputePointsTo;
+ IH.clear markedCompInfos;
+ H.clear dontUnrollTypes;
+ H.clear allocFunctions;
+
+ (* This is where we process all the functions. *)
+ theFile := [];
+ Stats.time "doGlobal"
+ (List.iter (fun g -> let g' = doGlobal g in
+ theFile := g' :: !theFile)) fl.globals;
+
+ (* Now we have to scan the nodes again. There might be some nodes whose
+ * type is pointer to TComp and which do not have any EPointsTo edges
+ * because the TComp was a forward reference. Now that should have been
+ * fixed, so try to regenerate the EPoints to edges *)
+ IH.iter (fun _ n -> N.setNodePointsTo n) mustRecomputePointsTo;
+
+ (* Now do the globinit *)
+ let newglobinit =
+ match fl.globinit with
+ None -> None
+ | Some g -> begin
+ match doGlobal (GFun(g, locUnknown)) with
+ GFun (g', _) -> Some g'
+ | _ -> E.s (bug "markptr: globinit")
+ end
+ in
+ if !verbose then
+ ignore (E.log "after markptr\n");
+
+ let newglobals = List.rev !theFile in
+
+ let newfile = {fl with globals = newglobals; globinit = newglobinit} in
+
+ H.clear dontUnrollTypes;
+ H.clear allocFunctions;
+ IH.clear mustRecomputePointsTo;
+ IH.clear markedCompInfos;
+ theFile := [];
+ currentFile := dummyFile;
+
+ newfile
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2006,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(* Call this to construct the pointer graph *)
+val markFile: Cil.file -> Cil.file
+
+val noStackOverflowChecks: bool ref
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2006,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+
+(* Implements nodes in a graph representing the pointer locations in a
+ * program *)
+open Cil
+open Pretty
+open Trace
+
+module H = Hashtbl
+module IH = Inthash
+module E = Errormsg
+
+(* Deputy uses separate compilation, so just about anything can
+ escape. So far, we only use this for pkReferenced *)
+let separateCompilation = true
+
+(* If defaultIsNotWild then pointers without a qualifier are SAFE and only
+ * the arrays that are specfically SIZED contain a size field and only the
+ * variables that are specifically TAGGED contain tags *)
+let defaultIsWild = ref false
+
+
+let useFSEQ = ref true
+let useStrings = ref true
+let extendStringBuffers = ref false
+
+let allowOverride = ref true
+
+let useOffsetNodes = true
+
+let printVerboseOutput = ref false
+
+(* Whether to check the chains *)
+let doCheckChains = false
+
+
+(* This function will be set by the Type module *)
+let isSubtype: (typ -> typ -> bool) ref = ref (fun _ _ -> false)
+let origSubtype = !isSubtype
+
+(* flag to force functions to never be tagged *)
+let wild_solve_untagged_functions = ref false
+
+(* force functions to always be tagged *)
+let wild_solve_tag_all_functions = ref false
+
+(* True if the wild solver is used. *)
+let use_wild_solver = ref false
+
+(** How much detail to print. -1 means do not print the graph *)
+let emitGraphDetailLevel : int ref = Doptions.emitGraphDetailLevel
+
+let graphDetailLevelLegend =
+"the level of detail in the .infer files:\n" ^
+"\t 0 - just the nodes, kind and the chains\n" ^
+"\t 1 - also the types, location, name and flags\n" ^
+"\t 2 - also the edges (without) justification\n" ^
+"\t 3 - everything"
+
+let keepDetails () =
+ !emitGraphDetailLevel > 0
+
+(* A marker that the solver places, if we use lean fats *)
+let useLeanFats = ref false
+
+let allowPartialElementsInSequence = ref false
+
+let hasPrefix p s =
+ let pl = String.length p in
+ (String.length s >= pl) && String.sub s 0 pl = p
+
+let hasSuffix suff s =
+ let ls = String.length s in
+ let lsuff = String.length suff in
+ ls >= lsuff && suff = String.sub s (ls - lsuff) lsuff
+
+(* A place where a pointer type can occur *)
+type place =
+ PGlob of string (* A global variable or a global function *)
+ | PType of string (* A global typedef *)
+ | PStatic of string * string (* A static variable or function. First is
+ * the filename in which it occurs *)
+ | PLocal of string * string * string (* A local varialbe. The name of the
+ * file, the function and the name of
+ * the local itself *)
+ | POffset of int * string (* An offset node, give the host node
+ * id and a field name *)
+ | PField of fieldinfo (* A field of a composite type *)
+
+ | PAnon of int (* Anonymous. This one must use a
+ * fresh int every time. Use
+ * anonPlace() to create one of these
+ * *)
+ | PStr (* The global node for all string
+ * literals. They all have the same
+ * kind, so we don't need separate
+ * nodes.*)
+ | PWStr (* The global node for all wide string
+ * literals. *)
+
+let anonId = ref (-1)
+let anonPlace () : place =
+ incr anonId;
+ PAnon !anonId
+
+(* Each node corresponds to a place in the program where a qualifier for a
+ * pointer type could occur. As a special case we also add qualifiers for
+ * variables in expectation that their address might be taken *)
+type node =
+ { id: int; (* A program-wide unique identifier *)
+ where: place * int; (* A way to identify where is this
+ * coming from. We use this to make
+ * sure we do not create duplicate
+ * nodes. The integer is an index
+ * within a place, such as if the
+ * type of a global contains several
+ * pointer types (nested) *)
+
+ btype: typ; (* The base type of this pointer *)
+ mutable attr: attributes; (* The attributes of this pointer
+ * type *)
+ mutable is_array: bool; (* This node is associated with an
+ * array, not with a pointer. *)
+
+ mutable flags: (whyflag option) array;
+
+ mutable succ: edge list; (* All edges with "from" = this node *)
+ mutable pred: edge list; (* All edges with "to" = this node *)
+
+
+ (* The rest are the computed results of constraint resolution *)
+ mutable kind: opointerkind;
+ mutable why_kind: whykind;
+ mutable sized: bool ; (* An array may be SIZED at which
+ * point it has a length field
+ * stored right before it. This
+ * leads to INDEX pointers. *)
+
+ mutable locked: bool; (* do not change this kind later *)
+ mutable mark: bool; (* For mark-and-sweep GC of nodes.
+ * Most of the time is false *)
+ mutable rep : (node * chain ) option;
+ (* the next node in the chain to the representative of this class.
+ * use get_rep to get the final representative *)
+ mutable loc : Cil.location; (* where did this node come from? *)
+
+ shouldInfer: bool; (* True if this is a local or a cast
+ and we can do more aggressive
+ inference. *)
+ }
+
+and opointerkind =
+ Safe (* a COUNT(1) pointer *)
+ | Sentinel (* a COUNT(0) pointer. If a pointer is not referenced,
+ not NT, is not annotated SAFE, and does not use
+ arithmetic, it gets this kind.*)
+
+ | Seq (* Needs lower and upper bounds *)
+ | FSeq (* Needs upper bound *)
+
+ | SeqN
+ | FSeqN
+ | String (* An NT COUNT(0) pointer *)
+
+ | UnknownN (* An NT pointer with no annotated bounds.
+ Inference turns this into String, FSeqN, or SeqN.
+ If no pkArith flag is present after solving, this
+ will default to String.*)
+
+ | Unknown (* If no pkArith or pkString flag is present after solving,
+ this will default to Safe.*)
+
+and whyflag = (* why is this flag set for this node? *)
+ | ProgramSyntax of Cil.location
+
+ (* This flag is set because it is set on some other node (node1 + the
+ * chain:node1->this). We also give the original source of the flag. *)
+ | FlagSpreadFromNode of node * chain * node
+
+ | DownCast of node
+ | SubtypeFailed of node
+ | RequiredByEdge of edge
+ | RequiredByPointerKind of opointerkind
+ | RequiredByFlag of int
+ | FlUserSpec of Cil.location (* Annotated by a user *)
+ | MayEscape of Cil.location (* We are using separate compilation,
+ and this node is not a local.
+ Therefore, we assume it can be used
+ by anybody. *)
+
+and whykind = (* why did we give it this kind? *)
+ BadCast of edge (* always attach to ECast edges *)
+ | BadSequenceCast of edge
+ | Incompat of node * chain * node (* Two nodes that should be in the same
+ * equivalence class are incompatible *)
+
+ | BoolFlag of int
+ | PolyInt (* This is a void* connected only to scalars *)
+ | Default
+ | UserSpec
+ | Unconstrained
+ | PrintfArg (* printf inference *)
+ | Special of string * location
+
+ (* This kind is set because it is set on some other node (node1 + the
+ * chain:node1->this). We also give the original source of the kind. *)
+ | SpreadFromNode of node * chain * node
+
+
+and edge =
+ { eid: int;
+ mutable efrom: node;
+ mutable eto: node;
+ mutable ekind: edgekind;
+ mutable eloc: location;
+ }
+
+
+and edgekind =
+ ECast of extra_edge_kind (* T_from ref q_from <= T_to ref q_to. We also
+ * cary some additional explanation for this
+ * edge. *)
+ | EOffset (* From a pointer to struct to a pointer to
+ * field *)
+ | EIndex (* q_to = if q_from = wild then wild else index *)
+
+ | ECompat (* the kinds of these two nodes must be
+ * compatible: either both wild, index or
+ * safe. This edge type is added by the solver
+ * for its convenience. In cases like
+ * int * 1 * 2 x;
+ * int * 3 * 4 y;
+ * We will connect 1 and 3 with ECompat. *)
+ of chain (* An ECompat edge can always be explained
+ * using a list of ECast edges *)
+ | ESameKind (* Special edge that does not require
+ * compatibility of the types involved, but does
+ * require that they be of the same KIND. *)
+ of extra_edge_kind_sk (* See below for uses of ESameKind *)
+ | EPointsTo (* from's base type included to *)
+ | EArgs (* From the pointer to the function to the
+ * actual arguments and result values. Before we
+ * added this edge we relied on WILDness to
+ * spread from the function pointer to the
+ * actual argument by means of EPoints to edge
+ * to the formals and then ECast edges. But that
+ * did not work when there were no formals
+ * declared ! *)
+
+(* More info about ECast edges *)
+and extra_edge_kind =
+ EEK_cast (* A true cast *)
+ | EEK_stringdrop (* An NTDROP cast in deputy. We do not push
+ pkString forwards across this edge.
+ (pkString flows backwards as usual) *)
+ | EEK_cxxOverride (* Due to the Cxx inheritance. See markcxx *)
+ | EEK_extends (* Due to an extends relationship *)
+ | EEK_mkptr (* Due to a mkptr or alignseq *)
+ | EEK_union (* Edges added between union fields *)
+ | EEK_rtti (* Edges due to auto RTTI *)
+
+(* More info about ESameKind edges *)
+and extra_edge_kind_sk =
+ | EEK_trustedCast (* This edge is added between the formal
+ * argument and the result value in an instance
+ * of trusted_cast function. This does not
+ * require compatibility of the types involved
+ * but does require that the two types be of the
+ * same KIND *)
+ | EEK_taggedUnion (* Behaves like an trustedCast, but is sound.
+ * We use this to connect union fields that must
+ * have the same kind in case we cast from one to
+ * another, but we can ignore types on these edges
+ * since those are checked dynamically. *)
+
+
+(************** CHAINS ********************)
+
+(** An implementation of chains using constructors for sym and trans *)
+and chain =
+ (* The chain why a node has a certain representative or why a
+ * ECompat edge exists *)
+ RIdent (* Identity: a relationship between identical nodes *)
+
+ | RSingle of edge
+ (* This is an ECast edge. This chain is used for
+ * ECompat edges that arise "below" a ECast edge. *)
+
+ | RSym of chain (* If "chain" explains ECompat(n1-n2) then,
+ * "RSym(chain)" explains ECompat(n2-n1). *)
+
+ (* Transitivity *)
+ | RTrans of node * chain * chain * node * int
+ (* Remember the first and the last nodes, and the length *)
+
+
+ | RList of node * (bool * edge) list * node * int
+ (* A list of elements along with the information whether they are
+ * reversed. Remember the first and the last node and the length. *)
+
+(** Keep a table with the shortest path *)
+type pathEntry =
+ { mutable peLen: int; (* Nr of RSingle *)
+ mutable peChain: chain
+ }
+
+let inftyLen = 1000000 (* A very large length *)
+let idPathEntry = { peLen = 0; peChain = RIdent }
+
+(* matth: unused in Deputy *)
+let shortestPath: (int * int, pathEntry) H.t = H.create 11111
+
+let getShortestChain (nfrom: node) (nto: node) : pathEntry * bool =
+ if nfrom.id = nto.id then
+ idPathEntry, false
+ else
+ let from', to', sym =
+ if nfrom.id < nto.id then
+ nfrom.id, nto.id, false
+ else
+ nto.id, nfrom.id, true
+ in
+ let pe =
+ Util.findOrAdd shortestPath (from', to')
+ (fun _ -> { peLen = inftyLen; peChain = RIdent }) in
+ pe, sym
+
+let d_edge (e: edge) = dprintf "%d->%d" e.efrom.id e.eto.id
+
+let rec d_chain () (r: chain) =
+ match r with
+ RIdent -> nil
+ | RSingle e -> d_edge e (* dprintf "%d->%d" e.efrom.id e.eto.id *)
+ | RSym r -> text "sym(" ++ d_chain () r ++ text ")"
+ | RTrans (_, r1, r2, _, _) ->
+ if !emitGraphDetailLevel > 2 then
+ d_chain () r1 ++ text "," ++ d_chain () r2
+ else text "..."
+ | RList (_, l, _, _) ->
+ dprintf "list(%a)"
+ (docList
+ (fun (isrev, a) ->
+ if isrev then text "sym(" ++ d_edge a ++ text ")"
+ else d_edge a))
+ l
+
+let rec dumpChain = function
+ RIdent -> ignore (E.log "RID\n")
+ | RSingle e -> ignore (E.log "Edge %a\n" insert (d_edge e))
+ | RSym r ->
+ ignore (E.log "(RSym \n");
+ dumpChain r;
+ ignore (E.log ")\n")
+
+ | RTrans (_, r1, r2, _, _) ->
+ ignore (E.log "(RTrans \n");
+ dumpChain r1;
+ ignore (E.log ") and (\n");
+ dumpChain r2;
+ ignore (E.log ")\n")
+ | RList (_, l, _, _) ->
+ ignore (E.log "list(\n");
+ List.iter
+ (fun (isrev, a) ->
+ if isrev then
+ ignore (E.log "sym(%a)" insert (d_edge a))
+ else
+ ignore (E.log "Edge %a," insert (d_edge a)))
+ l
+
+let debugChains = false
+
+let mkRIdent = RIdent
+let mkRSingle e = RSingle e
+
+ (* A few helper functions for manipulating chains *)
+let mkRSym (r: chain) =
+ match r with
+ RIdent -> RIdent
+ | RSym r1 -> r1
+ | _ -> RSym r
+
+let isSym (r: chain) =
+ match r with
+ RSym r1 -> Some r1
+ | _ -> None
+
+(* Get one edge from the chain *)
+let rec getOneEdge (r: chain) : edge option =
+ match r with
+ RSingle e' -> Some e'
+ | RSym r -> getOneEdge r
+ | RTrans (_, r1, r2, _, _) -> getOneEdge r1
+ | RList (_, ((_, h) :: _), _, _) -> Some h
+ | RIdent -> None
+ | RList _ -> None
+
+let rec isOneEdge (r: chain) : edge option =
+ match r with
+ RSingle e' -> Some e'
+ | RSym r -> isOneEdge r
+ | RList (_, [(_, e)], _, _) -> Some e
+ | _ -> None
+
+ (* Return a list of elements in a chain. The boolean value says
+ * whether the edge is reversed *)
+let rec chainToList (c: chain) : (bool * edge) list =
+ (* We have the tail already. We have to cons on the beginning of it the
+ * argument, possibly symmetric *)
+
+ (* Remember all the tails, indexed by the node number *)
+ let tails: (int, (bool * edge) list) H.t = H.create 19 in
+ let rec loop (sym: bool) (c: chain)
+ (tail: (bool * edge) list) =
+ match c with
+ RIdent -> tail
+ | RSingle e -> begin
+ (* Maybe this cancels out with something in the tail *)
+ match tail with
+ (sym', e') :: tail' when e == e' ->
+ if sym <> sym' then
+ tail'
+ else begin
+ ignore (E.warn "duplicate edge in chain");
+ (* (sym, e) :: *) tail
+ end
+ | _ -> begin
+ (* This is the place where we extend the tail. Check if we can
+ * use a shorter tail *)
+ let f = if sym then e.eto.id else e.efrom.id in
+ let res = (sym, e) :: tail in
+ Util.findOrAdd tails f (fun _ -> res)
+ end
+ end
+ | RSym c -> loop (not sym) c tail
+ | RTrans (_, r1, r2, _, _) ->
+ (* ignore (E.log "chainToList(%x)\n" (Obj.magic c)); *)
+ if sym then
+ loop sym r2 (loop sym r1 tail)
+ else
+ loop sym r1 (loop sym r2 tail)
+ | RList (_, l, _, _) ->
+ if sym then (* Must reverse the list as well *)
+ List.fold_left
+ (fun acc (isrev, h) ->
+ loop (sym <> isrev) (RSingle h) acc)
+ tail
+ l
+ else if tail = [] then
+ l (* since sym = false && tail = [] *)
+ else
+ ( try
+ List.fold_right
+ (fun (isrev, h) acc ->
+ loop (sym <> isrev) (RSingle h) acc)
+ l
+ tail
+ with e ->
+ (ignore (E.warn "List.fold_right raises %s"
+ (Printexc.to_string e)) ; raise e)
+ )
+ in
+ loop false c []
+
+
+let rec getFirstAndLastNode (sym: bool) (c: chain) : node * node * int =
+ match c with
+ RSingle e ->
+ let fn, ln = if sym then e.eto, e.efrom else e.efrom, e.eto in
+ fn, ln, 1
+
+ | RSym c -> getFirstAndLastNode (not sym) c
+ | RTrans (fn, _, _, ln, len)
+ | RList (fn, _, ln, len) ->
+ if sym then ln,fn,len else fn,ln,len
+ | _ -> E.s (E.bug "getFirstAndLastEdge: %a" d_chain c)
+
+
+(* A helper function for concatenating chains. Call when both of the chains
+ * are non-empty. *)
+let mkRTransHelper (r1: chain) (r2: chain) : chain =
+ let fn1, ln1, len1 = getFirstAndLastNode false r1 in
+ let fn2, ln2, len2 = getFirstAndLastNode false r2 in
+ (* Get the data about this whole path *)
+ let pe, sym = getShortestChain fn1 ln2 in
+ (* See if the new one has any chance of being better *)
+ if pe.peLen <= len1 + len2 then
+ if sym then mkRSym pe.peChain else pe.peChain (* Keep the old one *)
+ else begin
+ (* Prepare the possible result *)
+ let res = RTrans(fn1, r1, r2, ln2, len1 + len2) in
+ (* The new one is better. See how small it can get *)
+ if debugChains then
+ ignore (E.log "Finding best chain from %d->%d. Right now %d->%d(%d) + %d->%d(%d)\n"
+ fn1.id ln2.id fn1.id ln1.id len1 fn2.id ln2.id len2);
+ let l = chainToList res in
+ let l_len = List.length l in
+ if debugChains && l_len > 40 then begin
+ ignore (E.log " res=%a@!"
+ (docList
+ (fun (sym, e) ->
+ if sym then dprintf "<-%d" e.efrom.id
+ else dprintf "->%d" e.eto.id))
+ l);
+ end;
+ let bestLen, bestChain =
+ if l_len < len1 + len2 then
+ l_len, (if l_len = 0 then RIdent else RList (fn1, l, ln2, l_len))
+ else
+ len1+len2, res
+ in
+ (* Update the entry *)
+ if debugChains then
+ ignore (E.log "Setting best chain from %d->%d of length %d %s\n"
+ fn1.id ln2.id bestLen
+ (if bestLen < len1 + len2 then "(compressed)" else ""));
+ pe.peLen <- bestLen;
+ pe.peChain <- if sym then mkRSym bestChain else bestChain;
+ bestChain
+ end
+
+let mkRTransChain (r1: chain) (r2: chain) =
+ let isSymOf (r1: chain) (r2: chain) =
+ match r1, r2 with
+ | r1, RSym r1' when r1 == r1' -> true
+ | RSym r2', r2 when r2 == r2' -> true
+ | _, _ -> false
+ in
+ begin
+ match r1, r2 with
+ RIdent, r2 -> r2
+ | r1, RIdent -> r1
+ (* It is important to recognize some special cases that lead to
+ * exponential explosion *)
+ | r1, r2 when isSymOf r1 r2 -> RIdent
+ | r1, RTrans (_, r1', r2, _, _) when isSymOf r1 r1' -> r2
+ | RTrans (_, r1, r2, _, _), r2' when isSymOf r2 r2' -> r1
+ | _, _ -> mkRTransHelper r1 r2
+ end
+
+
+
+
+(* A mapping from place , index to ids. This will help us avoid creating
+ * duplicate nodes *)
+let placeId: (place * int, node) H.t = H.create 1111
+
+(* A mapping from ids to nodes. Rarely we need to find a node based on its
+ * index. *)
+let idNode: node IH.t = IH.create 1111
+
+(* Next identifier *)
+let lastNodeId = ref (-1)
+
+
+
+let pkInterface = 0 (* this is an interface node *)
+let pkUpdated = 1 (* we write through this pointer *)
+let pkIntCast = 2 (* can contain an integer *)
+let pkPosArith = 3 (* subject to positive pointer arithmetic *)
+let pkArith = 4 (* subject to arbitrary pointer arithmetic *)
+let pkString = 5 (* A String node. The value at the end of the
+ buffer is a nul. matth, sept05: This
+ flows forwards and backwards now.*)
+let pkReachIndex = 6 (* can reach an Index node *)
+let pkNoPrototype = 7 (* Used as actual argument in a function without
+ * prototype *)
+let pkEscape = 8 (* value may be assigned thru a pointer and
+ * escape to the heap *)
+let pkNotSafe = 9 (* constraint used by solvers: node must not be Safe *)
+
+let pkReferenced = 10 (* might be eventually referenced *)
+
+let pkRtti = 11
+
+let pkCompatWithScalars = 12
+ (* This flag means that a void* node (or its equivalence class) must be
+ * compatible with a scalar. Example:
+ * void *1 *2 v;
+ * int *3 x;
+ * v = x;
+ * In this case, node 1 should have this flag.
+ * (1) This flag is only valid on "void*" nodes. If a non-"void*" node
+ * has this flag, that node should be WILD by the end of solving.
+ * (2) This flag will always be present on the rep of a class if any node
+ * in that class has it.
+ * (3) If a node (or its rep) has this flag, then polymorphic_replace
+ * will return Int for the type of that node.
+ * (4) This flag is propagated whenever new reps are created.
+ *)
+
+(* Could point to the stack; CHECK_STORE_PTR and CHECK_RETURN needed.
+ * This is too conservative, since we flow this flag through globals and the
+ * heap, even though we know the checks will prevent that at runtime. But
+ * it's good enough for now. *)
+let pkStack = 13
+
+let pkOneWord = 14 (** Specified by user to be one word *)
+
+let pkFlagName = (* should match up with the order above *)
+ [| "Interface Node" ;
+ "Updated" ;
+ "Contains an Integer" ;
+ "Positive Arithmetic" ;
+ "Arithmetic" ;
+ "Reaches String" ;
+ "Reaches Index" ;
+ "No Prototype" ;
+ "Value Escapes to the Heap" ;
+ "Cannot be SAFE" ;
+ "Referenced";
+ "Has RTTI" ;
+ "Compatible with Scalars";
+ "Might Point To Stack";
+ "One Word" |]
+
+let pkNumberOfFlags = Array.length pkFlagName
+let pkLastFlag = pkNumberOfFlags - 1
+
+(* These are bitmasks of flags. *)
+let pkCastPredFlags = [pkUpdated ; pkPosArith ; pkArith ; pkEscape ;
+ pkReferenced]
+let pkCNIPredFlagsNoString = (* for ECast EEK_stringdrop *)
+ [pkReachIndex ; pkReferenced ]
+let pkCNIPredFlags = (* all ECasts except stringdrop *)
+ pkString :: pkCNIPredFlagsNoString
+let pkCastSuccFlagsNoString = (* for ECast EEK_stringdrop *)
+ [pkIntCast ; pkStack]
+let pkCastSuccFlags = (* all ECasts except stringdrop *)
+ pkString :: pkCastSuccFlagsNoString
+let pkOffsetSuccFlags = [pkEscape]
+let pkOffsetPredFlags = [pkReferenced]
+
+(* A list of all indices into the array *)
+let allFlags =
+ let rec allIndices (n: int) : int list =
+ if n > pkLastFlag then [] else n :: allIndices (n + 1)
+ in
+ allIndices 0
+
+let emptyFlags () = Array.make pkNumberOfFlags None
+
+(* set a boolean bitflag *)
+let setFlag n f why =
+ if n.flags.(f) = None then n.flags.(f) <- Some(why)
+(* check a boolean bitflag *)
+let hasFlag n f = n.flags.(f) <> None
+
+
+let canHaveRtti (t: typ) : bool = isVoidType t
+
+let allKinds =
+ [ Safe; Sentinel; Seq;
+ FSeq; SeqN; FSeqN;
+ String; UnknownN;
+ Unknown ]
+
+(* Just some code to check that we have added all pointer kinds to allKinds.
+ * If the compiler complains about an inexhaustive pattern then you have
+ * probalby added new pointer kinds. Add them to the pattern AND TO allKinds
+ * above. *)
+let _ =
+ List.iter
+ (function
+ | Safe | Sentinel
+ | String | UnknownN
+ | Seq | SeqN
+ | FSeq | FSeqN
+ | Unknown -> ())
+ allKinds
+
+(* Print the graph *)
+let d_place () = function
+ PGlob s -> dprintf "Glob(%s)" s
+ | PType s -> dprintf "Type(%s)" s
+ | PStatic (f, s) -> dprintf "Static(%s.%s)" f s
+ | PLocal (f, func, s) -> dprintf "Local(%s.%s.%s)" f func s
+ | POffset (nid, fld) -> dprintf "Offset(%d, %s)" nid fld
+ | PField(fi) -> dprintf "Field(%s.%s)" fi.fcomp.cname fi.fname
+ | PAnon id -> dprintf "Anon(%d)" id
+ | PStr -> text "Str"
+ | PWStr -> text "WStr"
+
+(* Print the place "nicely", in a human-readable format *)
+let d_place_nice () (p,i) = match p with
+ PGlob s -> dprintf "the global %s" s
+ | PType s -> dprintf "the type %s" s
+ | PStatic (f, s) -> dprintf "the static variable %s" s
+ | PLocal (f, func, s) -> dprintf "the local variable %s" s
+ | POffset (nid, fld) -> dprintf "the field %s of node %d" fld nid
+ | PField(fi) -> dprintf "the field %s" fi.fname
+ | PAnon id -> text "an unnamed location (often an inserted cast)"
+ | PStr -> text "global string literal node."
+ | PWStr -> text "global wide-string literal node."
+
+let d_placeidx () (p, idx) =
+ dprintf "%a.%d" d_place p idx
+
+let d_opointerkind () = function
+ Safe -> text "SAFE"
+ | Sentinel -> text "SNT"
+ | FSeq -> text "FSEQ"
+ | FSeqN -> text "FSEQN"
+ | UnknownN -> text "UNKNOWN_NT"
+ | String -> text "STRING"
+ | Seq -> text "SEQ"
+ | SeqN -> text "SEQN"
+ | Unknown -> text "UNKNOWN"
+
+let d_eekind () = function
+ EEK_cast -> nil
+ | EEK_stringdrop -> text "(ntdrop)"
+ | EEK_cxxOverride -> text "(cxx_override)"
+ | EEK_extends -> text "(extends)"
+ | EEK_mkptr -> text "(mkptr)"
+ | EEK_union -> text "(union)"
+ | EEK_rtti -> text "(rtti)"
+
+let d_ekind () = function
+ ECast eek -> text "Cast" ++ d_eekind () eek
+ | EOffset -> text "Offset"
+ | EIndex -> text "Index"
+ | ECompat(r) -> dprintf "Compat(%a)" d_chain r
+ | ESameKind EEK_trustedCast -> text "TCast"
+ | ESameKind EEK_taggedUnion -> text "Union"
+ | EPointsTo -> text "Points"
+ | EArgs -> text "Args"
+
+let d_whyflag (n: node) () = function
+ | ProgramSyntax(l) -> dprintf "Syntax at %a" d_loc l
+ | DownCast(n) -> dprintf "Downcast With Node %d" n.id
+ | SubtypeFailed(n) -> dprintf "Subtyping Failed With Node %d" n.id
+ | RequiredByEdge(e) -> dprintf "Required By %a Edge %d->%d"
+ d_ekind e.ekind e.efrom.id e.eto.id
+ | RequiredByPointerKind(o) -> dprintf "Required For %a Nodes"
+ d_opointerkind o
+ | RequiredByFlag(i) -> dprintf "Required By Flag [%s]"
+ pkFlagName.(i)
+ | FlagSpreadFromNode(near,r_near_this,orig) ->
+ dprintf "Spread from %d (%a). Transitive from %d"
+ near.id d_chain r_near_this orig.id
+ | FlUserSpec l -> text "User-specified at " ++ d_loc () l
+ | MayEscape l -> text "May escape this file at " ++ d_loc () l
+
+
+let ptrAttrCustom =
+ (* Define a hash table for printing the attributes *)
+ let ptrAttrCustomTable: (string, string * (attrparam list -> doc)) H.t =
+ let h: (string, string * (attrparam list -> doc)) H.t = H.create 31 in
+ let noArgs (al: attrparam list) : doc =
+ match al with
+ [] -> nil
+ | _ -> raise Not_found
+ in
+ let doArgs (al: attrparam list) : doc =
+ dprintf "(@[%a@])"
+ (docList (d_attrparam ())) al
+ in
+ let addSimple (n: string) =
+ H.add h n ("__" ^ String.uppercase n, noArgs)
+ in
+ List.iter addSimple
+ ["ronly"; "seq"; "fseq"; "seqn"; "fseqn" ];
+ H.add h "selector" ("__SELECTOR", doArgs);
+ H.add h "selectedwhen" ("__SELECTEDWHEN", doArgs);
+ H.add h "size" ("__SIZE", doArgs);
+ H.add h "count" ("__COUNT", doArgs);
+ h
+ in
+ fun ~(printnode: bool) (a: attribute) ->
+ match a with
+ Attr("_ptrnode", [AInt n]) ->
+ if printnode then
+ Some (dprintf "__NODE(%d)" n)
+ else begin
+ Some nil
+ end
+ | Attr("safe", []) ->
+ if printnode then Some (text "__SAFE") else Some nil
+ | Attr("discriminated_union", []) -> Some nil
+ | Attr("stack", []) -> Some (text "__STACK")
+ | Attr("trustedunion", []) -> Some (text "__TRUSTEDUNION")
+ | Attr("safeunion", []) -> Some (text "__SAFEUNION")
+ | Attr("heapify", []) -> Some (text "__HEAPIFY")
+ | Attr("nocure", []) -> Some (text "__NOCURE")
+ | Attr("nounroll",[]) -> Some (text "__NOUNROLL")
+ | Attr("noescape", []) -> Some (text "__NOESCAPE")
+ | Attr("ccuredvararg", [ASizeOf t]) -> Some (text "__CCUREDVARARG(" ++
+ d_type () t ++ text ")")
+ | Attr("ccuredformat", [AInt fidx]) -> Some (text "__CCUREDFORMAT(" ++
+ num fidx ++ text ")")
+ | Attr("override", [AStr s]) -> Some (text ("__OVERRIDE(\"" ^ s ^ "\")"))
+ | Attr("main_input", []) -> Some (text (""))
+ | Attr("metacomp", []) -> Some (text "")
+ | Attr("mergecomp", []) -> Some (text "")
+ | Attr("mdsize", _) -> Some (text "")
+ | Attr("annotated", _) -> Some (text "")
+ | Attr (n, args) -> begin
+ try
+ let n', args' = H.find ptrAttrCustomTable n in
+ Some (text n' ++ (args' args))
+ with Not_found -> None
+ end
+
+(* Now define a special way of printing the infer file *)
+class ccuredInferPrinterClass = object
+ inherit defaultCilPrinterClass as super
+
+ method pAttr (a: attribute) : doc * bool =
+ match ptrAttrCustom ~printnode:true a with
+ Some d -> d, false
+ | None -> super#pAttr a
+
+ (* We do not print some pragmas *)
+ method dGlobal (out: out_channel) (g: global) : unit =
+ match g with
+ | GPragma(Attr(n, _), _) ->
+ if hasPrefix "ccured" n || hasPrefix "cil" n then
+ if !printVerboseOutput then begin
+ fprint out 80 (text "// ");
+ super#dGlobal out g
+ end else
+ ()
+ else
+ ()
+
+ | GText t ->
+ if !printVerboseOutput || not (t = "//\n") then
+ super#dGlobal out g
+
+ | g -> super#dGlobal out g
+
+end
+let ccuredInferPrinter = new ccuredInferPrinterClass
+
+let d_type = printType ccuredInferPrinter
+
+let d_whykind (n: node) () = function
+ | BadCast e ->
+ dprintf "cast(%a(%d) <= %a(%d)) at %a"
+ d_type e.eto.btype e.eto.id d_type e.efrom.btype e.efrom.id
+ d_loc e.eloc
+ | BadSequenceCast e ->
+ dprintf "cast(%a(%d) <= %a(%d)) at %a (and cannot be sequence)"
+ d_type e.eto.btype e.eto.id d_type e.efrom.btype e.efrom.id
+ d_loc e.eloc
+ | Incompat (n1, why_n1_n2, n2) ->
+ dprintf "Incompat %d and %d (%a)"
+ n1.id n2.id d_chain why_n1_n2
+ | BoolFlag(i) -> dprintf "from_flag(%s)" pkFlagName.(i)
+ | PolyInt -> dprintf "void* equivalent to scalar"
+ | Default -> text "by_default"
+ | UserSpec -> text "user_spec"
+ | Unconstrained -> text "unconstrained"
+ | PrintfArg -> text "printf_arg"
+ | Special (s, l) -> text (s ^ " at ") ++ d_loc () l
+ | SpreadFromNode(near,r_near_this,orig) ->
+ dprintf "Spread from %d (%a). Transitive from %d\n"
+ near.id d_chain r_near_this orig.id
+
+let d_node () n =
+ num n.id
+ ++ text " : "
+ ++ (match n.rep with
+ None -> nil
+ | Some (nrep, _) -> dprintf "(rep is %d) " nrep.id)
+ ++ (if !emitGraphDetailLevel > 1 then d_placeidx () n.where else nil)
+ ++ (if !emitGraphDetailLevel > 1 then text " L=" ++ Cil.d_loc () n.loc else nil)
+ ++ line
+ ++ text " K=" ++ d_opointerkind () n.kind
+ ++ text "/" ++ (d_whykind n) () n.why_kind
+ ++ (if !emitGraphDetailLevel > 0 then text " T=" ++ d_type () n.btype else nil)
+ ++
+ (if !emitGraphDetailLevel > 0 &&
+ (Array.fold_left (fun acc elt -> acc || elt <> None) false n.flags)
+ then begin
+ line ++ text "Flags: "
+ ++ (align
+ ++ (docArray ~sep:(text "")
+ (fun i flag_opt -> match flag_opt with
+ (* Do not print the pkNotSafe flag. It is for internal
+ * use and in the case of polymorphic_void* we
+ * actuallly may make such nodes SAFE, creating
+ * confusion *)
+ | Some(why) when i <> pkNotSafe ->
+ dprintf "@![%s]: %a" pkFlagName.(i) (d_whyflag n) why
+ | _ -> nil
+ ) () n.flags)
+ ++ unalign ++ line)
+ end else begin
+ nil
+ end)
+ ++
+ (if !emitGraphDetailLevel > 1 then
+ line
+ ++ text " S="
+ ++ (align
+ ++ (docList ~sep:(chr ',' ++ break)
+ (fun e ->
+ num e.eto.id
+ ++ text ":"
+ ++ d_ekind () e.ekind
+ ++ text "@" ++ d_loc () e.eloc)
+ ()
+ n.succ)
+ ++ unalign)
+ ++ line
+ ++ text " P="
+ ++ (align
+ ++ (docList ~sep:(chr ',' ++ break)
+ (fun e ->
+ num e.efrom.id
+ ++ text ":"
+ ++ d_ekind () e.ekind)
+ ()
+ n.pred)
+ ++ unalign)
+ else nil)
+
+ ++ line
+
+let nodeOfAttrlist al =
+ let findnode n =
+ try Some (IH.find idNode n)
+ with Not_found -> E.s (E.bug "Cannot find node with id = %d\n" n)
+ in
+ match filterAttributes "_ptrnode" al with
+ [] -> None
+ | [Attr(_, [AInt n])] -> findnode n
+ | (Attr(_, [AInt n]) :: _) as filtered ->
+ ignore (E.warn "nodeOfAttrlist(%a)" d_attrlist filtered);
+ findnode n
+ | _ -> E.s (E.bug "nodeOfAttrlist")
+
+let nodeOfType (t: typ) : node option = nodeOfAttrlist (typeAttrs t)
+
+(* weimer: find the node that points to this one *)
+let nodeThatPointsTo (child : node) =
+ try
+ let e = List.find (fun e -> e.ekind = EPointsTo) child.pred in
+ Some e.efrom
+ with Not_found -> None
+
+let k2attr = function
+ Safe -> Attr("safe", [])
+ | Seq -> Attr("seq", [])
+ | FSeq -> Attr("fseq", [])
+ | SeqN -> Attr("seqn", [])
+ | FSeqN -> Attr("fseqn", [])
+ | String -> Attr("string", [])
+ | k -> E.s (E.unimp "k2attr:%a" d_opointerkind k)
+
+let nullterm_kind = 64
+let rec k2number = function
+ | Sentinel -> 0
+ | Safe -> 1
+ | Seq -> 2
+ | FSeq -> 3
+ | String -> 6
+ | SeqN -> nullterm_kind + k2number Seq
+ | FSeqN -> nullterm_kind + k2number FSeq
+ | k -> E.s (E.unimp "k2number:%a" d_opointerkind k)
+
+
+
+(* The inferred kind for this node. Optionally, do it only for inferrable
+ * nodes. *)
+let inferredKindOf ?(localOnly=false)
+ (allAttributes: attributes) : opointerkind * whykind =
+ let default =
+ if hasAttribute "nullterm" allAttributes then
+ UnknownN, Default
+ else
+ Unknown, Default
+ in
+ let rec loop al =
+ (* If there's no UserSpec kind, look at the node *)
+ match al with
+ Attr ("_ptrnode", [AInt n])::_ -> begin
+ let nd = IH.find idNode n in
+ (* If local only is set, then we look at the place for this node *)
+ if not localOnly ||
+ (match nd.where with
+ (PLocal _ | PAnon _), 1 -> true
+ | _ -> false) then
+ nd.kind, nd.why_kind
+ else
+ default
+ end
+ | _::rest -> loop rest
+ | [] -> (* No NODE() attribute *)
+ default
+ in
+ loop allAttributes
+
+
+(* The kind of this pointer. If there is no BND attribute,
+ defaults to inferredKind *)
+let kindOfAttrlist allAttributes: opointerkind * whykind =
+ let isNullterm = hasAttribute "nullterm" allAttributes in
+ let rec loop al =
+ match al with
+ Attr("bounds", [a1;a2])::rest -> begin
+ match Dattrs.checkParam a1, Dattrs.checkParam a2 with
+ | Dattrs.PKThis, Dattrs.PKThis ->
+ if isNullterm then
+ String, UserSpec
+ else
+ (* Sentinel, UserSpec *)
+ inferredKindOf allAttributes
+ | Dattrs.PKThis, Dattrs.PKOffset (AInt 1) -> (* SAFE -> SAFE*)
+ (if isNullterm then FSeqN else Safe),
+ UserSpec
+ | Dattrs.PKThis, Dattrs.PKOffset a -> (* COUNT -> FSEQ *)
+ (if isNullterm then FSeqN else FSeq),
+ UserSpec
+ | _ -> (* BND -> SEQ *)
+ (if isNullterm then SeqN else Seq),
+ UserSpec
+ end
+ | Attr("size", _)::rest ->
+ (if isNullterm then FSeqN else FSeq),
+ UserSpec
+ | _::rest -> loop rest
+ | [] -> (* No BND annotation *)
+ inferredKindOf allAttributes
+ in
+ loop allAttributes
+
+let kindIsNullterm (k:opointerkind) : bool =
+ match k with
+ | Safe | Sentinel | Seq | FSeq | Unknown -> false
+ | String | SeqN | FSeqN | UnknownN -> true
+
+let kindNeedsBounds (k:opointerkind) : bool =
+ match k with
+ | Safe | Sentinel | String | Unknown | UnknownN -> false
+ | Seq | FSeq | SeqN | FSeqN -> true
+
+
+
+(* Replace the ptrnode attribute with the actual qualifier attribute *)
+type whichAttr =
+ AtPtr (* In a pointer type *)
+ | AtArray (* In an array type *)
+ | AtOpenArray (* In an array type without a size *)
+ | AtVar (* For a variable *)
+ | AtOther (* Anything else *)
+
+
+let replacePtrNodeAttrList ~(which:whichAttr) al =
+(* ignore (E.log "replacePtrNode: %a\n"
+ (d_attrlist true) al); *)
+ let foundKind : string ref = ref "" in
+ let foundInNode : bool ref = ref false in
+ let foundAnother (innode: bool) (s: string) =
+ if innode then begin
+ foundInNode := true;
+ foundKind := s (* Discard all others *)
+ end else
+ (* Look at non-node ones only if we haven't found a node *)
+ if not !foundInNode then foundKind := s
+ in
+ (* Scan the attributes and look at pointer kind attributes and at node
+ * attributes. Remove all pointer-kind attributes and set foundKind and
+ * foundInNode if it was found in a node. *)
+ let rec loop = function
+ [] -> []
+ | a :: al -> begin
+ match a with
+ Attr("_ptrnode", [AInt n]) -> begin
+ try
+ let nd = IH.find idNode n in
+ let found =
+ if nd.kind = Unknown then begin
+ ignore (E.warn "Found node %d with kind Unknown\n" n);
+ ""
+ end else
+ match k2attr nd.kind with
+ Attr(s, _) -> s
+ in
+ foundAnother true found;
+ a :: loop al
+ with Not_found -> begin
+ ignore (E.warn "Cannot find node %d\n" n);
+ a :: loop al
+ end
+ end
+ | Attr("safe", []) -> foundAnother false "safe"; loop al
+ | Attr("seq", []) -> foundAnother false "seq"; loop al
+ | Attr("fseq", []) ->
+ foundAnother false (if !useFSEQ then "fseq" else "seq"); loop al
+ | Attr("seqn", []) ->
+ foundAnother false (if !useStrings then "seqn" else "seq"); loop al
+ | Attr("fseqn", []) ->
+ foundAnother false
+ (if !useFSEQ then
+ (if !useStrings then "fseqn" else "fseq")
+ else (if !useStrings then "seqn" else "seq")); loop al
+ | Attr("string", []) when !useStrings ->
+ foundAnother false "string"; loop al
+ | Attr("rostring", []) when !useStrings ->
+ foundAnother false "rostring"; loop al
+ | _ -> a :: loop al
+ end
+ in
+ let al' = loop al in (* Get the filtered attributes *)
+ let kres =
+ match which with
+ AtPtr ->
+ if !foundKind <> "" then !foundKind
+ else if !defaultIsWild then "wild" else "safe"
+ | (AtArray | AtOpenArray) ->
+ if !foundKind = "seqn" then "nullterm"
+ else if !foundKind = "fseqn" then "nullterm"
+ else if !foundKind = "string" then "nullterm"
+ else if !foundKind = "rostring" then "nullterm"
+ else !foundKind
+ | (AtVar | AtOther) -> !foundKind
+ in
+ if kres <> "" then
+ addAttribute (Attr(kres,[])) al'
+ else
+ al'
+
+let nodeExists (p: place) (idx: int) =
+ H.mem placeId (p, idx)
+
+let existsEdge ~(start : node) ~(dest : node) ~(kind : edgekind) =
+ List.fold_left (fun acc e -> acc ||
+ (e.eto.id = dest.id && e.ekind = kind)) false start.succ
+
+let isECompat e =
+ match e.ekind with
+ ECompat _ -> true
+ | _ -> false
+
+let isECast e =
+ match e.ekind with
+ ECast _ -> true
+ | _ -> false
+
+let isESameKind e =
+ match e.ekind with
+ ESameKind _ -> true
+ | _ -> false
+
+let lastEdgeIdx = ref 0 (* 0 is reserved for the union edge *)
+let addEdge ~(start: node) ~(dest: node) ~(kind: edgekind)
+ ~(eloc : Cil.location option) =
+
+ incr lastEdgeIdx;
+ let nedge =
+ { eid = !lastEdgeIdx;
+ efrom = start; eto= dest; ekind = kind;
+ eloc = match eloc with
+ Some(loc) -> loc
+ | None -> !currentLoc } in
+ start.succ <- nedge :: start.succ;
+ dest.pred <- nedge :: dest.pred ;
+ nedge
+
+let removeSucc n sid =
+ n.succ <- List.filter (fun e -> e.eto.id <> sid) n.succ
+
+let removePred n pid =
+ n.pred <- List.filter (fun e -> e.efrom.id <> pid) n.pred
+
+(* Delete an edge from the graph *)
+let removeEdge e =
+ if not (List.memq e e.efrom.succ) then
+ E.s (bug "edge not in e.efrom.succ");
+ if not (List.memq e e.eto.pred) then
+ E.s (bug "edge not in e.eto.pred");
+ e.efrom.succ <- List.filter ((!=) e) e.efrom.succ;
+ e.eto.pred <- List.filter ((!=) e) e.eto.pred
+
+(** Set the EPointsTo edges for a node. *)
+let setNodePointsTo (n: node) =
+ let doOneType = function
+ (* This will add points to to pointers embedded in structures or in
+ * functions (function return or arguments) *)
+ TPtr (bt, a) -> begin
+ (match nodeOfAttrlist a with
+ | Some n' -> ignore (addEdge n n' EPointsTo (Some n.loc))
+ | _ -> (*
+ ignore
+ (warn "Node %d points to a pointer of type %a without a node"
+ n.id d_type bt); *)
+ ());
+ ExistsFalse
+ end
+ | _ -> ExistsMaybe
+ in
+ ignore (existsType doOneType n.btype);
+
+
+ (* If a structure contains an array, a pointer to that structure also
+ * contains a pointer to the array. We need this information to
+ * properly handle wild pointers. *)
+ let lookForInternalArrays = function
+ TArray(bt,len,al) -> begin
+ (match nodeOfAttrlist al with
+ | Some n' -> ignore (addEdge n n' EPointsTo (Some !currentLoc))
+ | _ -> ());
+ ExistsFalse
+ end
+
+ | _ -> ExistsMaybe
+ in
+ ignore (existsType lookForInternalArrays n.btype)
+
+(* Make a new node *)
+let newNode ~(p: place) ~(idx: int) ~(bt: typ) ~(al: attributes) : node =
+ let where = p, idx in
+ incr lastNodeId;
+ (* Maybe it has a kind specified by the user *)
+ let kind,why_kind = kindOfAttrlist al in
+ let shouldInfer = match p with
+ PLocal _ | PAnon _ -> true
+ | _ -> false
+ in
+(* if !lastNodeId = 1 then
+ ignore (E.log "newNode: %a\n" d_opointerkind kind); *)
+(* E.log "%a: new node %d has attrs %a, kind %a\n" d_loc !currentLoc *)
+(* !lastNodeId d_attrlist al d_opointerkind kind; *)
+ let n = { id = !lastNodeId;
+ btype = bt;
+ attr = addAttribute (Attr("_ptrnode", [AInt !lastNodeId])) al;
+ is_array = false;
+ where = where;
+ flags = emptyFlags () ;
+ locked = false;
+ succ = [];
+ kind = kind;
+ why_kind = why_kind;
+ sized = false ;
+ mark = false;
+ pred = [];
+ rep = None;
+ loc = !Cil.currentLoc;
+ shouldInfer = shouldInfer; }
+ in
+ if hasAttribute "noescape" al then
+ setFlag n pkStack (FlUserSpec !Cil.currentLoc);
+ if separateCompilation && not shouldInfer then
+ (* Not a local or cast. Therefore, assume it's referenced somewhere. *)
+ setFlag n pkReferenced (MayEscape !Cil.currentLoc);
+
+(* ignore (E.log "Created new node(%d) at %a\n" n.id d_placeidx where); *)
+ H.add placeId where n;
+ IH.add idNode n.id n;
+ (* We do not yet set the EPointsTo edges because we might have forward
+ * references. But once we have created all the nodes, we should call the
+ * setNodePointsTo *)
+ setNodePointsTo n;
+ n
+
+
+(** Dummy node is a node with the ID=0 *)
+let dummyNode = newNode (PGlob "@dummy") 0 voidType []
+
+
+(* Get a node for a place and an index. Give also the base type and the
+ * attributes *)
+let getNode ~(p: place) ~(idx: int) ~(bt: typ) ~(al: attributes) : node =
+ (* See if exists already *)
+ let where = (p, idx) in
+ try
+ H.find placeId where
+ with Not_found -> newNode p idx bt al
+
+
+ (** Check that a node points to another node *)
+let rec checkPointsTo (seen: int list) (* To prevent recursion *)
+ (nstart: node)
+ (nend_id: int) : bool =
+ (* Scan all EPoints successors of nstart *)
+ if nstart.id = nend_id then true
+ else begin
+ if List.exists (fun s -> s = nstart.id) seen then begin
+ ignore (E.log "checkPointsTo: circularity at %d\n" nstart.id);
+ false
+ end else begin
+ let seen' = nstart.id :: seen in
+ List.exists (fun e ->
+ e.ekind = EPointsTo &&
+ checkPointsTo seen' e.eto nend_id) nstart.succ
+ end
+ end
+
+
+ (* Check that a node does not occur twice in a chain. We use
+ * this function to debug circular chains *)
+let rec checkChain
+ (start: node) (* The node that we think the edge should
+ * be starting from *)
+ (r: chain) : node * int list =
+ if not (keepDetails ()) then
+ E.s (bug "checkChains but not keeping details");
+ let edges = chainToList r in
+ let rec loop (start: node) (* The next expected node *)
+ (seen: int list) (* Nodes we've seen already *) = function
+ [] -> start, seen
+ | (sym, e) :: rest ->
+ (* Orient the edge appropriately *)
+ let estart, eend = if sym then e.eto, e.efrom else e.efrom, e.eto in
+ (* Check that we start at the right points. estart must be pointing to
+ * start or viceversa *)
+ if start.id <> 0 &&
+ not (checkPointsTo [] start estart.id) &&
+ not (checkPointsTo [] estart start.id) then begin
+ ignore (E.warn
+ "Disconnected chain: start=%d, edge %d->%d\n seen = %a\n"
+ start.id e.efrom.id e.eto.id
+ (docList num) (List.rev seen));
+ raise (Failure "bad chain: disconnected")
+ end;
+ (* Complain if we've seen eend.id already *)
+ if List.exists (fun s -> s = eend.id) seen then begin
+ ignore (E.warn
+ "Circular chain: start=%d, edge %d->%d\n seen = %a\n"
+ start.id e.efrom.id e.eto.id
+ (docList num) (List.rev seen));
+ raise (Failure "bad chain: circular")
+ end;
+ loop eend (eend.id :: (if start.id = 0 then [estart.id] else seen))
+ rest
+ in
+ loop start [] edges
+
+let checkChainEnds (nstart: node) (nend: node) (r: chain) : unit =
+ try
+ let end', seen' = checkChain nstart r in
+ if not (checkPointsTo [] end' nend.id) &&
+ not (checkPointsTo [] nend end'.id) then begin
+ ignore (E.warn "checkChainEnds. Ends at %d and expected %d\n"
+ end'.id nend.id);
+ raise (Failure "bad chain: misoriented edge")
+ end
+ with e -> begin
+ ignore (E.log "Failed the check that chain starts at %d and ends at %d\n"
+ nstart.id nend.id);
+ ();
+ end
+
+
+(* Override mkRTrans to do some checking *)
+let mkRTrans (r1: chain) (r2: chain) =
+ let res = mkRTransChain r1 r2 in
+ if doCheckChains && res != r1 && res != r2 then begin
+ try
+ ignore (checkChain dummyNode res);
+ with e -> begin
+ ignore (E.warn "Trying to mkRTrans of");
+ dumpChain r1;
+ ignore (E.log " and \n");
+ dumpChain r2;
+ raise e
+ end
+ end;
+ res
+
+
+
+
+(* Given a flag for a node, produce the original node where the flag
+ * originates, the true chain why it originates, and the chain:orig->this *)
+let rec trueSourceOfFlag (n: node) (f:int) : node * whyflag * chain =
+ match n.flags.(f) with
+ | Some(FlagSpreadFromNode(near,r_near_n,source)) when near.id <> n.id ->
+ let orig, why, r_orig_near = trueSourceOfFlag near f in
+ orig, why, mkRTrans r_orig_near r_near_n
+ | Some w -> n, w, mkRIdent
+ | None -> E.s (bug "trueSourceOfFlag(%d, %d)" n.id f)
+
+
+
+
+(* obtain the representative of this equivalence class. Also return the
+ * reaons n -> representative *)
+let rec get_rep_why (n: node) : node * chain =
+ match n.rep with
+ Some(nr,why_n_nr) ->
+ let final_result, why_nr_final_result = get_rep_why nr in
+ if final_result == nr then
+ nr, why_n_nr
+ else begin
+ (* Do path compression *)
+ let why_n_final_result = mkRTrans why_n_nr why_nr_final_result in
+ if not (hasFlag n pkRtti) then begin
+ (if hasFlag n pkCompatWithScalars then
+ let orig,_,_ = trueSourceOfFlag n pkCompatWithScalars in
+ setFlag final_result pkCompatWithScalars
+ (FlagSpreadFromNode(n,why_n_final_result,orig)));
+ n.rep <- Some(final_result, why_n_final_result) ;
+ end ;
+ final_result, why_n_final_result
+ end
+ | None -> n, mkRIdent
+
+let rec get_rep n = fst (get_rep_why n)
+
+let rec join n1 n2 (why_n1_n2: chain) (* The chain goes n1 -> n2 *) =
+ (if doCheckChains then checkChainEnds n1 n2 why_n1_n2);
+ let n1r, why_n1_n1r = get_rep_why n1 in
+ let n2r, why_n2_n2r = get_rep_why n2 in
+ if n1r.id = n2r.id then begin
+ () (* only join if they are distinct *)
+ end else begin
+ if isVoidType n1r.btype then begin (* n2r becomes the new rep *)
+ if not (hasFlag n1r pkRtti) then begin
+ (* chain: n1r -> n1 -> n2 -> n2r *)
+ let why_n1r_n2r =
+ mkRTrans (mkRSym why_n1_n1r) (mkRTrans why_n1_n2 why_n2_n2r)
+ in
+ n1r.rep <- Some(n2r, why_n1r_n2r);
+ if hasFlag n1r pkCompatWithScalars then begin
+ let res,_,_ = trueSourceOfFlag n1r pkCompatWithScalars in
+ setFlag n2r pkCompatWithScalars
+ (FlagSpreadFromNode(n1r, why_n1r_n2r, res))
+ end
+ end
+ end else if isVoidType n2r.btype then begin (* n1r becomes the new rep *)
+ if not (hasFlag n2r pkRtti) then begin
+ let why_n2r_n1r =
+ mkRTrans (mkRSym why_n2_n2r) (mkRTrans (mkRSym why_n1_n2) why_n1_n1r)
+ in
+ n2r.rep <- Some(n1r, why_n2r_n1r);
+ if hasFlag n2r pkCompatWithScalars then
+ let res,_,_ = trueSourceOfFlag n2r pkCompatWithScalars in
+ setFlag n1r pkCompatWithScalars
+ (FlagSpreadFromNode(n2r, why_n2r_n1r, res))
+ end
+ end else
+ (* Do not join nodes whose representatives are not void-ptr *)
+ ()
+ end
+(*
+ ignore (E.warn "join %d(%b) %d(%b) -> %d(%b)"
+ n1.id (hasFlag n1 pkCompatWithScalars)
+ n2.id (hasFlag n2 pkCompatWithScalars)
+ (get_rep n1).id (hasFlag (get_rep n1) pkCompatWithScalars)
+ ) *)
+
+(* Given a kind for a node, produce the original node where the kind
+ * originates, the true chain why it originates, and the chain:orig->this *)
+let rec trueSourceOfKind (n: node) : node * whykind * chain =
+ match n.why_kind with
+ | SpreadFromNode(near,r_near_n,source) ->
+ let orig, why, r_orig_near = trueSourceOfKind near in
+ orig, why, mkRTrans r_orig_near r_near_n
+ | w -> n, w, mkRIdent
+
+
+(* Type names, computed in such a way that compatible types have the same id,
+ * even if they are syntactically different. Right now we flatten structures
+ * but we do not pull common subcomponents out of unions and we do not unroll
+ * arrays. *)
+
+
+(* Some structs (those involved in recursive types) are named. This hash maps
+ * their name to the ID *)
+let namedStructs : (string, string) H.t = H.create 110
+
+
+(* Keep track of the structs in which we are (to detect loops). When we
+ * detect a loop we remember that *)
+let inStruct : (string, bool ref) H.t = H.create 110
+
+
+let rec typeIdentifier (t: typ) : string =
+ let res = typeId t in
+ H.clear inStruct; (* Start afresh next time *)
+ res
+
+and typeId = function
+ TInt(ik, a) -> ikId ik ^ attrsId a
+ | TVoid a -> "V" ^ attrsId a
+ | TFloat (fk, a) -> fkId fk ^ attrsId a
+ | TEnum _ -> ikId IInt (* !!! *)
+ | TNamed (t, a) -> typeId (typeAddAttributes a t.ttype)
+ | TComp (comp, a) when comp.cstruct -> begin
+ (* See if we are in a loop *)
+ try
+ let inloop = H.find inStruct comp.cname in
+ inloop := true; (* Part of a recursive type *)
+ "t" ^ prependLength comp.cname (* ^ attrsId comp.cattr *)
+ with Not_found ->
+ let inloop = ref false in
+ let isanon = hasPrefix "__anon" comp.cname in
+ if not isanon then H.add inStruct comp.cname inloop;
+ let fieldsids =
+ List.fold_left (fun acc f -> acc ^ typeId f.ftype) "" comp.cfields in
+ (* If it is in a loop then keep its name *)
+ let res = fieldsids (* ^ attrsId comp.cattr *) in
+ if not isanon then H.remove inStruct comp.cname;
+ if !inloop && not (H.mem namedStructs comp.cname) then begin
+ H.add namedStructs comp.cname res;
+ "t" ^ prependLength comp.cname (* ^ attrsId comp.cattr *)
+ end else
+ res
+ end
+ | TComp (comp, a) when not comp.cstruct ->
+ "N" ^ (string_of_int (List.length comp.cfields)) ^
+ (List.fold_left (fun acc f -> acc ^ typeId f.ftype ^ "n")
+ "" comp.cfields) ^
+ attrsId (addAttributes comp.cattr a)
+ | TPtr (t, a) -> "P" ^ typeId t ^ "p" ^ attrsId a
+ | TArray (t, lo, a) ->
+ let thelen = "len" in
+ "A" ^ typeId t ^ "a" ^ prependLength thelen ^ attrsId a
+ | TFun (tres, args, va, a) ->
+ "F" ^ typeId tres ^ "f" ^
+ (string_of_int (List.length (argsToList args))) ^
+ (List.fold_left (fun acc (_, at, _) -> acc ^ typeId at ^ "f")
+ "" (argsToList args)) ^ (if va then "V" else "v") ^ attrsId a
+ | _ -> E.s (E.bug "typeId")
+
+and ikId = function
+ IChar -> "C"
+ | ISChar -> "c"
+ | IUChar -> "b"
+ | IInt -> "I"
+ | IUInt -> "U"
+ | IShort -> "S"
+ | IUShort -> "s"
+ | ILong -> "L"
+ | IULong -> "l"
+ | ILongLong -> "W"
+ | IULongLong -> "w"
+
+and fkId = function
+ FFloat -> "O"
+ | FDouble -> "D"
+ | FLongDouble -> "T"
+
+and prependLength s =
+ let l = String.length s in
+ if s = "" || (s >= "0" && s <= "9") then
+ E.s (E.unimp "String %s starts with a digit\n" s);
+ string_of_int l ^ s
+
+and attrsId al =
+ match al with
+ [] -> "_"
+ | _ -> "r" ^ List.fold_left (fun acc (Attr(an,_)) -> acc ^ an) "" al ^ "r"
+
+
+
+(************ Print statistics about the graph ******************)
+let addToHisto (histo: ('a, int ref) H.t) (much: int) (which: 'a) : unit =
+ let r = Util.findOrAdd histo which (fun _ -> ref 0) in
+ r := !r + much
+
+let getHisto (histo: ('a, int ref) H.t) (which: 'a) : int =
+ try let r = H.find histo which in !r with Not_found -> 0
+
+let sortHisto (histo: ('a, int ref) H.t) : ('a * int) list =
+ let theList : ('a * int) list ref = ref [] in
+ H.iter (fun k r -> theList := (k, !r) :: !theList) histo;
+ List.sort (fun (_,v1) (_,v2) -> - (compare v1 v2)) !theList
+
+let showFirst (showone: 'a -> int -> unit)
+ (many: int) (lst: ('a * int) list) =
+ let rec loop i = function
+ (n, s) :: rest when i >= 0 && s > 0 ->
+ showone n s;
+ loop (i - 1) rest
+ | _ -> ()
+ in
+ loop many lst
+
+(*** Statistics ***)
+
+
+type incompat = node * chain * node
+
+type incompatClass =
+ {
+ icId: int;
+ mutable icCompats: incompat list; (* A list of incompats in this class *)
+ mutable icNodes: (int, node * int ref) H.t; (* A hashtable indexed by
+ * node id; for each node also keep a count
+ * of how many incompats it is part of *)
+ }
+
+
+(* Create a list of equivalence classes *)
+let incompatEquivalence: (node * (node * edge) list) list ref = ref []
+let nrIncompatClasses = ref 0
+let nrIncompatCasts = ref 0
+
+let reportIncompats (incompats: (int * int, incompat) H.t) =
+ incompatEquivalence := [];
+ nrIncompatClasses := 0;
+ nrIncompatCasts := 0;
+ let debugIncompat = false in
+ let icLastId = ref (-1) in (* A counter for incompat classes *)
+ (* Scan all incompats and construct the list of equivalence classes *)
+ let nodeClass: (int, incompatClass) H.t = H.create 11 in
+ let allClasses: (int, incompatClass) H.t = H.create 11 in
+ H.iter (fun _ ((n1, why_n1_n2, n2) as inc) ->
+ let c = chainToList why_n1_n2 in
+ if debugIncompat then
+ ignore (E.log "Processing incompat %d and %d\n" n1.id n2.id);
+ let theReprClass =
+ (* Scan first and find out the equivalence classes in which this chain
+ * should go (indexed by class id). This could be empty if all nodes
+ * are new. *)
+ let classes: (int, incompatClass) H.t = H.create 7 in
+ let markClassNode (n: node) =
+ (* Omit the extreme nodes *)
+ if n.id <> n1.id && n.id <> n2.id then begin
+ try
+ let cls = H.find nodeClass n.id in
+ ignore (Util.findOrAdd classes cls.icId (fun _ -> cls))
+ with Not_found ->
+ ()
+ end
+ in
+ List.iter
+ (fun (_, e) ->
+ markClassNode e.efrom; markClassNode e.eto) c;
+ let theRepr = ref None in
+ (* Now we must union all the classes *)
+ H.iter (fun _ cls ->
+ if debugIncompat then
+ ignore (E.log " already in class %d\n" cls.icId);
+ match !theRepr with
+ None -> theRepr := Some cls
+ | Some cls' ->
+ (**** UNION ****)
+ if debugIncompat then
+ ignore (E.log " unioning class %d to %d\n" cls.icId cls'.icId);
+ cls'.icCompats <- cls'.icCompats @ cls.icCompats;
+ H.remove allClasses cls.icId;
+ H.iter
+ (fun nid (nd, pCount) ->
+ let _, pCount' =
+ Util.findOrAdd cls'.icNodes nid (fun _ -> (nd, ref 0)) in
+ H.replace nodeClass nid cls';
+ pCount' := !pCount' + !pCount)
+ cls.icNodes)
+ classes;
+ (* Maybe we need to create a new class *)
+ (match !theRepr with
+ None ->
+ incr icLastId;
+ if debugIncompat then
+ ignore (E.log "create a new class %d\n" !icLastId);
+ let cls =
+ { icId = !icLastId; icCompats = []; icNodes = H.create 5 } in
+ H.add allClasses !icLastId cls;
+ cls
+
+ | Some cls -> cls)
+ in
+ if debugIncompat then
+ ignore (E.log "Found the representative class %d\n" theReprClass.icId);
+ (* Now add this chain to the class *)
+ theReprClass.icCompats <- inc :: theReprClass.icCompats;
+ let addIncToNode (n: node) =
+ if n.id <> n1.id && n.id <> n2.id then begin
+ H.replace nodeClass n.id theReprClass;
+ let _, pCount =
+ Util.findOrAdd theReprClass.icNodes n.id (fun _ -> (n, ref 0)) in
+ incr pCount
+ end
+ in
+
+ List.iter (fun (_, e) -> addIncToNode e.efrom; addIncToNode e.eto) c;
+
+ ) incompats;
+ if debugIncompat then
+ ignore (E.log "printing classes\n");
+ (* Now we have a list of classes of incompats *)
+ H.iter
+ (fun _ cls ->
+ (* Find the node with maximum count, and which is not Anon *)
+ incr nrIncompatClasses;
+ let maxNode = ref None in
+ let maxCount = ref 0 in
+ H.iter (fun nid (nd, pCount) ->
+ if !pCount > !maxCount
+ && (match nd.where with PAnon _, _ -> false | _ -> true) then begin
+ maxNode := Some nd;
+ maxCount := !pCount
+ end) cls.icNodes;
+ let reprNode =
+ match !maxNode with
+ None -> dummyNode
+ | Some nd -> nd
+ in
+ (* Now for each incompat we collect the extreme nodes along with the
+ * extreme edges *)
+ let extremes: (int * int, node * edge) H.t = H.create 7 in
+ List.iter
+ (fun (n1, why_n1_n2, n2) ->
+ let c = chainToList why_n1_n2 in
+ if List.length c = 0 then begin
+ if keepDetails() then
+ ignore (E.warn "Chain for incompat %d and %d is empty"
+ n1.id n2.id)
+ end else begin
+ let _, e1 = List.nth c 0 in
+ let _, e2 = List.nth (List.rev c) 0 in
+ ignore (Util.findOrAdd extremes (n1.id, e1.eid)
+ (fun _ -> (n1, e1)));
+ ignore (Util.findOrAdd extremes (n2.id, e2.eid)
+ (fun _ -> (n2, e2)))
+ end)
+ cls.icCompats;
+ (* Now print them *)
+ let extremesList = ref [] in
+ H.iter
+ (fun _ (n, e) ->
+ incr nrIncompatCasts;
+ extremesList := (n, e) :: !extremesList)
+ extremes;
+ incompatEquivalence :=
+ (reprNode, !extremesList) :: !incompatEquivalence;)
+ allClasses;
+ if !nrIncompatClasses > 0 && not (keepDetails()) then begin
+ ignore (E.warn "Cannot print details for the equivalence classes because you turned off the generation of the browser info")
+ end
+
+
+let printGraphStats () =
+ (* Keep a histograph per kind *)
+ if !isSubtype == origSubtype then
+ E.s (bug "printGraphStats: isSubtype is not set\n");
+ let totKind : (opointerkind, int ref) H.t = H.create 17 in
+ let totalNodes = ref 0 in
+ let unusedNodes = ref 0 in
+ let voidStarNodes = ref 0 in
+ let splitNodes = ref 0 in
+ let metaPtrNodes = ref 0 in
+ (* The number of bad casts *)
+ let badCastsCount = ref 0 in
+ let downCastCount = ref 0 in
+ (* All the incompats *)
+ let incompats: (int * int, node * chain * node) H.t = H.create 113 in
+ (* A list of the edges involved in bad casts, and whether or not each is
+ * a sequence cast. Will be sorted and printed *)
+ let badCastsList: (edge * bool) list ref = ref [] in
+ (* Index the bad casts by location because one bad bad cast can be counted
+ * many times (if it is in a macro). Use a separate hashtable,
+ * rather than badCastsList, for performance. *)
+ (* let badCastsLoc: (location, unit) H.t = H.create 113 in *)
+ let badCastsVoid = ref 0 in
+ let badCastsFPtr = ref 0 in
+ (* Keep track of spread_from_edge. For each node how many other nodes have
+ * WILD/spread_from_edge(n). *)
+ let spreadTo : (int, int ref) H.t = H.create 117 in
+ let examine_node id n =
+ incr totalNodes;
+ (match unrollType n.btype with
+ TVoid _ -> incr voidStarNodes
+ | _ -> ());
+ (* See if it is not-used. We check that it does not have ECompat, ECast
+ * or ESameKind edges *)
+ if n.kind = Safe then begin
+ let isUsedEdge e =
+ match e.ekind with
+ ECast _ | ECompat _ | ESameKind _ -> true
+ | _ -> false
+ in
+ if not (List.exists isUsedEdge n.succ ||
+ List.exists isUsedEdge n.pred) then
+ incr unusedNodes;
+ end;
+ addToHisto totKind 1 n.kind;
+ in
+ IH.iter examine_node idNode;
+ badCastsList := List.sort
+ (fun (e1, _) (e2, _) -> compareLoc e1.eloc e2.eloc)
+ !badCastsList;
+ List.iter
+ (fun (e, isseq) ->
+ incr badCastsCount;
+ ignore (E.log "** %d: Bad cast %sat %a (%a *%d ->%a *%d)\n"
+ !badCastsCount
+ (if isseq then "(seq) " else "")
+ d_loc e.eloc d_type e.efrom.btype e.efrom.id
+ d_type e.eto.btype e.eto.id))
+ !badCastsList;
+ (* sm: prepend string 'ptrkinds:' so I can easily grep for this info *)
+ ignore (E.log "ptrkinds: Graph contains %d nodes (%d are used)\n"
+ !totalNodes (!totalNodes - !unusedNodes));
+ (* Now subtract the unused ones *)
+ totalNodes := !totalNodes - !unusedNodes;
+ (try
+ let rsafe = H.find totKind Safe in
+ rsafe := !rsafe - !unusedNodes
+ with Not_found -> ());
+ let percent (n: int) : float =
+ if !totalNodes = 0 then begin
+ if n <> 0 then
+ ignore (E.warn "Ptrnode.percent: divide by 0");
+ 100.0
+ end else
+ (float_of_int n)
+ /. float_of_int (!totalNodes) *. 100.0
+ in
+ H.iter
+ (fun k r -> ignore (E.log "ptrkinds: %a - %d (%3.0f%%)\n"
+ d_opointerkind k !r (percent !r)))
+ totKind;
+ ignore (E.log "%d pointers are void*\n" !voidStarNodes);
+ ignore (E.log "%d bad casts of which %d involved void* and %d involved function pointers\n"
+ !badCastsCount !badCastsVoid !badCastsFPtr);
+ if !badCastsCount = 0 then
+ ignore (E.log "No bad casts, so no downcasts\n")
+ else begin
+ ignore (E.log "%d (%d%%) of the bad casts are downcasts\n"
+ !downCastCount (100 * !downCastCount / !badCastsCount));
+ end ;
+ ignore (E.log "%d (%d%%) of the nodes are split\n"
+ !splitNodes (int_of_float (percent !splitNodes)));
+ ignore (E.log "%d (%d%%) of the nodes are have a metadata pointer\n"
+ !metaPtrNodes (int_of_float (percent !metaPtrNodes)));
+ reportIncompats incompats;
+ let incompatCount = ref 0 in
+ List.iter
+ (fun (n, extremes) ->
+ let nrExtremes = List.length extremes in
+ if nrExtremes > 0 then begin
+ ignore (E.log "%d incompatible types flow into node %a *%d\n"
+ nrExtremes
+ d_type n.btype n.id);
+ List.iter
+ (fun (n, e) ->
+ incr incompatCount;
+ ignore (E.log " Type %a *%d at %a\n"
+ d_type n.btype n.id d_loc e.eloc)) extremes
+ end)
+ !incompatEquivalence;
+ ignore (E.log "%d incompatible equivalence classes\n" !incompatCount);
+ H.clear totKind;
+ H.clear spreadTo;
+ ()
+
+
+
+
+let printInferGraph (c: out_channel) =
+ output_string c "#if 0\n/* Now the graph */\n";
+ output_string c "/* Now the solved graph (simplesolve) */\n";
+
+ (* Get the nodes ordered by ID *)
+ let allsorted =
+ Stats.time "sortgraph"
+ (fun () ->
+ let all : node list ref = ref [] in
+ IH.iter (fun id n -> all := n :: !all) idNode;
+ List.sort (fun n1 n2 -> compare n1.id n2.id) !all) ()
+ in
+ Stats.time "printnodes"
+ (List.iter (fun n -> (
+ fprint c 80 (d_node () n)
+ )))
+ allsorted;
+ output_string c "/* End of solved graph*/\n#endif\n";
+ ()
+
+
+let printInfer (f: string) (file: Cil.file) =
+ begin
+ let c =
+ try open_out f (* Might throw an exception *)
+ with e -> E.s (E.error "Cannot open infer output file %s" f)
+ in
+ Util.tryFinally
+ (fun _ ->
+ dumpFile ccuredInferPrinter c f file;
+ Stats.time "printgraph" printInferGraph c)
+ (fun _ ->
+ close_out c)
+ ()
+ end
+
+let initialize () =
+ H.clear placeId;
+ IH.clear idNode;
+ H.clear namedStructs;
+ H.clear inStruct;
+ lastEdgeIdx := 0;
+ lastNodeId := 0; (* We reserve the ID=0 to the dummyNode *)
+ if dummyNode.id <> 0 then
+ E.s (E.bug "Ptrnode:dummyNode does not have ID=0");
+ (* And add the dummyNode in the graph *)
+ IH.add idNode dummyNode.id dummyNode;
+ if not !useStrings && !use_wild_solver then begin
+ useStrings := true;
+ ignore (E.warn "You must use strings when using the WILD solver! I turned them back on!");
+ end;
+
+ ()
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2006,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(* Initialize the pointer graph *)
+val initialize: unit -> unit
+
+(* If defaultIsNotWild then pointers without a qualifier are SAFE and only
+ * the arrays that are specfically SIZED contain a size field and only the
+ * variables that are specifically TAGGED contain tags *)
+val defaultIsWild: bool ref
+
+(* flag to force all functions to be untagged, in the WILD solver *)
+val wild_solve_untagged_functions: bool ref
+
+(* flag to force all functions to be tagged, in the WILD solver *)
+val wild_solve_tag_all_functions: bool ref
+
+(* True if the wild solver is used. *)
+val use_wild_solver: bool ref
+
+
+(** Whether we use Offset nodes. If false then we use the node stored with
+ * the address of a fieldinfo *)
+val useOffsetNodes: bool
+
+(** Whether to print verbose curing output source file *)
+val printVerboseOutput: bool ref
+
+(* Turn on/off the use of FSEQ *)
+val useFSEQ: bool ref
+
+(** Turn on/off the use of RWSTRING, ROSTRING and NULLTERM *)
+val useStrings: bool ref
+
+(** Whether to extend the strign buffers with the null character. If false,
+ * then we use the last character for the null *)
+val extendStringBuffers: bool ref
+
+(** Whether to override user-specified annotations *)
+val allowOverride: bool ref
+
+(** Allow partial elements in sequences *)
+val allowPartialElementsInSequence: bool ref
+
+(** Whether to emit more details in the .infer file. *)
+val emitGraphDetailLevel: int ref
+val graphDetailLevelLegend: string (* The meaning of different values *)
+
+(* A marker that the solver places, if we use lean fats *)
+val useLeanFats: bool ref
+
+
+(* A place where a pointer type can occur *)
+type place =
+ PGlob of string (* A global variable or a global function *)
+ | PType of string (* A global typedef *)
+ | PStatic of string * string (* A static variable or function. First is
+ * the filename in which it occurs *)
+ | PLocal of string * string * string (* A local variable. The name of the
+ * file, the function and the name of
+ * the local itself *)
+ | POffset of int * string (* An offset node, give the host node
+ * id and a field name *)
+ | PField of Cil.fieldinfo (* A field of a composite type *)
+
+ | PAnon of int (* Anonymous. This one must use a
+ * fresh int every time. Use
+ * anonPlace() to create one of these
+ * *)
+ | PStr (* The global node for all string
+ * literals. They all have the same
+ * kind, so we don't need separate
+ * nodes.*)
+ | PWStr (* The global node for all wide string
+ * literals. *)
+
+type chain (* A chain of edges *)
+
+(* Each node corresponds to a place in the program where a qualifier for a
+ * pointer type could occur. As a special case we also add qualifiers for
+ * variables in expectation that their address might be taken *)
+type node =
+ { id: int; (* A program-wide unique identifier *)
+ where: place * int; (* A way to identify where is this
+ * coming from. We use this to make
+ * sure we do not create duplicate
+ * nodes. The integer is an index
+ * within a place, such as if the
+ * type of a global contains several
+ * pointer types (nested) *)
+
+ btype: Cil.typ; (* The base type of this pointer *)
+ mutable attr: Cil.attribute list; (* The attributes of this pointer
+ * type *)
+ mutable is_array: bool; (* This node is associated with an
+ * array, not with a pointer. *)
+
+ mutable flags: (whyflag option) array;
+
+ mutable succ: edge list; (* All edges with "from" = this node *)
+ mutable pred: edge list; (* All edges with "to" = this node *)
+
+ (* The rest are the computed results of constraint resolution *)
+ mutable kind: opointerkind;
+ mutable why_kind: whykind;
+ mutable sized: bool ; (* An array may be SIZED at which
+ * point it has a length field
+ * stored right before it. This
+ * leads to INDEX pointers. *)
+
+ mutable locked: bool; (* do not change this kind later *)
+ mutable mark: bool; (* For mark-and-sweep GC of nodes.
+ * Most of the time is false *)
+
+ mutable rep : ((node * chain) option);
+ (* a representative pointer in this node's equivalence class. use
+ * this only for nodes whose btype is void. use get_rep to get the
+ * final representative. The chain is always from the node to the
+ * representative. *)
+ mutable loc : Cil.location; (* where did this node come from? *)
+
+ shouldInfer: bool; (* True if this is a local or a cast
+ and we can do more aggressive
+ inference. *)
+ }
+
+(*** If you add pointer kinds, make sure you extend the definition of
+ * allKinds *)
+and opointerkind =
+ Safe (* a COUNT(1) pointer *)
+ | Sentinel (* a COUNT(0) pointer. If a pointer is not referenced,
+ not NT, is not annotated SAFE, and does not use
+ arithmetic, it gets this kind.*)
+
+ | Seq (* Needs lower and upper bounds *)
+ | FSeq (* Needs upper bound *)
+
+ | SeqN
+ | FSeqN
+ | String (* An NT COUNT(0) pointer *)
+
+ | UnknownN (* An NT pointer with no annotated bounds.
+ Inference turns this into String, FSeqN, or SeqN.
+ If no pkArith flag is present after solving, this
+ will default to String.*)
+
+ | Unknown (* If no pkArith or pkString flag is present after solving,
+ this will default to Safe.*)
+
+and whykind = (* why did we give it this kind? *)
+
+ (* Give the edge of a bad cast. *)
+ BadCast of edge
+
+ | BadSequenceCast of edge
+
+ | Incompat of node * chain * node (* Two nodes that should be in the same
+ * equivalence class are incompatible *)
+
+ | BoolFlag of int (* Due to a flag *)
+ | PolyInt (* This is a void* connected only to scalars *)
+ | Default
+ | UserSpec
+ | Unconstrained
+ | PrintfArg (* printf inference *)
+ | Special of string * Cil.location
+ (* This kind is set because it is set on some other node (node1 + the
+ * chain:node1->this). We also give the original source of the kind. *)
+ | SpreadFromNode of node * chain * node
+
+and edge =
+ { eid: int;
+ mutable efrom: node;
+ mutable eto: node;
+ mutable ekind: edgekind;
+ mutable eloc: Cil.location;
+ }
+
+and whyflag = (* why is this flag set for this node? *)
+ | ProgramSyntax of Cil.location (* This flag was set because of the usage
+ * of this node in the program *)
+
+ (* This flag is set because it is set on some other node (node1 + the
+ * chain:node1->this). We also give the original source of the flag. *)
+ | FlagSpreadFromNode of node * chain * node
+
+ | DownCast of node
+
+ | SubtypeFailed of node
+
+ | RequiredByEdge of edge
+
+ | RequiredByPointerKind of opointerkind
+
+ | RequiredByFlag of int (* This flag is required by another flag *)
+
+ | FlUserSpec of Cil.location
+
+ | MayEscape of Cil.location (* We are using separate compilation,
+ and this node is not a local.
+ Therefore, we assume it can be used
+ by anybody. *)
+
+
+and edgekind =
+ ECast of extra_edge_kind (* T_from ref q_from <= T_to ref q_to. We also
+ * cary some additional explanation for this
+ * edge. *)
+ | EOffset (* This is an edge added from a pointer to a
+ * structure to a pointer to a field. The
+ * destination of this edge should be either a
+ * POffset node or the node associated with the
+ * address of a field. WILDness spreads in both
+ * directions across this edge. *)
+ | EIndex (* q_to = if q_from = wild then wild else index *)
+(* | ENull *) (* a NULL flows in the direction of the edge *)
+ | ECompat (* the kinds of these two nodes must be
+ * compatible: either both wild, index or
+ * safe. This edge type is added by the solver
+ * for its convenience. In cases like
+ * int * 1 * 2 x;
+ * int * 3 * 4 y;
+ * We will connect 1 and 3 with ECompat. *)
+ of chain (* the two types we were comparing when we
+ * decided that these had to be equal *)
+ | ESameKind (* Special edge that does not require
+ * compatibility of the types involved, but does
+ * require that they be of the same KIND. *)
+ of extra_edge_kind_sk (* See below for uses of ESameKind *)
+ | EPointsTo (* from's base type included to *)
+ | EArgs (* From the pointer to the function to the
+ * actual arguments and result values. Before we
+ * added this edge we relied on WILDness to
+ * spread from the function pointer to the
+ * actual argument by means of EPoints to edge
+ * to the formals and then ECast edges. But that
+ * did not work when there were no formals
+ * declared ! *)
+(* More info about ECast edges *)
+and extra_edge_kind =
+ EEK_cast (* A true cast *)
+ | EEK_stringdrop (* An NTDROP cast in deputy. We do not push
+ pkString forwards across this edge.
+ (pkString flows backwards as usual) *)
+ | EEK_cxxOverride (* Due to the Cxx inheritance. See markcxx *)
+ | EEK_extends (* Due to an extends relationship *)
+ | EEK_mkptr (* Due to a mkptr or alignseq *)
+ | EEK_union (* Edges added between union fields *)
+ | EEK_rtti (* Edges due to auto RTTI *)
+
+(* More info about ESameKind edges *)
+and extra_edge_kind_sk =
+ | EEK_trustedCast (* This edge is added between the formal
+ * argument and the result value in an instance
+ * of trusted_cast function. This does not
+ * require compatibility of the types involved
+ * but does require that the two types be of the
+ * same KIND *)
+ | EEK_taggedUnion (* Behaves like an trustedCast, but is sound.
+ * We use this to connect union fields that must
+ * have the same kind in case we cast from one to
+ * another, but we can ignore types on these edges
+ * since those are checked dynamically. *)
+
+val mkRIdent: chain
+
+val mkRSingle: edge -> chain
+val mkRSym: chain -> chain
+val mkRTrans: chain -> chain -> chain
+
+val isSym: chain -> chain option
+
+val getOneEdge: chain -> edge option
+
+val isOneEdge: chain -> edge option
+
+val get_rep : node -> node (* find the representative of this node's
+ * equivalence class *)
+
+val join : node -> node -> chain -> unit
+ (* join these two nodes into the same equivalence class because of
+ * the given edge. *)
+
+val doCheckChains: bool (* Whether to check the chains *)
+val checkChainEnds: node -> node -> chain -> unit
+
+val get_rep_why : node -> node * chain
+ (* given a node, return the list of edges that join'd it to its
+ * representative *)
+
+val setFlag : node -> int -> whyflag -> unit
+val hasFlag : node -> int -> bool
+
+(* Given a flag for a node, produce the original node where the flag
+ * originates, the true chain why it originates, and the chain:orig->this *)
+val trueSourceOfFlag: node -> int -> node * whyflag * chain
+
+(* Given a flag for a node, produce the original node where the flag
+ * originates, the true chain why it originates, and the chain:orig->this *)
+val trueSourceOfKind: node -> node * whykind * chain
+
+val pkInterface: int (* this is an interface node *)
+val pkUpdated: int (* we write through this pointer *)
+val pkIntCast: int (* can contain an integer *)
+val pkPosArith: int (* subject to positive pointer arithmetic *)
+val pkArith: int (* subject to arbitrary pointer arithmetic *)
+val pkString: int (* A String node *)
+val pkReachIndex: int (* can reach an Index node *)
+val pkNoPrototype: int (* Used as actual argument in a function without
+ * prototype *)
+val pkEscape: int (* can "escape" i.e. be assigned to a global or through a
+ * pointer *)
+val pkNotSafe: int (* constraint used by solvers: node must not be Safe *)
+
+val pkReferenced: int (* might be eventually referenced *)
+
+val pkRtti: int (* has run-time type information *)
+val pkCompatWithScalars: int (* void* node is compat with scalars *)
+val pkStack: int (* Could point to the stack; CHECK_STORE_PTR needed. *)
+
+val pkOneWord: int (* This is specified by the user to be one word *)
+
+val pkLastFlag: int
+val pkNumberOfFlags: int
+
+(* The names for the flags *)
+val pkFlagName: string array
+
+(* One certain types can have RTTI *)
+val canHaveRtti: Cil.typ -> bool
+
+
+(** All the pointer kinds *)
+val allKinds: opointerkind list
+
+(* The main graph *)
+val idNode: node Inthash.t
+
+val dummyNode: node (* A node with ID=0. Use when you don't have one *)
+
+(* Get a node for a place and an index. Give also the base type and the
+ * attributes *)
+val getNode: p:place -> idx:int -> bt:Cil.typ -> al:Cil.attribute list -> node
+
+(* Make a new node *)
+val newNode: p:place -> idx:int -> bt:Cil.typ -> al:Cil.attribute list -> node
+
+(** Recompute the EPointsTo information for a node *)
+val setNodePointsTo: node -> unit
+
+(* Make a new anonymous place *)
+val anonPlace: unit -> place
+
+(** A bitwise-or of the flags that are pushed to the predecessor of a node
+ * (backward) and always through the ECompat edges *)
+val pkCastPredFlags: int list
+
+(** A bitwise-or of the flags that are pushed to the successor of a node
+ * (forward) and always through the ECompat edges *)
+val pkCastSuccFlags: int list
+val pkCastSuccFlagsNoString: int list
+val pkCNIPredFlags: int list
+val pkCNIPredFlagsNoString: int list
+val pkOffsetSuccFlags: int list
+val pkOffsetPredFlags: int list
+val allFlags: int list
+
+val d_opointerkind: unit -> opointerkind -> Pretty.doc
+val d_whykind: node -> unit -> whykind -> Pretty.doc
+val d_whyflag: node -> unit -> whyflag -> Pretty.doc
+val d_node: unit -> node -> Pretty.doc
+val d_place: unit -> place -> Pretty.doc
+val d_place_nice: unit -> (place * int) -> Pretty.doc
+val d_chain: unit -> chain -> Pretty.doc
+
+val ccuredInferPrinter: Cil.cilPrinter
+
+(*val printBrowser: string -> Cil.file -> unit*)
+val printInfer: string -> Cil.file -> unit
+val printInferGraph: out_channel -> unit
+
+val printGraphStats: unit -> unit
+
+(* Helpers for printGraphStats *)
+val addToHisto: ('a, int ref) Hashtbl.t -> int -> 'a -> unit
+val getHisto: ('a, int ref) Hashtbl.t -> 'a -> int
+
+val existsEdge: start:node -> dest:node -> kind:edgekind -> bool
+
+(* Add an edge to the graph *)
+val addEdge: start:node -> dest:node -> kind:edgekind ->
+ eloc:Cil.location option -> edge
+
+val removeEdge: edge -> unit
+
+val isECompat: edge -> bool
+val isECast: edge -> bool
+val isESameKind: edge -> bool
+
+
+val nodeOfAttrlist: Cil.attribute list -> node option
+
+(* The inferred kind for this node. If localOnly is true and the node is not
+ * local, then return Unknown *)
+val inferredKindOf: ?localOnly:bool ->
+ Cil.attribute list -> opointerkind * whykind
+
+
+(* The kind of this pointer. If there is no BND attribute,
+ defaults to inferredKind *)
+val kindOfAttrlist: Cil.attribute list -> opointerkind * whykind
+
+val kindIsNullterm: opointerkind -> bool
+val kindNeedsBounds: opointerkind -> bool
+
+(* Replace the ptrnode attribute with the actual qualifier attribute *)
+type whichAttr =
+ AtPtr (* In a pointer type *)
+ | AtArray (* In an array type *)
+ | AtOpenArray (* In an array type without a size *)
+ | AtVar (* For a variable *)
+ | AtOther (* Anything else *)
+
+val replacePtrNodeAttrList: which:whichAttr
+ -> Cil.attribute list -> Cil.attribute list
+
+val k2attr: opointerkind -> Cil.attribute
+
+(** Return the numeric identifier of the kind *)
+val k2number: opointerkind -> int
+
+(** The parent in the points-to relationship *)
+val nodeThatPointsTo: node -> node option
+
+
+(** A function pointer that can be used to compare two types *)
+val isSubtype: (Cil.typ -> Cil.typ -> bool) ref
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2006,
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(* Weimer
+ *
+ * CCured pointer kind inference using an extension of the algorithm
+ * described in the paper submitted to PLDI'02.
+ *
+ * INPUT ASSUMPTIONS:
+ *
+ * The node hashtable includes the following edges:
+ * n1 ECAST n2 for the top-level nodes of casts
+ * n1 EOFFSET n2 from the top of a struct to its non-array fields
+ * n1 EINDEX n2 from the top of a struct to array fields
+ *
+ * Nodes have the following bits set iff the corresponding fact actually
+ * originate at that node:
+ * pkPosArith
+ * pkArith
+ * pkNull
+ * pkUpdated
+ * pkIntCast
+ * pkInterface
+ * pkSized
+ * pkNoPrototype (makes a function node wild)
+ *
+ * The "is_p x y" function returns true if x--cast-->y is from a polymorphic
+ * function and should not be considered.
+ *
+ * Returns "true" if we should typecheck the result because we let some
+ * user-annotated qualifier stand.
+ *)
+(*
+ * How does the solver work?
+ *
+ * We treat every "void *" as a separate type variable and we keep
+ * equivalence classes of void* nodes that are connected by ECast or
+ * ECompat edges. ECast edges come from Markptr as part of our
+ * precondition. We create ECompat edges.
+ *
+ * (1) We examine every CAST in the program. While scanning the
+ * types to see if the cast is valid we add ECompat edges between
+ * inner types that must be equal and mark as Wild types that
+ * do not match up. We also mark nodes as Not Safe in casts where
+ * the sizes are wrong.
+ * (2) Check equivalence classes. All nodes joined by ECompat edges must
+ * have equal types. Make sure all nodes in all equiv classes have
+ * the same flags.
+ * (3) We assign base-case flags. For example, we assign
+ * "pkString" to nodes that are of type string.
+ * (4) We push those flags around using standard data-flow tricks. Nodes
+ * connected by ECompat edges have identical flags.
+ * (5) Once we have all the flags in place we distinguish between all
+ * the kinds of sequences. For example, a node that cannot be safe
+ * and has an integer cast into it but does not reach a string becomes
+ * FSEQ.
+ * (6) We turn all string-like nodes that lead only into ROString nodes
+ * into ROString nodes themselves. Note all nodes connected by ECompat
+ * edges must have the same kind.
+ * (7) We push WILD as far as it can go. Generally WILD contaminates all
+ * outgoing edges and all points-to targets, however an edge from
+ * WILD to ROString is allowed.
+ * (8) All otherwise unconstrainted nodes become SAFE.
+ *
+ * Compared to previous solvers, this solver is much stricter about
+ * strings. No "safe -> string" or "safe -> rostring" casts should remain.
+ *)
+
+open Cil
+open Ptrnode
+open Pretty
+open Trace
+module E = Errormsg
+module IH = Inthash
+
+let verbose = Doptions.verbose
+
+(* Added for compatibility with Deputy's warnings. *)
+let warnLoc (loc : location) (fmt : ('a,unit,doc) format) : 'a =
+ let f d =
+ let saveLoc = !currentLoc in
+ currentLoc := loc;
+ Dutil.warn "%a" insert d;
+ currentLoc := saveLoc;
+ nil
+ in
+ Pretty.gprintf f fmt
+
+let bitsSizeOfOpt tau =
+ try Some(bitsSizeOf tau)
+ with SizeOfError _ -> None
+
+(* Euclid's algorithm for the GCD *)
+let rec gcd a b =
+ if a = 0 || b = 0 then 1
+ else if b > a then gcd b a
+ else match a mod b with
+ 0 -> b
+ | r -> gcd b r
+
+(* go through the source code and find where tau was declared *)
+class findTypeVisitor tau = object
+ inherit nopCilVisitor
+ val tau_sig = typeSig tau
+ method vtype some_type =
+ if tau_sig = typeSig some_type then
+ ignore (warn "type %a was not given a node by markptr" d_type tau) ;
+ DoChildren
+end
+
+(* equiv classes of nodes connected by ECompat edges. *)
+module OrderedNode =
+ struct
+ type t = node
+ let compare n1 n2 = n1.id - n2.id
+ (* Avoid using Pervasives.compare, which is the same as "=", which may
+ * loop forever because nodes contain "Cil.typ"s. *)
+ end
+module NodeSet = Set.Make(OrderedNode)
+module NodeUF = Unionfind.Make(NodeSet)
+
+
+(*
+ **
+ *** The Solver!
+ **
+ *)
+let solve (the_file : Cil.file) (node_ht : node Inthash.t) : unit = begin
+ let node_eq = ref (NodeUF.empty) in (* ECompat equivalence classes *)
+
+ let existsECompatEdge ~(start : node) ~(dest : node) =
+ List.fold_left (fun acc e -> acc ||
+ (e.eto.id = dest.id && match e.ekind with ECompat _ -> true | _ ->
+ false)) false start.succ
+ in
+
+ (* Spread a flag from one node to another one *)
+ let spreadFlag (f: int) (from: node) (why_from_to: chain) (nto: node) =
+ if not (hasFlag nto f) then begin
+ let orig, _, _ = trueSourceOfFlag from f in
+ setFlag nto f (FlagSpreadFromNode(from, why_from_to, orig))
+ end
+ in
+
+
+ (* Say that n1 and n2 (which are usually matching inner pointers) must
+ * really be equal. This adds an ECompat edge between them and places
+ * them in the same equivalence class. We avoid making duplicate edges.
+ * We know if this edge is for inner pointers. Otherwise it is for void*
+ * equivalence classes *)
+ let rec addECompatEdge (isinner: bool) n1 n2 why_n1_n2 location =
+ if existsECompatEdge n1 n2 ||
+ existsECompatEdge n2 n1 ||
+ n1.id = n2.id then
+ ()
+ else begin
+ (* Sometimes it might be convenient to swap the nodes in order to keep
+ * the explanations shorter. *)
+ let n1, n2, why_n1_n2 =
+ match isSym why_n1_n2 with
+ Some why_n2_n1 -> n2, n1, why_n2_n1
+ | _ -> n1, n2, why_n1_n2
+ in
+
+ if doCheckChains then
+ checkChainEnds n1 n2 why_n1_n2;
+
+ (* matth: I had originally removed this line from Deputy.
+ Does it break anything? *)
+ ignore(addEdge n1 n2 (ECompat why_n1_n2) (Some(location)));
+
+ (* We only join in the equivalence classes (maintained through the .rep
+ * fields) if at least one is TPtr(void). OTherwise we use the NodeUF
+ * equivalence classes *)
+ if (isVoidType n1.btype || isVoidType n2.btype) then begin
+ join n1 n2 why_n1_n2
+ end else
+ node_eq := NodeUF.make_equal (!node_eq) n1 n2 why_n1_n2 ;
+ end
+ in
+
+ (* whenever we have to "loop until things settle", we used
+ * finished to keep track of our status *)
+ let finished = ref false in
+
+ (* update changes node "n"'s kind to "k" because of "w" and sets
+ * finished to false. It also does logging and sanity checking. *)
+ let update n k w = begin
+ if (k <> n.kind) then begin
+ (* Check if the new kind is stronger than the old one *)
+ let shouldUpdate: bool =
+ match k, n.kind with
+ _, Unknown -> true (* Unknown is weakest *)
+ | Unknown, _ -> false
+ | _, Sentinel -> true (* Sentinel is next *)
+ | Safe, _ -> false (* this means Safe can only replace Unknown or
+ Sentinel *)
+ (* Strings replace non-strings *)
+ | String, (UnknownN|Safe) -> true
+ | FSeqN, (Seq|FSeq|Safe) -> true
+ | SeqN, (Seq|FSeq|Safe) -> true
+
+ (* Seq replaces FSeq, which in turn replaces SAFE,
+ unless the user specified otherwise *)
+ | (Seq|SeqN), (FSeq|FSeqN|Safe|String|UnknownN) ->
+ n.why_kind <> UserSpec
+ | (FSeq|FSeqN), (Safe|String|UnknownN) ->
+ n.why_kind <> UserSpec
+
+ | _, _ -> false
+ in
+ if shouldUpdate then begin
+ (* The new kind is stronger. We must update. *)
+ let trulyUpdate =
+ if n.why_kind = UserSpec then
+ if !allowOverride then begin
+ (* matth: If the user annotates a node as __RTTI
+ * and we infer it to be FSeqR or SeqR, assume that that's what
+ * the user intended, and don't print a warning. *)
+ (match n.kind, k with
+ | FSeq, FSeqN
+ | Seq, SeqN -> ()
+ | _ -> ignore (warnLoc n.loc
+ "Solver: Changing User Specified %a node %d (%a) to %a."
+ d_opointerkind n.kind n.id
+ d_place_nice n.where
+ d_opointerkind k));
+ true
+ end else begin
+ (* Use "ignore" so that we do not stop here. But we'll stop
+ * after solving *)
+ E.hadErrors := true;
+ ignore (errorLoc n.loc
+ "Solver: Should change User Specified %a node %d (%a) to %a."
+ d_opointerkind n.kind n.id
+ d_place_nice n.where
+ d_opointerkind k);
+ false
+ end
+ else
+ true (* If it is not User_Spec then always update *)
+ in
+ if trulyUpdate then begin
+ n.kind <- k ;
+ n.why_kind <- w ;
+ finished := false
+ end
+ end
+ end else (* Already have the same kind *)
+ ()
+ end
+ in
+
+ (* Help Function: find the attributes of a type *)
+ let node_of_type tau =
+ nodeOfAttrlist (typeAttrs tau)
+ in
+
+ (* Step 0
+ * ~~~~~~
+ * Our first pass over the set of nodes.
+ * Set all of the flag starting conditions that we know about.
+ *)
+ if !verbose then ignore (E.log "Solver: Step 0 (Base Case)\n") ;
+
+
+ (* loop over all the nodes ... *)
+ IH.iter (fun id n ->
+ (* calling a function without a prototype makes it wild *)
+ if hasFlag n pkNoPrototype then begin
+ Dutil.errorwarn "You passed too many arguments to a function (see above). We should make the function WILD.";
+ end ;
+
+ begin
+ match n.kind with
+ | String when !useStrings ->
+ setFlag n pkString (RequiredByPointerKind n.kind);
+ setFlag n pkOneWord (FlUserSpec n.loc)
+
+ | FSeq
+ | Seq -> ()
+
+ | FSeqN
+ | SeqN
+ | UnknownN when !useStrings ->
+ setFlag n pkString (RequiredByPointerKind n.kind)
+
+ | Safe -> setFlag n pkOneWord (FlUserSpec n.loc)
+
+ | _ -> ()
+ end ;
+
+ if hasAttribute "size" n.attr || hasAttribute "count" n.attr then
+ setFlag n pkOneWord (FlUserSpec n.loc);
+
+ ) node_ht ;
+
+ (* Step 1
+ * ~~~~~~
+ * Consider every cast.
+ *
+ * Generate ECOMPAT edges between aligned sub-pointers.
+ * Generate BADCAST constaints on failed pointers (make 'em WILD)
+ * Generate ARITH constaints on upcasts (make 'em not SAFE).
+ *)
+ if !verbose then ignore (E.log "Solver: Step 1 (Casts)\n") ;
+
+ let the_edge = ref None in
+
+ (* Whenever we compare two types for equality we should mark all
+ * matching inner pointers with ECOMPAT edges. This function is called
+ * by the type-scanning phase on all pairs of pointers that should
+ * match up. *)
+ let handle_inner_pointers loc explanation tau1 tau2 =
+ try begin
+ match (node_of_type tau1),(node_of_type tau2) with
+ | Some(n1),Some(n2) ->
+ addECompatEdge true n1 n2 explanation loc;
+
+ | Some(n),None
+ | None,Some(n) when (isVoidType n.btype) -> begin
+ (* Link a "void*" equivalence class with the scalars. *)
+ setFlag n pkCompatWithScalars (FlagSpreadFromNode(n,explanation,n)) ;
+ let (nr,why_n_nr) = get_rep_why n in
+ setFlag nr pkCompatWithScalars (FlagSpreadFromNode(n,why_n_nr,n))
+ end
+
+ | _,_ -> (* in this unfortunate case, we don't know how to get
+ * to the nodes of these types. Try to print a useful error
+ * message *)
+ begin
+ if node_of_type tau1 = None then
+ ignore (visitCilFile (new findTypeVisitor tau1) the_file) ;
+ if node_of_type tau2 = None then
+ ignore (visitCilFile (new findTypeVisitor tau2) the_file) ;
+
+ E.s (E.bug "Solver: cannot link inner pointers:@!%a@!%a@!%a\n"
+ d_type tau1 d_type tau2
+ (docOpt (fun e ->
+ dprintf "%d->%d" e.efrom.id e.eto.id)) !the_edge)
+ end
+ end with e -> begin
+ ignore (E.warn "handle_inner_pointers raises %s\n"
+ (Printexc.to_string e))
+ end
+ in
+ (* This function is called by type comparison functions in Type.ml when the
+ * base types of two pointer types fails to compare properly. This function
+ * should be called on representatives only. *)
+ let handle_failure n1 why_n1_n2 n2 =
+ if n1.rep != None then
+ E.s (E.bug "handle_failure called on node %d which is not a representative"
+ n1.id);
+ if n2.rep != None then
+ E.s (E.bug "handle_failure called on node %d which is not a representative"
+ n2.id);
+ in
+ (*
+ * Step 1 Loop : examine every cast
+ *)
+ (* Sometimes we might need to create new ECast edges for auto RTTI.
+ * Remember them here *)
+ let step1_oneEdge e = (* look at every forward edge *)
+ the_edge := Some(e) ;
+ if isECast e then begin
+ if Type.debugType then
+ ignore (E.log "Considering Edge %d->%d\n" e.efrom.id e.eto.id);
+
+ let from_rep, why_efrom_frep = get_rep_why e.efrom in
+ let to_rep, why_eto_trep = get_rep_why e.eto in
+ let from_rep_t = from_rep.btype in
+ let to_rep_t = to_rep.btype in
+ (* explanation: from_rep -> e.efrom -> e.eto -> to_rep *)
+ let why_frep_trep =
+ mkRTrans (mkRSym why_efrom_frep)
+ (mkRTrans (mkRSingle e) why_eto_trep) in
+
+ (* Deal with void* casts. *)
+ if (isVoidType from_rep_t || isVoidType to_rep_t) then begin
+ let from_rep_is_void = isVoidType from_rep_t in
+ let to_rep_is_void = isVoidType to_rep_t in
+
+ (* If one of the representatives types is void_ptr,
+ * and we are doing void* inferrence on this node,
+ * then we just add an ECompat edge and join the classes.
+ * If BOTH nodes are void*, only add the ECompat if we're doing
+ * inference on both of them. *)
+ if ( (from_rep_is_void || to_rep_is_void)
+ && (e.eto.shouldInfer || not to_rep_is_void)
+ && (e.efrom.shouldInfer || not from_rep_is_void)) then
+ addECompatEdge false from_rep to_rep why_frep_trep e.eloc
+ end else begin
+ (* Not a cast involving void*. Just go ahead and check the types *)
+ let from_size = try bitsSizeOf(from_rep_t) with SizeOfError _ -> 1 in
+ let to_size = try bitsSizeOf(to_rep_t) with SizeOfError _ -> 1 in
+ if from_size < to_size then begin
+ setFlag e.efrom pkNotSafe (DownCast e.eto); (* ARITH constraint *)
+ end ;
+
+ Stats.time "subtype" (fun () ->
+ if not (Type.subtype
+ ~compat:(handle_inner_pointers e.eloc)
+ ~failure:(handle_failure)
+ ~why_small_big:(mkRSym why_frep_trep)
+ ~small:to_rep_t
+ ~big:from_rep_t)
+ then begin (* they are not subtypes *)
+ (* We do *NOT* pass polymorphic_replace to Type.all_scalars
+ * because we have already replaced the top-level void*s
+ * (with to_rep and from_rep). p_r would just replace any
+ * void*s in to_rep_type and from_rep_type -- but if there
+ * are any void*s in to_rep_type or from_rep_type then we
+ * don't want to say that it was "all scalars" here. In
+ * particular, this could happen in a case like:
+ * int i = 5 __1 ;
+ * void *__2 *__3 v = ( void *__4 *__5 )&i;
+ * Between 3 and 5. 4 will have the pkCompatWithScalars flag,
+ * but we don't to make 2 and 4 FSEQ here. *)
+ if (Type.all_scalars to_rep_t) && (Type.all_scalars from_rep_t)
+ (* if it must be compatible with scalars and we failed the
+ * subtyping then it must be WILD! *)
+ then begin
+ (* ARITH constraint *)
+ (* GN: Subtyping failed but they are all scalars. In that
+ * case all we need is the the origin node is not SAFE. I
+ * commented out the next line. *)
+ (* setFlag e.eto pkNotSafe (SubtypeFailed e.efrom) ; *)
+ setFlag e.efrom pkNotSafe (SubtypeFailed e.eto) ;
+ (* In this one special case, we'll infer that the two
+ * types should be SEQ *)
+ end else begin
+ handle_failure from_rep why_frep_trep to_rep
+ end
+ end
+ ) ()
+ end
+ end else if e.ekind = EIndex then begin
+ (* while we're here, these arrays cannot be safe *)
+ setFlag e.eto pkNotSafe (RequiredByEdge e);
+ end
+ in
+ IH.iter (fun id cur ->
+ List.iter step1_oneEdge cur.succ ; (* look at every forward edge *)
+ the_edge := None ;
+ (* Set user-specified flags *)
+ match cur.kind with
+ Seq | SeqN ->
+ setFlag cur pkArith (RequiredByPointerKind cur.kind) ;
+ setFlag cur pkReferenced (RequiredByPointerKind cur.kind) ;
+ | FSeq | FSeqN ->
+ setFlag cur pkPosArith (RequiredByPointerKind cur.kind) ;
+ setFlag cur pkReferenced (RequiredByPointerKind cur.kind) ;
+ | Safe | String | UnknownN ->
+ setFlag cur pkReferenced (RequiredByPointerKind cur.kind) ;
+ | Unknown | Sentinel -> ()
+ ) node_ht ;
+
+
+ (* Step 2
+ * ~~~~~~
+ * Skipped in Deputy!
+ *)
+
+
+ (* Step 3
+ * ~~~~~~
+ * Check our equivalence classes for consistency.
+ *
+ * All "void *" equivalence class nodes should have an ECompat edge to
+ * their rep. The rep has the flags for the whole class.
+ *
+ * All nodes in "void*" equivalence classes should link up everything
+ * they point to in "void*" equivalence classes as well.
+ *
+ * All nodes in equiv classes should have the same flags.
+ *)
+ (* First we add transitive closure of the ECast edges on "void *" *)
+ if !verbose then ignore (E.log "Solver: Step 3 (equiv)\n") ;
+
+ let check_compat_fun e =
+ match e.ekind with
+ ECompat r ->
+ let to_t = e.eto.btype in
+ let from_t = e.efrom.btype in
+ (* Leave alone the edges that have a void-ptr !! *)
+ if isVoidType to_t || isVoidType from_t then
+ ()
+ else begin
+ the_edge := Some(e) ;
+ if (not (Stats.time "subtype"
+ (fun () -> Type.equal
+ ~compat:(fun _ _ _ -> ()) (* gn: why ? *)
+ ~failure:(handle_failure)
+ ~why_t1_t2: r
+ ~t1:from_t
+ ~t2:to_t) ())) then
+ handle_failure e.eto r e.efrom;
+
+ the_edge := None ;
+ end;
+ | _ -> ()
+
+ in
+
+ Stats.time "equiv-check"
+ (IH.iter (fun id cur ->
+ let rep, why_cur_rep = get_rep_why cur in
+
+ (* Check to see if any equivalence classes must be compatible with
+ * scalars AND ALSO with some non-void type. If so, that class becomes
+ * WILD. *)
+ if ( hasFlag cur pkCompatWithScalars &&
+ not (hasFlag rep pkCompatWithScalars)) then begin
+ E.s (E.bug "Solver: node %d has pkCompatWithScalars flag but its rep %d does not" cur.id rep.id)
+ end ;
+
+ if hasFlag rep pkCompatWithScalars && not (isVoidType rep.btype) then begin
+ ignore (warnLoc rep.loc "Solver: BAD CAST / EQ-SCALAR@!%a"
+ d_type rep.btype)
+ end ;
+
+ if doCheckChains then
+ checkChainEnds cur rep why_cur_rep;
+ if rep != cur then begin
+ for i = 0 to pkLastFlag do
+ (* The RTTI flag is spread while the edges are being created *)
+ if i <> pkRtti && hasFlag cur i then
+ spreadFlag i cur why_cur_rep rep
+ done ;
+ end;
+ (* Once for each edge *)
+ List.iter check_compat_fun cur.succ ;
+ (* List.iter check_compat_fun cur.pred ; *)
+ )) node_ht ;
+
+ (* Now we have equivalence classes of ECompat-joined nodes *)
+ let compat_eq_classes = NodeUF.eq_classes !node_eq in
+
+ (*
+ * Step 3 Loop #2 : examine each "void *" equiv class
+ *)
+
+ (* share all flags within equivalence classes *)
+ List.iter (fun eq_class ->
+ List.iter (fun from_elt ->
+ List.iter (fun to_elt ->
+ for i = 0 to pkLastFlag do
+ (* The RTTI flag is spread while the edges are being created *)
+ if i <> pkRtti && hasFlag from_elt i then
+ if not (hasFlag to_elt i) then
+ let why_from_to = NodeUF.why_equal !node_eq from_elt to_elt in
+ if doCheckChains then
+ checkChainEnds from_elt to_elt why_from_to;
+ spreadFlag i from_elt why_from_to to_elt
+ done ;
+ if (to_elt.why_kind = UserSpec) then begin
+ from_elt.kind <- to_elt.kind ;
+ from_elt.why_kind <- to_elt.why_kind
+ end ;
+ if (from_elt.why_kind = UserSpec) then begin
+ to_elt.kind <- from_elt.kind ;
+ to_elt.why_kind <- from_elt.why_kind
+ end ;
+ if (to_elt.why_kind = Default && from_elt.why_kind <> Default) then
+ to_elt.why_kind <- from_elt.why_kind
+ ) eq_class
+ ) eq_class
+ ) compat_eq_classes ;
+
+
+ (* Step 4
+ * ~~~~~~
+ * Push all of the boolean flags around.
+ *)
+ if !verbose then ignore (E.log "Solver: Step 4 (Data-Flow)\n") ;
+ (* loop over all the nodes ... *)
+ finished := false ;
+
+ let worklist = Queue.create () in
+
+ (* Find edge chain *)
+ let findEdgeChain (src: node) (e: edge) =
+ (* Find the chain src -> dst *)
+ let r1 =
+ match e.ekind with
+ ECompat r' -> r'
+ | _ -> mkRSingle e
+ in
+ (* Check that this edge has src as one of its ends *)
+ if doCheckChains && src.id <> e.efrom.id && src.id <> e.eto.id then
+ ignore (E.warn "findEdgeChain for src=%d and edge %d->%d\n"
+ src.id e.efrom.id e.eto.id);
+ (* See if the edge is going in the right direction *)
+ if e.efrom.id = src.id then r1 else mkRSym r1
+ in
+
+
+ let setFlagsFromListChain dst src r_src_dst lst =
+ if doCheckChains then
+ checkChainEnds src dst r_src_dst;
+ List.iter (fun i ->
+ (* The RTTI flag is spread while the edges are being created *)
+ if i <> pkRtti && hasFlag src i && not (hasFlag dst i)
+ (* Do not spread the intCast flag to RTTI pointer *)
+ && (i <> pkIntCast || not (hasFlag dst pkRtti)) then begin
+ Queue.add dst worklist ;
+ spreadFlag i src r_src_dst dst
+ end
+ ) lst
+ in
+
+ let setFlagsFromList dst src e lst =
+ let r_src_dst = findEdgeChain src e in
+ setFlagsFromListChain dst src r_src_dst lst
+ in
+
+ let processDataFlow cur = begin
+ (* First consider all ECompat edges:
+ * flags should be equal across them. This is motivated by
+ * test/small1/apachebuf.c. Merely making ECompat-linked nodes have
+ * the same kind does not suffice: a pred of an ecompat-linked node
+ * may need to be made FSEQ because of a posarith on the other side
+ * of the ecompat link. *)
+ let inner_fun e =
+ if isECompat e || isESameKind e then begin
+ setFlagsFromList e.efrom e.eto e allFlags ;
+ setFlagsFromList e.eto e.efrom e allFlags ;
+ end
+ in
+ List.iter inner_fun cur.pred ;
+ List.iter inner_fun cur.succ ;
+
+ (* Consider all Successor Edges, do data-flow *)
+ List.iter (fun e ->
+ (match e.ekind with
+ | ECast extra_kind ->
+ (* We do not propagate the pkString flag in the following cases:
+ * 1. The user explicitly dropped the NT flag.
+ * 2. The target is user-specified, in which case we do not want
+ * to override the user's choice.
+ * 3. The source is a non-local and non-cast (e.g., an argument)
+ * and it was not specified NT by the user. This check
+ * prevents NT from flowing into a function without the
+ * user's permission. *)
+ if extra_kind = EEK_stringdrop || e.eto.why_kind = UserSpec ||
+ (e.efrom.why_kind <> UserSpec && not e.efrom.shouldInfer) then
+ setFlagsFromList e.eto cur e pkCastSuccFlagsNoString
+ else
+ setFlagsFromList e.eto cur e pkCastSuccFlags;
+
+ (* If the successor node is referenced and we have the pkString
+ * flag, we propagate pkPosArith and pkArith flag to successor. We
+ * want to make sure that the accesses to these pointers will be
+ * checked against the bound, not using the NULLTERM functions *)
+ if hasFlag cur pkString && not (hasFlag e.eto pkOneWord) then
+ setFlagsFromList e.eto cur e [ pkPosArith; pkArith ]
+
+ | EOffset ->
+ setFlagsFromList e.eto cur e pkOffsetSuccFlags ;
+ | _ -> ()) ;
+ ) cur.succ ;
+
+ (* Consider all Predecessor Edges, do data-flow *)
+ List.iter (fun e ->
+ (match e.ekind with
+ ECast extra_kind -> (* track [F]SEQ information *)
+ setFlagsFromList e.efrom cur e pkCastPredFlags ;
+
+ (* See comment above for explanation. *)
+ if e.efrom.why_kind = UserSpec ||
+ (e.eto.why_kind <> UserSpec && not e.eto.shouldInfer) then
+ setFlagsFromList e.efrom cur e pkCNIPredFlagsNoString
+ else
+ setFlagsFromList e.efrom cur e pkCNIPredFlags;
+ | EIndex -> setFlagsFromList e.efrom cur e pkCNIPredFlagsNoString ;
+ | EOffset ->
+ setFlagsFromList e.efrom cur e pkOffsetPredFlags ;
+ | _ -> ()) ;
+ ) cur.pred ;
+
+ end
+ in
+
+ Stats.time "data-flow" (fun () ->
+ (* data-flow can actually take some time, so we'll use a work-list *)
+ IH.iter (fun id cur -> processDataFlow cur) node_ht;
+ while (Queue.length worklist > 0) do
+ (* first, run normal data-flow *)
+ while (Queue.length worklist > 0) do
+ let cur = Queue.take worklist in
+ processDataFlow cur
+ done ;
+ (* If one array has been compared against another, they must share
+ * the same flags. Notably, if you have:
+ * struct { int __INDEX a[8]; } *p;
+ * struct { int b[8]; } *q = p;
+ * we want b to end up being INDEX as well. *)
+ Hashtbl.iter (fun (t1,t2) why ->
+ let n1 = node_of_type t1 in
+ let n2 = node_of_type t2 in
+ match n1,n2 with
+ | Some(n1),Some(n2) ->
+ setFlagsFromListChain n1 n2 why [pkReachIndex] ;
+ setFlagsFromListChain n2 n1 (mkRSym why) [pkReachIndex]
+ | _ ->
+ ignore (E.warn "solver: cannot set flags equal for arrays %a and %a"
+ d_type t1 d_type t2)
+ ) Type.arraysThatHaveBeenComparedWithArrays ;
+ (* If this array step didn't update anything, we'll fall out of the
+ * outer loop and be done with data-flow. Otherwise we do it all
+ * again. *)
+ done
+ ) () ;
+
+
+ (* Step 5
+ * ~~~~~~
+ * Distinguish between sequences. We must do this after boolean flags
+ * (otherwise we cannot tell what reaches what, etc.) but before we do
+ * WILDs (because they interact with read-only strings).
+ *
+ * Also generate ARITH constraints: q != SAFE.
+ *)
+ if !verbose then ignore (E.log "Solver: Step 5 (sequences)\n") ;
+
+ (* n is a polymorphic "void *" node if it points to void* and its
+ * representative points to void* as well. *)
+ let is_polymorphic_voidstar n =
+ match n.btype, (get_rep n).btype with
+ TVoid _ , TVoid _-> true
+ | _ -> false
+ in
+
+ IH.iter (fun id cur ->
+ (* Generate "ARITH" style constraints: q != SAFE *)
+ List.iter (fun f ->
+ if hasFlag cur f then setFlag cur pkNotSafe (RequiredByFlag f)
+ ) [pkArith ; pkPosArith ] ;
+
+ if hasFlag cur pkIntCast then
+ setFlag cur pkNotSafe (RequiredByFlag pkIntCast) ;
+
+ if hasFlag cur pkString && not !useStrings then
+ E.s (bug "we are not using strings but node %d has the pkString flag"
+ cur.id);
+
+ if hasFlag cur pkNotSafe ||
+ hasFlag cur pkString ||
+ hasFlag cur pkReachIndex then
+ begin
+ let new_kind,why =
+ if (hasFlag cur pkReachIndex) then
+ E.s (bug "no Index in Deputy")
+ else if hasFlag cur pkArith then
+ (if hasFlag cur pkString then SeqN else Seq),BoolFlag pkArith
+
+ else if hasFlag cur pkPosArith then
+ (if hasFlag cur pkString then
+ (if !useFSEQ then FSeqN else SeqN)
+ else
+ (if !useFSEQ then FSeq else Seq)), BoolFlag pkPosArith
+
+ (* NOT: pkReachIndex, pkReachSeq, pkPosArith, pkArith *)
+ else if hasFlag cur pkIntCast then
+ begin
+ if is_polymorphic_voidstar cur then
+ Safe, PolyInt
+ else
+ (if hasFlag cur pkString then FSeqN else FSeq),
+ BoolFlag pkIntCast
+ end
+ else if hasFlag cur pkString then
+ String, BoolFlag pkString
+
+ (* NOT: pkString *)
+ else if hasFlag cur pkNotSafe then
+ (if !useFSEQ then FSeq else Seq), BoolFlag pkNotSafe
+
+ else begin
+ E.s (bug "Unexpected combination of flags for node %d: %a\n"
+ cur.id
+ (docArray ~sep:nil
+ (fun idx elm ->
+ match elm with
+ None -> nil
+ | Some _ -> text ("\n\t" ^ pkFlagName.(idx)))) cur.flags)
+ end
+ in
+ update cur new_kind why
+ end
+ ) node_ht ;
+
+ (* Step 7
+ * ~~~~~~
+ * Verify that SEQ-SEQ casts have the correct tiling. For example:
+ * struct A { int f1; } * __SEQ p1;
+ * struct B { int f2; int *f3; } * __SEQ p2;
+ * p1 = p2 ;
+ * This must result in WILD pointers, otherwise (p1++)->f1=5, *p2->f3 = 6
+ * causes a crash.
+ *)
+ if !verbose then ignore (E.log "Solver: Step 7 (SEQ-SEQ Tiling)\n") ;
+ let isSeqish n = match n.kind with
+ Seq | SeqN | FSeq | FSeqN -> true
+ | _ -> false
+ in
+ Stats.time "seq-seq checking" (fun () ->
+ IH.iter (fun id cur ->
+ List.iter (fun e ->
+ if isECast e && isSeqish cur && isSeqish e.eto then begin
+ let from_target = (get_rep cur).btype in
+ let to_target = (get_rep e.eto).btype in
+ if isVoidType from_target || isVoidType to_target then
+ ()
+ else begin
+ (* check for tiling! *)
+ let okay =
+ match bitsSizeOfOpt from_target, bitsSizeOfOpt to_target with
+ Some(from_size) ,Some(to_size) ->
+ let the_gcd = gcd from_size to_size in
+ let from_factor = to_size / the_gcd in
+ let to_factor = from_size / the_gcd in
+ Type.equal
+ ~compat:(fun _ _ _ -> ())
+ ~failure:(fun _ _ _ -> ())
+ ~why_t1_t2: mkRIdent
+ ~t1:(TArray(from_target, Some(integer from_factor), []))
+ ~t2:(TArray(to_target, Some(integer to_factor), []))
+ | _ ->
+ Type.equal
+ ~compat:(fun _ _ _ -> ())
+ ~failure: (fun _ _ _ -> ())
+ ~why_t1_t2: mkRIdent
+ ~t1:from_target
+ ~t2:to_target
+ in
+ if not okay then begin
+ ignore (warnLoc e.eloc "Solver: BAD CAST / SEQ-SEQ@! %a@!<- %a"
+ d_type to_target d_type from_target)
+ end
+ end
+ end
+ ) cur.succ
+ ) node_ht) () ;
+
+ (* Step 8
+ * ~~~~~~~
+ * All other nodes are Safe, String, or Sentinel.
+ *)
+ if !verbose then ignore (E.log "Solver: Step 8 (Safe)\n") ;
+ IH.iter (fun id n ->
+ (* Replace Unknown/referenced with Safe,
+ Unknown/unreferenced with Sentinel,
+ and UnknownN with String *)
+ if n.kind = Unknown then begin
+ if hasFlag n pkReferenced then
+ update n Safe Unconstrained
+ else
+ update n Sentinel Unconstrained
+ end else if n.kind = UnknownN then begin
+ update n String Unconstrained
+ end ;
+
+ (* Sanity Check! Typecheck.ml does much more than this. *)
+ if n.kind = Safe &&
+ (hasFlag n pkNotSafe ||
+ hasFlag n pkString ||
+ hasFlag n pkReachIndex ||
+ hasFlag n pkIntCast) &&
+ not (n.why_kind = UserSpec) &&
+ not (is_polymorphic_voidstar n) then begin
+ E.s (E.bug "Solver: botched node (left/made it safe) %d (%a)"
+ n.id d_place_nice n.where)
+ end ;
+
+ ) node_ht
+end
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2006,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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 solve: Cil.file -> Ptrnode.node Inthash.t -> unit
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2006,
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(*
+ * C Structural Type Equality
+ *)
+open Cil
+open Pretty
+module N = Ptrnode
+module E = Errormsg
+
+let debugType = false
+
+let useCompatOnRepresentative = false
+
+(* sm: When true, explicit padding elements are inserted, to try
+ * to fix the problem demonstrated by test/small2/alignprob.c; when
+ * false, we're back to the previous system.
+ *
+ * NOTE: The current implementation is really just a proof of concept,
+ * as the only entities that cause padding to be inserted are 'double's.
+ * A more elaborate system, one that ideally works for e.g. 64-bit
+ * aligned 'long' vs. 32-bit 'int', etc., is still future work.
+ *)
+let newPadding = false (* matth: we don't need this for deputy, because we
+ don't change any layouts *)
+
+(* When true, if we conclude that two types are incompatible due to
+ * padding/alignment issues, log "padding mismatch". Generally, such
+ * cases are exactly those that would have been allowed in the previous
+ * system but not in the new system, so we can check that the new
+ * system isn't rejecting things that are ok and were allowed before. *)
+let logPaddingMismatches = true
+
+let arraysThatHaveBeenComparedWithNonArrays = Hashtbl.create 511
+let arraysThatHaveBeenComparedWithArrays = Hashtbl.create 511
+(* A hash-table of arrays that have been compared with non-arrays. If that
+ * happened to an array that ends up INDEX, we flag an error (because INDEX
+ * changes the size/layout of the array, so our previous assessment was
+ * incorrect).
+ *)
+
+
+ (* replace a "void *" type with its representative *)
+ (* tau is already unrolled. The chain goes orig_tau -> replacedTau *)
+let polymorphic_replace (tau: typ) : typ * N.chain =
+ match tau with
+ | (TPtr((TVoid _),attr)) -> begin
+ match N.nodeOfAttrlist attr with
+ Some(n) ->
+ let rep,why_n_rep = N.get_rep_why n in
+ (* gn: use the attributes of the representatives not ours !! *)
+ if N.hasFlag rep N.pkCompatWithScalars then begin
+ intType, why_n_rep
+ end else
+ (TPtr(rep.N.btype, rep.N.attr)), why_n_rep
+ | None -> tau, N.mkRIdent
+ end
+ | _ -> tau, N.mkRIdent
+
+let ok_to_call_compat t1 t2 =
+ isVoidPtrType t1 || isVoidPtrType t2 ||
+ (isPointerType t1 && isPointerType t2)
+
+
+(* A failure handler is called on two nodes whose base types fail to match
+ * up. This should make those nodes have WILD types (and thus force them to
+ * match up) *)
+type failureHandler = N.node -> N.chain -> N.node -> unit
+
+(* A compatHandler is called on two nodes that must have an equal
+ * representation. This should put an ECompat edge between those two nodes.
+ *)
+type compatHandler = N.chain -> Cil.typ -> Cil.typ -> unit
+
+(* Idealized representation of C types to make structural equality
+ * comparisons easier. *)
+type layout =
+ Scalar of int (* length in bits *)
+ | Array of typ * (layout list) * int
+ (* original array type, layout of element type, size *)
+ | Pointer of typ (* original CIL pointer type
+ * either TPtr or TFun *)
+ (* GN: why not TPtr(TFun... )? *)
+ | Function of typ (* GN: add this one for TFun *)
+ | Anything of int (* length in bits, matches anything *)
+ | Padding of int (* sm: pad out to a specific bit boundary *)
+
+(* use this instead of "l1 = l2" because OCaml structural equality may
+ * exhaust all memory checking Cil.typ, and layout lists mention Cil.typs.
+ *)
+let rec ll_eq_simple (l1 : layout list) (l2 : layout list) : bool =
+ match l1, l2 with
+ [], [] -> true
+ | Array(_,left,i) :: tl1 , Array(_,right,j) :: tl2 ->
+ (i = j) && (ll_eq_simple left right) && (ll_eq_simple tl1 tl2)
+ | Pointer(t1) :: tl1, Pointer(t2) :: tl2
+ | Function(t1) :: tl1, Function(t2) :: tl2 ->
+ typeSig t1 = typeSig t2 && ll_eq_simple tl1 tl2
+ | Anything(i) :: tl1, Anything(j) :: tl2 ->
+ i = j && ll_eq_simple tl1 tl2
+ | Padding(i) :: tl1, Padding(j) :: tl2 ->
+ i = j && ll_eq_simple tl1 tl2
+ | _ -> false
+
+let is_array (l: layout) : bool =
+ match l with
+ Array(_) -> true
+ | _ -> false
+
+(* Pretty printing *)
+let rec d_layout () l = match l with
+ Scalar(i) -> dprintf "Scalar(%d)" i
+ | Anything(i) -> dprintf "Anything(%d)" i
+ | Array(_,ll,i) -> dprintf "Array %d %a" i d_layout_list ll
+ | Pointer(tau) -> dprintf "Ptr (%a)" d_type tau
+ | Function(tau) -> dprintf "Fun (%a)" d_type tau
+ | Padding(i) -> dprintf "Pad(%d)" i
+and d_layout_list () ll =
+ dprintf "@[[%a]@]" (docList ~sep:(chr ';' ++ break) (d_layout ())) ll
+
+let global_layout_list_cache = Hashtbl.create 2047
+
+(* does a CIL type's representation include any doubles? *)
+let rec has_doubles (orig_t : typ) : bool =
+ let t = unrollType orig_t in
+ match t with
+ | TFloat (FDouble, _) -> true
+ | TArray (tau,_,_) -> (has_doubles tau) (* should sizeless be false? *)
+ | TComp (ci,_) ->
+ let test (fi: fieldinfo) : bool =
+ (has_doubles fi.ftype)
+ in
+ (List.exists test ci.cfields)
+ | _ -> false
+
+(* Convert a C/CIL type into a list of layouts. This usually amounts
+ * to flattening structures and making padding and alignment explicit. *)
+let rec convert_type_to_layout_list (orig_t : typ) =
+ let t = unrollType orig_t in
+ let result =
+ match t with
+ TVoid _ -> (* failwith "convert_type_to_layout_list: void" *) []
+ | TFloat (FDouble, _) when newPadding ->
+ (* sm: wide scalar is preceded by padding to its width; I also
+ * follow it with padding to make it clear that it ends on a 64-bit
+ * boundary, for compatibility with a type where a struct ends
+ * after a double *)
+ [Padding(64); Scalar(64); Padding(64)]
+ | TInt _ | TFloat _ | TEnum _ ->
+ [Scalar((try bitsSizeOf t with SizeOfError _ -> 0))]
+ | TPtr(_) -> [Pointer(t)]
+ | TFun(_) -> [Function(t)] (* gn: was [Pointer(t)] *)
+
+ | TArray(tau,Some(e),_) when e = one -> convert_type_to_layout_list tau
+ | TArray(tau,Some(e),_) ->
+ let ll = convert_type_to_layout_list tau in
+ let e = constFold true e in
+ let len = begin match isInteger e with
+ Some(i64) -> Int64.to_int i64
+ | None ->
+ E.s (E.unimp
+ "type: convert_type_to_layout_list: non-const length %a"
+ d_type t)
+ end in
+ ( match ll with
+ [Scalar(length)] ->
+ (* [Scalar(length * len)] *)
+ if (length = 0) then begin
+ ignore (E.warn "type: convert_type_to_layout_list: array contains nothing: %a" d_type t)
+ end ;
+ [Array(t,[Scalar(length*len)],1)]
+ | _ -> [Array(t,ll,len)])
+ | TArray(tau,None,al) ->
+ convert_type_to_layout_list (TArray (tau,Some zero,al))
+ | TComp(ci,al) when ci.cstruct ->
+ let total_size = try (bitsSizeOf t) with SizeOfError _ -> 0 in
+ let seen_size = ref 0 in
+ let ll = ref [] in
+ List.iter (fun fi ->
+ let field_size_bits =
+ match fi.fbitfield with
+ Some(size) -> size
+ | None -> (try bitsSizeOf fi.ftype with SizeOfError _ -> 0)
+ in
+ let field_offset_bits, field_width_bits =
+ (try bitsOffset t (Field(fi,NoOffset)) with SizeOfError _ -> 0,0) in
+ let field_offset = field_offset_bits in
+ if (!seen_size < field_offset) then begin
+ ll := !ll @ [Scalar(field_offset - !seen_size)];
+ seen_size := field_offset
+ end ;
+ let field_ll = match fi.fbitfield with
+ Some(size) -> [Scalar(size)]
+ | None -> convert_type_to_layout_list fi.ftype
+ in
+ ll := !ll @ field_ll ;
+ seen_size := !seen_size + field_size_bits ;
+ ) ci.cfields ;
+ if (!seen_size < total_size) then begin
+ ll := !ll @ [Scalar(total_size - !seen_size)];
+ end ;
+ if (newPadding && (has_doubles t)) then
+ (* sm: alignment padding at start and end *)
+ [Padding(64)] @ !ll @ [Padding(64)]
+ else
+ !ll
+ (* Unions. We have already added (in markptr) casts from the longest field
+ * to all of the others. From now on it is safe to work with the longest
+ * field instead of the union *)
+ | TComp(ci,al) when not ci.cstruct ->
+ let rec longest (sofar: typ) (sofarsize: int) = function
+ [] ->
+ if sofarsize = 0 then
+ E.s (bug "type: convert_type_to_layout_list: Could not find the longest field in %s\n"
+ (compFullName ci))
+ else
+ sofar
+
+ | fi :: restfi ->
+ let this_size =
+ try bitsSizeOf fi.ftype with SizeOfError _ -> 0 in
+ if this_size > sofarsize then
+ longest fi.ftype this_size restfi
+ else
+ longest sofar sofarsize restfi
+ in
+ convert_type_to_layout_list (longest voidType 0 ci.cfields)
+ | TComp _ -> E.s (E.bug "type: convert_type_to_layout_list: mystery comp")
+ | TNamed _ -> E.s (E.bug "type: convert_type_to_layout_list: named")
+ | TBuiltin_va_list _ ->
+ E.s (E.bug "type: convert_type_to_layout_list: va_list")
+ in
+
+ (* strip leading padding; this is needed so that a struct that has
+ * no doubles can be a subtype of one that has them after the common
+ * prefix (test/small2/subtypebug2.c) *)
+ let rec strip_lead_pad (ll : layout list) : layout list =
+ match ll with
+ | Padding(i) :: tl -> (strip_lead_pad tl)
+ | _ -> ll
+ in
+
+ (* peephole optimization for layout lists *)
+ let rec peephole ll =
+ match ll with
+ [] -> []
+ | Scalar(i) :: Scalar(j) :: tl -> peephole (Scalar(i+j) :: tl)
+ | Padding(i) :: Padding(j) :: tl ->
+ (* sm: larger padding dominates (assuming all are powers of 2...) *)
+ (peephole ((Padding(max i j)) :: tl))
+ | hd :: tl -> hd :: (peephole tl)
+ in
+
+ (peephole (strip_lead_pad result))
+
+(* Strips 'i' bits of scalars from the beginning of the layout list 'll'.
+ * This is a utility function called by equal_ll.
+ * Returns a boolean success code and new layout list representing the
+ * suffix or raises an exception on failure. *)
+let rec strip_scalar_prefix (ll : layout list) i =
+ if i = 0 then
+ true, ll
+ else if i < 0 then
+ true, (Scalar(-i) :: ll)
+ else match ll with
+ [] -> false, []
+ | Scalar(j) :: tl -> (strip_scalar_prefix tl (i - j))
+ | Anything(j) :: tl ->
+ if (i >= j) then (* eat up the entire "Anything" *)
+ (strip_scalar_prefix tl (i - j))
+ else
+ true, (Anything(j - i) :: tl)
+ | Padding(j) :: tl -> E.s (E.bug "strip_scalar_prefix applied to padding")
+ | Array(_,inner_ll,0) :: tl -> (strip_scalar_prefix tl i)
+ | Array(_,inner_ll,1) :: tl -> (strip_scalar_prefix (inner_ll @ tl) i)
+ | Array(tau,inner_ll,j) :: tl ->
+ let new_ll = inner_ll @ (Array(tau,inner_ll,j-1) :: tl) in
+ (strip_scalar_prefix new_ll i )
+ | Pointer(_) :: tl
+ | Function(_) :: tl ->
+ let _, res = strip_scalar_prefix (Scalar(4*8) :: tl) i in
+ false, res
+ (* Consider the following code:
+ * void ( * fptr )() ;
+ * int *x;
+ *
+ * x = ( int * ) fptr;
+ *
+ * In this case, we will end up comparing a scalar with a function,
+ * so we will want to call strip_scalar_prefix on a function. It
+ * should return false. *)
+
+(* When we are computing "t1 < t2" or "t1 > t2", which one can be
+ * smaller? *)
+type subtype_direction = LeftCanEndEarly | RightCanEndEarly | MustBeEqual
+
+let flip_subtyping st = match st with
+ LeftCanEndEarly -> RightCanEndEarly
+ | RightCanEndEarly -> LeftCanEndEarly
+ | MustBeEqual -> MustBeEqual
+
+(* for debugging output *)
+let subtype_direction_name (st: subtype_direction) : string = match st with
+ LeftCanEndEarly -> "LeftCanEndEarly"
+ | RightCanEndEarly -> "RightCanEndEarly"
+ | MustBeEqual -> "MustBeEqual"
+
+(*
+ * Check to see if a type is made up entirely of scalars.
+ *)
+let all_scalars
+ ?(replace=(fun a -> a, N.mkRIdent))
+ t1
+=
+ let t1,ex1 (* ex1: orig_t1 -> t1 *) = replace (unrollType t1) in
+ (* GN: another implementation, that seems to work in the presence of unions *)
+ not (existsType (function TPtr _ -> ExistsTrue | _ -> ExistsMaybe) t1)
+(*
+ try
+ let ll = convert_type_to_layout_list t1 in
+ let rec all_scalars_ll ll = match ll with
+ | [] -> true
+ | [Scalar(_)] -> true
+ | Array(_,ll,_) :: tl -> (all_scalars_ll ll) && (all_scalars_ll tl)
+ | _ -> false
+ in
+ all_scalars_ll ll
+ with e -> begin
+ ignore (E.warn "all_scalars raises %s\n" (Printexc.to_string e));
+ false
+ end
+*)
+
+(* These memoization tables store results from previous calls to "compare" *)
+let memoize_equal = Hashtbl.create 32767
+let memoize_subtype = Hashtbl.create 32767
+
+(* This is the main (conceptual) entry point for this file.
+ *
+ * Use physical subtyping (a la Reps, etc.) to determine the relationship
+ * between t1 and t2. In general, this is similar to width subtyping (like
+ * in object oriented languages) with the following exceptions:
+ *
+ * (1) "void*" is treated as a type variable and special handling exists
+ * to replace a "void*" with its representative type. Any direct
+ * comparison with a representative-less "void*" type succeeds.
+ * (2) A special "compat" function is called on all pointers that must have
+ * the same physical representation and on all pointers that area
+ * compared against a representative-less "void*" type.
+ * (3) A special "failure" function is called on all internal pointers that
+ * "fail to match up correctly" and must thus have their types checked
+ * at run-time (e.g., by making them WILD in CCured). "compare" can
+ * return true even if some lower-level pointers fail to match up,
+ * provided that it calls "failure" on them.
+ *
+ * Because memoization is used to prevent this from taking too much time
+ * over the course of the analysis, "compat" and "failure" are only
+ * guaranteed to be called once per pair of types, even across many
+ * invocations of "compare".
+ *)
+let rec compare
+ (compat: compatHandler)
+ (failure: failureHandler)
+ (why_t1_t2: N.chain) (* Goes t1 -> t2 *)
+ (t1: typ)
+ (t2: typ)
+ (mode: subtype_direction) : bool
+=
+ let t1r, why_t1_t1r = polymorphic_replace (unrollType t1) in
+ let t2r, why_t2_t2r = polymorphic_replace (unrollType t2) in
+ (* explanation: t1r -> t1 -> t2 -> t2r *)
+ let why_t1r_t2r =
+ N.mkRTrans (N.mkRSym why_t1_t1r) (N.mkRTrans why_t1_t2 why_t2_t2r) in
+
+ if ok_to_call_compat t1r t2r then begin
+ if useCompatOnRepresentative then
+ compat why_t1r_t2r t1r t2r
+ else
+ compat why_t1_t2 t1 t2;
+ end ;
+
+ if debugType then begin
+ ignore (E.log "compare: %a %a@!" d_type t1r d_type t2r)
+ end ;
+
+ (* Can we short-circuit this calculation because one of them is a
+ * "void*", a type variable? *)
+ if isVoidPtrType t1r || isVoidPtrType t2r then
+ true
+ else
+ (* Can we short-circuit this calculation because we have considered these
+ * two types before, and they are thus in our memoization tables? *)
+ let already_seen, old_answer =
+ (* if they are equal, they are certainly sub-types *)
+ if Hashtbl.mem memoize_equal (t1r,t2r) then
+ true, Hashtbl.find memoize_equal (t1r,t2r)
+ else if Hashtbl.mem memoize_equal (t2r,t1r) then
+ true, Hashtbl.find memoize_equal (t2r,t1r)
+ (* they are not equal, but perhaps we have considered this
+ * subtyping comparison before *)
+ else match mode with
+ LeftCanEndEarly ->
+ if Hashtbl.mem memoize_subtype (t1r,t2r) then
+ true, Hashtbl.find memoize_subtype (t1r,t2r)
+ else
+ false, false
+ | RightCanEndEarly ->
+ if Hashtbl.mem memoize_subtype (t2r,t1r) then
+ true, Hashtbl.find memoize_subtype (t2r,t1r)
+ else
+ false, false
+ | MustBeEqual ->
+ false, false
+ in if already_seen then old_answer
+ else if
+ (* Can we short-circuit this calculation because the sizes are clearly
+ * wrong? *)
+ let s1 = try Some(bitsSizeOf t1r) with SizeOfError _ -> None in
+ let s2 = try Some(bitsSizeOf t2r) with SizeOfError _ -> None in
+ match mode,s1,s2 with
+ LeftCanEndEarly,Some(s1),Some(s2) -> s1 > s2
+ | RightCanEndEarly,Some(s1),Some(s2) -> s1 < s2
+ | MustBeEqual,Some(s1),Some(s2) -> s1 <> s2
+ | _ -> false
+ then
+ false
+ else if (* Can we short-circuit this based on typesigs? *)
+ (typeSig t1r) = (typeSig t2r) then
+ true
+ else
+ (* Looks like we must actually do the calculation. *)
+ let l1 = convert_type_to_layout_list t1r in
+ let l2 = convert_type_to_layout_list t2r in
+ if debugType then begin
+ ignore (E.log "compare: %a = %a@!" d_type t1r d_layout_list l1) ;
+ ignore (E.log "compare: %a = %a@!" d_type t2r d_layout_list l2) ;
+ end ;
+ let answer =
+ (* Try one last time to short-circuit the long calculation based on a
+ * simple equality-check for layout lists *)
+ if ll_eq_simple l1 l2 then
+ true
+ else begin
+ (* In order to make this algorithm terminate, we cannot recursively
+ * consider this particular comparison. We know that (t1r,t2r) is
+ * not in the memoize_equal hash table at all at this point. *)
+ Hashtbl.replace memoize_equal (t1r,t2r) true ;
+ let result = equal_ll l1 l2 mode compat failure why_t1r_t2r in
+ Hashtbl.remove memoize_equal (t1r,t2r) ;
+ result
+ end
+ in
+ begin
+ (* update our memoization tables so that we never compute this
+ * answer again *)
+ match mode with
+ LeftCanEndEarly -> Hashtbl.add memoize_subtype (t1r,t2r) answer
+ | RightCanEndEarly -> Hashtbl.add memoize_subtype (t2r,t1r) answer
+ | MustBeEqual -> Hashtbl.add memoize_equal (t1r,t2r) answer
+ end ;
+ if debugType then begin
+ ignore (E.log "compare: %b %a %a@!" answer d_type t1r d_type t2r)
+ end ;
+ answer
+
+(*
+ * arguments:
+ * l1 l2 // check and see if these two layout lists are equal
+ * subtyping // which one of these lists can end early?
+ * compat // call this function on all lined-up pointers in l1, l2
+ * failure // call on pointer types that fail to match up
+ * why_l1_l2 // why are we comparing l1 and l2?
+ *)
+and equal_ll
+ (l1:layout list)
+ (l2: layout list)
+ (subtyping: subtype_direction)
+ (compat: compatHandler)
+ (failure: failureHandler)
+ (why_l1_l2: N.chain)
+=
+ if debugType then
+ ignore (E.log "equal_ll (%s):@!%a@!%a@!"
+ (subtype_direction_name subtyping)
+ d_layout_list l1 d_layout_list l2);
+
+ (* pulled this out b/c ocaml won't let me combine two match clauses
+ * when they have 'when' limiters... *)
+ let padding_mismatch () : bool =
+ if logPaddingMismatches then
+ ignore (E.log "padding mismatch:@! %a@! %a@!"
+ d_layout_list l1 d_layout_list l2);
+ (* sm: Wes and I concluded that we do not need to check the tails,
+ * because by returning false here (and not simply calling 'failure'),
+ * we guarantee that all pointers in both structures will become wild *)
+ false
+ in
+
+ let final_answer =
+ match l1, l2 with
+ [], [] -> (true)
+ | [], _ when subtyping = LeftCanEndEarly -> (true)
+ | _, [] when subtyping = RightCanEndEarly -> (true)
+
+ | [], _
+ | _, [] -> (false)
+
+ (* sm: padding must match with padding *)
+ | (Padding(i) :: tl1), (Padding(j) :: tl2) ->
+ i = j && equal_ll tl1 tl2 subtyping compat failure why_l1_l2
+
+ (* padding mismatch.
+ * hack: If the other side is an Array, then we need to unroll it.
+ * So, the 'when' clause prevents this one from matching, so it
+ * will instead match the Array clauses below. I wanted to just move
+ * the array clauses to the top, but that causes a problem since
+ * the Scalar clause would be below the Array clause; see
+ * test/small2/subtypebug1.c. test/small2/getaddrinfo.c is a
+ * test that reveals the need for the 'when' in the first place. *)
+ | (Padding(_) :: _), (hd2 :: _) when (not (is_array hd2)) ->
+ padding_mismatch()
+ | (hd1 :: _), (Padding(_) :: _) when (not (is_array hd1)) ->
+ padding_mismatch()
+
+ | (Scalar(i) :: tl), _ ->
+ let new_l1 = tl in
+ let worked, new_l2 = strip_scalar_prefix l2 i in
+ let answer = equal_ll new_l1 new_l2 subtyping compat failure why_l1_l2 in
+ (answer && worked)
+
+ | (Anything(i) :: tl), _ ->
+ let new_l1 = tl in
+ let _, new_l2 = strip_scalar_prefix l2 i in
+ equal_ll new_l1 new_l2 subtyping compat failure why_l1_l2
+
+ (* array on left *)
+ | (Array(tau1,inner_ll1, i1) :: tl1) , _ ->
+ (* first, handle special case where we match up arrays *)
+ let same = ref false in
+ let remove_1 = ref None in
+ let remove_2 = ref None in
+ (match l2 with
+ Array(tau2,inner_ll2, i2) :: tl2 ->
+ Hashtbl.replace arraysThatHaveBeenComparedWithArrays
+ (tau1,tau2) why_l1_l2 ;
+ (* When we unpeel these guys, it will look like they are being
+ * compared against non-arrays when we compare them against
+ * their respective contents. So we remember now if they had
+ * a clean slate before and we'll reclean it later before
+ * we return. *)
+ if not (Hashtbl.mem arraysThatHaveBeenComparedWithNonArrays tau1)
+ then remove_1 := Some(tau1) ;
+ if not (Hashtbl.mem arraysThatHaveBeenComparedWithNonArrays tau2)
+ then remove_2 := Some(tau2) ;
+ if (i1 = i2 && ll_eq_simple inner_ll1 inner_ll2) then
+ same := true
+ | _ ->
+ Hashtbl.replace arraysThatHaveBeenComparedWithNonArrays
+ tau1 why_l1_l2
+ ) ;
+ if !same then
+ true
+ else begin
+ let new_l1 =
+ if i1 = 0 then
+ tl1
+ else if i1 = 1 then
+ inner_ll1 @ tl1
+ else
+ inner_ll1 @ (Array(tau1,inner_ll1,i1-1) :: tl1)
+ in
+ let final_answer = equal_ll new_l1 l2 subtyping compat failure why_l1_l2
+ in
+ (match !remove_1 with
+ Some(t) -> Hashtbl.remove arraysThatHaveBeenComparedWithNonArrays t
+ | _ -> () ) ;
+ (match !remove_2 with
+ Some(t) -> Hashtbl.remove arraysThatHaveBeenComparedWithNonArrays t
+ | _ -> () ) ;
+ final_answer
+ end
+
+ (* array/anything on right *)
+ | _, (Array(_) :: _)
+ | _, (Anything(_) :: _) ->
+ (* flip things around, use the code above *)
+ equal_ll l2 l1 (flip_subtyping subtyping) compat failure
+ (N.mkRSym why_l1_l2)
+
+ | (Pointer(tau1) :: tl1) , (Pointer(tau2) :: tl2) ->
+ (* already unrolled *)
+ let tau1r, why_tau1_tau1r = polymorphic_replace (unrollType tau1) in
+ let tau2r, why_tau2_tau2r = polymorphic_replace (unrollType tau2) in
+ if debugType then
+ ignore (E.log "Type.equal_ll for@! @[%a@]@!and @[%a@]@!@!"
+ d_type tau1r d_type tau2r);
+ (* explanation: tau1r -> tau1 -> tau2 -> tau2r *)
+ let why_tau1r_tau2r =
+ N.mkRTrans (N.mkRSym why_tau1_tau1r)
+ (N.mkRTrans why_l1_l2 why_tau2_tau2r) in
+
+ (if useCompatOnRepresentative then
+ (if ok_to_call_compat tau1r tau2r then
+ compat why_tau1r_tau2r tau1r tau2r)
+ else
+ (if ok_to_call_compat tau1 tau2 then
+ compat why_l1_l2 tau1 tau2));
+
+ if isVoidPtrType tau1r || isVoidPtrType tau2r then
+ () (* no recursive calls *)
+ else begin
+ match tau1r, tau2r with
+ | TPtr(inner1,a1), TPtr(inner2,a2) -> begin (* two non-fun pointers *)
+ if debugType then
+ ignore (E.log "Type.equal_ll doing inner pointers@! @[%a@]@!and @[%a@]@!@!"
+ d_type inner1 d_type inner2);
+ let answer =
+ compare compat failure why_tau1r_tau2r inner1 inner2 MustBeEqual
+ in
+ if not answer then begin
+ (* Get the nodes involved *)
+ let n1 =
+ match N.nodeOfAttrlist a1 with
+ Some n1 -> n1
+ | _ -> E.s (bug "Type.equal_ll: type %a does not have a node"
+ d_type tau1r)
+ in
+ let n2 =
+ match N.nodeOfAttrlist a2 with
+ Some n2 -> n2
+ | _ -> E.s (bug "Type.equal_ll: type %a does not have a node"
+ d_type tau2r)
+ in
+ if debugType then
+ ignore (E.log "Call failure %d and %d (from Inner)\n"
+ n1.N.id n2.N.id);
+ failure n1 why_tau1r_tau2r n2;
+ end
+ end
+
+ | TInt _, _
+ | _ , TInt _ ->
+ (* We thought one of these was a pointer, but its rep was
+ * an integer. In this case we just put the pointer in the same
+ * EQ class as the void* and let our logic in the solver work
+ * it out. They are not compatible, and our check in the solver
+ * with the compatWithScalars flag should notice that and
+ * make them WILD. *)
+ if ok_to_call_compat tau1 tau2 then (* should always be true *)
+ compat why_l1_l2 tau1 tau2
+
+ | _, _ -> E.s (E.bug "type: unexpected mystery pointers %a and %a"
+ d_type tau1r d_type tau2r)
+ end ;
+
+ (* Note that because we are assuming that "failure" makes its
+ * arguments WILD (or otherwise invisible to physical subtyping), we
+ * don't actually need to know whether the above check passed or
+ * failed at all. If it passed, the types are fine so far. If it
+ * failed, those two pointers will be made WILD, so they will be
+ * checked at run-time, so these two lists are still fine. *)
+ (* Now check the rest of the layout list! *)
+ equal_ll tl1 tl2 subtyping compat failure why_l1_l2
+
+ (* Compare two functions *)
+ | Function(TFun(rt1,vlo1,_,_) as t1) :: tl1,
+ Function(TFun(rt2,vlo2,_,_) as t2) :: tl2 ->
+ (* two fun ptrs *)
+ (* Check return types *)
+ let rt1r, why_rt1_rt1r = polymorphic_replace (unrollType rt1) in
+ let rt2r, why_rt2_rt2r = polymorphic_replace (unrollType rt2) in
+ (* explanation: rt1r -> rt1 -> rt2 -> rt2r *)
+ let why_rt1r_rt2r = N.mkRTrans (N.mkRSym why_rt1_rt1r)
+ (N.mkRTrans why_l1_l2 why_rt2_rt2r) in
+ (if useCompatOnRepresentative then
+ (if ok_to_call_compat rt1r rt2r then
+ compat why_rt1r_rt2r rt1r rt2r)
+ else
+ (if ok_to_call_compat rt1 rt2 then
+ compat why_l1_l2 rt1 rt2));
+ let ret_ok =
+ compare compat failure why_rt1r_rt2r rt1r rt2r MustBeEqual in
+ if debugType then
+ ignore (E.log "Type.equal_ll preparing to do arguments of@! @[%a@]@!and @[%a@]@!@!" d_type t1 d_type t2);
+ (* Check the arguments *)
+ let al1 = argsToList vlo1 in
+ let al2 = argsToList vlo2 in
+ let args_ok =
+ if List.length al1 <> List.length al2 then begin
+ false
+ end else begin
+ (* check every argument *)
+ let answer = ref true in
+ let compareFormalNames = ref false in
+ List.iter2 (fun (_, arg1t, _) (_, arg2t, _) ->
+ let at1r, why_argt1_at1r = polymorphic_replace (unrollType arg1t) in
+ let at2r, why_argt2_at2r = polymorphic_replace (unrollType arg2t) in
+ (* explanation: at1r -> argt1 -> argt2 -> at2r *)
+ let why_at1r_at2r =
+ N.mkRTrans (N.mkRSym why_argt1_at1r)
+ (N.mkRTrans why_l1_l2 why_argt2_at2r) in
+ if debugType then
+ ignore (E.log "Type.equal_ll doing argument@! @[%a@]@!and @[%a@]@!@!" d_type at1r d_type at2r);
+ (if useCompatOnRepresentative then
+ (if ok_to_call_compat at1r at2r then
+ compat why_at1r_at2r at1r at2r)
+ else
+ (if ok_to_call_compat arg1t arg2t then
+ compat why_l1_l2 arg1t arg2t));
+ let ans =
+ compare compat failure why_at1r_at2r at1r at2r MustBeEqual in
+ answer := ans && !answer ;
+
+ (* matth: this doesn't belong here, but I don't know where to put
+ it. Make sure the formal types agree on __COUNT and __SIZE
+ attributes. This prevents casting away of these attributes with
+ function pointers. *)
+ let a1 = typeAttrs at1r in
+ let a2 = typeAttrs at2r in
+ let doCheck what =
+ let a1f = filterAttributes what a1 in
+ if a1f <> filterAttributes what a2 then begin
+ ignore (warn
+ "Mismatched \"%s\" attributes in@! @[%a@]@!and @[%a@]@!@!"
+ what d_type at1r d_type at2r);
+ answer := false
+ end;
+ if a1f <> [] then
+ compareFormalNames := true;
+ in
+ doCheck "size";
+ doCheck "count";
+ )
+ al1 al2 ;
+ if !compareFormalNames then begin
+ (* If any formal has a SIZE or COUNT attribute, make sure that
+ all of the names of the formals match. See small2/size3.c
+ test funcptr_wrongorder. *)
+ List.iter2
+ (fun (name1, arg1t, _) (name2, _, _) ->
+ let hasSizeOrCount t =
+ let a = typeAttrs t in
+ (hasAttribute "size" a) || (hasAttribute "count" a)
+ in
+ if name1 <> name2
+ (* If this formal has a SIZE or COUNT annotation,
+ it's been renamed already. But no other formal can
+ depend on it, so it's okay to skip this case. *)
+ && (not (hasSizeOrCount arg1t)) then begin
+ ignore (warn
+ "The names of formals \"%s\" and \"%s\" must match when using SIZE/COUNT."
+ name1 name2);
+ answer := false
+ end)
+ al1 al2
+ end;
+ !answer
+ end
+ in
+ (* now check the rest of the layout list! *)
+ let (restok) = equal_ll tl1 tl2 subtyping compat failure why_l1_l2 in
+ (* We have to return false if either the args of the returns are not Ok *)
+ (restok && args_ok && ret_ok)
+
+
+ (* This match case is used: in particular 'something' could be
+ * Scalar(i) *)
+ | (Pointer(p) :: tl1) , something when isVoidType p ->
+ (* special scalar node handling *)
+ E.s (E.bug "type: unify Ptr(%a) with the scalar node" d_type p)
+
+ | (_ :: tl1), (_ :: tl2) -> (* NOT EQUAL *)
+ (* but check the rest anyway! *)
+ let _ = equal_ll tl1 tl2 subtyping compat failure why_l1_l2 in
+ false
+ in
+ (* ignore (E.warn "subtype: %b@!%a@!%a"
+ final_answer d_layout_list l1 d_layout_list l2) ;*)
+ (final_answer)
+
+
+(* subtype and equal both just call "compare" *)
+let subtype ~(compat:compatHandler)
+ ~(failure:failureHandler)
+ ~(why_small_big:Ptrnode.chain)
+ ~(small:Cil.typ)
+ ~(big:Cil.typ) : bool =
+ compare compat failure why_small_big small big LeftCanEndEarly
+
+
+let equal ~(compat:compatHandler)
+ ~(failure:failureHandler)
+ ~(why_t1_t2:Ptrnode.chain)
+ ~(t1:Cil.typ)
+ ~(t2:Cil.typ) : bool =
+ compare compat failure why_t1_t2 t1 t2 MustBeEqual
+
+(* Ptrnode.ml needs to call subtype *)
+let init () =
+ N.isSubtype :=
+ fun big small ->
+ try
+ subtype
+ ~compat:(fun _ _ _ -> ())
+ ~failure:(fun _ _ _ -> raise Not_found)
+ ~why_small_big:N.mkRIdent
+ ~small:small
+ ~big:big
+ with Not_found ->
+ false
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2006,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(*
+ * C Structural Type Equality
+ *)
+val debugType: bool
+
+
+(* Initialize the type module *)
+val init: unit -> unit
+
+(* A failure handler is called on two nodes whose base types fail to match
+ * up. This should make those nodes have WILD types (and thus force them to
+ * match up) *)
+type failureHandler = Ptrnode.node -> Ptrnode.chain -> Ptrnode.node -> unit
+
+(* A compatHandler is called on two nodes that must have an equal
+ * representation. This should put an ECompat edge between those two nodes.
+ *)
+type compatHandler = Ptrnode.chain -> Cil.typ -> Cil.typ -> unit
+
+
+(** Use this function to replace a void-ptr with its representative. The
+ * resulting chain is always orig_type -> type. *)
+val polymorphic_replace: Cil.typ -> Cil.typ * Ptrnode.chain
+
+(* This is the main (conceptual) entry point for this file.
+ *
+ * These remarks apply to "subtype" and "equal", both of which are
+ * implemented using an underlying function called "compare".
+ *
+ * Use physical subtyping (a la Reps, etc.) to determine the relationship
+ * between t1 and t2. In general, this is similar to width subtyping (like
+ * in object oriented languages) with the following exceptions:
+ *
+ * (1) "void*" is treated as a type variable and special handling exists
+ * to replace a "void*" with its representative type. Any direct
+ * comparison with a representative-less "void*" type succeeds.
+ * (2) A special "compat" function is called on all pointers that must have
+ * the same physical representation and on all pointers that area
+ * compared against a representative-less "void*" type.
+ * (3) A special "failure" function is called on all internal pointers that
+ * "fail to match up correctly" and must thus have their types checked
+ * at run-time (e.g., by making them WILD in CCured). "compare" can
+ * return true even if some lower-level pointers fail to match up,
+ * provided that it calls "failure" on them.
+ *
+ * Because memoization is used to prevent this from taking too much time
+ * over the course of the analysis, "compat" and "failure" are only
+ * guaranteed to be called once per pair of types, even across many
+ * invocations of "compare".
+ *)
+val subtype: compat:compatHandler ->
+ (* Failure is invoked with the two types involved and the chain
+ * between them *)
+ failure:failureHandler ->
+ why_small_big: Ptrnode.chain -> (* Goes small -> big *)
+ small:Cil.typ ->
+ big:Cil.typ -> bool
+
+
+val equal: compat:compatHandler ->
+ (* Failure is invoked with the two types involved and the chain
+ * between them *)
+ failure: failureHandler ->
+ why_t1_t2: Ptrnode.chain ->
+ t1:Cil.typ ->
+ t2:Cil.typ -> bool
+
+val all_scalars: ?replace: (Cil.typ -> Cil.typ * Ptrnode.chain) ->
+ Cil.typ -> bool
+
+val arraysThatHaveBeenComparedWithNonArrays: (Cil.typ, Ptrnode.chain) Hashtbl.t
+
+val arraysThatHaveBeenComparedWithArrays: (Cil.typ * Cil.typ, Ptrnode.chain) Hashtbl.t
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2006,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(*
+ * Union-Find Functor (no side effects, purely applicative)
+ *
+ * (used by physical type equality to keep equivalence classes of types)
+ *)
+module N = Ptrnode
+module E = Errormsg
+
+module type UF =
+ sig
+ type t
+
+ type elt
+
+ val empty : t
+
+ val check_equal : t -> elt -> elt -> bool
+
+ (* The chain is directed elt1 -> elt2 *)
+ val make_equal : t -> elt -> elt -> N.chain -> t
+
+ val eq_classes : t -> elt list list
+
+ val class_of : t -> elt -> elt list
+
+ (* Returns the chain why two elements are equal. Raises Failure if they
+ * are not actually equal *)
+ val why_equal : t -> elt -> elt -> N.chain
+ end
+
+
+module Make(S : Set.S) =
+ struct
+ (* An equivalence class supports membership queries and can also explain
+ * why two elements are equal *)
+ type aclass =
+ { set: S.t; (* For the membership query *)
+ why: whyset }
+ and whyset =
+ WSSingle of S.elt (* A singleton *)
+ (* Was formed by unioning aclass1 (containing elt1) and aclass2
+ * (containing elt2) with the given chain for elt1->elt2 *)
+ | WSUnion of aclass * S.elt * N.chain * S.elt * aclass
+
+ type t = aclass list
+
+ type elt = S.elt
+
+ let empty = []
+
+ let check_equal uf e1 e2 =
+ List.fold_left
+ (fun acc cls -> acc || (S.mem e1 cls.set && S.mem e2 cls.set)) false uf
+
+ exception AlreadyEqual
+ let make_equal (clss : aclass list) e1 e2 chain (* chain : e1->e2 *) =
+ (* Find the classes of e1 and e2 *)
+ let c1 : aclass ref = ref { set = S.singleton e1; why = WSSingle e1} in
+ let c2 : aclass ref = ref { set = S.singleton e2; why = WSSingle e2} in
+ (* Collect a list of the classes that do not contain e1 or e2 *)
+ try
+ let uninvolved : aclass list ref = ref [] in
+ List.iter (fun (cls : aclass) ->
+ if S.mem e1 cls.set then begin
+ if S.mem e2 cls.set then
+ raise AlreadyEqual
+ else
+ c1 := cls
+ end else if S.mem e2 cls.set then
+ c2 := cls
+ else
+ uninvolved := cls :: !uninvolved)
+ clss ;
+ let merged_set =
+ { set = S.union !c1.set !c2.set;
+ why = WSUnion (!c1, e1, chain, e2, !c2); }
+ in
+ let final_list_of_sets = merged_set :: !uninvolved in
+ (final_list_of_sets : aclass list)
+ with AlreadyEqual ->
+ clss
+
+ let eq_classes clss =
+ List.map (fun eqclass -> S.elements eqclass.set) clss
+
+ let class_of clss elt =
+ let rec search = function
+ [] -> []
+ | cls :: tl ->
+ if S.mem elt cls.set then S.elements cls.set else search tl
+ in
+ search clss
+
+ let why_equal (clss: aclass list) (e1: elt) (e2: elt) : N.chain =
+ (* Find the class of e1 *)
+ let cls =
+ try List.find (fun cls -> S.mem e1 cls.set) clss
+ with _ -> E.s (E.bug "why_equal: element not known") in
+ (* Check that e2 is in the same class *)
+ if not (S.mem e2 cls.set) then
+ E.s (E.bug "why_equal: not actually equal");
+ (* Now traverse the history of unions in reverse order. The invariant
+ * is that both e1 and e2 are in the set. *)
+ let rec whyLoop (e1: elt) (e2: elt) (why: whyset) =
+ (* Maybe they are equal *)
+ if compare e1 e2 = 0 then N.mkRIdent else
+ match why with
+ WSSingle _ -> E.s (E.bug "why_equal: equal elements")
+ | WSUnion (c1, e1', r', e2', c2) ->
+ if S.mem e1 c1.set then
+ if S.mem e2 c1.set then
+ (* Both e1 and e2 belong to c1 *)
+ whyLoop e1 e2 c1.why
+ else
+ (* e1 in c1 and e2 in c2 *)
+ N.mkRTrans (whyLoop e1 e1' c1.why)
+ (N.mkRTrans r'
+ (whyLoop e2' e2 c2.why))
+ else (* e1 in c2 *)
+ if S.mem e2 c2.set then
+ (* Both e1 and e2 in the c2 *)
+ whyLoop e1 e2 c2.why
+ else
+ (* e1 in c2 and e2 in c1 *)
+ N.mkRTrans (whyLoop e1 e2' c2.why)
+ (N.mkRTrans (N.mkRSym r')
+ (whyLoop e1' e2 c1.why))
+ in
+ whyLoop e1 e2 cls.why
+
+ end
+
+
+
+
--- /dev/null
+(*
+ * dinstrumenter.ml
+ *
+ * This module converts CIL to 3-address code, and then
+ * adds hooks for instrumentation.
+ *
+ *
+ *)
+
+open Cil
+open Pretty
+open Dcheckdef
+open Dutil
+
+module E = Errormsg
+
+let fixBlock = Dcheck.fixBlock ~giveID:false
+
+let mkInstrFun (name : string) (n : int) : exp =
+ let args = Util.list_init n (fun _ -> uintType) in
+ mkFun name voidType args
+
+let instrAssign = mkInstrFun "DINSTR_Assign" 5
+let instrBop = mkInstrFun "DINSTR_Bop" 10
+let instrUop = mkInstrFun "DINSTR_Uop" 6
+let instrPushArg = mkInstrFun "DINSTR_PushArg" 4
+let instrPopArg = mkInstrFun "DINSTR_PopArg" 1
+let instrUnRegLocal = mkInstrFun "DINSTR_UnRegLocal" 3
+let instrFunStart = mkInstrFun "DINSTR_FunStart" 1
+let instrRegField = mkInstrFun "DINSTR_RegField" 3
+let instrRegArray = mkInstrFun "DINSTR_RegArray" 4
+let instrCast = mkInstrFun "DINSTR_Cast" 5
+
+let instrRetBasic = mkInstrFun "DINSTR_RetBasic" 4
+let instrRetBop = mkInstrFun "DINSTR_RetBop" 9
+let instrRetUop = mkInstrFun "DINSTR_RetUop" 5
+let instrRetVoid = mkInstrFun "DINSTR_RetVoid" 0
+let instrPopRet = mkInstrFun "DINSTR_RetPop" 5
+let instrRetNoRet = mkInstrFun "DINSTR_RetNoRet" 1
+
+let instrIfBasic = mkInstrFun "DINSTR_IfBasic" 6
+let instrIfBop = mkInstrFun "DINSTR_IfBop" 11
+let instrIfUop = mkInstrFun "DINSTR_IfUop" 7
+
+let instrSwitchBasic = mkInstrFun "DINSTR_SwitchBasic" 5
+let instrSwitchBop = mkInstrFun "DINSTR_SwitchBop" 10
+let instrSwitchUop = mkInstrFun "DINSTR_SwitchUop" 6
+
+let instrCNonNull = mkInstrFun "DINSTR_CNonNull" 4
+let instrCEq = mkInstrFun "DINSTR_CEq" 8
+let instrCMult = mkInstrFun "DINSTR_CMult" 8
+let instrCPtrArith = mkInstrFun "DINSTR_CPtrArith" 17
+let instrCPtrArithNT = mkInstrFun "DINSTR_CPtrArithNT" 17
+let instrCPtrArithAccess = mkInstrFun "DINSTR_CPtrArithAccess" 17
+let instrCLeqInt = mkInstrFun "DINSTR_CLeqInt" 8
+let instrCLeq = mkInstrFun "DINSTR_CLeq" 10
+let instrCLeqSum = mkInstrFun "DINSTR_CLeqSum" 14
+let instrCSumLeq = mkInstrFun "DINSTR_CSumLeq" 14
+let instrCLeqNT = mkInstrFun "DINSTR_CLeqNT" 9
+let instrCNullOrLeq = mkInstrFun "DINSTR_CNullOrLeq" 12
+let instrCNullOrLeqNT = mkInstrFun "DINSTR_CNullOrLeqNT" 13
+let instrCWriteNT = mkInstrFun "DINSTR_CWriteNT" 13
+let instrCNullUnionOrSelected = mkInstrFun "DINSTR_CNullUnionOrSelected" 8
+let instrCSelected = mkInstrFun "DINSTR_CSelected" 4
+let instrCNotSelected = mkInstrFun "DINSTR_CNotSelected" 4
+
+let instrInit = mkInstrFun "DINSTR_init" 0
+let instrEnd = mkInstrFun "DINSTR_end" 0
+let instrNop = mkInstrFun "DINSTR_nop" 0
+
+let instrTaint = mkInstrFun "DINSTR_taint" 5
+let instrCTaint = mkInstrFun "DINSTR_ctaint" 8
+let instrArgv = mkInstrFun "DINSTR_Argv" 4
+
+let fileToken : exp = Lval(var (makeGlobalVar "__FILE__" charPtrType))
+let lineToken : exp = Lval(var (makeGlobalVar "__LINE__" uintType))
+
+let isInstrFun (i : instr) : bool =
+ match i with
+ | Call(_,Lval(Var vi, NoOffset),_,_) ->
+ (String.length vi.vname >= String.length "DINSTR_" &&
+ String.compare (String.sub vi.vname 0 7) "DINSTR_" = 0) ||
+ vi.vname = "caml_startup"
+ | _ -> false
+
+let isPtrCastableType (t : typ) : bool =
+ match unrollType t with
+ | TInt(_,_) | TPtr(_,_) | TArray(_,_,_) | TEnum(_,_) -> true
+ | _ -> false
+
+
+let constBop =
+ function
+ | PlusA -> integer 0
+ | PlusPI -> integer 1
+ | IndexPI -> integer 2
+ | MinusA -> integer 3
+ | MinusPI -> integer 4
+ | MinusPP -> integer 5
+ | Mult -> integer 6
+ | Div -> integer 7
+ | Mod -> integer 8
+ | Shiftlt -> integer 9
+ | Shiftrt -> integer 10
+ | Lt -> integer 11
+ | Gt -> integer 12
+ | Le -> integer 13
+ | Ge -> integer 14
+ | Eq -> integer 15
+ | Ne -> integer 16
+ | BAnd -> integer 17
+ | BXor -> integer 18
+ | BOr -> integer 19
+ | LAnd -> integer 20
+ | LOr -> integer 21
+let constUop =
+ function
+ | Neg -> integer 0
+ | BNot -> integer 1
+ | LNot -> integer 2
+
+let makeInstr (call : exp) (args : exp list) : instr =
+ if List.exists (fun e -> not(isPtrCastableType(typeOf e))) args then
+ Call(None,instrNop,[],locUnknown)
+ else
+ let args = List.map (fun e -> mkCast e uintType) args in
+ Call(None,call,args,locUnknown)
+
+let isSignedType (t : typ) : bool =
+ match unrollType t with
+ | TInt(ik,_) -> isSigned ik
+ | TEnum _ -> true
+ | _ -> false
+
+let baseType (t : typ) : typ option =
+ match unrollType t with
+ | TPtr(bt, _)
+ | TArray(bt,_,_) -> Some bt
+ | TInt _ -> Some voidType
+ | _ -> None
+
+let baseSize (t : typ) : int =
+ try
+ match baseType t with
+ | None -> 0
+ | Some t -> bitsSizeOf t / 8
+ with _ -> 0
+
+let integerSym = zero
+let pointerSym = one
+(* Takes a basic expression and returns the symbolic expression
+ * and a constant telling us to treat the symbolic expression as
+ * a constant or as the id of a symbolic variable *)
+let rec opToTypeAndSym (op : exp) : (exp * exp * exp) =
+ match op with
+ | Const _ ->
+ let size_exp =
+ if isSignedType (typeOf op) then
+ integer (-(bitsSizeOf(typeOf op)))
+ else
+ integer (bitsSizeOf (typeOf op))
+ in
+ (integerSym,size_exp,zero)
+ | AddrOf(_,_) | StartOf(_,_) ->
+ (pointerSym, integer (baseSize (typeOf op)), zero)
+ | Lval(Mem e, NoOffset) ->
+ (pointerSym, integer (baseSize (typeOf e)), e)
+ | Lval lv ->
+ if isPtrOrArray (typeOf op) then
+ (pointerSym, integer (baseSize (typeOf op)), AddrOf lv)
+ else if isSignedType (typeOf op) then
+ (integerSym, integer(-(bitsSizeOf(typeOf op))), AddrOf lv)
+ else
+ (integerSym, integer(bitsSizeOf(typeOf op)), AddrOf lv)
+ | CastE(t, op) ->
+ let (sym, sz, sop) = opToTypeAndSym op in
+ if isPtrOrArray t then
+ (pointerSym, integer (baseSize t), sop)
+ else if isSignedType t then
+ (integerSym, integer(-(bitsSizeOf t)), sop)
+ else
+ (integerSym, integer(bitsSizeOf t), sop)
+ | _ -> E.s(bug "opToTypeAndSym: exp not basic: %a\n" d_plainexp op)
+
+
+let makeCheckInstr (c : check) : instr list =
+ let split3 l =
+ let rec helper l acc1 acc2 acc3 =
+ match l with
+ | [] -> (List.rev acc1, List.rev acc2, List.rev acc3)
+ | (a,b,c)::rst ->
+ helper rst (a::acc1) (b::acc2) (c::acc3)
+ in
+ helper l [] [] []
+ in
+ let merge4 l1 l2 l3 l4 =
+ let rec helper l1 l2 l3 l4 acc =
+ match l1,l2,l3,l4 with
+ | [], [], [], [] -> List.rev acc
+ | x1::rst1, x2::rst2, x3::rst3, x4::rst4 ->
+ helper rst1 rst2 rst3 rst4 (x4::x3::x2::x1::acc)
+ | _, _, _, _ -> raise(Invalid_argument "merge4: different lengths")
+ in
+ helper l1 l2 l3 l4 []
+ in
+ let opsToArgList (ops : exp list) : exp list =
+ let typ ,sz, sops = split3 (List.map opToTypeAndSym ops) in
+ merge4 ops sops typ sz
+ in
+ match c with
+ | CNonNull op -> begin
+ match op with
+ | Lval(Var vi, off) ->
+ let (typ,sz,sop) = opToTypeAndSym op in
+ [makeInstr instrCNonNull [op;sop;typ;sz]]
+ | _ -> E.s(bug "makeCheckInstr: CNonNull of constant remains\n")
+ end
+ | CEq(op1,op2,s,dl) ->
+ [makeInstr instrCEq (opsToArgList [op1;op2])]
+ | CMult(op1,op2) ->
+ [makeInstr instrCMult (opsToArgList [op1;op2])]
+ | CPtrArith(op1,op2,op3,op4,sz) ->
+ let args_low = opsToArgList [op1;op3;op4] in
+ let args_up = opsToArgList [op3;op4;op2] in
+ [makeInstr instrCLeqSum (args_low@[fileToken;lineToken]);
+ makeInstr instrCSumLeq (args_up@[fileToken;lineToken])]
+ | CPtrArithNT(op1,op2,op3,op4,sz) ->
+ let args = (integer sz)::(opsToArgList [op1;op2;op3;op4]) in
+ [makeInstr instrCPtrArithNT args]
+ | CPtrArithAccess(op1,op2,op3,op4,sz) ->
+ let args = (integer sz)::(opsToArgList [op1;op2;op3;op4]) in
+ [makeInstr instrCPtrArithAccess args]
+ | CLeqInt(op1,op2,s) ->
+ [makeInstr instrCLeqInt (opsToArgList [op1;op2])]
+ | CLeq(op1,op2,s) ->
+ [makeInstr instrCLeq ((opsToArgList [op1;op2])@[fileToken;lineToken])]
+ | CLeqNT(op1,op2,sz,s) ->
+ let args = (integer sz)::(opsToArgList [op1;op2]) in
+ [makeInstr instrCLeqNT args]
+ | CNullOrLeq(op1,op2,op3,s) ->
+ [makeInstr instrCNullOrLeq (opsToArgList [op1;op2;op3])]
+ | CNullOrLeqNT(op1,op2,op3,sz,s) ->
+ let args = (integer sz)::(opsToArgList [op1;op2;op3]) in
+ [makeInstr instrCNullOrLeqNT args]
+ | CWriteNT(op1,op2,op3,sz) ->
+ let args = (integer sz)::(opsToArgList [op1;op2;op3]) in
+ [makeInstr instrCWriteNT args]
+ | CNullUnionOrSelected(lv,e) ->
+ [makeInstr instrCNullUnionOrSelected (opsToArgList [Lval lv;e])]
+ | CSelected e ->
+ [makeInstr instrCSelected (opsToArgList [e])]
+ | CNotSelected e ->
+ [makeInstr instrCNotSelected (opsToArgList [e])]
+
+
+let paramTrans (ap : attrparam)
+ (args : exp list)
+ (ro : lval option) : exp option =
+ match ap with
+ | AStar(ACons(is,[])) ->
+ if String.sub is 0 1 = "$" then begin
+ let nstr = String.sub is 1 ((String.length is) - 1) in
+ let i = int_of_string nstr in
+ if i = 0 then match ro with
+ | Some r -> Some(Lval(Mem (Lval r),NoOffset))
+ | None -> None
+ else Some(Lval(Mem(List.nth args (i-1)),NoOffset))
+ end else None
+ | ACons(is,[]) ->
+ if String.sub is 0 1 = "$" then begin
+ let nstr = String.sub is 1 ((String.length is) - 1) in
+ let i = int_of_string nstr in
+ if i = 0 then match ro with
+ | None -> None
+ | Some r -> Some(Lval r)
+ else Some(List.nth args (i-1))
+ end else None
+ | AInt i -> Some(integer i)
+ | _ -> None
+
+
+let rec drop (l : 'a list) (n : int) : 'a list =
+ if n = 0 then l else
+ match l with [] -> []
+ | x :: rst -> drop rst (n-1)
+
+
+let taintVarArg (start : int) (el : exp list) : instr list =
+ let el = drop el start in
+ List.map (fun e ->
+ makeInstr instrTaint [e;integer(baseSize(typeOf e));
+ one;fileToken;lineToken]) el
+
+
+let taintFlowCall (i : instr) : instr list =
+ match i with
+ | Call(None,Lval(Var fvi,NoOffset),el,_) -> begin
+ List.fold_left (fun il (Attr(an, apl)) ->
+ if an = "Taint" then begin
+ match apl with
+ | [ap;sz;num] -> begin
+ match paramTrans ap el None,
+ paramTrans sz el None,
+ paramTrans num el None with
+ | None, _, _ -> il
+ | _, None, _ -> il
+ | _, _, None -> il
+ | Some e, Some s, Some n ->
+ let (_,_,sop) = opToTypeAndSym e in
+ (makeInstr instrTaint [sop;s;n;
+ fileToken;lineToken])::il
+ end
+ | _ -> E.s(bug "taintFlowCall: bad attribute\n")
+ end else if an = "CTaint" then begin
+ match apl with
+ | [iap; oap] -> begin
+ match paramTrans iap el None,
+ paramTrans oap el None with
+ | _, None | None, _ -> il
+ | Some ie, Some oe ->
+ let (_,_,isop) = opToTypeAndSym ie in
+ let (otyp,osz,osop) = opToTypeAndSym oe in
+ let fe = AddrOf(Var fvi, NoOffset) in
+ (makeInstr instrCTaint [isop;osop;fe;oe;otyp;osz;
+ fileToken;lineToken])::il
+ end
+ | _ -> E.s(bug "taintFlowCall: bad attribute\n")
+ end else if an = "ScanTaint" then begin
+ match apl with
+ | [AInt start] -> begin
+ taintVarArg start el
+ end
+ | _ -> E.s(bug "taintFlowCall: bad attribute\n")
+ end else il) [] fvi.vattr
+ end
+ | Call(Some dlv,Lval(Var fvi,NoOffset),el,_) -> begin
+ List.fold_left (fun il (Attr(an,apl)) ->
+ if an = "Taint" then begin
+ match apl with
+ | [ap;sz;num] -> begin
+ match paramTrans ap el (Some dlv),
+ paramTrans sz el (Some dlv),
+ paramTrans num el (Some dlv) with
+ | None, _, _ -> il
+ | _, None, _ -> il
+ | _, _, None -> il
+ | Some e, Some s, Some n ->
+ let (_,_,sop) = opToTypeAndSym e in
+ (makeInstr instrTaint [sop;s;n;
+ fileToken;lineToken])::il
+ end
+ | _ -> E.s(bug "taintFlowCall: bad Attribute\n")
+ end else if an = "CTaint" then begin
+ match apl with
+ | [iap; oap] -> begin
+ match paramTrans iap el (Some dlv),
+ paramTrans oap el (Some dlv) with
+ | None, _ | _, None -> il
+ | Some ine, Some oute ->
+ let (_,_,isop) = opToTypeAndSym ine in
+ let (otyp,osz,osop) = opToTypeAndSym oute in
+ let fe = AddrOf(Var fvi, NoOffset) in
+ (makeInstr instrCTaint [isop;osop;fe;oute;otyp;osz;
+ fileToken;lineToken])::il
+ end
+ | _ -> E.s(bug "taintFlowCall: bad attribute\n")
+ end else if an = "ScanTaint" then begin
+ match apl with
+ | [AInt start] -> begin
+ taintVarArg start el
+ end
+ | _ -> E.s(bug "taintFlowCall: bad attribute\n")
+ end else il) [] fvi.vattr
+ end
+ | _ -> []
+
+
+let instrumentInstr (i : instr) : stmtkind =
+ if isInstrFun i then Instr [i] else
+ let (preinstri,postinstri) =
+ match i with
+ | Set(lv, e,_) -> begin
+ let destaddr =
+ match lv with
+ | (Mem destaddr, NoOffset) -> destaddr
+ | (Var vi, off) -> AddrOf lv
+ | _ -> E.s(bug "instrumentInstr: lval not basic\n")
+ in
+ match e with
+ | Const _ | AddrOf(_,_) | StartOf(_,_) ->
+ let (typ,sz,sop) = opToTypeAndSym e in
+ ([makeInstr instrAssign [destaddr;e;sop;typ;sz]],[])
+ | Lval(Var vi, off) ->
+ let (typ,sz,sop) = opToTypeAndSym e in
+ ([makeInstr instrAssign
+ [destaddr;e;sop;typ;sz]],
+ [])
+ | Lval(Mem srcaddr, NoOffset) ->
+ let (typ,sz,sop) = opToTypeAndSym e in
+ ([makeInstr instrAssign [destaddr;e;srcaddr;typ;sz]],[])
+ | BinOp(bop, op1, op2,_) ->
+ let (t1, sz1, sop1) = opToTypeAndSym op1 in
+ let (t2, sz2, sop2) = opToTypeAndSym op2 in
+ ([makeInstr instrBop
+ [destaddr;constBop bop;op1;sop1;t1;sz1;op2;sop2;t2;sz2]],
+ [])
+ | UnOp(uop, op,_) ->
+ let (t, sz, sop) = opToTypeAndSym op in
+ ([makeInstr instrUop [destaddr;constUop uop;op;sop;t;sz]],[])
+ | CastE(t,bexp) ->
+ let (typ, sz, sop) = opToTypeAndSym e in
+ ([makeInstr instrAssign [destaddr;e;sop;typ;sz]],[])
+ | _ -> E.s(bug "instrumentInstr: exp not 3-address\n")
+ end
+ | Call(None, fe, bel, loc) -> begin
+ match instrToCheck i with
+ | Some c -> begin
+ (makeCheckInstr c, [])
+ end
+ | None ->
+ (* XXX: check for libc calls here *)
+ let pushList = List.map (fun e ->
+ let (typ, sz, sop) = opToTypeAndSym e in
+ makeInstr instrPushArg [e;sop;typ;sz])
+ bel
+ in
+ let taintInstrs = taintFlowCall i in
+ (pushList,taintInstrs@[makeInstr instrRetNoRet [integer(List.length bel)]])
+ end
+ | Call(Some dlv, fe, bel, loc) ->
+ let makeRetPop lv =
+ match lv with
+ | (Mem bexp, NoOffset) ->
+ let (typ,sz,sop) = opToTypeAndSym (Lval lv) in
+ makeInstr instrPopRet [Lval lv;bexp;typ;sz;integer(List.length bel)]
+ | (Var vi, off) ->
+ let (typ,sz,sop) = opToTypeAndSym (Lval lv) in
+ makeInstr instrPopRet [Lval lv;AddrOf lv;typ;sz;integer(List.length bel)]
+ | _ -> E.s(bug "instrumentInstr: lval not basic\n")
+ in
+ let pushList = List.map (fun e ->
+ let (typ, sz, sop) = opToTypeAndSym e in
+ makeInstr instrPushArg [e;sop;typ;sz])
+ bel
+ in
+ let taintInstrs = taintFlowCall i in
+ let retInstrs =
+ match taintInstrs with
+ | [] -> [makeRetPop dlv]
+ | _ -> []
+ in
+ (pushList,taintInstrs@retInstrs)
+ | Asm(_,_,_,_,_,_) ->
+ (* XXX: do something reasonable *)
+ ([],[])
+ in
+ Instr(preinstri@[i]@postinstri)
+
+let instrUnRegLocals (sid : int) (fd : fundec) : instr list =
+ List.fold_left (fun ls vi ->
+ match unrollType vi.vtype with
+ | TArray (_,_,_) | TComp(_,_) -> ls
+ | _ ->
+ if not(Dtaint.viTainted sid vi) then ls else
+ let (typ,sz,sop) = opToTypeAndSym (Lval(Var vi, NoOffset)) in
+ (makeInstr instrUnRegLocal [sop;typ;sz])::ls)
+ [] (fd.slocals@fd.sformals)
+
+let instrumentReturn (sid : int)
+ (fd : fundec)
+ (inMain : bool)
+ ((eo : exp option), (loc : location))
+ : stmtkind
+ =
+ let i e =
+ match e with
+ | Const _ | AddrOf(_,_) | StartOf(_,_) ->
+ let (typ, sz, sop) = opToTypeAndSym e in
+ makeInstr instrRetBasic [e;sop;typ;sz]
+ | Lval(Var vi, off) ->
+ let (typ, sz, sop) = opToTypeAndSym e in
+ makeInstr instrRetBasic [e;sop;typ;sz]
+ | Lval(Mem srcaddr, NoOffset) ->
+ let (typ,sz,sop) = opToTypeAndSym e in
+ makeInstr instrRetBasic [e;srcaddr;typ;sz]
+ | BinOp(bop, op1, op2,_) ->
+ let (t1, sz1, sop1) = opToTypeAndSym op1 in
+ let (t2, sz2, sop2) = opToTypeAndSym op2 in
+ makeInstr instrRetBop [constBop bop;op1;sop1;sz1;t1;op2;sop2;t2;sz2]
+ | UnOp(uop,op,_) ->
+ let (t, sz, sop) = opToTypeAndSym op in
+ makeInstr instrRetUop [constUop uop;op;sop;t;sz]
+ | CastE(t,bexp) ->
+ let (typ, sz, sop) = opToTypeAndSym e in
+ makeInstr instrRetBasic [e;sop;typ;sz]
+ | _ -> E.s(bug "instrumentInstr: exp not 3-address\n")
+ in
+ let mainRet = if inMain then [makeInstr instrEnd []] else [] in
+ let unregs = instrUnRegLocals sid fd in
+ match eo with
+ | None ->
+ let ri = makeInstr instrRetVoid [] in
+ Block(mkBlock [mkStmt (Instr(ri::(unregs@mainRet))); mkStmt (Return(eo,loc))])
+ | Some e ->
+ Block(mkBlock [mkStmt (Instr([i e]@unregs@mainRet)); mkStmt (Return(eo,loc))])
+
+let instrumentIf ((ce : exp), (tb : block), (fb : block), (loc : location)) : stmtkind =
+ let i =
+ match ce with
+ | Const _ | AddrOf(_,_) | StartOf(_,_) ->
+ let (typ,sz,sop) = opToTypeAndSym ce in
+ makeInstr instrIfBasic [ce;sop;typ;sz;fileToken;lineToken]
+ | Lval(Var vi, off) ->
+ let (typ,sz,sop) = opToTypeAndSym ce in
+ makeInstr instrIfBasic [ce;sop;typ;sz;fileToken;lineToken]
+ | Lval(Mem srcaddr, NoOffset) ->
+ let (typ,sz,sop) = opToTypeAndSym ce in
+ makeInstr instrIfBasic [ce;srcaddr;typ;sz;fileToken;lineToken]
+ | BinOp(bop, op1, op2, _) ->
+ let (t1,sz1,sop1) = opToTypeAndSym op1 in
+ let (t2,sz2,sop2) = opToTypeAndSym op2 in
+ makeInstr instrIfBop [constBop bop;op1;sop1;t1;sz1;op2;sop2;t2;sz2;
+ fileToken;lineToken]
+ | UnOp(uop, op, _) ->
+ let (t, sz, sop) = opToTypeAndSym op in
+ makeInstr instrIfUop [constUop uop;op;sop;t;sz;fileToken;lineToken]
+ | CastE(t, op) ->
+ let (typ, sz, sop) = opToTypeAndSym ce in
+ makeInstr instrIfBasic [op;sop;typ;sz;fileToken;lineToken]
+ | _ -> E.s(bug "instrumentIf: exp not 3-address\n")
+ in
+ Block(mkBlock [mkStmt (Instr [i]); mkStmt (If(ce,tb,fb,loc))])
+
+let getCase x =
+ let c =
+ List.filter
+ (function Case(_,_) -> true | _ -> false)
+ x.labels
+ in
+ match c with
+ | [Case(e,l)] -> Some e
+ | _ -> None
+
+let rec getCases stmts acc =
+ match stmts with
+ | [] -> acc
+ | x :: rst -> begin
+ match getCase x with
+ | None -> getCases rst acc
+ | Some e -> getCases rst (e::acc)
+ end
+
+let makeBasicSwitchInstrs (e : exp) (sl : stmt list) : instr list =
+ let (t, sz, sop) = opToTypeAndSym e in
+ List.map (fun conste ->
+ makeInstr instrSwitchBasic [conste;e;sop;t;sz])
+ (getCases sl [])
+
+let makeBopSwitchInstrs ((bop:binop),(op1:exp),(op2:exp)) (sl:stmt list) : instr list =
+ let (t1, sz1, sop1) = opToTypeAndSym op1 in
+ let (t2, sz2, sop2) = opToTypeAndSym op2 in
+ List.map (fun conste ->
+ makeInstr instrSwitchBop [conste;constBop bop;op1;sop1;t1;sz1;op2;sop2;t2;sz2])
+ (getCases sl [])
+
+let makeUopSwitchInstrs ((uop:unop),(op:exp)) (sl:stmt list) : instr list =
+ let (t, sz, sop) = opToTypeAndSym op in
+ List.map (fun conste ->
+ makeInstr instrSwitchUop [conste;constUop uop;op;sop;t;sz])
+ (getCases sl [])
+
+let instrumentSwitch ((e:exp), (b:block), (sl:stmt list), (loc:location)) : stmtkind =
+ let il =
+ match e with
+ | Const _ | AddrOf(_,_) | StartOf(_,_)
+ | Lval(Var _, _)
+ | Lval(Mem _, NoOffset) ->
+ makeBasicSwitchInstrs e sl
+ | BinOp(bop, op1, op2, _) ->
+ makeBopSwitchInstrs (bop,op1,op2) sl
+ | UnOp(uop, op, _) ->
+ makeUopSwitchInstrs (uop,op) sl
+ | CastE(_, _) ->
+ makeBasicSwitchInstrs e sl
+ | _ -> E.s(bug "instrumentSwitch: exp not 3-address\n")
+ in
+ Block(mkBlock [mkStmt (Instr il); mkStmt (Switch(e,b,sl,loc))])
+
+let rec instrumentStmt (fd : fundec) (inMain : bool) (s : stmt) : unit =
+ match s.skind with
+ | Instr il -> begin
+ match il with
+ | [] -> ()
+ | [i] -> if Dtaint.instrContainsTaint s.sid i then
+ s.skind <- instrumentInstr i
+ | _ -> E.s(bug "instrumentStmt: Instr with more than one instr\n")
+ end
+ | Return(eo, loc) ->
+ s.skind <- instrumentReturn s.sid fd inMain (eo,loc)
+ | Goto(_,_) -> ()
+ | Break _ -> ()
+ | Continue _ -> ()
+ | If(ce,tb,fb,loc) -> begin
+ instrumentBlock fd inMain tb;
+ instrumentBlock fd inMain fb;
+ if Dtaint.expContainsTaint s.sid ce then
+ s.skind <- instrumentIf (ce,tb,fb,loc)
+ end
+ | Switch(e,b,sl,loc) -> begin
+ instrumentBlock fd inMain b;
+ s.skind <- instrumentSwitch (e,b,sl,loc)
+ end
+ | Loop(b,_,_,_) -> instrumentBlock fd inMain b
+ | Block b -> instrumentBlock fd inMain b
+ | TryFinally(b1,b2,_) -> begin
+ instrumentBlock fd inMain b1;
+ instrumentBlock fd inMain b2
+ end
+ | TryExcept(b1,_,b2,_) -> begin
+ instrumentBlock fd inMain b1;
+ instrumentBlock fd inMain b2
+ end
+
+and instrumentBlock (fd : fundec) (inMain : bool) (b : block) : unit =
+ List.iter (instrumentStmt fd inMain) b.bstmts
+
+let fixMain (fd : fundec) : unit =
+ (*let arg =
+ if List.exists (fun vi -> vi.vname = "argv") fd.sformals then
+ Lval(Var(List.find (fun vi -> vi.vname = "argv") fd.sformals),NoOffset)
+ else CastE(voidPtrType,zero)
+ in*)
+ let dinstr_init = makeInstr instrInit [] in
+ let argv_init = makeInstr instrArgv
+ ((List.map (fun vi -> Lval(Var vi, NoOffset)) fd.sformals)@
+ [fileToken;lineToken])
+ in
+ fd.svar.vname <- "cMain";
+ fd.sbody.bstmts <-
+ (mkStmt(Instr [dinstr_init;argv_init]))::fd.sbody.bstmts
+(*
+type rfContext =
+{
+ rfHash : (string, fundec) Hashtbl.t; (* reg funs already built *)
+ mutable rfTyps : typ list (* types already seen in a traversal *)
+ mutable rfAttrCtxt : context (* attribute context *)
+}
+
+(* returns an expression for the start of an array, and the size in context c *)
+let getCount (t : typ) (e : exp) (c : context) : exp * exp =
+ if isNullterm t then (e, integer (-1))
+ let rec getBounds (a : attributes) : exp * exp option =
+ match a with
+ | Attr ("bounds", [lo; hi]) :: _ ->
+ let _, lo' = compileAttribute ctx lo in
+ let _, hi' = compileAttribute ctx hi in
+ Some(lo', hi')
+ | Attr ("fancybounds", [AInt lo; AInt hi]) :: _ ->
+ Some(getBoundsExp lo, getBoundsExp hi)
+ | Attr _ :: rest -> getBounds rest
+ | _ -> None
+ in
+ match getBounds (typeAttrs t) with
+ | None -> (e, one)
+ | Some(lo, hi) -> (lo, BinOp(MinusPP, hi, lo, t))
+
+
+let isStructType (t : typ) : bool =
+ match unrollType t with
+ | TComp(ci,_) when ci.cstruct -> true
+ | _ -> false
+
+let getRegFunForStructType (ctx : rfContext)
+ (f : file)
+ (baseTyp : typ)
+ : exp
+ =
+ match baseTyp with
+
+
+(* Make a call to register an argument. Build the registration function and add
+ it to rfHash if necessary. Do this recursively for structure fields. Punt on
+ recursive and abstract types. *)
+let getRegFunForFormal (ctx : rfContext) (* already built reg funs. ptr types already chased *)
+ (vi : varinfo) (* exp we're building for *)
+ : instr (* call to the reg fun for e *)
+ =
+ let typ = vi.vtype in
+ let e = Lval(Var vi, NoOffset) in
+ if isPtrOrArray typ then (* potential aggregate *)
+ if isAbstractPtr typ then (* can't look in, so register as a scalar *)
+ let (typ,sz,sop) = opToTypeAndSym e
+ makeInstr instrRegField [e;sop;typ;sz]
+ else if isStructType (baseType typ) then
+ let regFun = getRegFunForCompTyp ctx f (baseType typ) in
+ let (base,cnt) = getCount typ e ctx.context in
+ let sz = integer (baseSize typ) in
+ makeInstr instrRegArray [base;sz;cnt;regFun]
+ else (* yay it's just a scalar! Return call to RegisterField*)
+ let (typ,sz,sop) = opToTypeAndSym e in
+ makeInstr instrRegField [e;sop;typ;sz]
+*)
+
+
+let addPrologue (inMain : bool) (fd : fundec) : unit =
+ let pinstrs =
+ List.map (fun vi ->
+ makeInstr instrPopArg [AddrOf(Var vi, NoOffset)])
+ (List.rev fd.sformals)
+ in
+ (*let locinstrs = instrRegLocals fd in
+ let pinstrs = locinstrs @ pinstrs in*)
+ let pinstrs = (makeInstr instrFunStart [integer(List.length pinstrs)])::pinstrs in
+ if pinstrs <> [] && not(inMain) then
+ fd.sbody.bstmts <- (mkStmt(Instr pinstrs))::fd.sbody.bstmts;
+ if inMain then
+ fixMain fd
+
+let stripRegister (fd : fundec) : unit =
+ let f vi =
+ match vi.vstorage with
+ | Register -> vi.vstorage <- NoStorage
+ | _ -> ()
+ in
+ List.iter f fd.slocals
+
+let instrumentFun (fd : fundec) : unit =
+ let inMain = (fd.svar.vname = "main") in
+ stripRegister fd;
+ fixBlock fd.sbody;
+ Dtaint.computeTaint fd;
+ instrumentBlock fd inMain fd.sbody;
+ addPrologue inMain fd
+
+let mergeTaintAnnots (f : file) : unit =
+ try
+ let fn = "itaint.patch.h" in
+ let fh = open_in fn in
+ close_in fh;
+ Dpatch.applyPatch f fn
+ with Sys_error _ -> ignore(E.log "mergeTaintAnnots: failed\n")
+
+let instrumentFile (f : file) : unit =
+ Simplify.splitStructs := false;
+ Simplify.simpleMem := false;
+ Simplify.simplAddrOf := false;
+ mergeTaintAnnots f;
+ iterGlobals f Simplify.doGlobal;
+ iterGlobals f (function GFun(fd,_) -> instrumentFun fd | _ -> ());
+ iterGlobals f (function GFun(fd,_) -> Oneret.oneret fd | _ -> ());
+ f.globals <- (GText("#include <deputy/sml_instrumenter.h>"))::f.globals
--- /dev/null
+(*
+ * dtaint.ml
+ *
+ * A taint analysis for tracking program inputs.
+ *
+ *
+ *)
+
+open Cil
+open Expcompare
+open Pretty
+open Dattrs
+open Dcheckdef
+open Dutil
+
+module H = Hashtbl
+module IH = Inthash
+module E = Errormsg
+module DF = Dataflow
+module P = Ptranal
+module F = Frontc
+
+let debug = ref true
+
+let staint_fname = "staint.patch.h"
+
+module LEH =
+ H.Make(struct
+ type t = lval
+ let equal lv1 lv2 = compareLval lv1 lv2
+ let hash = H.hash
+ end)
+
+let leh_tryfind leh k =
+ try Some(LEH.find leh k)
+ with Not_found -> None
+
+module VS = Usedef.VS
+
+module VEH =
+ H.Make(struct
+ type t = varinfo
+ let equal vi1 vi2 = vi1.vid = vi2.vid
+ let hash = H.hash
+ end)
+
+let tryfind veh k =
+ try Some(H.find veh k)
+ with Not_found -> None
+
+let readPatchAnnots () : (string,varinfo) H.t = try
+ let dummy = open_in staint_fname in
+ close_in dummy;
+ let veh = H.create 16 in
+ let pfile = F.parse staint_fname () in
+ List.iter (fun g -> match g with
+ | GVarDecl(fdv, _) -> begin
+ if not(H.mem builtinFunctions fdv.vname) then begin
+ ignore(E.log "readPatchAnnots: %a\n" dp_global (GVarDecl(fdv,locUnknown)));
+ H.replace veh fdv.vname fdv
+ end
+ end
+ | GVar(fdv,_,_) -> begin
+ if not(H.mem builtinFunctions fdv.vname) then begin
+ ignore(E.log "readPatchAnnots: %a\n" dp_global (GVarDecl(fdv,locUnknown)));
+ H.replace veh fdv.vname fdv
+ end
+ end
+ | _ -> ()) pfile.globals;
+ veh
+ with Sys_error _ -> H.create 16
+
+let writePatchAnnots (ta : (string,varinfo) H.t) : unit =
+ let outpf = open_out staint_fname in
+ H.iter (fun _ vi ->
+ if not(H.mem builtinFunctions vi.vname) then begin
+ ignore(E.log "writePatchAnnot: %a\n" dp_global (GVarDecl(vi,locUnknown)));
+ let d = dprintf "%a\n" dp_global (GVarDecl(vi,locUnknown)) in
+ fprint outpf ~width:200 d
+ end)
+ ta;
+ close_out outpf
+
+type tData = {
+ leh : lval LEH.t;
+ vis : VS.t;
+ ann : (string,varinfo) H.t;
+}
+
+let logArgAnnots (vi : varinfo) : unit =
+ match unrollType vi.vtype with
+ | TFun(_,al,_,_) -> begin
+ List.iter (fun (_,_,an) ->
+ List.iter (fun (Attr(a,_)) ->
+ ignore(E.log "found arg attr = %s\n" a))
+ an)
+ (argsToList al)
+ end
+ | _ -> ()
+
+let addPatchAnnots (td : tData) (vi : varinfo) : unit =
+ ignore(E.log "Dtaint: adding patch: %a\n" dp_global (GVarDecl(vi,locUnknown)));
+ logArgAnnots vi;
+ H.replace td.ann vi.vname vi
+
+let leh_pretty () leh =
+ LEH.fold (fun lv _ d -> d ++ text " " ++ (d_lval () lv)) leh nil
+let leh_contains leh1 leh2 =
+ LEH.fold (fun lv _ b -> b && LEH.mem leh1 lv) leh2 true
+let leh_equals leh1 leh2 =
+ (leh_contains leh1 leh2) && (leh_contains leh2 leh1)
+let leh_union leh1 leh2 =
+ let nleh = LEH.copy leh1 in
+ LEH.iter (fun lv _ -> LEH.replace nleh lv lv) leh2;
+ nleh
+
+let h_union veh1 veh2 =
+ let nveh = H.copy veh1 in
+ H.iter (fun n vi -> H.replace nveh n vi) veh2;
+ nveh
+
+class taintFinderClass tD br = object(self)
+ inherit nopCilVisitor
+
+ method vlval (lv : lval) =
+ if LEH.mem tD.leh lv then begin
+ br := true;
+ SkipChildren
+ end else DoChildren
+
+ method vvrbl (vi : varinfo) =
+ if H.mem tD.ann vi.vname || vi.vname = "argv" then begin
+ br := true;
+ SkipChildren
+ end else DoChildren
+end
+
+let isTainted tD (e : exp) : bool =
+ let br = ref false in
+ let vis = new taintFinderClass tD br in
+ ignore(visitCilExpr vis e);
+ !br
+
+class viFinderClass vi br = object(self)
+ inherit nopCilVisitor
+
+ method vvrbl vi' =
+ if vi.vid = vi'.vid
+ then (br := true; SkipChildren)
+ else DoChildren
+
+end
+
+let lval_has_vi vi lv =
+ let br = ref false in
+ let vis = new viFinderClass vi br in
+ ignore(visitCilLval vis lv);
+ !br
+
+let viTainted tD (vi : varinfo) : bool =
+ LEH.fold (fun lv _ b -> b || lval_has_vi vi lv) tD.leh false
+
+let taintArgs tD (el : exp list) : unit =
+ List.iter (fun e -> match e with
+ | Lval lv
+ | AddrOf lv
+ | StartOf lv -> begin
+ ignore(E.log "taintArgs: %a\n" d_exp e);
+ LEH.replace tD.leh lv lv
+ end
+ | _ -> ()) el
+
+let take (l : 'a list) (n : int) : 'a list =
+ let rec h l n acc =
+ if n = 0 then List.rev acc else
+ match l with [] -> List.rev acc
+ | x :: rst -> h rst (n-1) (x :: acc)
+ in
+ h l n []
+
+let taintSomeArgs tD stal (args : exp list) : unit =
+ let args = take args (List.length stal) in
+ List.iter2 (fun (s,t,al) a ->
+ if List.exists (fun (Attr(an,_)) -> an = "tainted") al then
+ taintArgs tD [a]) stal args
+
+let paramTrans (ap : attrparam)
+ (args : exp list)
+ (ro : lval option) : exp option =
+ match ap with
+ | AStar(ACons(is,[])) ->
+ if String.sub is 0 1 = "$" then begin
+ let nstr = String.sub is 1 ((String.length is) - 1) in
+ let i = int_of_string nstr in
+ if i = 0 then match ro with
+ | Some r -> Some(Lval(Mem (Lval r),NoOffset))
+ | None -> None
+ else Some(Lval(Mem(List.nth args (i-1)),NoOffset))
+ end else None
+ | ACons(is,[]) ->
+ if String.sub is 0 1 = "$" then begin
+ let nstr = String.sub is 1 ((String.length is) - 1) in
+ let i = int_of_string nstr in
+ if i = 0 then match ro with
+ | None -> None
+ | Some r -> Some(Lval r)
+ else Some(List.nth args (i-1))
+ end else None
+ | AInt i -> Some(integer i)
+ | _ -> None
+
+let rec drop (l : 'a list) (n : int) : 'a list =
+ if n = 0 then l else
+ match l with [] -> []
+ | x :: rst -> drop rst (n-1)
+
+let taintVarArg tD (start : int) (args : exp list) : unit =
+ let args = drop args start in
+ List.iter (fun e -> taintArgs tD [e]) args
+
+let taintCall tD (fvi : varinfo) (args : exp list) (lvo : lval option) : unit =
+ let fvi = match tryfind tD.ann fvi.vname with None -> fvi | Some vi -> vi in
+ ignore(E.log "taintCall: %s\n" fvi.vname);
+ List.iter (fun (Attr(an, apl)) ->
+ if an = "Taint" then begin
+ match apl with
+ | [ap;sz;num] -> begin
+ match paramTrans ap args lvo with
+ | None -> ()
+ | Some a -> taintArgs tD [a]
+ end
+ | _ -> E.s(bug "taintCall: bad attribute\n")
+ end else if an = "CTaint" then begin
+ ignore(E.log "Found CTaint function: %s\n" fvi.vname);
+ match apl with
+ | [iap; oap] -> begin
+ match paramTrans iap args lvo,
+ paramTrans oap args lvo with
+ | None, _ | _, None -> ()
+ | Some ie, Some oe ->
+ if isTainted tD ie then taintArgs tD [oe]
+ else ()
+ end
+ | _ -> E.s(bug "taintCall: bad attribute\n")
+ end else if an = "ScanTaint" then begin
+ ignore(E.log "taintCall: found ScanTaint: %s\n" fvi.vname);
+ match apl with
+ | [AInt start] -> begin
+ taintVarArg tD start args
+ end
+ | _ -> E.s(bug "taintCall: bad attribute\n")
+ end else if an = "tainted" then begin
+ (* the return value becomes tainted *)
+ match lvo with
+ | None -> ()
+ | Some lv -> begin
+ ignore(E.log "taintCall: adding %a\n" d_exp (Lval lv));
+ taintArgs tD [Lval lv]
+ end
+ end else ()) fvi.vattr
+
+let addTaintAnnots tD (fvi : varinfo) (el : exp list) : unit =
+ let fvi = match tryfind tD.ann fvi.vname with None -> fvi | Some vi -> vi in
+ match unrollType fvi.vtype with
+ | TFun(r,al,b,l) -> begin
+ let el = take el (List.length (argsToList al)) in
+ let modified = ref false in
+ let nal = List.map2 (fun (s,t,an) a ->
+ if isTainted tD a then begin
+ ignore(E.log "addTaintAnnots: %a is tainted\n" d_exp a);
+ modified := true;
+ (s,t,addAttribute (Attr("tainted",[])) an)
+ end else begin
+ ignore(E.log "addTaintAnnots: %a is not tainted\n" d_exp a);
+ (s,t,an)
+ end)
+ (argsToList al) el
+ in
+ if !modified then begin
+ (match al with None -> () | Some _ -> fvi.vtype <- TFun(r,Some nal,b,l));
+ addPatchAnnots tD fvi
+ end
+ end
+ | _ -> E.s(bug "non-fun in addTaintAnnots\n")
+
+class globFinderClass (vilr : VS.t ref) = object(self)
+ inherit nopCilVisitor
+
+ method vvrbl (vi : varinfo) =
+ if vi.vglob then begin
+ vilr := VS.add vi (!vilr);
+ DoChildren
+ end else DoChildren
+
+end
+
+let globals_from_lv (lv : lval) : VS.t =
+ let vilr = ref VS.empty in
+ let vis = new globFinderClass vilr in
+ ignore(visitCilLval vis lv);
+ !vilr
+
+let addTaintGlobs tD =
+ LEH.iter (fun lv _ ->
+ VS.iter (fun gvi ->
+ gvi.vattr <- addAttribute (Attr("tainted",[])) gvi.vattr;
+ addPatchAnnots tD gvi)
+ (globals_from_lv lv))
+ tD.leh
+
+let addTaintFormals tD fd =
+ let fvi = match tryfind tD.ann fd.svar.vname with None -> fd.svar | Some vi -> vi in
+ match unrollType fvi.vtype with
+ | TFun(r,al,b,l) -> begin
+ let modified = ref false in
+ let nal = List.map2 (fun (s,t,an) vi ->
+ if viTainted tD vi then begin
+ modified := true;
+ (s,t,addAttribute (Attr("tainted",[])) an)
+ end else (s,t,an))
+ (argsToList al) fd.sformals
+ in
+ if !modified then begin
+ (match al with None -> () | Some _ -> fvi.vtype <- TFun(r,Some nal,b,l));
+ addPatchAnnots tD fvi
+ end
+ end
+ | _ -> E.s(bug "non-fun in addTaintFormals\n")
+
+let isLibCCall (fvi : varinfo) : bool =
+ match fvi.vname with
+ | "memcpy" | "memmove" | "strncpy" | "__builtin_strncpy" | "strlcpy"
+ | "bzero" | "strdup" | "__strdup" -> true
+ | _ -> false
+
+let handleLibCCall (i : instr) (tD : tData) : unit =
+ match i with
+ | Call(lvo,Lval(Var fvi,NoOffset),[d;s;_],_)
+ when fvi.vname = "memcpy" || fvi.vname = "memmove" ||
+ fvi.vname = "strncpy" || fvi.vname = "__builtin_strncpy" ||
+ fvi.vname = "strlcpy" ->
+ if isTainted tD s then taintArgs tD [d]
+ | Call(lvo,Lval(Var fvi,NoOffset),args,_) when fvi.vname = "bzero" ->
+ ()
+ | Call(Some lv,Lval(Var fvi,NoOffset),[s],_)
+ when fvi.vname = "strdup" || fvi.vname = "__strdup" ->
+ if isTainted tD s then LEH.replace tD.leh lv lv
+ | _ -> ()
+
+
+(* All of the intelligence goes here *)
+let handleInstr i tD =
+ ignore(E.log "handleInstr: looking at: %a\n" d_instr i);
+ if is_check_instr i then tD else
+ match i with
+ | Set(lv,e,_) -> begin
+ if isTainted tD e then LEH.replace tD.leh lv lv;
+ tD
+ end
+ | Call(_,Lval(Var fvi,NoOffset),_,_) when isLibCCall fvi -> begin
+ handleLibCCall i tD;
+ tD
+ end
+ | Call(Some lv,Lval(Var fvi,NoOffset),args,_) -> begin
+ addTaintAnnots tD fvi args;
+ taintCall tD fvi args (Some lv);
+ match unrollType fvi.vtype with
+ | TFun(_,al,_,_) -> begin
+ taintSomeArgs tD (argsToList al) args;
+ tD
+ end
+ | _ -> E.s(bug "non-fun in handleInstr\n")
+ end
+ | Call(None,Lval(Var fvi,NoOffset),args,_) -> begin
+ addTaintAnnots tD fvi args;
+ taintCall tD fvi args None;
+ match unrollType fvi.vtype with
+ | TFun(_,al,_,_) -> begin
+ taintSomeArgs tD (argsToList al) args;
+ tD
+ end
+ | _ -> E.s(bug "non-fun in handleInstr\n")
+ end
+ | Call(Some lv,fe,args,_) -> begin
+ LEH.replace tD.leh lv lv;
+ taintArgs tD args;
+ tD
+ end
+ | Call(None,fe,args,_) -> begin
+ taintArgs tD args;
+ tD
+ end
+ | Asm(_,_,_,_,_,_) -> tD
+
+module TaintFlow = struct
+
+ let name = "Taint Flow"
+ let debug = debug
+ type t = tData
+ let copy tD = {leh = LEH.copy tD.leh; vis = tD.vis; ann = H.copy tD.ann}
+
+ let stmtStartData = IH.create 64
+
+ let pretty () tD = leh_pretty () tD.leh
+
+ let computeFirstPredecessor stm tD = tD
+
+ let combinePredecessors (stm:stmt) ~(old:t) (tD:t) =
+ if leh_equals old.leh tD.leh then None else
+ Some({leh=leh_union old.leh tD.leh;vis=old.vis;ann=h_union old.ann tD.ann})
+
+ let doInstr i tD =
+ let action = handleInstr i in
+ DF.Post(action)
+
+ let doStmt s tD = DF.SDefault
+
+ let doGuard c leh = DF.GDefault
+
+ let filterStmt stm = true
+
+end
+
+module TF = DF.ForwardsDataFlow(TaintFlow)
+
+let recomputeCfg (fd:fundec) : unit =
+ Cfg.clearCFGinfo fd;
+ ignore (Cfg.cfgFun fd)
+
+let computeTaint (fd : fundec) =
+ ignore(E.log "computeTaint: %s\n" fd.svar.vname);
+ recomputeCfg fd;
+ try let slst = fd.sbody.bstmts in
+ let first_stm = List.hd slst in
+ (*let fset = List.fold_left (fun s vi -> VS.add vi s) VS.empty fd.sformals in*)
+ let fset = VS.empty in
+ let fdat = {leh = LEH.create 4;vis = fset;ann=readPatchAnnots()} in
+ IH.clear TaintFlow.stmtStartData;
+ IH.add TaintFlow.stmtStartData first_stm.sid fdat;
+ TF.compute [first_stm]
+ with Failure "hd" -> ()
+ | Not_found -> ()
+
+
+let getRetTD (fd : fundec) : tData option =
+ let rec h sl =
+ match sl with
+ | [] -> None
+ | s :: rst -> begin
+ match s.skind with
+ | Return _ -> IH.tryfind TaintFlow.stmtStartData s.sid
+ | _ -> h rst
+ end
+ in
+ h fd.sallstmts
+
+let addTaintReturn (tD : tData) (fd : fundec) : unit =
+ let fvi = match tryfind tD.ann fd.svar.vname with None -> fd.svar | Some vi -> vi in
+ let rec h sl =
+ match sl with
+ | [] -> ()
+ | s :: rst -> begin
+ match s.skind with
+ | Return(Some re,_) ->
+ if isTainted tD re then begin
+ fvi.vattr <- addAttribute (Attr("tainted",[])) fvi.vattr;
+ addPatchAnnots tD fvi
+ end
+ | _ -> h rst
+ end
+ in
+ h fd.sallstmts
+
+let updateAnnotations (fd : fundec) =
+ match getRetTD fd with
+ | None -> None
+ | Some returnTD -> begin
+ addTaintGlobs returnTD;
+ addTaintFormals returnTD fd;
+ addTaintReturn returnTD fd;
+ (Some returnTD)
+ end
+
+let instrContainsTaint (sid : int) (i : instr) : bool =
+ match IH.tryfind TaintFlow.stmtStartData sid with
+ | None -> false
+ | Some tD -> begin
+ let tDp = handleInstr i tD in
+ let br = ref false in
+ let vis = new taintFinderClass tD br in
+ let visp = new taintFinderClass tDp br in
+ ignore(visitCilInstr vis i);
+ ignore(visitCilInstr visp i);
+ !br
+ end
+
+let expContainsTaint (sid : int) (e : exp) : bool =
+ match IH.tryfind TaintFlow.stmtStartData sid with
+ | None -> false
+ | Some tD -> isTainted tD e
+
+
+let viTainted (sid: int) (vi : varinfo) : bool =
+ match IH.tryfind TaintFlow.stmtStartData sid with
+ | None -> false
+ | Some tD ->
+ LEH.fold (fun lv _ b -> b || lval_has_vi vi lv) tD.leh false
+
+let mergeTaintAnnots (f : file) : unit =
+ try
+ let fn = "itaint.patch.h" in
+ let fh = open_in fn in
+ close_in fh;
+ Dpatch.applyPatch f fn
+ with Sys_error _ -> ignore(E.log "mergeTaintAnnots: failed\n")
+
+let calcTaintFile (f : file) : unit =
+ mergeTaintAnnots f;
+ List.iter (fun g ->
+ match g with
+ | GFun(fd,l) -> begin
+ Oneret.oneret fd;
+ computeTaint fd;
+ match updateAnnotations fd with
+ | None -> ()
+ | Some tD -> writePatchAnnots tD.ann
+ end
+ | _ -> ())
+ f.globals
+
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2006,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+
+module F = Frontc
+module C = Cil
+module E = Errormsg
+
+let outChannel: out_channel option ref = ref None
+
+exception Done_Processing
+
+let printFile ~(extraPrinting:(out_channel->unit) option)
+ ~(globinit:C.fundec option)
+ (f: C.file) (name: string) : unit
+ =
+ if name <> "" then begin
+ try
+ let channel = open_out name in
+ let printer = (Dattrs.deputyFilePrinter :> C.cilPrinter) in
+ C.dumpFile printer channel name f;
+ (match globinit with
+ Some g -> C.dumpGlobal printer channel (C.GFun(g, C.locUnknown))
+ | None -> ());
+ (match extraPrinting with
+ Some doit -> doit channel
+ | None -> ());
+ close_out channel
+ with Sys_error _ ->
+ E.s (E.error "Error dumping inference results to %s\n" name)
+ end
+
+let parseOneFile (fname: string) : Cabs.file * C.file =
+ let cabs, cil = F.parse_with_cabs fname () in
+ Rmtmps.removeUnusedTemps ~isRoot:(Dattrs.treatAsRoot cil) cil;
+ cabs, cil
+
+let rec processOneFile ((cabs: Cabs.file), (cil: C.file)) =
+ try
+ printFile ~extraPrinting:None ~globinit:None cil !Doptions.parseFile;
+ Dinfer.preProcessFile cil;
+
+ (* "marked" is the original file plus NODE() annotations. *)
+ let marked =
+ if !Doptions.inferKinds then
+ Stats.time "Interprocedural inference" Inferkinds.inferKinds cil
+ else
+ cil
+ in
+ if !Doptions.inferBlocking <> "" then begin
+ Controlflow.blockingAnalysis marked;
+ raise F.CabsOnly; (* matth: don't run the rest of Deputy. *)
+ end;
+
+ Dinfer.preProcessFileAfterMarking marked;
+ (* Now insert the function with the global initializers. Does not insert
+ * it in the file. *)
+ let globinit = Dglobinit.prepareGlobalInitializers marked in
+
+ let extraprint =
+ if !Doptions.inferKinds && !Doptions.emitGraphDetailLevel >= 0 then
+ Some Ptrnode.printInferGraph
+ else
+ None
+ in
+ printFile ~extraPrinting:extraprint
+ ~globinit:(Some globinit) marked !Doptions.inferFile;
+
+ (* See if we should make use of Preconditions annotations *)
+ let fdat : Dprecfinder.functionData =
+ if !Doptions.propPreconditions then begin
+ ignore(E.log "Extracting preconditions from annotations\n");
+ let fdat = Dprecfinder.mkFDat() in
+ Dprecfinder.extractPrecsFromAnnots fdat marked;
+ Dmodref.extractModAnnotations fdat marked;
+ fdat
+ end else Dprecfinder.mkFDat() (* empty *)
+ in
+
+ (* alias analysis *)
+ if !Doptions.doPtrAnalysis then begin
+ Ptranal.callHasNoSideEffects := Dcheckdef.lvNoSideEffects;
+ Stats.time "Pointer analysis" Ptranal.analyze_file marked;
+ Stats.time "Pointer analysis" Ptranal.compute_results false
+ end;
+
+ (* Initialize the octagon analysis. Revert to level 3 if
+ * it's broken. *)
+ if !Doptions.optLevel = 4 then
+ if not(Doctanalysis.init()) then
+ Doptions.optLevel := 3;
+
+ if !Doptions.findPreconditions then begin
+ Cfg.clearFileCFG marked;
+ Cfg.computeFileCFG marked;
+ ignore(Dprecfinder.applyPrecPatch marked); (* for deputy added funs *)
+ Dmodref.extractModAnnotations fdat marked;
+ Dmodref.registerIgnoreInst Dcheckdef.is_check_instr;
+ Dmodref.registerIgnoreCall Dcheckdef.is_deputy_instr;
+ Dmodref.registerIgnoreCall Dcheckdef.isLibcNoSideEffects;
+ Dmodref.addAllModifications fdat marked;
+ Cfg.clearFileCFG marked
+ end;
+
+ Dcheck.checkFile marked globinit fdat;
+
+ (* Now do the global initializer *)
+ let residualChecks: bool =
+ Dglobinit.checkGlobinit marked globinit
+ (fun gi -> Dcheck.checkFundec gi)
+ (fun gi l ->
+ Doptimmain.optimFunction gi l fdat;
+ ignore (C.visitCilBlock Dinfer.postPassVisitor gi.C.sbody)) in
+
+ if residualChecks then
+ marked.C.globals <- marked.C.globals @ [C.GFun (globinit, C.locUnknown)];
+
+ Dinfer.postProcessFile marked;
+
+ (*let ogchecks, hgchecks = Doptimmain.numGlobalChecks marked in
+ E.log("GlobalChecks: %d %d\n") ogchecks hgchecks;*)
+
+ if !Doptions.findNonNull then begin
+ Cfg.clearFileCFG marked;
+ Cfg.computeFileCFG marked;
+ Dnonnullfinder.addNonNullAnnotations fdat marked;
+ Dprecfinder.addAnnotsToPatch fdat "nonnull.patch.h";
+ Cil.visitCilFile Dinfer.postPassVisitor marked
+ end;
+
+ if !Doptions.findPreconditions then begin
+ Cfg.clearFileCFG marked;
+ Cfg.computeFileCFG marked;
+ Dprecfinder.extractPrecsFromAnnots fdat marked;
+ Dprecfinder.addAllPreconditions fdat marked;
+ let pfn = (Filename.chop_extension marked.Cil.fileName)^".patch.h" in
+ Dprecfinder.addAnnotsToPatch fdat pfn;
+ Cil.visitCilFile Dinfer.postPassVisitor marked
+ end;
+
+ if !Doptions.htmlOutDir <> "" then begin
+ Dfdatbrowser.genPageForFile marked fdat
+ end;
+
+ if !Doptions.instrument then begin
+ Dinstrumenter.instrumentFile marked;
+ Cil.visitCilFile Dinfer.postPassVisitor marked
+ end;
+
+ if !Doptions.taintflow then begin
+ Dtaint.calcTaintFile marked;
+ Cil.visitCilFile Dinfer.postPassVisitor marked
+ end;
+
+ begin
+ match !outChannel with
+ | None -> ()
+ | Some c ->
+ (* Tell CIL to put comments around the bounds attributes. *)
+ C.print_CIL_Input := false;
+ Stats.time "printCIL"
+ (C.dumpFile (!C.printerForMaincil) c !Doptions.outFile) marked
+ end;
+ if !Doptions.countTrustedLines && not !E.hadErrors then
+ Dutil.reportTrustedLines ();
+ let optTime = Stats.lookupTime "optimizations" in
+ if optTime >= 20.0 && !Doptions.optLevel > 1 then
+ E.log("\nNote: Optimizations took %.1f s. For faster (but less precise)"
+ ^^" analysis, you can use a lower optimization level.\n\n")
+ optTime;
+
+ if !Doptions.checkCilInvariants && not !E.hadErrors then begin
+ let ignoreInstr i =
+ Dcheckdef.is_deputy_instr i ||
+ (match i with
+ C.Call (_,f,_,_) when Dattrs.isSpecialFunction (C.typeOf f) -> true
+ | _ -> false) ||
+ Dinstrumenter.isInstrFun i
+ in
+ if not(Check.checkFile
+ [Check.IgnoreInstructions ignoreInstr] marked) then
+ E.s (Dutil.bug "Check.checkFile failed after optimizations\n");
+ end;
+
+ if !E.hadErrors then
+ raise E.Error
+ with Done_Processing -> ()
+
+let main () =
+ let usageMsg = "Usage: deputy [options] source-files" in
+
+ (* sm: enabling this by default, since I think usually we
+ * want 'cilly' transformations to preserve annotations; I
+ * can easily add a command-line flag if someone sometimes
+ * wants these suppressed *)
+ C.print_CIL_Input := true;
+
+ (* Turn off the implicit casts *)
+ C.insertImplicitCasts := false;
+
+ (* Turn off line wrapping. *)
+ C.lineLength := 100000;
+
+ (* Suppress truncate warnings. *)
+ C.warnTruncate := false;
+
+ (* Make TRUSTED an attribute of types, not names.
+ * (This is just for the sake of uniformity) *)
+ Hashtbl.add C.attributeHash "trusted" C.AttrType;
+
+ (* Tell cabs2cil to strip dependent attributes from the types of
+ * temporaries that it creates and casts that it inserts. Also tell
+ * it to alpha-rename Deputy attributes when merging function types. *)
+ Cabs2cil.typeForTypeof := Dutil.stripDepsFromType;
+ Cabs2cil.typeForInsertedVar := Dutil.stripDepsFromType;
+ Cabs2cil.typeForInsertedCast := Dutil.stripDepsFromType;
+ Cabs2cil.typeForCombinedArg := Dpatch.patchAttrParamsInType;
+ Cabs2cil.attrsForCombinedArg := Dpatch.patchAttrParamsInAttrs;
+
+ (* Don't make the cast between a function call and its destination
+ explicit. We need to set this so that polymorphic functions
+ are handled correctly. *)
+ Cabs2cil.doCollapseCallCast := true;
+
+ Arg.parse (Doptions.align Doptions.options) Ciloptions.recordFile usageMsg;
+
+ if !Doptions.stats then
+ Stats.reset Stats.SoftwareTimer; (* no performance counters *)
+ (* else leave Stats disabled *)
+
+
+ if !Doptions.outFile <> "" then begin
+ try
+ outChannel := Some (open_out !Doptions.outFile)
+ with _ ->
+ E.s (E.error "Couldn't open file %s\n" !Doptions.outFile)
+ end;
+
+ Cil.initCIL ();
+ Ciloptions.fileNames := List.rev !Ciloptions.fileNames;
+
+ let fileName =
+ match !Ciloptions.fileNames with
+ | [name] -> name
+ | [] -> E.s (E.error "No file names provided\n")
+ | _ -> E.s (E.error "Too many file names provided (%a)\n"
+ (Pretty.docList Pretty.text) !Ciloptions.fileNames)
+ in
+
+ let cabs, file = parseOneFile fileName in
+
+ List.iter (Dpatch.applyPatch file) !Doptions.patches;
+
+ (* If there is no precondition patch file, then make one *)
+ if !Doptions.propPreconditions &&
+ not(Dprecfinder.applyPrecPatch file) then begin
+ Doptions.findPreconditions := true;
+ Doptions.propPreconditions := false
+ end;
+
+ if !E.hadErrors then
+ E.s (E.error "Cabs2cil had some errors");
+
+ processOneFile (cabs, file)
+;;
+
+let failed = ref false
+
+let cleanup () =
+ Dutil.outputAll ();
+ if !E.verboseFlag || !Doptions.stats then
+ Stats.print !E.logChannel "Timings:\n";
+ if !E.logChannel != stderr then
+ close_out (! E.logChannel);
+ match !outChannel with
+ | Some c -> close_out c
+ | _ -> ()
+;;
+
+begin
+ try
+ main ()
+ with
+ | F.CabsOnly -> (* this is OK *) ()
+ | E.Error -> failed := true
+end;
+cleanup ();
+exit (if !failed then 1 else 0)
--- /dev/null
+(*
+ *
+ * Copyright (c) 2004,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(*
+ *
+ * dcanonexp.ml
+ *
+ * Canonicalizer for Cil expressions.
+ *
+ *)
+
+open Cil
+open Expcompare
+open Pretty
+open Doptions
+open Dutil
+(*open Doptimutil*)
+open Dattrs
+
+module E = Errormsg
+
+let rec canTypeOf (e: exp) : typ =
+ match e with
+ | Const(CInt64 (_, ik, _)) -> TInt(ik, [])
+
+ (* Character constants have type int. ISO/IEC 9899:1999 (E),
+ * section 6.4.4.4 [Character constants], paragraph 10, if you
+ * don't believe me. *)
+ | Const(CChr _) -> intType
+
+ (* The type of a string is a pointer to characters ! The only case when
+ * you would want it to be an array is as an argument to sizeof, but we
+ * have SizeOfStr for that *)
+ | Const(CStr s) -> charPtrType
+
+ | Const(CWStr s) -> TPtr(!wcharType,[])
+
+ | Const(CReal (_, fk, _)) -> TFloat(fk, [])
+
+ | Const(CEnum(_, _, ei)) -> TEnum(ei, [])
+
+ | Lval(lv) -> canTypeOfLval lv
+ | SizeOf _ | SizeOfE _ | SizeOfStr _ -> !typeOfSizeOf
+ | AlignOf _ | AlignOfE _ -> !typeOfSizeOf
+ | UnOp (_, _, t) -> t
+ | BinOp (_, _, _, t) -> t
+ | CastE (t, _) -> t
+ | AddrOf (lv) -> TPtr(canTypeOfLval lv, [])
+ | StartOf (lv) -> begin
+ match unrollType (canTypeOfLval lv) with
+ TArray (t,_, a) -> TPtr(t, a)
+ | _ -> E.s (E.bug "canTypeOf: StartOf on a non-array")
+ end
+
+and canTypeOfInit (i: init) : typ =
+ match i with
+ SingleInit e -> canTypeOf e
+ | CompoundInit (t, _) -> t
+
+and canTypeOfLval = function
+ Var vi, off -> canTypeOffset vi.vtype off
+ | Mem addr, off -> begin
+ match unrollType (canTypeOf addr) with
+ TPtr (t, _)
+ | TArray(t,_,_) -> canTypeOffset t off
+ | _ -> E.s (bug "canTypeOfLval: Mem on a non-pointer (%a):%a" d_exp addr d_type (canTypeOf addr))
+ end
+
+and canTypeOffset basetyp =
+ let blendAttributes baseAttrs =
+ let (_, _, contageous) =
+ partitionAttributes ~default:(AttrName false) baseAttrs in
+ typeAddAttributes contageous
+ in
+ function
+ NoOffset -> basetyp
+ | Index (_, o) -> begin
+ match unrollType basetyp with
+ TArray (t, _, baseAttrs) ->
+ let elementType = canTypeOffset t o in
+ blendAttributes baseAttrs elementType
+ | t -> E.s (E.bug "canTypeOffset: Index on a non-array")
+ end
+ | Field (fi, o) ->
+ match unrollType basetyp with
+ TComp (_, baseAttrs) ->
+ let fieldType = canTypeOffset fi.ftype o in
+ blendAttributes baseAttrs fieldType
+ | _ -> E.s (bug "canTypeOffset: Field on a non-compound")
+
+(** Keep expressions to be compared in a canonical form: a constant + sum of
+ * weighted expressions, where the latter are not something that can be
+ * broken in a canonical expression themselves. These atomic expressions will
+ * be compared for equality. *)
+module Can = struct
+ type t =
+ { ct: int64;
+ cf: (int64 * exp) list;
+ ck: ikind;
+ }
+ let mkInt n ik = { ct = n; cf = []; ck = ik}
+ let atomic (f: int64) (e: exp) (ik : ikind) =
+ if f = Int64.zero then { ct = Int64.zero; cf = []; ck = ik } else
+ { ct = Int64.zero; cf = [(f, e)]; ck = ik}
+
+ let zero ik = mkInt Int64.zero ik
+ let weightedAdd (w1: int64) (c1: t) (cacc: t) (rkind : ikind) =
+ let truncate i = fst(truncateInteger64 rkind i) in
+ let rec insert (w: int64) (e: exp) = function
+ [] -> if w = Int64.zero then [] else [ (w, e) ]
+ | (w', e') :: rest ->
+ if deputyCompareExp e e' then
+ let w'' = truncate (Int64.add w w') in
+ if w'' = Int64.zero then
+ rest
+ else
+ (w'', e') :: rest
+ else begin
+ (*log "weightedAdd: %a != %a\n" d_plainexp e d_plainexp e';*)
+ (w', e') :: insert w e rest
+ end
+ in
+ { ct = truncate(Int64.add (Int64.mul w1 c1.ct) cacc.ct);
+ cf = List.fold_left (fun acc (w,e) -> insert (truncate (Int64.mul w1 w)) e acc)
+ cacc.cf c1.cf;
+ ck = rkind;
+ }
+
+ let add c1 c2 ik = weightedAdd Int64.one c1 c2 ik
+ let sub c1 c2 ik = weightedAdd Int64.minus_one c2 c1 ik
+ let mult c n ik = weightedAdd n c (zero c.ck) ik
+
+ (* do not use *)
+ let addConst cnst ik c =
+ let ct,cnst,rkind = convertInts c.ct c.ck cnst ik in
+ { c with ct = fst(truncateInteger64 rkind (Int64.add cnst c.ct))}
+
+ let d_t () c =
+ if c.cf = [] then
+ num64 c.ct
+ else begin
+ dprintf "%a%a"
+ insert
+ (if c.ct = Int64.zero then nil else (d_int64 c.ct))
+ (docList ~sep:nil
+ (fun (w, e) ->
+ dprintf "%a%a"
+ insert
+ (if w = Int64.one then chr '+'
+ else if w = Int64.minus_one then chr '-'
+ else
+ (if w > Int64.zero then chr '+' else nil) ++
+ dprintf "%s*" (Int64.to_string w))
+ d_exp e))
+ c.cf
+ end
+
+ type sign = Pos | Neg | Zero | DontKnow
+
+ (* t -> sign *)
+ let getSign c =
+ let getTermSign (f, e) =
+ if f > Int64.zero && not(isSignedType(canTypeOf e))
+ then Pos
+ else DontKnow
+ in
+ let cfs = List.map getTermSign c.cf in
+ try
+ let s = List.fold_left (fun s s' ->
+ match s, s' with
+ | Pos, Pos -> Pos
+ | Neg, Neg -> Neg
+ | _, _ -> DontKnow) (List.hd cfs) cfs
+ in
+ if s = Pos && c.ct >= Int64.zero then
+ Pos
+ else if s = Neg && c.ct <= Int64.zero then
+ Neg
+ else
+ DontKnow
+ with Failure "hd" ->
+ if c.ct > Int64.zero then
+ Pos
+ else if c.ct < Int64.zero then
+ Neg
+ else
+ Zero
+
+end
+
+(** The arithmetic factor for a base type *)
+let arithFactor (t: typ) : int64 =
+ match unrollType t with
+ | TPtr (bt, _) -> Int64.of_int(bitsSizeOf bt / 8)
+ | _ -> Int64.one
+
+
+
+(* Convert lh[x] to *(lh + x)
+ * Convert &lh[x] to (lh + x)
+ *)
+let rec canonMemAccess (e : exp) : exp =
+ let canonLh (lh : lhost) : lhost =
+ match lh with
+ | Mem e -> Mem(canonMemAccess e)
+ | _ -> lh
+ in
+ let rec canonOff (off : offset) : offset =
+ match off with
+ | Index(e, off) -> Index(canonMemAccess e, canonOff off)
+ | Field(fi, off) -> Field(fi, canonOff off)
+ | NoOffset -> NoOffset
+ in
+ match e with
+ | Lval(lh,Index(e,off))
+ | StartOf(lh,Index(e,off)) ->
+ let base = StartOf(lh,NoOffset) in
+ canonMemAccess (Lval(Mem(BinOp(PlusPI,base,e,canTypeOf base)), off))
+ | Lval(lh,off) -> Lval(canonLh lh, canonOff off)
+ | StartOf(lh,off) -> StartOf(canonLh lh, canonOff off)
+ (* &A[x] -> (A + x) *)
+ | AddrOf(lh, off) -> begin
+ let rec splitOffset off =
+ match off with
+ | NoOffset -> NoOffset, NoOffset
+ | Field(fi, off') ->
+ let flds, idx = splitOffset off' in
+ Field(fi, flds), idx
+ | Index(e, NoOffset) ->
+ NoOffset, Index(e, NoOffset)
+ | Index(e, off') ->
+ let flds, idx = splitOffset off' in
+ Index(e,flds), idx
+ in
+ let (flds, indx) = splitOffset off in
+ match indx with
+ | Index(e, NoOffset) -> begin
+ let base = StartOf(lh, flds) in
+ canonMemAccess (BinOp(PlusPI, base, e, canTypeOf base))
+ end
+ | _ -> AddrOf(canonLh lh, canonOff off)
+ end
+ | UnOp(uop,e,t) -> UnOp(uop,canonMemAccess e,t)
+ | BinOp(bop,e1,e2,t) ->
+ BinOp(bop,canonMemAccess e1,canonMemAccess e2,t)
+ | CastE(t,e) -> CastE(t,canonMemAccess e)
+ | _ -> e
+
+let findIkindSz (unsigned : bool) (sz : int) : ikind =
+ (* Test the most common sizes first *)
+ if sz = bytesSizeOfInt IInt then
+ if unsigned then IUInt else IInt
+ else if sz = bytesSizeOfInt ILong then
+ if unsigned then IULong else ILong
+ else if sz = 1 then
+ if unsigned then IUChar else IChar
+ else if sz = bytesSizeOfInt IShort then
+ if unsigned then IUShort else IShort
+ else if sz = bytesSizeOfInt ILongLong then
+ if unsigned then IULongLong else ILongLong
+ else if unsigned then IULong else ILong
+
+(* I need my own versions of isSignedType and typeOf because I need to use them
+ after canonMemAccess, wchih breaks some invarients *)
+
+let rec isSignedType (t:typ) : bool =
+ match unrollType t with
+ | TInt(ik,_) -> isSigned ik
+ | TEnum _ -> true
+ | TPtr _ -> false
+ | TArray _ -> false
+ | _ -> false
+
+
+
+(** Convert an expression into a canonical expression *)
+let rec canonExp (fact: int64) (e: exp) : Can.t =
+ match e with
+ | Const (CInt64 (i, ik, _)) -> Can.mkInt (Int64.mul fact i) ik
+ | BinOp ((PlusA|PlusPI|IndexPI), e1, e2, t) ->
+ begin
+ try
+ let facte2 : int64 = Int64.mul fact (arithFactor t) in
+ let ik = findIkindSz (not(isSignedType t)) ((bitsSizeOf t)/8) in
+ Can.add (canonExp fact e1) (canonExp facte2 e2) ik
+ with SizeOfError _ ->
+ (*log "canonExp: isSignedType Plus (%a)" d_type t;*)
+ let ik = findIkindSz (not(isSignedType t)) ((bitsSizeOf t)/8) in
+ Can.atomic fact e ik
+ end
+
+ | BinOp ((MinusA|MinusPI|MinusPP), e1, e2, t) ->
+ begin
+ try
+ let facte2 : int64 = Int64.mul fact (arithFactor t) in
+ let ik = findIkindSz (not(isSignedType t)) ((bitsSizeOf t)/8) in
+ Can.add (canonExp fact e1) (canonExp (Int64.neg facte2) e2) ik
+ with SizeOfError _ ->
+ (*log "canonExp: isSignedType Minus (%a)" d_type t;*)
+ let ik = findIkindSz (not(isSignedType t)) ((bitsSizeOf t)/8) in
+ Can.atomic fact e ik
+ end
+
+ | BinOp (Div, BinOp(Mult, e1, e2, tm), e3, td) ->
+ if deputyCompareExp e2 e3 then
+ canonExp fact e1
+ else begin
+ (*log "canonExp: isSignedType DivMult (%a)" d_type td;*)
+ let ik = findIkindSz (not(isSignedType td)) ((bitsSizeOf td)/8) in
+ Can.atomic fact e ik
+ end
+
+ | CastE _ -> begin
+ let ep = stripNopCasts e in
+ if not(Util.equals e ep) then begin
+ let ce = canonExp fact ep in
+ (*ignore(E.log "canonExp: stripped casts: %a -> %a\n"
+ d_plainexp e Can.d_t ce);*)
+ ce
+ end else begin
+ (*log "canonExp: isSignedType CastE (%a)" d_type (canTypeOf ep);*)
+ let ik = findIkindSz (not(isSignedType(canTypeOf ep))) ((bitsSizeOf(canTypeOf ep))/8) in
+ let ce = Can.atomic fact ep ik in
+ (*ignore(E.log "canonExp: cast left: %a\n"
+ d_plainexp e);*)
+ ce
+ end
+ end
+
+ (* Let's not distinguish between A[x] and *(A + x) *)
+(*
+ | Lval(lh, Index(e, off))
+ | StartOf(lh, Index(e, off)) -> begin
+ let base = StartOf(lh, NoOffset) in
+ Can.atomic fact (Lval(Mem(BinOp(PlusPI, base, e, typeOf base)), off))
+ end
+*)
+ (* &A[x] -> (A + x) *)
+(*
+ | AddrOf(lh, off) -> begin
+ let rec splitOffset off =
+ match off with
+ | NoOffset -> NoOffset, NoOffset
+ | Field(fi, off') ->
+ let flds, idx = splitOffset off' in
+ Field(fi, flds), idx
+ | Index(e, NoOffset) ->
+ NoOffset, Index(e, NoOffset)
+ | Index(e, off') ->
+ let flds, idx = splitOffset off' in
+ Index(e,flds), idx
+ in
+ let (flds, indx) = splitOffset off in
+ match indx with
+ | Index(e, NoOffset) -> begin
+ let base = StartOf(lh, flds) in
+ canonExp fact (BinOp(PlusPI, base, e, typeOf base))
+ end
+ | _ -> Can.atomic fact e
+ end
+*)
+ | _ ->
+ (*log "canonExp: %a isSignedType _ (%a)" d_exp e d_type (canTypeOf e);*)
+ Can.atomic fact e (findIkindSz (not(isSignedType(canTypeOf e)))
+ ((bitsSizeOf(canTypeOf e))/8))
+
+
+let canonExp (fact: int64) (e: exp) : Can.t =
+ let e = constFold true e in (* Apply constant folding first *)
+ let e = canonMemAccess e in (* Canonicalize memory access *)
+ if false then begin
+ ignore (log "canonicalizing %a\n" d_exp e);
+ let res = canonExp fact e in
+ ignore (log "canonExp(%a) = %a\n" d_exp e Can.d_t res);
+ res
+ end else
+ canonExp fact e
+
+let canonCompareExp (e1 : exp) (e2 : exp) : bool =
+ let dce1 = canonExp Int64.one e1 in
+ let dce2 = canonExp Int64.one e2 in
+ let diff = Can.sub dce1 dce2 ILong in
+ diff.Can.ct = Int64.zero && diff.Can.cf = []
+
+let canonCompareLval (lv1 : lval) (lv2 : lval) : bool =
+ let dce1 = canonExp Int64.one (Lval lv1) in
+ let dce2 = canonExp Int64.one (Lval lv2) in
+ let diff = Can.sub dce1 dce2 ILong in
+ diff.Can.ct = Int64.zero && diff.Can.cf = []
--- /dev/null
+(*
+ * Calculate "very busy" checks, and hoist them into
+ * dominators.
+ *
+ *
+ *
+ *)
+
+open Cil
+open Pretty
+open Dutil
+open Dcheckdef
+open Doptimutil
+open Doptions
+
+module DF = Dataflow
+module IH = Inthash
+module UD = Usedef
+module AELV = Availexpslv
+module E = Errormsg
+module DOM = Dominators
+module S = Stats
+module P = Dptranal
+
+module DPF = Dprecfinder
+
+let debug = ref false
+let doTiming = ref true
+
+let time s f x =
+ if !doTiming then S.time s f x else f x
+
+
+(*
+ * When ignore_inst returns true, then
+ * the instruction in question has no
+ * effects on the abstract state.
+ * When ignore_call returns true, then
+ * the instruction only has side-effects
+ * from the assignment if there is one.
+ *)
+let ignore_inst = ref (fun i -> false)
+let ignore_call = ref (fun i -> false)
+
+let registerIgnoreInst (f : instr -> bool) : unit =
+ let f' = !ignore_inst in
+ ignore_inst := (fun i -> (f i) || (f' i))
+
+let registerIgnoreCall (f : instr -> bool) : unit =
+ let f' = !ignore_call in
+ ignore_call := (fun i -> (f i) || (f' i))
+
+
+(* do two lists contain the same checks *)
+let il_equals il1 il2 =
+ if not(List.length il1 = List.length il2)
+ then false
+ else List.fold_left (fun b i1 ->
+ b && List.exists (fun i2 ->
+ deputyCallsEqual i1 i2)
+ il2)
+ true il1
+
+(* return the intersection of two lists
+ * of checks *)
+let il_combine il1 il2 =
+ List.filter (fun i1 ->
+ List.exists (fun i2 ->
+ deputyCallsEqual i1 i2) il2) il1
+
+(* add new checks from chks to cl *)
+(* instr list -> instr list -> instr list *)
+let il_add il newil =
+ List.fold_left (fun il' i ->
+ if not(List.exists (fun i' ->
+ deputyCallsEqual i i') il')
+ then begin
+ if !debug then ignore(E.log "VBC: adding %a\n" d_instr i);
+ i::il'
+ end else il')
+ il newil
+
+let il_pretty () il =
+ line ++ seq line (fun i ->
+ (d_instr () i)) il
+
+(* see if f returns true on an
+ * expression in the list *)
+let expListTest f el =
+ List.fold_left (fun b e ->
+ b || (f e))
+ false el
+
+(* if f is true on an instruction
+ * then filter it out of the list *)
+let ilKiller f il =
+ List.filter (fun i ->
+ match instrToCheck i with
+ Some c -> begin
+ if not(test_check f c) then true else begin
+ if !debug then
+ ignore(E.log "VBCFlow: killing %a\n" d_instr i);
+ false
+ end
+ end
+ | None -> match i with
+ Call(_,_,el,_) ->
+ not(expListTest f el)
+ | _ -> true)
+ il
+
+(* filter out checks having memory reads *)
+let il_kill_mem il eo =
+ if !debug then ignore(E.log "VBCFlow: Killing memory reads\n");
+ if !doPtrAnalysis then
+ match eo with
+ | Some ee ->
+ ilKiller (P.exp_has_alias_read ee) il
+ | None ->
+ ilKiller AELV.exp_has_mem_read il
+ else
+ ilKiller AELV.exp_has_mem_read il
+
+(* filter out checks refering to vi *)
+let il_kill_vi il vi =
+ ilKiller (AELV.exp_has_vi vi) il
+
+(* filter out checks refering to lv *)
+let il_kill_lval il lv =
+ ilKiller (AELV.exp_has_lval lv) il
+
+let int_list_union l1 l2 =
+ List.fold_left (fun l x ->
+ if List.mem x l then l else x :: l) l1 l2
+
+let vi_list_union l1 l2 =
+ List.fold_left (fun l x ->
+ if List.exists (fun vi -> vi.vid = x.vid) l then l else x :: l)
+ l1 l2
+
+let handleCall (*(fdato : DPF.functionData option)
+ (fe : exp)
+ (args : exp list)
+ (il : instr list) :
+ instr list*)
+ = P.handleCall il_kill_mem
+(*
+ match fdato with
+ | None -> il_kill_mem il None
+ | Some fdat -> begin
+ (* find what fe can point to *)
+ let fns : varinfo list =
+ if !doPtrAnalysis then
+ match try_resolve_funptr fe with
+ | None -> begin
+ match fe with
+ | Lval(Var vf, NoOffset) -> [vf]
+ | _ -> []
+ end
+ | Some [] -> begin
+ match fe with
+ | Lval(Var vf, NoOffset) -> [vf]
+ | _ -> []
+ end
+ | Some fds -> List.map (fun fd -> fd.svar) fds
+ else match fe with
+ | Lval(Var vf, NoOffset) -> [vf]
+ | _ -> []
+ in
+ (* if the function couldn't be identified then kill everything *)
+ if fns = [] then il_kill_mem il None else
+ (* glob vis and arg nums that fns might modify, an option in case
+ nothing is known *)
+ let modsopt : (varinfo list * int list) option =
+ List.fold_left
+ (fun modsopt fvi ->
+ match modsopt with None -> None
+ | Some(gmds, amds) -> begin
+ match IH.tryfind fdat.DPF.fdModHash fvi.vid with
+ | None -> None
+ | Some(ngmds, namds) ->
+ Some(vi_list_union ngmds gmds,
+ int_list_union namds amds)
+ end)
+ (Some([],[]))
+ fns
+ in
+ match modsopt with
+ | None -> il_kill_mem il None
+ | Some(gmds, amds) -> begin
+ (* kill lvals refering to globals in gmds *)
+ let il = List.fold_left (fun a gvi ->
+ il_kill_mem il (Some(AddrOf(Var gvi, NoOffset))))
+ il gmds
+ in
+ (* kill lvals that have reads of things aliasing things in amds *)
+ List.fold_left (fun a anum ->
+ il_kill_mem il (Some(List.nth args anum)))
+ il amds
+ end
+ end
+*)
+
+(* fdato is set in hoistChecks.
+ Easier for it to be a global b/c of dataflow functor *)
+let fdato : DPF.functionData option ref = ref None
+let il_handle_inst i il =
+ if is_check_instr i then il else
+ match i with
+ Set((Mem ee, _),_,_) ->
+ il_kill_mem il (Some ee)
+ | Set((Var vi, _),e,_) ->
+ il_kill_vi il vi
+ | Call(Some(Var vi, NoOffset),f,args,_) ->
+ let il' = il_kill_vi il vi in
+ if is_deputy_instr i || (!ignore_call) i
+ then il'
+ else handleCall (!fdato) f args il'
+ | Call(Some(Mem ee, _) ,f,args,_) ->
+ let il' = il_kill_mem il (Some ee) in
+ if (!ignore_call) i then il' else
+ handleCall (!fdato) f args il'
+ | Call(_,f,args,_) ->
+ if (!ignore_call) i then il else
+ handleCall (!fdato) f args il
+ | Asm(_,_,_,_,_,_) ->
+ let _, d = UD.computeUseDefInstr i in
+ UD.VS.fold (fun vi il' ->
+ il_kill_vi il' vi) d il
+
+module VBCheckFlow = struct
+
+ let name = "Very Busy Checks"
+
+ let debug = debug
+
+ type t = instr list
+
+ let stmtStartData = IH.create 64
+
+ let funcExitData = []
+
+ let pretty = il_pretty
+
+ let combineStmtStartData (stm:stmt) ~(old:t) (now:t) =
+ if il_equals old now then None else
+ Some(il_add old now)
+
+ let combineSuccessors = il_combine
+
+ let doStmt s =
+ if !debug then
+ ignore(E.log "VBCFlow: looking at %a\n" d_stmt s);
+ DF.Default
+
+ let doInstr i il =
+ if !debug then ignore(E.log "VBCFlow: handling %a\n" d_instr i);
+ let transform il' =
+ match instrToCheck i with
+ | Some _ -> il_add il [i]
+ | None ->
+ if is_check_instr i
+ then il_add il [i]
+ else il_handle_inst i il
+ in
+ DF.Post transform
+
+ let filterStmt stm1 stm2 = true
+
+end
+
+module VBC = DF.BackwardsDataFlow(VBCheckFlow)
+
+let all_stmts = ref []
+class stmtInitializeClass = object(self)
+ inherit nopCilVisitor
+
+ method vstmt s =
+ all_stmts := s :: (!all_stmts);
+ IH.add VBCheckFlow.stmtStartData s.sid [];
+ DoChildren
+
+end
+
+let getStmtList fd =
+ ignore(visitCilFunction (new stmtInitializeClass) fd);
+ !all_stmts
+
+let computeVBC fd =
+ IH.clear VBCheckFlow.stmtStartData;
+ all_stmts := [];
+ let sl = getStmtList fd in
+ try
+ VBC.compute sl
+ with E.Error -> begin
+ ignore(E.log "VBC failed on function:\n%s\n" fd.svar.vname);
+ E.s "Bug in VBC"
+ end
+
+let getVBList sid =
+ try Some(IH.find VBCheckFlow.stmtStartData sid)
+ with Not_found -> None
+
+(* when i is a deputy call, returns true if
+ * i is in statement s *)
+let inIL s i =
+ match s.skind with
+ | Instr il ->
+ (List.exists (deputyCallsEqual i) il)
+ | _ -> false
+
+
+let hoister (m: instr list IH.t) (t: DOM.tree) (s: stmt) : unit =
+ let childHasCheck s i =
+ match IH.tryfind m s.sid with
+ | None -> inIL s i
+ | Some il ->
+ (List.exists (deputyCallsEqual i) il) ||
+ (inIL s i)
+ in
+ let addCheck s i =
+ match IH.tryfind m s.sid with
+ | None -> IH.add m s.sid [i]
+ | Some il ->
+ (*if not(List.exists (deputyCallsEqual i) il) then*)
+ IH.replace m s.sid (i::il)
+ in
+ let removeCheck s i =
+ match IH.tryfind m s.sid with
+ | None -> ()
+ | Some il ->
+ let newil = List.filter
+ (fun i' -> not(deputyCallsEqual i i')) il
+ in
+ IH.replace m s.sid newil
+ in
+ match getVBList s.sid with
+ | None -> ()
+ | Some il -> begin
+ let children = DOM.children t s in
+ List.iter (fun i ->
+ List.iter (fun c ->
+ if childHasCheck c i
+ then begin
+ removeCheck c i;
+ addCheck s i
+ end)
+ children)
+ il
+ end
+
+class checkAdderClass m = object(self)
+ inherit nopCilVisitor
+
+ method vblock b =
+ let rec processStmtLst sl seen =
+ match sl with
+ | [] -> List.rev seen
+ | s :: rst -> begin
+ match IH.tryfind m s.sid with
+ | None -> processStmtLst rst (s::seen)
+ | Some il -> begin
+ let s' = mkStmt(Instr il) in
+ processStmtLst rst (s::s'::seen)
+ end
+ end
+ in
+ b.bstmts <- processStmtLst b.bstmts [];
+ DoChildren
+
+ method vstmt s =
+ match s.skind with
+ | Switch(e, b, _, _) -> SkipChildren
+ | _ -> DoChildren
+
+end
+
+
+class stmtFinderClass slr = object(self)
+ inherit nopCilVisitor
+ method vstmt s =
+ slr := s :: (!slr);
+ DoChildren
+end
+
+let stmtFinder fd =
+ let slr = ref [] in
+ ignore(visitCilFunction (new stmtFinderClass slr) fd);
+ !slr
+
+let hoistChecks (fd : fundec) (fdat : DPF.functionData) : unit =
+ if !debug then ignore(E.log "VBC: hoistChecks\n");
+ fdato := (Some fdat);
+ time "vbc" computeVBC fd;
+ fd.sallstmts <- time "find-stmts" stmtFinder fd;
+ let idoms, tree = time "compute-idom" (DOM.computeDomTree ~doCFG:false) fd in
+ let m = IH.create 100 in
+ time "hoister" (DOM.domTreeIter (hoister m tree) DOM.PostOrder) tree;
+ ignore(time "adderClass" (visitCilFunction (new checkAdderClass m)) fd)
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2004,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(*
+ *
+ * dcheckstrengthen.ml
+ *
+ * This module looks at groups of checks and replaces them
+ * with a smaller number of equivalent checks.
+ *
+ *)
+
+open Cil
+open Expcompare
+open Pretty
+open Dutil
+open Dcheckdef
+open Doptimutil
+
+module E = Errormsg
+module DCE = Dcanonexp
+
+(******************
+ *
+ * Replace:
+ * CPtrArith(e1,e2,e3,e4,s);
+ * CLeq(e3+e4+1,e2);
+ *
+ * With:
+ * CPtrArithAccess(e1,e2,e3,e4,s);
+ *
+ * Replace:
+ * CNullOrLeq(e1,e2,e3)
+ * CNonNull(e1)
+ *
+ * With:
+ * CLeq(e2,e3)
+ * CNonNull(e1)
+ *
+ ******************)
+class checkStrengthenClass = object(self)
+ inherit nopCilVisitor
+
+ method private increaseStrength c1 c2 =
+ match c1, c2 with
+ | CPtrArith(e1,e2,e3,e4,e5), CLeq(e6,e7,_) -> begin
+ match deputyStripCastsForPtrArith e6 with
+ | BinOp((PlusA|PlusPI|IndexPI),
+ BinOp((PlusA|PlusPI|IndexPI),e3',e4',_),ce,t) ->
+ if (DCE.canonCompareExp e3 e3' &&
+ DCE.canonCompareExp e4 e4' &&
+ DCE.canonCompareExp e2 e7 ||
+ DCE.canonCompareExp e4 e3' &&
+ DCE.canonCompareExp e3 e4' &&
+ DCE.canonCompareExp e2 e7) &&
+ DCE.canonCompareExp ce one
+ then
+ [CPtrArithAccess(e1,e2,e3,e4,e5)]
+ else
+ [c1;c2]
+ | _ -> [c1;c2]
+ end
+ | CNullOrLeq(e1,e2,e3,r), CNonNull e4 ->
+ if DCE.canonCompareExp e1 e4 then
+ [c2;CLeq(e2,e3,r)]
+ else [c1;c2]
+ | _, _-> [c1;c2]
+
+ method private processInstrs il =
+ let rec helper il seen = match il with
+ | [] -> List.rev seen
+ | [x] -> List.rev (x::seen)
+ | i1::i2::rest -> begin
+ match instrToCheck i1, instrToCheck i2 with
+ | Some c1, Some c2 -> begin
+ (* Set location so that it is properly recorded by checkToInstr. *)
+ currentLoc := get_instrLoc i1;
+ let cl = self#increaseStrength c1 c2 in
+ if cl = [] then helper rest seen else
+ let cl = List.map checkToInstr cl in
+ let c1 = List.hd cl in
+ helper ((List.tl cl)@rest) (c1::seen)
+ end
+ | _, _ -> helper (i2::rest) (i1::seen)
+ end
+ in
+ helper il []
+
+ method private procStmt s =
+ match s.skind with
+ | Instr il -> begin
+ s.skind <- Instr(self#processInstrs il);
+ s
+ end
+ | _ -> s
+
+ method private processStmts sl =
+ let rec helper sl seen = match sl with
+ | [] -> List.rev seen
+ | [x] -> List.rev ((self#procStmt x)::seen)
+ | s1::s2::rest -> begin
+ match s1.skind, s2.skind with
+ | Instr il1, Instr il2 when s1.labels = [] && s2.labels = [] -> begin
+ s1.skind <- Instr(il1 @ il2);
+ helper (s1 :: rest) seen
+ end
+ | Instr il1, Instr il2 when il1 <> [] && il2 <> [] -> begin
+ (* get the last form il1 and the first from il2 *)
+ let i1 = List.hd (List.rev il1) in
+ let il1' = List.tl (List.rev il1) in
+ let i2 = List.hd il2 in
+ let il2' = List.tl il2 in
+ match self#processInstrs [i1;i2] with
+ | [] -> E.s "CheckStrengthen: processInstrs returned empty\n"
+ | [i] -> begin
+ s1.skind <- Instr(List.rev(i::il1'));
+ s2.skind <- Instr il2';
+ helper (s2::rest) ((self#procStmt s1)::seen)
+ end
+ | [i1;i2] -> begin
+ s1.skind <- Instr(List.rev(i1::il1'));
+ s2.skind <- Instr(i2::il2');
+ helper (s2::rest) ((self#procStmt s1)::seen)
+ end
+ | _ -> E.s "CheckStrengthen: processInstrs returned more than one\n"
+ end
+ | _, _ -> helper (s2::rest) ((self#procStmt s1)::seen)
+ end
+ in
+ helper sl []
+
+ method vblock b =
+ b.bstmts <- self#processStmts b.bstmts;
+ DoChildren
+
+end
+
+let checkStrengthener = new checkStrengthenClass
--- /dev/null
+(*
+ *
+ * Copyright (c) 2004,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(*
+ *
+ * ddupcelim.ml
+ *
+ * A flow sensitive analysis that removes duplicate checks.
+ *
+ * XXX: This pass might be obviated by other passes.
+ *
+ *)
+
+open Cil
+open Pretty
+open Dutil
+open Dcheckdef
+open Doptimutil
+open Doptions
+
+module E = Errormsg
+module IH = Inthash
+module UD = Usedef
+module AELV = Availexpslv
+module DF = Dataflow
+module S = Stats
+
+module P = Dptranal
+module DPF = Dprecfinder
+
+(* For turning on debugging in just this file *)
+(*let debug = ref true*)
+
+(**********************************
+ * Flow-sensitive optimizer for
+ * removing duplicate checks across
+ * multiple statements
+ **********************************)
+
+(* do two lists contain the same checks *)
+let il_equals il1 il2 =
+ if not(List.length il1 = List.length il2)
+ then false
+ else List.fold_left (fun b i1 ->
+ b && List.exists (fun i2 ->
+ deputyCallsEqual i1 i2)
+ il2)
+ true il1
+
+(* return the intersection of two lists
+ * of checks *)
+let il_combine il1 il2 =
+ List.filter (fun i1 ->
+ List.exists (fun i2 ->
+ deputyCallsEqual i1 i2) il2) il1
+
+(* add new checks from chks to cl *)
+(* instr list -> instr list -> instr list *)
+let il_add il newil =
+ List.fold_left (fun il' i ->
+ if not(List.exists (fun i' ->
+ deputyCallsEqual i i') il')
+ then i::il' else il')
+ il newil
+
+let il_pretty () il =
+ line ++ seq line (fun i ->
+ (d_instr () i)) il
+
+(* see if f returns true on an
+ * expression in the list *)
+let expListTest f el =
+ List.fold_left (fun b e ->
+ b || (f e))
+ false el
+
+(* if f is true on an instruction
+ * then filter it out of the list *)
+let ilKiller f il =
+ List.filter (fun i ->
+ match instrToCheck i with
+ Some c ->
+ not(test_check f c)
+ | None -> match i with
+ Call(_,_,el,_) ->
+ not(expListTest f el)
+ | _ -> true)
+ il
+
+(* filter out checks having memory reads *)
+let il_kill_mem il eo =
+ if !debug then ignore(E.log "VBCFlow: Killing memory reads\n");
+ if !doPtrAnalysis then
+ match eo with
+ | Some ee ->
+ ilKiller (P.exp_has_alias_read ee) il
+ | None ->
+ ilKiller AELV.exp_has_mem_read il
+ else
+ ilKiller AELV.exp_has_mem_read il
+
+(* filter out checks refering to vi *)
+let il_kill_vi il vi =
+ ilKiller (AELV.exp_has_vi vi) il
+
+(* filter out checks refering to lv *)
+let il_kill_lval il lv =
+ ilKiller (AELV.exp_has_lval lv) il
+
+let il_handle_inst i il =
+ if is_check_instr i then il else
+ match i with
+ Set((Mem ee, _),_,_) ->
+ il_kill_mem il (Some ee)
+ | Set((Var vi, NoOffset),e,_) ->
+ (match e with
+ Lval(Var vi', NoOffset) ->
+ if vi'.vid = vi.vid then il else
+ il_kill_vi il vi
+ | _ -> il_kill_vi il vi)
+ | Set(lv,_,_) -> il_kill_lval il lv
+ | Call(Some(Var vi, NoOffset),_,_,_) ->
+ let il' = il_kill_vi il vi in
+ if is_deputy_instr i then il' else
+ il_kill_mem il' None
+ | Call(_,_,_,_) ->
+ il_kill_mem il None
+ | Asm(_,_,_,_,_,_) ->
+ let _, d = UD.computeUseDefInstr i in
+ UD.VS.fold (fun vi il' ->
+ il_kill_vi il' vi) d il
+
+module AvailChecks =
+ struct
+
+ let name = "Available Checks"
+
+ let debug = debug
+
+ (* list of checks that are available *)
+ type t = instr list
+
+ let copy il = il
+
+ let stmtStartData = IH.create 64
+
+ let pretty = il_pretty
+
+ let computeFirstPredecessor stm il = il
+
+ let combinePredecessors (stm:stmt) ~(old:t) (il:t) =
+ if il_equals old il then None else
+ Some(il_combine old il)
+
+ let doInstr i il =
+ let action il =
+ match instrToCheck i with
+ | Some _ -> il_add il [i]
+ | None ->
+ if is_deputy_instr i
+ then il_add il [i]
+ else il_handle_inst i il
+ in
+ DF.Post action
+
+ let doStmt stm il =
+ (*if !debug then ignore(E.log "AvailChecks: looking at stmt %d %a\n"
+ stm.sid d_stmt stm);*)
+ DF.SDefault
+
+ let doGuard c il = DF.GDefault
+
+ let filterStmt stm = true
+
+ end
+
+module AC = DF.ForwardsDataFlow(AvailChecks)
+
+let computeACs fd (fdat : DPF.functionData) =
+ try let slst = fd.sbody.bstmts in
+ let first_stm = List.hd slst in
+ let precs =
+ match IH.tryfind fdat.DPF.fdPCHash fd.svar.vid with
+ | None -> []
+ | Some cl -> begin
+ if !debug then
+ ignore(E.log "computeACs: precs for %s: %a\n" fd.svar.vname
+ d_stmt (mkStmt (Instr cl)));
+ cl
+ end
+ in
+ IH.clear AvailChecks.stmtStartData;
+ IH.add AvailChecks.stmtStartData first_stm.sid precs;
+ AC.compute [first_stm]
+ with Failure "hd" -> ()
+ | Not_found -> ()
+
+let getACs sid =
+ try Some(IH.find AvailChecks.stmtStartData sid)
+ with Not_found -> None
+
+(* Visitor that eliminates a check at a statement where it is available *)
+class dupCheckElimClass = object(self)
+ inherit nopCilVisitor
+
+ method private filter_dups ail il =
+ (* make in instr that sets the lhs of i
+ * to the lhs of ai *)
+ let makeSet i ai =
+ match i, ai with
+ Call(Some lv1,_,_,l),Call(Some lv2,_,_,_) ->
+ Set(lv1,Lval lv2, l)
+ | _ -> E.s "dupCheckElim: bad deputy instrs in list\n"
+ in
+ let rec filter_dups' ail il ril =
+ match il with [] -> List.rev ril
+ | i::rest -> match instrToCheck i with
+ | Some _ ->
+ if List.exists (deputyCallsEqual i) ail
+ then (if !debug then ignore(E.log "dupCheckElim: Removing: %a\n"
+ d_instr i);
+ filter_dups' ail rest ril)
+ else let ail' = il_add ail [i] in
+ (if !debug then ignore(E.log "dupCheckElim: Not Removing: %a\n"
+ d_instr i);
+ filter_dups' ail' rest (i::ril))
+ | None ->
+ if is_deputy_instr i then
+ if List.exists (deputyCallsEqual i) ail
+ then let ai = List.find (deputyCallsEqual i) ail in
+ let newi = makeSet i ai in
+ (if !debug then ignore(E.log "dupCheckElim: Removing: %a\n"
+ d_instr i);
+ filter_dups' ail rest (newi::ril))
+ else let ail' = il_add ail [i] in
+ (if !debug then ignore(E.log "dupCheckElim: Not Removing: %a\n"
+ d_instr i);
+ filter_dups' ail' rest (i::ril))
+ else let ail' = il_handle_inst i ail in
+ filter_dups' ail' rest (i::ril)
+ in
+ filter_dups' ail il []
+
+ method vstmt s =
+ match getACs s.sid with
+ | None -> SkipChildren
+ | Some acs ->
+ match s.skind with
+ Instr il -> begin
+ (*if !debug then ignore(E.log "Filtering dups from stmt %d with data %a\n"
+ s.sid il_pretty acs);*)
+ let il' = self#filter_dups acs il in
+ s.skind <- Instr il';
+ SkipChildren
+ end
+ | _ -> DoChildren
+
+end
+
+let dupCheckElimer = new dupCheckElimClass
+
+let elim_dup_checks fd (fdat : DPF.functionData) =
+ computeACs fd fdat;
+ ignore(visitCilFunction dupCheckElimer fd)
+
+
+(* See what checks are available at every return *)
+class postConditionFinderClass postcsr = object(self)
+ inherit nopCilVisitor
+
+ method vstmt s =
+ match s.skind with
+ | Return(_,_) -> begin
+ match getACs s.sid with
+ | None -> DoChildren
+ | Some acs -> begin
+ postcsr := il_combine acs (!postcsr);
+ DoChildren
+ end
+ end
+ | _ -> DoChildren
+
+end
+
+class allChecksBuilderClass clr = object(self)
+ inherit nopCilVisitor
+
+ method vinst i =
+ match instrToCheck i with
+ | None -> DoChildren
+ | Some c -> begin
+ if not(List.exists (deputyCallsEqual i) (!clr)) then
+ clr := i :: (!clr);
+ DoChildren
+ end
+end
+
+(* fundec -> instr list *)
+let findFnPostConditions (fd : fundec) (fdat : DPF.functionData) =
+ let clr = ref [] in
+ computeACs fd fdat;
+ ignore(visitCilFunction (new allChecksBuilderClass clr) fd);
+ ignore(visitCilFunction (new postConditionFinderClass clr) fd);
+ !clr
--- /dev/null
+(*
+ * dfailfinder.ml
+ *
+ * This module tries to find feasible models of parameters and globals
+ * under which Deputy checks will fail.
+ *
+ * The entry point is:
+ *
+ * failcheck: Cil.exp list -> DCE.Can.t -> (Cil.exp * int) list
+ *
+ * When given a list of constraints and a canon exp, it will try to find a model
+ * of the constraints under which the canon exp is < 0.
+ *)
+
+open Cil
+open Pretty
+open Dattrs
+open Dutil
+open Dcheckdef
+open Doptimutil
+
+module IH = Inthash
+module E = Errormsg
+module S = Stats
+module SI = SolverInterface
+module DSF = Dsolverfront
+module DCE = Dcanonexp
+module AELV = Availexpslv (* for AELV.exp_has_lval *)
+
+let debug = ref true
+
+(* If there isn't some fact about each lval in the ce,
+ * then return false o/w true *)
+let checkFacts (cl : exp list)
+ (ce : DCE.Can.t)
+ : bool * exp list
+ =
+ (* filter facts in cl that don't mention lvals in ce *)
+ let fcl =
+ List.filter (fun c ->
+ List.exists (fun (_, (e : exp)) ->
+ match e with
+ | Lval lv | StartOf lv -> AELV.exp_has_lval lv c
+ | _ -> false)
+ ce.DCE.Can.cf)
+ cl
+ in
+ let b =
+ not(List.exists (fun (_, (e : exp)) ->
+ match e with
+ | Lval lv
+ | StartOf lv -> not(List.exists (AELV.exp_has_lval lv) fcl)
+ | _ -> true) ce.DCE.Can.cf)
+ in
+ (b, fcl)
+
+class lvalCollectorClass (lvalHash : (string, lval) Hashtbl.t) = object(self)
+ inherit nopCilVisitor
+ method vlval (lv : lval) =
+ Hashtbl.add lvalHash (sprint 80 (d_lval () lv)) lv;
+ DoChildren
+end
+
+(* create a mapping from the string of an lval to the lval *)
+let makeLvalHash (cl : exp list)
+ : (string, lval) Hashtbl.t
+ =
+ let lvalHash = Hashtbl.create 100 in
+ List.iter (fun e ->
+ ignore(visitCilExpr (new lvalCollectorClass lvalHash) e))
+ cl;
+ lvalHash
+
+
+let failCheck (cl : exp list) (ce : DCE.Can.t) : (exp * int) list =
+ try
+ (* will raise SI.NYI if there is no solver *)
+ if !debug then ignore(E.log "failCheck: getting translator\n");
+ let translator = SI.getTranslator 0 in
+
+ (* see if there are a quarum of facts
+ * TODO: remove facts that can't be translated *)
+ if !debug then ignore(E.log "failCheck: checking facts\n");
+ let enoughFacts, factList = checkFacts cl ce in
+ if not enoughFacts then [] else begin
+
+ (* translate the canon exp *)
+ if !debug then ignore(E.log "failCheck: translating check exp\n");
+ let (tce,_) = DSF.transCan translator ce in
+ (* ce >= 0 *)
+ if !debug then ignore(E.log "failCheck: build 0 <= ce\n");
+ let tce = translator.DSF.mkLe (translator.DSF.mkConst 0) tce in
+
+ (* translate the constraints *)
+ if !debug then ignore(E.log "failCheck: translate constraints\n");
+ let tcl = List.map (DSF.transCilExp translator) factList in
+
+ (* make a conjuction of the constraints *)
+ (*
+ ignore(E.log "failCheck: build conjunction of constraints\n");
+ let conj = List.fold_left (fun conj te ->
+ translator.DSF.mkAnd te conj) (translator.DSF.mkTrue()) tcl
+ in
+ *)
+
+ (* make conj => tce *)
+ (*
+ ignore(E.log "failCheck: build implication\n");
+ let impl = translator.DSF.mkImp conj tce in
+ *)
+
+ (* if it's invalid, then ask for a counterexample, if it's
+ valid, then return [(Cil.one, 1)] *)
+ if !debug then ignore(E.log "failCheck: check validity\n");
+ let valid, counterEx = translator.DSF.isValidWithAssumptions tcl tce in
+ if valid then [(one, 1)] else begin
+
+ (* a list of translated equalities *)
+ if !debug then ignore(E.log "failCheck: make lvhash\n");
+ let lvalHash = makeLvalHash cl in
+
+ (* convert strings to Cil expressions and return the list *)
+ if !debug then ignore(E.log "failCheck: replace strings with lvals\n");
+ let res = List.map (fun (str, i) ->
+ try
+ (Lval(Hashtbl.find lvalHash str), i)
+ with Not_found -> (integer 0, i)) counterEx
+ in
+ if !debug then ignore(E.log "failCheck: done! returning...\n");
+ res
+ end
+ end
+ with
+ | SI.NYI _ -> begin
+ if !debug then ignore(E.log "Translation failed\n");
+ []
+ end
+ | DSF.NYI -> begin
+ if !debug then ignore(E.log "Translation failed\n");
+ []
+ end
+ | ex -> begin
+ ignore(E.log "failCheck: %s was raised during failCheck\n"
+ (Printexc.to_string ex));
+ raise ex
+ end
--- /dev/null
+(*
+ * dfdatbrowser.ml
+ *
+ * This module generates an html file for a source file.
+ * The html file has links to an html file for each function mentioned in
+ * the functionData structure that is also defined in the source file.
+ *
+ *)
+
+
+open Cil
+open Pretty
+open Doptions
+open Dattrs
+open Dcheckdef
+
+module E = Errormsg
+module IH = Inthash
+
+module DPF = Dprecfinder
+module DCE = Dcanonexp
+
+module X = XHTML.M
+
+
+let tmToStr (t : Unix.tm) : string =
+ (string_of_int (t.Unix.tm_hour))^":"^
+ (string_of_int (t.Unix.tm_min))^" GMT "^
+ (string_of_int (t.Unix.tm_mon+1))^"/"^
+ (string_of_int (t.Unix.tm_mday))^"/"^
+ (string_of_int (t.Unix.tm_year + 1900))
+
+let href url elts =
+ X.a ~a:[X.a_href url] elts
+
+
+let rec gcd a b = if b = Int64.zero then a else gcd b (Int64.rem a b)
+
+let ceGCD (ce : DCE.Can.t) : int64 =
+ List.fold_left (fun g (f, _) ->
+ if f = Int64.zero then g else
+ if g = Int64.zero then (Int64.abs f)
+ else gcd g (Int64.abs f)) Int64.zero ce.DCE.Can.cf
+
+let divByGCD (ce : DCE.Can.t) : DCE.Can.t =
+ let g = ceGCD ce in
+ let newcf = List.map (fun (f, e) -> (Int64.div f g, e)) ce.DCE.Can.cf in
+ {DCE.Can.ct = Int64.div ce.DCE.Can.ct g;
+ DCE.Can.cf = newcf;
+ DCE.Can.ck = ce.DCE.Can.ck}
+
+let partConExp (ce : DCE.Can.t) : DCE.Can.t * DCE.Can.t =
+ let ce = divByGCD ce in
+ let pos, neg = List.partition (fun (c, _) -> c > Int64.zero) ce.DCE.Can.cf in
+ let neg = List.map (fun (c, e) -> (Int64.neg c, e)) neg in
+ if ce.DCE.Can.ct > Int64.zero then
+ {DCE.Can.ct = ce.DCE.Can.ct; DCE.Can.cf = pos;DCE.Can.ck=ce.DCE.Can.ck},
+ {DCE.Can.ct = Int64.zero; DCE.Can.cf = neg;DCE.Can.ck=ce.DCE.Can.ck}
+ else if ce.DCE.Can.ct < Int64.zero then
+ {DCE.Can.ct = Int64.zero; DCE.Can.cf = pos;DCE.Can.ck=ce.DCE.Can.ck},
+ {DCE.Can.ct = Int64.neg ce.DCE.Can.ct; DCE.Can.cf = neg;DCE.Can.ck=ce.DCE.Can.ck}
+ else
+ {DCE.Can.ct = Int64.zero; DCE.Can.cf = pos;DCE.Can.ck=ce.DCE.Can.ck},
+ {DCE.Can.ct = Int64.zero; DCE.Can.cf = neg;DCE.Can.ck=ce.DCE.Can.ck}
+
+let printConLeq (e1 : exp) (e2 : exp) : doc =
+ let ce1 = DCE.canonExp Int64.one e1 in
+ let ce2 = DCE.canonExp Int64.one e2 in
+ let cdiff = DCE.Can.sub ce2 ce1 ILong in
+ let greater, lesser = partConExp cdiff in
+ (DCE.Can.d_t () lesser) ++ text " <= " ++
+ (DCE.Can.d_t () greater)
+
+let d_checkinstr () (i : instr) : doc =
+ match instrToCheck i with
+ | None -> nil
+ | Some c -> begin
+ match c with
+ | CNonNull e ->
+ dprintf "%a != NULL" dc_exp e
+ | CEq(e1, e2, _, _) ->
+ dprintf "%a == %a" dc_exp e1 dc_exp e2
+ | CMult(e1,e2) ->
+ dprintf "%a %% %a == 0" dc_exp e2 dc_exp e1
+ | CPtrArithAccess(lo,hi,p,e,_) ->
+ let e' = BinOp(PlusPI,p,e,typeOf p) in
+ let e'' = BinOp(PlusPI,p,BinOp(PlusA,e,one,typeOf e),typeOf p) in
+ (printConLeq lo e') ++ text " /\\ " ++
+ (printConLeq e'' hi)
+ | CPtrArith(lo,hi,p,e,_) ->
+ let e' = BinOp(PlusPI,p,e,typeOf p) in
+ (printConLeq lo e') ++ text " /\\ " ++
+ (printConLeq e' hi)
+ | CPtrArithNT(lo,hi,p,e,_) ->
+ let e' = BinOp(PlusPI,p,e,typeOf p) in
+ (printConLeq lo e') ++ text " /\\ " ++
+ (dprintf "%a <= %a + len(%a)"
+ dc_exp e' dc_exp hi dc_exp hi)
+ | CLeqInt(e1,e2,_) ->
+ printConLeq e1 e2
+ | CLeq(e1, e2, _) ->
+ printConLeq e1 e2
+ | CLeqNT(e1,e2,_,_) ->
+ dprintf "%a <= %a + len(%a)" dc_exp e1 dc_exp e2 dc_exp e2
+ | CNullOrLeq(e1,e2,e3,_) ->
+ (dprintf "%a == NULL \\/ " dc_exp e1) ++
+ (printConLeq e2 e3)
+ | CNullOrLeqNT(e1,e2,e3,_,_) ->
+ (dprintf "%a == NULL \\/ %a <= %a + len(%a)"
+ dc_exp e1 dc_exp e2 dc_exp e3 dc_exp e3)
+ | CWriteNT(p,hi,what,sz) ->
+ (dprintf "%a != %a \\/ *(%a) != 0 \\/ %a == 0"
+ dc_exp p dc_exp hi dc_exp p dc_exp what)
+ | CNullUnionOrSelected(lv, sfs) ->
+ (dprintf "%a || iszero(%a)" dc_exp sfs dx_lval lv)
+ | CSelected e ->
+ (dprintf "%a" dc_exp e)
+ | CNotSelected e ->
+ (dprintf "! %a" dc_exp e)
+ end
+
+
+(* TODO : 1. clean up and canonicalize the checks.
+ 2. refer to globals as filename:varname. *)
+let genPrecsForHtml (il : instr list) =
+ List.fold_left
+ (fun el i ->
+ (*let d = sprint ~width:80 (d_instr () i) in*)
+ let p = sprint ~width:80 (d_checkinstr () i) in
+ (*(X.p [X.pcdata d]) ::*)
+ (X.p [X.pcdata p]) :: el)
+ []
+ il
+
+let declToHtml (vi : varinfo) =
+ let p = sprint ~width:80 (d_global () (GVarDecl(vi, locUnknown))) in
+ (X.p [X.pcdata p])
+
+(* Take the fundec, the list of preconditions and a base name, and write
+ the prototype and preconditions to an html file with base name name *)
+let genPageForFunction (fd : fundec) (il : instr list) (name : string) : unit =
+ let precs = genPrecsForHtml il in
+ if precs = [] then () else
+ let time = Unix.gmtime (Unix.time()) in
+ let locstr = sprint ~width:80 (d_loc () fd.svar.vdecl) in
+ let titlestr = locstr^" - "^fd.svar.vname in
+ let html = X.html (*~a:[X.a_xmlns X.W3_org_1999_xhtml; X.a_xml_lang "en"]*)
+ (X.head
+ (X.title (X.pcdata titlestr))
+ [X.style ~contenttype:"text/css" [X.pcdata "H1 {color: back}"]])
+ (X.body
+ ([X.h1 [X.pcdata titlestr];
+ X.hr()] @
+ [X.h2 [X.pcdata "Function Prototype"];
+ declToHtml fd.svar;
+ X.h2 [X.pcdata "Preconditions"]] @
+ precs @
+ [X.hr();
+ X.p [X.pcdata ("Last update - "^(tmToStr time))]]))
+ in try
+ let outf = open_out (!htmlOutDir^"/"^name^".html") in
+ X.pretty_print ~width:80 (output_string outf) html;
+ close_out outf
+ with Sys_error msg -> begin
+ ignore(E.log "Dfdatbrowser: error writing file: %s" msg)
+ end
+
+
+(* Take in a file and the function data and generate the files
+ for functions, and a list of links to those files *)
+let genLinksForFile (f : file) (fdat : DPF.functionData) =
+ (* For each function defined in the file:
+ 1. If it's mentioned in fdat, write to file.html.
+ 2. Call genPageForFunction on the function. *)
+ foldGlobals f
+ (fun l g -> match g with
+ | GFun(fd, loc) -> begin
+ match IH.tryfind fdat.DPF.fdPCHash fd.svar.vid with
+ | (Some il) when il <> [] -> begin
+ let name = fd.svar.vname in
+ genPageForFunction fd il name;
+ (X.p [href (name^".html") [X.pcdata name]]) ::
+ l
+ end
+ | _ -> l
+ end
+ | _ -> l) []
+
+let genSourceFileLinks () =
+ try
+ let dirhand = Unix.opendir (!htmlOutDir) in
+ let rec loop acc =
+ try
+ let fname = Unix.readdir dirhand in
+ if Filename.check_suffix fname "i.html" then
+ loop ((X.p [href fname [X.pcdata fname]]) :: acc)
+ else loop acc
+ with End_of_file -> acc
+ in
+ loop []
+ with Sys_error msg -> begin
+ ignore(E.log "Dfdatbrowser: error writing index: %s" msg);
+ []
+ end
+
+let rewriteIndex () : unit =
+ let links = genSourceFileLinks () in
+ if links = [] then () else
+ let time = Unix.gmtime (Unix.time()) in
+ let html = X.html (*~a:[X.a_xmlns X.W3_org_1999_xhtml; X.a_xml_lang "en"]*)
+ (X.head
+ (X.title (X.pcdata "File Information"))
+ [X.style ~contenttype:"text/css" [X.pcdata "H1 {color: back}"]])
+ (X.body
+ ([X.h1 [X.pcdata "File Information"];
+ X.hr()] @
+ links @
+ [X.hr();
+ X.p [X.pcdata ("Last update - "^(tmToStr time))]]))
+ in try
+ let outf = open_out (!htmlOutDir^"/index.html") in
+ X.pretty_print ~width:80 (output_string outf) html;
+ close_out outf
+ with Sys_error msg -> begin
+ ignore(E.log "Dfdatbrowser: error writing file: %s" msg)
+ end
+
+(* Take in a file and the function data and generate the html file
+ for it *)
+(* TODO: This should be made more robust. I.e. if htmlOutDir doesn't exist,
+ then create it. Also, if htmlOutDir/index.html doesn't exist, then create it.
+ If it does exist then concat the link to this file. *)
+let genPageForFile (f : file) (fdat : DPF.functionData) =
+ let links = genLinksForFile f fdat in
+ if links = [] then () else
+ let time = Unix.gmtime (Unix.time()) in
+ let html = X.html (*~a:[X.a_xmlns X.W3_org_1999_xhtml; X.a_xml_lang "en"]*)
+ (X.head
+ (X.title (X.pcdata f.fileName))
+ [X.style ~contenttype:"text/css" [X.pcdata "H1 {color: back}"]])
+ (X.body
+ ([X.h1 [X.pcdata f.fileName];
+ X.hr()] @
+ links @
+ [X.hr();
+ X.p [X.pcdata ("Last update - "^(tmToStr time))]]))
+ in try
+ let outf = open_out (!htmlOutDir^"/"^f.fileName^".html") in
+ X.pretty_print ~width:80 (output_string outf) html;
+ close_out outf;
+ rewriteIndex ()
+ with Sys_error msg -> begin
+ ignore(E.log "Dfdatbrowser: error writing file: %s" msg)
+ end
--- /dev/null
+(*
+ *
+ * Copyright (c) 2004,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(*
+ * dflowinsens.ml
+ *
+ * A flow insensitive pass that looks for
+ * easy-to-reason-about checks.
+ *
+ *
+ *)
+
+open Cil
+open Expcompare
+open Pretty
+open Dutil
+open Dattrs
+open Dcheckdef
+open Doptimutil
+
+module DO = Doptions
+module E = Errormsg
+module S = Stats
+module DCE = Dcanonexp
+module Z = Zrapp
+
+(* Called when a compile-time assertion failure is detected. This
+ * function should mirror deputy_fail in the runtime library in terms
+ * of output formatting. *)
+let deputyFail (c: check) : unit =
+ let why = checkWhy c in
+ let docs = checkText c in
+ error "Assertion will always fail in %s:\n %a"
+ why (docList ~sep:(text "\n ") (insert ())) docs
+
+let deputyFailLe (e1: exp) (e2: exp) (why: string) : unit =
+ deputyFail (CLeq (e1, e2, why))
+
+(** Split an expression e into e',i', such that e=e'+i' (pointer arithmetic) *)
+let rec getBaseOffset (e: exp) : exp * int =
+ match e with
+ | BinOp ((PlusPI | IndexPI | MinusPI) as op, e', off, t) ->
+ let intFold e = isInteger (constFold true e) in
+ begin
+ match getBaseOffset e', intFold off, op with
+ | (b, n1), Some n2, (PlusPI | IndexPI) ->
+ b, n1 + (to_signedint n2)
+ | (b, n1), Some n2, MinusPI ->
+ b, n1 - (to_signedint n2)
+ | _, _, _ ->
+ e, 0
+ end
+ | CastE (t, e') ->
+ let strip t = typeRemoveAttributes ["bounds"; "size"; "nullterm"] t in
+ let b, n = getBaseOffset e' in
+ if compareTypes (strip (typeOf e')) (strip t) then begin
+ b, n
+ end else begin
+ match sizeOfBaseType (typeOf e'), sizeOfBaseType t with
+ | Some sz1, Some sz2 when sz1 = sz2 -> b, n
+ | Some sz1, Some sz2 when sz1 mod sz2 = 0 ->
+ mkCast b t, n * (sz1 / sz2)
+ | _ -> e, 0
+ end
+ | AddrOf (base, off) -> begin (* Look for when off ends in Index *)
+ match removeOffset off with
+ off', Index(idx, NoOffset) -> begin
+ match isInteger (constFold true idx) with
+ Some n -> mkAddrOrStartOf (base, off'), (to_signedint n)
+ | _ -> e, 0
+ end
+ | _ -> e, 0
+ end
+
+ | _ ->
+ e, 0
+
+let proveLeWithBounds (e1: exp) (e2: exp) : bool =
+ let ctx = allContext () in
+ let rec getExpBounds (e:exp) : exp option * exp option =
+ match e with
+ (* TODO: structs, memory *)
+ | Lval (Var vi, NoOffset) when isPointerType vi.vtype &&
+ hasAttribute "bounds" (typeAttrs vi.vtype) ->
+ let ctx = addThisBinding ctx vi.vtype e in
+ let lo, hi = boundsOfAttrs ctx (typeAttrs vi.vtype) in
+(* log " %a has bounds %a and %a.\n" dx_exp e *)
+(* dx_exp lo dx_exp hi; *)
+ Some lo, Some hi
+ | CastE (t, e') when (bitsSizeOf t) = (bitsSizeOf voidPtrType) ->
+ getExpBounds e'
+ | _ -> None, None
+ in
+ let lo1, hi1 = getExpBounds e1 in
+ let lo2, hi2 = getExpBounds e2 in
+ (* we know e1 <= hi1 and lo2 <= e2 *)
+ match hi1, lo2 with
+ Some hi1, Some lo2 ->
+ (DCE.canonCompareExp hi1 lo2)
+ || (DCE.canonCompareExp hi1 e2)
+ || (DCE.canonCompareExp e1 lo2)
+ | Some hi1, None ->
+ (DCE.canonCompareExp hi1 e2)
+ | None, Some lo2 ->
+ (DCE.canonCompareExp e1 lo2)
+ | None, None ->
+ false
+
+let newProveLe ?(allowGt: bool = false) (e1: exp) (e2: exp) : int option =
+ let e1c = DCE.canonExp Int64.one e1 in
+ let e2c = DCE.canonExp Int64.one e2 in
+ let e1res = DCE.Can.sub e2c e1c ILong in
+ (*log "le(%a, %a) = %a" d_exp e1 d_exp e2 DCE.Can.d_t e1res;*)
+ match DCE.Can.getSign e1res with
+ | DCE.Can.Zero
+ | DCE.Can.Pos -> begin
+ (*log "newProveLe : Yes %a" DCE.Can.d_t e1res;*)
+ Some 1
+ end
+ | DCE.Can.Neg -> begin
+ (*log "newProveLe : No %a" DCE.Can.d_t e1res;*)
+ Some (-1)
+ end
+ | DCE.Can.DontKnow -> begin
+ (* special cases. *)
+ match e1res.DCE.Can.cf with
+ | [(f, e)] -> begin
+ (* look for C + f * (e & D) >= 0, with f * D >= -C *)
+ match e with
+ | BinOp(BAnd, e1, e2, _) -> begin
+ match isInteger e2 with
+ | None -> begin
+ (*log "newProveLe: mask not const %a" d_plainexp e;*)
+ None
+ end
+ | Some d ->
+ let c = Int64.neg e1res.DCE.Can.ct in
+ if Int64.mul f d >= c
+ then begin
+ (*log "newProveLe: Yes %a" DCE.Can.d_t e1res;*)
+ Some (1)
+ end else begin
+ (*log "newProveLe: couldn't prove %a" DCE.Can.d_t e1res;*)
+ None
+ end
+ end
+ | _ -> begin
+ (*log "newProveLe: not BAnd: %a" d_plainexp e;*)
+ None
+ end
+ end
+ | _ -> begin
+ (*log "newProveLe: Too Many: %a" DCE.Can.d_t e1res;*)
+ None
+ end
+ end
+
+
+type rel = Greater | LessEqual | DontKnow
+(** Return true if e1 <= e2 (statically). Reports an error if we can prove
+ * statically e1 > e2, unless allowGt = true *)
+let proveLe ?(allowGt: bool = false) (e1: exp) (e2: exp) (why: string) : rel =
+ match newProveLe e1 e2 with
+ | Some i when i > 0 -> LessEqual
+ | Some i -> begin
+ if not allowGt then
+ deputyFailLe e1 e2 why;
+ Greater
+ end
+ | None -> begin
+ let b1, off1 = getBaseOffset (stripNopCasts e1) in
+ let b2, off2 = getBaseOffset (stripNopCasts e2) in
+ if false then begin
+ log " proveLeq: Comparing:\n";
+ log " %a = (%a) + %d.\n" dx_exp e1 d_plainexp b1 off1;
+ log " %a = (%a) + %d.\n" dx_exp e2 d_plainexp b2 off2;
+ end;
+ if DCE.canonCompareExp b1 b2 then begin
+ let doCompare n1 n2 =
+ if n1 > n2 then begin
+ if not allowGt then
+ deputyFailLe e1 e2 why;
+ Greater
+ end else begin
+ LessEqual
+ end
+ in
+ let t1 = typeOf b1 in
+ let t2 = typeOf b2 in
+ match sizeOfBaseType t1, sizeOfBaseType t2 with
+ | Some n1, Some n2 -> doCompare (off1 * n1) (off2 * n2)
+ | _ when compareTypes t1 t2 -> doCompare off1 off2
+ | _ -> DontKnow
+ end else begin
+ if (proveLeWithBounds b1 b2 && off1 = 0 && off2 = 0) then
+ LessEqual
+ else
+ DontKnow
+ end
+ end
+
+
+(** Optimize an individual check *)
+let rec optimizeCheck ?(supErr: bool = false) (c: check) : check list =
+ if false then
+ ignore (log "optimizing %a\n"
+ d_instr (checkToInstr c));
+ match c with
+ | CNullOrLeq (z, _, _, _) when isZero z -> []
+
+ | CNullOrLeq (e, e1, e2, why) -> begin
+ (* There are some user defined reallocaters in bc, for example,
+ * that need this to be okay, so errors need to be suppressed until
+ * after symbolic evaluation - zra *)
+ match proveLe ~allowGt:true e1 e2 why with
+ | LessEqual -> []
+ | Greater -> begin
+ if isNonnullType (typeOf e) then begin
+ deputyFail c;
+ [c]
+ end else
+ optimizeCheck ~supErr:supErr (CEq (e, zero, why, checkText c))
+ end
+ | DontKnow -> [c]
+ end
+
+ | CLeq (e1, e2, why) -> begin
+ match proveLe ~allowGt:supErr e1 e2 why with
+ | LessEqual -> []
+ | _ -> [c]
+ end
+
+ | CNullOrLeqNT (z, _, _, _, _) when isZero z -> []
+
+ | CNullOrLeqNT (_, e1, e2, _, why)
+ | CLeqNT (e1, e2, _, why) -> begin
+ match proveLe ~allowGt:true e1 e2 why with
+ | LessEqual -> []
+ | _ -> [c]
+ end
+
+ | CEq (e1, e2, why, _) -> begin
+
+ if DCE.canonCompareExp e1 e2 then []
+ else begin
+ match proveLe ~allowGt:true e1 e2 why,
+ proveLe ~allowGt:true e2 e1 why with
+ | LessEqual, LessEqual -> []
+ | _, _ -> [c]
+ end
+
+ end
+
+ | CLeqInt (e1, e2, why) -> begin
+ match proveLe ~allowGt:supErr e1 e2 why with
+ | LessEqual -> []
+ | _ -> [c]
+ end
+
+ | CPtrArith (lo, hi, p, e, sz) -> begin
+ let ep = BinOp(PlusPI,p,e,typeOf p) in
+ match proveLe ~allowGt:supErr lo ep "lower bound check",
+ proveLe ~allowGt:supErr ep hi "upper bound check" with
+ | LessEqual, LessEqual -> []
+ | _, _ -> [c]
+ end
+
+ | CPtrArithNT (lo, hi, p, e, sz) -> begin
+ let ep = BinOp(PlusPI,p,e,typeOf p) in
+ match proveLe ~allowGt:supErr lo ep "lower bound check",
+ proveLe ~allowGt:true ep hi "nullterm upper bound check" with
+ | LessEqual, LessEqual -> []
+ | _ -> [c]
+ end
+
+ | CPtrArithAccess(lo, hi, p, e, sz) -> begin
+ let ep = BinOp(PlusPI,p,e,typeOf p) in
+ let epo = (BinOp(PlusPI,p,BinOp(PlusA,e,one,typeOf e),typeOf p)) in
+ match proveLe ~allowGt:supErr lo ep "lower bound check",
+ proveLe ~allowGt:supErr epo hi "upper bound check" with
+ | LessEqual, LessEqual -> []
+ | _, _-> [c]
+ end
+
+ | CWriteNT (_, _, z, _) when isZero z -> []
+
+ | CWriteNT (p, hi, what, sz) -> begin
+ let t = typeOf p in
+ assert (sz == (baseSize t));
+ let p_plus_one = BinOp(PlusPI, p, one, t) in
+ match proveLe ~allowGt:true p_plus_one hi "nullterm write check" with
+ | LessEqual -> []
+ | _ -> [c]
+ end
+ | CSelected e when isZero e -> begin
+ deputyFail c;
+ []
+ end
+ | _ -> [c]
+
+let opt_deputy_instr i =
+ match i with
+ | Call(Some(lv), Lval(Var vf,NoOffset), el, l) -> begin
+ if not(vf.vname = "deputy_max") then [i] else
+ match el with
+ | [e1;e2] -> begin
+ if DCE.canonCompareExp e1 e2
+ then [Set(lv,e1,l)]
+ else begin
+ match proveLe ~allowGt:true e1 e2 "deputy_max",
+ proveLe ~allowGt:true e2 e1 "deputy_max" with
+ | LessEqual, _ -> [Set(lv,e2,l)]
+ | _, LessEqual -> [Set(lv,e1,l)]
+ | _, _ -> begin
+ if !debug then
+ ignore(E.log "opt_deputy_instr: must keep %a\n" d_instr i);
+ [i]
+ end
+ end
+ end
+ | _ -> begin
+ if !debug then
+ ignore(E.log "opt_deputy_instr: not right form %a\n" d_instr i);
+ [i]
+ end
+ end
+ | _ -> begin
+ if !debug then
+ ignore(E.log "opt_deputy_instr: not deputy_max: %a\n" d_instr i);
+ [i]
+ end
+
+let optimizeVisitor ?(supErr : bool = false) () = object (self)
+ inherit nopCilVisitor
+
+ method vinst i =
+ match instrToCheck i with
+ | Some c -> ChangeTo (List.map checkToInstr (optimizeCheck ~supErr:supErr c))
+ | None -> if is_deputy_instr i
+ then ChangeTo(opt_deputy_instr i)
+ else DoChildren
+
+ method vfunc fd =
+ curFunc := fd;
+ let cleanup x =
+ curFunc := dummyFunDec;
+ x
+ in
+ ChangeDoChildrenPost (fd, cleanup)
+
+end
--- /dev/null
+(*
+ *
+ * Copyright (c) 2004,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(*
+ *
+ * dflowsens.ml
+ *
+ * A flow-sensitive optimizer for nonnull, strlen, and inequalities
+ *
+ *
+ *)
+
+open Cil
+open Expcompare
+open Pretty
+open Dattrs
+open Dutil
+open Dcheckdef
+open Doptimutil
+open Doptions
+
+open Dflowinsens
+
+module E = Errormsg
+module IH = Inthash
+module DF = Dataflow
+module S = Stats
+module P = Dptranal
+module DCE = Dcanonexp
+module DPF = Dprecfinder
+module AELV = Availexpslv
+
+(*let debug = ref true*)
+
+(*
+ * When ignore_inst returns true, then
+ * the instruction in question has no
+ * effects on the abstract state.
+ * When ignore_call returns true, then
+ * the instruction only has side-effects
+ * from the assignment if there is one.
+ *)
+let ignore_inst = ref (fun i -> false)
+let ignore_call = ref (fun i -> false)
+
+let registerIgnoreInst (f : instr -> bool) : unit =
+ let f' = !ignore_inst in
+ ignore_inst := (fun i -> (f i) || (f' i))
+
+let registerIgnoreCall (f : instr -> bool) : unit =
+ let f' = !ignore_call in
+ ignore_call := (fun i -> (f i) || (f' i))
+
+type kind =
+ | VCV (* var1 + const <= var2 *)
+ | VVC (* var1 + var2 <= const *)
+
+type absState = {
+ nonNullLvals: (lval * referenced) list; (*varinfo list;*)
+
+ strlenVars: (varinfo * (exp * referenced)) list;
+ (** (v, e, mem, vars) means that v holds the the length of string e.
+ For convenience, we also remember whether e involves a memory reference
+ and what local vars e contains. *)
+
+ ineqs: (lval * int64 * lval * referenced * kind) list;
+ (** (x, c, y, vars, VCV) means that x + c <= y.
+ (x, c, y, vars, VVC) means that x + y <= c.
+ Also, if x is a pointer and VCV, then x+c < 2^32, so x+c doesn't overflow.
+ (We usually get this fact just by knowing that any ptr arith that appears
+ in a program has first been checked for overflow with CPtrArith)
+ '+' is done on integers, not pointers.
+ We also remember the memory/variables that either expression depend on. *)
+
+ preds: (exp * int64 * referenced) list list;
+ (** list of true disjunctions. i.e. [[(e,5);(e,8)];[(f,10)]] means
+ ((e==5)\/(e==8))/\(f==10) *)
+
+ canIncrement: (lval * exp * referenced) list;
+ (** (x, e) means that x is an NT pointer that can safely be incremented
+ by e. *)
+}
+
+
+let top = { nonNullLvals = [];
+ strlenVars = [];
+ ineqs = [];
+ preds = [];
+ canIncrement = [];
+ }
+
+let printIneq (lv1,i,lv2,_,k): doc =
+ match k with
+ | VCV ->
+ dprintf "%a + %Ld <= %a" dx_lval lv1 i dx_lval lv2
+ | VVC ->
+ dprintf "%a + %a <= %Ld" dx_lval lv1 dx_lval lv2 i
+
+let d_state () a: doc =
+ if a.strlenVars == [] then
+ dprintf
+ "@[Nonnull lvals:@[%a@]\nInEqs:@[%a@]\nPreds:@[%a@]\nCanIncr:@[%a@]@]"
+ (docList (fun (lv,_) -> dx_lval () lv)) a.nonNullLvals
+ (docList ~sep:Pretty.line printIneq) a.ineqs
+ (docList ~sep:Pretty.line (fun dl -> dprintf "%a"
+ (docList (fun (e,i,_) -> dprintf "%a = %Ld" dx_exp e i)) dl)) a.preds
+ (docList ~sep:Pretty.line (fun (x,e,_) -> dprintf "%a by %a"
+ dx_lval x dx_exp e)) a.canIncrement
+ else
+ dprintf
+ "@[Nonnull lvals:@[%a@]\nStrlenVars:@[%a@]\nInEqs:@[%a@]\nPreds:@[%a@]\nCanIncr:@[%a@]@]"
+ (docList (fun (lv,_) -> dx_lval () lv)) a.nonNullLvals
+ (docList (fun (vi,(e,_)) ->
+ text(vi.vname^" for ") ++ dx_exp () e)) a.strlenVars
+ (docList ~sep:Pretty.line printIneq) a.ineqs
+ (docList ~sep:Pretty.line (fun dl -> dprintf "%a"
+ (docList (fun (e,i,_) -> dprintf "%a = %Ld" dx_exp e i)) dl)) a.preds
+ (docList ~sep:Pretty.line (fun (x,e,_) -> dprintf "%a by %a"
+ dx_lval x dx_exp e)) a.canIncrement
+
+
+(* This fake variable is used to represent 0. It should never appear in
+ output code *)
+let zeroLv : lval =
+ let v = makeVarinfo false "_ZERO_" longType in
+ var v
+
+let isNonNull' (a: absState) (lv: lval) : bool =
+ List.exists (fun (lv',_) -> DCE.canonCompareLval lv lv')
+ a.nonNullLvals
+
+let addNonNull (a:absState) (lv: lval) : absState =
+ if isNonNull' a lv then a
+ else begin
+ let kill : referenced = Dutil.varsOfExp (Lval lv) in
+ { a with nonNullLvals = (lv,kill)::a.nonNullLvals }
+ end
+
+let addStringlen (a:absState) (vi:varinfo) (str:exp) : absState =
+ try
+ let other,_ = List.assq vi a.strlenVars in
+ if DCE.canonCompareExp(*compareExpStripCasts*) other str then
+ a
+ else
+ E.s (unimp "%s is the length of two different strings: %a and %a\n"
+ vi.vname dx_exp other dx_exp str)
+ with Not_found ->
+ let kill : referenced = Dutil.varsOfExp str in
+ { a with strlenVars = (vi,(str,kill))::a.strlenVars }
+
+(* Do we know the length of this string? *)
+let hasStringlen (a:absState) (str:exp) : exp option =
+ let rec loop =
+ function (vi, (e, _))::rest ->
+ if DCE.canonCompareExp(*compareExpStripCasts*) e str then
+ Some (Lval (var vi))
+ else loop rest
+ | [] -> None
+ in
+ loop a.strlenVars
+
+let addLessEq (a:absState) (lv1: lval) (i:int64) (lv2:lval) (k:kind) : absState =
+ let alreadyExists: bool =
+ (* unlike ineqHolds, we look for this exact statement rather than a
+ stronger one. *)
+ List.exists
+ (fun (lv1', i', lv2', _,k') ->
+ (DCE.canonCompareLval lv1 lv1') && (DCE.canonCompareLval lv2 lv2') &&
+ i' = i && k = k')
+ a.ineqs
+ in
+ if alreadyExists then a
+ else begin
+ (* make a fake binop so we can get the combined deps of e1 and e2*)
+ let e' = BinOp(PlusA, Lval lv1, Lval lv2, intType) in
+ let fact = (lv1, i, lv2, Dutil.varsOfExp e', k) in
+ let a' = { a with ineqs = fact::a.ineqs } in
+ if !debug then log "New State = %a\n" d_state a';
+ a'
+ end
+
+(* is there some i for which lv1 + i <= lv2 *)
+(*let getLessEq (a:absState) (lv1 : lval) (lv2 : lval) : int64 option =*)
+
+(* If k is VCV, Is it true that (lv1 + i <= lv2)?
+ * To answer this, we look for (lv1, i', lv2) in the state, where i' >= i.
+ * If k is VVC, Is it true that (lv1 + lv2 <= i)?
+ * To answer this, we look for (lv1, i', lv2) in the state, where i' <= i. *)
+let ineqHolds (a:absState) (lv1: lval) (i:int64) (lv2:lval) (k:kind) : bool =
+ let findIneq lv1 i lv2: bool =
+ (* Search the state for lv1 + i <= lv2, or a stronger statement. *)
+ match k with
+ | VCV ->
+ List.exists
+ (fun (lv1', i', lv2', _, k') ->
+ (DCE.canonCompareLval lv1 lv1') && (DCE.canonCompareLval lv2 lv2') &&
+ i' >= i && k=k')
+ a.ineqs
+ | VVC ->
+ List.exists
+ (fun (lv1', i', lv2', _, k') ->
+ (DCE.canonCompareLval lv1 lv1') && (DCE.canonCompareLval lv2 lv2') &&
+ i' <= i && k = k')
+ a.ineqs
+ in
+(* log "Checking inequality %a + %Ld <= %a\n in %a" *)
+(* dx_lval lv1 i dx_lval lv2 d_state a; *)
+ if k = VCV && DCE.canonCompareLval lv1 lv2 then
+ (i <=% 0L)
+ else if findIneq lv1 i lv2 then
+ true
+ else if lv1 != zeroLv && lv2 != zeroLv && k = VCV then begin
+ (* One last shot: If there exists k such that lv1 <= k && k + i <= lv2,
+ then the inequality holds. *)
+ List.exists
+ (fun (lv1', negk, z, _, k') ->
+ z == zeroLv && k' = VCV && (DCE.canonCompareLval lv1 lv1')
+ (* so far, lv + negk <= 0 (i.e. lv <= -negk)
+ Now check k + i <= lv2. *)
+ && findIneq zeroLv (i -% negk) lv2)
+ a.ineqs
+ end else
+ false
+
+let isLvalZero (a : absState) (lv : lval) : bool =
+ ineqHolds a zeroLv Int64.zero lv VCV &&
+ ineqHolds a lv Int64.zero zeroLv VCV
+
+(* Is there an integer upper bound for lv1 + lv2 ? *)
+let findUpperBoundSum (a:absState) (lv1 : lval) (lv2 : lval) : int64 option =
+ let rec helper ineql io : int64 option =
+ match ineql with
+ | [] -> io
+ | (lv1p, i, lv2p, _, VVC) :: rst -> begin
+ if DCE.canonCompareLval lv1 lv1p &&
+ DCE.canonCompareLval lv2 lv2p then begin
+ match io with
+ | None -> helper rst (Some i)
+ | Some ip ->
+ if i < ip
+ then helper rst (Some i)
+ else helper rst io
+ end else helper rst io
+ end
+ | _ -> io
+ in
+ helper a.ineqs None
+
+let findUpperBound (a : absState) (lv : lval) : int64 option =
+ let rec helper ineql io : int64 option =
+ match ineql with
+ | [] -> io
+ | (lv1p, i, lv2p, _, VCV) :: rst when lv2p == zeroLv -> begin
+ if DCE.canonCompareLval lv lv1p then begin
+ match io with
+ | None -> helper rst (Some (Int64.neg i))
+ | Some ip ->
+ if i > ip
+ then helper rst (Some i)
+ else helper rst io
+ end else helper rst io
+ end
+ | _ -> io
+ in
+ helper a.ineqs None
+
+let addPred (a : absState) (djs : (exp * int64) list) : absState =
+ let djs = List.map (fun (e,i) -> (e,i,Dutil.varsOfExp e)) djs in
+ let djeq dj =
+ List.filter (fun (e,i,_) ->
+ not(List.exists (fun (e',i',_) ->
+ DCE.canonCompareExp e e' && i = i')
+ djs))
+ dj = [] &&
+ List.filter (fun (e,i,_) ->
+ not(List.exists (fun (e',i',_) ->
+ DCE.canonCompareExp e e' && i = i')
+ dj))
+ djs = []
+ in
+ if List.exists djeq a.preds then a else
+ let preds = (* if a term has a disjunct that disagrees with
+ all disjuncts of djs, then filter out the whole term *)
+ List.filter (fun dj ->
+ not(List.exists (fun (e,i,_) ->
+ not(List.exists (fun (e',i',_) ->
+ not(DCE.canonCompareExp e e') || i = i')
+ djs))
+ dj))
+ a.preds
+ in
+ let preds = List.filter (fun dj -> dj <> []) preds in
+ { a with preds = djs :: preds }
+
+let hasPred (a : absState) (p : (exp * int64) list) : bool =
+ List.exists (fun dl -> dl <> [] && List.fold_left
+ (fun b (e,i,_) -> b &&
+ List.exists (fun (e',i') ->
+ i = i' && DCE.canonCompareExp e e')
+ p)
+ true dl)
+ a.preds
+
+let addCanIncrement (a:absState) (p:lval) (howmuch:exp) : absState =
+ (* make a fake binop so we can get the combined deps of p and howmuch *)
+ let e' = BinOp(PlusA, Lval p, howmuch, intType) in
+ let fact = (p, howmuch, Dutil.varsOfExp e') in
+ if List.mem fact a.canIncrement then a
+ else
+ { a with canIncrement = fact::a.canIncrement }
+
+let canIncrement (a:absState) (p:lval) (howmuch:exp) : bool =
+ (* TODO: is it worthwhile to use inequality information here? *)
+ (List.exists
+ (fun (p', e', _) ->
+ (DCE.canonCompareLval p p') && (DCE.canonCompareExp howmuch e') )
+ a.canIncrement)
+ ||
+ (* Is howmuch == strlen(p)? *)
+ ((hasStringlen a (Lval p)) = (Some howmuch))
+
+(* Remove certain entries from a list, without preserving order *)
+let removeAll (f: 'a -> bool) (l: 'a list): 'a list =
+ if List.exists f l then
+ List.fold_left
+ (fun acc x -> if f x then acc else x::acc)
+ []
+ l
+ else
+ l
+
+let updateNonnull (a:absState) nonnull' : absState =
+ (*if nonnull' == a.nonNullVars then a
+ else*)
+ { a with nonNullLvals = nonnull' }
+
+let updateStrlen (a:absState) strlens' : absState =
+ if strlens' == a.strlenVars then a
+ else
+ { a with strlenVars = strlens' }
+let updateIneqs (a:absState) ineqs' : absState =
+ if ineqs' == a.ineqs then a
+ else
+ { a with ineqs = ineqs' }
+
+let updatePreds (a : absState) preds : absState =
+ if preds == a.preds then a
+ else { a with preds = preds }
+
+let updateCanIncr (a:absState) ci' : absState =
+ if ci' == a.canIncrement then a
+ else
+ { a with canIncrement = ci' }
+
+let scrambleVar (a:absState) (v: varinfo) : absState =
+ let a =
+ let refersToV (_, kill) = (List.memq v kill.varsRead) in
+ let nonnull' = removeAll refersToV a.nonNullLvals in
+ updateNonnull a nonnull'
+ in
+ let a =
+ let refersToV (v',(_,kill)) = (v==v') || (List.memq v kill.varsRead) in
+ let strlen' = removeAll refersToV a.strlenVars in
+ updateStrlen a strlen'
+ in
+ let a =
+ let refersToV (_,_,_,kill,_) = (List.memq v kill.varsRead) in
+ let ineqs' = removeAll refersToV a.ineqs in
+ updateIneqs a ineqs'
+ in
+ let a =
+ let reversToV dl = List.exists
+ (fun (_,_,kill) -> List.memq v kill.varsRead) dl
+ in
+ let preds' = removeAll reversToV a.preds in
+ updatePreds a preds'
+ in
+ let a =
+ let refersToV (_,_,kill) = (List.memq v kill.varsRead) in
+ let ci' = removeAll refersToV a.canIncrement in
+ updateCanIncr a ci'
+ in
+ a
+
+(* After a write to memory, scramble all vars whose addresses have been
+ taken.*)
+let scrambleMem ?(globalsToo=false) (a:absState) (eo : exp option) : absState =
+ let scrambled: varinfo -> bool =
+ fun vi -> vi.vaddrof || (vi.vglob && globalsToo)
+ in
+ let a =
+ if !doPtrAnalysis then
+ match eo with
+ | Some ee ->
+ let nonnull =
+ List.filter (fun lvr -> not(P.lval_has_alias_read ee (fst lvr)))
+ a.nonNullLvals
+ in
+ updateNonnull a nonnull
+ | None ->
+ let refersToMem (_, kill) =
+ kill.memRead || (List.exists scrambled kill.varsRead) in
+ let nonnull' = removeAll refersToMem a.nonNullLvals in
+ updateNonnull a nonnull'
+ else
+ let refersToMem (_, kill) =
+ kill.memRead || (List.exists scrambled kill.varsRead) in
+ let nonnull' = removeAll refersToMem a.nonNullLvals in
+ updateNonnull a nonnull'
+ in
+ let a =
+ if !doPtrAnalysis then
+ match eo with
+ | Some ee ->
+ let strlen =
+ List.filter (fun vir ->
+ not(P.lval_has_alias_read ee (Var (fst vir),NoOffset)))
+ a.strlenVars
+ in
+ updateStrlen a strlen
+ | None ->
+ let refersToMem (v',(_,kill)) =
+ kill.memRead || (scrambled v') || (List.exists scrambled kill.varsRead) in
+ let strlen' = removeAll refersToMem a.strlenVars in
+ updateStrlen a strlen'
+ else
+ let refersToMem (v',(_,kill)) =
+ kill.memRead || (scrambled v') || (List.exists scrambled kill.varsRead) in
+ let strlen' = removeAll refersToMem a.strlenVars in
+ updateStrlen a strlen'
+ in
+ let a =
+ if !doPtrAnalysis then
+ match eo with
+ | Some ee ->
+ let ineqs =
+ List.filter (fun (lv1,_,lv2,_,_) ->
+ not(P.lval_has_alias_read ee lv1) &&
+ not(P.lval_has_alias_read ee lv2))
+ a.ineqs
+ in
+ updateIneqs a ineqs
+ | None ->
+ let refersToMem (_,_,_,kill,_) =
+ kill.memRead || (List.exists scrambled kill.varsRead) in
+ let ineqs' = removeAll refersToMem a.ineqs in
+ updateIneqs a ineqs'
+ else
+ let refersToMem (_,_,_,kill,_) =
+ kill.memRead || (List.exists scrambled kill.varsRead) in
+ let ineqs' = removeAll refersToMem a.ineqs in
+ updateIneqs a ineqs'
+ in
+ let a =
+ if !doPtrAnalysis then
+ match eo with
+ | Some ee ->
+ let preds =
+ List.filter (fun dl -> not(List.exists
+ (fun (e,_,_) -> P.exp_has_alias_read ee e) dl))
+ a.preds
+ in
+ updatePreds a preds
+ | None ->
+ let refersToMem dl = List.exists
+ (fun (_,_,kill) ->
+ kill.memRead || (List.exists scrambled kill.varsRead))
+ dl
+ in
+ let preds = removeAll refersToMem a.preds in
+ updatePreds a preds
+ else
+ let refersToMem dl = List.exists
+ (fun (_,_,kill) ->
+ kill.memRead || (List.exists scrambled kill.varsRead))
+ dl
+ in
+ let preds = removeAll refersToMem a.preds in
+ updatePreds a preds
+ in
+ let a =
+ if !doPtrAnalysis then
+ match eo with
+ | Some ee ->
+ let ci =
+ List.filter (fun (lv,e,_) ->
+ not(P.lval_has_alias_read ee lv) &&
+ not(P.exp_has_alias_read ee e))
+ a.canIncrement
+ in
+ updateCanIncr a ci
+ | None ->
+ let refersToMem (_,_,kill) =
+ kill.memRead || (List.exists scrambled kill.varsRead) in
+ let ci' = removeAll refersToMem a.canIncrement in
+ updateCanIncr a ci'
+ else
+ let refersToMem (_,_,kill) =
+ kill.memRead || (List.exists scrambled kill.varsRead) in
+ let ci' = removeAll refersToMem a.canIncrement in
+ updateCanIncr a ci'
+ in
+ a
+
+let stateMap : absState IH.t = IH.create 50
+
+let isNonNull state e: bool =
+(* log "isNonNull? on %a.\n" d_plainexp e; *)
+ (isNonnullType (typeOf e)) ||
+ (match stripNopCasts e with
+ Lval lv ->
+ isNonNull' state lv
+ | BinOp((PlusPI|IndexPI|MinusPI), e1, e2, _) ->
+ (* We've disallowed ptr arith if e1 is null. *)
+ let t1 = typeOf e1 in
+ isPointerType t1 && not (isSentinelType t1)
+ | AddrOf lv
+ | StartOf lv -> true
+ | Const(CStr _) -> true
+ | _ -> false)
+
+let isFalse state e =
+ match e with
+ UnOp(LNot, e', _) -> isNonNull state e'
+ | _ -> isZero e
+
+
+exception CantDecompose
+
+(* Take this sum expression and return p, [off1; off2; ...], c
+ where e = p + (off1 + off2 + ... + c), p is a pointer or zeroLv,
+ and the first + is ptr arith (unless p is zeroLv). *)
+let rec expToSum (e: exp) : lval * (lval list) * int64 =
+ let e' = constFold true (stripCastsForPtrArith e) in
+ match e' with
+ Lval lv
+ | StartOf lv -> (* Treat array references as lvals. *)
+ (* we get the type of e, not e', because we want to consider casts
+ when deciding whether to classify this as a pointer or an int. *)
+ if isPointerType (typeOf e) then
+ lv, [], 0L
+ else if isArrayType (typeOf e) then
+ raise CantDecompose
+ (*E.s (bug "expToSum on %a" dx_exp e)*)
+ else
+ zeroLv, [lv], 0L
+ | Const _ when isIntegralType (typeOf e) ->
+ let c = match isInteger e' with
+ Some i64 -> i64
+ | None -> E.s (bug "expected a constant here.")
+ in
+ zeroLv, [], c
+ | BinOp((PlusPI|IndexPI), e1, e2, t) ->
+ let lvp1, offs1, c1 = expToSum e1 in
+ let lvp2, offs2, c2 = expToSum e2 in
+ if lvp2 != zeroLv then
+ E.s (bug ("expToSum on \"%a\" returned a pointer, but there should be"
+ ^^" no pointer on the right operand of PlusPI") dx_exp e);
+ if lvp1 == zeroLv then
+ E.s (unimp "expToSum returned NULL for the left operand of PlusPI");
+ lvp1, offs1@offs2, (c1+%c2)
+ | BinOp(PlusA, e1, e2, t) when isIntegralType t ->
+ let lvp1, offs1, c1 = expToSum e1 in
+ let lvp2, offs2, c2 = expToSum e2 in
+ if lvp1 != zeroLv || lvp2 != zeroLv then
+ E.s (bug ("expToSum on \"%a\" returned a pointer, but there should be"
+ ^^" no pointer with PlusA") dx_exp e);
+ zeroLv, offs1@offs2, (c1+%c2)
+ | _ ->
+ (*if !debug then
+ log "Can't decompose %a into a sum." dx_exp e;*)
+ raise CantDecompose
+
+(* Given a list of lvals, return an lval representing the sum of the list
+ elements, or raise CantDecompose if there are two or more lvals in the list*)
+let getOneLval (l:lval list) : lval =
+ match l with
+ [] -> zeroLv
+ | [lv] -> lv
+ | _ -> raise CantDecompose
+
+
+(* Decompose the expression into lv+c (integer arithmetic, not pointer),
+ or raise an exception if this isn't possible *)
+let rec expToIntSum (e:exp) : lval * int64 =
+ match expToSum e with
+ lv, [], c when lv != zeroLv -> begin
+ (* FIXME: I'm trusting here that there's no overflow, since
+ that should already be taken care of. Is there a better way to reason
+ about overlfow? *)
+ (* This is lv+c. Do the multiplication now, to handle ptr arith. *)
+ let bs = try bitsSizeOf (baseType "(sizeof base type)" (typeOfLval lv)) / 8
+ with _ -> raise CantDecompose
+ in
+ if c <> 0L then
+ lv, (c *% (Int64.of_int bs))
+ else
+ (* if c = 0, don't compute the baseSize, since we don't need to
+ (and it could be a pointer to an abstract type.) *)
+ lv, 0L
+ end
+ | z, offs, c when z == zeroLv ->
+ (* offs + c, no pointers involved. *)
+ getOneLval offs, c
+ | _ ->
+ raise CantDecompose
+
+(* Try to find an upper bound for the canon exp ce *)
+(* TODO: handle more things than just c + f1*lv1 + f2*lv2 *)
+let upperBoundCESum (state : absState) (ce : DCE.Can.t) : DCE.Can.t =
+ if !debug then
+ log "upperBoundCE: finding ubound for: %a" DCE.Can.d_t ce;
+ match ce.DCE.Can.cf with
+ | [(f1,e1) ; (f2,e2)] -> begin
+ match e1, e2 with
+ | (StartOf lv1 | Lval lv1), (StartOf lv2 | Lval lv2) -> begin
+ if f1 >=Int64.zero && f1 = f2 then begin
+ match findUpperBoundSum state lv1 lv2 with
+ | Some c64 ->
+ let c = fst(truncateInteger64 ce.DCE.Can.ck (Int64.add c64 ce.DCE.Can.ct)) in
+ {DCE.Can.ct = c; DCE.Can.cf = []; DCE.Can.ck = ce.DCE.Can.ck}
+ | None -> begin
+ if !debug then
+ log "upperBoundCE: no ubound in state %a" DCE.Can.d_t ce;
+ ce
+ end
+ end else begin
+ if !debug then
+ log "upperBoundCE: bad coefs %a" DCE.Can.d_t ce;
+ ce
+ end
+ end
+ | _ -> begin
+ if !debug then
+ log "upperBoundCE: bad form %a" DCE.Can.d_t ce;
+ ce
+ end
+ end
+ | _ -> begin
+ if !debug then
+ log "upperBoundCE: too many %a" DCE.Can.d_t ce;
+ ce
+ end
+
+
+(* TODO: overflow? *)
+let upperBoundCEAtom (state : absState) (ce : DCE.Can.t) : DCE.Can.t =
+ let rec ubExp (e : exp) : int64 option =
+ match e with
+ | Const(CInt64(i,_,_)) -> Some i
+ | Lval lv | StartOf lv -> findUpperBound state lv
+ | BinOp(Mult,e1,e2,t) -> begin
+ match ubExp e1, ubExp e2 with
+ | Some i1, Some i2 -> Some(Int64.mul i1 i2)
+ | _ -> None
+ end
+ | BinOp(Div,e1,e2,t) -> begin
+ match ubExp e1, ubExp e2 with
+ | Some i1, Some i2 -> Some(Int64.div i1 i2)
+ | _ -> None
+ end
+ | BinOp(Shiftlt,e1,e2,t) -> begin
+ match ubExp e1, ubExp e2 with
+ | Some i1, Some i2 -> Some(Int64.shift_left i1 (Int64.to_int i2))
+ | _ -> None
+ end
+ | BinOp(Shiftrt,e1,(Const _ as e2),t) when not(isSignedType t) -> begin
+ match ubExp e1, ubExp e2 with
+ | Some i1, Some i2 ->
+ Some(Int64.shift_right_logical i1 (Int64.to_int i2))
+ | _ -> None
+ end
+ | BinOp(BAnd,e1,(Const _ as e2),t) -> begin
+ match ubExp e1, ubExp e2 with
+ | Some i1, Some i2 -> Some(Int64.logand i1 i2)
+ | _ -> None
+ end
+ | BinOp(BXor,e1,(Const _ as e2),t) -> begin
+ match ubExp e1, ubExp e2 with
+ | Some i1, Some i2 -> Some(Int64.logxor i1 i2)
+ | _ -> None
+ end
+ | BinOp(BOr,e1,(Const _ as e2),t) -> begin
+ match ubExp e1, ubExp e2 with
+ | Some i1, Some i2 -> Some(Int64.logor i1 i2)
+ | _ -> None
+ end
+ | _ -> None
+ in
+ let ubTerm (f, e) : int64 option =
+ if f < Int64.zero then None else
+ match ubExp e with
+ | None -> None
+ | Some i -> Some(Int64.mul i f)
+ in
+ let rec folder sum l r : int64 * (int64 * exp) list =
+ match l with
+ | [] -> sum, r
+ | t :: rst -> begin
+ match ubTerm t with
+ | Some i -> folder (Int64.add sum i) rst r
+ | None -> folder sum rst (t::r)
+ end
+ in
+ let (c,l) = folder ce.DCE.Can.ct ce.DCE.Can.cf [] in
+ {DCE.Can.ct = c; DCE.Can.cf = l; DCE.Can.ck = ce.DCE.Can.ck}
+
+
+
+let biginteger (i : int64) : exp = Const(CInt64(i,ILongLong,None))
+
+
+
+
+(* cePosInState: "canonical expression positive in state"
+ *)
+let rec cePosInState (modify : bool)
+ (state : absState)
+ (cdiff : DCE.Can.t)
+ : bool * absState
+ =
+ if !debug then log "cePosInState: %a" DCE.Can.d_t cdiff;
+ match DCE.Can.getSign cdiff with
+ | DCE.Can.Pos | DCE.Can.Zero -> (true, state)
+ | DCE.Can.Neg -> begin
+ if !debug then
+ log "doExpLeq: can't prove %a >= 0"
+ DCE.Can.d_t cdiff;
+ (false, state)
+ end
+ | DCE.Can.DontKnow -> begin
+ match cdiff.DCE.Can.cf with
+ | [ f, e ] -> begin
+ match e with
+ | StartOf lv
+ | Lval lv ->
+ (* need to get rid of coefs on the lval *)
+ if Int64.rem (Int64.abs cdiff.DCE.Can.ct)(Int64.abs f) = Int64.zero then
+ let c = Int64.div cdiff.DCE.Can.ct (Int64.abs f) in
+ let f = Int64.div f (Int64.abs f) in
+ (* need 0 - c <= f*lv --> f*lv + c >= 0 *)
+ if f >= Int64.zero then
+ if modify then
+ (true, addLessEq state zeroLv (Int64.neg c) lv VCV)
+ else if ineqHolds state zeroLv (Int64.neg c) lv VCV then
+ (true, state)
+ else begin
+ if !debug then
+ log "doExpLeq: in state %a\ncan't prove %a >= 0"
+ d_state state DCE.Can.d_t cdiff;
+ (false, state)
+ end
+ else
+ if modify then begin
+ (true, addLessEq state lv (Int64.neg c) zeroLv VCV)
+ end else
+ if ineqHolds state lv (Int64.neg c) zeroLv VCV then
+ (true, state)
+ else begin
+ if !debug then
+ log "doExpLeq: in state %a\ncan't prove %a >= 0"
+ d_state state DCE.Can.d_t cdiff;
+ (false, state)
+ end
+ else begin
+ if !debug then
+ log "doExpLeq: bad coefs %a"
+ DCE.Can.d_t cdiff;
+ (false, state)
+ end
+ | _ -> begin
+ if !debug then
+ log "doExpLeq: bad form1: %a"
+ DCE.Can.d_t cdiff;
+ (false, state)
+ end
+ end
+ (* We've only got octagons. *)
+ | (f1,e1') :: (f2,e2') :: [] -> begin
+ (* Check that f1*e1 + f2*e2 + c >= 0 *)
+ (* We want to make sure this is non-negative *)
+ (* If f1 f2 and c are >= 0, then check e1, e2 >= 0 *)
+ if f1 >= Int64.zero && f2 >= Int64.zero &&
+ cdiff.DCE.Can.ct >= Int64.zero then
+ match e1', e2' with
+ | StartOf lv1, StartOf lv2
+ | StartOf lv1, Lval lv2
+ | Lval lv1, StartOf lv2
+ | Lval lv1, Lval lv2 ->
+ if modify then
+ let state = addLessEq state zeroLv Int64.zero lv1 VCV in
+ (true, addLessEq state zeroLv Int64.zero lv2 VCV)
+ else if (ineqHolds state zeroLv Int64.zero lv1 VCV) &&
+ (ineqHolds state zeroLv Int64.zero lv2 VCV) then
+ (true, state)
+ else begin
+ if !debug then
+ log "doExpLeq: in state %a\ncan't prove %a >= 0"
+ d_state state DCE.Can.d_t cdiff;
+ (false, state)
+ end
+ | _, _ -> begin
+ if !debug then
+ log "doExpLeq: bad form2: %a"
+ DCE.Can.d_t cdiff;
+ (false, state)
+ end
+ (* If f1 < 0, then check f2*e2 >= -f1*e1 - c *)
+ (* If f2 < 0, then check f1*e1 >= -f2*e2 - c *)
+ (* If both, then check c >= -f1*e1 + -f2*e2 *)
+ else begin
+ match e1', e2' with
+ | StartOf lv1, StartOf lv2
+ | StartOf lv1, Lval lv2
+ | Lval lv1, StartOf lv2
+ | Lval lv1, Lval lv2 -> begin
+ if (Int64.abs f1) = (Int64.abs f2) &&
+ Int64.rem (Int64.abs cdiff.DCE.Can.ct) (Int64.abs f1) = Int64.zero
+ then
+ let c = Int64.div cdiff.DCE.Can.ct (Int64.abs f1) in
+ let f1 = Int64.div f1 (Int64.abs f1) in
+ (*let f2 = f2 / (abs f2) in*)
+ if f1 < Int64.zero && f2 > Int64.zero then
+ if modify then
+ (true, addLessEq state lv1 (Int64.neg c) lv2 VCV)
+ else if ineqHolds state lv1 (Int64.neg c) lv2 VCV then
+ (true, state)
+ else begin
+ if !debug then
+ log "doExpLeq: in state %a\ncan't prove %a >= 0"
+ d_state state DCE.Can.d_t cdiff;
+ (false, state)
+ end
+ else if f2 < Int64.zero && f1 > Int64.zero then (* f2 < 0 *)
+ if modify then
+ (true, addLessEq state lv2 (Int64.neg c) lv1 VCV)
+ else if ineqHolds state lv2 (Int64.neg c) lv1 VCV then
+ (true, state)
+ else begin
+ if !debug then
+ log "doExpLeq: in state %a\ncan't prove %a >= 0"
+ d_state state DCE.Can.d_t cdiff;
+ (false, state)
+ end
+ else if f1 < Int64.zero && f2 < Int64.zero then
+ if modify then
+ (true, addLessEq state lv1 c lv2 VVC)
+ else if ineqHolds state lv1 c lv2 VVC ||
+ ineqHolds state lv2 c lv1 VVC then
+ (true, state)
+ else begin
+ if !debug then
+ log "doExpLeq: in state %a\ncan't prove %a >= 0"
+ d_state state DCE.Can.d_t cdiff;
+ (false, state)
+ end
+ else begin
+ if !debug then
+ log "doExpLeq: bad coefs: %a"
+ DCE.Can.d_t cdiff;
+ (false, state)
+ end
+ else begin
+ if !debug then
+ log "doExpLeq: bad coefs: %a"
+ DCE.Can.d_t cdiff;
+ (false, state)
+ end
+ end
+ | _, _ -> begin
+ if !debug then
+ log "doExpLeq: bad form3: %a"
+ DCE.Can.d_t cdiff;
+ (false, state)
+ end
+ end
+ end
+ | _ -> begin (false, state)
+(*
+ match upperBoundCE state ce2, modify with
+ | Some c, true ->
+ doExpLeq ~modify:modify e1 (biginteger c) state
+ | _, _ -> begin
+ if !debug then
+ log "doExpLeq: Too Many: %a"
+ DCE.Can.d_t cdiff;
+ (false, state)
+ end
+*)
+ end
+ end
+
+(* Check that e1 <= e2 in state "state"
+ * fst(doExpLeq false e1 e2 s) is true if e1 <= e2 can be proved
+ * snd(doExpLeq true e1 e2 s) is the state with e1 <= e2 added.
+ * fst(doExpLeq true e1 e2 s) is false if the state couldn't be updated.
+ *
+ *)
+and doExpLeq ?(modify:bool=false)
+ (e1 : exp)
+ (e2 : exp)
+ (state : absState)
+ : bool * absState
+ =
+ let ce1 = DCE.canonExp Int64.one e1 in
+ let ce2 = DCE.canonExp Int64.one e2 in
+ let cdiff = DCE.Can.sub ce2 ce1 ILong in
+ let cdiff =
+ if modify then cdiff else
+ let nozeroes = List.filter (isNonZeroInState state) cdiff.DCE.Can.cf in
+ {cdiff with DCE.Can.cf = nozeroes}
+ in
+ if modify && !debug then
+ log "doExpLeq: adding %a <= %a" DCE.Can.d_t ce1 DCE.Can.d_t ce2
+ else if !debug then
+ log "doExpLeq: checking if %a <= %a" DCE.Can.d_t ce1 DCE.Can.d_t ce2;
+ let (b, s) = cePosInState modify state cdiff in
+ if b then (b,s) else
+ (* The inequality could not be proved or added.
+ * If we're doing a modify, use an upper bound on e2.
+ * If we're doing a check, use an upper bound on e1
+ *)
+ if modify then begin
+ let ce2 = upperBoundCESum state ce2 in
+ let cdiff = DCE.Can.sub ce2 ce1 ILong in
+ if !debug then
+ log "doExpLeq: failed. now trying to add %a <= %a"
+ DCE.Can.d_t ce1 DCE.Can.d_t ce2;
+ cePosInState modify state cdiff
+ end else begin
+ let ce1 = upperBoundCEAtom state ce1 in
+ let cdiff = DCE.Can.sub ce2 ce1 ILong in
+ let nonzeroes = List.filter (isNonZeroInState state) cdiff.DCE.Can.cf in
+ let cdiff = {cdiff with DCE.Can.cf = nonzeroes} in
+ if !debug then
+ log "doExpLeq: failed. now checking if %a <= %a"
+ DCE.Can.d_t ce1 DCE.Can.d_t ce2;
+ cePosInState modify state cdiff
+ end
+
+
+(* return true if we know that the expression is zero.
+ false is the safe answer *)
+and isZeroInState (state : absState) (e : exp) : bool =
+ let bigone = Const(CInt64(Int64.of_int 1,IULongLong,None)) in
+ match e with
+ | Const _ when DCE.canonCompareExp e zero -> true
+ | Lval lv -> isLvalZero state lv
+ | UnOp(Neg,e,t) -> isZeroInState state e
+ | BinOp((PlusA|PlusPI|IndexPI),e1,e2,t) ->
+ isZeroInState state e1 &&
+ isZeroInState state e2
+ | BinOp((MinusA|MinusPI|MinusPP),e1,e2,t) ->
+ fst(doExpLeq e1 e2 state) &&
+ fst(doExpLeq e2 e1 state)
+ | BinOp(Mult,e1,e2,t) ->
+ isZeroInState state e1 ||
+ isZeroInState state e2
+ | BinOp(Div,e1,e2,t) ->
+ isZeroInState state e1
+ | BinOp(Shiftlt,e1,e2,t) ->
+ isZeroInState state e1
+ | BinOp(Shiftrt,e1,e2,t) when not(isSignedType t) ->
+ isZeroInState state e1 ||
+ fst(doExpLeq e1 (constFold true (BinOp(Shiftlt,bigone,e2,t))) state)
+ | BinOp(BAnd,e1,e2,t) ->
+ isZeroInState state e1 ||
+ isZeroInState state e2
+ | BinOp(BXor,e1,e2,t) ->
+ fst(doExpLeq e1 e2 state) &&
+ fst(doExpLeq e2 e1 state)
+ | BinOp(BOr,e1,e2,t) ->
+ isZeroInState state e1 &&
+ isZeroInState state e2
+ | CastE(t,e) -> isZeroInState state e
+ | _ -> false
+
+and isNonZeroInState (state : absState) (fe : int64 * exp) : bool =
+ not(isZeroInState state (snd fe))
+
+
+
+
+(* FIXME: use the sign info! E.g. add e1 >= 0 *)
+let doLessEq a (e1: exp) (e2:exp) ~(signed:bool): absState =
+ if !debug then log "Guard %a <= %a.\n" dx_exp e1 dx_exp e2;
+ try
+ let t1 = typeOf e1 in
+ let t2 = typeOf e2 in
+ let lv1, c1 = expToIntSum e1 in
+ let lv2, c2 = expToIntSum e2 in
+ (* if t1 is unsigned or pointer, then add zeroLv + 0 <= lv1 *)
+ let a =
+ match t1 with
+ | TInt(ku,_) -> addLessEq a zeroLv (~-% c1) lv1 VCV
+ | TPtr(_,_) -> addLessEq a zeroLv (~-% c1) lv1 VCV
+ | _ -> a
+ in
+ let a =
+ match t2 with
+ | TInt(ku,_) -> addLessEq a zeroLv (~-% c2) lv2 VCV
+ | TPtr(_,_) -> addLessEq a zeroLv (~-% c2) lv2 VCV
+ | _ -> a
+ in
+ (*addLessEq a lv1 (c1 -% c2) lv2*)
+ snd(doExpLeq ~modify:true e1 e2 a)
+ with CantDecompose ->
+ snd(doExpLeq ~modify:true e1 e2 a)
+
+
+let doLess a (e1: exp) (e2:exp) ~(signed:bool): absState =
+ if !debug then log "Guard %a < %a.\n" d_exp e1 d_exp e2;
+ try
+ let t1 = typeOf e1 in
+ let t2 = typeOf e2 in
+ let lv1, c1 = expToIntSum e1 in
+ let lv2, c2 = expToIntSum e2 in
+ (* if t1 is unsigned or pointer, then add zeroLv + 0 <= lv1 *)
+ let a =
+ match t1 with
+ | TInt(ku,_) when not(isSigned ku) -> addLessEq a zeroLv (~-% c1) lv1 VCV
+ | TPtr(_,_) -> addLessEq a zeroLv (~-% c1) lv1 VCV
+ | _ -> a
+ in
+ let a =
+ match t2 with
+ | TInt(ku,_) when not(isSigned ku) -> addLessEq a zeroLv (~-% c2) lv2 VCV
+ | TPtr(_,_) -> addLessEq a zeroLv (~-% c2) lv2 VCV
+ | _ -> a
+ in
+ (*addLessEq a lv1 (1L +% c1 -% c2) lv2*)
+ let e' = BinOp(PlusPI,e1,one,typeOf e1) in
+ snd(doExpLeq ~modify:true e' e2 a)
+ with CantDecompose ->
+ let e' = BinOp(PlusPI,e1,one,typeOf e1) in
+ snd(doExpLeq ~modify:true e' e2 a)
+
+
+(* Turn a conjunction into a list of conjuncts *)
+let expToConjList (e:exp) : (exp list) =
+ let rec helper e l =
+ match e with
+ | BinOp(LAnd, e1, e2, _) ->
+ let l1 = helper e1 [] in
+ let l2 = helper e2 [] in
+ l@l1@l2
+ | _ -> e::l
+ in
+ helper e []
+
+let expToDisjList (e:exp) : (exp list) =
+ let rec helper e l =
+ match e with
+ | BinOp(LOr, e1, e2, _) ->
+ let l1 = helper e1 [] in
+ let l2 = helper e2 [] in
+ l@l1@l2
+ | _ -> e::l
+ in
+ helper e []
+
+class nonDisjEqTestFinderClass (b : bool ref) = object(self)
+ inherit nopCilVisitor
+
+ method vexpr (e : exp) =
+ match e with
+ | BinOp(Eq,_,_,_) -> SkipChildren
+ | BinOp(LOr,_,_,_) -> DoChildren
+ | BinOp(_,_,_,_)
+ | UnOp(_,_,_) ->
+ b := true;
+ SkipChildren
+ | _ -> SkipChildren
+
+end
+
+let onlyDisjEqTests (e : exp) : bool =
+ let br = ref false in
+ ignore(visitCilExpr (new nonDisjEqTestFinderClass br) e);
+ not(!br)
+
+let mkAddablePred (p : exp) : (exp * int64) list =
+ let djs = expToDisjList p in
+ List.map (fun p -> match p with
+ | BinOp(Eq,e1,e2,_) -> begin
+ match isInteger e1, isInteger e2 with
+ | None, Some i -> (e1,i)
+ | Some i, None -> (e2,i)
+ | _ -> (p,Int64.one) (* if onlyDisjEqTests p, then impossible *)
+ end
+ | _ -> (p,Int64.one)) (* if onlyDisjEqTests p, then impossible *)
+ djs
+
+let doOneBranch (a:absState) (e:exp) : absState =
+ if !debug then
+ log "Guard %a.\n" dx_exp e;
+ let rec simplifyBoolExp e =
+ match stripNopCasts e with
+ UnOp(LNot, UnOp(LNot, e, _), _) -> simplifyBoolExp e
+ | BinOp(Ne, e, z, _) when isZero z -> simplifyBoolExp e
+ | UnOp(LNot,BinOp(Ne,e1,e2,t),_) ->
+ BinOp(Eq,e1,e2,t)
+ | UnOp(LNot, BinOp(Eq, e, z, _), _) -> simplifyBoolExp e
+ | UnOp(LNot, BinOp(Lt, e1, e2, t), _) ->
+ BinOp(Ge, e1, e2, t)
+ | UnOp(LNot, BinOp(Le, e1, e2, t), _) ->
+ BinOp(Gt, e1, e2, t)
+ | UnOp(LNot, BinOp(Gt, e1, e2, t), _) ->
+ BinOp(Le, e1, e2, t)
+ | UnOp(LNot, BinOp(Ge, e1, e2, t), _) ->
+ BinOp(Lt, e1, e2, t)
+ | e -> e
+ in
+ let e = simplifyBoolExp e in
+ match e with
+ | Lval lv -> begin
+ let a =
+ match lv with
+ | (Mem(Lval lvp), NoOffset) when isNullterm (typeOfLval lvp) ->
+ addCanIncrement a lvp Cil.one
+ | _ -> a
+ in
+ if isPointerType(typeOf e) then
+ addNonNull a lv
+ else
+ a
+ end
+ | BinOp(Lt, e1, e2, t) when isIntOrPtrType (typeOf e1) ->
+ let e1 = stripNopCasts e1 in
+ let e2 = stripNopCasts e2 in
+ doLess a e1 e2 ~signed:(isSignedType (typeOf e1))
+ | BinOp(Le, e1, e2, t) when isIntOrPtrType (typeOf e1) ->
+ let e1 = stripNopCasts e1 in
+ let e2 = stripNopCasts e2 in
+ doLessEq a e1 e2 ~signed:(isSignedType (typeOf e1))
+ | BinOp(Gt, e1, e2, t) when isIntOrPtrType (typeOf e1) ->
+ let e1 = stripNopCasts e1 in
+ let e2 = stripNopCasts e2 in
+ doLess a e2 e1 ~signed:(isSignedType (typeOf e1))
+ | BinOp(Ge, e1, e2, t) when isIntOrPtrType (typeOf e1) ->
+ let e1 = stripNopCasts e1 in
+ let e2 = stripNopCasts e2 in
+ doLessEq a e2 e1 ~signed:(isSignedType (typeOf e1))
+ | e -> if onlyDisjEqTests e then addPred a (mkAddablePred e) else a
+
+(* Update a state to reflect a branch *)
+let doBranch (a:absState) (e:exp) : absState =
+ if !debug then log "doBranch: for branch %a: state %a ->"
+ d_exp e d_state a;
+ let conjList = expToConjList e in
+ let newstate = List.fold_left doOneBranch a conjList in
+ if !debug then log "doBranch: result %a" d_state newstate;
+ newstate
+
+(* Add that
+ * lv >= e1 and
+ * lv >= e2
+ *)
+let doMax a lv e1 e2 =
+ let a' = doLessEq a e1 (Lval lv) ~signed:(isSignedType(typeOf e1)) in
+ let a' = doLessEq a' e2 (Lval lv) ~signed:(isSignedType(typeOf e2)) in
+ a'
+
+
+(* Update a state to reflect a check *)
+let processCheck a (c:check) : absState =
+ match c with
+ CNonNull e -> doBranch a e
+ | CLeq(e1, e2, _) -> doLessEq a e1 e2 ~signed:false
+ | CLeqInt(e1, e2, _) -> doLessEq a e1 e2 ~signed:false
+ | CPtrArith(lo, hi, p, e, _) ->
+ let e' = BinOp(PlusPI,p,e,typeOf p) in
+ (*let a = doLessEq a e' (kinteger64 IUInt (maxUnsignedInt(typeOf e'))) ~signed:false in*)
+ let a = doLessEq a lo e' ~signed:false in
+ doLessEq a e' hi ~signed:false
+ | CPtrArithNT(lo, hi, p, e, _) ->
+ let e' = BinOp(PlusPI,p,e,typeOf p) in
+ (*let a = doLessEq a e' (kinteger64 IUInt (maxUnsignedInt(typeOf e'))) ~signed:false in*)
+ let a = doLessEq a lo e' ~signed:false in
+ a (* no upper bound *)
+ | CPtrArithAccess(lo, hi, p, e, _) ->
+ let e' = BinOp(PlusPI,p,e,typeOf p) in
+ (*let a = doLessEq a e' (kinteger64 IUInt (maxUnsignedInt(typeOf e'))) ~signed:false in*)
+ let a = doLessEq a lo e' ~signed: false in
+ doLessEq a (BinOp(PlusPI,p,BinOp(PlusA,e,one,typeOf e),typeOf p)) hi ~signed:false
+ | CSelected e -> doBranch a e
+ | CNotSelected e -> doBranch a (UnOp(LNot,e,typeOf e))
+ | _ -> a
+
+(* Add to anext any relevant inequality information for the assignment
+ dest := e
+*)
+let doSet ~(aold:absState) ~(anext:absState) (dest: lval) (e:exp) : absState =
+ if !debug then log "doSet: %a := %a\n" dx_lval dest dx_exp e;
+ match isInteger (constFold true e) with
+ Some i ->
+ (* Add dest <= i and i <= dest *)
+ let anext = addLessEq anext dest (~-% i) zeroLv VCV in
+ let anext = addLessEq anext zeroLv i dest VCV in
+ anext
+ | None -> begin
+ let anext = match e with
+ Lval lv ->
+ (* For each fact about lv in the old state,
+ add an analogous fact about dest *)
+ List.fold_left
+ (fun anext (lv1, e, _) ->
+ if DCE.canonCompareLval lv1 lv then
+ addCanIncrement anext dest e
+ else
+ anext)
+ anext
+ aold.canIncrement
+ | _ -> anext
+ in
+ try
+ let lvrhs, c = expToIntSum e in
+ if c = 0L then begin
+ (* The assignment is dest := lvrhs *)
+
+ (* For each fact about lvrhs in the old state,
+ add an analogous fact about dest *)
+ List.fold_left
+ (fun anext (lv1, n, lv2, _, k) ->
+ let anext = if DCE.canonCompareLval lv1 lvrhs then
+ addLessEq anext dest n lv2 k
+ else anext in
+ let anext = if DCE.canonCompareLval lv2 lvrhs then
+ addLessEq anext lv1 n dest k
+ else anext in
+ anext)
+ anext
+ aold.ineqs
+ end
+ else begin
+ (* The assignment is dest := lvrhs+c, where c is an int *)
+
+ (* For each fact about lvrhs in the old state,
+ add a fact about dest, after adjusting by c *)
+ let anext =
+ List.fold_left
+ (fun anext (z, n, lv2, _, k) ->
+ (* We have to be very conservative, because of
+ overflow. If 0+n <= lvrhs AND lvrhs <= MAXINT-c,
+ then "dest := lvrhs+c" does not overflow, and we
+ get the new fact 0 + (n+c) <= dest *)
+ if (z == zeroLv && DCE.canonCompareLval lv2 lvrhs) (*&& k = VCV*)
+ (* so far, 0+n <= lvrhs *)
+ &&
+ (ineqHolds aold lvrhs (c -% (maxUnsignedInt(typeOf e))) zeroLv VCV)
+ (* now lvrhs <= MAXINT-c. To see this, note that the line
+ above tests lvrhs + c-MAXINT <= 0, i.e. lvrhs <= -(c-MAXINT)
+ *)
+ then begin
+ if !debug then log "doSet: adding 0 + %Ld <= %a\n"
+ (n +% c) d_lval dest;
+ addLessEq anext zeroLv (n +% c) dest k
+ end else if (DCE.canonCompareLval dest lvrhs) (* y = y + c *)
+ && (DCE.canonCompareLval dest lv2) (* z + n <= y *)
+ (*&& k = VCV*)
+ && (ineqHolds aold dest (c -% (maxUnsignedInt(typeOf e))) zeroLv VCV)
+ (* y + c doesn't overflow *)
+ then
+ addLessEq anext z (n +% c) dest k
+ else if (DCE.canonCompareLval dest lvrhs) (* y = y + c *)
+ && (DCE.canonCompareLval dest z) (* y + n <= lv2 *)
+ (*&& k = VCV*)
+ && (ineqHolds aold dest (c -% (maxUnsignedInt(typeOf e))) zeroLv VCV)
+ (* y + c doesn't overflow *)
+ then
+ addLessEq anext z (n -% c) lv2 k
+ else
+ anext)
+ anext
+ aold.ineqs
+ in
+ if !debug then log "doSet: result = %a\n" d_state anext;
+ anext
+ end
+ with CantDecompose ->
+ anext
+ end
+
+let handleCall = P.handleCall (scrambleMem ~globalsToo:true)
+
+let fdato : DPF.functionData option ref = ref None
+let flowHandleInstr a i =
+ if !debug then E.log "Doing instr %a in state %a\n" d_instr i d_state a;
+ match instrToCheck i with
+ | Some c -> processCheck a c
+ | None -> begin
+ match i with
+
+ | Set (lh, e, _) when DCE.canonCompareExp (Lval lh) e -> a
+ | Set ((Var vi, NoOffset) as dest, e, _)
+ when isPointerType vi.vtype -> begin
+ let anext = scrambleVar a vi in
+ let anext = if isNonNull a e then
+ addNonNull anext dest
+ else
+ anext
+ in
+ doSet ~aold:a ~anext dest e
+ end
+ | Set ((Var vi, _) as dest, e, _)->
+ let anext = scrambleVar a vi in
+ let anext = if isNonNull a e then
+ addNonNull anext dest
+ else
+ anext
+ in
+ doSet ~aold:a ~anext dest e
+ | Set ((Mem ee, _), _, _)->
+ (* FIXME: Is this sound? What if the address of a global is taken
+ * somewhere and then written through the pointer? *)
+ scrambleMem a (Some ee)
+ | Call (Some(Var vi, NoOffset), Lval (Var vf, NoOffset),
+ [estr; bytes], _)
+ when (vf.vname = "deputy_findnull") -> begin
+ if not (isIntegralType vi.vtype) || not (isPointer estr) then
+ E.s (bug "bad arg to %s\n" vf.vname);
+ let a = scrambleVar a vi in
+ addStringlen a vi estr
+ end
+ | Call (Some(Var vi, NoOffset), Lval (Var vf, NoOffset),
+ [estr], _)
+ when (vf.vname = "strlen") -> begin
+ if not (isIntegralType vi.vtype)
+ || ((baseSize (typeOf estr)) <> 1) then
+ E.s (bug "bad arg to %s\n" vf.vname);
+ let a = scrambleVar a vi in
+ addStringlen a vi estr
+ end
+ | Call (Some(Var vi, NoOffset), Lval(Var vf, NoOffset),[e1;e2], _)
+ when vf.vname = "deputy_max" -> begin
+ let a' = scrambleVar a vi in
+ doMax a' (Var vi, NoOffset) e1 e2
+ end
+ | Call (Some (Var vi, NoOffset), f, args, _) when isPointerType vi.vtype ->
+ let a =
+ if is_deputy_instr i || (!ignore_call) i then
+ scrambleVar a vi
+ else
+ handleCall (!fdato) f args (scrambleVar a vi)
+ (*scrambleMem ~globalsToo:true (scrambleVar a vi) None*)
+ in
+ let rt, _, _, _ = splitFunctionType (typeOf f) in
+ if isNonnullType rt then
+ addNonNull a (Var vi, NoOffset)
+ else
+ a
+ | Call (Some lv, f, args, _) ->
+ let a =
+ match lv with
+ | (Var vi, _) -> scrambleVar a vi
+ | (Mem ee, _) -> scrambleMem a (Some ee)
+ in
+ if !ignore_call i || is_deputy_instr i then
+ a
+ else
+ handleCall (!fdato) f args a
+ | Call (_, f, args, _) ->
+ if (!ignore_call) i then a else
+ handleCall (!fdato) f args a
+ (*scrambleMem ~globalsToo:true a None*)
+ | Asm (_, _, writes, _, _, _) ->
+ (* This is a quasi-sound handling of inline assembly *)
+ let a = scrambleMem a None in
+ List.fold_left (fun a (_,_,(lh,_)) ->
+ match lh with Var vi -> scrambleVar a vi
+ | Mem _ -> a)
+ a
+ writes
+ end
+
+
+module Flow = struct
+ let name = "DeputyOpt"
+ let debug = debug
+ type t = absState
+ let copy x = x
+ let stmtStartData = stateMap
+ let pretty = d_state
+ let computeFirstPredecessor s a = a
+
+ let combinePredecessors s ~(old:t) newa =
+ let nnv = List.filter
+ (fun (lv,_) -> isNonNull' newa lv)
+ old.nonNullLvals
+ in
+ let sv = List.filter
+ (fun x -> List.mem x newa.strlenVars)
+ old.strlenVars
+ in
+ let ie = List.filter
+ (fun ((lv1, c, lv2, _, k) as x) ->
+ (* Make sure newa contains something at least as strong as x *)
+ (List.memq x newa.ineqs) (* for performance *)
+ || (ineqHolds newa lv1 c lv2 k))
+ old.ineqs
+ in
+ let ps = List.filter
+ (fun dl -> hasPred newa (List.map (fun (e,i,_) -> (e,i)) dl))
+ old.preds
+ in
+ let ci = List.filter
+ (fun x -> List.mem x newa.canIncrement)
+ old.canIncrement
+ in
+ if (List.length nnv <> List.length old.nonNullLvals)
+ || (List.length sv <> List.length old.strlenVars)
+ || (List.length ie <> List.length old.ineqs)
+ || (List.length ps <> List.length old.preds)
+ || (List.length ci <> List.length old.canIncrement) then
+ Some {nonNullLvals = nnv; strlenVars = sv; ineqs = ie; preds = ps; canIncrement = ci}
+ else
+ None (* at fixed point *)
+
+ let doInstr i a =
+(* log "Visiting %a State is %a.\n" dn_instr i d_state a; *)
+ DF.Done (flowHandleInstr a i)
+
+ let doStmt s a =
+ curStmt := s.sid;
+ DF.SDefault
+
+ let doGuard e a =
+ if isFalse a e then DF.GUnreachable
+ else DF.GUse (doBranch a e)
+
+ let filterStmt s = true
+end
+
+module FlowEngine = DF.ForwardsDataFlow (Flow)
+
+(* a single term in a.preds precludes every case in djs *)
+let predDisjNotSelected (a : absState) (djs : exp) =
+ let djs = mkAddablePred djs in
+ List.exists (fun adjs ->
+ not(List.exists (fun (e,i,_) ->
+ List.exists (fun (e',i') ->
+ i = i' && DCE.canonCompareExp e e') djs) adjs)) a.preds
+
+let flowOptimizeCheck (c: check) ((inState, acc):(absState * check list))
+ : (absState * check list) =
+ let isNonNull = isNonNull inState in
+ (* Returns true if CPtrArith(lo, hi, p, Lval x, sz) can be optimized away:*)
+ let checkPtrArith lo hi p e : bool =
+ let e' = BinOp(PlusPI,p,e,typeOf p) in
+ (*(fst (doExpLeq e' (kinteger64 IUInt (maxUnsignedInt(typeOf e'))) inState)) &&*)
+ (fst (doExpLeq lo e' inState)) &&
+ (fst (doExpLeq e' hi inState))
+ in
+ (* Returns true if CPtrArithAccess(lo, hi, p, Lval x, sz) can be optimized away:*)
+ let checkPtrArithAccess lo hi p e : bool =
+ let e' = BinOp(PlusPI,p,e,typeOf p) in
+ (*(fst (doExpLeq e' (kinteger64 IUInt (maxUnsignedInt(typeOf e'))) inState)) &&*)
+ (fst (doExpLeq lo e' inState)) &&
+ (fst (doExpLeq (BinOp(PlusPI,p,BinOp(PlusA,e,one,typeOf e),typeOf p)) hi inState))
+ in
+ (* Returns true if CLeq(e1, e2) can be optimized away:*)
+ let checkLeq e1 e2 : bool =
+ fst (doExpLeq e1 e2 inState)
+ in
+
+ (* doOpt is called recursivly if we simplify the check to a different check
+ that has its own optimization rule.
+ It returns the simplified check, or None if we satisfied the check
+ completely.*)
+ let rec doOpt (c : check) : check option =
+ match c with
+ | CNonNull e1 when isNonNull e1 ->
+ None
+ | CNonNull e1 when isZero e1 ->
+ error "non-null check will always fail.";
+ Some c
+ | CNullOrLeq (e1, _, _, why)
+ | CNullOrLeqNT (e1, _, _, _, why) when isZero e1 ->
+ None
+ | CNullOrLeq (e1, e2, e3, why) when isNonNull e1 ->
+ doOpt (CLeq(e2, e3, why))
+ | CNullOrLeqNT (e1, e2, e3, e4, why) when isNonNull e1 ->
+ let c' = CLeqNT(e2, e3, e4, why) in
+ doOpt c'
+ | CPtrArithAccess (lo, hi, p, e, sz) when checkPtrArithAccess lo hi p e ->
+ None
+ | CPtrArith (lo, hi, p, e, sz)
+ | CPtrArithNT (lo, hi, p, e, sz) when checkPtrArith lo hi p e ->
+ None
+ | CPtrArithNT (_, _, Lval p, e, _) when canIncrement inState p e ->
+ None
+ | CLeq (e1, e2, _)
+ | CNullOrLeq (_, e1, e2, _)
+ | CNullOrLeqNT (_, e1, e2, _, _) when checkLeq e1 e2 ->
+ None
+ | CLeq(e1, e2, why) when isZero e2 && isNonNull e1 &&
+ not (isSignedType (typeOf e1)) ->
+ deputyFail c;
+ Some c
+ | CEq (e1, e2, why, _) when isZero e2 && isNonNull e1 -> begin
+ deputyFail c;
+ Some c
+ end
+ | CLeqNT (e1, e2, sz, why) -> begin
+ match hasStringlen inState e2 with
+ Some len ->
+ let e2' = BinOp(PlusPI, e2, len, typeOf e2) in
+ (* len == strlen(e2). So rewrite the check as e1 <= e2+len *)
+ (* This will often be optimized away completely
+ by a later pass, since e1 often equals e2' *)
+ doOpt (CLeq(e1, e2', why))
+ | None -> Some c
+ end
+ | CLeqInt (e1, (BinOp (MinusPP, hi, p, _)), _) ->
+ let e' = BinOp(PlusPI, p, e1, (typeOf p)) in
+ if checkLeq e' hi then
+ None
+ else
+ Some c
+ | CSelected e ->
+ if onlyDisjEqTests e && hasPred inState (mkAddablePred e)
+ then None
+ else Some c
+ | CNotSelected e ->
+ if (onlyDisjEqTests e && predDisjNotSelected inState e)
+ then None
+ else Some c
+ | _ -> Some c
+ in
+ let acc' = match doOpt c with
+ Some c -> c::acc | None -> acc
+ in
+ (processCheck inState c), acc'
+
+
+(* returns the largest prefix of l such that each
+ * element of the prefix satisfies p *)
+let prefix p l =
+ let rec helper p l seen =
+ match l with
+ | [] -> (List.rev seen, [])
+ | x :: rst -> begin
+ if p x
+ then helper p rst (x::seen)
+ else (List.rev seen, x :: rst)
+ end
+ in
+ helper p l []
+
+
+class flowOptimizeVisitor tryReverse = object (self)
+ inherit nopCilVisitor
+
+ val mutable curSid = -1
+
+ method vstmt s =
+ (* now that checks and instructions can be mixed,
+ * the state has to be changed when an instruction is
+ * visited *)
+ let rec filterIl state il fl =
+ match il with
+ | [] -> List.rev fl
+ | i::rest -> begin
+ (* Make sure to update the location for checkToInstr's use. *)
+ currentLoc := get_instrLoc i;
+ let new_state = flowHandleInstr state i in
+ if !debug then log "state after %a is %a\n" d_instr i d_state new_state;
+ match instrToCheck i with
+ | Some c -> begin
+ let _, c' = flowOptimizeCheck c (state,[]) in
+ match c' with
+ | [] -> begin
+ if !debug then ignore(E.log "fOV: in state %a, optimized %a out\n"
+ d_state state d_instr i);
+ filterIl new_state rest fl
+ end
+ | [nc] -> begin
+ let i' = checkToInstr nc in
+ if !debug then ignore(E.log "fOV: changed to %a\n" d_instr i');
+ filterIl new_state rest (i'::fl)
+ end
+ | _ -> begin
+ if !debug then ignore(E.log "fOV: didn't remove %a\n" d_instr i);
+ filterIl new_state rest (i::fl)
+ end
+ end
+ | None -> filterIl new_state rest (i::fl)
+ end
+ in
+ begin
+ try
+ curSid <- s.sid;
+ let state = IH.find stateMap s.sid in
+ if !debug then
+ E.log "Optimizing statement %a with state %a\n" d_stmt s d_state state;
+ begin
+ match s.skind with
+ (* Don't remove explicit programmer checks. There might be
+ special error handling
+ | If(e, blk1, blk2, l) when isNonNull state e ->
+ if hasALabel blk2 then
+ s.skind <- If(Cil.one, blk1, blk2, l)
+ else
+ (* blk2 is unreachable *)
+ s.skind <- Block blk1
+ | If(e, blk1, blk2, l) when isFalse state e ->
+ if hasALabel blk1 then
+ s.skind <- If(Cil.zero, blk1, blk2, l)
+ else
+ (* blk1 is unreachable *)
+ s.skind <- Block blk2*)
+ | Instr il ->
+ if tryReverse then
+ let il' = filterIl state il [] in
+ let (pre, rst) = prefix is_check_instr il' in
+ let il'' = filterIl state (List.rev pre) [] in
+ s.skind <- Instr((List.rev il'')@rst)
+ else
+ s.skind <- Instr(filterIl state il [])
+ | _ -> ()
+ end
+ with Not_found -> () (* stmt is unreachable *)
+ end;
+ DoChildren
+
+ method vfunc fd =
+ curFunc := fd;
+ let cleanup x =
+ curFunc := dummyFunDec;
+ x
+ in
+ ChangeDoChildrenPost (fd, cleanup)
+
+end
+
+let addNonNullLocals (fd : fundec) (a : absState) : absState =
+ let nnls = List.filter (fun vi ->
+ match vi.vtype with
+ | TArray _ -> true
+ | _ -> false) fd.slocals
+ in
+ let nnlvals = List.map (fun vi ->
+ let lv = (Var vi, NoOffset) in
+ let refd = Dutil.varsOfExp (Lval lv) in
+ (Var vi, NoOffset), refd) nnls
+ in
+ { a with nonNullLvals = nnlvals }
+
+class switchFinderClass (br : bool ref) = object(self)
+ inherit nopCilVisitor
+
+ method vstmt (s : stmt) =
+ match s.skind with
+ | Switch _ ->
+ br := true;
+ SkipChildren
+ | _ -> DoChildren
+
+end
+
+let funHasSwitch (fd : fundec) : bool =
+ let br = ref false in
+ ignore(visitCilFunction (new switchFinderClass br) fd);
+ !br
+
+class cSelectedFinderClass (br : bool ref) = object(self)
+ inherit nopCilVisitor
+
+ method vinst (i : instr) =
+ match instrToCheck i with
+ | Some(CNotSelected _)
+ | Some(CSelected _) ->
+ br := true;
+ SkipChildren
+ | _ -> DoChildren
+
+end
+
+let funHasCSelected (fd : fundec) : bool =
+ let br = ref false in
+ ignore(visitCilFunction (new cSelectedFinderClass br) fd);
+ !br
+
+(** flow-sensitive optimizer for nonnull, strlen, and inequalities*)
+let doFlowAnalysis ?(tryReverse:bool=false)
+ (fd:fundec)
+ (fdat : DPF.functionData)
+ : unit
+ =
+ try
+ IH.clear stateMap;
+ if funHasSwitch fd && funHasCSelected fd then begin
+ prepareCFG fd;
+ Cfg.clearCFGinfo fd;
+ ignore (Cfg.cfgFun fd)
+ end;
+ let fst = List.hd fd.sbody.bstmts in
+ let t = addNonNullLocals fd top in
+ let precs =
+ match IH.tryfind fdat.DPF.fdPCHash fd.svar.vid with
+ | None -> []
+ | Some cl -> cl
+ in
+ let t = List.fold_left flowHandleInstr t precs in
+ IH.add stateMap fst.sid t;
+ FlowEngine.compute [fst];
+ if !debug then
+ E.log "%s: finished analysis; starting optimizations.\n" Flow.name;
+ ignore (visitCilFunction (new flowOptimizeVisitor tryReverse) fd);
+ IH.clear stateMap;
+ curStmt := -1;
+ ()
+ with Failure "hd" -> ()
+
+
+class nonNullReturnCheckerClass (br : bool ref) = object(self)
+ inherit nopCilVisitor
+
+ method vstmt s =
+ match s.skind with
+ | Return(eo, _) -> begin
+ match eo with
+ | None -> begin
+ br := false;
+ SkipChildren
+ end
+ | Some e -> begin
+ match IH.tryfind stateMap s.sid with
+ | None -> begin
+ br := false;
+ SkipChildren
+ end
+ | Some state -> begin
+ br := (!br) && isNonNull state e;
+ DoChildren
+ end
+ end
+ end
+ | _ -> DoChildren
+end
+
+
+let isReturnNonNull (fvar : varinfo) (f : file) : bool =
+ try
+ let fdg = List.find (fun g -> match g with
+ | GFun(fd, _ ) -> fd.svar.vname = fvar.vname
+ | _ -> false) f.globals
+ in
+ match fdg with
+ | GFun(fd, _) -> begin
+ IH.clear stateMap;
+ let fst = List.hd fd.sbody.bstmts in
+ IH.add stateMap fst.sid top;
+ FlowEngine.compute [fst];
+ let br = ref true in
+ ignore(visitCilFunction (new nonNullReturnCheckerClass br) fd);
+ IH.clear stateMap;
+ curStmt := -1;
+ !br
+ end
+ | _ -> false
+ with
+ | Failure "hd" -> false
+ | Not_found -> false
+
+
+
+let reportStats () = ()
--- /dev/null
+(*
+ *
+ * Copyright (c) 2004,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(*
+ * dfwdsubst.ml
+ *
+ * The visitor below symbolically evaluates expressions
+ * inside of checks for easy consumption by the other
+ * passes.
+ *
+ *)
+
+open Cil
+open Pretty
+open Dutil
+open Dcheckdef
+open Doptimutil
+
+module E = Errormsg
+module AE = Availexps
+module AELV = Availexpslv
+module UD = Usedef
+module RCT = Rmciltmps
+module S = Stats
+module IH = Inthash
+
+module DFI = Dflowinsens
+
+let doTime = ref false
+
+let time s f a =
+ if !doTime then
+ S.time s f a
+ else f a
+
+(* First, some things for handling funkyness created by the composition
+ * of CIL transformations and Deputy transormations in regards to
+ * temporaries created for function calls. This will make reducing the
+ * number of remaining temps(and even some checks) easier. *)
+
+(* Type for the form of temporary variable names *)
+type nameform = Suffix of string | Prefix of string | Exact of string
+
+(* check if a name matches a form *)
+(* string -> nameform -> bool *)
+let check_form s f =
+ match f with
+ Suffix sfx ->
+ let frmlen = String.length sfx in
+ let slen = String.length s in
+ slen >= frmlen &&
+ compare (String.sub s (slen - frmlen) frmlen) sfx = 0
+ | Prefix pfx ->
+ let frmlen = String.length pfx in
+ String.length s >= frmlen &&
+ compare (String.sub s 0 frmlen) pfx = 0
+ | Exact ext ->
+ let frmlen = String.length ext in
+ String.length s = frmlen &&
+ compare s ext = 0
+
+(* check a name against a list of forms
+ if it matches any then return true *)
+(* string -> nameform list -> bool *)
+let inTmpForm s fl =
+ List.fold_left (fun b f -> b || check_form s f)
+ false fl
+
+let tmpForms = [Exact "tmp";
+ Prefix "tmp___";
+ Prefix "__cil_tmp";
+ Suffix "__e";
+ Suffix "__b";]
+
+
+
+(* This will clean up the CIL a bit so that
+ the forward substitution can do a better job *)
+(* If we see:
+ tmp = f(...);
+ notatemp = tmp;
+ then replace with:
+ notatemp = f(...);
+ tmp = notatemp;
+ *)
+class symEvalPrePass (fd : fundec) = object(self)
+ inherit nopCilVisitor
+
+ method private procIl il =
+ let rec helper il seen = match il with
+ | [] -> List.rev seen
+ | [x] -> List.rev (x::seen)
+ | i1::i2::rest -> begin
+ match i1, i2 with
+ | Call(Some(Var rvi, NoOffset), flv, el, l),
+ Set((Var vi', NoOffset), Lval(Var rvi', NoOffset),l')
+ when inTmpForm rvi.vname tmpForms && not(inTmpForm vi'.vname tmpForms)
+ && rvi'.vid = rvi.vid
+ -> begin
+
+ if !debug then ignore(E.log "Merging Instructions %a and %a\n"
+ d_instr i1 d_instr i2);
+ let new1 = Call(Some(Var vi',NoOffset),flv,el,l) in
+ let new2 = Set((Var rvi,NoOffset),Lval(Var vi',NoOffset),l') in
+ helper rest (new2::new1::seen)
+ end
+ | Set((Var vi1, NoOffset), Lval(Var vir1, NoOffset), l1),
+ Set((Var vi2, NoOffset), Lval(Var vir2, NoOffset), ll2)
+ when inTmpForm vi1.vname tmpForms &&
+ inTmpForm vir1.vname tmpForms &&
+ vir1.vid = vir2.vid &&
+ not(inTmpForm vi2.vname tmpForms) -> begin
+ match seen with
+ | [] -> helper rest (i1::i2::seen)
+ | i3 :: seen -> (* backtrack and try again *)
+ helper (i3 :: i2 :: i1 :: rest) seen
+ end
+ | _, _ -> begin
+ helper (i2::rest) (i1::seen)
+ end
+ end
+ in
+ helper il []
+
+ method private procStmt s =
+ match s.skind with
+ | Instr il -> begin
+ s.skind <- Instr(self#procIl il);
+ s
+ end
+ | _ -> s
+
+ method private processStmts sl =
+ let rec helper sl seen = match sl with
+ | [] -> List.rev seen
+ | [x] -> List.rev ((self#procStmt x)::seen)
+ | s1::s2::rest -> begin
+ match s1.skind, s2.skind with
+ | Instr il1, Instr il2 when s1.labels = [] && s2.labels = [] -> begin
+ s1.skind <- Instr(il1 @ il2);
+ helper (s1 :: rest) seen
+ end
+ | Instr il1, Instr il2 when il1 <> [] && il2 <> [] -> begin
+ (* get the last instr in il1 and the first in il2 *)
+ let i1 = List.hd (List.rev il1) in
+ let il1' = List.tl (List.rev il1) in
+ let i2 = List.hd il2 in
+ let il2' = List.tl il2 in
+ match i1, i2 with
+ | Call(Some(Var rvi, NoOffset), flv, el, l),
+ Set((Var vi',NoOffset),Lval(Var rvi',NoOffset),l')
+ when inTmpForm rvi.vname tmpForms && not(inTmpForm vi'.vname tmpForms)
+ && rvi'.vid = rvi.vid
+ -> begin
+
+ if !debug then ignore(E.log "Merging Stmts %a and %a\n" d_stmt s1 d_stmt s2);
+ let newi1 = Call(Some(Var vi',NoOffset),flv,el,l) in
+ let newi2 = Set((Var rvi,NoOffset),Lval(Var vi',NoOffset),l') in
+ let new1 = Instr (List.rev (newi1::il1')) in
+ let new2 = Instr (newi2::il2') in
+ s1.skind <- new1;
+ s2.skind <- new2;
+ helper rest ((self#procStmt s2)::(self#procStmt s1)::seen)
+ end
+ | Set((Var vi1, NoOffset), Lval(Var vir1, NoOffset), l1),
+ Set((Var vi2, NoOffset), Lval(Var vir2, NoOffset), l2)
+ when inTmpForm vi1.vname tmpForms &&
+ inTmpForm vir1.vname tmpForms &&
+ vir1.vid = vir2.vid &&
+ not(inTmpForm vi2.vname tmpForms)
+ -> begin
+ match seen with
+ | [] -> begin
+ s1.skind <- Instr (List.rev (i2::il1'));
+ s2.skind <- Instr (i1::il2');
+ helper rest ((self#procStmt s2)::(self#procStmt s1)::seen)
+ end
+ | s3 :: seen -> begin (* backtrack and try again *)
+ s1.skind <- Instr (List.rev (i2::il1'));
+ s2.skind <- Instr (i1::il2');
+ if !debug then ignore(E.log "backtrack: %a\n%a\n" d_stmt s3 d_stmt s1);
+ helper (s3 :: s1 :: s2 :: rest) seen
+ end
+ end
+ | _, _ -> helper (s2 :: rest) ((self#procStmt s1) :: seen)
+ end
+ | _, Instr [] when s2.labels = [] ->
+ (* dump empty statements having no labels *)
+ helper (s1::rest) seen
+ | _, _ -> begin
+ helper (s2::rest) ((self#procStmt s1)::seen)
+ end
+ end
+ in
+ helper sl []
+
+ (* Cil.constFold doesn't bother getting rid of addition of zero when
+ the result type is a pointer, so handle that here *)
+ method vexpr e =
+ let rec mkInt = function
+ Const(CChr c) -> Const(charConstToInt c)
+ | Const(CEnum (v, s, ei)) -> mkInt v
+ | CastE(TInt (ik, ta), e) -> begin
+ match mkInt e with
+ Const(CInt64(i, _, _)) ->
+ let i', _ = truncateInteger64 ik i in
+ Const(CInt64(i', ik, None))
+ | e' -> CastE(TInt(ik, ta), e')
+ end
+ | e -> e
+ in
+ match e with
+ | BinOp(bop,e1,e2,typ) -> begin
+ match bop, mkInt e1, mkInt e2 with
+ | PlusA, Const(CInt64(z,_,_)), e2 when z = Int64.zero -> ChangeTo(e2)
+ | PlusA, e1, Const(CInt64(z,_,_)) when z = Int64.zero -> ChangeTo(e1)
+ | PlusPI, e1, Const(CInt64(z,_,_)) when z = Int64.zero -> ChangeTo(e1)
+ | IndexPI, e1, Const(CInt64(z,_,_)) when z = Int64.zero -> ChangeTo(e1)
+ | MinusPI, e1, Const(CInt64(z,_,_)) when z = Int64.zero -> ChangeTo(e1)
+ | _,_,_ -> DoChildren
+ end
+ | _ -> DoChildren
+
+ method vblock b =
+ b.bstmts <- self#processStmts b.bstmts;
+ DoChildren
+
+end
+
+let preFwdSubst (fd : fundec) =
+ visitCilFunction (new symEvalPrePass fd) fd
+
+
+(* Here follows the actual forward substitution transformaction.
+ This currently uses some code in rmciltmps, but that code
+ isn't really general purpose anymore, and should move here. *)
+
+let can_elim_check c =
+ match DFI.optimizeCheck ~supErr:true c with
+ [] -> true
+ | _ -> false
+
+let checkVisit_change = ref true
+
+let checkAEVisit action (fd : fundec) = object(self)
+ inherit AE.aeVisitorClass as super
+
+ method private do_action b e =
+ match self#get_cur_eh() with
+ None -> e
+ | Some eh ->
+ let e', b' = action eh sid e fd b in
+ if b' then checkVisit_change := true;
+ e'
+
+ method private fix_check =
+ let fold_act e = constFold true (self#do_action true e) in
+ map_to_check ~cond:can_elim_check fold_act
+
+ method vexpr e =
+ ChangeTo (self#do_action false e)
+
+ method vinst i =
+ let action = super#vinst i in
+ if action <> DoChildren then
+ E.s (bug "Expected DoChildren");
+ match instrToCheck i with
+ | Some c ->
+ let c' = time "handle checks" self#fix_check c in
+ ChangeTo [checkToInstr c']
+ | None -> begin
+ (* see if it's a deputy function *)
+ if not (is_deputy_fun i) then
+ DoChildren
+ else match i with
+ | Call(lvo,lv,el,l) ->
+ let el = List.map (self#do_action true) el in
+ ChangeTo [Call(lvo,lv,el,l)]
+ | _ -> DoChildren
+ end
+
+ method vfunc fd =
+ time "available expressions" AE.computeAEs fd;
+ curFunc := fd;
+ let cleanup x =
+ curFunc := dummyFunDec;
+ x
+ in
+ ChangeDoChildrenPost (fd, cleanup)
+
+end
+
+let checkAELVVisit action (fd : fundec) = object(self)
+ inherit AELV.aeVisitorClass as super
+
+ method private do_action b e =
+ match self#get_cur_eh() with
+ None -> e
+ | Some eh ->
+ let e', b' = action eh sid e fd b in
+ if b' then checkVisit_change := true;
+ e'
+
+ method private fix_check =
+ let fold_act e = constFold true (self#do_action true e) in
+ map_to_check ~cond:can_elim_check fold_act
+
+ method vexpr e =
+ ChangeTo (self#do_action false e)
+
+ method vinst i =
+ let action = super#vinst i in
+ if action <> DoChildren then
+ E.s (bug "Expected DoChildren");
+ match instrToCheck i with
+ | Some c ->
+ let c' = time "handle checks" self#fix_check c in
+ ChangeTo [checkToInstr c']
+ | None -> begin
+ (* see if it's a deputy function *)
+ if not (is_deputy_fun i) then
+ DoChildren
+ else match i with
+ | Call(lvo,lv,el,l) ->
+ let el = List.map (self#do_action true) el in
+ ChangeTo [Call(lvo,lv,el,l)]
+ | _ -> DoChildren
+ end
+
+ method vfunc fd =
+ if !debug then ignore(E.log "Computing AELV for %s\n" fd.svar.vname);
+ time "available expressions" AELV.computeAEs fd;
+ curFunc := fd;
+ let cleanup x =
+ curFunc := dummyFunDec;
+ x
+ in
+ ChangeDoChildrenPost (fd, cleanup)
+
+end
+
+(* applies the action to the function until
+ no changes are made, or lim is reached *)
+(* action: 'a -> sid -> exp -> fundec -> bool -> exp * bool *)
+(* action -> int -> fundec -> unit *)
+let fp cls action lim fd =
+ let vis = cls action fd in
+ let i = ref 0 in
+ checkVisit_change := true;
+ while !i < lim && !checkVisit_change do
+ if !debug then ignore(E.log "fp: in while loop\n");
+ checkVisit_change := false;
+ ignore(visitCilFunction (vis :> cilVisitor) fd);
+ i := !i + 1;
+ done
+
+
+let forwardTmpSub (fd : fundec) =
+ ignore(preFwdSubst fd);
+ fp checkAELVVisit RCT.ae_lv_fwd_subst 4 fd;
+ ignore(preFwdSubst fd)
+
+(*let forwardTmpSub = fp checkAEVisit RCT.ae_fwd_subst 4*)
+
+(* Constant propagation into checks. This is probably useless. *)
+let constProp = fp checkAEVisit RCT.ae_const_prop 4
+
+
+
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2004,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(*
+ * dloopoptim.ml
+ *
+ * Move loop invariant checks out
+ * of loops.
+ *
+ * TODO: identify loop induction variables and move bounds
+ * checks on each iteration to one check before the loop.
+ *)
+
+open Cil
+open Expcompare
+open Pretty
+open Dutil
+open Dcheckdef
+open Doptimutil
+
+
+module E = Errormsg
+module IH = Inthash
+module RD = Reachingdefs
+module AE = Availexps
+module AELV = Availexpslv
+module RCT = Rmciltmps
+module UD = Usedef
+module S = Stats
+
+
+(* stm -> UD.VS.t *)
+let find_varying loop_stm =
+ let _, d = UD.computeDeepUseDefStmtKind loop_stm.skind in
+ d
+
+(* for visiting a block to determine whether it contains
+ * a write to memory or a function call *)
+class writeOrCallFinderClass br = object(self)
+ inherit nopCilVisitor
+ method vinst i =
+ if is_deputy_instr i then SkipChildren else
+ match i with
+ Set((Mem _,_),_,_) ->
+ br := true;
+ DoChildren
+ | Call(_,_,_,_) ->
+ br := true;
+ DoChildren
+ | Asm(_,_,_,_,_,_) -> (* Not precisely... *)
+ br := true;
+ DoChildren
+ | _ -> DoChildren
+end
+
+let writeOrCallFinder = new writeOrCallFinderClass
+
+(* block -> bool *)
+let block_has_write_or_call b =
+ let br = ref false in
+ let vis = new writeOrCallFinderClass br in
+ ignore(visitCilBlock vis b);
+ !br
+
+(* UD.VS.t -> fundec -> UD.VS.t *)
+let add_globs_addrs vvs fd =
+ List.fold_left (fun vvs' vi ->
+ if vi.vglob || vi.vaddrof
+ then UD.VS.add vi vvs'
+ else vvs') vvs (fd.sformals@fd.slocals)
+
+(* check -> bool *)
+let check_has_mem_read c =
+ test_check AELV.exp_has_mem_read c
+
+(* the argument b is the body of a Loop *)
+(* returns the loop termination condition along with
+ * the checks that must preceed its evaluation *)
+(* block -> (exp option * instr list) *)
+let get_loop_condition b =
+ let isListOfChecks =
+ List.fold_left (fun b i ->
+ b && (is_check_instr i))
+ true
+ in
+ (* returns the first non-empty, non-check
+ * statement of a statement list along with
+ * the list of checks that were seen *)
+ (* stm list -> stm list * instr list *)
+ let rec skipEmpty = function
+ [] -> [], []
+ | {skind = Instr []; labels = []}::rest ->
+ skipEmpty rest
+ | ({skind = Instr il; labels = []} as s)::rest ->
+ if isListOfChecks il
+ then let sl,il' = skipEmpty rest in
+ sl, il@il'
+ else let sl, _ = skipEmpty rest in
+ s::sl, []
+ | x -> x, []
+ in
+ (* stm -> exp option * instr list *)
+ let rec get_cond_from_if if_stm =
+ match if_stm.skind with
+ If(e,tb,fb,_) ->
+ let e = stripNopCasts e in
+ RCT.fold_blocks tb;
+ RCT.fold_blocks fb;
+ let tsl, tcil = skipEmpty tb.bstmts in
+ let fsl, fcil = skipEmpty fb.bstmts in
+ (match tsl, fsl with
+ {skind = Break _} :: _, [] -> Some e, tcil
+ | [], {skind = Break _} :: _ ->
+ Some(UnOp(LNot, e, intType)), fcil
+ | ({skind = If(_,_,_,_)} as s) :: _, [] ->
+ let teo, tcil' = get_cond_from_if s in
+ (match teo with
+ None -> None, []
+ | Some te ->
+ Some(BinOp(LAnd,e,stripNopCasts te,intType)), tcil@tcil')
+ | [], ({skind = If(_,_,_,_)} as s) :: _ ->
+ let feo, fcil' = get_cond_from_if s in
+ (match feo with
+ None -> None, []
+ | Some fe ->
+ Some(BinOp(LAnd,UnOp(LNot,e,intType),
+ stripNopCasts fe,intType)), fcil@fcil')
+ | {skind = Break _} :: _, ({skind = If(_,_,_,_)} as s):: _ ->
+ let feo,fcil' = get_cond_from_if s in
+ (match feo with
+ None -> None, []
+ | Some fe ->
+ Some(BinOp(LOr,e,stripNopCasts fe,intType)), fcil@fcil')
+ | ({skind = If(_,_,_,_)} as s) :: _, {skind = Break _} :: _ ->
+ let teo, tcil' = get_cond_from_if s in
+ (match teo with
+ None -> None, []
+ | Some te ->
+ Some(BinOp(LOr,UnOp(LNot,e,intType),
+ stripNopCasts te,intType)), tcil@tcil')
+ | ({skind = If(_,_,_,_)} as ts) :: _ , ({skind = If(_,_,_,_)} as fs) :: _ ->
+ let teo, tcil' = get_cond_from_if ts in
+ let feo, fcil' = get_cond_from_if fs in
+ (match teo, feo with
+ Some te, Some fe ->
+ Some(BinOp(LOr,BinOp(LAnd,e,stripNopCasts te,intType),
+ BinOp(LAnd,UnOp(LNot,e,intType),
+ stripNopCasts fe,intType),intType)),
+ tcil@fcil@tcil'@fcil'
+ | _,_ -> None, [])
+ | _, _ -> (if !debug then ignore(E.log "checkMover: branches of %a not good\n"
+ d_stmt if_stm);
+ None, []))
+ | _ -> (if !debug then ignore(E.log "checkMover: %a not an if\n" d_stmt if_stm);
+ None, [])
+ in
+ let sl, cil = skipEmpty b.bstmts in
+ match sl with
+ ({skind = If(_,_,_,_)} as s) :: _ ->
+ let eo, cil' = get_cond_from_if s in
+ eo, cil@cil'
+ | s :: _ ->
+ (if !debug then ignore(E.log "checkMover: %a is first, not an if\n"
+ d_stmt s);
+ None, [])
+ | [] ->
+ (if !debug then ignore(E.log "checkMover: no statements in loop block?\n");
+ None, [])
+
+(* UD.VS.t -> check -> bool *)
+let check_has_varying_var vvs c =
+ UD.VS.fold (fun vi b ->
+ b || test_check (AELV.exp_has_vi vi) c)
+ vvs false
+
+(* if the instruction is deputy_findnull or
+ * deputy_max, then if the arguments
+ * are loop invariant and there is no
+ * other definition of vi reaching i, then
+ * the instruction can be lifted out of the
+ * loop *)
+let can_lift_instr i vvs mw iosh =
+ let bad_args el =
+ List.fold_left (fun b e ->
+ b || (UD.VS.fold (fun vi b ->
+ b || (AELV.exp_has_vi vi e) ||
+ (mw && AELV.exp_has_mem_read e)) vvs false))
+ false el
+ in
+ let check_def vi =
+ if IH.mem iosh vi.vid then
+ let ios = IH.find iosh vi.vid in
+ if not(RD.IOS.cardinal ios = 2) then
+ (if !debug then ignore(E.log "checkMover: %d defs reach\n" (RD.IOS.cardinal ios));
+ false)
+ else match RD.IOS.elements ios with
+ [io1;io2] -> (match io1,io2 with
+ Some did, None |
+ None, Some did -> RD.isDefInstr i did
+ | Some d1, Some d2 ->
+ (if !debug then ignore(E.log "checkMover: more than one real def reaches %d %d\n" d1 d2);
+ false)
+ | _ -> false)
+ | _ -> (if !debug then ignore(E.log "checkMover: impossible\n");
+ false)
+ else (if !debug then ignore(E.log "checkMover: %s not in iosh\n" vi.vname);
+ false)
+ in
+ match i with
+ Call(Some(Var vi,NoOffset),Lval(Var vf,NoOffset),el,_) ->
+ if (vf.vname = "deputy_findnull" || vf.vname = "deputy_max")
+ then if bad_args el
+ then (if !debug then ignore(E.log "checkMover: has varying arg %a\n" d_instr i);
+ false)
+ else if check_def vi
+ then (if !debug then ignore(E.log "checkMover: can be moved %a\n" d_instr i);
+ true)
+ else (if !debug then ignore(E.log "checkMover: had bad def %a\n" d_instr i);
+ false)
+ else false
+ | _ -> false
+
+(* remove and return a list of check instructions
+ * not containing things in vvs and not having
+ * memory reads when mw is true.
+ *)
+(* UD.VS.t -> bool -> (instr * rddat) list -> instr list * instr list *)
+let filter_instr_list vvs mw ildl =
+ let gir, rir = List.fold_left
+ (fun (gi,ri) (i,(u,s,iosh)) -> match instrToCheck i with
+ None -> if can_lift_instr i vvs mw iosh
+ then (gi,i::ri)
+ else (i::gi,ri)
+ | Some c ->
+ (if check_has_varying_var vvs c
+ then (if !debug then ignore(E.log "checkMover: has varying var %a\n" d_instr i);
+ (i::gi,ri))
+ else if mw && check_has_mem_read c
+ then (if !debug then ignore(E.log "checkMover: has memory read %a\n" d_instr i);
+ (i::gi,ri))
+ else (if !debug then ignore(E.log "checkMover: can be moved %a\n" d_instr i);
+ (gi, i::ri))))
+ ([],[])
+ ildl
+ in
+ List.rev gir, List.rev rir
+
+(* remove loop invariant checks from the block,
+ * return a list of checks along with the
+ * expression that must guard them *)
+(* block -> UD.VS.t -> int -> (exp,instr list) list *)
+let rec filter_and_collect_checks b vvs sid =
+ let mw = block_has_write_or_call b in
+ List.fold_left (fun cl s ->
+ match s.skind with
+ Block b' -> cl@(filter_and_collect_checks b' vvs s.sid)
+ | If(e,tb,fb,_) ->
+ (* see if e is loop invariant *)
+ let aedato = AELV.getAEs s.sid in
+ (match aedato with None -> cl | Some aedat ->
+ let e',_ = RCT.ae_lv_simp_fwd_subst aedat e true in
+ let e' = stripNopCasts e' in
+ if (UD.VS.exists (fun vi -> AELV.exp_has_vi vi e') vvs) ||
+ (mw && AELV.exp_has_mem_read e) then cl (* can't move *)
+ else let tgcl = filter_and_collect_checks tb vvs s.sid in
+ let fgcl = filter_and_collect_checks fb vvs s.sid in
+ let tgcl' = List.map (fun (g,cl) ->
+ if DCE.canonCompareExp(*StripCasts*) g one
+ then (e',cl)
+ else if DCE.canonCompareExp(*StripCasts*) g e'
+ then (e',cl)
+ else (BinOp(LAnd,e',g,intType),cl)) tgcl in
+ let fgcl' = List.map (fun (g,cl) ->
+ if DCE.canonCompareExp(*StripCasts*) g one
+ then (UnOp(LNot,e',intType),cl)
+ else (BinOp(LAnd,UnOp(LNot,e',intType),g,intType),cl))
+ fgcl in
+ cl@tgcl'@fgcl')
+ | Instr il ->
+ (match RD.getRDs s.sid with None -> cl | Some(_,x,iosh) ->
+ let rd_dat_lst = RD.instrRDs il s.sid ((),x,iosh) false in
+ let il_dat_lst = List.combine il rd_dat_lst in
+ let gi, ri = filter_instr_list vvs mw il_dat_lst in
+ if !debug then ignore(E.log "checkMover: after filter to move %d\n"
+ (List.length ri));
+ s.skind <- Instr gi;
+ cl@[(one ,ri)])
+ | _ -> cl) [] b.bstmts
+
+(* exp -> exp * instr list -> stmt option *)
+let eil_to_if_stmt cond (e,il) =
+ match il with
+ [] -> (if !debug then ignore(E.log "checkMover: no checks to make\n");
+ None)
+ | _ ->
+ let ifblk = mkBlock [mkStmt(Instr il)] in
+ if DCE.canonCompareExp(*StripCasts*) e one ||
+ DCE.canonCompareExp(*StripCasts*) e cond
+ then (if !debug then ignore(E.log "checkMover: need check %a\n" d_block ifblk);
+ Some(mkStmt (Block ifblk)))
+ else if DCE.canonCompareExp(*StripCasts*) e zero
+ then (if !debug then ignore(E.log "checkMover: checks never made\n");
+ None)
+ else (if !debug then ignore(E.log "checkMover: need checks %a\n" d_block ifblk);
+ Some(mkStmt (If(e,ifblk,mkBlock [],locUnknown))))
+
+(* stmt option list -> stmt list *)
+let rec filter_sol sol =
+ match sol with [] -> [] |
+ so :: rest -> match so with
+ None -> filter_sol rest
+ | Some s -> s :: (filter_sol rest)
+
+(* return an If statement that does
+ * the invariant checks if the condition is true. *)
+(* instr list -> (exp, instr list) list -> exp -> stmt -> stmt option *)
+let make_pre_header cil gcl cond loop_stm =
+ let if_stmo_lst = List.map (eil_to_if_stmt cond) gcl in
+ let if_stm_lst = filter_sol if_stmo_lst in
+ match if_stm_lst with [] -> None | _ ->
+ let preheader_checks = mkStmt (Instr cil) in
+ let preheader_if = mkStmt (If(cond, mkBlock if_stm_lst,
+ mkBlock [], locUnknown)) in
+ let preheader_block = mkBlock [preheader_checks;
+ preheader_if] in
+ let preheader_stm = mkStmt (Block preheader_block) in
+ Some preheader_stm
+
+let check_moved = ref false
+class loopInvCheckMoverClass fd = object(self)
+ inherit nopCilVisitor
+
+ val mutable cur_block = ref {bstmts = []; battrs = []}
+
+ method vstmt s = match s.skind with
+ Loop(b,_,_,_) ->
+ if !debug then ignore(E.log "checkMover: looking at loop statement\n%a\n" d_stmt s);
+ let vvs = find_varying s in
+ let vvs = if block_has_write_or_call b
+ then add_globs_addrs vvs fd else vvs in
+ RCT.fold_blocks b;
+ let condo, cil = get_loop_condition b in
+ (match condo with
+ None ->
+ if !debug then ignore(E.log "checkMover: sid %d: no cond\n" s.sid);
+ DoChildren
+ | Some cond ->
+ let cond = UnOp(LNot,cond,intType) in (* Need the opposite of termination cond *)
+ if !debug then ignore(E.log "checkMover: found condition %a\n" d_exp cond);
+ let gcl = filter_and_collect_checks b vvs s.sid in
+ if !debug then ignore(E.log "checkMover: %d checks to move\n"
+ (List.length gcl));
+ match gcl with [] -> DoChildren | _ ->
+ let pho = make_pre_header cil gcl cond s in
+ match pho with None -> DoChildren | Some ph ->
+ check_moved := true;
+ if !debug then ignore(E.log "checkMover: pre-header=\n%a\n" d_stmt ph);
+ (* put the new statement in the current
+ block's statement list before the loop *)
+ let rec insert_before seen to_insert notseen =
+ match notseen with [] -> seen
+ | s'::rest -> if s'.sid = s.sid
+ then (if !debug then ignore(E.log "checkMover: inserting pre-header\n");
+ seen@[to_insert]@notseen)
+ else insert_before (seen@[s']) to_insert rest
+ in
+ (!cur_block).bstmts <- insert_before [] ph (!cur_block).bstmts;
+ if !debug then ignore(E.log "checkMover: new enclosing block=\n%a\n" d_block (!cur_block));
+ DoChildren)
+ | _ -> DoChildren
+
+ method vblock b =
+ let old_block = cur_block in
+ cur_block <- ref b;
+ let block_restore b' =
+ cur_block <- old_block;
+ b
+ in
+ ChangeDoChildrenPost(b,block_restore)
+
+ method vfunc fd =
+ Cfg.clearCFGinfo fd;
+ ignore (Cfg.cfgFun fd);
+ AELV.computeAEs fd;
+ RD.computeRDs fd;
+ DoChildren
+
+end
+
+let loopInvCheckMover fd =
+ check_moved := true;
+ while !check_moved do
+ check_moved := false;
+ ignore(visitCilFunction (new loopInvCheckMoverClass fd) fd)
+ done
+
+class checkMoverCleanupClass = object(self)
+ inherit nopCilVisitor
+
+ method private is_empty_if s =
+ match s.skind with
+ If(_,tb,fb,_) ->
+ (match tb.bstmts, fb.bstmts with
+ [],[] -> true
+ | _,_ -> false)
+ | _ -> false
+
+ method private if_to_block s =
+ if self#is_empty_if s
+ then mkStmt(Block(mkBlock []))
+ else s
+
+ method vstmt s = match s.skind with
+ If(e,tb,fb,l) ->
+ let aedato = AELV.getAEs s.sid in
+ (match aedato with None -> DoChildren
+ | Some aedat -> begin
+ let e',_ = RCT.ae_lv_simp_fwd_subst aedat e true in
+ let e'' = stripNopCasts(constFold true e') in
+ match isInteger e'' with
+ | Some 0L when not (hasALabel tb) -> (* tb is unreachable *)
+ s.skind <- Block fb;
+ DoChildren
+ | Some n when not (hasALabel fb)
+ && n <> Int64.zero -> (* fb is unreachable *)
+ s.skind <- Block tb;
+ DoChildren
+ | _ -> (* Both branches reachable *)
+ s.skind <- If(e'',tb,fb,l);
+ ChangeDoChildrenPost(s,self#if_to_block)
+ end)
+ | _ -> DoChildren
+
+ method vblock b =
+ RCT.fold_blocks b;
+ let new_stmts = List.filter (fun s ->
+ match s.skind with
+ Instr [] when s.labels = [] -> false
+ | _ -> true) b.bstmts in
+ b.bstmts <- new_stmts;
+ DoChildren
+
+ method vfunc fd =
+ Cfg.clearCFGinfo fd;
+ ignore (Cfg.cfgFun fd);
+ AELV.computeAEs fd;
+ DoChildren
+end
+
--- /dev/null
+(*
+ * Find checks on globals and formals at the beginning of functions.
+ * Also, some utilities for filtering the results.
+ *
+ *)
+
+open Cil
+open Pretty
+open Dattrs
+open Dutil
+open Dcheckdef
+open Doptimutil
+
+module F = Frontc
+module IH = Inthash
+module E = Errormsg
+module S = Stats
+module DPF = Dprecfinder
+module DFS = Dflowsens
+module DP = Dpatch
+
+(* This visitor sets br to true if it finds an lval that is not
+ * (Var vi, NoOffset) or one where the vi is not in the formal list of fd *)
+class nonFormalLvalFinderClass (fvar : varinfo) (br : bool ref) = object(self)
+ inherit nopCilVisitor
+
+ method vlval lv = match lv with
+ | (Var vi, NoOffset) -> begin
+ if vi.vname <> "__LOCATION__" then begin
+ match fvar.vtype with
+ | TFun(_, Some args, _, _) ->
+ br := not(List.exists (fun (s,_,_) -> vi.vname = s) args)
+ | _ -> ()
+ end;
+ DoChildren
+ end
+ | _ -> begin
+ br := true;
+ DoChildren;
+ end
+end
+
+(* returns true if the instruction refers only to formals of fd *)
+let instrOnlyFormals (fvar : varinfo) (i : instr) : bool =
+ let br = ref false in
+ let vis = new nonFormalLvalFinderClass fvar br in
+ match i with
+ | Call(_, _, el, _) -> begin
+ List.iter (fun e -> ignore(visitCilExpr vis e)) el;
+ not !br
+ end
+ | _ -> false (* This is impossible *)
+
+
+(* Filter down preconditions to those that are only in terms of formals *)
+let precFormalFilter (fdat : DPF.functionData) : unit =
+ DPF.precFilter instrOnlyFormals fdat
+
+
+let nonNullFilter (fvar : varinfo) (c : instr) : bool =
+ match instrToCheck c with
+ | None -> false
+ | Some c -> begin
+ match c with
+ | CNonNull _ -> true
+ | _ -> false
+ end
+
+
+(* Filter down preconditions to NonNulls *)
+let precNonNullFilter (fdat : DPF.functionData) : unit =
+ DPF.precFilter nonNullFilter fdat
+
+
+(* returns only the precondition data about the NonNullness of formals *)
+let getNonNullPreConditions (fdat : DPF.functionData) (f : file) : unit =
+ DPF.preConditionFinder fdat f;
+ precFormalFilter fdat;
+ precNonNullFilter fdat
+
+
+(* add attributes a to the parameter called name in the type of function fd *)
+let addAttrToFormalType (name : string) (a : attributes) (fvar : varinfo) : unit =
+ match fvar.vtype with
+ | TFun(ft,args,b,fattrs) -> begin
+ let rec helper args seen =
+ match args with
+ | [] -> List.rev seen
+ | (n,t,aattr) :: rst -> begin
+ if n <> name then helper rst ((n,t,aattr)::seen) else
+ let newtyp = typeAddAttributes a t in
+ (List.rev seen)@((n,newtyp,aattr)::rst)
+ end
+ in
+ match args with
+ | None -> ()
+ | Some args ->
+ fvar.vtype <- TFun(ft, Some(helper args []), b, fattrs)
+ end
+ | _ -> ()
+
+let addAttrToReturnType (a : attributes) (fvar : varinfo) : bool =
+ match fvar.vtype with
+ | TFun(rt, args, b, fattrs) -> begin
+ match unrollType rt with
+ | TPtr(_,_) -> begin
+ let newrt = typeAddAttributes a rt in
+ fvar.vtype <- TFun(newrt, args, b, fattrs);
+ true
+ end
+ | _ -> false
+ end
+ | _ -> false
+
+
+(* add NONNULL annotations to the types of formals indicated by fdat *)
+let addAnnotations (fdat : DPF.functionData) (f : file) : unit =
+ IH.iter (fun vid cl ->
+ match IH.tryfind fdat.DPF.fdFnHash vid with
+ | None -> () (* an error message? *)
+ | Some (fvar, _) -> begin
+
+ (* Annotate returns *)
+ if DFS.isReturnNonNull fvar f then begin
+ (*let (fd, _) = IH.find fdat.DPF.fdFnHash vid in*)
+ let nattr = [Attr("nonnull",[])] in
+ let b = addAttrToReturnType nattr fvar in
+ IH.replace fdat.DPF.fdFnHash vid (fvar, b)
+ end;
+
+ (* Annotate arguments *)
+ List.iter (fun c ->
+ match instrToCheck c with
+ | Some(CNonNull(Lval(Var vi,NoOffset))) -> begin
+ let nattr = [Attr("nonnull",[])] in
+ addAttrToFormalType vi.vname nattr fvar;
+ IH.replace fdat.DPF.fdFnHash vid (fvar,true)
+ end
+ | _ -> () (* impossible *)) cl
+
+ end) fdat.DPF.fdPCHash
+
+
+let addNonNullAnnotations (fdat : DPF.functionData) (f : file) : unit =
+ getNonNullPreConditions fdat f;
+ addAnnotations fdat f;
+ ()
--- /dev/null
+(*
+ *
+ * Copyright (c) 2004,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(*
+ *
+ * doptimmain.ml
+ *
+ * This is the interface of the optimizer exposed to Deputy proper.
+ *
+ *)
+
+open Cil
+open Pretty
+open Doptions
+open Dutil
+open Dcheckdef
+
+module E = Errormsg
+module AE = Availexps
+module AELV = Availexpslv
+module RCT = Rmciltmps
+module S = Stats
+
+(* optimizer modules *)
+module DFI = Dflowinsens
+module DFS = Dflowsens
+module DSA = Dfwdsubst
+module DDE = Ddupcelim
+module DLO = Dloopoptim
+module DCS = Dcheckstrengthen
+module DOU = Doptimutil
+module DCH = Dcheckhoister
+module DOA = Doctanalysis
+module DPF = Dprecfinder
+
+(* Determine some properties of the remaining checks *)
+class localFinderClass (fd : fundec) br = object(self)
+ inherit nopCilVisitor
+
+ method vvrbl vi =
+ let isFormal vi =
+ List.exists (fun vi' -> vi'.vid = vi.vid)
+ fd.sformals
+ in
+ if not vi.vglob && not (isFormal vi) then br := true;
+ DoChildren
+
+end
+
+class globFormFinderClass (fd : fundec) br = object(self)
+ inherit nopCilVisitor
+
+ method vvrbl vi =
+ if vi.vglob then br := true;
+ DoChildren
+
+end
+
+(* returns true if e only refers to globals. *)
+let expOnlyGlobalsAndFormals fd e =
+ let br = ref false in
+ let vis = new localFinderClass fd br in
+ ignore(visitCilExpr vis e);
+ not !br
+
+let expHasGlobOrForm fd e =
+ let br = ref false in
+ let vis = new globFormFinderClass fd br in
+ ignore(visitCilExpr vis e);
+ !br
+
+class checkPropsClass ogcr hgcr = object(self)
+ inherit nopCilVisitor
+
+ val mutable curFunc = None
+
+ method vinst i =
+ match instrToCheck i with
+ | None -> DoChildren
+ | Some c -> begin
+ match curFunc with
+ | Some fd -> begin
+ let f = expOnlyGlobalsAndFormals fd in
+ if (DOU.test_check ~comb:(fun a b -> a && b) f c) then
+ ogcr := !ogcr + 1;
+ if (DOU.test_check (expHasGlobOrForm fd) c) then
+ hgcr := !hgcr + 1;
+ DoChildren
+ end
+ | None -> DoChildren
+ end
+
+ method vfunc f =
+ curFunc <- (Some f);
+ DoChildren
+
+end
+
+let numGlobalChecks (f : file) =
+ let ogcount = ref 0 in
+ let hgcount = ref 0 in
+ let vis = new checkPropsClass ogcount hgcount in
+ ignore(visitCilFile vis f);
+ !ogcount, !hgcount
+
+class checkCounterClass (cr : int ref) = object(self)
+ inherit nopCilVisitor
+
+ method vinst i =
+ match instrToCheck i with
+ | None -> DoChildren
+ | Some _ -> begin
+ incr cr;
+ DoChildren
+ end
+end
+
+let countChecks (fd : fundec) : int =
+ let cr = ref 0 in
+ let vis = new checkCounterClass cr in
+ ignore(visitCilFunction vis fd);
+ !cr
+
+let recomputeCfg (fd:fundec) : unit =
+ Cfg.clearCFGinfo fd;
+ ignore (Cfg.cfgFun fd)
+
+let optLevel1 (fd:fundec) : unit =
+ if !verbose then
+ log "Doing flow-insensitive optimizations.\n";
+ recomputeCfg fd;
+ ignore (visitCilFunction (DFI.optimizeVisitor()) fd);
+ ignore (visitCilFunction DCS.checkStrengthener fd);
+ recomputeCfg fd
+
+let optLevel2 (fd:fundec) (fdat: DPF.functionData) : unit =
+ if !verbose then
+ log "Doing some flow-sensitive optimizations.\n";
+ recomputeCfg fd;
+ ignore (visitCilFunction (DFI.optimizeVisitor()) fd);
+ DFS.doFlowAnalysis fd fdat;
+ ignore (visitCilFunction (DFI.optimizeVisitor()) fd);
+ ignore (visitCilFunction DCS.checkStrengthener fd);
+ recomputeCfg fd
+
+
+let optLevel3 (fd:fundec) (fdat : DPF.functionData) : unit =
+ if !verbose then
+ log "Doing one pass of all optimizations:\n";
+ recomputeCfg fd;
+ let cf = constFoldVisitor false in
+ AE.registerIgnoreInst is_check_instr;
+ AE.registerIgnoreCall is_deputy_instr;
+ AE.registerIgnoreCall isLibcNoSideEffects;
+ AELV.registerIgnoreInst is_check_instr;
+ AELV.registerIgnoreCall is_deputy_instr;
+ AELV.registerIgnoreCall isLibcNoSideEffects;
+ DFS.registerIgnoreCall is_deputy_instr;
+ DFS.registerIgnoreCall isLibcNoSideEffects;
+ DCH.registerIgnoreCall isLibcNoSideEffects;
+ Deadcodeelim.callHasNoSideEffects := is_deputy_fun;
+
+ ignore (S.time "flow-insensitive"
+ (visitCilFunction (DFI.optimizeVisitor ~supErr:true ())) fd);
+
+ S.time "matts" (DFS.doFlowAnalysis fd) fdat;
+
+ DPF.addChecksAtCallSites fd fdat;
+ recomputeCfg fd;
+ S.time "dup-check-elim" (DDE.elim_dup_checks fd) fdat;
+
+ ignore(S.time "check-merge"
+ (visitCilFunction DCS.checkStrengthener) fd);
+
+ if !findNonNull || !findPreconditions then begin
+ recomputeCfg fd;
+ S.time "check-hoist" (DCH.hoistChecks fd) fdat
+ end;
+
+ recomputeCfg fd;
+ ignore(S.time "dce" Deadcodeelim.elim_dead_code fd);
+
+ recomputeCfg fd;
+ S.time "symbol-eval" DSA.forwardTmpSub fd;
+ ignore(S.time "constant-fold" (visitCilFunction cf) fd);
+
+ recomputeCfg fd;
+ S.time "symbol-eval" DSA.forwardTmpSub fd;
+ ignore(S.time "constant-fold" (visitCilFunction cf) fd);
+
+ (* doFlowAnalysis *must* come before the optimizeVisitor
+ after fwd subst, const prop, and const folding *)
+ recomputeCfg fd;
+ S.time "matts" (DFS.doFlowAnalysis ~tryReverse:true fd) fdat;
+
+ ignore(S.time "flow-insensitive"
+ (visitCilFunction (DFI.optimizeVisitor())) fd);
+ ignore(S.time "check-merge"
+ (visitCilFunction DCS.checkStrengthener) fd);
+
+ recomputeCfg fd;
+ S.time "dup-check-elim" (DDE.elim_dup_checks fd) fdat;
+
+ recomputeCfg fd;
+ S.time "loopcheck" DLO.loopInvCheckMover fd;
+
+ if !findNonNull || !findPreconditions then begin
+ recomputeCfg fd;
+ S.time "check-hoist" (DCH.hoistChecks fd) fdat;
+
+ recomputeCfg fd;
+ S.time "symbol-eval" DSA.forwardTmpSub fd;
+ ignore(S.time "constant-fold" (visitCilFunction cf) fd);
+ recomputeCfg fd;
+ S.time "check-hoist" (DCH.hoistChecks fd) fdat;
+
+ recomputeCfg fd;
+ S.time "symbol-eval" DSA.forwardTmpSub fd;
+ ignore(S.time "constant-fold" (visitCilFunction cf) fd);
+ recomputeCfg fd;
+ S.time "check-hoist" (DCH.hoistChecks fd) fdat;
+ end;
+ recomputeCfg fd
+
+
+
+let optLevel4 (fd: fundec) (fdat : DPF.functionData) : unit =
+ if (not DOA.real) || !findNonNull || !findPreconditions
+ then optLevel3 fd fdat else begin
+ recomputeCfg fd;
+ let cf = constFoldVisitor false in
+ AE.registerIgnoreInst is_check_instr;
+ AE.registerIgnoreCall is_deputy_instr;
+ AE.registerIgnoreCall isLibcNoSideEffects;
+ AELV.registerIgnoreInst is_check_instr;
+ AELV.registerIgnoreCall is_deputy_instr;
+ AELV.registerIgnoreCall isLibcNoSideEffects;
+ DFS.registerIgnoreCall is_deputy_instr;
+ DFS.registerIgnoreCall isLibcNoSideEffects;
+ DOA.registerIgnoreCall is_deputy_instr;
+ DOA.registerIgnoreCall isLibcNoSideEffects;
+ Deadcodeelim.callHasNoSideEffects := is_deputy_fun;
+
+
+ (*if fd.svar.vname <> "__deputy_global_initializers" then
+ ignore(E.log "PreFIChecks %d\n" (countChecks fd));*)
+ (*ignore (E.log "flow-insensitive\n");*)
+ ignore (S.time "flow-insensitive"
+ (visitCilFunction (DFI.optimizeVisitor ~supErr:true ())) fd);
+ (*if fd.svar.vname <> "__deputy_global_initializers" then
+ ignore(E.log "PostFIChecks %d\n" (countChecks fd));*)
+
+ (*ignore(E.log "matts\n");*)
+ S.time "matts" (DFS.doFlowAnalysis fd) fdat;
+
+ DPF.addChecksAtCallSites fd fdat;
+ recomputeCfg fd;
+ (*ignore (E.log "dup-check-elim\n");*)
+ S.time "dup-check-elim" (DDE.elim_dup_checks fd) fdat;
+ (*ignore (E.log "check-merge\n");*)
+ ignore(S.time "check-merge"
+ (visitCilFunction DCS.checkStrengthener) fd);
+
+ recomputeCfg fd;
+ (*ignore (E.log "dce\n");*)
+ ignore(S.time "dce" Deadcodeelim.elim_dead_code fd);
+
+ recomputeCfg fd;
+ (*ignore (E.log "symbol-eval\n");*)
+ S.time "symbol-eval" DSA.forwardTmpSub fd;
+ (*ignore (E.log "constant-fold\n");*)
+ ignore(S.time "constant-fold" (visitCilFunction cf) fd);
+
+ (*ignore (E.log "matts\n");*)
+ S.time "matts" (DFS.doFlowAnalysis ~tryReverse:true fd) fdat;
+ (*ignore (E.log "flow-insensitive\n");*)
+ ignore(S.time "flow-insensitive"
+ (visitCilFunction (DFI.optimizeVisitor())) fd);
+
+ (*ignore(E.log "check-merge\n");*)
+ ignore(S.time "check-merge"
+ (visitCilFunction DCS.checkStrengthener) fd);
+
+ recomputeCfg fd;
+ (*ignore(E.log "loopcheck\n");*)
+ S.time "loopcheck" DLO.loopInvCheckMover fd;
+
+ recomputeCfg fd;
+ (*ignore(E.log "oct-analysis\n");*)
+ S.time "oct-analysis" (DOA.doOctAnalysis fd) fdat;
+ DOA.reportStats();
+
+ (*ignore(E.log "dup-check-elim\n");*)
+ S.time "dup-check-elim" (DDE.elim_dup_checks fd) fdat
+ end;
+ recomputeCfg fd
+
+let deadCodeElim (f:file) : unit =
+ Cfg.clearFileCFG f;
+ Cfg.computeFileCFG f;
+ S.time "dce" Deadcodeelim.dce f;
+ List.iter
+ (fun g ->
+ match g with
+ | GFun (fd, _) -> begin
+ RCT.rm_unused_locals fd
+ end
+ | _ -> ())
+ f.globals;
+ Cfg.clearFileCFG f;
+ ()
+
+let optimFunction (fd: fundec) (l: location) (fdat : DPF.functionData) =
+ currentLoc := l;
+ if !optLevel = 1 then
+ Stats.time "optimizations" optLevel1 fd
+ else if !optLevel = 2 then
+ Stats.time "optimizations" (optLevel2 fd) fdat
+ else if !optLevel = 3 then
+ Stats.time "optimizations" (optLevel3 fd) fdat
+ else if !optLevel = 4 then
+ Stats.time "optimizations" (optLevel4 fd) fdat
+
+
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2004,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(*
+ * doptimutil.ml
+ *
+ * This file contains useful utility functions for the Deputy
+ * optimizer.
+ *
+ *)
+
+open Cil
+open Expcompare
+open Pretty
+open Dattrs
+open Dutil
+open Dcheckdef
+
+module E = Errormsg
+module P = Ptranal
+
+module DCE = Dcanonexp
+
+let debug = ref false
+
+let (<%) = (fun x y -> (Int64.compare x y) < 0)
+let (<=%) = (fun x y -> (Int64.compare x y) <= 0)
+let (>%) = (fun x y -> (Int64.compare x y) > 0)
+let (>=%) = (fun x y -> (Int64.compare x y) >= 0)
+let (<>%) = (fun x y -> (Int64.compare x y) <> 0)
+
+let (+%) = Int64.add
+let (-%) = Int64.sub
+let ( *% ) = Int64.mul
+let (/%) = Int64.div
+let (~-%) = Int64.neg
+
+let debugOptim = false
+
+(* let int64to32 (i: int64) : int32 = *)
+(* let i' = Int64.to_int32 i in (\* Silently drop the high 32 bits *\) *)
+(* if i = Int64.of_int32 i' then i' *)
+(* else E.s (unimp "A constant that doesn't fit in 32 bits.") *)
+
+(* What is the largest number that can be stored in the given integral type,
+ assuming it is treated as unsigned? *)
+let maxUnsignedInt (t:typ) : int64 =
+ (Int64.shift_left 1L (bitsSizeOf t)) -% 1L
+
+let rec isIntOrPtrType (t:typ) : bool =
+ match t with
+ TInt _ | TPtr _ -> true
+ | TNamed (tt,_) -> isIntOrPtrType tt.ttype
+ | _ -> false
+
+(* Returns the size of a pointer's base type in bytes, if known *)
+let sizeOfBaseType ptrt: int option =
+ match unrollType ptrt with
+ | TPtr (bt, _) -> begin
+ match isInteger (constFold true (SizeOf bt)) with
+ | Some n -> Some (to_int n)
+ | None -> None
+ end
+ | _ -> (* maybe the expression is NULL *)
+ None
+
+(* Do we need an alignment check for p + x? Well, that depends on the size of
+ * *p. If the size is a power of two, p + x will be aligned even if it
+ * overflows, so we can skip the check. *)
+let needsAlignCheck ptrt: bool =
+ match sizeOfBaseType ptrt with (* Look for common multiples of 2 *)
+ Some (1|2|4|8|16|32|64|128|256|512|1024|2048|4096) -> false
+ | _ -> true
+
+let false_cond (c:check) = false
+
+(* map f to all the expressions in a check
+ * only if cnd c is false *)
+(* (check -> bool) -> (exp -> exp) -> check -> check *)
+let map_to_check ?cond:(cnd=false_cond) f c =
+ match c with
+ CNonNull e ->
+ let e' = f e in
+ CNonNull e'
+ | CEq(e1,e2,why,docs) ->
+ let e1' = f e1 in
+ if cnd (CEq(e1',e2,why,docs)) then CEq(e1',e2,why,docs) else
+ let e2' = f e2 in
+ if cnd (CEq(e1,e2',why,docs)) then CEq(e1,e2',why,docs) else
+ CEq(e1',e2',why,docs)
+ | CMult(e1,e2) ->
+ let e1' = f e1 in
+ let e2' = f e2 in
+ CMult(e1',e2')
+ | CPtrArith(e1,e2,e3,e4,sz) ->
+ let e1' = f e1 in
+ if isZero e1' then CPtrArith(e1',e2,e3,e4,sz) else
+ let e2' = f e2 in
+ if cnd (CPtrArith(e1',e2',e3,e4,sz)) then CPtrArith(e1',e2',e3,e4,sz) else
+ let e3' = f e3 in
+ if cnd (CPtrArith(e1',e2,e3',e4,sz)) then CPtrArith(e1',e2,e3',e4,sz) else
+ let e4' = f e4 in
+ if cnd (CPtrArith(e1',e2,e3',e4',sz)) then CPtrArith(e1',e2,e3',e4',sz) else
+ CPtrArith(e1',e2',e3',e4',sz)
+ | CPtrArithAccess(e1,e2,e3,e4,sz) ->
+ let e1' = f e1 in
+ if isZero e1' then CPtrArithAccess(e1',e2,e3,e4,sz) else
+ let e2' = f e2 in
+ if cnd (CPtrArithAccess(e1',e2',e3,e4,sz)) then CPtrArithAccess(e1',e2',e3,e4,sz) else
+ let e3' = f e3 in
+ if cnd (CPtrArithAccess(e1',e2,e3',e4,sz)) then CPtrArithAccess(e1',e2,e3',e4,sz) else
+ let e4' = f e4 in
+ if cnd (CPtrArithAccess(e1',e2,e3',e4',sz)) then CPtrArithAccess(e1',e2,e3',e4',sz) else
+ CPtrArithAccess(e1',e2',e3',e4',sz)
+ | CPtrArithNT(e1,e2,e3,e4,sz) ->
+ let e1' = f e1 in
+ if isZero e1' then CPtrArithNT(e1',e2,e3,e4,sz) else
+ let e2' = f e2 in
+ if cnd (CPtrArithNT(e1',e2',e3,e4,sz)) then CPtrArithNT(e1',e2',e3,e4,sz) else
+ let e3' = f e3 in
+ if cnd (CPtrArithNT(e1',e2,e3',e4,sz)) then CPtrArithNT(e1',e2,e3',e4,sz) else
+ let e4' = f e4 in
+ if cnd (CPtrArithNT(e1',e2,e3',e4',sz)) then CPtrArithNT(e1',e2,e3',e4',sz) else
+ CPtrArithNT(e1',e2',e3',e4',sz)
+ | CLeqInt(e1,e2,why) ->
+ let e1' = f e1 in
+ let e2' = f e2 in
+ CLeqInt(e1',e2',why)
+ | CLeq(e1,e2,why) ->
+ let e1' = f e1 in
+ if cnd (CLeq(e1',e2,why)) then CLeq(e1',e2,why) else
+ let e2' = f e2 in
+ if cnd (CLeq(e1,e2,why)) then CLeq(e1,e2',why) else
+ CLeq(e1',e2',why)
+ | CLeqNT(e1,e2,sz,why) ->
+ let e1' = f e1 in
+ if cnd (CLeqNT(e1',e2,sz,why)) then CLeqNT(e1',e2,sz,why) else
+ let e2' = f e2 in
+ if cnd (CLeqNT(e1,e2',sz,why)) then CLeqNT(e1,e2',sz,why) else
+ CLeqNT(e1',e2',sz,why)
+ | CNullOrLeq(e1,e2,e3,why) ->
+ let e1' = f e1 in
+ if isZero e1' then CNullOrLeq(e1',e2,e3,why) else
+ let e2' = f e2 in
+ if cnd (CNullOrLeq(e1',e2',e3,why)) then CNullOrLeq(e1',e2',e3,why) else
+ let e3' = f e3 in
+ if cnd (CNullOrLeq(e1',e2,e3',why)) then CNullOrLeq(e1',e2,e3',why) else
+ CNullOrLeq(e1',e2',e3',why)
+ | CNullOrLeqNT(e1,e2,e3,sz,why) ->
+ let e1' = f e1 in
+ if isZero e1' then CNullOrLeqNT(e1',e2,e3,sz,why) else
+ let e2' = f e2 in
+ if cnd (CNullOrLeqNT(e1',e2',e3,sz,why)) then CNullOrLeqNT(e1',e2',e3,sz,why) else
+ let e3' = f e3 in
+ if cnd (CNullOrLeqNT(e1',e2,e3',sz,why)) then CNullOrLeqNT(e1',e2,e3',sz,why) else
+ CNullOrLeqNT(e1',e2',e3',sz,why)
+ | CWriteNT(e1,e2,e3,sz) ->
+ let e1' = f e1 in
+ let e2' = f e2 in
+ let e3' = f e3 in
+ CWriteNT(e1',e2',e3',sz)
+ | CSelected e ->
+ let e' = f e in
+ CSelected e'
+ | CNotSelected e ->
+ let e' = f e in
+ CNotSelected e'
+ | CNullUnionOrSelected (lv,e) ->
+ let e' = f e in
+ CNullUnionOrSelected(lv,e')
+
+
+(* Apply f to all expressions in a check
+ * and return the combination of the results
+ * specified by comb the default for which is
+ * ||.
+ *)
+(* (bool -> bool -> bool) -> (exp -> bool) -> check -> bool *)
+let test_check ?comb:(cmb=(fun a b -> a || b)) f c =
+ match c with
+ CNonNull e
+ | CNotSelected e
+ | CSelected e ->
+ f e
+ | CNullUnionOrSelected (lv,e) ->
+ cmb (f (Lval lv)) (f e)
+ | CEq(e1,e2,_,_)
+ | CMult(e1,e2)
+ | CLeq(e1,e2,_)
+ | CLeqInt(e1,e2,_)
+ | CLeqNT(e1,e2,_,_) ->
+ let b1 = f e1 in
+ let b2 = f e2 in
+ cmb b1 b2
+ | CNullOrLeq(e1,e2,e3,why) ->
+ let b1 = f e1 in
+ let b2 = f e2 in
+ let b3 = f e3 in
+ cmb b1 (cmb b2 b3)
+ | CNullOrLeqNT(e1,e2,e3,sz,_)
+ | CWriteNT(e1,e2,e3,sz) ->
+ let b1 = f e1 in
+ let b2 = f e2 in
+ let b3 = f e3 in
+ cmb (cmb b1 b2) b3
+ | CPtrArith(e1,e2,e3,e4,sz)
+ | CPtrArithAccess(e1,e2,e3,e4,sz)
+ | CPtrArithNT(e1,e2,e3,e4,sz) ->
+ let b1 = f e1 in
+ let b2 = f e2 in
+ let b3 = f e3 in
+ let b4 = f e4 in
+ cmb (cmb b1 b2) (cmb b3 b4)
+
+let compareExpLists el1 el2 =
+ if List.length el1 <> List.length el2
+ then false
+ else List.fold_left (fun b (e1,e2) ->
+ b && DCE.canonCompareExp(*StripCasts*) e1 e2)
+ true (List.combine el1 el2)
+
+let deputyCallsEqual i1 i2 =
+ (*ignore(E.log "comparing %a and %a\n" d_instr i1 d_instr i2);*)
+ match instrToCheck i1, instrToCheck i2 with
+ Some c1, Some c2 -> checks_equal c1 c2
+ | Some _, None -> false
+ | None, Some _ -> false
+ | None, None ->
+ if not(is_deputy_instr i1) ||
+ not(is_deputy_instr i2)
+ then false
+ else match i1, i2 with
+ Call(_,fn1,el1,_), Call(_,fn2,el2,_) ->
+ if not(compareExp fn1 fn2)
+ then false
+ else compareExpLists el1 el2
+ | _ -> false
+
+
+(* Is the block reachable through a goto? *)
+let hasALabel (b:block) : bool =
+ let hasLabel = ref false in
+ let hasALabelVisitor = object (self)
+ inherit nopCilVisitor
+ method vstmt s =
+ if s.labels <> [] then begin
+ hasLabel := true;
+ end;
+ DoChildren
+ end in
+ ignore (visitCilBlock hasALabelVisitor b);
+ !hasLabel
+
+(* returns the largest prefix of l such that each
+ * element of the prefix satisfies p *)
+let prefix p l =
+ let rec helper p l seen =
+ match l with
+ | [] -> (List.rev seen, [])
+ | x :: rst -> begin
+ if p x
+ then helper p rst (x::seen)
+ else (List.rev seen, x :: rst)
+ end
+ in
+ helper p l []
+
--- /dev/null
+(*
+ * Find checks on globals and formals at the beginning of functions.
+ * Also, some utilities for filtering the results.
+ *
+ *)
+
+open Cil
+open Pretty
+open Dattrs
+open Dutil
+open Dcheckdef
+open Doptimutil
+
+module IH = Inthash
+module E = Errormsg
+module S = Stats
+module F = Frontc
+module DP = Dpatch
+
+let debug = ref false
+
+let patch_fname = "preconditions.patch.h"
+let modp_fname = "modifies.patch.h"
+
+type functionData =
+ {
+ (* Hash from function vids to list of preconditions *)
+ fdPCHash : instr list IH.t;
+
+ (* Hash from function vids to fundecs. The bool is true
+ * if the function has been modified *)
+ fdFnHash : (varinfo * bool) IH.t;
+
+ (* Hash from the function vids to lists of modified globals and
+ parameters *)
+ fdModHash : (varinfo list * int list) IH.t
+ }
+
+let mkFDat () =
+ {
+ fdPCHash = IH.create 100;
+ fdFnHash = IH.create 100;
+ fdModHash = IH.create 100;
+ }
+
+(* Visit each function.
+ * Find checks before any real instructions.
+ * Add checks to entry in fnPCHash for the function
+ *)
+class preConditionFinderClass (fdat : functionData) = object(self)
+ inherit nopCilVisitor
+
+ (* return the checks that are first in the block *)
+ method private findDomChecks (blk : block) fd =
+ let rec helper (sl : stmt list) (cl : instr list) =
+ match sl with
+ | [] -> cl
+ | s :: rst -> begin
+ match s.skind with
+ | Instr il -> begin
+ (*if !debug then
+ ignore(E.log "precFinder: LOOKING AT %a in %s\n"
+ d_stmt (mkStmt (Instr il)) fd.svar.vname);*)
+ if List.exists (fun i -> not(is_check_instr i)) il
+ then begin
+ let newcs = fst((prefix is_check_instr il)) in
+ if !debug && newcs <> [] then
+ ignore(E.log "precFinder: MIXED %a in %s\n"
+ d_stmt (mkStmt (Instr newcs)) fd.svar.vname);
+ newcs@cl
+ end
+ else begin
+ if !debug then
+ ignore(E.log "precFinder: ADDING %a to %s\n"
+ d_stmt (mkStmt (Instr il)) fd.svar.vname);
+ helper rst (il @ cl)
+ end
+ end
+ | _ -> cl
+ end
+ in
+ helper blk.bstmts []
+
+ method vfunc (fd: fundec) =
+ let precs = self#findDomChecks fd.sbody fd in
+ IH.replace fdat.fdPCHash fd.svar.vid precs;
+ IH.replace fdat.fdFnHash fd.svar.vid (fd.svar, false);
+ SkipChildren
+
+end
+
+
+(* return a hash from function var id to a list of
+ * preconditions for the function *)
+let preConditionFinder (fdat : functionData) (f : file) : unit =
+ let vis = new preConditionFinderClass fdat in
+ visitCilFile vis f
+
+(* filter returns true if a precondition should be kept *)
+let precFilter (filter : varinfo -> instr -> bool)
+ (fdat : functionData)
+ : unit
+ =
+ IH.iter (fun vid cl ->
+ match IH.tryfind fdat.fdFnHash vid with
+ | None -> () (* an error message perhaps? *)
+ | Some (fvar, _) -> begin
+ let newcl = List.filter (filter fvar) cl in
+ IH.replace fdat.fdPCHash vid newcl
+ end) fdat.fdPCHash
+
+(* get the place of arg in fnargs *)
+let argToNumber (arg: varinfo) (fnvi: varinfo) : int option =
+ let rec helper (count : int)
+ (args : (string * typ * attributes) list) :
+ int option
+ =
+ match args with
+ | [] -> None
+ | (n,_,_) :: rst ->
+ if arg.vname = n then (Some count) else
+ helper (count + 1) rst
+ in
+ match fnvi.vtype with
+ | TFun(_,Some args,_,_) -> helper 0 args
+ | _ -> None
+
+
+(* Convert an expression into an attribute, if possible. Otherwise raise
+ * NotAnAttrParam *)
+exception NotAnAttrParam of exp
+let rec expToAttrParam (fnvi: varinfo) (e: exp) : attrparam =
+ match e with
+ | Const(CInt64(i,k,_)) ->
+ let i', trunc = truncateInteger64 k i in
+ if trunc then
+ raise (NotAnAttrParam e);
+ let i2 = Int64.to_int i' in
+ if i' <> Int64.of_int i2 then
+ raise (NotAnAttrParam e);
+ AInt i2
+ | Lval lv -> lvalToAttrParam fnvi lv
+ | StartOf lv -> lvalToAttrParam fnvi lv
+ | AddrOf lv -> AAddrOf(lvalToAttrParam fnvi lv)
+ | SizeOf t -> ASizeOf t
+ | SizeOfE e' -> ASizeOfE (expToAttrParam fnvi e')
+ | UnOp(uo, e', _) -> AUnOp (uo, expToAttrParam fnvi e')
+ | BinOp(bo, e1',e2', _) -> ABinOp (bo, expToAttrParam fnvi e1',
+ expToAttrParam fnvi e2')
+ | CastE(t, e) when deputyCompareTypes t (typeOf e) ->
+ expToAttrParam fnvi e
+ | _ -> begin
+ if !debug then ignore(E.log "expToAttrParam: not a param: %a\n" d_exp e);
+ raise (NotAnAttrParam e)
+ end
+
+(* Convernt an lvalue to an attribute parameter *)
+and lvalToAttrParam (fnvi : varinfo) (lv : lval) : attrparam =
+ match lv with
+ | (Var vi, off) -> begin
+ match argToNumber vi fnvi with
+ | None ->
+ offToAttrParam fnvi (ACons(vi.vname, [])) off
+ | Some i ->
+ let vname = "$"^(string_of_int i) in
+ offToAttrParam fnvi (ACons(vname,[])) off
+ end
+ | (Mem e, off) -> begin
+ let eattr = expToAttrParam fnvi e in
+ offToAttrParam fnvi (AStar eattr) off
+ end
+
+(* convert an attrparam with an offset into an attrparam *)
+and offToAttrParam (fnvi: varinfo)
+ (ap: attrparam)
+ (off: offset)
+ : attrparam
+ =
+ match off with
+ | NoOffset -> ap
+ | Field(fi, off) ->
+ offToAttrParam fnvi (ADot(ap,fi.fname)) off
+ | Index(e, off) ->
+ let eap = expToAttrParam fnvi e in
+ offToAttrParam fnvi (AIndex(ap,eap)) off
+
+
+(* convert an attribute parameter into an expresssion *)
+
+exception NotAnExp of attrparam
+let rec attrParamToExp ?(fnargs: varinfo list = [])
+ (globmap: (string,varinfo) Hashtbl.t)
+ (ap: attrparam)
+ : exp
+ =
+ let attrParamStringToLval (s: string) : exp =
+ if String.sub s 0 1 = "$" then begin
+ try
+ let nstr = String.sub s 1 ((String.length s) - 1) in
+ let n = int_of_string nstr in
+ let vi = List.nth fnargs n in
+ if isArrayType vi.vtype then
+ StartOf(Var vi, NoOffset)
+ else
+ Lval(Var vi, NoOffset)
+ with
+ | Failure "nth" -> begin
+ ignore(E.log "Failure \"nth\" in attrParamStringToLval: %a\n"
+ d_attrparam ap);
+ raise (NotAnExp ap)
+ end
+ (*| Failure "int_of_string" ->
+ raise (NotAnExp ap)
+ | Invalid_argument ->
+ raise (NotAnExp ap) *)
+ end else begin
+ try
+ let vi = Hashtbl.find globmap s in
+ if isArrayType vi.vtype then
+ StartOf(Var vi, NoOffset)
+ else
+ Lval(Var vi, NoOffset)
+ with Not_found -> begin
+ ignore(E.log "Not_found in attrParamStringToLval: %a\n"
+ d_attrparam ap);
+ raise (NotAnExp ap)
+ end
+ end
+ in
+ let fieldInfoFromName (t: typ) (fn: string) : fieldinfo =
+ match unrollType t with
+ | TComp(ci, _) -> begin
+ try List.find (fun fi -> fi.fname = fn) ci.cfields
+ with Not_found -> raise (NotAnExp ap)
+ end
+ | _ -> raise (NotAnExp ap)
+ in
+ let attrParamToExp = attrParamToExp ~fnargs:fnargs globmap in
+ match ap with
+ | AInt i -> integer i
+ | AStr s -> Const(CStr s)
+ | ACons(s, []) -> attrParamStringToLval s
+ | ASizeOf typ -> SizeOf typ
+ | ASizeOfE ap -> SizeOfE (attrParamToExp ap)
+ | AAlignOf typ -> AlignOf typ
+ | AAlignOfE ap -> AlignOfE (attrParamToExp ap)
+ | AUnOp(op, ap) ->
+ let e = attrParamToExp ap in
+ UnOp(op, e, typeOf e)
+ | ABinOp(op, ap1, ap2) -> begin
+ let e1 = attrParamToExp ap1 in
+ let e2 = attrParamToExp ap2 in
+ (* Need to make sure that op is correct, here *)
+ match op, unrollType (typeOf e1) with
+ | PlusA, (TPtr _ | TArray _) -> BinOp(PlusPI, e1, e2, typeOf e1)
+ | _, _ -> BinOp(op, e1, e2, typeOf e1)
+ end
+ | ADot(lap, fn) -> begin
+ let e = attrParamToExp lap in
+ let fi = fieldInfoFromName (typeOf e) fn in
+ match e with
+ | Lval(lh, off) ->
+ let newoff = Field(fi,NoOffset) in
+ if isArrayType fi.ftype then
+ StartOf(lh, addOffset newoff off)
+ else
+ Lval(lh, addOffset newoff off)
+ | _ -> raise (NotAnExp ap)
+ end
+ | AStar ap ->
+ let e = attrParamToExp ap in
+ Lval(Mem e, NoOffset)
+ | AAddrOf aap -> begin
+ let e = attrParamToExp aap in
+ match e with
+ | Lval lv -> AddrOf lv
+ | _ -> raise (NotAnExp ap)
+ end
+ | AIndex(bap,iap) -> begin
+ let be = attrParamToExp bap in
+ let ie = attrParamToExp iap in
+ match be with
+ | Lval(lh,off) ->
+ let newoff = Index(ie,NoOffset) in
+ Lval(lh, addOffset newoff off)
+ | StartOf(lh, off) ->
+ let newoff = Index(ie, NoOffset) in
+ Lval(lh, addOffset newoff off)
+ | _ -> raise (NotAnExp ap)
+ end
+ | _ -> raise (NotAnExp ap)
+
+class globalMapMakerClass (globmap : (string,varinfo) Hashtbl.t) = object(self)
+ inherit nopCilVisitor
+
+ method vvrbl vi =
+ if vi.vglob then begin
+ Hashtbl.replace globmap vi.vname vi
+ end;
+ DoChildren
+
+ method vglob = function
+ | GVar(vi,_,_)
+ | GVarDecl(vi,_) -> begin
+ Hashtbl.replace globmap vi.vname vi;
+ DoChildren
+ end
+ | _ -> DoChildren
+
+end
+
+
+
+(* Convert a whold deputy check into an attribute parameter *)
+let checkToAttrParam (fnvi: varinfo)
+ (i : instr)
+ : attrparam option
+ =
+ let mkACons ?(sz : int option = None)
+ (name : string)
+ (el : exp list)
+ : attrparam
+ =
+ let expToAttrParam = expToAttrParam fnvi in
+ let ael = List.map expToAttrParam el in
+ let asz = match sz with Some sz -> [AInt sz] | None -> [] in
+ ACons(name, ael@asz)
+ in
+ try
+ match instrToCheck i with
+ | None -> None
+ | Some c -> begin
+ match c with
+ | CNonNull e -> Some(mkACons "_CNonNull" [e])
+ | CEq(e1,e2,_,_) -> Some(mkACons "_CEq" [e1;e2])
+ | CPtrArith(e1,e2,e3,e4,sz) ->
+ Some(mkACons ~sz:(Some sz) "_CPtrArith" [e1;e2;e3;e4])
+ | CPtrArithNT(e1,e2,e3,e4,sz) ->
+ Some(mkACons ~sz:(Some sz) "_CPtrArithNT" [e1;e2;e3;e4])
+ | CPtrArithAccess(e1,e2,e3,e4,sz) ->
+ Some(mkACons ~sz:(Some sz) "_CPtrArithAccess" [e1;e2;e3;e4])
+ | CLeqInt(e1,e2,_) -> Some(mkACons "_CLeqInt" [e1;e2])
+ | CLeq(e1,e2,_) -> Some(mkACons "_CLeq" [e1;e2])
+ | CLeqNT(e1,e2,sz,_) -> Some(mkACons ~sz:(Some sz) "_CLeqNT" [e1;e2])
+ | CNullOrLeq(e1,e2,e3,_) -> Some(mkACons "_CNullOrLeq" [e1;e2;e3])
+ | CNullOrLeqNT(e1,e2,e3,sz,_) ->
+ Some(mkACons ~sz:(Some sz) "_CNullOrLeqNT" [e1;e2;e3])
+ | CWriteNT(e1,e2,e3,sz) ->
+ Some(mkACons ~sz:(Some sz) "_CWriteNT" [e1;e2;e3])
+ | CNullUnionOrSelected(lv,e) ->
+ Some(mkACons "_CNullUnionOrSelected" [(Lval lv);e])
+ | CSelected e -> Some(mkACons "_CSelected" [e])
+ | CNotSelected e -> Some(mkACons "_CNotSelected" [e])
+ | _ -> None
+ end
+ with NotAnAttrParam e -> begin
+ if !debug then ignore(E.log "checkToAttrParam: %a\n" d_exp e);
+ None
+ end
+
+type ctxt =
+ {
+ mutable cGlobMap : (string, varinfo) Hashtbl.t;
+ mutable cInited : bool;
+ mutable cFile : file
+ }
+
+let mkGlobalContext (f : file) : ctxt =
+ let cgm = Hashtbl.create 100 in
+ ignore(visitCilFile (new globalMapMakerClass cgm) f);
+ {
+ cGlobMap = cgm;
+ cInited = true;
+ cFile = f
+ }
+
+(* Convert a Precondition attribute into a list of check instructions *)
+let attributeToCheckInstrs ?(fnargs : varinfo list = [])
+ (c : ctxt)
+ (a : attribute)
+ : instr list
+ =
+ let attrParamToCheck (ap : attrparam) : instr list =
+ let attrParamToExp = attrParamToExp ~fnargs:fnargs c.cGlobMap in
+ match ap with
+ | ACons("_CNonNull", [ap]) ->
+ let e = attrParamToExp ap in
+ [checkToInstr(CNonNull(e))]
+ | ACons("_CEq", [ap1;ap2]) ->
+ let e1 = attrParamToExp ap1 in
+ let e2 = attrParamToExp ap2 in
+ [checkToInstr(CEq(e1,e2,"precondition",[]))]
+ | ACons("_CPtrArith", [ap1;ap2;ap3;ap4;ap5]) -> begin
+ let e1 = attrParamToExp ap1 in
+ let e2 = attrParamToExp ap2 in
+ let e3 = attrParamToExp ap3 in
+ let e4 = attrParamToExp ap4 in
+ let e5 = attrParamToExp ap5 in
+ match e5 with
+ | Const(CInt64(i64,_,_)) ->
+ let sz = Int64.to_int i64 in
+ [checkToInstr(CPtrArith(e1,e2,e3,e4,sz))]
+ | _ -> []
+ end
+ | ACons("_CPtrArithNT", [ap1;ap2;ap3;ap4;ap5]) -> begin
+ let e1 = attrParamToExp ap1 in
+ let e2 = attrParamToExp ap2 in
+ let e3 = attrParamToExp ap3 in
+ let e4 = attrParamToExp ap4 in
+ let e5 = attrParamToExp ap5 in
+ match e5 with
+ | Const(CInt64(i64,_,_)) ->
+ let sz = Int64.to_int i64 in
+ [checkToInstr(CPtrArithNT(e1,e2,e3,e4,sz))]
+ | _ -> []
+ end
+ | ACons("_CPtrArithAccess", [ap1;ap2;ap3;ap4;ap5]) -> begin
+ let e1 = attrParamToExp ap1 in
+ let e2 = attrParamToExp ap2 in
+ let e3 = attrParamToExp ap3 in
+ let e4 = attrParamToExp ap4 in
+ let e5 = attrParamToExp ap5 in
+ match e5 with
+ | Const(CInt64(i64,_,_)) ->
+ let sz = Int64.to_int i64 in
+ [checkToInstr(CPtrArithAccess(e1,e2,e3,e4,sz))]
+ | _ -> []
+ end
+ | ACons("_CLeqInt", [ap1;ap2]) ->
+ let e1 = attrParamToExp ap1 in
+ let e2 = attrParamToExp ap2 in
+ [checkToInstr(CLeqInt(e1,e2,"precondition"))]
+ | ACons("_CLeq", [ap1; ap2]) ->
+ let e1 = attrParamToExp ap1 in
+ let e2 = attrParamToExp ap2 in
+ [checkToInstr(CLeq(e1,e2,"precondition"))]
+ | ACons("_CLeqNT", [ap1;ap2;ap3]) -> begin
+ let e1 = attrParamToExp ap1 in
+ let e2 = attrParamToExp ap2 in
+ let e3 = attrParamToExp ap3 in
+ match e3 with
+ | Const(CInt64(i64,_,_)) ->
+ let sz = Int64.to_int i64 in
+ [checkToInstr(CLeqNT(e1,e2,sz,"precondition"))]
+ | _ -> []
+ end
+ | ACons("_CNullOrLeq", [ap1;ap2;ap3]) ->
+ let e1 = attrParamToExp ap1 in
+ let e2 = attrParamToExp ap2 in
+ let e3 = attrParamToExp ap3 in
+ [checkToInstr(CNullOrLeq(e1,e2,e3,"precondition"))]
+ | ACons("_CNullOrLeqNT", [ap1;ap2;ap3;ap4]) -> begin
+ let e1 = attrParamToExp ap1 in
+ let e2 = attrParamToExp ap2 in
+ let e3 = attrParamToExp ap3 in
+ let e4 = attrParamToExp ap4 in
+ match e4 with
+ | Const(CInt64(i64,_,_)) ->
+ let sz = Int64.to_int i64 in
+ [checkToInstr(CNullOrLeqNT(e1,e2,e3,sz,"precondition"))]
+ | _ -> []
+ end
+ | ACons("_CWriteNT", [ap1;ap2;ap3;ap4]) -> begin
+ let e1 = attrParamToExp ap1 in
+ let e2 = attrParamToExp ap2 in
+ let e3 = attrParamToExp ap3 in
+ let e4 = attrParamToExp ap4 in
+ match e4 with
+ | Const(CInt64(i64,_,_)) ->
+ let sz = Int64.to_int i64 in
+ [checkToInstr(CWriteNT(e1,e2,e3,sz))]
+ | _ -> []
+ end
+ | ACons("_CNullUnionOrSelected", [ap1; ap2]) -> begin
+ let e1 = attrParamToExp ap1 in
+ let e2 = attrParamToExp ap2 in
+ match e1 with
+ | Lval lv ->
+ [checkToInstr(CNullUnionOrSelected(lv,e2))]
+ | _ -> []
+ end
+ | ACons("_CSelected", [ap]) ->
+ let e1 = attrParamToExp ap in
+ [checkToInstr(CSelected(e1))]
+ | ACons("_CNotSelected", [ap]) ->
+ let e1 = attrParamToExp ap in
+ [checkToInstr(CNotSelected(e1))]
+ | _ -> []
+ in
+ match a with
+ | Attr("Preconditions",apl) -> begin
+ try
+ if not c.cInited then
+ ignore(visitCilFile (new globalMapMakerClass c.cGlobMap) c.cFile);
+ if !debug then
+ ignore(E.log "From attr: %a\n" d_attr a);
+ let cl = List.concat(List.map attrParamToCheck apl) in
+ if !debug then
+ ignore(E.log "Extracted: %a\n" d_stmt (mkStmt (Instr cl)));
+ cl
+ with NotAnExp ap -> begin
+ ignore(E.log "Warning: NotAnExp: %a\n" d_attrparam ap);
+ []
+ end
+ end
+ | Attr(s, _) -> begin
+ if !debug then
+ ignore(E.log "Found attr = %s\n" s);
+ []
+ end
+
+
+class precsFromAnnotsClass (c : ctxt) (fdat : functionData) = object(self)
+ inherit nopCilVisitor
+
+ method vfunc (fd : fundec) =
+ try
+ if !debug then
+ ignore(E.log "Preconditions for: %s : %a\n"
+ fd.svar.vname d_type fd.svar.vtype);
+ let attrToChecks = attributeToCheckInstrs ~fnargs:fd.sformals c in
+ let attrs = typeAttrs fd.svar.vtype in
+ let cl = List.concat(List.map attrToChecks attrs) in
+ if cl <> [] then begin
+ IH.replace fdat.fdPCHash fd.svar.vid cl;
+ match IH.tryfind fdat.fdFnHash fd.svar.vid with
+ | None -> IH.add fdat.fdFnHash fd.svar.vid (fd.svar, true)
+ | Some _ -> ()
+ end;
+ SkipChildren
+ with Not_found -> SkipChildren
+end
+
+let extractPrecsFromAnnots (fdat : functionData) (f : file) : unit =
+ let c = mkGlobalContext f in
+ ignore(visitCilFile (new precsFromAnnotsClass c fdat) f)
+
+let rec fixIndexLval (lv : lval) : lval =
+ let lvp, off = removeOffsetLval lv in
+ match off with
+ | Index(i, NoOffset) -> begin
+ let lvp = fixIndexLval lvp in
+ let p = StartOf lvp in
+ (Mem (BinOp (PlusPI, p, i, typeOf p)), NoOffset)
+ end
+ | _ -> lv
+
+class formalSubsterClass stalal = object(self)
+ inherit nopCilVisitor
+
+ method vexpr (e : exp) =
+ match e with
+ | AddrOf(Var vi, off)
+ | StartOf(Var vi, off)
+ | Lval(Var vi, off) -> begin
+ try
+ let ((_,t,_),ae) = List.find (fun ((s,_,_),_) -> s = vi.vname)
+ stalal
+ in
+ match ae with
+ | AddrOf(lh, aoff) ->
+ let lv = fixIndexLval (lh, addOffset off aoff) in
+ let newe = mkCast (AddrOf lv) t in
+ ChangeTo(newe)
+ | StartOf(lh, aoff) ->
+ let lv = fixIndexLval (lh, addOffset off aoff) in
+ let newe = mkCast (StartOf lv) t in
+ ChangeTo(newe)
+ | Lval(lh, aoff) ->
+ let lv = fixIndexLval (lh, addOffset off aoff) in
+ let newe = mkCast (Lval lv) t in
+ ChangeTo(newe)
+ | _ -> begin
+ match off with
+ | NoOffset -> ChangeTo (mkCast ae t)
+ | _ -> begin
+ ignore(E.log "%a not a good argument\n" d_exp ae);
+ DoChildren
+ end
+ end
+ with Not_found -> begin
+ if !debug then
+ ignore(E.log "%s not a formal\n" vi.vname);
+ DoChildren
+ end
+ end
+ | _ -> begin
+ DoChildren
+ end
+
+end
+
+(* Replace the formals of t mentioned in ci with the corresponding expr from
+ al *)
+let substForFormals (t : typ) (al : exp list) (ci : instr) : instr list =
+ match t with
+ | TFun(rt, Some stal, _, _) -> begin
+ let stalal = List.combine stal al in
+ let fixedcl = visitCilInstr (new formalSubsterClass stalal) ci in
+ if !debug then
+ ignore(E.log "type: %a\n oldcheck = %a\n fixedcheck = %a\n"
+ d_type t
+ d_stmt (mkStmt (Instr [ci])) d_stmt (mkStmt (Instr fixedcl)));
+ fixedcl
+ end
+ | _ -> [ci] (* internal error *)
+
+class callSitePrecAdderClass (fdat : functionData) = object(self)
+ inherit nopCilVisitor
+
+ method vinst (i : instr) =
+ match i with
+ | Call(_, Lval(Var fvi, NoOffset), el, _) -> begin
+ try
+ let cl = IH.find fdat.fdPCHash fvi.vid in
+ let clGoodArgs =
+ List.concat(List.map (substForFormals fvi.vtype el) cl)
+ in
+ ChangeTo(clGoodArgs@[i])
+ with Not_found -> DoChildren
+ end
+ | _ -> DoChildren
+end
+
+let addChecksAtCallSites (fd : fundec) (fdat : functionData) : unit =
+ ignore(visitCilFunction (new callSitePrecAdderClass fdat) fd)
+
+(* list of options to list of the things inside the Somes *)
+let filterNoneAndUnwrap (aol : 'a option list) : 'a list =
+ let rec helper aol seen =
+ match aol with
+ | [] -> List.rev seen
+ | x :: rst ->
+ match x with
+ | None -> helper rst seen
+ | Some a -> helper rst (a::seen)
+ in
+ helper aol []
+
+
+let addAllPreconditions (fdat : functionData) (f : file) : unit =
+ preConditionFinder fdat f
+ (*;addPreconditionAttributes fdat*)
+
+
+(* prints the annotated prototypes from f in file called fname.nonnull.h *)
+let printPrototypes (fdat : functionData) (fname : string) : unit =
+ let gl = IH.fold (fun vid (fvar,b) gl ->
+ if not b then gl else
+ (GVarDecl(fvar,locUnknown))::gl)
+ fdat.fdFnHash []
+ in
+ if gl = [] then () else
+ let outpf = open_out fname in
+ List.iter (fun g ->
+ match g with
+ | GVarDecl _ ->
+ let d = dprintf "%a\n" dp_global g in
+ ignore(E.log "Adding %a to %s\n" dp_global g fname);
+ fprint outpf ~width:200 d
+ | _ -> ()) gl;
+ close_out outpf
+
+let binopEqual o1 o2 =
+ o1 = o2 ||
+ match o1, o2 with
+ | PlusA, PlusPI
+ | PlusA, IndexPI
+ | PlusPI, PlusA
+ | PlusPI, IndexPI
+ | IndexPI, PlusA
+ | IndexPI, PlusPI
+ | MinusA, MinusPP
+ | MinusA, MinusPI
+ | MinusPP, MinusA
+ | MinusPP, MinusPI
+ | MinusPI, MinusA
+ | MinusPI, MinusPP -> true
+ | _, _ -> false
+
+let rec attrParamsEqual ap1 ap2 =
+ ap1 == ap2 ||
+ match ap1, ap2 with
+ | AInt i1, AInt i2 -> i1 = i2
+ | AStr s1, AStr s2 -> String.compare s1 s2 = 0
+ | ASizeOf t1, ASizeOf t2 -> deputyCompareTypes t1 t2
+ | ASizeOfE ap1, ASizeOfE ap2 -> attrParamsEqual ap1 ap2
+ | ASizeOfS ts1, ASizeOfS ts2 -> Util.equals ts1 ts2
+ | AAlignOf t1, AAlignOf t2 -> deputyCompareTypes t1 t2
+ | AAlignOfE ap1, AAlignOfE ap2 -> attrParamsEqual ap1 ap2
+ | AAlignOfS ts1, AAlignOfS ts2 -> Util.equals ts1 ts2
+ | AUnOp(o1,ap1), AUnOp(o2,ap2) -> o1 = o2 && (attrParamsEqual ap1 ap2)
+ | ABinOp(o1,ap11,ap12), ABinOp(o2,ap21,ap22) ->
+ (binopEqual o1 o2) &&
+ (attrParamsEqual ap11 ap21) &&
+ (attrParamsEqual ap12 ap22)
+ | ADot(ap1,s1), ADot(ap2,s2) ->
+ String.compare s1 s2 = 0 &&
+ (attrParamsEqual ap1 ap2)
+ | AStar ap1, AStar ap2 -> attrParamsEqual ap1 ap2
+ | AAddrOf ap1, AAddrOf ap2 -> attrParamsEqual ap1 ap2
+ | AIndex(apb1, api1), AIndex(apb2, api2) ->
+ (attrParamsEqual apb1 apb2) &&
+ (attrParamsEqual api1 api2)
+ | AQuestion(ap11,ap12,ap13), AQuestion(ap21,ap22,ap23) ->
+ (attrParamsEqual ap11 ap21) &&
+ (attrParamsEqual ap12 ap22) &&
+ (attrParamsEqual ap13 ap23)
+ | ACons(s1,apl1), ACons(s2,apl2) ->
+ String.compare s1 s2 = 0 &&
+ List.length apl1 = List.length apl2 &&
+ List.fold_left (fun b (ap1, ap2) ->
+ b && (attrParamsEqual ap1 ap2))
+ true (List.combine apl1 apl2)
+ | _ -> false
+
+
+let list_union l1 l2 =
+ List.fold_left (fun l x ->
+ if List.exists (attrParamsEqual x) l then l
+ else x :: l) l1 l2
+
+(* Take two function types and merge the attributes in the names list *)
+let mergeAttributes (oldt : typ)
+ (newt : typ)
+ (names : string list)
+ : typ
+ =
+ List.fold_left (fun oldt name ->
+ match oldt, newt with
+ | TFun(r1, args1, v1, attrs1), TFun(r2, args2, v2, attrs2) -> begin
+ match filterAttributes name attrs1 with
+ | [] -> begin
+ match filterAttributes name attrs2 with
+ | [] -> oldt
+ | newprecs :: _ ->
+ TFun(r1, args1, v1, addAttribute newprecs attrs1)
+ end
+ | (Attr(_,precs1)) :: _ -> begin
+ match filterAttributes name attrs2 with
+ | [] -> TFun(r1, args1, v1, attrs1)
+ | (Attr(_,precs2)) :: _ -> begin
+ let newattrs = dropAttributes [name] attrs1 in
+ let newprecs = Attr(name, list_union precs1 precs2) in
+ let newattrs = addAttribute newprecs newattrs in
+ TFun(r1, args1, v1, newattrs)
+ end
+ end
+ end
+ | _, _ -> oldt) oldt names
+
+
+(* Add Precondition attributes to functions *)
+let addPreconditionAttributes (fdat : functionData) : unit =
+ IH.iter (fun vid cl ->
+ match IH.tryfind fdat.fdFnHash vid with
+ | None -> ()
+ | Some (fvar, _) -> begin
+ (* HACK: only add if function is static and address is not taken *)
+ if fvar.vstorage <> Static || fvar.vaddrof then () else
+ let apl = List.map (checkToAttrParam fvar) cl in
+ let apl = filterNoneAndUnwrap apl in
+ if apl = [] then begin
+ if !debug then
+ ignore(E.log "addPreconditionAttributes: nothing to add for %s : %a\n"
+ fvar.vname d_type fvar.vtype);
+ ()
+ end else
+ let precAttr = [Attr("Preconditions",apl)] in
+ fvar.vtype <- typeAddAttributes precAttr fvar.vtype;
+ if !debug then
+ ignore(E.log "addPreconditionAttributes: new prec for %s = %a\n"
+ fvar.vname d_type fvar.vtype);
+ IH.replace fdat.fdFnHash vid (fvar,true)
+ end) fdat.fdPCHash
+
+(* add things in fdat.fdModHash to the prototypes in fdat.fdFnHash *)
+let addModificationAttributes (fdat : functionData) : unit =
+ IH.iter (fun vid (vilst, anlst) ->
+ match IH.tryfind fdat.fdFnHash vid with
+ | None -> ()
+ | Some (fvar, _) -> begin
+ (* HACK: only add if function is static and address is not taken *)
+ if fvar.vstorage <> Static || not(fvar.vaddrof) then () else
+ let gattrs = List.map (fun vi -> ACons(vi.vname,[])) vilst in
+ let anattrs = List.map (fun i -> ACons("$"^(string_of_int i), [])) anlst in
+ let attrs = gattrs @ anattrs in
+ let modAttr =
+ if attrs = [] then
+ [Attr("Modifies",[ACons("None",[])])]
+ else
+ [Attr("Modifies",attrs)]
+ in
+ fvar.vtype <- typeAddAttributes modAttr fvar.vtype;
+ if !debug then
+ ignore(E.log "DModRef: added attr: %s : %a\n"
+ fvar.vname d_type fvar.vtype);
+ IH.replace fdat.fdFnHash vid (fvar, true)
+ end) fdat.fdModHash
+
+(* Make sure that all the right annotations are on the fundecs in fdFnHash *)
+let mergeFunctionData (fdat : functionData) : unit =
+ addPreconditionAttributes fdat;
+ addModificationAttributes fdat
+
+(* If there is an annotated prototype in the patch file already, then merge
+ * these annotations with it, otherwise add the prototype to the patch file *)
+let addAnnotsToPatch (fdat : functionData) (pfname : string) : unit =
+ mergeFunctionData fdat;
+ try
+ let dummy = open_in pfname in (* see if the file exists *)
+ close_in dummy;
+ let pfile = F.parse pfname () in
+ IH.iter (fun vid (fvar,b) ->
+ let matched = ref false in
+ if b then
+ List.iter (fun g ->
+ match g with
+ | GVarDecl(fdv, _) when fdv.vname = fvar.vname -> begin
+ let attrnames = ["Preconditions";"Modifies"] in
+ let newt = mergeAttributes fdv.vtype fvar.vtype attrnames in
+ if !debug then
+ ignore(E.log "addAnnotsToPatch: changing %a to %a\n"
+ d_type fdv.vtype d_type newt);
+ fdv.vtype <- newt;
+ matched := true
+ end
+ | _ -> ()) pfile.globals;
+ if not !matched && b then begin
+ pfile.globals <- (GVarDecl(fvar,locUnknown)) :: pfile.globals
+ end)
+ fdat.fdFnHash;
+ let outpf = open_out pfname in
+ List.iter (fun g ->
+ match g with
+ | GVarDecl _ ->
+ let d = dprintf "%a\n" dp_global g in
+ fprint outpf ~width:200 d
+ | _ -> ()) pfile.globals;
+ close_out outpf;
+ with Sys_error msg -> (* If "Cannot open" is at beginning of msg, then create *)
+ printPrototypes fdat pfname
+ | x-> begin
+ ignore(E.log "%s was raised in addAnnotsToPatch\n" (Printexc.to_string x));
+ raise x
+ end
+
+let getModifiesPatch (f : file) : unit =
+ try
+ let fh = open_in modp_fname in
+ close_in fh;
+ Dpatch.applyPatch f modp_fname
+ with Sys_error _ -> ()
+
+(* apply the preconditions patch if it exists. otherwise return false *)
+let applyPrecPatch (f : file) : bool =
+ let pfn = (Filename.chop_extension f.fileName) ^ ".patch.h" in
+ try
+ let fh = open_in pfn in
+ close_in fh;
+ Dpatch.applyPatch f pfn;
+ true
+ with Sys_error _ -> begin
+ false
+ end
+(*
+ try
+ let fh = open_in patch_fname in
+ close_in fh;
+ let fh = open_in pfn in
+ close_in fh;
+ Dpatch.applyPatch f patch_fname;
+ getModifiesPatch f;
+ true
+ with Sys_error _ -> begin
+ let fh = open_out pfn in
+ close_out fh;
+ false
+ end
+*)
--- /dev/null
+(*
+ * dmodref.ml
+ *
+ * Figure out what globals and formals a function may modify and reference.
+ * Add Modifies annotations.
+ *
+ *)
+
+open Cil
+open Pretty
+open Doptions
+open Doptimutil
+
+(* From Saturn *)
+module B = Bdb
+module S = Spec
+module SIO = Specio
+
+module E = Errormsg
+module IH = Inthash
+module DPF = Dprecfinder
+
+let debug = ref false
+
+(* To match the interface *)
+let registerIgnoreInst (f : instr -> bool) : unit = ()
+let registerIgnoreCall (f : instr -> bool) : unit = ()
+
+let varinfoEqual vi1 vi2 = vi1.vid = vi2.vid
+
+let addGlobalMod (fdat : DPF.functionData)
+ (fvi : varinfo)
+ (gvi : varinfo) :
+ unit
+ =
+ ignore(E.log "DModRef: %s modifies global %s\n" fvi.vname gvi.vname);
+ match IH.tryfind fdat.DPF.fdModHash fvi.vid with
+ | Some(gvil,argl) -> begin
+ if List.exists (varinfoEqual gvi) gvil then () else begin
+ IH.replace fdat.DPF.fdModHash fvi.vid (gvi::gvil,argl);
+ match IH.tryfind fdat.DPF.fdFnHash fvi.vid with
+ | None -> IH.add fdat.DPF.fdFnHash fvi.vid (fvi, true)
+ | Some _ -> ()
+ end
+ end
+ | None -> begin
+ IH.add fdat.DPF.fdModHash fvi.vid ([gvi],[]);
+ match IH.tryfind fdat.DPF.fdFnHash fvi.vid with
+ | None -> IH.add fdat.DPF.fdFnHash fvi.vid (fvi, true)
+ | Some _ -> ()
+ end
+
+let addArgMod (fdat : DPF.functionData)
+ (fvi : varinfo)
+ (i : int) :
+ unit
+ =
+ ignore(E.log "DModRef: %s modifies argument %d\n" fvi.vname i);
+ match IH.tryfind fdat.DPF.fdModHash fvi.vid with
+ | Some(gvil,argl) -> begin
+ if List.mem i argl then () else begin
+ IH.replace fdat.DPF.fdModHash fvi.vid (gvil,i::argl);
+ match IH.tryfind fdat.DPF.fdFnHash fvi.vid with
+ | None -> IH.add fdat.DPF.fdFnHash fvi.vid (fvi, true)
+ | Some _ -> ()
+ end
+ end
+ | None -> begin
+ IH.add fdat.DPF.fdModHash fvi.vid ([],[i]);
+ match IH.tryfind fdat.DPF.fdFnHash fvi.vid with
+ | None -> IH.add fdat.DPF.fdFnHash fvi.vid (fvi, true)
+ | Some _ -> ()
+ end
+
+type satConst =
+ | SatStr of string
+ | SatInt of int
+(* look inside of v for glob sums and arg sums *)
+let extractModsFromVal (fvi : varinfo)
+ (fdat : DPF.functionData)
+ (c : DPF.ctxt)
+ (v : S.t_val) :
+ unit
+ =
+ (* if it's a sum, unwrap the first val and repeat.
+ if it's a constant, then return that *)
+ let rec helper (v : S.t_val) : satConst option =
+ try
+ let (name, vars) = S.val2sum v in
+ if name = "arg" then
+ Some(SatInt(S.val2sint vars.(0)))
+ else if name = "glob" then
+ Some(SatStr(S.val2str vars.(0)))
+ else helper vars.(0)
+ with S.Unexpected s -> begin
+ ignore(E.log "DModRef: Expected sum but got %s: %s\n"
+ (S.full_string_of_val v) s);
+ None
+ end
+ in
+ match helper v with
+ | None -> ()
+ | Some(SatStr s) -> begin
+ try
+ (* there might be a colon. we want things to the right of it *)
+ if String.contains s ':' then begin
+ let ci = String.index s ':' in
+ let len = String.length s in
+ let s = String.sub s (ci+1) (len - ci - 1) in
+ let vi = Hashtbl.find c.DPF.cGlobMap s in
+ addGlobalMod fdat fvi vi;
+ ()
+ end else begin
+ let vi = Hashtbl.find c.DPF.cGlobMap s in
+ addGlobalMod fdat fvi vi;
+ ()
+ end
+ with Not_found -> begin
+ ignore(E.log "DModRef: %s not found in global table\n" s);
+ ()
+ end
+ end
+ | Some(SatInt i) ->
+ addArgMod fdat fvi i;
+ ()
+
+let extractModsFromPred (fvi : varinfo)
+ (fdat : DPF.functionData)
+ (c : DPF.ctxt)
+ (pred : S.t_pred) :
+ unit
+ =
+ let (name, valarr) = S.pred2rep pred in
+ if name <> "stuse" then begin
+ if !debug then
+ ignore(E.log "DModRef: name %s is not stuse\n" name);
+ ()
+ end else
+ let typ = valarr.(1) in
+ try
+ let (typstr,_) = S.val2sum typ in
+ if typstr <> "write" && typstr <> "deepwrite" then begin
+ if !debug then
+ ignore(E.log "DModRef: %s is not write or deepwrite\n"
+ typstr);
+ ()
+ end else
+ let written = valarr.(0) in
+ extractModsFromVal fvi fdat c written;
+ ()
+ with S.Unexpected s -> begin
+ ignore(E.log "typ not a string: %s\n" s);
+ ()
+ end
+
+let dbTryFind (db : B.db) (key : string) : string option =
+ try Some(B.find db key)
+ with Not_found -> None
+
+let getDbData (db : B.db)
+ (fname : string)
+ (name : string) :
+ string option (* this is really database data. not a real string *)
+ =
+ let key = "sum_usemod(\""^name^"\",s_func)" in
+ match dbTryFind db key with
+ | Some s -> Some s
+ | None -> begin
+ let basename = Filename.basename fname in
+ (* force extension to be .c *)
+ let basename =
+ try (Filename.chop_extension basename)^".c"
+ with Invalid_argument _ -> basename^".c"
+ in
+ let key = "sum_usemod(\""^basename^":"^name^"\",s_func)" in
+ match dbTryFind db key with
+ | Some s -> Some s
+ | None -> begin
+ ignore(E.log "DModRef: Neither %s nor %s were in the database\n"
+ name (basename^":"^name));
+ None
+ end
+ end
+
+
+let extractModsFromDB (db : B.db)
+ (c : DPF.ctxt)
+ (fdat : DPF.functionData)
+ (f : file) :
+ unit
+ =
+ let handleFunVi (vi : varinfo) : unit =
+ if not(isFunctionType vi.vtype) then () else
+ (* XXX: Also, figure out how to add Modifies(None) annotations! *)
+ match getDbData db f.fileName vi.vname with
+ | Some data -> begin
+ ignore(E.log "DModRef: db found key for %s\n" vi.vname);
+ match SIO.load_session_str data with
+ | Some sess ->
+ S.iter_ext_logic sess (extractModsFromPred vi fdat c)
+ | None -> begin
+ ignore(E.log "DModRef: SIO.load_session_str returned None\n")
+ end
+ end
+ | None -> begin
+ ignore(E.log "DModRef: key for %s was not found in database\n"
+ vi.vname);
+ match IH.tryfind fdat.DPF.fdModHash vi.vid with
+ | Some _ -> begin (* Don't change what's already there *)
+ ignore(E.log "DModRef: already data about %s\n"
+ vi.vname);
+ ()
+ end
+ | None -> begin
+ (* If we don't already know about it, and Saturn says it
+ * doesn't modify anything, then we'll go with that.
+ * The caveat here is that if Saturn warns us that it
+ * doesn't know about something, then we have to add a stub
+ * for it to analyse *)
+ IH.add fdat.DPF.fdModHash vi.vid ([],[]);
+ ()
+ end;
+ ()
+ end
+ in
+ List.iter (fun g -> match g with
+ | GVarDecl(vi, _) -> handleFunVi vi
+ | GFun(fd, _) -> handleFunVi fd.svar
+ | _ -> ()) f.globals
+
+
+(* Entry point: find Modifications and add them to the prototypes in
+ fdat *)
+let addAllModifications (fdat : DPF.functionData) (f : file) : unit =
+ let sumFile = !saturnLogicPath ^ "/sum_usemod.db" in
+ try
+ let fd = open_in sumFile in
+ close_in fd;
+ let db = Bdb.opendbm None sumFile [ Bdb.Dbm_rdonly ] 0o666 in
+ let c = DPF.mkGlobalContext f in
+ extractModsFromDB db c fdat f;
+ ()
+ with Sys_error msg -> begin
+ ignore(E.log "DModRef: Could not open database file: %s\n" msg);
+ ()
+ end
+
+
+(* The functions below are copied from ../zraModRef/dmodref.ml *)
+(* helper for modsFromAnnotationsClass *)
+let attributeToModVar (c : DPF.ctxt)
+ (al : attribute list) :
+ (varinfo list * int list) option
+ =
+ let helper a =
+ let attrParamListToModInfo (apl : attrparam list) :
+ (varinfo list * int list)
+ =
+ let rec helper apl (viacc,iacc) =
+ match apl with
+ | [] -> viacc, iacc
+ | [ACons("None",[])] -> [], []
+ | ap :: rst -> begin
+ match ap with
+ | ACons(s, []) -> begin
+ if String.sub s 0 1 = "$" then
+ let nstr = String.sub s 1 ((String.length s) - 1) in
+ let n = int_of_string nstr in
+ helper rst (viacc, n :: iacc)
+ else try
+ let vi = Hashtbl.find c.DPF.cGlobMap s in
+ helper rst (vi :: viacc, iacc)
+ with Not_found -> begin
+ helper rst (viacc, iacc)
+ end
+ end
+ | _ -> helper rst (viacc, iacc)
+ end
+ in
+ helper apl ([],[])
+ in
+ match a with
+ | Attr("Modifies",apl) -> begin
+ try
+ if not c.DPF.cInited then
+ ignore(visitCilFile
+ (new DPF.globalMapMakerClass c.DPF.cGlobMap)
+ c.DPF.cFile);
+ Some(attrParamListToModInfo apl)
+ with DPF.NotAnExp ap -> begin
+ ignore(E.log "DModRef: Not an Exp %a\n" d_attrparam ap);
+ None
+ end
+ end
+ | Attr(s, _) -> begin
+ None
+ end
+ in
+ (*if al = [] then ignore(E.log "DModRef: No Attributes at all!\n");*)
+ List.fold_left (fun r a ->
+ match helper a with
+ | None -> r
+ | Some(vilst, ilst) -> Some(vilst, ilst))
+ None al
+
+(* helper for extractModAnnotations *)
+class modsFromAnnotationsClass (c : DPF.ctxt)
+ (fdat : DPF.functionData) = object(self)
+ inherit nopCilVisitor
+
+ method vvdec (vi : varinfo) =
+ if isFunctionType vi.vtype then
+ try
+ let attrs = typeAttrs vi.vtype in
+ let modso = attributeToModVar c attrs in
+ (match modso with
+ | None -> begin
+ if !debug then
+ ignore(E.log "DModRef: no annotations for %s:%d\n"
+ vi.vname vi.vid);
+ end
+ | Some(vilst,ilst) -> begin
+ if !debug then
+ ignore(E.log "DModRef: found annotations for %s:%d\n"
+ vi.vname vi.vid);
+ (* strip annotation to avoid type errors *)
+ vi.vtype <- setTypeAttrs vi.vtype (dropAttribute "Modifies" attrs);
+ IH.replace fdat.DPF.fdModHash vi.vid (vilst,ilst)
+ end);
+ SkipChildren
+ with Not_found -> DoChildren
+ else DoChildren
+end
+
+(* Entry point: take info from Modifies annotations and add to fdat *)
+let extractModAnnotations (fdat : DPF.functionData)
+ (f : file) :
+ unit
+ =
+ let c = DPF.mkGlobalContext f in
+ let vis = new modsFromAnnotationsClass c fdat in
+ ignore(visitCilFile vis f)
--- /dev/null
+(*
+ * dmodref.ml
+ *
+ * Figure out what globals and formals a function may modify and reference.
+ * Add Modifies annotations.
+ *
+ *)
+
+ open Cil
+ open Pretty
+ open Doptions
+ open Doptimutil
+
+ module E = Errormsg
+ module IH = Inthash
+
+ module P = Dptranal
+ module DPF = Dprecfinder
+
+let debug = ref false
+
+(*
+ * When ignore_inst returns true, then
+ * the instruction in question has no
+ * effects on the abstract state.
+ * When ignore_call returns true, then
+ * the instruction only has side-effects
+ * from the assignment if there is one.
+ *)
+let ignore_inst = ref (fun i -> false)
+let ignore_call = ref (fun i -> false)
+
+let registerIgnoreInst (f : instr -> bool) : unit =
+ let f' = !ignore_inst in
+ ignore_inst := (fun i -> (f i) || (f' i))
+
+let registerIgnoreCall (f : instr -> bool) : unit =
+ let f' = !ignore_call in
+ ignore_call := (fun i -> (f i) || (f' i))
+
+
+let varinfoEqual vi1 vi2 = vi1.vid = vi2.vid
+
+
+(* helper for modFinderVisitor *)
+let addViToGlobMod (globmod : varinfo list ref)
+ (vi : varinfo) :
+ unit
+ =
+ if vi.vglob then
+ if not(List.exists (varinfoEqual vi) (!globmod)) then
+ globmod := vi :: (!globmod)
+
+(* helper for modFinderVisitor *)
+let addViToArgMod (argmod : int list ref)
+ (f : fundec)
+ (vi : varinfo) :
+ unit
+ =
+ if List.exists (varinfoEqual vi) f.sformals then
+ if not(List.mem vi.vid (!argmod)) then
+ match DPF.argToNumber vi f.svar with
+ | Some i -> argmod := i :: (!argmod)
+ | None -> ()
+
+let kill (globmod : varinfo list ref)
+ (argmod : int list ref)
+ (error : bool ref) :
+ unit
+ =
+ globmod := [];
+ argmod := [];
+ error := true
+
+(* helper for modFinderVisitor *)
+let memWrite (globmod : varinfo list ref)
+ (argmod : int list ref)
+ (error : bool ref)
+ (f : fundec)
+ (ptre : exp) :
+ bool
+ =
+ if not(!doPtrAnalysis) then begin
+ if !debug then ignore(E.log "DModRef: Pointer Analysis is off\n");
+ kill globmod argmod error;
+ false
+ end else begin
+ match P.try_resolve_exp ptre with
+ | Some dests -> begin
+ if dests = [] then
+ if !debug then
+ ignore(E.log "DModRef: pt-set for %a was empty\n" d_exp ptre);
+ List.iter (fun vi ->
+ if !debug then
+ ignore(E.log "DModRef: %s is a dest of %a\n"
+ vi.vname d_exp ptre);
+ addViToGlobMod globmod vi;
+ addViToArgMod argmod f vi)
+ dests;
+ true
+ end
+ | None -> begin
+ kill globmod argmod error;
+ false
+ end
+ end
+
+(* helper for modFinderVisitor *)
+let funCall (fdat : DPF.functionData)
+ (globmod : varinfo list ref)
+ (argmod : int list ref)
+ (error : bool ref)
+ (f : fundec)
+ (vf : varinfo)
+ (args : exp list) :
+ bool
+ =
+ if vf.vname = "__deputy_memset" then begin
+ match P.try_resolve_exp (List.hd args) with
+ | Some dests -> begin
+ List.iter (fun vi ->
+ addViToGlobMod globmod vi;
+ addViToArgMod argmod f vi)
+ dests;
+ true
+ end
+ | None -> begin
+ kill globmod argmod error;
+ false
+ end
+ end else match IH.tryfind fdat.DPF.fdModHash vf.vid with
+ | None -> begin
+ if !debug then
+ ignore(E.log "DModRef: No data for %s:%d\n" vf.vname vf.vid);
+ kill globmod argmod error;
+ false
+ end
+ | Some(gm, am) -> begin
+ List.iter (addViToGlobMod globmod) gm;
+ List.fold_left (fun b i ->
+ let ae = List.nth args i in
+ if not(!doPtrAnalysis) then begin
+ if !debug then
+ ignore(E.log "DModRef: Pointer Analysis is off\n");
+ kill globmod argmod error;
+ false
+ end else
+ match P.try_resolve_exp ae with
+ | Some dests -> begin
+ List.iter (fun vi ->
+ addViToGlobMod globmod vi;
+ addViToArgMod argmod f vi)
+ dests;
+ b
+ end
+ | None -> begin
+ kill globmod argmod error;
+ false
+ end)
+ true am
+ end
+
+(* accumulate globals and arguments modified by f in globmod and argmod.
+ if error is true after the visitor is run, then this information could not
+ be determined. If error is false but the lists are empty, then the function
+ is pure. fdat gives info about other functions. *)
+(* helper for funcModificationFinder *)
+class modFinderVisitor (fdat : DPF.functionData)
+ (f : fundec)
+ (globmod : varinfo list ref)
+ (argmod : int list ref)
+ (error : bool ref) = object(self)
+ inherit nopCilVisitor
+
+ method vinst (i : instr) =
+ (* If the function writes memory, but no pointer analysis has been done
+ * then give up. *)
+ if (!error) && not(!doPtrAnalysis) then SkipChildren else
+ match i with
+ | Set((Var vi, _), _, _) -> begin
+ addViToGlobMod globmod vi;
+ DoChildren
+ end
+ | Set((Mem e, _), _, _) -> begin
+ if memWrite globmod argmod error f e then
+ DoChildren
+ else
+ SkipChildren
+ end
+ | Call(Some(Var vi,_), fe, args, _) -> begin
+ addViToGlobMod globmod vi;
+ if (!ignore_call) i then DoChildren else
+ match fe with
+ | Lval(Var vf, NoOffset) -> begin
+ if funCall fdat globmod argmod error f vf args then
+ DoChildren
+ else SkipChildren
+ end
+ | _ -> begin
+ if not(!doPtrAnalysis) then begin
+ if !debug then
+ ignore(E.log "DModRef: Pointer Analysis is off\n");
+ kill globmod argmod error;
+ SkipChildren
+ end else begin
+ match P.try_resolve_funptr fe with
+ | None -> begin
+ kill globmod argmod error;
+ SkipChildren
+ end
+ | Some fds ->
+ let b = List.fold_left (fun b fd ->
+ b && (funCall fdat globmod argmod error f fd.svar args))
+ true fds
+ in
+ if b then DoChildren else SkipChildren
+ end
+ end
+ end
+ | Call(Some(Mem e, off), fe, args, _) -> begin
+ if memWrite globmod argmod error f e then
+ if (!ignore_call) i then DoChildren else
+ match fe with
+ | Lval(Var vf, NoOffset) -> begin
+ if funCall fdat globmod argmod error f vf args then
+ DoChildren
+ else
+ SkipChildren
+ end
+ | _ -> begin
+ if not(!doPtrAnalysis) then begin
+ if !debug then
+ ignore(E.log "DModRef: Pointer Analysis is off\n");
+ kill globmod argmod error;
+ SkipChildren
+ end else begin
+ match P.try_resolve_funptr fe with
+ | None -> begin
+ kill globmod argmod error;
+ SkipChildren
+ end
+ | Some fds ->
+ let b = List.fold_left (fun b fd ->
+ b && (funCall fdat globmod argmod error f fd.svar args))
+ true fds
+ in
+ if b then DoChildren else SkipChildren
+ end
+ end
+ else
+ SkipChildren
+ end
+ | Call(None, fe, args, _) -> begin
+ if (!ignore_call) i then DoChildren else
+ match fe with
+ | Lval(Var vf, NoOffset) -> begin
+ if funCall fdat globmod argmod error f vf args then
+ DoChildren
+ else
+ SkipChildren
+ end
+ | _ -> begin
+ if not(!doPtrAnalysis) then begin
+ if !debug then
+ ignore(E.log "DModRef: Pointer Analysis is off\n");
+ kill globmod argmod error;
+ SkipChildren
+ end else begin
+ match P.try_resolve_funptr fe with
+ | None -> begin
+ kill globmod argmod error;
+ SkipChildren
+ end
+ | Some fds ->
+ let b = List.fold_left (fun b fd ->
+ b && (funCall fdat globmod argmod error f fd.svar args))
+ true fds
+ in
+ if b then DoChildren else SkipChildren
+ end
+ end
+ end
+ | Asm(_,_,writes,_,_,_) -> begin
+ (* XXX: fix me! *)
+ DoChildren
+ end
+end
+
+(* helper for modificationFinder *)
+let funcModificationFinder (fdat : DPF.functionData) (f : fundec) : unit =
+ let globmod = ref [] in
+ let argmod = ref [] in
+ let error = ref false in
+ let vis = new modFinderVisitor fdat f globmod argmod error in
+ ignore(visitCilFunction vis f);
+ if not(!error) then begin
+ if !debug then
+ ignore(E.log "DModRef: found some Modifies stuff! %s\n" f.svar.vname);
+ IH.replace fdat.DPF.fdModHash f.svar.vid (!globmod,!argmod);
+ match IH.tryfind fdat.DPF.fdFnHash f.svar.vid with
+ | None -> IH.add fdat.DPF.fdFnHash f.svar.vid (f.svar, true)
+ | Some _ -> ()
+ end else
+ if !debug then
+ ignore(E.log "DModRef: problem with %s\n" f.svar.vname)
+
+(* helper for addAllModifications. finds Modifications and adds them to
+ fdat.fdModHash *)
+let modificationFinder (fdat : DPF.functionData) (f : file) : unit =
+ List.iter (fun g -> match g with
+ | GFun(fd, _ ) -> funcModificationFinder fdat fd
+ | _ -> ()) f.globals
+
+
+(* Entry point: find Modifications and add them to the prototypes in
+ fdat *)
+let addAllModifications (fdat : DPF.functionData) (f : file) : unit =
+ modificationFinder fdat f
+ (*;addModificationAttributes fdat*)
+
+(* The functions below are also in ../saturnModRef/dmodref.ml *)
+(* helper for modsFromAnnotationsClass *)
+let attributeToModVar (c : DPF.ctxt)
+ (al : attribute list) :
+ (varinfo list * int list) option
+ =
+ let helper a =
+ let attrParamListToModInfo (apl : attrparam list) :
+ (varinfo list * int list)
+ =
+ let rec helper apl (viacc,iacc) =
+ match apl with
+ | [] -> viacc, iacc
+ | [ACons("None",[])] -> [], []
+ | ap :: rst -> begin
+ match ap with
+ | ACons(s, []) -> begin
+ if String.sub s 0 1 = "$" then
+ let nstr = String.sub s 1 ((String.length s) - 1) in
+ let n = int_of_string nstr in
+ helper rst (viacc, n :: iacc)
+ else try
+ let vi = Hashtbl.find c.DPF.cGlobMap s in
+ helper rst (vi :: viacc, iacc)
+ with Not_found -> begin
+ helper rst (viacc, iacc)
+ end
+ end
+ | _ -> helper rst (viacc, iacc)
+ end
+ in
+ helper apl ([],[])
+ in
+ match a with
+ | Attr("Modifies",apl) -> begin
+ try
+ if not c.DPF.cInited then
+ ignore(visitCilFile
+ (new DPF.globalMapMakerClass c.DPF.cGlobMap)
+ c.DPF.cFile);
+ Some(attrParamListToModInfo apl)
+ with DPF.NotAnExp ap -> begin
+ if !debug then
+ ignore(E.log "DModRef: Not an Exp %a\n" d_attrparam ap);
+ None
+ end
+ end
+ | Attr(s, _) -> begin
+ None
+ end
+ in
+ (*if al = [] then ignore(E.log "DModRef: No Attributes at all!\n");*)
+ List.fold_left (fun r a ->
+ match helper a with
+ | None -> r
+ | Some(vilst, ilst) -> Some(vilst, ilst))
+ None al
+
+(* helper for extractModAnnotations *)
+class modsFromAnnotationsClass (c : DPF.ctxt)
+ (fdat : DPF.functionData) = object(self)
+ inherit nopCilVisitor
+
+ method vvdec (vi : varinfo) =
+ if isFunctionType vi.vtype then
+ try
+ let attrs = typeAttrs vi.vtype in
+ let modso = attributeToModVar c attrs in
+ (match modso with
+ | None -> begin
+ if !debug then
+ ignore(E.log "DModRef: no annotations for %s:%d\n"
+ vi.vname vi.vid);
+ end
+ | Some(vilst,ilst) -> begin
+ if !debug then
+ ignore(E.log "DModRef: found annotations for %s:%d\n"
+ vi.vname vi.vid);
+ (* strip annotation to avoid type errors *)
+ vi.vtype <- setTypeAttrs vi.vtype (dropAttribute "Modifies" attrs);
+ IH.replace fdat.DPF.fdModHash vi.vid (vilst,ilst)
+ end);
+ SkipChildren
+ with Not_found -> DoChildren
+ else DoChildren
+end
+
+(* Entry point: take info from Modifies annotations and add to fdat *)
+let extractModAnnotations (fdat : DPF.functionData)
+ (f : file) :
+ unit
+ =
+ let c = DPF.mkGlobalContext f in
+ let vis = new modsFromAnnotationsClass c fdat in
+ ignore(visitCilFile vis f)
--- /dev/null
+(*
+ * nullSolverInterface.ml
+ *
+ * This is the interface of a null solver provided to the Deputy optimizer
+ *
+ *)
+
+(* This is the interface exposed to doptim.ml *)
+(* check if (e1 op e2) is valid in state s *)
+let valid s op e1 e2 = false
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2004,
+ * Jeremy Condit <jcondit@cs.berkeley.edu>
+ * George C. Necula <necula@cs.berkeley.edu>
+ * 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.
+ *
+ *)
+
+(*
+ *
+ * doctanalysis.ml
+ *
+ * An octogon analysis using the library by Antoine Mine'
+ *
+ *
+ *)
+
+open Cil
+open Expcompare
+open Pretty
+open Dattrs
+open Dutil
+open Dcheckdef
+open Doptimutil
+open Doptions
+
+open Dflowinsens
+
+module E = Errormsg
+module IH = Inthash
+module P = Dptranal
+module DF = Dataflow
+module S = Stats
+module DCE = Dcanonexp
+module AELV = Availexpslv
+module H = Hashtbl
+module UF = Unionfind
+module DFF = Dfailfinder
+module SI = SolverInterface
+module DPF = Dprecfinder
+
+module O = Oct
+
+module LvHash =
+ H.Make(struct
+ type t = lval
+ let equal lv1 lv2 = compareLval lv1 lv2
+ let hash = H.hash
+ end)
+
+module LvSet =
+ Set.Make(struct
+ type t = lval
+ let compare = Pervasives.compare
+ end)
+
+module LvUf = UF.Make(LvSet)
+
+(* A mapping from lvals to the family(list) of lvals
+ that the lval belongs to *)
+type lvalFams = lval list ref LvHash.t
+
+
+(* The abstract state for one family of lvals *)
+type smallState = {
+ (* The octagon *)
+ mutable octagon: O.oct;
+
+ (* The mapping from lvals to octagon variables *)
+ lvHash: int LvHash.t;
+ }
+
+(* A mapping from each lval to the abstract state for
+ * its family *)
+type absState = {
+ (* the state for each lv *)
+ lvState: smallState ref LvHash.t;
+
+ (* A list of small states for easy iteration, etc. *)
+ smallStates: smallState ref list
+ }
+
+let debug = ref false
+
+let doTime = ref true
+
+let time s f x = if !doTime then S.time s f x else f x
+
+
+(*
+ * When ignore_inst returns true, then
+ * the instruction in question has no
+ * effects on the abstract state.
+ * When ignore_call returns true, then
+ * the instruction only has side-effects
+ * from the assignment if there is one.
+ *)
+let ignore_inst = ref (fun i -> false)
+let ignore_call = ref (fun i -> false)
+
+let registerIgnoreInst (f : instr -> bool) : unit =
+ let f' = !ignore_inst in
+ ignore_inst := (fun i -> (f i) || (f' i))
+
+let registerIgnoreCall (f : instr -> bool) : unit =
+ let f' = !ignore_call in
+ ignore_call := (fun i -> (f i) || (f' i))
+
+(* unit -> bool *)
+(* This should be called from doptimmain before doing anything *)
+let init = O.init
+
+(* This indicates that this module actualy does something *)
+let real = true
+
+let octprinter =
+ O.foctprinter (fun i -> "v"^(string_of_int i))
+ Format.str_formatter
+
+let d_oct () (o: O.oct) =
+ octprinter o;
+ text (Format.flush_str_formatter())
+
+let d_state () (a:absState) =
+ List.fold_left (fun d sSr ->
+ if O.is_universe (!sSr).octagon then
+ d ++ text "-> Universe"
+ ++ line
+ else if O.is_empty (!sSr).octagon then
+ d ++ text "-> Empty"
+ ++ line
+ else begin
+ octprinter (!sSr).octagon;
+ d ++ text ("-> "^(Format.flush_str_formatter()))
+ ++ line
+ end) nil a.smallStates
+
+let d_vnum () (v:O.vnum) =
+ O.fvnumprinter Format.str_formatter v;
+ text (Format.flush_str_formatter()) ++ line
+
+let lvHashRevLookup (lvih : int LvHash.t) (i : int) : lval option =
+ LvHash.fold (fun lv j lvo -> if i = j then (Some lv) else lvo)
+ lvih None
+
+
+(* Convert an octagon to a list of Cil expressions embodying the constraints *)
+let octToBinOpList (a : absState) : exp list =
+ List.fold_left (fun el sSr ->
+ let o = (!sSr).octagon in
+ let lvih = (!sSr).lvHash in
+ let nel = ref [] in
+ let n = O.dim o in
+ if O.is_empty o then el else begin
+ for i = 0 to n - 1 do
+ let m_ij = O.get_elem o (2*i + 1) (2*i) in
+ match O.int_of_num m_ij with
+ | None -> ()
+ | Some m_ij -> begin
+ match lvHashRevLookup lvih i with
+ | Some lv_i ->
+ let e_i = Lval lv_i in
+ let ineq = BinOp(Le, e_i, integer m_ij, intType) in
+ nel := ineq :: (!nel)
+ | _ -> ()
+ end
+ done;
+ for i = 0 to n - 1 do
+ for j = 0 to i - 1 do
+ let m_ij = O.get_elem o (2*j) (2*i) in
+ (match O.int_of_num m_ij with
+ | None -> ()
+ | Some m_ij -> begin
+ (* v_i - v_j <= m_ij *)
+ (* Reverse lookup in lvih for the lvals of v_j and v_i,
+ then build an expression and add it to the list *)
+ match lvHashRevLookup lvih i, lvHashRevLookup lvih j with
+ | Some lv_i, Some lv_j ->
+ let e_i = Lval lv_i in
+ let e_j = Lval lv_j in
+ let diff = BinOp(MinusA, e_i, e_j, intType) in
+ let ineq = BinOp(Le, diff, integer m_ij, intType) in
+ nel := ineq :: (!nel)
+ | _, _ -> ()
+ end);
+ let m_ij = O.get_elem o (2*j+1) (2*i) in
+ (match O.int_of_num m_ij with
+ | None -> ()
+ | Some m_ij -> begin
+ (* v_i + v_j <= m_ij *)
+ match lvHashRevLookup lvih i, lvHashRevLookup lvih j with
+ | Some lv_i, Some lv_j ->
+ let e_i = Lval lv_i in
+ let e_j = Lval lv_j in
+ let sum = BinOp(PlusA, e_i, e_j, intType) in
+ let ineq = BinOp(Le, sum, integer m_ij, intType) in
+ nel := ineq :: (!nel)
+ | _, _ -> ()
+ end)
+ done
+ done;
+ el @ (!nel)
+ end)
+ [] a.smallStates
+
+
+(* Forget the state for any lval that mentions lv *)
+let forgetLval (a: absState) (lv: lval) : absState =
+ List.iter (fun sSr ->
+ let newoct = LvHash.fold (fun elv id o ->
+ if AELV.exp_has_lval lv (Lval elv) then
+ time "oct-forget" (O.forget o) id
+ else o) (!sSr).lvHash (!sSr).octagon
+ in
+ (!sSr).octagon <- newoct) a.smallStates;
+ a
+
+let forgetMem ?(globalsToo : bool=false)
+ (a : absState)
+ (eo : exp option) (* e is being written if (Some e) *)
+ : absState
+ =
+ List.iter (fun sSr ->
+ let newoct = LvHash.fold (fun elv id o ->
+ if !doPtrAnalysis then
+ match eo with
+ | Some ee ->
+ if P.lval_has_alias_read ee elv then begin
+ time "oct-forget" (O.forget o) id
+ end else o
+ | None ->
+ if AELV.lval_has_mem_read elv then
+ time "oct-forget" (O.forget o) id
+ else o
+ else if AELV.lval_has_mem_read elv then
+ time "oct-forget" (O.forget o) id
+ else o)
+ (!sSr).lvHash (!sSr).octagon
+ in
+ (!sSr).octagon <- newoct)a.smallStates;
+ a
+
+
+let stateMap : absState IH.t = IH.create 50
+
+
+let rec gcd a b =
+ if b = 0 then a else gcd b (a mod b)
+
+(* find the gcd of the non-zero elements of the array *)
+let arrayGCD (a: int array) =
+ Array.fold_left (fun g x ->
+ if x = 0 then g else
+ if g = 0 then (abs x) else gcd g (abs x)) 0 a
+
+(* divide each non-zero element of the array by the gcd of
+ all the non-zero elements of the array *)
+let divByGCD (a: int array) =
+ let gcd = arrayGCD a in
+ if gcd = 0 then a else
+ Array.map (fun x -> x / gcd) a
+
+
+exception BadConExp
+(* Take a canonicalized expression and return a list of lval ids and coefficients
+ * along with the smallState for their family. If not all lvals are from
+ * the same family, or if the canonicalized expression isn't of the form we need
+ * then raise BadConExp. *)
+let getCoefIdList (cdiff: DCE.Can.t) (state: absState)
+ : (int * int) list * smallState ref
+ =
+ (* Make a list of (id, coef) pairs *)
+ let sSror = ref None in (* For Sanity Checking *)
+ let id_coef_lst =
+ List.map (fun (f, e) ->
+ match e with
+ | StartOf lv
+ | Lval lv -> begin
+ try
+ let sSr = LvHash.find state.lvState lv in
+ let id = LvHash.find (!sSr).lvHash lv in
+ (* Sanity Check! Make sure all lvals are in
+ * the same family. For loop conditions that don't matter
+ * it's okay if they're not, though. *)
+ if true then begin
+ match (!sSror) with
+ | None -> sSror := Some sSr
+ | Some sSr' -> if not(sSr' == sSr) then begin
+ if !debug then
+ ignore(E.log "Not all lvals in the same family!! %a in %a\n"
+ d_lval lv DCE.Can.d_t cdiff);
+ raise BadConExp
+ end
+ end;
+ (id, Int64.to_int f) (* TODO: mine's oct lib doesn't do 64-bits? *)
+ with Not_found -> begin
+ (* If this happens, it is likely a failure in
+ expression canonicalization. *)
+ if not(LvHash.mem state.lvState lv) && !debug then
+ warn "lval not in hash in getCoefIdList: %a\n" d_lval lv
+ else if !debug then
+ warn "lval not in smallState for itself?!: %a\n" d_lval lv;
+ raise BadConExp
+ end
+ end
+ | _ -> begin
+ if !debug then
+ ignore(E.log "Non lv in canon exp\n");
+ raise BadConExp
+ end) cdiff.DCE.Can.cf
+ in
+
+ (* get the small state of interest *)
+ let sSr =
+ match (!sSror) with
+ | None -> raise BadConExp
+ | Some sSr -> sSr
+ in
+ (id_coef_lst, sSr)
+
+
+(* Given a canonicalized expression, make a vnum of
+ * coefs and return the smallState that the lvals in
+ * the expression belong to *)
+let makeCoefVnum (cdiff: DCE.Can.t) (state: absState)
+ : O.vnum * smallState ref
+ =
+ let (id_coefs_lst, sSr) = getCoefIdList cdiff state in
+ (* make an array of coefficients. The last elemens is the constant *)
+ let numcs = O.dim (!sSr).octagon in
+ let coefs = Array.make (numcs + 1) 0 in
+
+ (* add coefs to the array *)
+ List.iter (fun (id, f) -> coefs.(id) <- f) id_coefs_lst;
+
+ (* Add the constant term *)
+ coefs.(numcs) <- Int64.to_int cdiff.DCE.Can.ct; (* TODO: 64-bits *)
+
+ (* Try to make all of the coefs +/-1 *)
+ let coefs = divByGCD coefs in
+
+ (* If any but the constant term are not +/-1 or 0, then
+ raise BadConExp, which will return false and not update state *)
+(* let cs = Array.sub coefs 0 numcs in
+ let hasBadE = Array.fold_left
+ (fun b i -> b || (abs i <> 1 && i <> 0)) false cs
+ in
+ if hasBadE then begin
+ if !debug then
+ ignore(E.log "makeCoefVnum: bad coef %a\n" DCE.Can.d_t cdiff);
+ raise BadConExp
+ end else*)
+
+ (* convert coefs to something that the Octagon library understands *)
+ let octcoefs = O.vnum_of_int coefs in
+ (octcoefs, sSr)
+
+let findCounterExamples (a : absState)
+ (ce1 : DCE.Can.t)
+ (ce2 : DCE.Can.t) : doc option =
+ if !debug then
+ ignore(E.log "findCounterExamples: converting oct to binop list\n");
+ let el = octToBinOpList a in
+ if !debug then
+ ignore(E.log "findCounterExamples: calling DFF.failCheck\n");
+ if SI.is_real then begin
+ let ce = DCE.Can.sub ce2 ce1 ILong in
+ let eil = DFF.failCheck el ce in
+ if eil = [] then None else begin
+ let d = List.fold_left (fun d (e, i) ->
+ d ++ text "\t" ++ d_exp () e ++ text " = " ++ num i ++ line)
+ (text "Check will fail when:" ++ line) eil
+ in
+ Some d
+ end
+ end else begin
+ try
+ let ce = DCE.Can.sub ce1 ce2 ILong in
+ let ce = DCE.Can.sub ce (DCE.Can.mkInt Int64.one ILong) ILong in
+ let (enoughFacts, _) = DFF.checkFacts el ce in
+ if not enoughFacts then None else
+ let (octcoefs, sSr) = makeCoefVnum ce a in
+ let newoct = O.add_constraint (!sSr).octagon octcoefs in
+ if O.is_empty newoct then None else
+ (*if O.is_included_in (!sSr).octagon newoct then
+ Some (text "\n\nCHECK WILL ALWAYS FAIL\n\n") else*)
+ let newbox = O.int_of_vnum (O.get_box newoct) in
+ let oldbox = O.int_of_vnum (O.get_box (!sSr.octagon)) in
+ let n = O.dim newoct in
+ let d = ref nil in
+ if !debug then
+ ignore(E.log "findCounterExamples: looping over octagon: %d\n"
+ n);
+ for i = 0 to n - 1 do
+ match lvHashRevLookup (!sSr).lvHash i with
+ | None -> ()
+ | Some lv -> begin
+ let newlo = newbox.(2*i + 1) in
+ let newhi = newbox.(2*i) in
+ let oldlo = oldbox.(2*i + 1) in
+ let oldhi = oldbox.(2*i) in
+ match newlo, newhi with
+ | None, Some hi ->
+ if newhi <> oldhi || newlo <> oldlo then ()
+ (*d := !d ++ text "\t" ++ dx_lval () lv ++ text " <= "
+ ++ num hi ++ line*)
+ | Some lo, None ->
+ if newlo <> oldlo || newhi <> oldhi then ()
+ (*d := !d ++ text "\t" ++ num (-lo) ++ text " <= "
+ ++ dx_lval () lv ++ line*)
+ | Some lo, Some hi ->
+ if (newlo <> oldlo || newhi <> oldhi) &&
+ hi - (-lo) <= 10
+ then
+ d := !d ++ text "\t" ++ num (-lo) ++ text " <= "
+ ++ dx_lval () lv ++ text " <= " ++ num hi
+ ++ line
+ | _, _ -> ()
+ end
+ done;
+ if !d <> nil then begin
+ let d = text "Check will fail when:\n" ++ (!d) in
+ Some d
+ end else None
+ with
+ | BadConExp -> None
+ end
+
+(* Check that e1 <= e2 in state "state"
+ * fst(doExpLeq false e1 e2 s) is true if e1 <= e2 can be proved
+ * snd(doExpLeq true e1 e2 s) is the state with e1 <= e2 added.
+ * fst(doExpLeq true e1 e2 s) is false if the state couldn't be updated.
+ *
+ * Remember the invariant that all lvals that will be compared here will
+ * be in the same family. (If they aren't, it is a bug)
+ *)
+let totalChecks = ref 0
+let totalAssert = ref 0
+let octoCheckInsuf = ref 0
+let octoAssertInsuf = ref 0
+let interAssertInsuf = ref 0
+let interCheckInsuf = ref 0
+let doExpLeq ?(modify : bool = false)
+ ?(fCE : bool = true)
+ (e1 : exp)
+ (e2 : exp)
+ (state : absState)
+ : bool * absState * doc option
+ =
+ if modify then incr totalChecks else incr totalAssert;
+ try
+ let ce1 = DCE.canonExp Int64.one e1 in
+ let ce2 = DCE.canonExp Int64.one e2 in
+ let cdiff = DCE.Can.sub ce2 ce1 ILong in
+ (* if modify is true then add the fact that cdiff >= 0,
+ if modify is false return true iff absState can show that cdiff >= 0 *)
+
+ (* May raise BadConExp *)
+ if !debug then ignore(E.log "doExpLeq: %a\n" DCE.Can.d_t cdiff);
+ let canonSign = DCE.Can.getSign cdiff in
+ if canonSign = DCE.Can.Pos || canonSign = DCE.Can.Zero then (true, state, None) else
+ let (octcoefs, sSr) = makeCoefVnum cdiff state in
+
+ if List.length cdiff.DCE.Can.cf > 1 then begin
+ if modify then incr interCheckInsuf else incr interAssertInsuf
+ end;
+
+ (* if modify is true, then add the information to the state,
+ otherwise check if the inequality holds *)
+ if modify then begin
+ let newoct = time "oct-add-constraint" (O.add_constraint (!sSr).octagon) octcoefs in
+ if !debug then ignore(E.log "doExpLeq: adding %a >= 0 to %a to get %a\n"
+ DCE.Can.d_t cdiff d_oct (!sSr).octagon d_oct newoct);
+ (!sSr).octagon <- newoct;
+ (true, state, None)
+ end else begin
+ if !debug then ignore(E.log "doExpLeq: coefs = %a\n" d_vnum octcoefs);
+ if !debug then ignore(E.log "adding %a >= 0\n" DCE.Can.d_t cdiff);
+ let testoct = time "oct-add-constraint" (O.add_constraint (!sSr).octagon) octcoefs in
+ if !debug then ignore(E.log "is %a included in %a?\n"
+ d_oct (!sSr).octagon d_oct testoct);
+ if time "oct-inclusion" (O.is_included_in (!sSr).octagon) testoct &&
+ not(O.is_empty testoct) && not(O.is_universe testoct)
+ then begin
+ if !debug then ignore(E.log "Yes!\n");
+ (true, state, None)
+ end else begin
+ if !debug then ignore(E.log "No!\n");
+ try
+ if !debug then ignore(E.log "doExpLeq: finding counterexamples\n");
+ let docoption =
+ if fCE then
+ findCounterExamples state ce1 ce2
+ else None
+ in
+ (*let docoption = None in*)
+ if !debug then ignore(E.log "doExpLeq: done finding counterexamples\n");
+ (false, state, docoption)
+ with ex -> begin
+ ignore(E.log "doExpLeq: findCounterEamples raised %s\n"
+ (Printexc.to_string ex));
+ raise ex
+ end
+ end
+ end
+ with
+ | BadConExp -> begin
+ if modify then incr octoCheckInsuf else incr octoAssertInsuf;
+ if modify then incr interCheckInsuf else incr interAssertInsuf;
+ (false, state, None)
+ end
+
+let fst3 (f,s,t) = f
+let snd3 (f,s,t) = s
+let trd3 (f,s,t) = t
+
+(* FIXME: use the sign info! E.g. add e1 >= 0 *)
+let doLessEq a (e1: exp) (e2:exp) ~(signed:bool): absState =
+(* log "Guard %a <= %a.\n" dx_exp e1 dx_exp e2; *)
+ snd3(doExpLeq ~modify:true e1 e2 a)
+
+
+let doLess a (e1: exp) (e2:exp) ~(signed:bool): absState =
+(* log "Guard %a < %a.\n" d_plainexp e1 d_plainexp e2; *)
+ match unrollType (typeOf e1) with
+ | TPtr _ -> snd3(doExpLeq ~modify:true (BinOp(PlusPI,e1,one,typeOf e1)) e2 a)
+ | TInt _ -> snd3(doExpLeq ~modify:true (BinOp(PlusA,e1,one,typeOf e1)) e2 a)
+ | _ -> a
+
+let isNonNull state e: bool = false
+(*
+(* log "isNonNull? on %a.\n" d_plainexp e; *)
+ (isNonnullType (typeOf e)) ||
+ (match stripNopCasts e with
+ | BinOp((PlusPI|IndexPI|MinusPI), e1, e2, _) ->
+ (* We've disallowed ptr arith if e1 is null. *)
+ let t1 = typeOf e1 in
+ isPointerType t1 && not (isSentinelType t1)
+ | AddrOf lv
+ | StartOf lv -> true
+ | Const(CStr _) -> true
+ | _ -> fst(doExpLeq one e state))
+*)
+
+let isFalse state e =
+ match e with
+ UnOp(LNot, e', _) -> isNonNull state e'
+ | _ -> isZero e
+
+
+let addNonNull (state:absState) (lv: lval) : absState = state
+ (*snd(doExpLeq ~modify:true one (Lval lv) state)*)
+
+
+(* Turn a conjunction into a list of conjuncts *)
+let expToConjList (e:exp) : (exp list) =
+ let rec helper e l =
+ match e with
+ | BinOp(LAnd, e1, e2, _) ->
+ let l1 = helper e1 [] in
+ let l2 = helper e2 [] in
+ l@l1@l2
+ | _ -> e::l
+ in
+ helper e []
+
+let rec simplifyBoolExp e =
+ match stripNopCasts e with
+ UnOp(LNot, UnOp(LNot, e, _), _) -> simplifyBoolExp e
+ | BinOp(Ne, e, z, _) when isZero z -> simplifyBoolExp e
+ | UnOp(LNot, BinOp(Eq, e, z, _), _) when isZero z -> simplifyBoolExp e
+ | UnOp(LNot, BinOp(Lt, e1, e2, t), _) ->
+ BinOp(Ge, e1, e2, t)
+ | UnOp(LNot, BinOp(Le, e1, e2, t), _) ->
+ BinOp(Gt, e1, e2, t)
+ | UnOp(LNot, BinOp(Gt, e1, e2, t), _) ->
+ BinOp(Le, e1, e2, t)
+ | UnOp(LNot, BinOp(Ge, e1, e2, t), _) ->
+ BinOp(Lt, e1, e2, t)
+ | e -> e
+
+let doOneBranch (a:absState) (e:exp) : absState =
+ if !debug then
+ log "Guard %a.\n" dx_exp e;
+ let e = simplifyBoolExp e in
+ match e with
+ | BinOp(Lt, e1, e2, t) when isIntOrPtrType (typeOf e1) ->
+ let e1 = stripNopCasts e1 in
+ let e2 = stripNopCasts e2 in
+ doLess a e1 e2 ~signed:(isSignedType (typeOf e1))
+ | BinOp(Le, e1, e2, t) when isIntOrPtrType (typeOf e1) ->
+ let e1 = stripNopCasts e1 in
+ let e2 = stripNopCasts e2 in
+ doLessEq a e1 e2 ~signed:(isSignedType (typeOf e1))
+ | BinOp(Gt, e1, e2, t) when isIntOrPtrType (typeOf e1) ->
+ let e1 = stripNopCasts e1 in
+ let e2 = stripNopCasts e2 in
+ doLess a e2 e1 ~signed:(isSignedType (typeOf e1))
+ | BinOp(Ge, e1, e2, t) when isIntOrPtrType (typeOf e1) ->
+ let e1 = stripNopCasts e1 in
+ let e2 = stripNopCasts e2 in
+ doLessEq a e2 e1 ~signed:(isSignedType (typeOf e1))
+ | Lval lv ->
+ doLess a zero (Lval lv) ~signed:(isSignedType (typeOf (Lval lv)))
+ | _ -> (* TODO: Add things here for BinOp(Eq, Ne) and Lval *)
+ a
+
+(* Update a state to reflect a branch *)
+let doBranch (a:absState) (e:exp) : absState =
+ let conjList = expToConjList e in
+ List.fold_left doOneBranch a conjList
+
+(* Add that
+ * lv >= e1 and
+ * lv >= e2
+ *)
+let doMax a lv e1 e2 =
+ let a' = doLessEq a e1 (Lval lv) ~signed:(isSignedType(typeOf e1)) in
+ let a' = doLessEq a' e2 (Lval lv) ~signed:(isSignedType(typeOf e2)) in
+ a'
+
+
+(* Update a state to reflect a check *)
+let processCheck a (c:check) : absState =
+ match c with
+ (*CNonNull e -> doBranch a e*)
+ | CLeq(e1, e2, _) -> doLessEq a e1 e2 ~signed:false
+ | CLeqInt(e1, e2, _) -> doLessEq a e1 e2 ~signed:false
+ | CPtrArith(lo, hi, p, e, _) ->
+ let e' = BinOp(PlusPI,p,e,typeOf p) in
+ let a = doLessEq a lo e' ~signed:false in
+ doLessEq a e' hi ~signed:false
+ | CPtrArithNT(lo, hi, p, e, _) ->
+ let e' = BinOp(PlusPI,p,e,typeOf p) in
+ let a = doLessEq a lo e' ~signed:false in
+ a (* no upper bound *)
+ | CPtrArithAccess(lo, hi, p, e, _) ->
+ let e' = BinOp(PlusPI,p,e,typeOf p) in
+ let a = doLessEq a lo e' ~signed: false in
+ doLessEq a (BinOp(PlusPI,p,BinOp(PlusA,e,one,typeOf e),typeOf p)) hi ~signed:false
+ | _ -> a
+
+(* Add to anext any relevant inequality information for the assignment
+ dest := e
+*)
+let doSet ~(state: absState) (dest: lval) (e:exp) : absState =
+ if !debug then log "doSet: %a := %a\n" dx_lval dest dx_exp e;
+ let ce = DCE.canonExp Int64.one e in
+ let cdest = DCE.canonExp Int64.one (Lval dest) in
+
+ let dlv =
+ match cdest.DCE.Can.cf with
+ | [(_,e)] -> begin
+ match e with
+ | Lval lv | StartOf lv | AddrOf lv -> lv
+ | _ -> begin
+ ignore(E.log "doSet: bad lval %a\n" d_plainexp e);
+ raise BadConExp
+ end
+ end
+ | _ -> begin
+ if !debug then
+ ignore(E.log "doSet: bad canon lval %a" d_plainexp e);
+ raise BadConExp
+ end
+ in
+ try
+ let (octcoefs, sSr) =
+ match ce.DCE.Can.cf with
+ | [] -> begin
+ let sSr = LvHash.find state.lvState dlv in
+ let numcs = O.dim (!sSr).octagon in
+ let coefs = Array.make (numcs + 1) 0 in
+ coefs.(numcs) <- Int64.to_int ce.DCE.Can.ct;
+ let octcoefs = O.vnum_of_int coefs in
+ (octcoefs, sSr)
+ end
+ | _ -> makeCoefVnum ce state
+ in
+ let destid = LvHash.find (!sSr).lvHash dlv in
+
+ (* do the assignment! *) (* TODO: check for overflow *)
+ let newoct = time "oct-assign" (O.assign_var (!sSr).octagon destid) octcoefs in
+ if !debug then ignore(E.log "doSet: {%a} %a <- %a {%a}\n"
+ d_oct (!sSr).octagon d_lval dest d_exp e d_oct newoct);
+ (!sSr).octagon <- newoct;
+ state
+ with
+ | BadConExp -> begin
+ if !debug then
+ ignore(E.log "doSet: BadConExp: %a\n" DCE.Can.d_t ce);
+ state
+ end
+ | Not_found ->
+ if !debug then
+ ignore(E.log "doSet: %a should be in the same family as %a"
+ d_lval dlv DCE.Can.d_t ce);
+ state
+
+let int_list_union l1 l2 =
+ List.fold_left (fun l x ->
+ if List.mem x l then l else x :: l) l1 l2
+
+let vi_list_union l1 l2 =
+ List.fold_left (fun l x ->
+ if List.exists (fun vi -> vi.vid = x.vid) l then l else x :: l)
+ l1 l2
+
+
+let handleCall = P.handleCall (forgetMem ~globalsToo:true)
+
+
+(* fdato is set in doOctAnalysis.
+ Easier for it to be a global b/c of dataflow functor *)
+let fdato : DPF.functionData option ref = ref None
+let flowHandleInstr a i =
+ (* E.log "Doing instr %a in state %a\n" d_instr i d_state a; *)
+ match instrToCheck i with
+ | Some c -> processCheck a c
+ | None -> begin
+ match i with
+ | Set (lh, e, _) when compareExpStripCasts (Lval lh) e -> a
+ | Set ((Var _, _) as dest, e, _) ->
+ let anext = forgetLval a dest in
+ doSet ~state:anext dest e
+ | Set ((Mem e, _), _, _) ->
+ forgetMem a (Some e)
+ | Call (Some(Var vi, NoOffset), Lval(Var vf, NoOffset), [e1;e2], _)
+ when vf.vname = "deputy_max" -> begin
+ let a' = forgetLval a (Var vi, NoOffset) in
+ doMax a' (Var vi, NoOffset) e1 e2
+ end
+ | Call (Some (Var vi, NoOffset), f, args, _) when isPointerType vi.vtype ->
+ let a =
+ if is_deputy_instr i || (!ignore_call) i then
+ forgetLval a (Var vi, NoOffset)
+ else
+ handleCall (!fdato) f args (forgetLval a (Var vi, NoOffset))
+ (*forgetMem ~globalsToo:true (forgetLval a (Var vi, NoOffset))
+ None*)
+ in
+ let rt, _, _, _ = splitFunctionType (typeOf f) in
+ if isNonnullType rt then
+ addNonNull a (Var vi, NoOffset)
+ else
+ a
+ | Call (Some lv, f, args, _) ->
+ if !ignore_call i || is_deputy_instr i then
+ forgetLval a lv
+ else
+ handleCall (!fdato) f args (forgetLval a lv)
+ (*forgetMem ~globalsToo:true (forgetLval a lv)*)
+ | Call (_, f, args, _) ->
+ if (!ignore_call) i || is_deputy_instr i then a else
+ handleCall (!fdato) f args a
+ (*forgetMem ~globalsToo:true a None*)
+ | Asm (_, _, writes, _, _, _) ->
+ (* This is a quasi-sound handling of inline assembly *)
+ let a = forgetMem a None in
+ List.fold_left (fun a (_,_,lv) ->
+ forgetLval a lv) a writes
+ end
+
+(* make a copy of the absState *)
+let absStateCopy (a: absState) =
+ (* make copy of list *)
+ let newSSRList = List.map (fun sSr ->
+ let newoct = (!sSr).octagon in
+ let newhash = (!sSr).lvHash in
+ let newSS = {octagon = newoct; lvHash = newhash} in
+ ref newSS) a.smallStates
+ in
+ (* zip up with old list *)
+ let newold = List.combine newSSRList a.smallStates in
+ let newFromOld old = fst(List.find (fun (n,o) -> old == o) newold) in
+ (* Iter through old hash table to make new hash table *)
+ let newSSHash = LvHash.create 10 in
+ LvHash.iter (fun lv sSr ->
+ LvHash.add newSSHash lv (newFromOld sSr)) a.lvState;
+ {lvState = newSSHash; smallStates = newSSRList}
+
+let absStateEqual (a1: absState) (a2: absState) =
+ (* Check that each of the octagons are the same *)
+ let not_equal =
+ List.exists (fun (sSr1,sSr2) ->
+ not(O.is_equal (!sSr1).octagon (!sSr2).octagon))
+ (List.combine a1.smallStates a2.smallStates)
+ in
+ not(not_equal)
+
+let absStateWiden (old: absState) (newa: absState) =
+ List.iter (fun (old_sSr, new_sSr) ->
+ (!new_sSr).octagon <-
+ O.widening (!old_sSr).octagon (!new_sSr).octagon O.WidenFast)
+ (List.combine old.smallStates newa.smallStates)
+
+let absStateUnion (old: absState) (newa: absState) =
+ List.iter (fun (old_sSr, new_sSr) ->
+ (!new_sSr).octagon <-
+ O.union (!old_sSr).octagon (!new_sSr).octagon)
+ (List.combine old.smallStates newa.smallStates)
+
+module Flow = struct
+ let name = "DeputyOpt"
+ let debug = debug
+ type t = absState
+ let copy = time "oct-copy" absStateCopy
+ let stmtStartData = stateMap
+ let pretty = d_state
+ let computeFirstPredecessor s a = a
+
+ let combinePredecessors s ~(old:t) newa =
+ if time "oct-equal" (absStateEqual old) newa then None else
+ match s.skind with
+ | Loop(b, l, so1, so2) -> begin
+ if !debug then ignore(E.log "widening at sid: %d\n" s.sid);
+ time "oct-widen" (absStateWiden old) newa;
+ Some newa
+ end
+ | _ -> begin
+ time "oct-union" (absStateUnion old) newa;
+ Some newa
+ end
+
+ let doInstr i a =
+ if !debug then ignore(E.log "Visiting %a State is %a.\n" dn_instr i d_state a);
+ let newstate = flowHandleInstr a i in
+ DF.Done (newstate)
+
+ let doStmt s a =
+ curStmt := s.sid;
+ DF.SDefault
+
+ let doGuard e a =
+ if isFalse a e then DF.GUnreachable
+ else DF.GUse (doBranch (copy a) e)
+
+ let filterStmt s = true
+end
+
+module FlowEngine = DF.ForwardsDataFlow (Flow)
+
+let printFailCond (tl : (bool * absState * doc option) list)
+ (c : check)
+ : bool
+ =
+ let ci = checkToInstr c in
+ List.fold_left (fun b1 (b2, _, fco) ->
+ (match fco with
+ | Some fc -> ignore(E.log "%a\n%t" dt_instr ci (fun () -> fc))
+ | None -> ());
+ b1 && b2)
+ true tl
+
+
+let flowOptimizeCheck (c: check) ((inState, acc):(absState * check list))
+ : (absState * check list) =
+ let isNonNull = isNonNull inState in
+ (* Returns true if CPtrArith(lo, hi, p, Lval x, sz) can be optimized away:*)
+ let checkPtrArith lo hi p e : bool =
+ let e' = BinOp(PlusPI,p,e,typeOf p) in
+ printFailCond [doExpLeq lo e' inState; doExpLeq e' hi inState] c
+ in
+ (* Returns true if CPtrArithAccess(lo, hi, p, Lval x, sz) can be optimized away:*)
+ let checkPtrArithAccess lo hi p e : bool =
+ let e' = BinOp(PlusPI,p,e,typeOf p) in
+ let e'' = BinOp(PlusPI,p,BinOp(PlusA,e,one,typeOf e),typeOf p) in
+ printFailCond [doExpLeq lo e' inState; doExpLeq e'' hi inState] c
+ in
+ let checkPtrArithNT lo hi p e : bool =
+ let e' = BinOp(PlusPI,p,e,typeOf p) in
+ printFailCond [doExpLeq lo e' inState; doExpLeq ~fCE:false e' hi inState] c
+ in
+ (* Returns true if CLeq(e1, e2) can be optimized away:*)
+ let checkLeq ?(fCE: bool = true) e1 e2 : bool =
+ printFailCond [doExpLeq ~fCE:fCE e1 e2 inState] c
+ in
+
+ (* doOpt is called recursivly if we simplify the check to a different check
+ that has its own optimization rule.
+ It returns the simplified check, or None if we satisfied the check
+ completely.*)
+ let rec doOpt (c : check) : check option =
+ match c with
+ | CNonNull (e1) when isNonNull e1 ->
+ None
+ | CNonNull (e1) when isZero e1 ->
+ error "non-null check will always fail.";
+ Some c
+ | CNullOrLeq (e1, _, _, why)
+ | CNullOrLeqNT (e1, _, _, _, why) when isZero e1 ->
+ None
+ | CNullOrLeq (e1, e2, e3, why) when isNonNull e1 ->
+ doOpt (CLeq(e2, e3, why))
+ | CNullOrLeqNT (e1, e2, e3, e4, why) when isNonNull e1 ->
+ let c' = CLeqNT(e2, e3, e4, why) in
+ doOpt c'
+ | CPtrArithAccess(lo,hi,p,e,sz) when checkPtrArithAccess lo hi p e ->
+ None
+ | CPtrArith(lo, hi, p, e, sz) when checkPtrArith lo hi p e ->
+ None
+ | CPtrArithNT(lo, hi, p, e, sz) when checkPtrArithNT lo hi p e ->
+ None
+ | CLeqNT(e1,e2,_,_) when checkLeq ~fCE:false e1 e2 ->
+ None
+ | CLeq(e1, e2, _)
+ | CNullOrLeq(_, e1, e2, _)
+ | CNullOrLeqNT(_, e1, e2, _, _) when checkLeq e1 e2 ->
+ None
+ | CLeqInt(e1, (BinOp (MinusPP, hi, p, _)), _) ->
+ let e' = BinOp(PlusPI, p, e1, (typeOf p)) in
+ if checkLeq e' hi then
+ None
+ else
+ Some c
+ | _ -> Some c
+ in
+ let acc' = match doOpt c with
+ Some c -> c::acc | None -> acc
+ in
+ (processCheck inState c), acc'
+
+
+
+
+
+class flowOptimizeVisitor tryReverse = object (self)
+ inherit nopCilVisitor
+
+ val mutable curSid = -1
+
+ method vstmt s =
+ (* now that checks and instructions can be mixed,
+ * the state has to be changed when an instruction is
+ * visited *)
+ let rec filterIl state il fl =
+ match il with
+ | [] -> List.rev fl
+ | i::rest -> begin
+ if !debug then ignore(E.log "filterIL: looking at %a in state %a\n"
+ d_instr i d_state state);
+ match instrToCheck i with
+ | Some c -> begin
+ let _, c' = flowOptimizeCheck c (state,[]) in
+ let new_state = flowHandleInstr state i in
+ match c' with
+ | [] -> begin
+ if !debug then ignore(E.log "fOV: in state %a, optimized %a out\n"
+ d_state state d_instr i);
+ filterIl new_state rest fl
+ end
+ | [nc] -> begin
+ let i' = checkToInstr nc in
+ if !debug then ignore(E.log "fOV: changed to %a out\n" d_instr i');
+ filterIl new_state rest (i'::fl)
+ end
+ | _ -> begin
+ if !debug then ignore(E.log "fOV: didn't optimize %a out\n" d_instr i);
+ filterIl new_state rest (i::fl)
+ end
+ end
+ | None ->
+ let new_state = flowHandleInstr state i in
+ filterIl new_state rest (i::fl)
+ end
+ in
+ begin
+ try
+ curSid <- s.sid;
+ let state = IH.find stateMap s.sid in
+ if !debug then
+ E.log "Optimizing statement %d with state %a\n" s.sid d_state state;
+ begin
+ match s.skind with
+ | If(e, blk1, blk2, l) when isNonNull state e ->
+ if hasALabel blk2 then
+ s.skind <- If(Cil.one, blk1, blk2, l)
+ else
+ (* blk2 is unreachable *)
+ s.skind <- Block blk1
+ | If(e, blk1, blk2, l) when isFalse state e ->
+ if hasALabel blk1 then
+ s.skind <- If(Cil.zero, blk1, blk2, l)
+ else
+ (* blk1 is unreachable *)
+ s.skind <- Block blk2
+ | Instr il ->
+ if tryReverse then
+ let il' = filterIl state il [] in
+ let (pre, rst) = prefix is_check_instr il' in
+ let il'' = filterIl state (List.rev pre) [] in
+ s.skind <- Instr((List.rev il'')@rst)
+ else
+ s.skind <- Instr(filterIl state il [])
+ | _ -> ()
+ end
+ with Not_found -> () (* stmt is unreachable *)
+ end;
+ DoChildren
+
+ method vfunc fd =
+ curFunc := fd;
+ let cleanup x =
+ curFunc := dummyFunDec;
+ x
+ in
+ ChangeDoChildrenPost (fd, cleanup)
+
+end
+
+
+(* lvh is a mapping from lvals to lval list refs *)
+class lvalFamilyMakerClass lvh = object(self)
+ inherit nopCilVisitor
+
+ val mutable singCondVar = None
+
+ method private makeFamily ?(sing:bool=false) (ce: DCE.Can.t) =
+ (*if !debug then ignore(E.log "Making family for: %a\n" DCE.Can.d_t ce);*)
+ if sing then match ce.DCE.Can.cf with
+ | [(_, StartOf lv)]
+ | [(_, Lval lv)] -> singCondVar <- Some lv
+ | _ -> ()
+ else
+ List.iter (fun (_,e1) ->
+ List.iter (fun (_,e2) ->
+ match e1, e2 with
+ | Lval lv1, Lval lv2
+ | Lval lv1, StartOf lv2
+ | Lval lv1, AddrOf lv2
+ | StartOf lv1, Lval lv2
+ | StartOf lv1, StartOf lv2
+ | StartOf lv1, AddrOf lv2
+ | AddrOf lv1, Lval lv2
+ | AddrOf lv1, StartOf lv2
+ | AddrOf lv1, AddrOf lv2 -> begin
+ match lv1, lv2 with
+ | (Var vi, NoOffset), _ when vi.vname = "__LOCATION__" -> ()
+ | _, (Var vi, NoOffset) when vi.vname = "__LOCATION__" -> ()
+ | _ -> begin
+ match singCondVar with
+ | None ->
+ lvh := LvUf.make_equal (!lvh) lv1 lv2 Ptrnode.mkRIdent
+ | Some lv ->
+ let tlvh = LvUf.make_equal (!lvh) lv1 lv Ptrnode.mkRIdent in
+ lvh := LvUf.make_equal tlvh lv1 lv2 Ptrnode.mkRIdent
+ end
+ end
+ | _, _ -> ()) ce.DCE.Can.cf) ce.DCE.Can.cf
+
+ (* use the lvals we get from canonicalized expressions *)
+ method vexpr e =
+ let ce = DCE.canonExp Int64.one e in
+ self#makeFamily ce;
+ DoChildren
+
+ method vinst i =
+ match i with
+ | Set(lv, e, _) -> begin
+ let ce = DCE.canonExp Int64.one e in
+ let lvce = DCE.canonExp Int64.one (Lval lv) in
+ let ce = {ce with DCE.Can.cf = ce.DCE.Can.cf@lvce.DCE.Can.cf} in
+ self#makeFamily ce;
+ DoChildren
+ end
+ | Call(Some lv, _, el, _) when is_deputy_instr i -> begin
+ let cel = List.map (DCE.canonExp Int64.one) el in
+ let cfll = List.map (fun ce -> ce.DCE.Can.cf) cel in
+ let cfl = List.concat cfll in
+ let ce = DCE.canonExp Int64.one (Lval lv) in
+ let ce = {ce with DCE.Can.cf = ce.DCE.Can.cf @ cfl} in
+ self#makeFamily ce;
+ DoChildren
+ end
+ | Call(_,_,el,_) when is_deputy_instr i -> begin
+ if el <> [] then
+ let cel = List.map (DCE.canonExp Int64.one) el in
+ let cfll = List.map (fun ce -> ce.DCE.Can.cf) cel in
+ let cfl = List.concat cfll in
+ let ce = DCE.canonExp Int64.one (List.hd el) in
+ let ce = {ce with DCE.Can.cf = ce.DCE.Can.cf @ cfl} in
+ self#makeFamily ce;
+ DoChildren
+ else DoChildren
+ end
+ | _ -> DoChildren
+
+ method vstmt s =
+ match s.skind with
+ | If(e, _, _, _) -> begin
+ let e = simplifyBoolExp e in
+ match e with
+ | BinOp(_, e1, e2, t) when isIntOrPtrType (typeOf e1) ->
+ let ce1 = DCE.canonExp Int64.one e1 in
+ let ce2 = DCE.canonExp Int64.one e2 in
+ let d = DCE.Can.sub ce2 ce1 ILong in
+ self#makeFamily ~sing:false d;
+ DoChildren
+ | _ -> DoChildren
+ end
+ | _ -> DoChildren
+
+end
+
+let famListsToAbsState lvh : absState =
+ if !debug then ignore(E.log "famListsToAbsState: begin\n");
+ let ssHash = LvHash.create 32 in
+ let sSrLstr = ref [] in
+ let lvlistlist = LvUf.eq_classes (!lvh) in
+ if !debug then ignore(E.log "famListsToAbsState: There are %d families\n"
+ (List.length lvlistlist));
+ List.iter (fun lvl ->
+ if List.length lvl <= 1 then () else (* no singleton families *)
+ let newoct = O.universe (List.length lvl) in
+ let idHash = LvHash.create 10 in
+ let cr = ref 0 in
+ if !debug then ignore(E.log "Family: ");
+ List.iter (fun lv ->
+ if !debug then ignore(E.log "(%d, %a) " (!cr) d_lval lv);
+ LvHash.add idHash lv (!cr);
+ incr cr) lvl;
+ if !debug then ignore(E.log "\n");
+ let newssr = ref {octagon = newoct; lvHash = idHash} in
+ sSrLstr := newssr :: (!sSrLstr);
+ List.iter (fun lv ->
+ LvHash.add ssHash lv newssr)
+ lvl) lvlistlist;
+ { lvState = ssHash; smallStates = !sSrLstr }
+
+let lvFamsCreate fd =
+ let lvh = ref LvUf.empty in
+ let vis = new lvalFamilyMakerClass lvh in
+ if !debug then ignore(E.log "making lv hash for %s\n" fd.svar.vname);
+ try
+ ignore(visitCilFunction vis fd);
+ if !debug then ignore(E.log "lvFamsCreate: finished making lvh\n");
+ lvh
+ with x ->
+ ignore(E.log "lvFamsCreate: There was an exception in lvalFamilyMakerClass: %s\n"
+ (Printexc.to_string x));
+ raise x
+
+let makeTop fd =
+ let lvh = lvFamsCreate fd in
+ if !debug then ignore(E.log "Making top for %s\n" fd.svar.vname);
+ famListsToAbsState lvh
+
+(** flow-sensitive octagon analysis *)
+let doOctAnalysis ?(tryReverse : bool=false)
+ (fd : fundec)
+ (fdat : DPF.functionData)
+ : unit =
+ try
+ if !debug then ignore(E.log "OctAnalysis: analyzing %s\n" fd.svar.vname);
+ IH.clear stateMap;
+ fdato := (Some fdat); (* for flowHandleInstr *)
+ let fst = List.hd fd.sbody.bstmts in
+ let precs =
+ match IH.tryfind fdat.DPF.fdPCHash fd.svar.vid with
+ | None -> []
+ | Some cl -> cl
+ in
+ let t = List.fold_left flowHandleInstr (makeTop fd) precs in
+ IH.add stateMap fst.sid t;
+ if !debug then ignore(E.log "running flow engine for %s\n" fd.svar.vname);
+ totalChecks := 0;
+ totalAssert := 0;
+ octoCheckInsuf := 0;
+ octoAssertInsuf := 0;
+ interAssertInsuf := 0;
+ interCheckInsuf := 0;
+ time "oct-compute" FlowEngine.compute [fst];
+ if !debug then
+ E.log "%s: finished analysis; starting optimizations.\n" Flow.name;
+ ignore (time "oct-optim" (visitCilFunction (new flowOptimizeVisitor tryReverse)) fd);
+ IH.clear stateMap;
+ curStmt := -1;
+ ()
+ with Failure "hd" -> ()
+
+let reportStats() = ()
+(* ignore(E.log "totalChecks %d\n" (!totalChecks));
+ ignore(E.log "totalAssert %d\n" (!totalAssert));
+ ignore(E.log "interCheckInsuf %d\n" (!interCheckInsuf));
+ ignore(E.log "interAssertInsuf %d\n" (!interAssertInsuf));
+ ignore(E.log "octoCheckInsuf %d\n" (!octoCheckInsuf));
+ ignore(E.log "octoAssertInsuf %d\n" (!octoAssertInsuf))*)
--- /dev/null
+/* oct.h
+ Public interface for the library.
+
+ This file is part of the Octagon Abstract Domain Library.
+ Please read the COPYING file packaged in the distribution.
+ Main web page is: http://www.di.ens.fr/~mine/oct/
+
+ Copyright (C) Antoine Mine' 2000-2002
+ */
+
+#ifndef OCT_H__
+#define OCT_H__
+
+#ifdef __cplusplus
+#ifndef OCT_HAS_BOOL
+#define OCT_HAS_BOOL
+#endif
+#endif
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <sys/types.h>
+#include <sys/time.h>
+#include <unistd.h>
+#include <limits.h>
+
+#include <oct_config_2.h>
+
+#ifdef OCT_HAS_NEW_POLKA
+#include <poly.h>
+#endif
+
+#ifdef OCT_ENABLE_ASSERT
+#include <signal.h>
+#include <unistd.h>
+#endif
+
+/* zra */
+#define OCT_PREFIX CAT(octiag_
+
+#define CAT(a,b) a##b
+#define OCT_PROTO(s) OCT_PREFIX,s)
+
+
+/************/
+/* Booleans */
+/************/
+
+#ifndef OCT_HAS_NEW_POLKA /* booleans are already defined in New Polka */
+
+/* true/false */
+#ifndef OCT_HAS_BOOL /* bool/true/false are defined in recent C++ compilers */
+typedef int bool;
+#define true (int)1
+#define false (int)0
+#endif
+
+/* complete lattice: bot<true,false<top */
+typedef enum {
+ tbool_bottom = 0,
+ tbool_true = 1,
+ tbool_false = 2,
+ tbool_top = 3
+} tbool;
+
+#endif
+
+
+/********************/
+/* Numerical Domain */
+/********************/
+
+#include <oct_num.h>
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+
+/*************/
+/* Shortcuts */
+/*************/
+
+#define oct_init OCT_PROTO(init)
+
+#define oct_mmalloc_new OCT_PROTO(mmalloc_new)
+#define oct_mmalloc_print OCT_PROTO(mmalloc_print)
+#define oct_mmalloc_use OCT_PROTO(mmalloc_use)
+#define oct_mmalloc_get_current OCT_PROTO(mmalloc_get_current)
+#define oct_mmalloc_reset OCT_PROTO(mmalloc_reset)
+#define oct_mm_malloc OCT_PROTO(mm_malloc)
+#define oct_mm_realloc OCT_PROTO(mm_realloc)
+#define oct_mm_free OCT_PROTO(mm_free)
+#define oct_empty OCT_PROTO(empty)
+#define oct_universe OCT_PROTO(universe)
+#define oct_copy OCT_PROTO(copy)
+#define oct_free OCT_PROTO(free)
+
+#define oct_dimension OCT_PROTO(dimension)
+#define oct_nbconstraints OCT_PROTO(nbconstraints)
+#define oct_get_box OCT_PROTO(get_box)
+#define oct_from_box OCT_PROTO(from_box)
+#define oct_get_bounds OCT_PROTO(get_bounds)
+#define oct_set_bounds OCT_PROTO(set_bounds)
+#define oct_is_empty OCT_PROTO(is_empty)
+#define oct_is_empty_lazy OCT_PROTO(is_empty_lazy)
+#define oct_is_universe OCT_PROTO(is_universe)
+#define oct_is_included_in OCT_PROTO(is_included_in)
+#define oct_is_included_in_lazy OCT_PROTO(is_included_in_lazy)
+#define oct_is_equal OCT_PROTO(is_equal)
+#define oct_is_equal_lazy OCT_PROTO(is_equal_lazy)
+#define oct_is_in OCT_PROTO(is_in)
+#define oct_intersection OCT_PROTO(intersection)
+#define oct_convex_hull OCT_PROTO(convex_hull)
+#define oct_widening OCT_PROTO(widening)
+#define oct_widening_steps OCT_PROTO(widening_steps)
+#define oct_narrowing OCT_PROTO(narrowing)
+#define oct_forget OCT_PROTO(forget)
+#define oct_add_bin_constraints OCT_PROTO(add_bin_constraints)
+#define oct_assign_variable OCT_PROTO(assign_variable)
+#define oct_substitute_variable OCT_PROTO(substitute_variable)
+#define oct_add_constraint OCT_PROTO(add_constraint)
+#define oct_interv_assign_variable OCT_PROTO(interv_assign_variable)
+#define oct_interv_add_constraint OCT_PROTO(interv_add_constraint)
+#define oct_interv_substitute_variable OCT_PROTO(interv_substitute_variable)
+#define oct_time_flow OCT_PROTO(time_flow)
+#define oct_add_dimensions_and_embed OCT_PROTO(add_dimensions_and_embed)
+#define oct_add_dimensions_and_project OCT_PROTO(add_dimensions_and_project)
+#define oct_remove_dimensions OCT_PROTO(remove_dimensions)
+#define oct_add_dimensions_and_embed_multi \
+ OCT_PROTO(add_dimensions_and_embed_multi)
+#define oct_add_dimensions_and_project_multi \
+ OCT_PROTO(add_dimensions_and_project_multi)
+#define oct_remove_dimensions_multi \
+ OCT_PROTO(remove_dimensions_multi)
+#define oct_add_permute_dimensions_and_embed \
+ OCT_PROTO(add_permute_dimensions_and_embed)
+#define oct_add_permute_dimensions_and_project \
+ OCT_PROTO(add_permute_dimensions_and_project)
+#define oct_permute_remove_dimensions \
+ OCT_PROTO(permute_remove_dimensions)
+#define oct_print OCT_PROTO(print)
+#define oct_add_epsilon OCT_PROTO(add_epsilon)
+#define oct_add_epsilon_max OCT_PROTO(add_epsilon_max)
+#define oct_add_epsilon_bin OCT_PROTO(add_epsilon_bin)
+#define oct_m_empty OCT_PROTO(m_empty)
+#define oct_m_from_oct OCT_PROTO(m_from_oct)
+#define oct_m_to_oct OCT_PROTO(m_to_oct)
+#define oct_m_free OCT_PROTO(m_free)
+#define oct_m_is_equal OCT_PROTO(m_is_equal)
+#define oct_m_print OCT_PROTO(m_print)
+#define oct_m_dimension OCT_PROTO(m_dimension)
+#define oct_m_is_empty OCT_PROTO(m_is_empty)
+#define oct_serialize OCT_PROTO(serialize)
+#define oct_deserialize OCT_PROTO(deserialize)
+#define oct_m_serialize OCT_PROTO(m_serialize)
+#define oct_m_deserialize OCT_PROTO(m_deserialize)
+#define oct_to_poly OCT_PROTO(to_poly)
+#define oct_from_poly OCT_PROTO(from_poly)
+#define oct_random_init OCT_PROTO(random_init)
+#define oct_chrono_reset OCT_PROTO(chrono_reset)
+#define oct_chrono_start OCT_PROTO(chrono_start)
+#define oct_chrono_stop OCT_PROTO(chrono_stop)
+#define oct_chrono_get OCT_PROTO(chrono_get)
+#define oct_chrono_print OCT_PROTO(chrono_print)
+#define oct_timing_enter OCT_PROTO(timing_enter)
+#define oct_timing_exit OCT_PROTO(timing_exit)
+#define oct_timing_print OCT_PROTO(timing_print)
+#define oct_timing_print_all OCT_PROTO(timing_print_all)
+#define oct_timing_reset OCT_PROTO(timing_reset)
+#define oct_timing_reset_all OCT_PROTO(timing_reset_all)
+#define oct_timing_clear OCT_PROTO(timing_clear)
+
+
+/**********/
+/* Assert */
+/**********/
+
+#ifdef OCT_ENABLE_ASSERT
+
+/* it is very convinient when debugging to make the program core dump at the
+ very place a check fails, this is why there is a kill(getpid(),SIGABRT)
+*/
+#define OCT_ASSERT(t,s) if (!(t)) { fprintf(stderr,"Assert failure in file %s at line %i:\n%s (%s)\n",__FILE__,__LINE__,s,#t); fflush(stderr); kill(getpid(),SIGABRT); }
+
+#else
+
+#define OCT_ASSERT(t,s) ;
+
+#endif
+
+
+/**********/
+/* Memory */
+/**********/
+
+/* oct_mm_alloc as malloc
+ oct_mm_free as free
+ oct_mm_realloc as realloc
+ new_t(t) returns a pointer t* on a buffer of the size sizeof(t)
+ new_n(t,n) returns a pointer t* on a buffer of the size sizeof(t)*n
+ renew_n(c,t,n) like new_n, but call mm_realloc
+
+ if ENABLE_MALLOC_MONITORING if defined, allows memory usage monitoring:
+
+ . a monitor is allocated by mm=oct_mmalloc_new()
+
+ . monitors count the number of oct_mm_malloc/oct_mm_realloc/oct_mm_free,
+ memory and max memory consumption
+ malloc, realloc and free are unchanged
+
+ . after a oct_mmalloc_use(mm), all blocks mm_malloced belong to monitor mm
+
+ . if you then oct_mm_realloc/oct_mm_free this block, it is monitored by
+ the same monitor used when it was oct_mm_malloced, not the current monitor
+
+ . use oct_mmalloc_print(mm) to print infos
+
+ . oct_mmalloc_reset(mm) resets counters to 0 and forget about all blocks it
+ monitored
+
+ . monitors MUST NOT be deallocated (blocks may be still monitored by them !)
+
+ . before any call to oct_mmalloc_use, a default global monitor is used,
+ use oct_mmalloc_get_current to get it
+
+ if ENABLE_MALLOC_MONITORING is not defined, oct_mm_alloc, oct_mm_realloc
+ and oct_mm_free are simply malloc, realloc and free
+
+ YOU SHOULD NOT MIX POINTERS USED BY malloc/realloc/free ANS THOSE USED BY
+ oct_mm_malloc/oct_mm_realloc/oct_mm_free/new_t/new_n/renew_n
+
+ */
+
+struct mmalloc_tt;
+typedef struct mmalloc_tt mmalloc_t;
+
+/* monitor manipulation */
+mmalloc_t* OCT_PROTO(mmalloc_new) (void);
+void OCT_PROTO(mmalloc_print) (mmalloc_t* mm);
+void OCT_PROTO(mmalloc_use) (mmalloc_t* mm);
+mmalloc_t* OCT_PROTO(mmalloc_get_current) ();
+void OCT_PROTO(mmalloc_reset) (mmalloc_t* mm);
+
+#ifdef OCT_ENABLE_MALLOC_MONITORING
+/* monitored malloc/realloc/free */
+void* OCT_PROTO(mm_malloc) (size_t t);
+void* OCT_PROTO(mm_realloc) (void* p, size_t t);
+void OCT_PROTO(mm_free) (void* p);
+#else
+
+static inline void* OCT_PROTO(mm_malloc) (size_t t)
+{ void* p = malloc(t);
+ OCT_ASSERT(p || !t, "mm_malloc returns NULL pointer");
+ return p; }
+
+static inline void* OCT_PROTO(mm_realloc) (void* p, size_t t)
+{ p = realloc(p,t);
+ OCT_ASSERT(p || !t, "mm_realloc returns NULL pointer");
+ return p; }
+
+static inline void OCT_PROTO(mm_free) (void* p) { free(p); }
+
+#endif
+
+#define new_t(t) ((t*) oct_mm_malloc (sizeof(t)))
+#define new_n(t,n) ((t*) oct_mm_malloc (sizeof(t)*(n)))
+#define renew_n(c,t,n) ((t*) oct_mm_realloc (c,sizeof(t)*(n)))
+
+
+
+/************/
+/* Octagons */
+/************/
+
+/* initialization */
+int OCT_PROTO(init) ();
+
+
+struct oct_tt;
+typedef struct oct_tt oct_t;
+
+
+/* unary/binary constraint type */
+typedef enum {
+ px = 0, /* x <= c (y ignored) */
+ mx = 1, /* -x <= c (y ignored) */
+ pxpy = 2, /* x+y <= c */
+ pxmy = 3, /* x-y <= c */
+ mxpy = 4, /* -x+y <= c */
+ mxmy = 5 /* -x-y <= c */
+} oct_cons_type;
+
+typedef struct {
+ var_t x;
+ var_t y;
+ num_t c;
+ oct_cons_type type;
+} oct_cons;
+
+/* Bertrand Jeannet's way to specify insertion / deletion of dimensions,
+ not necessarily at the end
+ */
+#ifndef OCT_HAS_NEW_POLKA
+typedef struct {
+ var_t pos;
+ var_t nbdims;
+} dimsup_t;
+#endif
+
+/* octagon creation/destruction */
+oct_t* OCT_PROTO(empty) (var_t n); /* empty domain, c not allocated */
+oct_t* OCT_PROTO(universe) (var_t n); /* full domain */
+oct_t* OCT_PROTO(copy) (oct_t* m); /* increase ref count */
+void OCT_PROTO(free) (oct_t* m); /* decrease ref count & free if 0 */
+
+/* query functions */
+var_t OCT_PROTO(dimension) (oct_t* m);
+size_t OCT_PROTO(nbconstraints) (oct_t* m); /* number of non infinitary constraints */
+
+/* interval functions */
+num_t* OCT_PROTO(get_box) (oct_t* m); /* get bounds for all variables */
+
+oct_t* OCT_PROTO(from_box) (var_t n,
+ const num_t* b); /* construct an octagon from a box */
+
+void OCT_PROTO(get_bounds) (oct_t* m, var_t k, /* get bounds for one variable */
+ num_t* up, num_t* down);
+
+oct_t* OCT_PROTO(set_bounds) (oct_t* m, var_t k, /* set bounds for one variable */
+ const num_t* up, const num_t* down,
+ bool destructive);
+
+
+/* tests */
+bool OCT_PROTO(is_empty ) (oct_t* m);
+tbool OCT_PROTO(is_empty_lazy) (oct_t* m);
+bool OCT_PROTO(is_universe) (oct_t* m);
+bool OCT_PROTO(is_included_in) (oct_t* ma, oct_t* mb);
+tbool OCT_PROTO(is_included_in_lazy) (oct_t* ma, oct_t* mb);
+bool OCT_PROTO(is_equal) (oct_t* ma, oct_t* mb);
+tbool OCT_PROTO(is_equal_lazy) (oct_t* ma, oct_t* mb);
+bool OCT_PROTO(is_in) (oct_t* a, const num_t* v);
+
+/* operators */
+typedef enum
+{
+ OCT_WIDENING_FAST = 0, /* fast convergence, less precision */
+ OCT_WIDENING_ZERO = 1, /* elements<0 are first set to 0 */
+ OCT_WIDENING_UNIT = 2, /* elemets are set to -1, 0, and 1 before +oo */
+
+ /* Not a widening, but a degenerate hull (precisely, a hull without
+ closure of the left argument).
+ It is tantalizing to interleave widenings and hulls to improve the
+ precision of fix-point computations but, unfortunately, this destroys
+ the converge property and makes analyses loop forever.
+ The PRE_WIDENING is a middle-ground.
+ It does not ensure convergence by itself, but can be safely interleaved
+ with widenings.
+ As long as proper widenings occur infinitely often, the interleaved
+ sequence will converge. Also, it converges more slowly, and so, gives
+ a better precision.
+ */
+ OCT_PRE_WIDENING = 3
+} oct_widening_type;
+
+oct_t* OCT_PROTO(intersection) (oct_t* ma, oct_t* mb, bool destructive);
+
+oct_t* OCT_PROTO(convex_hull) (oct_t* ma, oct_t* mb, bool destructive);
+
+oct_t* OCT_PROTO(widening) (oct_t* ma, oct_t* mb, bool destructive,
+ oct_widening_type type);
+
+oct_t* OCT_PROTO(widening_steps) (oct_t* ma, oct_t* mb, bool destructive,
+ int nb_steps, num_t* steps);
+
+oct_t* OCT_PROTO(narrowing) (oct_t* ma, oct_t* mb, bool destructive);
+
+/* transfer functions */
+oct_t* OCT_PROTO(forget) (oct_t* m, var_t k, bool destructive);
+
+oct_t* OCT_PROTO(add_bin_constraints) (oct_t* m,
+ unsigned int nb,
+ const oct_cons* cons,
+ bool destructive);
+
+oct_t* OCT_PROTO(assign_variable) (oct_t* m,
+ var_t x,
+ const num_t* tab,
+ bool destructive);
+
+oct_t* OCT_PROTO(substitute_variable) (oct_t* m,
+ var_t x,
+ const num_t* tab,
+ bool destructive);
+
+oct_t* OCT_PROTO(add_constraint) (oct_t* m,
+ const num_t* tab,
+ bool destructive);
+
+
+oct_t* OCT_PROTO(interv_assign_variable) (oct_t* m,
+ var_t x,
+ const num_t* t,
+ bool destructive);
+
+oct_t* OCT_PROTO(interv_add_constraint) (oct_t* m,
+ const num_t* tab,
+ bool destructive);
+
+
+oct_t* OCT_PROTO(interv_substitute_variable) (oct_t* m,
+ var_t x,
+ const num_t* t,
+ bool destructive);
+
+oct_t* OCT_PROTO(time_flow) (oct_t* m,
+ const num_t *nmin,
+ const num_t *nmax,
+ const num_t *tab,
+ bool destructive);
+
+/* change of dimensions */
+oct_t* OCT_PROTO(add_dimensions_and_embed) (oct_t* m,
+ var_t dimsup,
+ bool destructive);
+
+oct_t* OCT_PROTO(add_dimensions_and_project) (oct_t* m,
+ var_t dimsup,
+ bool destructive);
+
+oct_t* OCT_PROTO(remove_dimensions) (oct_t* m,
+ var_t dimsup,
+ bool destructive);
+
+
+oct_t* OCT_PROTO(add_dimensions_and_embed_multi) (oct_t* m,
+ const dimsup_t* tab,
+ size_t size_tab,
+ bool destructive);
+
+oct_t* OCT_PROTO(add_dimensions_and_project_multi)(oct_t* m,
+ const dimsup_t* tab,
+ size_t size_tab,
+ bool destructive);
+
+oct_t* OCT_PROTO(remove_dimensions_multi) (oct_t* m,
+ const dimsup_t* tab,
+ size_t size_tab,
+ bool destructive);
+
+oct_t* OCT_PROTO(add_permute_dimensions_and_embed) (oct_t* m,
+ var_t dimsup,
+ const var_t* permutation,
+ bool destructive);
+
+oct_t* OCT_PROTO(add_permute_dimensions_and_project) (oct_t* m,
+ var_t dimsup,
+ const var_t* permutation,
+ bool destructive);
+
+oct_t* OCT_PROTO(permute_remove_dimensions) (oct_t* m,
+ var_t diminf,
+ const var_t* permutation,
+ bool destructive);
+
+
+/* perturbation */
+
+oct_t* OCT_PROTO(add_epsilon) (oct_t* m,
+ const num_t* epsilon,
+ bool destructive);
+
+oct_t* OCT_PROTO(add_epsilon_max) (oct_t* m,
+ const num_t* epsilon,
+ bool destructive);
+
+oct_t* OCT_PROTO(add_epsilon_bin) (oct_t* ma,
+ oct_t* mb,
+ const num_t* epsilon,
+ bool destructive);
+
+
+/* utilities */
+void OCT_PROTO(print) (const oct_t* m); /* print in the form a constrain set */
+
+/* minimal form */
+
+struct moct_tt;
+typedef struct moct_tt moct_t;
+
+moct_t* OCT_PROTO(m_empty) (var_t n);
+moct_t* OCT_PROTO(m_from_oct) (oct_t* m);
+oct_t* OCT_PROTO(m_to_oct) (moct_t* a);
+void OCT_PROTO(m_free) (moct_t* a);
+
+bool OCT_PROTO(m_is_equal) (moct_t* ma, moct_t* mb);
+void OCT_PROTO(m_print) (moct_t* m);
+var_t OCT_PROTO(m_dimension) (moct_t* m);
+bool OCT_PROTO(m_is_empty) (moct_t* m);
+
+
+/* serialization */
+void* OCT_PROTO(serialize) (oct_t* m, size_t* size);
+oct_t* OCT_PROTO(deserialize) (void* d);
+void* OCT_PROTO(m_serialize) (moct_t* m, size_t* size);
+moct_t* OCT_PROTO(m_deserialize) (void* d);
+
+
+
+/****************************/
+/* Interface with New Polka */
+/****************************/
+#ifdef OCT_HAS_NEW_POLKA
+
+poly_t* OCT_PROTO(to_poly) (oct_t* m);
+oct_t* OCT_PROTO(from_poly) (poly_t* p);
+
+#endif
+
+
+
+/**********/
+/* Chrono */
+/**********/
+
+
+typedef struct
+{
+ struct timeval begin;
+ long usec;
+ long sec;
+ int start;
+} chrono_t;
+
+
+void OCT_PROTO(chrono_reset) (chrono_t* c);
+void OCT_PROTO(chrono_start) (chrono_t* c);
+void OCT_PROTO(chrono_stop) (chrono_t* c);
+void OCT_PROTO(chrono_get) (chrono_t* c,
+ long* hour, long* min, long* sec, long* usec);
+void OCT_PROTO(chrono_print) (chrono_t* c);
+
+/* if ENABLE_TIMING is enabled, each library function use the following macros
+ for basic profiling: number of calls and time elapsed in each function
+
+ should not be used to
+ */
+
+
+#ifdef OCT_ENABLE_TIMING
+
+#define OCT_ENTER(s,k) oct_timing_enter(s,k)
+#define OCT_EXIT(s,k) oct_timing_exit(s,k)
+
+#else
+
+#define OCT_ENTER(s,k)
+#define OCT_EXIT(s,k)
+
+#endif
+
+void OCT_PROTO(timing_enter) (const char* name, unsigned key);
+void OCT_PROTO(timing_exit) (const char* name, unsigned key);
+void OCT_PROTO(timing_print) (const char* name);
+void OCT_PROTO(timing_print_all) (void);
+void OCT_PROTO(timing_reset) (const char* name);
+void OCT_PROTO(timing_reset_all) (void);
+void OCT_PROTO(timing_clear) (void);
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
--- /dev/null
+(* oct_common.ml
+ Abstract semantics functions and OCaml pretty-printing.
+
+ This file is part of the Octagon Abstract Domain Library.
+ Please read the COPYING file packaged in the distribution.
+ Main web page is: http://www.di.ens.fr/~mine/oct/
+
+ Copyright (C) Antoine Mine' 2000-2002
+*)
+
+(******************************)
+(* This is from oct_common.ml *)
+(******************************)
+
+(* initialization *)
+external init: unit -> bool = "ocaml_oct_init"
+
+
+(* numerical domain *)
+type num
+type vnum
+
+external num_of_int: int -> num = "ocaml_num_int"
+external num_of_frac: int*int -> num = "ocaml_num_frac"
+external num_of_float: float -> num = "ocaml_num_float"
+external num_infty: unit -> num = "ocaml_num_infty"
+
+external vnum_of_int: int array -> vnum = "ocaml_vnum_int"
+external vnum_of_frac: int*int array -> vnum = "ocaml_vnum_frac"
+external vnum_of_float: float array -> vnum = "ocaml_vnum_float"
+
+external vnum_of_int_opt: int option array -> vnum = "ocaml_vnum_int_opt"
+external vnum_of_frac_opt: int*int option array -> vnum = "ocaml_vnum_frac_opt"
+
+external string_of_num: num -> string = "ocaml_num_string"
+external string_of_vnum: vnum -> int -> string = "ocaml_vnum_string"
+external vnum_length: vnum -> int = "ocaml_vnum_length"
+
+external int_of_num: num -> int option = "ocaml_int_num"
+external frac_of_num: num -> int*int option = "ocaml_frac_num"
+external float_of_num: num -> float = "ocaml_float_num"
+
+external int_of_vnum: vnum -> int option array = "ocaml_int_vnum"
+external frac_of_vnum: vnum -> int*int option array = "ocaml_frac_vnum"
+external float_of_vnum: vnum -> float array = "ocaml_float_vnum"
+
+let fnumprinter f o =
+ Format.fprintf f "@[%s@]" (string_of_num o)
+
+let fvnumprinter f o =
+ let n = vnum_length o in
+ Format.fprintf f "@[[ @[";
+ for i=0 to n-1 do
+ if i=0 then Format.fprintf f "@[%s@]" (string_of_vnum o i)
+ else Format.fprintf f ", @[%s@]" (string_of_vnum o i)
+ done;
+ Format.fprintf f "@] ]@]"
+
+let numprinter = fnumprinter Format.std_formatter
+let vnumprinter = fvnumprinter Format.std_formatter
+
+
+(* boolean lattice *)
+type tbool = Bottom | True | False | Top
+
+(* abstract types of regular & minimized octagons *)
+type oct
+type moct
+
+(* octagon creation *)
+external empty: int -> oct = "ocaml_oct_empty"
+external universe: int -> oct = "ocaml_oct_universe"
+
+(* query functions *)
+external dim: oct -> int = "ocaml_oct_dim"
+external nbconstraints: oct -> int = "ocaml_oct_nbconstraints"
+external get_elem: oct -> int -> int -> num = "ocaml_oct_get_elem"
+
+(* tests *)
+external is_empty: oct -> bool = "ocaml_oct_is_empty"
+external is_empty_lazy: oct -> tbool= "ocaml_oct_is_empty_lazy"
+external is_universe: oct -> bool= "ocaml_oct_is_universe"
+external is_included_in: oct -> oct -> bool= "ocaml_oct_is_included_in"
+external is_included_in_lazy:
+ oct -> oct -> tbool= "ocaml_oct_is_included_in_lazy"
+external is_equal: oct -> oct -> bool= "ocaml_oct_is_equal"
+external is_equal_lazy: oct -> oct -> tbool= "ocaml_oct_is_equal_lazy"
+external is_in: oct -> vnum -> bool= "ocaml_oct_is_in"
+
+(* operators *)
+type wident = WidenFast | WidenZero | WidenUnit | WidenSteps of vnum | PreWiden
+external inter: oct -> oct -> oct = "ocaml_oct_inter"
+external union: oct -> oct -> oct = "ocaml_oct_union"
+external widening: oct -> oct -> wident -> oct = "ocaml_oct_widening"
+external narrowing: oct -> oct -> oct = "ocaml_oct_narrowing"
+
+(* transfer function *)
+type constr =
+ PX of int*num (* x <= c *)
+ | MX of int*num (* -x <= c *)
+ | PXPY of int*int*num (* x+y <= c *)
+ | PXMY of int*int*num (* x-y <= c *)
+ | MXPY of int*int*num (* -x+y <= c *)
+ | MXMY of int*int*num (* -x-y <= c *)
+external forget: oct -> int -> oct = "ocaml_oct_forget"
+external add_bin_constraints:
+ oct -> constr array -> oct = "ocaml_oct_add_bin_constraints"
+external assign_var: oct -> int -> vnum -> oct = "ocaml_oct_assign_variable"
+external substitute_var:
+ oct -> int -> vnum -> oct = "ocaml_oct_substitute_variable"
+external add_constraint:
+ oct -> vnum -> oct = "ocaml_oct_add_constraint"
+external interv_assign_var:
+ oct -> int -> vnum -> oct = "ocaml_oct_interv_assign_variable"
+external interv_add_constraint:
+ oct -> vnum -> oct = "ocaml_oct_interv_add_constraint"
+external interv_substitute_var:
+ oct -> int -> vnum -> oct = "ocaml_oct_interv_substitute_variable"
+external time_flow:
+ oct -> num -> num -> vnum -> oct = "ocaml_oct_time_flow"
+
+(* change of dimensions *)
+external add_dims_and_embed:
+ oct -> int -> oct = "ocaml_oct_add_dimensions_and_embed"
+external add_dims_and_project:
+ oct -> int -> oct = "ocaml_oct_add_dimensions_and_project"
+external del_dims:
+ oct -> int -> oct = "ocaml_oct_remove_dimensions"
+
+(* change of dimensions at arbitrary positions *)
+type dimsup = { pos:int; nbdims:int; }
+external add_dims_and_embed_multi:
+ oct -> dimsup array -> oct = "ocaml_oct_add_dimensions_and_embed_multi"
+external add_dims_and_project_multi:
+ oct -> dimsup array -> oct = "ocaml_oct_add_dimensions_and_project_multi"
+external del_dims_multi:
+ oct -> dimsup array -> oct = "ocaml_oct_remove_dimensions_multi"
+
+(* change of dimensions with permutation *)
+external add_permute_dims_and_embed:
+ oct -> int -> int array -> oct = "ocaml_oct_add_permute_dimensions_and_embed"
+external add_permute_dims_and_project:
+ oct -> int -> int array -> oct = "ocaml_oct_add_permute_dimensions_and_project"
+external permute_del_dims:
+ oct -> int -> int array -> oct = "ocaml_oct_permute_remove_dimensions"
+
+(* normal form *)
+external close: oct -> oct = "ocaml_oct_close"
+
+(* interval functions *)
+external get_box: oct -> vnum = "ocaml_oct_get_box"
+external from_box: vnum -> oct = "ocaml_oct_from_box"
+external get_bounds: oct -> int -> num*num = "ocaml_oct_get_bounds"
+external set_bounds: oct -> int -> num*num -> oct = "ocaml_oct_set_bounds"
+
+(* preturbation *)
+external add_epsilon: oct -> num -> oct = "ocaml_oct_add_epsilon"
+external add_epsilon_max: oct -> num -> oct = "ocaml_oct_add_epsilon_max"
+external add_epsilon_bin: oct -> oct -> num -> oct ="ocaml_oct_add_epsilon_bin"
+
+(* utilities *)
+external print: oct -> unit = "ocaml_oct_print"
+
+(* minimal form *)
+external m_to_oct: moct -> oct = "ocaml_oct_m_to_oct"
+external m_from_oct: oct -> moct = "ocaml_oct_m_from_oct"
+external m_print: moct -> unit = "ocaml_oct_m_print"
+external m_dim: moct -> int = "ocaml_oct_m_dim"
+external m_is_empty: moct -> bool = "ocaml_oct_m_is_empty"
+external m_is_equal: moct -> moct -> bool = "ocaml_oct_m_is_equal"
+external m_get_elem: moct -> int -> int -> num = "ocaml_oct_m_get_elem"
+
+(* top-level prettry printers *)
+external elem_to_string:
+ oct -> int -> int -> string option = "ocaml_oct_elem_to_string"
+external elem_to_string2:
+ oct -> int -> int -> string -> string option = "ocaml_oct_elem_to_string2"
+external get_state: oct -> int = "ocaml_oct_get_state"
+
+let foctprinter v f o =
+ if (get_state o) = 0
+ then Format.fprintf f "@[(empty)@]"
+ else
+ begin
+ Format.fprintf f "@[";
+(* if (get_state o) = 2 then Format.fprintf f "(closed)@ ";*)
+ Format.fprintf f "@[<hov 2>{@ ";
+
+ let n = dim o in
+ let beg = ref true in
+
+ for i=0 to n-1 do
+ (match (elem_to_string2 o (2*i+1) (2*i) (v i)) with
+ Some a ->
+ if !beg then beg:=false else Format.fprintf f ",@ ";
+ Format.fprintf f "@[%s@]" a
+ | _ -> ())
+ done;
+
+ for i=0 to n-1 do
+ for j=0 to i-1 do
+ (match (elem_to_string2 o (2*j) (2*i) ((v i)^"-"^(v j))) with
+ Some a ->
+ if !beg then beg:=false else Format.fprintf f ",@ ";
+ Format.fprintf f "@[%s@]" a
+ | _ -> ());
+ (match (elem_to_string2 o (2*j+1) (2*i) ((v i)^"+"^(v j))) with
+ Some a ->
+ if !beg then beg:=false else Format.fprintf f ",@ ";
+ Format.fprintf f "@[%s@]" a
+ | _ -> ())
+ done
+ done;
+
+ Format.fprintf f "@]@ }@]"
+ end
+
+
+let octprinter v = foctprinter v Format.std_formatter
+
+(* this version only prints the new version of changed constraints *)
+let foctnewprinter v f o p =
+ if dim o != dim p then failwith "oct_common.ml:foctnewprinter: incompatible octagon dimensions";
+ if (get_state o) != (get_state p) then foctprinter v f p
+ else if (get_state p) == 0 then Format.fprintf f "{@ }"
+ else
+ begin
+ Format.fprintf f "@[";
+ Format.fprintf f "@[<hov 2>{@ ";
+
+ let n = dim o in
+ let beg = ref true in
+
+ for i=0 to n-1 do
+ if get_elem o (2*i+1) (2*i) <> get_elem p (2*i+1) (2*i) ||
+ get_elem o (2*i) (2*i+1) <> get_elem p (2*i) (2*i+1)
+ then
+ (match (elem_to_string2 p (2*i+1) (2*i) (v i)) with
+ Some a ->
+ if !beg then beg:=false else Format.fprintf f ",@ ";
+ Format.fprintf f "@[%s@]" a
+ | _ -> ())
+ done;
+
+ for i=0 to n-1 do
+ for j=0 to i-1 do
+ if get_elem o (2*j) (2*i) <> get_elem p (2*j) (2*i) ||
+ get_elem o (2*i) (2*j) <> get_elem p (2*i) (2*j)
+ then
+ (match (elem_to_string2 p (2*j) (2*i) ((v i)^"-"^(v j))) with
+ Some a ->
+ if !beg then beg:=false else Format.fprintf f ",@ ";
+ Format.fprintf f "@[%s@]" a
+ | _ -> ());
+
+ if get_elem o (2*j+1) (2*i) <> get_elem p (2*j+1) (2*i) ||
+ get_elem o (2*i) (2*j+1) <> get_elem p (2*i) (2*j+1)
+ then
+ (match (elem_to_string2 p (2*j+1) (2*i) ((v i)^"+"^(v j))) with
+ Some a ->
+ if !beg then beg:=false else Format.fprintf f ",@ ";
+ Format.fprintf f "@[%s@]" a
+ | _ -> ())
+ done
+ done;
+
+ Format.fprintf f "@]@ }@]"
+ end
+
+(** this version prints both the old and the new version of changed constraints
+ *)
+let foctdiffprinter v f o p =
+ if dim o != dim p then failwith "oct_common.ml:foctdiffprinter: incompatible octagon dimensions";
+ if (get_state o) != (get_state p) then Format.fprintf f "old:%a@ new:%a"
+ (foctprinter v) o (foctprinter v) p
+ else if (get_state p) == 0 then Format.fprintf f "{@ }"
+ else
+ begin
+ Format.fprintf f "@[";
+ Format.fprintf f "@[<hov 2>{@ ";
+
+ let n = dim o in
+ let beg = ref true in
+
+ let pp x y = match x,y with
+ Some a,Some b ->
+ if !beg then beg:=false else Format.fprintf f ",@ ";
+ Format.fprintf f "@[old: %s@ new: %s@]" a b
+ | None,Some b ->
+ if !beg then beg:=false else Format.fprintf f ",@ ";
+ Format.fprintf f "@[old: _@ new: %s@]" b
+ | Some a,None ->
+ if !beg then beg:=false else Format.fprintf f ",@ ";
+ Format.fprintf f "@[old: %s@ new: _@]" a
+ | None,None -> ()
+ in
+
+ for i=0 to n-1 do
+ if get_elem o (2*i+1) (2*i) <> get_elem p (2*i+1) (2*i) ||
+ get_elem o (2*i) (2*i+1) <> get_elem p (2*i) (2*i+1)
+ then
+ pp (elem_to_string2 o (2*i+1) (2*i) (v i))
+ (elem_to_string2 p (2*i+1) (2*i) (v i))
+ done;
+
+ for i=0 to n-1 do
+ for j=0 to i-1 do
+ if get_elem o (2*j) (2*i) <> get_elem p (2*j) (2*i) ||
+ get_elem o (2*i) (2*j) <> get_elem p (2*i) (2*j)
+ then
+ pp (elem_to_string2 o (2*j) (2*i) ((v i)^"-"^(v j)))
+ (elem_to_string2 p (2*j) (2*i) ((v i)^"-"^(v j)));
+
+ if get_elem o (2*j+1) (2*i) <> get_elem p (2*j+1) (2*i) ||
+ get_elem o (2*i) (2*j+1) <> get_elem p (2*i) (2*j+1)
+ then
+ pp (elem_to_string2 o (2*j+1) (2*i) ((v i)^"+"^(v j)))
+ (elem_to_string2 p (2*j+1) (2*i) ((v i)^"+"^(v j)))
+ done
+ done;
+
+ Format.fprintf f "@]@ }@]"
+ end
+
+external melem_to_string:
+ moct -> int -> int -> string option = "ocaml_oct_melem_to_string"
+external melem_to_string2:
+ moct -> int -> int -> string -> string option = "ocaml_oct_melem_to_string2"
+
+let fmoctprinter v f o =
+ if (m_is_empty o)
+ then Format.fprintf f "@[(empty)@]"
+ else
+ begin
+ Format.fprintf f "@[";
+ Format.fprintf f "@[<hov 2>{@ ";
+
+ let n = m_dim o in
+ let beg = ref true in
+
+ for i=0 to n-1 do
+ (match (melem_to_string2 o (2*i+1) (2*i) (v i)) with
+ Some a ->
+ if !beg then beg:=false else Format.fprintf f ",@ ";
+ Format.fprintf f "@[%s@]" a
+ | _ -> ())
+ done;
+
+ for i=0 to n-1 do
+ for j=0 to i-1 do
+ (match (melem_to_string2 o (2*j) (2*i) ((v i)^"-"^(v j))) with
+ Some a ->
+ if !beg then beg:=false else Format.fprintf f ",@ ";
+ Format.fprintf f "@[%s@]" a
+ | _ -> ());
+ (match (melem_to_string2 o (2*j+1) (2*i) ((v i)^"+"^(v j))) with
+ Some a ->
+ if !beg then beg:=false else Format.fprintf f ",@ ";
+ Format.fprintf f "@[%s@]" a
+ | _ -> ())
+ done
+ done;
+
+ Format.fprintf f "@]@ }@]"
+ end
+
+let moctprinter v = fmoctprinter v Format.std_formatter
+
+(* utilities *)
+external memprint: unit -> unit = "ocaml_oct_memprint"
+external timeprint: unit -> unit = "ocaml_oct_timeprint"
+
+(* polyhedra <-> octagons conversion *)
+(* 'a is used instead of Poly.t in case the Poly module is not defined *)
+external from_poly: 'a -> oct = "ocaml_oct_from_poly"
+external to_poly: oct -> 'a = "ocaml_oct_to_poly"
--- /dev/null
+(* oct_common.mli
+ Abstract semantics functions.
+
+ This file is part of the Octagon Abstract Domain Library.
+ Please read the COPYING file packaged in the distribution.
+ Main web page is: http://www.di.ens.fr/~mine/oct/
+
+ Copyright (C) Antoine Mine' 2000-2002
+*)
+
+
+(* initialization *)
+external init: unit -> bool = "ocaml_oct_init"
+
+
+(* numerical domain *)
+type num
+type vnum
+
+external num_of_int: int -> num = "ocaml_num_int"
+external num_of_frac: int*int -> num = "ocaml_num_frac"
+external num_of_float: float -> num = "ocaml_num_float"
+external num_infty: unit -> num = "ocaml_num_infty"
+
+external vnum_of_int: int array -> vnum = "ocaml_vnum_int"
+external vnum_of_frac: int*int array -> vnum = "ocaml_vnum_frac"
+external vnum_of_float: float array -> vnum = "ocaml_vnum_float"
+
+external vnum_of_int_opt: int option array -> vnum = "ocaml_vnum_int_opt"
+external vnum_of_frac_opt: int*int option array -> vnum = "ocaml_vnum_frac_opt"
+
+external string_of_num: num -> string = "ocaml_num_string"
+external string_of_vnum: vnum -> int -> string = "ocaml_vnum_string"
+external vnum_length: vnum -> int = "ocaml_vnum_length"
+
+external int_of_num: num -> int option = "ocaml_int_num"
+external frac_of_num: num -> int*int option = "ocaml_frac_num"
+external float_of_num: num -> float = "ocaml_float_num"
+
+external int_of_vnum: vnum -> int option array = "ocaml_int_vnum"
+external frac_of_vnum: vnum -> int*int option array = "ocaml_frac_vnum"
+external float_of_vnum: vnum -> float array = "ocaml_float_vnum"
+
+val fnumprinter: Format.formatter -> num -> unit
+val fvnumprinter: Format.formatter -> vnum -> unit
+val numprinter: num -> unit
+val vnumprinter: vnum -> unit
+
+(* boolean lattice *)
+type tbool = Bottom | True | False | Top
+
+(* abstract types of regular & minimized octagons *)
+type oct
+type moct
+
+(* octagon creation *)
+external empty: int -> oct = "ocaml_oct_empty"
+external universe: int -> oct = "ocaml_oct_universe"
+
+(* query functions *)
+external dim: oct -> int = "ocaml_oct_dim"
+external nbconstraints: oct -> int = "ocaml_oct_nbconstraints"
+external get_elem: oct -> int -> int -> num = "ocaml_oct_get_elem"
+
+(* tests *)
+external is_empty: oct -> bool = "ocaml_oct_is_empty"
+external is_empty_lazy: oct -> tbool= "ocaml_oct_is_empty_lazy"
+external is_universe: oct -> bool= "ocaml_oct_is_universe"
+external is_included_in: oct -> oct -> bool= "ocaml_oct_is_included_in"
+external is_included_in_lazy:
+ oct -> oct -> tbool= "ocaml_oct_is_included_in_lazy"
+external is_equal: oct -> oct -> bool= "ocaml_oct_is_equal"
+external is_equal_lazy: oct -> oct -> tbool= "ocaml_oct_is_equal_lazy"
+external is_in: oct -> vnum -> bool= "ocaml_oct_is_in"
+
+(* operators *)
+type wident = WidenFast | WidenZero | WidenUnit | WidenSteps of vnum | PreWiden
+external inter: oct -> oct -> oct = "ocaml_oct_inter"
+external union: oct -> oct -> oct = "ocaml_oct_union"
+external widening: oct -> oct -> wident -> oct = "ocaml_oct_widening"
+external narrowing: oct -> oct -> oct = "ocaml_oct_narrowing"
+
+(* transfer function *)
+type constr =
+ PX of int*num (* x <= c *)
+ | MX of int*num (* -x <= c *)
+ | PXPY of int*int*num (* x+y <= c *)
+ | PXMY of int*int*num (* x-y <= c *)
+ | MXPY of int*int*num (* -x+y <= c *)
+ | MXMY of int*int*num (* -x-y <= c *)
+external forget: oct -> int -> oct = "ocaml_oct_forget"
+external add_bin_constraints: oct -> constr array -> oct = "ocaml_oct_add_bin_constraints"
+external assign_var:
+ oct -> int -> vnum -> oct = "ocaml_oct_assign_variable"
+external substitute_var:
+ oct -> int -> vnum -> oct = "ocaml_oct_substitute_variable"
+external add_constraint: oct -> vnum -> oct = "ocaml_oct_add_constraint"
+external interv_assign_var:
+ oct -> int -> vnum -> oct = "ocaml_oct_interv_assign_variable"
+external interv_add_constraint:
+ oct -> vnum -> oct = "ocaml_oct_interv_add_constraint"
+external interv_substitute_var:
+ oct -> int -> vnum -> oct = "ocaml_oct_interv_substitute_variable"
+external time_flow:
+ oct -> num -> num -> vnum -> oct = "ocaml_oct_time_flow"
+
+(* change of dimensions *)
+external add_dims_and_embed:
+ oct -> int -> oct = "ocaml_oct_add_dimensions_and_embed"
+external add_dims_and_project:
+ oct -> int -> oct = "ocaml_oct_add_dimensions_and_project"
+external del_dims: oct -> int -> oct = "ocaml_oct_remove_dimensions"
+
+(* change of dimensions at arbitrary positions *)
+type dimsup = { pos:int; nbdims:int; }
+external add_dims_and_embed_multi:
+ oct -> dimsup array -> oct = "ocaml_oct_add_dimensions_and_embed_multi"
+external add_dims_and_project_multi:
+ oct -> dimsup array -> oct = "ocaml_oct_add_dimensions_and_project_multi"
+external del_dims_multi:
+ oct -> dimsup array -> oct = "ocaml_oct_remove_dimensions_multi"
+
+(* change of dimensions with permutation *)
+external add_permute_dims_and_embed:
+ oct -> int -> int array -> oct = "ocaml_oct_add_permute_dimensions_and_embed"
+external add_permute_dims_and_project:
+ oct -> int -> int array -> oct = "ocaml_oct_add_permute_dimensions_and_project"
+external permute_del_dims:
+ oct -> int -> int array -> oct = "ocaml_oct_permute_remove_dimensions"
+
+(* normal form *)
+external close: oct -> oct = "ocaml_oct_close"
+
+(* interval functions *)
+external get_box: oct -> vnum = "ocaml_oct_get_box"
+external from_box: vnum -> oct = "ocaml_oct_from_box"
+external get_bounds: oct -> int -> num*num = "ocaml_oct_get_bounds"
+external set_bounds: oct -> int -> num*num -> oct = "ocaml_oct_set_bounds"
+
+(* preturbation *)
+external add_epsilon: oct -> num -> oct = "ocaml_oct_add_epsilon"
+external add_epsilon_max: oct -> num -> oct = "ocaml_oct_add_epsilon_max"
+external add_epsilon_bin: oct -> oct -> num -> oct ="ocaml_oct_add_epsilon_bin"
+
+(* utilities *)
+external print: oct -> unit = "ocaml_oct_print"
+
+(* minimal form *)
+external m_to_oct: moct -> oct = "ocaml_oct_m_to_oct"
+external m_from_oct: oct -> moct = "ocaml_oct_m_from_oct"
+external m_print: moct -> unit = "ocaml_oct_m_print"
+external m_dim: moct -> int = "ocaml_oct_m_dim"
+external m_is_empty: moct -> bool = "ocaml_oct_m_is_empty"
+external m_is_equal: moct -> moct -> bool = "ocaml_oct_m_is_equal"
+external m_get_elem: moct -> int -> int -> num = "ocaml_oct_m_get_elem"
+
+(* top-level prettry_printers *)
+
+val foctprinter: (int -> string) -> Format.formatter -> oct -> unit
+val octprinter: (int -> string) -> oct -> unit
+val fmoctprinter: (int -> string) -> Format.formatter -> moct -> unit
+val moctprinter: (int -> string) -> moct -> unit
+
+(* prints only constraints that differ between two two octagons *)
+
+(* only prints _new_ constraints in the difference *)
+val foctnewprinter: (int -> string) -> Format.formatter -> oct -> oct -> unit
+
+(* prints both old and new constraints in the difference *)
+val foctdiffprinter: (int -> string) -> Format.formatter -> oct -> oct -> unit
+
+
+(* utilities *)
+external memprint: unit -> unit = "ocaml_oct_memprint"
+external timeprint: unit -> unit = "ocaml_oct_timeprint"
+
--- /dev/null
+/* oct_config.h. Generated by configure. */
+/* Define if you have the ANSI C header files. */
+#define STDC_HEADERS 1
+
+/* Define if your processor stores words with the most significant
+ byte first (like Motorola and SPARC, unlike Intel and VAX). */
+/* #undef WORDS_BIGENDIAN */
+
+/* Define if you have the <dlfcn.h> header file. */
+#define HAVE_DLFCN_H 1
+
+/* Define if you have the m library (-lm). */
+#define HAVE_LIBM 1
+
+typedef unsigned int var_t;
+static const var_t max_index = 1<<(sizeof(int)*8-2);
--- /dev/null
+#ifndef OCT_CONFIG_H__
+#define OCT_CONFIG_H__
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* oct_config.h. Generated by configure. */
+/* Define if you have the ANSI C header files. */
+#define STDC_HEADERS 1
+
+/* Define if your processor stores words with the most significant
+ byte first (like Motorola and SPARC, unlike Intel and VAX). */
+/* #undef WORDS_BIGENDIAN */
+
+/* Define if you have the <dlfcn.h> header file. */
+#define HAVE_DLFCN_H 1
+
+/* Define if you have the m library (-lm). */
+#define HAVE_LIBM 1
+
+typedef unsigned int var_t;
+static const var_t max_index = 1<<(sizeof(int)*8-2);
+
+#ifndef __cplusplus
+#undef OCT_HAS_BOOL
+#else
+#define OCT_HAS_BOOL
+#endif
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* OCT_CONFIG_H__ */
--- /dev/null
+/* oct_num.h
+ Defines all underlying numerical domains as macros / inline functions.
+ This is automatically included by oct.h.
+
+ This file is part of the Octagon Abstract Domain Library.
+ Please read the COPYING file packaged in the distribution.
+ Main web page is: http://www.di.ens.fr/~mine/oct/
+
+ Copyright (C) Antoine Mine' 2000-2002
+ */
+
+#ifndef OCT_NUM_H__
+#define OCT_NUM_H__
+
+#include <stdio.h>
+#include <string.h>
+#include <math.h>
+#include <oct_config_2.h>
+
+#ifdef OCT_HAS_GMP
+#include <gmp.h>
+#endif
+
+#ifdef OCT_HAS_MPFR
+#include <mpfr.h>
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* zra */
+#define OCT_NUM_INT 1
+
+/* here, exactely one of the following must be defined */
+/* OCT_NUM_INT un-saturated integers (int) */
+/* OCT_NUM_FLOAT floats (double) */
+/* OCT_NUM_LONGDOUBLE floats (long double) */
+/* OCT_NUM_FRAC rationals */
+/* OCT_NUM_GMP_INT GMP integers */
+/* OCT_NUM_GMP_FRAC GMP fractions */
+/* OCT_NUM_MPFR_FLOAT MPFR floats */
+
+
+/* All numerical types suppose perfect numbers: no treatement of modulo
+ arithmetic or overflow-as-error is done.
+
+ Numerical types are *sound approximations* of perfect numbers:
+ a number that cannont be exactely represented is approximated by a
+ number this is greater, a number that cannot be overapproximated by
+ a finite number is approximated by +oo.
+
+ Tests are either correct (integer, fractionnals) or semi-correct (floats).
+ In the later case, true means "really true" and "false" means "maybee
+ not true". If this is the case, operators on octagons are also
+ semi-correct.
+*/
+
+
+/* WARNING
+
+ the GMP / MPFR types has not been tested much
+ especially, conversion functions may not be correct!
+
+*/
+
+typedef enum {
+ OCT_DOMAIN_INT = 0, /* numbers represent integers */
+ OCT_DOMAIN_FRAC = 1, /* numbers represent rationals */
+ OCT_DOMAIN_REAL = 2 /* numbers rerpesent reals */
+} num_domain_t;
+
+static const char* oct_domain_string[] = {"integers","rationals","reals"};
+
+
+/* generic functions */
+
+#ifdef WORDS_BIGENDIAN
+
+static inline void swap_word(void* dst, const void* src, size_t t)
+{
+ unsigned char *s = (unsigned char*)src+t-1, *d = (unsigned char*) dst;
+ size_t i;
+ for (i=0;i<t;i++,s--,d++) *d = *s;
+}
+
+#else
+
+static inline void swap_word(void* dst, const void* src, size_t t)
+{
+ memcpy(dst,src,t);
+}
+
+#endif
+
+static inline void dump16(unsigned char * c, unsigned i)
+{
+ c[0] = (i>>8)&0xff;
+ c[1] = i&0xff;
+}
+
+static inline unsigned undump16(const unsigned char * c)
+{
+ return (unsigned)c[1]+(((unsigned)c[0])<<8);
+}
+
+static inline void dump32(unsigned char * c, unsigned long i)
+{
+ c[0] = (i>>24)&0xff;
+ c[1] = (i>>16)&0xff;
+ c[2] = (i>>8)&0xff;
+ c[3] = i&0xff;
+}
+
+static inline unsigned long undump32(const unsigned char * c)
+{
+ return (unsigned long)c[3]+(((unsigned long)c[2])<<8)+
+ (((unsigned long)c[1])<<16)+(((unsigned long)c[0])<<24);
+}
+
+
+
+/********************/
+/* Machine-integers */
+/********************/
+
+/* unsafe in case of an overflow */
+
+#ifdef OCT_NUM_INT
+
+#ifdef OCT_NUM
+#error "only one OCT_NUM_ must be defined in oct_num.h"
+#endif
+#define OCT_NUM
+
+#define OCT_DOMAIN OCT_DOMAIN_INT
+#define OCT_IMPLEMENTATION_STRING "long"
+
+typedef long num_t;
+
+static const num_t num__infty = (unsigned)(1<<(sizeof(num_t)*8-1))-1;
+
+/* constructors */
+
+#define num_init(a)
+#define num_init_n(a,n)
+#define num_init_set(a,b) num_set((a),(b))
+#define num_init_set_n(a,b,n) num_set_n((a),(b),(n))
+#define num_init_set_int(a,b) num_set_int((a),(b))
+#define num_init_set_float(a,b) num_set_float((a),(b))
+#define num_init_set_frac(a,b,c) num_set_frac((a),(b),(c))
+#define num_init_set_infty(a) num_set_infty((a))
+
+/* copy / update */
+
+#define num_set(a,b) *(a) = *(b)
+#define num_set_n(a,b,n) memcpy((a),(b),sizeof(num_t)*(n));
+
+static inline void num_set_int(num_t* a, long i)
+{ *a = (i<-num__infty || i>num__infty) ? num__infty : i; }
+
+static inline void num_set_float(num_t* a, double k)
+{ k = ceil(k); *a = (k<-num__infty || k>num__infty) ? num__infty : (num_t)k; }
+
+#define num_set_frac(a,i,j) num_set_float((a),((double)(i))/((double)(j)))
+#define num_set_infty(a) *(a) = num__infty
+
+/* destructors */
+
+#define num_clear(a)
+#define num_clear_n(a,n)
+
+/* conversions */
+
+#define num_fits_int(a) (*(a) != num__infty)
+#define num_fits_float(a) (*(a) != num__infty)
+#define num_fits_frac(a) (*(a) != num__infty)
+
+#define num_get_int(a) ((long)*(a))
+#define num_get_float(a) ((double)*(a))
+#define num_get_num(a) ((long)*(a))
+#define num_get_den(a) (1L)
+
+/* tests */
+
+#define num_infty(a) (*(a)==num__infty)
+
+static inline int num_cmp(const num_t* a, const num_t *b)
+{ return (*a==*b)?0:(*a>*b)?1:-1; }
+
+static inline int num_cmp_int(const num_t* a, long b)
+{ return (*a==b)?0:((*a>b)?1:-1); }
+
+static inline int num_cmp_zero(const num_t* a)
+{ return (*a==0)?0:((*a>0)?1:-1); }
+
+static inline void num_max(num_t* r, const num_t* a, const num_t* b)
+{ *r = (*a>=*b) ? *a : *b; }
+
+static inline void num_min(num_t* r, const num_t* a, const num_t* b)
+{ *r = (*a<=*b) ? *a : *b; }
+
+static inline void num_add(num_t* r, const num_t* a, const num_t* b)
+{ *r = (*a==num__infty || *b==num__infty) ? num__infty : *a + *b; }
+
+static inline void num_sub(num_t* r, const num_t* a, const num_t* b)
+{ *r = (*a==num__infty || *b==num__infty) ? num__infty : *a - *b; }
+
+static inline void num_mul(num_t* r, const num_t* a, const num_t* b)
+{ *r = (*a==num__infty || *b==num__infty) ? num__infty : *a * *b; }
+
+static inline void num_mul_by_2(num_t* r, const num_t* a)
+{ *r = (*a==num__infty) ? num__infty : *a * 2; }
+
+static inline void num_div_by_2(num_t* r, const num_t* a)
+{ *r = (*a==num__infty) ? num__infty : (*a>=0) ? (*a+1)/2 : *a/2; }
+
+static inline void num_neg(num_t* r, const num_t* a)
+{ *r = (*a==num__infty) ? num__infty : -(*a); }
+
+/* printing */
+
+static inline void num_print(const num_t* a)
+{ if (*a!=num__infty) printf("%li",(long)*a); else printf("+oo"); }
+
+static inline void num_snprint(char* s, size_t n, const num_t* a)
+{ if (*a!=num__infty) snprintf(s,n,"%li",(long)*a); else snprintf(s,n,"+oo"); }
+
+/* GMP conversion */
+
+#ifdef OCT_HAS_GMP
+
+static inline void num_set_mpz(num_t* a, const mpz_t b)
+{
+ if (mpz_fits_slong_p(b)) num_set_int(a,mpz_get_si(b));
+ else num_set_infty(a);
+}
+
+#define num_get_mpz(a,b) mpz_set_si((a),*(b))
+
+#define num_set_mpq(a,b) num_set_float((a),ceil(mpq_get_d((b)))) /* is it sound ? */
+
+#define num_get_mpq(a,b) mpq_set_si((a),*(b),1)
+
+#endif
+
+#ifdef OCT_HAS_MPFR
+
+static inline void num_set_mpfr(num_t* a, const mpfr_t b)
+{
+ mpfr_t m;
+ mpfr_init(m);
+ mpfr_ceil(m,b);
+ num_set_float(a,mpfr_get_d(m
+#if (__GNU_MP_VERSION >= 4) && (__GNU_MP_VERSION_MINOR >= 1)
+ , GMP_RNDU
+#endif
+ ));
+ mpfr_clear(m);
+}
+
+#define num_get_mpfr(a,b) mpfr_set_si((a),*(b),GMP_RNDU)
+
+#endif
+
+
+#undef OCT_NUM_CLOSED
+#undef OCT_NUM_EXACT
+
+/* serialization */
+
+#define OCT_NUM_SERIALIZE
+
+static const int num_serialize_id = 0x1000+sizeof(num_t);
+
+static inline size_t num_serialize(const num_t* a, void* c)
+{ swap_word(c,a,sizeof(num_t)); return sizeof(num_t); }
+
+static inline size_t num_deserialize(num_t* a, const void* c)
+{ swap_word(a,c,sizeof(num_t)); return sizeof(num_t); }
+
+static inline size_t num_serialize_size(num_t* a)
+{ return sizeof(num_t); }
+
+
+#endif
+
+
+
+/******************/
+/* Machine-floats */
+/******************/
+
+
+/* define OCT_DEBUG_NAN if you want to check that there is no NaN in the
+ library
+*/
+
+#if defined(OCT_NUM_FLOAT) || defined(OCT_NUM_LONGDOUBLE)
+
+#ifdef OCT_NUM
+#error "only one OCT_NUM_ must be defined in oct_num.h"
+#endif
+#define OCT_NUM
+
+#define OCT_DOMAIN OCT_DOMAIN_REAL
+
+#ifdef OCT_NUM_LONGDOUBLE
+#define OCT_IMPLEMENTATION_STRING "long double"
+typedef long double num_t;
+#else
+#define OCT_IMPLEMENTATION_STRING "double"
+typedef double num_t;
+#endif
+
+#ifdef __INTEL_COMPILER
+#define num__infty (1.0/0.0)
+#else
+static const num_t num__infty = ((num_t)1.0)/((num_t)0.0);
+#endif
+static const num_t max_long = (num_t) (((unsigned long)(-1))>>1);
+
+/* constructors */
+
+#define num_init(a)
+#define num_init_n(a,n)
+#define num_init_set(a,b) num_set((a),(b))
+#define num_init_set_n(a,b,n) num_set_n((a),(b),(n))
+#define num_init_set_int(a,b) num_set_int((a),(b))
+#define num_init_set_float(a,b) num_set_float((a),(b))
+#define num_init_set_frac(a,b,c) num_set_frac((a),(b),(c))
+#define num_init_set_infty(a) num_set_infty((a))
+
+/* copy / update */
+
+#define num_set(a,b) *(a) = *(b)
+#define num_set_n(a,b,n) memcpy((a),(b),sizeof(num_t)*(n));
+
+#define num_set_int(a,i) *(a) = (num_t)(i)
+
+#ifdef OCT_DEBUG_NAN
+#define num_set_float(a,k) do{ *(a) = (num_t)(k); OCT_ASSERT(!isnan(*(a)),"NaN in num_set_float"); }while(0)
+#else
+#define num_set_float(a,k) *(a) = (num_t)(k)
+#endif
+
+#define num_set_frac(a,i,j) *(a) = ((num_t)(i))/((num_t)(j))
+#define num_set_infty(a) *(a) = num__infty
+
+/* destructors */
+
+#define num_clear(a)
+#define num_clear_n(a,n)
+
+/* conversions */
+
+static inline bool num_fits_int(const num_t* a)
+{
+ num_t d = ceil(*a);
+ return d!=num__infty && d<=max_long && d>=-max_long;
+}
+
+#define num_fits_float(a) (*(a) != num__infty)
+
+#define num_fits_frac(a) num_fits_int((a))
+
+#define num_get_int(a) ((long)*(a))
+#define num_get_float(a) ((double)*(a))
+#define num_get_num(a) ((long)ceil(*(a)))
+#define num_get_den(a) (1L)
+
+/* tests */
+
+#define num_infty(a) (*(a)==num__infty)
+
+static inline int num_cmp(const num_t* a, const num_t *b)
+{ return (*a==*b) ? 0 : (*a>*b) ? 1 : -1; }
+
+static inline int num_cmp_int(const num_t* a, long b)
+{ num_t bb = (num_t)b; return (*a==bb) ? 0 : (*a>bb) ? 1 : -1; }
+
+static inline int num_cmp_zero(const num_t* a)
+{ return (*a==0.)?0:((*a>0.)?1:-1); }
+
+/* operations */
+
+#ifdef OLD_MIN_MAX
+static inline void num_max(num_t* r, const num_t* a, const num_t* b)
+{ *r = (*a>=*b) ? *a : *b; }
+
+static inline void num_min(num_t* r, const num_t* a, const num_t* b)
+{ *r = (*a<=*b) ? *a : *b; }
+
+#else
+ /* DM: this version compiles to minsd/maxsd on SSE
+ (the other version is not equivalent in general because of NaNs ) */
+static inline void num_max(num_t* r, const num_t* a, const num_t* b)
+{ *r = (*a > *b) ? *a : *b; }
+
+static inline void num_min(num_t* r, const num_t* a, const num_t* b)
+{ *r = (*a < *b) ? *a : *b; }
+#endif
+
+#ifdef OCT_DEBUG_NAN
+#define num_add(r,a,b) do{ *(r) = *(a) + *(b); OCT_ASSERT(!isnan(*(r)),"NaN in num_add"); }while(0)
+#define num_sub(r,a,b) do{ *(r) = *(a) - *(b); OCT_ASSERT(!isnan(*(r)),"NaN in num_sub"); }while(0)
+#define num_mul(r,a,b) do{ *(r) = *(a) * *(b); OCT_ASSERT(!isnan(*(r)),"NaN in num_mul"); }while(0)
+#define num_mul_by_2(r,a) do{ *(r) = *(a) * 2.; OCT_ASSERT(!isnan(*(r)),"NaN in num_mul_by_2"); }while(0)
+#define num_div_by_2(r,a) do{ *(r) = *(a) / 2.; OCT_ASSERT(!isnan(*(r)),"NaN in num_div_by_2"); }while(0)
+#define num_neg(r,a) do{ *(r) = - *(a); OCT_ASSERT(!isnan(*(r)),"NaN in num_neg"); }while(0)
+#else
+#define num_add(r,a,b) *(r) = *(a) + *(b)
+#define num_sub(r,a,b) *(r) = *(a) - *(b)
+#define num_mul(r,a,b) *(r) = *(a) * *(b)
+#define num_mul_by_2(r,a) *(r) = *(a) * 2.
+#define num_div_by_2(r,a) *(r) = *(a) / 2.
+#define num_neg(r,a) *(r) = - *(a)
+#endif
+
+/* printing */
+
+#ifdef OCT_NUM_LONGDOUBLE
+
+static inline void num_print(const num_t* a)
+{ if (*a!=num__infty) printf("%.20Lg",(long double)*a+0.);
+ else printf("+oo"); }
+
+static inline void num_snprint(char* s, size_t n, const num_t* a)
+{ if (*a!=num__infty) snprintf(s,n,"%.20Lg",(long double)*a+0.);
+ else snprintf(s,n,"+oo");}
+
+#else
+
+static inline void num_print(const num_t* a)
+{ if (*a!=num__infty) printf("%.20g",(double)*a+0.);
+ else printf("+oo"); }
+
+static inline void num_snprint(char* s, size_t n, const num_t* a)
+{ if (*a!=num__infty) snprintf(s,n,"%.20g",(double)*a+0.);
+ else snprintf(s,n,"+oo");}
+
+
+#endif
+
+
+/* GMP conversion */
+
+#ifdef OCT_HAS_GMP
+
+#define num_set_mpz(a,b) *(a)=mpz_get_d((b)) /* is this sound ? */
+#define num_get_mpz(a,b) mpz_set_d((a),ceil(*(b)))
+#define num_set_mpq(a,b) *(a)=mpq_get_d((b)) /* is this sound ? */
+#define num_get_mpq(a,b) mpq_set_d((a),*(b))
+
+#endif
+
+#ifdef OCT_HAS_MPFR
+
+#if (__GNU_MP_VERSION >= 4) && (__GNU_MP_VERSION_MINOR >= 1)
+#define num_set_mpfr(a,b) *(a)=mpfr_get_d((b), GMP_RNDU)
+#else
+#define num_set_mpfr(a,b) *(a)=mpfr_get_d((b))
+#endif
+
+#define num_get_mpfr(a,b) mpfr_set_d((a),*(b),GMP_RNDU)
+
+#endif
+
+
+#define OCT_NUM_CLOSED
+#undef OCT_NUM_EXACT
+
+
+/* serialization */
+
+#define OCT_NUM_SERIALIZE
+
+static const int num_serialize_id = 0x1100+sizeof(num_t);
+
+static inline size_t num_serialize(const num_t* a, void* c)
+{ swap_word(c,a,sizeof(num_t)); return sizeof(num_t); }
+
+static inline size_t num_deserialize(num_t* a, const void* c)
+{ swap_word(a,c,sizeof(num_t)); return sizeof(num_t); }
+
+static inline size_t num_serialize_size(num_t* a)
+{ return sizeof(num_t); }
+
+#endif
+
+
+/********************************/
+/* Rationals using machine-ints */
+/********************************/
+
+#ifdef OCT_NUM_FRAC
+
+#ifdef OCT_NUM
+#error "only one OCT_NUM_ must be defined in oct_num.h"
+#endif
+#define OCT_NUM
+
+#define OCT_DOMAIN OCT_DOMAIN_FRAC
+#define OCT_IMPLEMENTATION_STRING "long"
+
+typedef long coef_t;
+
+/* all rationals are kept in irreductible form */
+typedef struct {
+ coef_t n; /* numerator */
+ coef_t d; /* denominator, >=0 */
+} num_t;
+
+static const num_t num__infty = { 1,0 };
+
+static const coef_t coef_overflow = ((coef_t)1<<(sizeof(coef_t)*4-1))-1;
+
+static
+inline
+void
+num_normalize (num_t* r)
+{
+ if (r->d) {
+ /* euclide */
+ coef_t pgcd, b;
+ pgcd = (r->n<0) ? -r->n : r->n;
+ b = r->d;
+ while (b) {
+ coef_t r = pgcd%b;
+ pgcd = b;
+ b = r;
+ }
+ r->n /= pgcd;
+ r->d /= pgcd;
+ if (r->n<=-coef_overflow || r->n>=coef_overflow || r->d>=coef_overflow)
+ r->d = 0;
+ }
+}
+
+/* constructors */
+
+#define num_init(a)
+#define num_init_n(a,n)
+#define num_init_set(a,b) num_set((a),(b))
+#define num_init_set_n(a,b,n) num_set_n((a),(b),(n))
+#define num_init_set_int(a,b) num_set_int((a),(b))
+#define num_init_set_float(a,b) num_set_float((a),(b))
+#define num_init_set_frac(a,b,c) num_set_frac((a),(b),(c))
+#define num_init_set_infty(a) num_set_infty((a))
+
+/* copy / update */
+
+#define num_set(a,b) *(a) = *(b)
+#define num_set_n(a,b,n) memcpy((a),(b),sizeof(num_t)*(n));
+
+static inline void num_set_int(num_t* a, long i)
+{ a->n = (coef_t)i; a->d = 1; num_normalize(a); }
+
+static inline void num_set_float(num_t* a, double k)
+{
+ k = ceil(k);
+ if (k<(double)-coef_overflow || k>(double)coef_overflow) *a = num__infty;
+ else { a->n = (coef_t)k; a->d = 1; num_normalize(a); }
+}
+
+static inline void num_set_frac(num_t* a, long i, long j)
+{
+ if (j>=0) { a->n=(coef_t)i; a->d=(coef_t)j; }
+ else { a->n=(coef_t)-i; a->d=(coef_t)-j; }
+ num_normalize(a);
+}
+
+#define num_set_infty(a) *(a) = num__infty
+
+/* destructors */
+
+#define num_clear(a)
+#define num_clear_n(a,n)
+
+/* conversions */
+
+#define num_fits_int(a) ((a)->d!=0)
+#define num_fits_float(a) ((a)->d!=0)
+#define num_fits_frac(a) ((a)->d!=0)
+
+#define num_get_int(a) ((long)ceil(((double)((a)->n))/((double)((a)->d))))
+#define num_get_float(a) (((double)((a)->n))/((double)((a)->d)))
+#define num_get_num(a) ((long)(a)->n)
+#define num_get_den(a) ((long)(a)->d)
+
+/* tests */
+
+#define num_infty(a) ((a)->d==0)
+
+static inline int num_cmp(const num_t* a, const num_t* b)
+{
+ if (!a->d) {
+ if (!b->d) return 0;
+ else return 1;
+ }
+ if (!b->d) return -1;
+ else {
+ const coef_t aa = a->n*b->d;
+ const coef_t bb = a->d*b->n;
+ if (aa==bb) return 0;
+ if (aa>bb) return 1;
+ return -1;
+ }
+}
+
+static inline int num_cmp_int(const num_t* a, long b)
+{
+ if (!a->d) return 1;
+ else if (b<=-coef_overflow) return 1;
+ else if (b>= coef_overflow) return -1;
+ else {
+ const coef_t aa = a->n;
+ const coef_t bb = a->d*b;
+ if (aa==bb) return 0;
+ if (aa>bb) return 1;
+ return -1;
+ }
+}
+
+static inline int num_cmp_zero(const num_t* a)
+{ return (!a->d) ? 1 : ((a->n==0) ? 0 : ((a->n>0) ? 1 : -1)); }
+
+/* operations */
+
+static inline void num_max(num_t* r, const num_t* a, const num_t* b)
+{ *r = (!a->d || !b->d) ? num__infty : (a->n*b->d>=b->n*a->d) ? *a : *b; }
+
+static inline void num_min(num_t* r, const num_t* a, const num_t* b)
+{ *r = (!a->d) ? *b : (!b->d) ? *a : (a->n*b->d<=b->n*a->d) ? *a : *b; }
+
+static inline void num_add(num_t* r, const num_t* a, const num_t* b)
+{ coef_t d=a->d*b->d; r->n=a->n*b->d+a->d*b->n; r->d=d; num_normalize(r); }
+
+static inline void num_sub(num_t* r, const num_t* a, const num_t* b)
+{ coef_t d=a->d*b->d; r->n=a->n*b->d-a->d*b->n; r->d=d; num_normalize(r); }
+
+static inline void num_mul(num_t* r, const num_t* a, const num_t* b)
+{ r->n = a->n*b->n; r->d = a->d*b->d; num_normalize(r); }
+
+static inline void num_mul_by_2(num_t* r, const num_t* a)
+{
+ *r = *a;
+ if (r->d & 1) {
+ r->n *= 2;
+ if (r->n<=-coef_overflow || r->n>=coef_overflow) r->d = 0;
+ }
+ else r->d /= 2;
+}
+
+static inline void num_div_by_2(num_t* r, const num_t* a)
+{
+ *r = *a;
+ if (r->n & 1) { r->d *= 2; if (r->d>=coef_overflow) r->d = 0; }
+ else r->n /= 2;
+}
+
+static inline void num_neg(num_t* r, const num_t* a)
+{ r->n = -a->n; r->d = a->d; }
+
+/* printing */
+
+static
+inline
+void
+num_print(const num_t* a)
+{
+ if (a->d)
+ if (!a->n) printf("0");
+ else if (a->d==1) printf("%li",(long)a->n);
+ else printf("%li/%li",(long)a->n,(long)a->d);
+ else printf("+oo");
+}
+
+static
+inline
+void
+num_snprint(char* s, size_t n, const num_t* a)
+{
+ if (a->d)
+ if (!a->n) snprintf(s,n,"0");
+ else if (a->d==1) snprintf(s,n,"%li",(long)a->n);
+ else snprintf(s,n,"%li/%li",(long)a->n,(long)a->d);
+ else snprintf(s,n,"+oo");
+}
+
+/* GMP conversion */
+
+#ifdef OCT_HAS_GMP
+
+static inline void num_set_mpz(num_t* a, const mpz_t b)
+{
+ if (mpz_fits_slong_p(b)) num_set_int(a,mpz_get_si(b));
+ else num_set_infty(a);
+}
+
+#define num_get_mpz(a,b) mpz_set_si((a),num_get_int((b)))
+
+static inline void num_set_mpq(num_t* a, const mpq_t b)
+{
+ if (mpz_fits_slong_p(mpq_numref(b)) &&
+ mpz_fits_slong_p(mpq_denref(b)))
+ num_set_frac(a,mpz_get_si(mpq_numref(b)),mpz_get_si(mpq_denref(b)));
+ else num_set_infty(a);
+}
+
+#define num_get_mpq(a,b) mpq_set_si((a),(b)->n,(b)->d)
+
+#endif
+
+#ifdef OCT_HAS_MPFR
+
+static inline void num_set_mpfr(num_t* a, const mpfr_t b)
+{
+ mpfr_t m;
+ mpfr_init(m);
+ mpfr_ceil(m,b);
+ num_set_float(a,mpfr_get_d(m
+#if (__GNU_MP_VERSION >= 4) && (__GNU_MP_VERSION_MINOR >= 1)
+ , GMP_RNDU
+#endif
+ ));
+ mpfr_clear(m);
+}
+
+static inline void num_get_mpfr(mpfr_t a, const num_t* b)
+{ mpfr_set_si(a,b->n,GMP_RNDU); mpfr_div_ui(a,a,b->d,GMP_RNDU); }
+
+#endif
+
+#define OCT_NUM_CLOSED
+#define OCT_NUM_EXACT
+
+/* serialization */
+
+#define OCT_NUM_SERIALIZE
+
+static const int num_serialize_id = 0x1200+sizeof(coef_t);
+
+static inline size_t num_serialize(const num_t* a, void* c)
+{
+ swap_word(c,&a->n,sizeof(coef_t));
+ swap_word((char*)c+sizeof(coef_t),&a->d,sizeof(coef_t));
+ return 2*sizeof(coef_t);
+}
+
+static inline size_t num_deserialize(num_t* a, const void* c)
+{
+ swap_word(&a->n,c,sizeof(coef_t));
+ swap_word(&a->d,(char*)c+sizeof(coef_t),sizeof(coef_t));
+ return 2*sizeof(coef_t);
+}
+
+static inline size_t num_serialize_size(num_t* a)
+{ return 2*sizeof(coef_t); }
+
+
+#endif
+
+
+/****************/
+/* GMP Integers */
+/****************/
+
+#ifdef OCT_NUM_GMP_INT
+
+#ifndef OCT_HAS_GMP
+#error "the gmpint numerical type requires the GMP library"
+#endif
+
+#ifdef OCT_NUM
+#error "only one OCT_NUM_ must be defined in oct_num.h"
+#endif
+#define OCT_NUM
+
+#define OCT_DOMAIN OCT_DOMAIN_INT
+#define OCT_IMPLEMENTATION_STRING "GMP mpz"
+
+
+typedef struct {
+ mpz_t num; /* always allocated, even if inf=1 */
+ char inf; /* 1 => +oo; 0 => <+oo */
+} num_t;
+
+static const double double_infty = ((double)1.0)/((double)0.0);
+static const double double_minfty = -((double)1.0)/((double)0.0);
+
+/* constructors */
+
+#define num_init(a) mpz_init((a)->num)
+
+
+static inline void num_init_n(num_t* a, size_t n)
+{ size_t i; for (i=0;i<n;i++,a++) num_init(a); }
+
+static inline void num_init_set(num_t* a, const num_t* b)
+{ a->inf=b->inf; if (a->inf) mpz_init(a->num); else mpz_init_set(a->num,b->num); }
+
+static inline void num_init_set_n(num_t* a, const num_t* b, size_t n)
+{ size_t i; for (i=0;i<n;i++,a++,b++) num_init_set(a,b); }
+
+static inline void num_init_set_int(num_t* a, long i)
+{ a->inf=0; mpz_init_set_si(a->num,i); }
+
+static inline void num_init_set_float(num_t* a, double d)
+{ a->inf=0; mpz_init_set_d(a->num,ceil(d)); }
+
+#define num_init_set_frac(a,i,j) num_init_set_float((a),((double)(i))/((double)(j)))
+
+static inline void num_init_set_infty(num_t* a) { a->inf=1; mpz_init(a->num); }
+
+/* copy / update */
+
+static inline void num_set(num_t* a, const num_t* b)
+{ a->inf=b->inf; if (!a->inf) mpz_set(a->num,b->num); }
+
+static inline void num_set_n(num_t* a, const num_t* b, size_t n)
+{ size_t i; for (i=0;i<n;i++,a++,b++) num_set(a,b); }
+
+static inline void num_set_int(num_t* a, long i)
+{ a->inf=0; mpz_set_si(a->num,i); }
+
+static inline void num_set_float(num_t* a, double d)
+{ a->inf=0; mpz_set_d(a->num,ceil(d)); }
+
+#define num_set_frac(a,i,j) num_set_float((a),((double)(i))/((double)(j)))
+
+#define num_set_infty(a) (a)->inf=1
+
+/* destructors */
+
+#define num_clear(a) mpz_clear((a)->num)
+
+static inline void num_clear_n(num_t* a, size_t n)
+{ size_t i; for (i=0;i<n;i++,a++) num_clear(a); }
+
+/* conversions */
+
+static inline bool num_fits_int(const num_t* a)
+{ return !a->inf && mpz_fits_slong_p(a->num); }
+
+static inline bool num_fits_float(const num_t* a)
+{
+ double d = mpz_get_d(a->num);
+ return !a->inf && d!=double_infty && d!=double_minfty;
+}
+
+#define num_fits_frac(a) num_fits_int(a)
+
+#define num_get_int(a) mpz_get_si((a)->num)
+#define num_get_float(a) mpz_get_d((a)->num)
+#define num_get_num(a) mpz_get_si((a)->num)
+#define num_get_den(a) (1L)
+
+
+/* GMP conversion */
+
+#define num_get_mpz(a,b) mpz_set((a),(b)->num)
+#define num_get_mpq(a,b) mpq_set_z((a),(b)->num)
+
+static inline void num_set_mpz(num_t *a, const mpz_t b)
+{ mpz_set(a->num,b); a->inf=0; }
+
+static inline void num_set_mpq(num_t *a, const mpq_t b)
+{ mpz_cdiv_q(a->num, mpq_numref(b), mpq_denref(b)); }
+
+
+#ifdef OCT_HAS_MPFR
+
+#define num_get_mpfr(a,b) mpfr_set_z((a),(b)->num,GMP_RNDU)
+
+static inline void num_set_mpfr(num_t *a, const mpfr_t b)
+{
+ mpfr_t m;
+ mpfr_init(m);
+ mpfr_ceil(m,b);
+ num_set_float(a,mpfr_get_d(m
+#if (__GNU_MP_VERSION >= 4) && (__GNU_MP_VERSION_MINOR >= 1)
+ , GMP_RNDU
+#endif
+ ));
+ mpfr_clear(m);
+}
+
+#endif
+
+/* tests */
+
+#define num_infty(a) ((a)->inf!=0)
+
+static inline int num_cmp(const num_t* a, const num_t* b)
+{
+ if (a->inf) {
+ if (b->inf) return 0;
+ else return 1;
+ }
+ if (b->inf) return -1;
+ return mpz_cmp(a->num,b->num);
+}
+
+static inline int num_cmp_int(const num_t* a, long i)
+{ if (a->inf) return 1; return mpz_cmp_si(a->num,i); }
+
+static inline int num_cmp_zero(const num_t* a)
+{ return num_cmp_int(a,0); }
+
+/* operations */
+
+static inline void num_max(num_t* r, const num_t* a, const num_t* b)
+{
+ if (a->inf || b->inf) r->inf=1;
+ else { r->inf=0; mpz_set(r->num,mpz_cmp(a->num,b->num)>0?a->num:b->num); }
+}
+
+static inline void num_min(num_t* r, const num_t* a, const num_t* b)
+{
+ if (a->inf)
+ if (b->inf) r->inf=1;
+ else { r->inf=0; mpz_set(r->num,b->num); }
+ else if (b->inf) { r->inf=0; mpz_set(r->num,a->num); }
+ else { r->inf=0; mpz_set(r->num,mpz_cmp(a->num,b->num)<0?a->num:b->num); }
+}
+
+static inline void num_add(num_t* r, const num_t* a, const num_t* b)
+{
+ if (a->inf || b->inf) r->inf=1;
+ else { r->inf=0; mpz_add(r->num,a->num,b->num); }
+}
+
+static inline void num_sub(num_t* r, const num_t* a, const num_t* b)
+{
+ if (a->inf || b->inf) r->inf=1;
+ else { r->inf=0; mpz_sub(r->num,a->num,b->num); }
+}
+
+static inline void num_mul(num_t* r, const num_t* a, const num_t* b)
+{
+ if (a->inf || b->inf) r->inf=1;
+ else { r->inf=0; mpz_mul(r->num,a->num,b->num); }
+}
+
+static inline void num_mul_by_2(num_t* r, const num_t* a)
+{
+ if (a->inf) r->inf=1;
+ else { r->inf=0; mpz_mul_2exp(r->num,a->num,1); }
+}
+
+static inline void num_div_by_2(num_t* r, const num_t* a)
+{
+ if (a->inf) r->inf=1;
+ else { r->inf=0; mpz_cdiv_q_2exp(r->num,a->num,1); }
+}
+
+static inline void num_neg(num_t* r, const num_t* a)
+{
+ if (a->inf) r->inf=1;
+ else { r->inf=0; mpz_neg(r->num,a->num); }
+}
+
+/* printing */
+
+static inline void num_print(const num_t* a)
+{
+ if (a->inf) printf("+oo");
+ else mpz_out_str(stdout,10,a->num);
+}
+
+static inline void num_snprint(char* s, size_t n, const num_t* a)
+{
+ if (a->inf) snprintf(s,n,"+oo");
+ else if (mpz_sizeinbase(a->num,10)+2>n)
+ if (mpz_sgn(a->num)>0) snprintf(s,n,"+BIG");
+ else snprintf(s,n,"-BIG");
+ else mpz_get_str(s,10,a->num);
+}
+
+#undef OCT_NUM_CLOSED
+#undef OCT_NUM_EXACT
+
+
+/* serialization */
+
+#define OCT_NUM_SERIALIZE
+
+static const int num_serialize_id = 0x1300;
+
+static inline size_t num_serialize(const num_t* a, void* c)
+{
+ size_t count;
+ *((char*)c) = a->inf;
+ if (a->inf) return 1;
+ *((char*)c+1) = mpz_sgn(a->num);
+ mpz_export((char*)c+6,&count,1,1,1,0,a->num);
+ dump32((unsigned char*)c+2,count);
+ return count+6;
+}
+
+static inline size_t num_deserialize(num_t* a, const void* c)
+{
+ size_t count;
+ a->inf = *(char*)c;
+ if (a->inf) return 1;
+ count = undump32((unsigned char*)c+2);
+ mpz_import(a->num,count,1,1,1,0,(char*)c+6);
+ if (*((char*)c+1)<0) {
+ mpz_neg(a->num,a->num);
+ }
+ return count+6;
+}
+
+/* note: this does not give the exact size of serialized data, but a sound
+ overapproximation
+*/
+static inline size_t num_serialize_size(num_t* a)
+{
+ if (a->inf) return 1;
+ return mpz_sizeinbase(a->num,2)/8+6+sizeof(mp_limb_t);
+}
+
+
+#endif
+
+
+
+
+/*****************/
+/* GMP Rationals */
+/*****************/
+
+#ifdef OCT_NUM_GMP_FRAC
+
+#ifndef OCT_HAS_GMP
+#error "the gmpfrac numerical type requires the GMP library"
+#endif
+
+#ifdef OCT_NUM
+#error "only one OCT_NUM_ must be defined in oct_num.h"
+#endif
+#define OCT_NUM
+
+#define OCT_DOMAIN OCT_DOMAIN_FRAC
+#define OCT_IMPLEMENTATION_STRING "GMP mpq"
+
+typedef struct {
+ mpq_t num; /* always allocated, even if inf=1 */
+ char inf; /* 1 => +oo; 0 => <+oo */
+} num_t;
+
+static const double double_infty = ((double)1.0)/((double)0.0);
+static const double double_minfty = -((double)1.0)/((double)0.0);
+static const double max_long = (double) (((unsigned long)(-1))>>1);
+
+/* constructors */
+
+#define num_init(a) mpq_init((a)->num)
+
+static inline void num_init_n(num_t* a, size_t n)
+{ size_t i; for (i=0;i<n;i++,a++) num_init(a); }
+
+static inline void num_init_set(num_t* a, const num_t* b)
+{ a->inf=b->inf; mpq_init(a->num); if (!a->inf) mpq_set(a->num,b->num); }
+
+static inline void num_init_set_n(num_t* a, const num_t* b, size_t n)
+{ size_t i; for (i=0;i<n;i++,a++,b++) num_init_set(a,b); }
+
+static inline void num_init_set_int(num_t* a, long i)
+{ a->inf=0; mpq_init(a->num); mpq_set_si(a->num,i,1); }
+
+static inline void num_init_set_float(num_t* a, double d)
+{ a->inf=0; mpq_init(a->num); mpq_set_d(a->num,d); }
+
+static inline void num_init_set_frac(num_t* a, long i, long j)
+{
+ if (j<0) { i=-i; j=-j; }
+ a->inf=0; mpq_init(a->num); mpq_set_si(a->num,i,j);
+ mpq_canonicalize(a->num);
+}
+
+static inline void num_init_set_infty(num_t* a)
+{ a->inf=1; mpq_init(a->num); }
+
+/* copy / update */
+
+static inline void num_set(num_t* a, const num_t* b)
+{ a->inf=b->inf; if (!a->inf) mpq_set(a->num,b->num); }
+
+static inline void num_set_n(num_t* a, const num_t* b, size_t n)
+{ size_t i; for (i=0;i<n;i++,a++,b++) num_set(a,b); }
+
+static inline void num_set_int(num_t* a, long i)
+{ a->inf=0; mpq_set_si(a->num,i,1); }
+
+static inline void num_set_float(num_t* a, double d)
+{ a->inf=0; mpq_set_d(a->num,d); }
+
+static inline void num_set_frac(num_t* a, long i, long j)
+{
+ if (j<0) { i=-i; j=-j; }
+ a->inf=0; mpq_set_si(a->num,i,j);
+ mpq_canonicalize(a->num);
+}
+
+#define num_set_infty(a) (a)->inf=1
+
+/* destructors */
+
+#define num_clear(a) mpq_clear((a)->num)
+
+static inline void num_clear_n(num_t* a, size_t n)
+{ size_t i; for (i=0;i<n;i++,a++) num_clear(a); }
+
+/* conversions */
+
+static inline bool num_fits_int(const num_t* a)
+{
+ double d;
+ if (a->inf) return false;
+ d = ceil(mpq_get_d(a->num));
+ return d<=max_long && d>=-max_long;
+}
+
+static inline bool num_fits_float(const num_t* a)
+{
+ double d = mpq_get_d(a->num);
+ return !a->inf && d!=double_infty && d!=double_minfty;
+}
+
+static inline bool num_fits_frac(const num_t* a)
+{ return !a->inf && mpz_fits_slong_p(mpq_numref(a->num))
+ && mpz_fits_slong_p(mpq_denref(a->num)); }
+
+
+static inline long num_get_int(const num_t* a)
+{ return (long)ceil(mpq_get_d(a->num)); /* Bad... */ }
+
+#define num_get_float(a) mpq_get_d((a)->num)
+#define num_get_num(a) mpz_get_si(mpq_numref((a)->num))
+#define num_get_den(a) mpz_get_si(mpq_denref((a)->num))
+
+
+/* GMP conversion */
+
+#define num_get_mpq(a,b) mpq_set((a),(b)->num)
+
+static inline void num_set_mpq(num_t *a, const mpq_t b)
+{ mpq_set(a->num,b); a->inf=0; }
+
+static inline void num_set_mpz(num_t *a, const mpz_t b)
+{ mpq_set_z(a->num,b); a->inf=0; }
+
+static inline void num_get_mpz(mpz_t a, const num_t* b)
+{ mpz_cdiv_q(a, mpq_numref(b->num), mpq_denref(b->num)); }
+
+
+
+#ifdef OCT_HAS_MPFR
+
+#define num_get_mpfr(a,b) mpfr_set_q((a),(b)->num,GMP_RNDU)
+
+static inline void num_set_mpfr(num_t *a, const mpfr_t b)
+{
+ mpfr_t m;
+ mpfr_init(m);
+ mpfr_ceil(m,b);
+ num_set_float(a,mpfr_get_d(m
+#if (__GNU_MP_VERSION >= 4) && (__GNU_MP_VERSION_MINOR >= 1)
+ , GMP_RNDU
+#endif
+ ));
+ mpfr_clear(m);
+}
+
+
+#endif
+
+
+/* tests */
+
+#define num_infty(a) ((a)->inf!=0)
+
+static inline int num_cmp(const num_t* a, const num_t* b)
+{
+ if (a->inf) {
+ if (b->inf) return 0;
+ else return 1;
+ }
+ if (b->inf) return -1;
+ return mpq_cmp(a->num,b->num);
+}
+
+static inline int num_cmp_int(const num_t* a, long i)
+{ if (a->inf) return 1; return mpq_cmp_si(a->num,i,1); }
+
+static inline int num_cmp_zero(const num_t* a)
+{ return num_cmp_int(a,0); }
+
+/* operations */
+
+static inline void num_max(num_t* r, const num_t* a, const num_t* b)
+{
+ if (a->inf || b->inf) r->inf=1;
+ else { r->inf=0; mpq_set(r->num,mpq_cmp(a->num,b->num)>0?a->num:b->num); }
+}
+
+static inline void num_min(num_t* r, const num_t* a, const num_t* b)
+{
+ if (a->inf)
+ if (b->inf) r->inf=1;
+ else { r->inf=0; mpq_set(r->num,b->num); }
+ else if (b->inf) { r->inf=0; mpq_set(r->num,a->num); }
+ else { r->inf=0; mpq_set(r->num,mpq_cmp(a->num,b->num)<0?a->num:b->num); }
+}
+
+static inline void num_add(num_t* r, const num_t* a, const num_t* b)
+{
+ if (a->inf || b->inf) r->inf=1;
+ else { r->inf=0; mpq_add(r->num,a->num,b->num); }
+}
+
+static inline void num_sub(num_t* r, const num_t* a, const num_t* b)
+{
+ if (a->inf || b->inf) r->inf=1;
+ else { r->inf=0; mpq_sub(r->num,a->num,b->num); }
+}
+
+static inline void num_mul(num_t* r, const num_t* a, const num_t* b)
+{
+ if (a->inf || b->inf) r->inf=1;
+ else { r->inf=0; mpq_mul(r->num,a->num,b->num); }
+}
+
+static inline void num_mul_by_2(num_t* r, const num_t* a)
+{
+ if (a->inf) r->inf=1;
+ else { r->inf=0; mpq_mul_2exp(r->num,a->num,1); }
+}
+
+static inline void num_div_by_2(num_t* r, const num_t* a)
+{
+ if (a->inf) r->inf=1;
+ else { r->inf=0; mpq_div_2exp(r->num,a->num,1); }
+}
+
+static inline void num_neg(num_t* r, const num_t* a)
+{
+ if (a->inf) r->inf=1;
+ else { r->inf=0; mpq_neg(r->num,a->num); }
+}
+
+/* printing */
+
+static inline void num_print(const num_t* a)
+{
+ if (a->inf) printf("+oo");
+ else if (!mpz_cmp_si(mpq_denref(a->num),1))
+ mpz_out_str(stdout,10,mpq_numref(a->num));
+ else mpq_out_str(stdout,10,a->num);
+}
+
+static inline void num_snprint(char* s, size_t n, const num_t* a)
+{
+ if (a->inf) snprintf(s,n,"+oo");
+ else if (mpz_sizeinbase(mpq_numref(a->num),10)+
+ mpz_sizeinbase(mpq_denref(a->num),10)+3>n)
+ if (mpq_sgn(a->num)>0) snprintf(s,n,"+BIG");
+ else snprintf(s,n,"-BIG");
+ else
+ if (!mpz_cmp_si(mpq_denref(a->num),1))
+ mpz_get_str(s,10,mpq_numref(a->num));
+ else {
+ mpz_get_str(s,10,mpq_numref(a->num));
+ strcat(s,"/");
+ mpz_get_str(s+strlen(s),10,mpq_denref(a->num));
+ }
+}
+
+
+#define OCT_NUM_CLOSED
+#define OCT_NUM_EXACT
+
+
+/* serialization */
+
+#define OCT_NUM_SERIALIZE
+
+static const int num_serialize_id = 0x1400;
+
+static inline size_t num_serialize(const num_t* a, void* c)
+{
+ size_t count1,count2;
+ *((char*)c) = a->inf;
+ if (a->inf) return 1;
+ *((char*)c+1) = mpq_sgn(a->num);
+ mpz_export((char*)c+10,&count1,1,1,1,0,mpq_numref(a->num));
+ mpz_export((char*)c+10+count1,&count2,1,1,1,0,mpq_denref(a->num));
+ dump32((unsigned char*)c+2,count1);
+ dump32((unsigned char*)c+6,count2);
+ return count1+count2+10;
+}
+
+static inline size_t num_deserialize(num_t* a, const void* c)
+{
+ size_t count1,count2;
+ a->inf = *(char*)c;
+ if (a->inf) return 1;
+ count1 = undump32((unsigned char*)c+2);
+ count2 = undump32((unsigned char*)c+6);
+ mpz_import(mpq_numref(a->num),count1,1,1,1,0,(char*)c+10);
+ mpz_import(mpq_denref(a->num),count2,1,1,1,0,(char*)c+10+count1);
+ if (*((char*)c+1)<0) {
+ mpq_neg(a->num,a->num);
+ }
+ return count1+count2+10;
+}
+
+/* note: this does not give the exact size of serialized data, but a sound
+ overapproximation
+*/
+static inline size_t num_serialize_size(num_t* a)
+{
+ if (a->inf) return 1;
+ return
+ (mpz_sizeinbase(mpq_numref(a->num),2)+
+ mpz_sizeinbase(mpq_denref(a->num),2))/8+10+2*sizeof(mp_limb_t);
+}
+
+
+#endif
+
+
+
+/***************/
+/* MPFR Floats */
+/***************/
+
+#ifdef OCT_NUM_MPFR_FLOAT
+
+#ifndef OCT_HAS_GMP
+#error "the mpfrfloat numerical type requires the GMP library"
+#endif
+
+#ifndef OCT_HAS_MPFR
+#error "the mpfrfloat numerical type requires the MPFR library"
+#endif
+
+#ifdef OCT_NUM
+#error "only one OCT_NUM_ must be defined in oct_num.h"
+#endif
+#define OCT_NUM
+
+#define OCT_DOMAIN OCT_DOMAIN_REAL
+#define OCT_IMPLEMENTATION_STRING "GMP mpfr"
+
+typedef struct {
+ mpfr_t num;
+} num_t;
+
+static const double double_infty = ((double)1.0)/((double)0.0);
+static const double double_minfty = -((double)1.0)/((double)0.0);
+static const double max_long = (double) (((unsigned long)(-1))>>1);
+
+/* constructors */
+
+#define num_init(a) mpfr_init((a)->num)
+
+static inline void num_init_n(num_t* a, size_t n)
+{ size_t i; for (i=0;i<n;i++,a++) num_init(a); }
+
+#define num_init_set(a,b) mpfr_init_set((a)->num,(b)->num,GMP_RNDU)
+
+static inline void num_init_set_n(num_t* a, const num_t* b, size_t n)
+{ size_t i; for (i=0;i<n;i++,a++,b++) num_init_set(a,b); }
+
+#define num_init_set_int(a,i) mpfr_init_set_si((a)->num,(i),GMP_RNDU)
+#define num_init_set_float(a,d) mpfr_init_set_d ((a)->num,(d),GMP_RNDU)
+
+static inline void num_init_set_frac(num_t* a, long i, long j)
+{
+ if (j<0) { i=-i; j=-j; }
+ mpfr_init_set_si(a->num,i,GMP_RNDU);
+ mpfr_div_ui(a->num,a->num,j,GMP_RNDU);
+}
+
+#define num_init_set_infty(a) mpfr_init_set_d((a)->num,double_infty,GMP_RNDU)
+
+/* copy / update */
+
+#define num_set(a,b) mpfr_set((a)->num,(b)->num,GMP_RNDU)
+
+static inline void num_set_n(num_t* a, const num_t* b, size_t n)
+{ size_t i; for (i=0;i<n;i++,a++,b++) num_set(a,b); }
+
+#define num_set_int(a,i) mpfr_set_si((a)->num,(i),GMP_RNDU)
+#define num_set_float(a,d) mpfr_set_d ((a)->num,(d),GMP_RNDU)
+
+static inline void num_set_frac(num_t* a, long i, long j)
+{
+ if (j<0) { i=-i; j=-j; }
+ mpfr_set_si(a->num,i,GMP_RNDU);
+ mpfr_div_ui(a->num,a->num,j,GMP_RNDU);
+}
+
+#define num_set_infty(a) mpfr_set_d((a)->num,double_infty,GMP_RNDU)
+
+/* destructors */
+
+#define num_clear(a) mpfr_clear((a)->num)
+
+static inline void num_clear_n(num_t* a, size_t n)
+{ size_t i; for (i=0;i<n;i++,a++) num_clear(a); }
+
+/* conversions */
+
+static inline bool num_fits_int(const num_t* a)
+{
+ bool b;
+ mpfr_t m;
+ double d;
+ if (mpfr_inf_p(a->num)) return false;
+ mpfr_init(m);
+ mpfr_ceil(m,a->num);
+ d = mpfr_get_d(m
+#if (__GNU_MP_VERSION >= 4) && (__GNU_MP_VERSION_MINOR >= 1)
+ , GMP_RNDU
+#endif
+ );
+ b = d<=max_long && d>=-max_long;
+ mpfr_clear(m);
+ return b;
+}
+
+static inline bool num_fits_float(const num_t* a)
+{
+ double d = mpfr_get_d(a->num
+#if (__GNU_MP_VERSION >= 4) && (__GNU_MP_VERSION_MINOR >= 1)
+ , GMP_RNDU
+#endif
+ );
+ return d!=double_infty && d!=double_minfty;
+}
+
+#define num_fits_frac(a) num_fits_int(a)
+
+static inline long num_get_int(const num_t* a)
+{
+ mpfr_t m;
+ long l;
+ mpfr_init(m);
+ mpfr_ceil(m,a->num);
+ l = (long)ceil(mpfr_get_d(m
+#if (__GNU_MP_VERSION >= 4) && (__GNU_MP_VERSION_MINOR >= 1)
+ , GMP_RNDU
+#endif
+ ));
+ mpfr_clear(m);
+ return l;
+}
+
+#if (__GNU_MP_VERSION >= 4) && (__GNU_MP_VERSION_MINOR >= 1)
+#define num_get_float(a) mpfr_get_d((a)->num, GMP_RNDU)
+#else
+#define num_get_float(a) mpfr_get_d((a)->num)
+#endif
+
+#define num_get_num(a) num_get_int(a)
+#define num_get_den(a) (1L)
+
+
+/* GMP conversion */
+
+#define num_set_mpz(a,b) mpfr_set_z((a)->num,(b),GMP_RNDU)
+#define num_set_mpq(a,b) mpfr_set_q((a)->num,(b),GMP_RNDU)
+#define num_set_mpfr(a,b) mpfr_set((a)->num,(b),GMP_RNDU)
+
+#define num_get_mpfr(a,b) mpfr_set((a),(b)->num,GMP_RNDU)
+
+static inline void num_get_mpz(mpz_t b, const num_t* a)
+{
+ mpfr_t m;
+ long l;
+ mpfr_init(m);
+ mpfr_ceil(m,a->num);
+ l = (long)ceil(mpfr_get_d(m
+#if (__GNU_MP_VERSION >= 4) && (__GNU_MP_VERSION_MINOR >= 1)
+ , GMP_RNDU
+#endif
+ ));
+ mpz_set_si(b,l);
+ mpfr_clear(m);
+}
+
+static inline void num_get_mpq(mpq_t b, const num_t* a)
+{
+ mpfr_t m;
+ long l;
+ mpfr_init(m);
+ mpfr_ceil(m,a->num);
+ l = (long)ceil(mpfr_get_d(m
+#if (__GNU_MP_VERSION >= 4) && (__GNU_MP_VERSION_MINOR >= 1)
+ , GMP_RNDU
+#endif
+ ));
+ mpq_set_si(b,l,1);
+ mpfr_clear(m);
+}
+
+
+
+/* tests */
+
+#define num_infty(a) mpfr_inf_p((a)->num)
+#define num_cmp(a,b) mpfr_cmp((a)->num,(b)->num)
+#define num_cmp_int(a,b) mpfr_cmp_si((a)->num,(b))
+#define num_cmp_zero(a) mpfr_cmp_si((a)->num,0)
+
+/* operations */
+
+static inline void num_max(num_t* r, const num_t* a, const num_t* b)
+{ mpfr_set(r->num,mpfr_cmp(a->num,b->num)>0?a->num:b->num,GMP_RNDU); }
+
+static inline void num_min(num_t* r, const num_t* a, const num_t* b)
+{ mpfr_set(r->num,mpfr_cmp(a->num,b->num)<0?a->num:b->num,GMP_RNDU); }
+
+#define num_add(r,a,b) mpfr_add((r)->num,(a)->num,(b)->num,GMP_RNDU)
+#define num_sub(r,a,b) mpfr_sub((r)->num,(a)->num,(b)->num,GMP_RNDU)
+#define num_mul(r,a,b) mpfr_mul((r)->num,(a)->num,(b)->num,GMP_RNDU)
+#define num_mul_by_2(r,a) mpfr_mul_2exp((r)->num,(a)->num,1,GMP_RNDU)
+#define num_div_by_2(r,a) mpfr_div_2exp((r)->num,(a)->num,1,GMP_RNDU)
+#define num_neg(r,a) mpfr_neg((r)->num,(a)->num,GMP_RNDU)
+
+/* printing */
+
+static inline void num_print(const num_t* a)
+{ mpfr_out_str(stdout,10,6,a->num,GMP_RNDU); }
+
+static inline void num_snprint(char*s, size_t n, const num_t* a)
+{
+ char buf[100];
+ mp_exp_t ex;
+ if (mpfr_inf_p(a->num)) snprintf(s,n,"+oo");
+ else {
+ /* mpfr_get_str(buf,&ex,10,(sizeof(buf)>=n)?n:sizeof(buf)-1,a->num,GMP_RNDU);
+ if (ex) snprintf(s,n,"%c.%se%li",buf[0],buf+1,(long)ex);
+ else snprintf(s,n,"%c.%s",buf[0],buf+1); */
+ snprintf(s,n,"%f", mpfr_get_d(a->num
+#if (__GNU_MP_VERSION >= 4) && (__GNU_MP_VERSION_MINOR >= 1)
+ , GMP_RNDU
+#endif
+ ));
+ }
+}
+
+
+#define OCT_NUM_CLOSED
+#undef OCT_NUM_EXACT
+
+
+/* serialization */
+
+/* there is currently no _export / _import functions in MPFR
+ => we designed our own functions, not very portable and relying on
+ the internal encoding...
+ */
+
+#define OCT_NUM_SERIALIZE
+
+static const int num_serialize_id =
+ 0x150000 +
+ sizeof(mpfr_prec_t) + 16*sizeof(mp_exp_t) + 256*sizeof(mp_limb_t);
+
+static inline size_t num_serialize(const num_t* a, void* c)
+{
+ size_t i,count=0,bytes;
+ swap_word((char*)c+count,&a->num[0]._mpfr_prec,sizeof(mpfr_prec_t));
+ count += sizeof(mpfr_prec_t);
+ *((char*)c+count) = a->num[0]._mpfr_sign;
+ count++;
+ swap_word((char*)c+count,&a->num[0]._mpfr_exp,sizeof(mp_exp_t));
+ count += sizeof(mp_exp_t);
+ bytes = (a->num[0]._mpfr_prec+8*sizeof(mp_limb_t)-1)/(8*sizeof(mp_limb_t));
+ for (i=0;i<bytes;i++,count+=sizeof(mp_limb_t))
+ swap_word((char*)c+count,&a->num[0]._mpfr_d[i],sizeof(mp_limb_t));
+ return count;
+}
+
+static inline size_t num_deserialize(num_t* a, const void* c)
+{
+ size_t i,count=0,bytes;
+ mpfr_prec_t p;
+ mp_exp_t e;
+ char s;
+ swap_word(&p,(char*)c+count,sizeof(mpfr_prec_t));
+ count += sizeof(mpfr_prec_t);
+ s = *((char*)c+count);
+ count++;
+ swap_word(&e,(char*)c+count,sizeof(mp_exp_t));
+ count += sizeof(mp_exp_t);
+ bytes = (p+8*sizeof(mp_limb_t)-1)/(8*sizeof(mp_limb_t));
+ mpfr_set_prec(a->num,p);
+ for (i=0;i<bytes;i++,count+=sizeof(mp_limb_t))
+ swap_word(&a->num[0]._mpfr_d[i],(char*)c+count,sizeof(mp_limb_t));
+ a->num[0]._mpfr_sign = s;
+ a->num[0]._mpfr_exp = e;
+ return count;
+}
+
+
+/* note: this does not give the exact size of serialized data, but a sound
+ overapproximation
+*/
+static inline size_t num_serialize_size(num_t* a)
+{
+ return
+ sizeof(mpfr_prec_t)+1+sizeof(mp_exp_t)+
+ (a->num[0]._mpfr_prec/8)+sizeof(mp_limb_t);
+}
+
+
+#endif
+
+
+
+#ifdef __cplusplus
+}
+#endif
+
+#ifndef OCT_NUM
+#error "one OCT_NUM_ must be defined in oct_num.h"
+#endif
+
+
+#endif
--- /dev/null
+/* oct_ocaml.c
+ OCaml binding for all library functions.
+
+ This file is part of the Octagon Abstract Domain Library.
+ Please read the COPYING file packaged in the distribution.
+ Main web page is: http://www.di.ens.fr/~mine/oct/
+
+ Copyright (C) Antoine Mine' 2000-2002
+ */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/intext.h>
+#include <oct.h>
+#include <oct_private.h>
+#include <oct_ocaml.h>
+
+/* define to 1 if you want octagons to be marshalized in minimized form */
+#define OCAML_SERIALIZE_COMPRESS 1
+
+/* num/vnum -> num_t */
+
+void ocaml_num_finalize (value o)
+{
+ num_clear(Num_val(o));
+}
+
+int
+ocaml_num_compare (value a, value b)
+{
+ return num_cmp(Num_val(a),Num_val(b));
+}
+
+void ocaml_vnum_finalize (value o)
+{
+ num_clear_n(Vnum_val(o)->n,Vnum_val(o)->nb);
+ oct_mm_free(Vnum_val(o)->n);
+}
+
+#ifdef OCT_NUM_SERIALIZE
+
+void ocaml_num_serialize (value a, unsigned long * w32, unsigned long * w64)
+{
+ num_t* n = Num_val(a);
+ unsigned size = num_serialize_size(n);
+ char* data = new_n(char,size);
+ num_serialize(n,data);
+ serialize_int_4(num_serialize_id);
+ serialize_int_4(size);
+ serialize_block_1(data,size);
+ *w32=size;
+ *w64=size;
+ oct_mm_free(data);
+}
+
+unsigned long ocaml_num_deserialize (void * dst)
+{
+ int id = deserialize_sint_4();
+ unsigned size;
+ char* data;
+ if (id!=num_serialize_id)
+ failwith ("ocaml_num_deserialize: incompatible serialized num");
+ size = deserialize_uint_4();
+ data = new_n(char,size);
+ deserialize_block_1(data,size);
+ num_init((num_t*)dst);
+ num_deserialize((num_t*)dst,data);
+ oct_mm_free(data);
+ return(size);
+}
+
+void ocaml_vnum_serialize (value a, unsigned long * w32, unsigned long * w64)
+{
+ vnum_t* v = Vnum_val(a);
+ unsigned size,i;
+ char* data, *d;
+ for (i=0,size=0;i<v->nb;i++)
+ size += num_serialize_size(v->n+i);
+
+ data = new_n(char,size);
+ for (i=0,d=data;i<v->nb;i++)
+ d += num_serialize(v->n+i,d);
+
+ serialize_int_4(num_serialize_id);
+ serialize_int_4(size);
+ serialize_int_4(v->nb);
+ serialize_block_1(data,size);
+ *w32=4*2;
+ *w64=8*2;
+ oct_mm_free(data);
+}
+
+unsigned long ocaml_vnum_deserialize (void * dst)
+{
+ int id = deserialize_sint_4();
+ unsigned size, nb, i;
+ char* data, *d;
+ if (id!=num_serialize_id)
+ failwith ("ocaml_vnum_deserialize: incompatible serialized vnum");
+ size = deserialize_uint_4();
+ nb = deserialize_uint_4();
+ data = new_n(char,size);
+ deserialize_block_1(data,size);
+
+ ((vnum_t*)dst)-> nb = nb;
+ ((vnum_t*)dst)->n = new_n(num_t,nb);
+ num_init_n(((vnum_t*)dst)->n, nb);
+ for (i=0,d=data;i<nb;i++)
+ d += num_deserialize(((vnum_t*)dst)->n+i,d);
+
+ oct_mm_free(data);
+ return(sizeof(vnum_t));
+}
+
+#endif
+
+static struct custom_operations ocaml_num_custom = {
+ "o_n@1",
+ ocaml_num_finalize,
+ ocaml_num_compare,
+ custom_hash_default,
+#ifdef OCT_NUM_SERIALIZE
+ ocaml_num_serialize,
+ ocaml_num_deserialize
+#else
+ custom_serialize_default,
+ custom_deserialize_default
+#endif
+};
+
+static struct custom_operations ocaml_vnum_custom = {
+ "o_v@1",
+ ocaml_vnum_finalize ,
+ custom_compare_default,
+ custom_hash_default,
+#ifdef OCT_NUM_SERIALIZE
+ ocaml_vnum_serialize,
+ ocaml_vnum_deserialize
+#else
+ custom_serialize_default,
+ custom_deserialize_default
+#endif
+};
+
+CAMLprim value
+ocaml_num_infty (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ r = alloc_custom(&ocaml_num_custom,sizeof(num_t),0,1);
+ num_init_set_infty(Num_val(r));
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_num_int (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ r = alloc_custom(&ocaml_num_custom,sizeof(num_t),0,1);
+ num_init_set_int(Num_val(r),Int_val(v));
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_num_frac (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ r = alloc_custom(&ocaml_num_custom,sizeof(num_t),0,1);
+ num_init_set_frac(Num_val(r),Int_val(Field(v,0)),Int_val(Field(v,1)));
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_num_float (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ r = alloc_custom(&ocaml_num_custom,sizeof(num_t),0,1);
+ num_init_set_float(Num_val(r),Double_val(v));
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_vnum_int (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ size_t i, n = Wosize_val(v);
+ num_t* k = new_n(num_t,n);
+ r = alloc_custom(&ocaml_vnum_custom,sizeof(vnum_t),0,1);
+ Vnum_val(r)->nb = n;
+ Vnum_val(r)->n = k;
+ for (i=0;i<n;i++)
+ num_init_set_int(k+i,Int_val(Field(v,i)));
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_vnum_frac (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ size_t i, n = Wosize_val(v);
+ num_t* k = new_n(num_t,n);
+ r = alloc_custom(&ocaml_vnum_custom,sizeof(vnum_t),0,1);
+ Vnum_val(r)->nb = n;
+ Vnum_val(r)->n = k;
+ for (i=0;i<n;i++)
+ num_init_set_frac(k+i,
+ Int_val(Field(Field(v,i),0)),
+ Int_val(Field(Field(v,i),1)));
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_vnum_float (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ size_t i, n = Wosize_val(v)/Double_wosize;
+ num_t* k = new_n(num_t,n);
+ r = alloc_custom(&ocaml_vnum_custom,sizeof(vnum_t),0,1);
+ Vnum_val(r)->nb = n;
+ Vnum_val(r)->n = k;
+ for (i=0;i<n;i++)
+ num_init_set_float(k+i,Double_field(v,i));
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_vnum_int_opt (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ size_t i, n = Wosize_val(v);
+ num_t* k = new_n(num_t,n);
+ r = alloc_custom(&ocaml_vnum_custom,sizeof(vnum_t),0,1);
+ Vnum_val(r)->nb = n;
+ Vnum_val(r)->n = k;
+ for (i=0;i<n;i++)
+ if (Is_long(Field(v,i))) num_init_set_infty(k+i);
+ else num_init_set_int(k+i,Int_val(Field(Field(v,i),0)));
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_vnum_frac_opt (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ size_t i, n = Wosize_val(v);
+ num_t* k = new_n(num_t,n);
+ r = alloc_custom(&ocaml_vnum_custom,sizeof(vnum_t),0,1);
+ Vnum_val(r)->nb = n;
+ Vnum_val(r)->n = k;
+ for (i=0;i<n;i++)
+ if (Is_long(Field(v,i))) num_init_set_infty(k+i);
+ else num_init_set_frac(k+i,
+ Int_val(Field(Field(v,i),0)),
+ Int_val(Field(Field(v,i),1)));
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_int_num (value v)
+{
+ long i;
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ if (!num_fits_int(Num_val(v))) r = Val_int(0);
+ else {
+ i = num_get_int(Num_val(v));
+ if (i<(1<<30) && i>=-(1<<30)) {
+ r = alloc_tuple(1);
+ Store_field (r,0,Val_int(i));
+ }
+ else r = Val_int(0);
+ }
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_frac_num (value v)
+{
+ long i,j;
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ if (!num_fits_frac(Num_val(v))) r = Val_int(0);
+ else {
+ i = num_get_num(Num_val(v));
+ j = num_get_den(Num_val(v));
+ if (i<(1<<30) && i>=-(1<<30) && j<(1<<30)) {
+ r = alloc_tuple(2);
+ Store_field (r,0,Val_int(i));
+ Store_field (r,1,Val_int(j));
+ }
+ else r = Val_int(0);
+ }
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_float_num (value v)
+{
+ double d;
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ if (!num_fits_float(Num_val(v))) r = copy_double(1./0.);
+ else r = copy_double(num_get_float(Num_val(v)));
+ CAMLreturn(r);
+}
+
+
+CAMLprim value
+ocaml_int_vnum (value v)
+{
+ size_t i,n;
+ vnum_t* k;
+ CAMLparam1(v);
+ CAMLlocal2(r,s);
+ k = Vnum_val(v);
+ r = alloc_tuple(k->nb);
+ for (i=0;i<k->nb;i++) {
+ if (!num_fits_int(k->n+i)) s = Val_int(0);
+ else {
+ long a = num_get_int(k->n+i);
+ if (a<(1<<30) && a>=-(1<<30)) {
+ s = alloc_tuple(1);
+ Store_field (s,0,Val_int(a));
+ }
+ else s = Val_int(0);
+ }
+ Store_field (r,i,s);
+ }
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_frac_vnum (value v)
+{
+ size_t i,n;
+ vnum_t* k;
+ CAMLparam1(v);
+ CAMLlocal2(r,s);
+ k = Vnum_val(v);
+ r = alloc_tuple(k->nb);
+ for (i=0;i<k->nb;i++) {
+ if (!num_fits_frac(k->n+i)) s = Val_int(0);
+ else {
+ long a = num_get_num(k->n+i);
+ long b = num_get_den(k->n+i);
+ if (a<(1<<30) && a>=-(1<<30) && b<(1<<30)) {
+ s = alloc_tuple(2);
+ Store_field (s,0,Val_int(a));
+ Store_field (s,1,Val_int(b));
+ }
+ else s = Val_int(0);
+ }
+ Store_field (r,i,s);
+ }
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_float_vnum (value v)
+{
+ size_t i,n;
+ vnum_t* k;
+ CAMLparam1(v);
+ CAMLlocal2(r,s);
+ k = Vnum_val(v);
+ r = alloc(k->nb*Double_wosize,Double_array_tag);
+ for (i=0;i<k->nb;i++) {
+ if (!num_fits_float(k->n+i)) Store_double_field(r,i,1./0.);
+ else Store_double_field(r,i,num_get_float(k->n+i));
+}
+ CAMLreturn(r);
+}
+
+
+#if defined(OCT_HAS_GMP) && defined(OCT_HAS_OCAML_GMP)
+
+#include <gmp.h>
+
+extern struct custom_operations _mlgmp_custom_z;
+extern struct custom_operations _mlgmp_custom_q;
+
+CAMLprim value
+ocaml_num_mpz (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ r = alloc_custom(&ocaml_num_custom,sizeof(num_t),0,1);
+ num_init(Num_val(r));
+ num_set_mpz(Num_val(r),*((mpz_t*)(Data_custom_val(v))));
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_num_mpq (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ r = alloc_custom(&ocaml_num_custom,sizeof(num_t),0,1);
+ num_init(Num_val(r));
+ num_set_mpq(Num_val(r),*((mpq_t*)(Data_custom_val(v))));
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_vnum_mpz (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ size_t i, n = Wosize_val(v);
+ num_t* k = new_n(num_t,n);
+ r = alloc_custom(&ocaml_vnum_custom,sizeof(vnum_t),0,1);
+ Vnum_val(r)->nb = n;
+ Vnum_val(r)->n = k;
+ num_init_n(k,n);
+ for (i=0;i<n;i++)
+ num_set_mpz(k+i,*((mpz_t*)(Data_custom_val(Field(v,i)))));
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_vnum_mpq (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ size_t i, n = Wosize_val(v);
+ num_t* k = new_n(num_t,n);
+ r = alloc_custom(&ocaml_vnum_custom,sizeof(vnum_t),0,1);
+ Vnum_val(r)->nb = n;
+ Vnum_val(r)->n = k;
+ num_init_n(k,n);
+ for (i=0;i<n;i++)
+ num_set_mpq(k+i,*((mpq_t*)(Data_custom_val(Field(v,i)))));
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_vnum_mpz_opt (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ size_t i, n = Wosize_val(v);
+ num_t* k = new_n(num_t,n);
+ r = alloc_custom(&ocaml_vnum_custom,sizeof(vnum_t),0,1);
+ Vnum_val(r)->nb = n;
+ Vnum_val(r)->n = k;
+ num_init_n(k,n);
+ for (i=0;i<n;i++)
+ if (Is_long(Field(v,i))) num_set_infty(k+i);
+ else num_set_mpz(k+i,*((mpz_t*)(Data_custom_val(Field(Field(v,i),0)))));
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_vnum_mpq_opt (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ size_t i, n = Wosize_val(v);
+ num_t* k = new_n(num_t,n);
+ r = alloc_custom(&ocaml_vnum_custom,sizeof(vnum_t),0,1);
+ Vnum_val(r)->nb = n;
+ Vnum_val(r)->n = k;
+ num_init_n(k,n);
+ for (i=0;i<n;i++)
+ if (Is_long(Field(v,i))) num_set_infty(k+i);
+ else num_set_mpq(k+i,*((mpq_t*)(Data_custom_val(Field(Field(v,i),0)))));
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_mpz_num (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal2(r,s);
+ if (num_infty(Num_val(v))) r = Val_int(0);
+ else {
+ s = alloc_custom(&_mlgmp_custom_z,sizeof(mpz_t),0,1);
+ num_get_mpz (*((mpz_t*)Data_custom_val(s)), Num_val(v));
+ r = alloc_tuple(1);
+ Store_field (r,0,s);
+ }
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_mpq_num (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal2(r,s);
+ if (num_infty(Num_val(v))) r = Val_int(0);
+ else {
+ s = alloc_custom(&_mlgmp_custom_q,sizeof(mpq_t),0,1);
+ num_get_mpq (*((mpq_t*)Data_custom_val(s)), Num_val(v));
+ r = alloc_tuple(1);
+ Store_field (r,0,s);
+ }
+ CAMLreturn(r);
+}
+
+
+CAMLprim value
+ocaml_mpz_vnum (value v)
+{
+ size_t i,n;
+ vnum_t* k;
+ CAMLparam1(v);
+ CAMLlocal2(r,s);
+ k = Vnum_val(v);
+ r = alloc_tuple(k->nb);
+ for (i=0;i<k->nb;i++) {
+ if (!num_infty(k->n+i)) s = Val_int(0);
+ else {
+ s = alloc_custom(&_mlgmp_custom_z,sizeof(mpz_t),0,1);
+ num_get_mpz (*((mpz_t*)Data_custom_val(s)), k->n+i);
+ }
+ Store_field (r,i,s);
+ }
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_mpq_vnum (value v)
+{
+ size_t i,n;
+ vnum_t* k;
+ CAMLparam1(v);
+ CAMLlocal2(r,s);
+ k = Vnum_val(v);
+ r = alloc_tuple(k->nb);
+ for (i=0;i<k->nb;i++) {
+ if (!num_infty(k->n+i)) s = Val_int(0);
+ else {
+ s = alloc_custom(&_mlgmp_custom_q,sizeof(mpq_t),0,1);
+ num_get_mpq (*((mpq_t*)Data_custom_val(s)), k->n+i);
+ }
+ Store_field (r,i,s);
+ }
+ CAMLreturn(r);
+}
+
+#else
+
+CAMLprim void
+ocaml_num_mpz (value v)
+{
+ CAMLparam1(v);
+ failwith ("ocaml_num_mpz: GMP support not enabled");
+ CAMLreturn0;
+}
+
+CAMLprim void
+ocaml_num_mpq (value v)
+{
+ CAMLparam1(v);
+ failwith ("ocaml_num_mpq: GMP support not enabled");
+ CAMLreturn0;
+}
+
+CAMLprim void
+ocaml_vnum_mpz (value v)
+{
+ CAMLparam1(v);
+ failwith ("ocaml_vnum_mpz: GMP support not enabled");
+ CAMLreturn0;
+}
+
+CAMLprim void
+ocaml_vnum_mpq (value v)
+{
+ CAMLparam1(v);
+ failwith ("ocaml_vnum_mpq: GMP support not enabled");
+ CAMLreturn0;
+}
+
+CAMLprim void
+ocaml_vnum_mpz_opt (value v)
+{
+ CAMLparam1(v);
+ failwith ("ocaml_vnum_mpz_opt: GMP support not enabled");
+ CAMLreturn0;
+}
+
+CAMLprim void
+ocaml_vnum_mpq_opt (value v)
+{
+ CAMLparam1(v);
+ failwith ("ocaml_vnum_mpq_opt: GMP support not enabled");
+ CAMLreturn0;
+}
+
+CAMLprim void
+ocaml_mpz_num (value v)
+{
+ CAMLparam1(v);
+ failwith ("ocaml_mpz_num: GMP support not enabled");
+ CAMLreturn0;
+}
+
+CAMLprim void
+ocaml_mpq_num (value v)
+{
+ CAMLparam1(v);
+ failwith ("ocaml_mpq_num: GMP support not enabled");
+ CAMLreturn0;
+}
+
+CAMLprim void
+ocaml_mpz_vnum (value v)
+{
+ CAMLparam1(v);
+ failwith ("ocaml_mpz_vnum: GMP support not enabled");
+ CAMLreturn0;
+}
+
+CAMLprim void
+ocaml_mpq_vnum (value v)
+{
+ CAMLparam1(v);
+ failwith ("ocaml_mpq_vnum: GMP support not enabled");
+ CAMLreturn0;
+}
+
+#endif
+
+#if defined(OCT_HAS_MPFR) && defined(OCT_HAS_OCAML_GMP)
+
+#include <mpfr.h>
+
+extern struct custom_operations _mlgmp_custom_fr;
+
+CAMLprim value
+ocaml_num_mpfr (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ r = alloc_custom(&ocaml_num_custom,sizeof(num_t),0,1);
+ num_init(Num_val(r));
+ num_set_mpfr(Num_val(r),*((mpfr_t*)(Data_custom_val(v))));
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_vnum_mpfr (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ size_t i, n = Wosize_val(v);
+ num_t* k = new_n(num_t,n);
+ r = alloc_custom(&ocaml_vnum_custom,sizeof(vnum_t),0,1);
+ Vnum_val(r)->nb = n;
+ Vnum_val(r)->n = k;
+ num_init_n(k,n);
+ for (i=0;i<n;i++)
+ num_set_mpfr(k+i,*((mpfr_t*)(Data_custom_val(Field(v,i)))));
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_vnum_mpfr_opt (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal1(r);
+ size_t i, n = Wosize_val(v);
+ num_t* k = new_n(num_t,n);
+ r = alloc_custom(&ocaml_vnum_custom,sizeof(vnum_t),0,1);
+ Vnum_val(r)->nb = n;
+ Vnum_val(r)->n = k;
+ num_init_n(k,n);
+ for (i=0;i<n;i++)
+ if (Is_long(Field(v,i))) num_set_infty(k+i);
+ else num_set_mpfr(k+i,(*(mpfr_t*)(Data_custom_val(Field(Field(v,i),0)))));
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_mpfr_num (value v)
+{
+ CAMLparam1(v);
+ CAMLlocal2(r,s);
+ if (num_infty(Num_val(v))) r = Val_int(0);
+ else {
+ s = alloc_custom(&_mlgmp_custom_fr,sizeof(mpfr_t),0,1);
+ num_get_mpfr (*((mpfr_t*)Data_custom_val(s)), Num_val(v));
+ r = alloc_tuple(1);
+ Store_field (r,0,s);
+ }
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_mpfr_vnum (value v)
+{
+ size_t i,n;
+ vnum_t* k;
+ CAMLparam1(v);
+ CAMLlocal2(r,s);
+ k = Vnum_val(v);
+ r = alloc_tuple(k->nb);
+ for (i=0;i<k->nb;i++) {
+ if (!num_infty(k->n+i)) s = Val_int(0);
+ else {
+ s = alloc_custom(&_mlgmp_custom_fr,sizeof(mpfr_t),0,1);
+ num_get_mpfr (*((mpfr_t*)Data_custom_val(s)), k->n+i);
+ }
+ Store_field (r,i,s);
+ }
+ CAMLreturn(r);
+}
+
+#else
+
+CAMLprim void
+ocaml_num_mpfr (value v)
+{
+ CAMLparam1(v);
+ failwith ("ocaml_num_mpfr: GMP support not enabled");
+ CAMLreturn0;
+}
+
+CAMLprim void
+ocaml_vnum_mpfr (value v)
+{
+ CAMLparam1(v);
+ failwith ("ocaml_vnum_mpfr: GMP support not enabled");
+ CAMLreturn0;
+}
+
+CAMLprim void
+ocaml_vnum_mpfr_opt (value v)
+{
+ CAMLparam1(v);
+ failwith ("ocaml_vnum_mpfr_opt: GMP support not enabled");
+ CAMLreturn0;
+}
+
+CAMLprim void
+ocaml_mpfr_num (value v)
+{
+ CAMLparam1(v);
+ failwith ("ocaml_mpfr_num: GMP support not enabled");
+ CAMLreturn0;
+}
+
+CAMLprim void
+ocaml_mpfr_vnum (value v)
+{
+ CAMLparam1(v);
+ failwith ("ocaml_mpfr_vnum: GMP support not enabled");
+ CAMLreturn0;
+}
+
+#endif
+
+
+CAMLprim value
+ocaml_num_string(value m)
+{
+ char buf[4096];
+ CAMLparam1(m);
+ num_snprint(buf,4095,Num_val(m));
+ CAMLreturn(copy_string(buf));
+}
+
+
+CAMLprim value
+ocaml_vnum_string(value m, value i)
+{
+ char buf[4096];
+ int j;
+ CAMLparam2(m,i);
+ j = Int_val(i);
+ if (j<0 || j>=Vnum_val(m)->nb)
+ failwith("ocaml_vnum_string: invalid index");
+ num_snprint(buf,4095,Vnum_val(m)->n+j);
+ CAMLreturn(copy_string(buf));
+}
+
+CAMLprim value
+ocaml_vnum_length(value m)
+{
+ CAMLparam1(m);
+ CAMLreturn(Val_int(Vnum_val(m)->nb));
+}
+
+/* octagons management */
+
+void
+ocaml_oct_finalize (value o)
+{
+ oct_free(Oct_val(o));
+}
+
+void
+ocaml_oct_serialize (value a, unsigned long * w32, unsigned long * w64)
+{
+ size_t size;
+ char* data;
+#if OCAML_SERIALIZE_COMPRESS
+ moct_t* m = oct_m_from_oct (Oct_val(a));
+ data = oct_m_serialize(m,&size);
+ oct_m_free(m);
+#else
+ data = oct_serialize(Oct_val(a),&size);
+#endif
+ serialize_int_8(size);
+ serialize_block_1(data,size);
+ *w32=4;
+ *w64=8;
+ oct_mm_free(data);
+}
+
+unsigned long
+ocaml_oct_deserialize (void * dst)
+{
+ size_t size;
+ void* data;
+ size = deserialize_uint_8() & 0xFFFFFFFFUL; /* DM kludge */
+ data = new_n(char, size);
+ deserialize_block_1(data,size);
+#if OCAML_SERIALIZE_COMPRESS
+ {
+ moct_t* m = oct_m_deserialize(data);
+ *((oct_t**)dst) = oct_m_to_oct(m);
+ oct_m_free(m);
+ }
+#else
+ *((oct_t**)dst) = oct_deserialize(data);
+#endif
+ oct_mm_free(data);
+ return(sizeof(oct_t*));
+}
+
+static struct custom_operations ocaml_oct_custom = {
+ "o_o@1",
+ ocaml_oct_finalize ,
+ custom_compare_default,
+ custom_hash_default,
+ ocaml_oct_serialize,
+ ocaml_oct_deserialize
+};
+
+inline
+CAMLprim value
+Val_oct (const oct_t* o)
+{
+ CAMLparam0();
+ CAMLlocal1(v);
+ v = alloc_custom(&ocaml_oct_custom,sizeof(oct_t*),0,1);
+ Oct_val(v) = (oct_t*)o;
+ CAMLreturn(v);
+}
+
+
+/* functions wrappers */
+
+CAMLprim value
+ocaml_oct_empty (value n)
+{
+ CAMLparam1(n);
+ CAMLreturn(Val_oct(oct_empty(Int_val(n))));
+}
+
+CAMLprim value
+ocaml_oct_universe (value n)
+{
+ CAMLparam1(n);
+ CAMLreturn(Val_oct(oct_universe(Int_val(n))));
+}
+
+CAMLprim value
+ocaml_oct_dim (value n)
+{
+ CAMLparam1(n);
+ CAMLreturn(Val_int(oct_dimension(Oct_val(n))));;
+}
+
+CAMLprim value
+ocaml_oct_nbconstraints (value n)
+{
+ CAMLparam1(n);
+ CAMLreturn(Val_int(oct_nbconstraints(Oct_val(n))));
+}
+
+CAMLprim value
+ocaml_oct_get_elem (value m, value i, value j)
+{
+ CAMLparam3(m,i,j);
+ CAMLlocal1(r);
+ r = alloc_custom(&ocaml_num_custom,sizeof(num_t),0,1);
+ num_init_set(Num_val(r),oct_elem(Oct_val(m),Int_val(i),Int_val(j)));
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_oct_is_empty (value n)
+{
+ CAMLparam1(n);
+ CAMLreturn(Val_bool(oct_is_empty(Oct_val(n))));
+}
+
+CAMLprim value
+ocaml_oct_is_empty_lazy (value n)
+{
+ CAMLparam1(n);
+ CAMLreturn(Val_int(oct_is_empty_lazy(Oct_val(n))));
+}
+
+CAMLprim value
+ocaml_oct_is_universe (value n)
+{
+ CAMLparam1(n);
+ CAMLreturn(Val_bool(oct_is_universe(Oct_val(n))));
+}
+
+CAMLprim value
+ocaml_oct_is_included_in (value n, value m)
+{
+ CAMLparam2(n,m);
+ CAMLreturn(Val_bool(oct_is_included_in(Oct_val(n),Oct_val(m))));
+}
+
+CAMLprim value
+ocaml_oct_is_included_in_lazy (value n, value m)
+{
+ CAMLparam2(n,m);
+ CAMLreturn(Val_int(oct_is_included_in_lazy(Oct_val(n),Oct_val(m))));
+}
+
+CAMLprim value
+ocaml_oct_is_equal (value n, value m)
+{
+ CAMLparam2(n,m);
+ CAMLreturn(Val_bool(oct_is_equal(Oct_val(n),Oct_val(m))));
+}
+
+CAMLprim value
+ocaml_oct_is_equal_lazy (value n, value m)
+{
+ CAMLparam2(n,m);
+ CAMLreturn(Val_int(oct_is_equal_lazy(Oct_val(n),Oct_val(m))));
+}
+
+CAMLprim value
+ocaml_oct_is_in (value n, value m)
+{
+ CAMLparam2(n,m);
+ if (Vnum_val(m)->nb!=Oct_val(n)->n)
+ failwith("ocaml_oct_is_in: incompatible dimensions");
+ CAMLreturn(Val_bool(oct_is_in (Oct_val(n),Vnum_val(m)->n)));
+}
+
+CAMLprim value
+ocaml_oct_inter (value n, value m)
+{
+ CAMLparam2(n,m);
+ CAMLreturn(Val_oct(oct_intersection(Oct_val(n),Oct_val(m),false)));
+}
+
+CAMLprim value
+ocaml_oct_union (value n, value m)
+{
+ CAMLparam2(n,m);
+ CAMLreturn(Val_oct(oct_convex_hull(Oct_val(n),Oct_val(m),false)));
+}
+
+CAMLprim value
+ocaml_oct_widening (value n, value m, value t)
+{
+ oct_t* r;
+ CAMLparam3(n,m,t);
+ if (Is_block(t)) r = oct_widening_steps(Oct_val(n),Oct_val(m),false,
+ Vnum_val(Field(t,0))->nb,
+ Vnum_val(Field(t,0))->n);
+ else {
+ oct_widening_type w;
+ switch (Int_val(t)) {
+ case 0: w = OCT_WIDENING_FAST; break;
+ case 1: w = OCT_WIDENING_ZERO; break;
+ case 2: w = OCT_WIDENING_UNIT; break;
+ case 3: w = OCT_PRE_WIDENING; break;
+ default: w = OCT_WIDENING_FAST;
+ }
+ r = oct_widening(Oct_val(n),Oct_val(m),false,w);
+ }
+ CAMLreturn(Val_oct(r));
+}
+
+CAMLprim value
+ocaml_oct_narrowing (value n, value m)
+{
+ CAMLparam2(n,m);
+ CAMLreturn(Val_oct(oct_narrowing(Oct_val(n),Oct_val(m),false)));
+}
+
+CAMLprim value
+ocaml_oct_forget (value n, value m)
+{
+ CAMLparam2(n,m);
+ CAMLreturn(Val_oct(oct_forget(Oct_val(n),Int_val(m),false)));
+}
+
+CAMLprim value
+ocaml_oct_add_bin_constraints (value n, value m)
+{
+ int i, nb;
+ oct_t* r;
+ oct_cons* c;
+ CAMLparam2(n,m);
+ CAMLlocal1(l);
+ nb = Wosize_val(m);
+ c = new_n(oct_cons,nb);
+ for (i=0;i<nb;i++) {
+ l = Field(m,i);
+ switch (Tag_val(l)) {
+ case 0: /* PX x <= c */
+ c[i].x = Int_val(Field(l,0));
+ num_init_set(&c[i].c,Num_val(Field(l,1)));
+ c[i].type = px;
+ break;
+ case 1: /* MX -x <= c */
+ c[i].x =Int_val( Field(l,0));
+ num_init_set(&c[i].c,Num_val(Field(l,1)));
+ c[i].type = mx;
+ break;
+ case 2: /* PXPY x+y <= c */
+ c[i].x = Int_val(Field(l,0));
+ c[i].y = Int_val(Field(l,1));
+ num_init_set(&c[i].c,Num_val(Field(l,2)));
+ c[i].type = pxpy;
+ break;
+ case 3: /* PXMY x-y <= c */
+ c[i].x = Int_val(Field(l,0));
+ c[i].y = Int_val(Field(l,1));
+ num_init_set(&c[i].c,Num_val(Field(l,2)));
+ c[i].type = pxmy;
+ break;
+ case 4: /* MXPY x+y <= c */
+ c[i].x = Int_val(Field(l,0));
+ c[i].y = Int_val(Field(l,1));
+ num_init_set(&c[i].c,Num_val(Field(l,2)));
+ c[i].type = mxpy;
+ break;
+ case 5: /* MXMY -x+y <= c */
+ c[i].x = Int_val(Field(l,0));
+ c[i].y = Int_val(Field(l,1));
+ num_init_set(&c[i].c,Num_val(Field(l,2)));
+ c[i].type = mxmy;
+ break;
+ default:
+ oct_mm_free(c);
+ failwith("ocaml_oct_add_bin_constraints: invalid element of type constr");
+ }
+ }
+ r = oct_add_bin_constraints(Oct_val(n),nb,c,false);
+ for (i=0;i<nb;i++) num_clear(&c[i].c);
+ oct_mm_free(c);
+ CAMLreturn(Val_oct(r));
+}
+
+CAMLprim value
+ocaml_oct_assign_variable (value n, value m, value o)
+{
+ CAMLparam3(n,m,o);
+ if (Vnum_val(o)->nb!=Oct_val(n)->n+1)
+ failwith("ocaml_oct_assign_variable: incompatible dimensions");
+ CAMLreturn(Val_oct(oct_assign_variable(Oct_val(n),Int_val(m),
+ Vnum_val(o)->n,false)));
+}
+
+CAMLprim value
+ocaml_oct_substitute_variable (value n, value m, value o)
+{
+ CAMLparam3(n,m,o);
+ if (Vnum_val(o)->nb!=Oct_val(n)->n+1)
+ failwith("ocaml_oct_substitute_variable: incompatible dimensions");
+ CAMLreturn(Val_oct(oct_substitute_variable(Oct_val(n),Int_val(m),
+ Vnum_val(o)->n,false)));
+}
+
+CAMLprim value
+ocaml_oct_add_constraint (value n, value o)
+{
+ CAMLparam2(n,o);
+ if (Vnum_val(o)->nb!=Oct_val(n)->n+1)
+ failwith("ocaml_oct_add_constraint: incompatible dimensions");
+ CAMLreturn(Val_oct(oct_add_constraint (Oct_val(n),Vnum_val(o)->n,false)));
+}
+
+CAMLprim value
+ocaml_oct_interv_assign_variable (value n, value m, value o)
+{
+ CAMLparam3(n,m,o);
+ if (Vnum_val(o)->nb!=2*(Oct_val(n)->n+1))
+ failwith("ocaml_oct_interv_assign_variable: incompatible dimensions");
+ CAMLreturn(Val_oct(oct_interv_assign_variable(Oct_val(n),Int_val(m),
+ Vnum_val(o)->n,false)));
+}
+
+CAMLprim value
+ocaml_oct_interv_add_constraint (value n, value o)
+{
+ CAMLparam2(n,o);
+ if (Vnum_val(o)->nb!=2*(Oct_val(n)->n+1))
+ failwith("ocaml_oct_interv_add_constraint: incompatible dimensions");
+ CAMLreturn(Val_oct(oct_interv_add_constraint (Oct_val(n),Vnum_val(o)->n,false)));
+}
+
+CAMLprim value
+ocaml_oct_interv_substitute_variable (value n, value m, value o)
+{
+ CAMLparam3(n,m,o);
+ if (Vnum_val(o)->nb!=2*(Oct_val(n)->n+1))
+ failwith("ocaml_oct_interv_substitute_variable: incompatible dimensions");
+ CAMLreturn(Val_oct(oct_interv_substitute_variable(Oct_val(n),Int_val(m),
+ Vnum_val(o)->n,false)));
+}
+
+
+CAMLprim value
+ocaml_oct_add_dimensions_and_embed (value n, value m)
+{
+ CAMLparam2(n,m);
+ CAMLreturn(Val_oct(oct_add_dimensions_and_embed(Oct_val(n),Int_val(m),false)));
+}
+
+CAMLprim value
+ocaml_oct_add_dimensions_and_project (value n, value m)
+{
+ CAMLparam2(n,m);
+ CAMLreturn(Val_oct(oct_add_dimensions_and_project(Oct_val(n),Int_val(m),false)));
+}
+
+CAMLprim value
+ocaml_oct_remove_dimensions (value n, value m)
+{
+ CAMLparam2(n,m);
+ CAMLreturn(Val_oct(oct_remove_dimensions(Oct_val(n),Int_val(m),false)));
+}
+
+static dimsup_t*
+get_dimsup (value tab)
+{
+ size_t i,n = Wosize_val(tab);
+ dimsup_t* d = new_n(dimsup_t,n);
+ for (i=0;i<n;i++) {
+ d[i].pos = Int_val(Field(Field(tab,i),0));
+ d[i].nbdims = Int_val(Field(Field(tab,i),1));
+ }
+ return d;
+}
+
+CAMLprim value
+ocaml_oct_add_dimensions_and_embed_multi (value n, value m)
+{
+ dimsup_t* t;
+ oct_t* r;
+ CAMLparam2(n,m);
+ t = get_dimsup(m);
+ r = oct_add_dimensions_and_embed_multi(Oct_val(n),t,Wosize_val(m),false);
+ oct_mm_free(t);
+ CAMLreturn(Val_oct(r));
+}
+
+CAMLprim value
+ocaml_oct_add_dimensions_and_project_multi (value n, value m)
+{
+ dimsup_t* t;
+ oct_t* r;
+ CAMLparam2(n,m);
+ t = get_dimsup(m);
+ r = oct_add_dimensions_and_project_multi(Oct_val(n),t,Wosize_val(m),false);
+ oct_mm_free(t);
+ CAMLreturn(Val_oct(r));
+}
+
+CAMLprim value
+ocaml_oct_remove_dimensions_multi (value n, value m)
+{
+ dimsup_t* t;
+ oct_t* r;
+ CAMLparam2(n,m);
+ t = get_dimsup(m);
+ r = oct_remove_dimensions_multi(Oct_val(n),t,Wosize_val(m),false);
+ oct_mm_free(t);
+ CAMLreturn(Val_oct(r));
+}
+
+CAMLprim value
+ocaml_oct_add_permute_dimensions_and_embed (value n, value m, value t)
+{
+ CAMLparam3(n,m,t);
+ oct_t* r;
+ var_t* tt,i,sz=Wosize_val(t);
+ if (Oct_val(n)->n+Int_val(m)!=sz)
+ failwith("ocaml_oct_add_permute_dimensions_and_embed: invalid permutation dimension");
+ tt = new_n(var_t,sz);
+ for (i=0;i<sz;i++) tt[i] = Int_val(Field(t,i));
+ r = oct_add_permute_dimensions_and_embed(Oct_val(n),Int_val(m),tt,false);
+ oct_mm_free(tt);
+ CAMLreturn(Val_oct(r));
+}
+
+CAMLprim value
+ocaml_oct_add_permute_dimensions_and_project (value n, value m, value t)
+{
+ CAMLparam3(n,m,t);
+ oct_t* r;
+ var_t* tt,i,sz=Wosize_val(t);
+ if (Oct_val(n)->n+Int_val(m)!=sz)
+ failwith("ocaml_oct_add_permute_dimensions_and_project: invalid permutation dimension");
+ tt = new_n(var_t,sz);
+ for (i=0;i<sz;i++) tt[i] = Int_val(Field(t,i));
+ r = oct_add_permute_dimensions_and_project(Oct_val(n),Int_val(m),tt,false);
+ oct_mm_free(tt);
+ CAMLreturn(Val_oct(r));
+}
+
+CAMLprim value
+ocaml_oct_permute_remove_dimensions (value n, value m, value t)
+{
+ CAMLparam3(n,m,t);
+ oct_t* r;
+ var_t* tt,i,sz=Wosize_val(t);
+ if (Oct_val(n)->n!=sz)
+ failwith("ocaml_oct_permute_remove_dimensions: invalid permutation dimension");
+ tt = new_n(var_t,sz);
+ for (i=0;i<sz;i++) tt[i] = Int_val(Field(t,i));
+ r = oct_permute_remove_dimensions(Oct_val(n),Int_val(m),tt,false);
+ oct_mm_free(tt);
+ CAMLreturn(Val_oct(r));
+}
+
+CAMLprim value
+ocaml_oct_print (value m)
+{
+ CAMLparam1(m);
+ fflush(stdout);
+ oct_print(Oct_val(m));
+ fflush(stdout);
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value
+ocaml_oct_close (value m)
+{
+ CAMLparam1(m);
+ CAMLreturn(Val_oct(oct_close(Oct_val(m),false,false)));
+}
+
+CAMLprim value
+ocaml_oct_from_box (value m)
+{
+ CAMLparam1(m);
+ CAMLreturn(Val_oct(oct_from_box(Vnum_val(m)->nb/2,Vnum_val(m)->n)));
+}
+
+CAMLprim value
+ocaml_oct_get_box (value m)
+{
+ CAMLparam1(m);
+ CAMLlocal1(r);
+ r = alloc_custom(&ocaml_vnum_custom,sizeof(vnum_t),0,1);
+ Vnum_val(r)->nb = Oct_val(m)->n*2;
+ Vnum_val(r)->n = oct_get_box (Oct_val(m));;
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_oct_set_bounds (value m, value i, value t)
+{
+ CAMLparam3(m,i,t);
+ CAMLreturn(Val_oct(oct_set_bounds(Oct_val(m),Int_val(i),
+ Num_val(Field(t,0)), Num_val(Field(t,1)),
+ false)));
+}
+
+CAMLprim value
+ocaml_oct_get_bounds (value m, value i)
+{
+ CAMLparam2(m,i);
+ CAMLlocal1(r);
+ r = alloc_tuple(2);
+ Store_field(r,0,alloc_custom(&ocaml_num_custom,sizeof(num_t),0,1));
+ Store_field(r,1,alloc_custom(&ocaml_num_custom,sizeof(num_t),0,1));
+ num_init(Num_val(Field(r,0))); num_init(Num_val(Field(r,1)));
+ oct_get_bounds(Oct_val(m),Int_val(i),
+ Num_val(Field(r,0)),Num_val(Field(r,1)));
+ CAMLreturn(r);
+}
+
+
+CAMLprim value
+ocaml_oct_add_epsilon (value m, value n)
+{
+ CAMLparam2(m,n);
+ CAMLreturn(Val_oct(oct_add_epsilon(Oct_val(m),Num_val(n),false)));
+}
+
+CAMLprim value
+ocaml_oct_add_epsilon_max (value m, value n)
+{
+ CAMLparam2(m,n);
+ CAMLreturn(Val_oct(oct_add_epsilon_max(Oct_val(m),Num_val(n),false)));
+}
+
+CAMLprim value
+ocaml_oct_add_epsilon_bin (value m, value n, value o)
+{
+ CAMLparam3(m,n,o);
+ CAMLreturn(Val_oct(oct_add_epsilon_bin(Oct_val(m),Oct_val(n),Num_val(o),
+ false)));
+}
+
+
+CAMLprim value ocaml_oct_time_flow (value m, value min, value max,
+ value tab)
+{
+ CAMLparam4(m,min,max,tab);
+ if (Vnum_val(tab)->nb!=2*Oct_val(m)->n)
+ failwith("ocaml_oct_time_flow: incompatible dimensions");
+ CAMLreturn(Val_oct(oct_time_flow(Oct_val(m),Num_val(min),Num_val(max),
+ Vnum_val(tab)->n,false)));
+}
+
+
+/* minimized octagons management */
+
+void
+ocaml_oct_m_finalize (value o)
+{
+ oct_m_free(Moct_val(o));
+}
+
+void
+ocaml_oct_m_serialize (value a, unsigned long * w32, unsigned long * w64)
+{
+ size_t size;
+ char* data = oct_m_serialize(Moct_val(a),&size);
+ serialize_int_8(size);
+ serialize_block_1(data,size);
+ *w32=4;
+ *w64=8;
+ oct_mm_free(data);
+}
+
+unsigned long
+ocaml_oct_m_deserialize (void * dst)
+{
+ size_t size;
+ void* data;
+ size = deserialize_uint_8();
+ data = new_n(char,size);
+ deserialize_block_1(data,size);
+ *((moct_t**)dst) = oct_m_deserialize(data);
+ oct_mm_free(data);
+ return(sizeof(moct_t*));
+}
+
+struct custom_operations ocaml_moct_custom = {
+ "o_m@1",
+ ocaml_oct_m_finalize ,
+ custom_compare_default,
+ custom_hash_default,
+ ocaml_oct_m_serialize,
+ ocaml_oct_m_deserialize
+};
+
+inline
+CAMLprim value
+Val_moct (const moct_t* o)
+{
+ CAMLparam0();
+ CAMLlocal1(v);
+ v = alloc_custom(&ocaml_moct_custom,sizeof(moct_t*),0,1);
+ Moct_val(v) = (moct_t*)o;
+ CAMLreturn(v);
+}
+
+/* functions */
+
+
+CAMLprim value
+ocaml_oct_m_from_oct (value m)
+{
+ CAMLparam1(m);
+ CAMLreturn(Val_moct(oct_m_from_oct(Oct_val(m))));
+}
+
+CAMLprim value
+ocaml_oct_m_to_oct (value m)
+{
+ CAMLparam1(m);
+ CAMLreturn(Val_oct(oct_m_to_oct(Moct_val(m))));
+}
+
+CAMLprim value
+ocaml_oct_m_print (value m)
+{
+ CAMLparam1(m);
+ fflush(stdout);
+ oct_m_print(Moct_val(m));
+ fflush(stdout);
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value
+ocaml_oct_m_dim (value m)
+{
+ CAMLparam1(m);
+ CAMLreturn(Val_int(oct_m_dimension(Moct_val(m))));
+}
+
+CAMLprim value
+ocaml_oct_m_is_empty (value m)
+{
+ CAMLparam1(m);
+ CAMLreturn(Val_bool(oct_m_is_empty(Moct_val(m))));
+}
+
+CAMLprim value
+ocaml_oct_m_is_equal (value n, value m)
+{
+ CAMLparam2(n,m);
+ CAMLreturn(Val_bool(oct_m_is_equal(Moct_val(n),Moct_val(m))));
+}
+
+CAMLprim value
+ocaml_oct_m_get_elem (value m, value i, value j)
+{
+ CAMLparam3(m,i,j);
+ CAMLlocal1(r);
+ r = alloc_custom(&ocaml_num_custom,sizeof(num_t),0,1);
+ num_init_set(Num_val(r),oct_m_elem(Moct_val(m),Int_val(i),Int_val(j)));
+ CAMLreturn(r);
+}
+
+
+/* used pretty-printing, not intended for the user, only for octprinter */
+
+CAMLprim value
+ocaml_oct_elem_to_string (value m, value i, value j)
+{
+ char buf[4096];
+ int ii,jj;
+ num_t* c;
+ CAMLparam3(m,i,j);
+ CAMLlocal1(r);
+ ii = Int_val(i);
+ jj = Int_val(j);
+ c = oct_elem(Oct_val(m),ii,jj);
+ if (num_infty(c)) r = Val_int(0);
+ else {
+ r = alloc_tuple(1);
+ num_snprint (buf,4095,c);
+ Store_field (r,0,copy_string (buf));
+ }
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_oct_elem_to_string2 (value m, value i, value j, value s)
+{
+ char buf[4096*3+20];
+ int ii,jj;
+ num_t *cp, *cm;
+ num_t c;
+ CAMLparam4(m,i,j,s);
+ CAMLlocal1(r);
+ ii = Int_val(i);
+ jj = Int_val(j);
+ cp = oct_elem(Oct_val(m),ii,jj);
+ cm = oct_elem(Oct_val(m),jj,ii);
+ num_init(&c);
+ if (num_infty(cp) && num_infty(cm)) r = Val_int(0);
+ else if (num_infty(cm)) {
+ strncpy(buf,String_val(s),4096);
+ strcat(buf," <= ");
+ if ((ii^1)==jj) num_div_by_2(&c,cp); else num_set(&c,cp);
+ num_snprint (buf+strlen(buf),4096,&c);
+ r = alloc_tuple(1);
+ Store_field (r,0,copy_string (buf));
+ }
+ else if (num_infty(cp)) {
+ strncpy(buf,String_val(s),4096);
+ strcat(buf," >= ");
+ num_neg(&c,cm);
+ if ((ii^1)==jj) num_div_by_2(&c,&c);
+ num_snprint (buf+strlen(buf),4096,&c);
+ r = alloc_tuple(1);
+ Store_field (r,0,copy_string (buf));
+ }
+ else {
+ num_neg(&c,cm);
+ if (!num_cmp(&c,cp)) {
+ strncpy(buf,String_val(s),4096);
+ strcat(buf," = ");
+ if ((ii^1)==jj) num_div_by_2(&c,cp); else num_set(&c,cp);
+ num_snprint (buf+strlen(buf),4096,&c);
+ r = alloc_tuple(1);
+ Store_field (r,0,copy_string (buf));
+ }
+ else {
+ num_neg(&c,cm);
+ if ((ii^1)==jj) num_div_by_2(&c,&c);
+ num_snprint (buf,4096,&c);
+ strcat(buf," <= ");
+ strncat(buf,String_val(s),4096);
+ strcat(buf," <= ");
+ if ((ii^1)==jj) num_div_by_2(&c,cp); else num_set(&c,cp);
+ num_snprint (buf+strlen(buf),4096,&c);
+ r = alloc_tuple(1);
+ Store_field (r,0,copy_string (buf));
+ }
+ }
+ num_clear (&c);
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_oct_get_state (value m)
+{
+ CAMLparam1(m);
+ CAMLreturn(Val_int(Oct_val(m)->state));
+}
+
+CAMLprim value
+ocaml_oct_melem_to_string (value m, value i, value j)
+{
+ char buf[4096];
+ int ii,jj;
+ num_t* c;
+ CAMLparam3(m,i,j);
+ CAMLlocal1(r);
+ ii = Int_val(i);
+ jj = Int_val(j);
+ c = oct_m_elem(Moct_val(m),ii,jj);
+ if (!c || num_infty(c)) r = Val_int(0);
+ else {
+ r = alloc_tuple(1);
+ num_snprint (buf,4095,c);
+ Store_field (r,0,copy_string (buf));
+ }
+ CAMLreturn(r);
+}
+
+
+CAMLprim value
+ocaml_oct_melem_to_string2 (value m, value i, value j, value s)
+{
+ char buf[4096*3+20];
+ int ii,jj;
+ num_t *cp,*cm;
+ num_t c;
+ CAMLparam4(m,i,j,s);
+ CAMLlocal1(r);
+ ii = Int_val(i);
+ jj = Int_val(j);
+ cp = oct_m_elem(Moct_val(m),ii,jj);
+ cm = oct_m_elem(Moct_val(m),jj,ii);
+ num_init(&c);
+ if ((!cp || num_infty(cp)) && (!cm || num_infty(cm))) r = Val_int(0);
+ else if (!cm || num_infty(cm)) {
+ strncpy(buf,String_val(s),4096);
+ strcat(buf," <= ");
+ if ((ii^1)==jj) num_div_by_2(&c,cp); else num_set(&c,cp);
+ num_snprint (buf+strlen(buf),4096,&c);
+ r = alloc_tuple(1);
+ Store_field (r,0,copy_string (buf));
+ }
+ else if (!cp || num_infty(cp)) {
+ strncpy(buf,String_val(s),4096);
+ strcat(buf," >= ");
+ num_neg(&c,cm);
+ if ((ii^1)==jj) num_div_by_2(&c,&c);
+ num_snprint (buf+strlen(buf),4096,&c);
+ r = alloc_tuple(1);
+ Store_field (r,0,copy_string (buf));
+ }
+ else {
+ num_neg(&c,cm);
+ if (!num_cmp(&c,cp)) {
+ strncpy(buf,String_val(s),4096);
+ strcat(buf," = ");
+ if ((ii^1)==jj) num_div_by_2(&c,cp); else num_set(&c,cp);
+ num_snprint (buf+strlen(buf),4096,&c);
+ r = alloc_tuple(1);
+ Store_field (r,0,copy_string (buf));
+ }
+ else {
+ num_neg(&c,cm);
+ if ((ii^1)==jj) num_div_by_2(&c,&c);
+ num_snprint (buf,4096,&c);
+ strcat(buf," <= ");
+ strncat(buf,String_val(s),4096);
+ strcat(buf," <= ");
+ if ((ii^1)==jj) num_div_by_2(&c,cp); else num_set(&c,cp);
+ num_snprint (buf+strlen(buf),4096,&c);
+ r = alloc_tuple(1);
+ Store_field (r,0,copy_string (buf));
+ }
+ }
+ num_clear (&c);
+ CAMLreturn(r);
+}
+
+CAMLprim value
+ocaml_oct_memprint (value v)
+{
+ CAMLparam1(v);
+ oct_mmalloc_print(oct_mmalloc_get_current());
+ CAMLreturn(Val_unit);
+}
+
+
+CAMLprim value
+ocaml_oct_timeprint (value v)
+{
+ CAMLparam1(v);
+ oct_timing_print_all ();
+ CAMLreturn(Val_unit);
+}
+
+/* New Polka interface */
+
+#ifdef OCT_HAS_OCAML_NEW_POLKA
+
+#include <polka_caml.h>
+
+CAMLprim value
+ocaml_oct_from_poly (value v)
+{
+ CAMLparam1(v);
+ poly_t* p;
+ camlidl_polka_poly_ml2c(v,&p);
+ CAMLreturn(Val_oct(oct_from_poly(p)));
+}
+
+CAMLprim value
+ocaml_oct_to_poly (value v)
+{
+ CAMLparam1(v);
+ poly_t* p = oct_to_poly(Oct_val(v));
+ CAMLreturn(camlidl_polka_poly_c2ml(&p));
+}
+
+#else
+
+CAMLprim void
+ocaml_oct_from_poly (value v)
+{
+ CAMLparam1(v);
+ failwith ("ocaml_oct_from_poly: New Polka library support not enabled");
+ CAMLreturn0;
+}
+
+CAMLprim void
+ocaml_oct_to_poly (value v)
+{
+ CAMLparam1(v);
+ failwith ("ocaml_oct_to_poly: New Polka library support not enabled");
+ CAMLreturn0;
+}
+
+#endif
+
+
+
+CAMLprim value
+ocaml_oct_init (value dummy)
+{
+ CAMLparam1(dummy);
+#ifdef OCT_NUM_SERIALIZE
+ register_custom_operations(&ocaml_num_custom);
+ register_custom_operations(&ocaml_vnum_custom);
+ register_custom_operations(&ocaml_oct_custom);
+ register_custom_operations(&ocaml_moct_custom);
+#endif
+ CAMLreturn(oct_init() ? Val_int(1) : Val_int(0));
+}
--- /dev/null
+/* oct_ocaml.h
+ Include this to access to OCaml wrappers for the C library data-structures.
+
+ This file is part of the Octagon Abstract Domain Library.
+ Please read the COPYING file packaged in the distribution.
+ Main web page is: http://www.di.ens.fr/~mine/oct/
+
+ Copyright (C) Antoine Mine' 2000-2002
+ */
+
+#ifndef OCT_OCAMLH__
+#define OCT_OCAMLH__
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/custom.h>
+
+#include <oct.h>
+#include <oct_private.h>
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* value <-> num_t conversion */
+
+typedef struct /* array of num_t */
+{
+ size_t nb;
+ num_t* n;
+} vnum_t;
+
+#define Num_val(v) ((num_t*)Data_custom_val(v)) /* v: Oct.num */
+#define Vnum_val(v) ((vnum_t*)Data_custom_val(v)) /* v: Oct.vnum */
+
+/* value <-> oct_t conversion */
+#define Oct_val(v) (*((oct_t**)Data_custom_val(v))) /* v: Oct.oct */
+value Val_oct (const oct_t* o); /* Return a *new* value containing o */
+
+/* value <-> moct_t conversion */
+#define Moct_val(v) (*((moct_t**)Data_custom_val(v))) /* v: Oct.moct */
+value Val_moct (const moct_t* o); /* Return a *new* value containing o */
+
+/* Use Int_val / Val_int to convert objects of type
+ tbool_t / Oct.tbool,
+ oct_widening_type / Oct.wident
+*/
+
+
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
--- /dev/null
+/* oct_private.h
+ Include this in order to access to low-level octagon data structures.
+
+ This file is part of the Octagon Abstract Domain Library.
+ Please read the COPYING file packaged in the distribution.
+ Main web page is: http://www.di.ens.fr/~mine/oct/
+
+ Copyright (C) Antoine Mine' 2000-2002
+ */
+#ifndef OCT_PRIVATE_H__
+#define OCT_PRIVATE_H__
+
+#include <oct.h>
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+
+/* Shortcuts */
+/* --------- */
+
+#define oct_alloc OCT_PROTO(alloc)
+#define oct_full_copy OCT_PROTO(full_copy)
+#define oct_close OCT_PROTO(close)
+#define oct_is_closed OCT_PROTO(is_closed)
+#define oct_close_lazy OCT_PROTO(close_lazy)
+#define oct_check_closed OCT_PROTO(check_closed)
+#define oct_m_elem OCT_PROTO(m_elem)
+#define oct_close_incremental OCT_PROTO(close_incremental)
+
+
+/************/
+/* Octagons */
+/************/
+
+/*
+ Unlike the presentation of the article "The Octagonal Abstract Domain",
+ there is no redundancy in the internal representation of the invariants.
+ This is achevied by storing m[i][j] only if i>=j or i=j^1.
+ There is no loss of information because, by coherence, m[j^1][i^1]=m[i][j].
+ In memory, the matrix has approximately the form of a triangle:
+
+ j -> 0 1 2 3 4 5
+ ___
+ 0 |_|_|
+ 1 |_|_|___
+ i -> 2 |_|_|_|_|
+ 3 |_|_|_|_|___
+ 4 |_|_|_|_|_|_|
+ 5 |_|_|_|_|_|_|
+
+ In the following we will use the term 'matrix' even if the representation
+ no longer has a matrix form.
+ The elements are stored in a flat array with m[i][j] beeing stored in
+ c[j+((i+1)*(i+1))/2].
+
+ There is no longer an emptyness test as emptyness is tested during the
+ closure.
+
+ Memory managment is a little complex in order to avoid unnecessary copy,
+ closure or emptyness checking.
+ All operators come in 2 forms: a copy form that protects all arguments,
+ and a in-place form that destroys the arguments and is more efficient.
+ There is also reference counting so that copy versions of operators can
+ return the one of the argument without having to copy it (union when one
+ argument is empty, for example).
+ This results in a lazy copy-on-write policy saying that we must perform
+ an actual copy only when modifing in-place a matrix that have a
+ reference count > 1.
+ The last mechanism is remembering of closure form. When the argument of
+ an operator must be closed, but must stay accessible in its original form
+ (either we use the copy form of the operator, or the argument has a
+ reference count > 1); we keep the closed form in memory and add a pointer
+ from the original unchanged argument to its closed form we just computed.
+ If the arguement is used again with an operator requiring the normal form,
+ the stored form is reused and no extra closure algorithm is performed.
+ (this mechanism can be turned off manually if we are short of memory,
+ this can result in time inefficiency).
+
+*/
+
+/* nb of elements in a matrix with n variables */
+#define matsize(n) (2*(size_t)(n)*((size_t)(n)+1))
+
+/* xj - xi <= m->c[matpos(i,j)], if j/2 <= i/2 */
+#define matpos(i,j) ((size_t)(j)+(((size_t)(i)+1)*((size_t)(i)+1))/2)
+
+/* xj - xi <= m->c[matpos2(i,j)] for all i,j */
+#define matpos2(i,j) ((j)>(i)?matpos(((j)^1),((i)^1)):matpos(i,j))
+
+/* state of a matrix representing an octagon */
+typedef enum {
+ OCT_EMPTY = 0, /* empty domain */
+ OCT_NORMAL = 1,
+ OCT_CLOSED = 2
+} oct_state;
+
+
+/* octagon data structure */
+struct oct_tt {
+ var_t n; /* number of variables, aka dimension */
+
+ int ref; /* reference counting */
+
+ oct_state state; /* is it empty, closed, etc. ? */
+ struct oct_tt* closed; /* pointer to the closed version, or NULL */
+
+ num_t* c; /* the matrix, contains matsize(n) elements */
+};
+
+/* private because not really useful for user */
+oct_t* OCT_PROTO(alloc) (var_t n); /* c allocated but not initialized */
+oct_t* OCT_PROTO(full_copy) (oct_t* m); /* new copy with ref=1 */
+
+/* strong closure */
+oct_t* OCT_PROTO(close) (oct_t* m, bool destructive, bool cache);
+bool OCT_PROTO(is_closed) (oct_t* m);
+oct_t* OCT_PROTO(close_lazy) (oct_t* m, bool destructive);
+
+bool OCT_PROTO(check_closed) (const oct_t* m, bool quiet); /* for debugging purpose */
+void OCT_PROTO(close_incremental) (oct_t* m, var_t v);
+
+
+/* low-level access to an element
+ get the element m[i][j] */
+static inline
+num_t*
+oct_elem (oct_t* m,
+ var_t i,
+ var_t j)
+{
+ OCT_ASSERT(m->c,"matrix not allocated in oct_elem");
+ OCT_ASSERT(i<2*m->n && j<2*m->n,"invalid index in oct_elem");
+ return m->c+matpos2(i,j);
+}
+
+
+/* Octagon in hollow form,
+ cannot be modified in-place !
+*/
+
+struct moct_tt {
+ var_t n; /* number of variables */
+
+ size_t* bol; /* begin-of-line indices, array of n*2+1 indices */
+ var_t* col; /* column indices, array of bol[n*2] elements */
+ num_t* data; /* constraint array of bol[n*2] elements */
+ /* data[i] contains the original matrix element at position
+ col[i],
+ line l, such that bol[l] <= i < bol[l+1]
+ */
+ /* all fields are NULL if the octagon is empty */
+};
+
+
+/* no direct access, O(log n) time cost */
+num_t* OCT_PROTO(m_elem) (moct_t* a, var_t i, var_t j);
+
+
+/**********/
+/* Memory */
+/**********/
+
+/* a memory monitor */
+struct mmalloc_tt
+{
+ int id; /* incremented after a reset */
+
+ int nb_alloc; /* nb of calls to malloc */
+ int nb_realloc; /* nb of calls to realloc */
+ int nb_free; /* nb of calls to free */
+
+ size_t rem; /* memory consumption */
+ size_t max; /* max memory consumption */
+ size_t tot; /* total allocated */
+
+};
+
+
+
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
--- /dev/null
+/* oct_sem.c
+ Semantics abstract functions.
+
+ This file is part of the Octagon Abstract Domain Library.
+ Please read the COPYING file packaged in the distribution.
+ Main web page is: http://www.di.ens.fr/~mine/oct/
+
+ Copyright (C) Antoine Mine' 2000-2002
+ */
+
+#include <oct.h>
+#include <oct_private.h>
+
+/* define to use simplified closure / incremental closure */
+#undef BHMZ05
+
+/*******************/
+/* Initialization */
+/*******************/
+
+
+#if defined(__FreeBSD__) || defined(sun)
+
+#include <ieeefp.h>
+static int init_fpu()
+{ fpsetround(FP_RP); /*fpsetmask(fpgetmask()|FP_X_INV); */ return 1; }
+
+#elif defined(linux)
+
+#include <fenv.h>
+static int init_fpu()
+{ return !fesetround(FE_UPWARD) /*&& feenableexcept(FE_INVALID)!=-1*/; }
+
+#elif defined(__ppc__)
+
+static int init_fpu() {
+ asm volatile ("mtfsfi 7,2");
+ /* asm volatile ("mtfsb1 24"); */
+ return 1;
+}
+
+#else
+
+static int init_fpu() { fprintf(stderr,"Octagon Library Warning: don't know how top set the FPU rounding mode.\n"); return 0; }
+
+#endif
+
+
+
+int
+OCT_PROTO(init) ()
+{
+#if defined(OCT_NUM_FLOAT) || defined(OCT_NUM_LONGDOUBLE)
+ return init_fpu();
+#else
+ return 1;
+#endif
+}
+
+
+/********************************/
+/* Octagon Creation/Destruction */
+/********************************/
+
+/* empty domain, c is not allocated */
+inline
+oct_t*
+OCT_PROTO(empty) (const var_t n)
+{
+ oct_t* m;
+ OCT_ENTER("oct_empty",3);
+ m = new_t(oct_t);
+ m->n = n;
+ m->ref = 1;
+ m->state = OCT_EMPTY;
+ m->closed = (oct_t*)NULL;
+ m->c = (num_t*)NULL;
+ OCT_EXIT("oct_empty",3);
+ return m;
+}
+
+/* constraints not initialized, it returns an INVALID matrix */
+inline
+oct_t*
+OCT_PROTO(alloc) (const var_t n)
+{
+ size_t nn = matsize(n);
+ oct_t* m;
+ m = oct_empty(n);
+ m->c = new_n(num_t,nn);
+ num_init_n(m->c,nn);
+ m->state = OCT_NORMAL;
+ m->closed = (oct_t*)NULL;
+ return m;
+}
+
+/* all constraints are set to +infty, (except m[i][i]=0) */
+inline
+oct_t*
+OCT_PROTO(universe) (const var_t n)
+{
+ oct_t* m;
+ size_t i, nn = matsize(n);
+ OCT_ENTER("oct_universe",4);
+ m = oct_alloc(n);
+ for (i=0;i<nn;i++) num_set_infty(m->c+i);
+ for (i=0;i<2*n;i++) num_set_int(m->c+matpos(i,i),0);
+ m->state = OCT_CLOSED;
+ OCT_EXIT("oct_universe",4);
+ return m;
+}
+
+/* full copy, except new ref is 1 (oct_copy is preferred for lazy copy) */
+inline
+oct_t*
+OCT_PROTO(full_copy) (oct_t* mm)
+{
+ oct_t* m;
+ OCT_ENTER("oct_full_copy",5);
+ m = oct_empty(mm->n);
+ m->state = mm->state;
+ m->closed = mm->closed;
+ if (m->closed) m->closed->ref++;
+ if (mm->c) {
+ const size_t nn = matsize(mm->n);
+ m->c = new_n(num_t,nn);
+ num_init_set_n(m->c,mm->c,nn);
+ }
+ else m->c = (num_t*)NULL;
+ OCT_EXIT("oct_full_copy",5);
+ return m;
+}
+
+/* just add one to ref count */
+inline
+oct_t*
+OCT_PROTO(copy) (oct_t* m)
+{
+ m->ref++;
+ return m;
+}
+
+/* really free if ref count reaches 0 */
+inline
+void
+OCT_PROTO(free) (oct_t* m)
+{
+ m->ref--;
+ if (!m->ref) {
+ if (m->closed) {
+ m->closed->ref--;
+ if (!m->closed->ref) { /* free cached closed version */
+ if (m->closed->c)
+ { num_clear_n(m->closed->c,matsize(m->n)); oct_mm_free(m->closed->c); }
+ oct_mm_free(m->closed);
+ }
+ }
+ if (m->c) { num_clear_n(m->c,matsize(m->n)); oct_mm_free(m->c); }
+ oct_mm_free(m);
+ }
+}
+
+
+/*******************/
+/* Query Functions */
+/*******************/
+
+/* number of variables */
+inline
+var_t
+OCT_PROTO(dimension) (oct_t* m)
+{
+ return m->n;
+}
+
+size_t
+OCT_PROTO(nbconstraints) (oct_t* m)
+{
+ const size_t nn = matsize(m->n);
+ size_t i;
+ size_t n = 0;
+ num_t* c = m->c;
+ OCT_ENTER("oct_nbconstraints",6);
+ if (m->state==OCT_EMPTY) return 0;
+ for (i=0;i<nn;i++,c++)
+ if (!num_infty(c)) n++;
+ OCT_EXIT("oct_nbconstraints",6);
+ return n-2*m->n; /* remove the 2n constraints of the form x_i-x_i<=0 */
+}
+
+
+/******************/
+/* Strong Closure */
+/******************/
+
+
+/*
+ strong closure algorithm.
+ returns either a CLOSED matrix, or an EMPTY matrix
+ if destructive!=0, the argument is freed and may not be used anymore
+ the closure is cached in m->cached if cache=1
+ O(n^3) time complexity
+ O(n) space complexity (no temporary matrix created!)
+*/
+
+
+#ifndef BHMZ05 /* original version */
+
+oct_t*
+OCT_PROTO(close) (oct_t* m,
+ bool destructive,
+ bool cache)
+{
+ var_t i,j,k;
+ oct_t* mm;
+ const var_t n2 = m->n*2;
+ num_t *buf1, *buf2;
+ num_t kk1,kk2,ik1,ik2,ij1,ij2,ij3,ij4;
+
+ OCT_ENTER("oct_close",48);
+ /* already closed or empty, we have nothing to do */
+ if (m->state==OCT_CLOSED || m->state==OCT_EMPTY) {
+ if (destructive) mm=m; else mm = oct_copy(m);
+ goto end2;
+ }
+
+ /* closed form is cached, we have nothing to do */
+ if (m->closed) {
+ mm = oct_copy(m->closed);
+ if (destructive) oct_free(m);
+ goto end2;
+ }
+
+ if (destructive)
+ if (m->ref==1) mm = m;
+ else { mm = oct_full_copy(m); m->ref--; }
+ else mm = oct_full_copy(m);
+ if (cache && m!=mm) m->closed = oct_copy(mm);
+
+ OCT_ENTER("oct_really_close",49);
+ /* these buffers avoid a temporary matrix to be created
+ they can also speed up the computation if they stay in the CPU cache!
+ */
+ buf1 = new_n(num_t,n2); buf2 = new_n(num_t,n2);
+ num_init_n(buf1,n2); num_init_n(buf2,n2);
+ num_init(&kk1); num_init(&kk2);
+ num_init(&ik1); num_init(&ik2);
+ num_init(&ij1); num_init(&ij2); num_init(&ij3); num_init(&ij4);
+
+ for (k=0;k<n2;k+=2) {
+
+ /* Ck step */
+
+ num_t* d = mm->c; /* xj-xi */
+ num_set(&kk1,mm->c+matpos(k+1,k)); /* xk+xk */
+ num_set(&kk2,mm->c+matpos(k,k+1)); /* -xk-xk */
+
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ for (i=0;i<=k;i+=2) {
+ num_set(buf1+i ,mm->c+matpos(k+1,i+1)); /* -xi+xk */
+ num_set(buf2+i ,mm->c+matpos(k ,i+1)); /* -xi-xk */
+ num_set(buf1+i+1,mm->c+matpos(k+1,i )); /* xi+xk */
+ num_set(buf2+i+1,mm->c+matpos(k ,i )); /* xi-xk */
+ }
+ for (;i<n2;i+=2) {
+ num_set(buf1+i ,mm->c+matpos(i ,k )); /* xk-xi */
+ num_set(buf2+i ,mm->c+matpos(i ,k+1)); /* -xk-xi */
+ num_set(buf1+i+1,mm->c+matpos(i+1,k )); /* xk+xi */
+ num_set(buf2+i+1,mm->c+matpos(i+1,k+1)); /* -xk+xi */
+ }
+
+ for (i=0;i<n2;i++) {
+ const var_t ii = i|1;
+ num_add(&ik1,buf2+i,&kk1); /* (-xk-xi) + ( xk+xk) */
+ num_add(&ik2,buf1+i,&kk2); /* ( xk-xi) + (-xk-xk) */
+ for (j=0;j<=ii;j++,d++) {
+ var_t jj = j^1;
+ num_add(&ij1,buf1+i,buf2+jj); num_add(&ij2,&ik1,buf2+jj);
+ num_add(&ij3,buf2+i,buf1+jj); num_add(&ij4,&ik2,buf1+jj);
+ num_min(&ij1,&ij1,&ij2); num_min(&ij3,&ij3,&ij4);
+ num_min(&ij1,&ij1,&ij3);
+ num_min(d,d,&ij1);
+ }
+ }
+
+ /* S step */
+
+ d = mm->c; /* xj-xi */
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+
+ for (i=0;i<n2;i+=2) {
+ num_div_by_2(buf1+i, mm->c+matpos(i+1,i)); /* ( xi+xi)/2 */
+ num_div_by_2(buf1+i+1,mm->c+matpos(i,i+1)); /* (-xi-xi)/2 */
+ }
+
+ for (i=0;i<n2;i++) {
+ const var_t ii = i|1;
+ const var_t ii2 = i^1;
+ for (j=0;j<=ii;j++,d++) {
+ num_add(&ij1,buf1+j,buf1+ii2);
+ num_min(d,d,&ij1);
+ }
+ }
+
+ /* emptyness checking */
+ for (i=0;i<n2;i+=2)
+ if (num_cmp_zero(mm->c+matpos(i,i))<0) {
+ mm->state = OCT_EMPTY;
+ num_clear_n(mm->c,matsize(mm->n));
+ oct_mm_free(mm->c); mm->c = (num_t*)NULL;
+ goto end;
+ }
+ }
+
+ mm->state = OCT_CLOSED;
+ end:
+ num_clear(&kk1); num_clear(&kk2);
+ num_clear(&ik1); num_clear(&ik2);
+ num_clear(&ij1); num_clear(&ij2); num_clear(&ij3); num_clear(&ij4);
+ num_clear_n(buf1,n2); num_clear_n(buf2,n2);
+ oct_mm_free(buf1); oct_mm_free(buf2);
+ OCT_EXIT("oct_really_close",49);
+ end2:
+ OCT_EXIT("oct_close",48);
+ return mm;
+}
+
+#else /* optimized algorithm from BHMZ05 (constant factor improvement) */
+
+oct_t*
+OCT_PROTO(close) (oct_t* m,
+ bool destructive,
+ bool cache)
+{
+ var_t i,j,k;
+ oct_t* mm;
+ const var_t n2 = m->n*2;
+ num_t *c,ik,ik2,ij;
+
+ OCT_ENTER("oct_close",48);
+ /* already closed or empty, we have nothing to do */
+ if (m->state==OCT_CLOSED || m->state==OCT_EMPTY) {
+ if (destructive) mm=m; else mm = oct_copy(m);
+ goto end2;
+ }
+
+ /* closed form is cached, we have nothing to do */
+ if (m->closed) {
+ mm = oct_copy(m->closed);
+ if (destructive) oct_free(m);
+ goto end2;
+ }
+
+ if (destructive)
+ if (m->ref==1) mm = m;
+ else { mm = oct_full_copy(m); m->ref--; }
+ else mm = oct_full_copy(m);
+ if (cache && m!=mm) m->closed = oct_copy(mm);
+
+ OCT_ENTER("oct_really_close_BHMZ05",49);
+
+ num_init(&ik); num_init(&ik2); num_init(&ij);
+
+ /* Floyd-Warshall */
+ for (k=0;k<n2;k++) {
+ const var_t k2 = k^1;
+ c = mm->c;
+ for (i=0;i<n2;i++) {
+ const var_t i2 = i|1;
+ const var_t br = k<i2 ? k : i2;
+ num_set(&ik,mm->c+matpos2(i,k));
+ num_set(&ik2,mm->c+matpos2(i,k2));
+ for (j=0;j<=br;j++,c++) {
+ num_add(&ij,&ik,mm->c+matpos(k,j)); /* ik+kj */
+ num_min(c,c,&ij);
+ num_add(&ij,&ik2,mm->c+matpos(k2,j)); /* ik2+k2j */
+ num_min(c,c,&ij);
+ }
+ for (;j<=i2;j++,c++) {
+ num_add(&ij,&ik,mm->c+matpos(j^1,k2)); /* ik+kj */
+ num_min(c,c,&ij);
+ num_add(&ij,&ik2,mm->c+matpos(j^1,k)); /* ik2+k2j */
+ num_min(c,c,&ij);
+ }
+ }
+
+ }
+
+ /* lone S step */
+ c = mm->c;
+ for (i=0;i<n2;i++) {
+ const var_t i2 = i|1;
+ num_div_by_2(&ij,mm->c+matpos(i,i^1));
+ for (j=0;j<=i2;j++,c++) {
+ num_div_by_2(&ik,mm->c+matpos(j^1,j)); /* (ii2+j2j)/2 */
+ num_add(&ik,&ik,&ij);
+ num_min(c,c,&ik);
+ }
+ }
+
+ /* emptyness checking */
+ for (i=0;i<n2;i++) {
+ c = mm->c+matpos(i,i);
+ if (num_cmp_zero(c)<0) {
+ mm->state = OCT_EMPTY;
+ num_clear_n(mm->c,matsize(mm->n));
+ oct_mm_free(mm->c); mm->c = (num_t*)NULL;
+ goto end;
+ }
+ else num_set_int(c,0);
+ }
+
+ mm->state = OCT_CLOSED;
+ end:
+ num_clear(&ik); num_clear(&ik2); num_clear(&ij);
+ OCT_EXIT("oct_really_close_BHMZ05",49);
+ end2:
+ OCT_EXIT("oct_close",48);
+ return mm;
+}
+
+#endif
+
+
+/* returns the closure of m if it is available without computation,
+ and m elsewhere
+ null cost
+*/
+inline
+oct_t*
+OCT_PROTO(close_lazy) (oct_t* m,
+ bool destructive)
+{
+ oct_t* r;
+ OCT_ENTER("oct_close_lazy",8);
+ if (m->closed) {
+ r = oct_copy(m->closed);
+ if (destructive) oct_free(m);
+ }
+ else if (destructive) r = m;
+ else r = oct_copy(m);
+ OCT_EXIT("oct_close_lazy",8);
+ return r;
+}
+
+inline
+bool
+OCT_PROTO(is_closed) (oct_t* m)
+{
+ return (m->state==OCT_CLOSED || m->state==OCT_EMPTY)?true:false;
+}
+
+
+/*
+ incremental version of the closure
+ the argument matrix must be almost closed, ie, it must be a closed
+ matrix except the constraints involving variable v
+ always destructive, modify its argument in-place
+ O(n^2) time complexity
+*/
+
+#ifndef BHMZ05 /* original version */
+
+inline
+void
+OCT_PROTO(close_incremental) (oct_t* m,
+ var_t v)
+{
+ var_t i,j,k;
+ const var_t n2 = m->n*2;
+ const var_t v2 = v*2;
+ num_t *buf1, *buf2;
+ num_t kk1,kk2,ik1,ik2,ij1,ij2,ij3,ij4;
+
+ OCT_ENTER("oct_close_incremental",9);
+ OCT_ASSERT(v<m->n,"variable index greater than the number of variables in oct_close_incremental");
+ if (m->state==OCT_EMPTY) goto end2;
+
+ buf1 = new_n(num_t,n2); buf2 = new_n(num_t,n2);
+ num_init_n(buf1,n2); num_init_n(buf2,n2);
+ num_init(&kk1); num_init(&kk2);
+ num_init(&ik1); num_init(&ik2);
+ num_init(&ij1); num_init(&ij2); num_init(&ij3); num_init(&ij4);
+
+ /* try to reduce xv coefficients using xk coefficients */
+ OCT_ENTER("oct_close_incremental_1",10);
+ {
+ num_t* pvpv = m->c+matpos(v2+1,v2); /* xv+xv */
+ num_t* mvmv = m->c+matpos(v2,v2+1); /* -xv-xv */
+
+ for (k=0;k<n2;k+=2) {
+
+ /* Ck step */
+ num_t* pkpk = m->c+matpos (k+1,k); /* xk+xk */
+ num_t* mkmk = m->c+matpos (k,k+1); /* -xk-xk */
+ num_t* pkpv = m->c+matpos2(v2+1,k );
+ num_t* mkpv = m->c+matpos2(v2+1,k+1);
+ num_t* pkmv = m->c+matpos2(v2 ,k );
+ num_t* mkmv = m->c+matpos2(v2 ,k+1);
+ for (i=0;i<n2;i++) {
+ /*(TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* imv = m->c + matpos2(v2 ,i); /* xi-xv */
+ num_t* ipv = m->c + matpos2(v2+1,i); /* xi+xv */
+ num_t* imk = m->c + matpos2(k ,i); /* xi-xk */
+ num_t* ipk = m->c + matpos2(k+1 ,i); /* xi+xk */
+ num_add(&ij1,imk,pkpv);
+ num_add(&ij2,ipk,mkpv);
+ num_add(&ij3,imk,pkpk); num_add(&ij3,&ij3,mkpv);
+ num_add(&ij4,ipk,mkmk); num_add(&ij4,&ij4,pkpv);
+ num_min(&ij1,&ij1,&ij2); num_min(&ij3,&ij3,&ij4);
+ num_min(&ij1,&ij1,&ij3);
+ num_min(ipv,ipv,&ij1);
+
+ num_add(&ij1,imk,pkmv);
+ num_add(&ij2,ipk,mkmv);
+ num_add(&ij3,imk,pkpk); num_add(&ij3,&ij3,mkmv);
+ num_add(&ij4,ipk,mkmk); num_add(&ij4,&ij4,pkmv);
+ num_min(&ij1,&ij1,&ij2); num_min(&ij3,&ij3,&ij4);
+ num_min(&ij1,&ij1,&ij3);
+ num_min(imv,imv,&ij1);
+ }
+
+ /* S step */
+ for (i=0;i<v2+2;i++) {
+ /*(TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* imv = m->c + matpos(v2 ,i); /* xi-xv */
+ num_t* ipv = m->c + matpos(v2+1,i); /* xi+xv */
+ num_t* ii = m->c + matpos(i^1,i); /* xi+xi */
+ num_add(&ij1,ii,pvpv); num_div_by_2(&ij1,&ij1); num_min(ipv,ipv,&ij1);
+ num_add(&ij2,ii,mvmv); num_div_by_2(&ij2,&ij2); num_min(imv,imv,&ij2);
+ }
+ for (;i<n2;i++) {
+ /*(TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* imv = m->c + matpos(i, v2+1); /* -xi-xv */
+ num_t* ipv = m->c + matpos(i, v2 ); /* -xi+xv */
+ num_t* ii = m->c + matpos(i,i^1); /* -xi-xi */
+ num_add(&ij1,ii,pvpv); num_div_by_2(&ij1,&ij1); num_min(ipv,ipv,&ij1);
+ num_add(&ij2,ii,mvmv); num_div_by_2(&ij2,&ij2); num_min(imv,imv,&ij2);
+ }
+
+ /* emptyness checking */
+ if (num_cmp_zero(m->c+matpos(v,v))<0) {
+ m->state=OCT_EMPTY;
+ num_clear_n(m->c,matsize(m->n));
+ oct_mm_free(m->c); m->c = (num_t*)NULL;
+ OCT_EXIT("oct_close_incremental_1",10);
+ goto end;
+ }
+ }
+ }
+ OCT_EXIT("oct_close_incremental_1",10);
+
+ /* try to reduce xk coefficients using xv coefficients */
+ OCT_ENTER("oct_close_incremental_2",11);
+ {
+ num_t* d = m->c; /* xj-xi */
+ k = v2;
+
+ /* Ck step */
+
+ num_set(&kk1,m->c+matpos(k+1,k)); /* xk+xk */
+ num_set(&kk2,m->c+matpos(k,k+1)); /* -xk-xk */
+
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ for (i=0;i<=k;i+=2) {
+ num_set(buf1+i ,m->c+matpos(k+1,i+1)); /* -xi+xk */
+ num_set(buf2+i ,m->c+matpos(k ,i+1)); /* -xi-xk */
+ num_set(buf1+i+1,m->c+matpos(k+1,i )); /* xi+xk */
+ num_set(buf2+i+1,m->c+matpos(k ,i )); /* xi-xk */
+ }
+ for (;i<n2;i+=2) {
+ num_set(buf1+i ,m->c+matpos(i ,k )); /* xk-xi */
+ num_set(buf2+i ,m->c+matpos(i ,k+1)); /* -xk-xi */
+ num_set(buf1+i+1,m->c+matpos(i+1,k )); /* xk+xi */
+ num_set(buf2+i+1,m->c+matpos(i+1,k+1)); /* -xk+xi */
+ }
+
+ for (i=0;i<n2;i++) {
+ const var_t ii = i|1;
+ num_add(&ik1,buf2+i,&kk1); /* (-xk-xi) + ( xk+xk) */
+ num_add(&ik2,buf1+i,&kk2); /* ( xk-xi) + (-xk-xk) */
+ for (j=0;j<=ii;j++,d++) {
+ var_t jj = j^1;
+ num_add(&ij1,buf1+i,buf2+jj); num_add(&ij2,&ik1,buf2+jj);
+ num_add(&ij3,buf2+i,buf1+jj); num_add(&ij4,&ik2,buf1+jj);
+ num_min(&ij1,&ij1,&ij2); num_min(&ij3,&ij3,&ij4);
+ num_min(&ij1,&ij1,&ij3);
+ num_min(d,d,&ij1);
+ }
+ }
+
+ /* S step */
+
+ d = m->c; /* xj-xi */
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+
+ for (i=0;i<n2;i+=2) {
+ num_div_by_2(buf1+i, m->c+matpos(i+1,i)); /* ( xi+xi)/2 */
+ num_div_by_2(buf1+i+1,m->c+matpos(i,i+1)); /* (-xi-xi)/2 */
+ }
+
+ for (i=0;i<n2;i++) {
+ const var_t ii = i|1;
+ const var_t ii2 = i^1;
+ for (j=0;j<=ii;j++,d++) {
+ num_add(&ij1,buf1+j,buf1+ii2);
+ num_min(d,d,&ij1);
+ }
+ }
+
+ /* emptyness checking */
+ for (i=0;i<n2;i+=2)
+ if (num_cmp_zero(m->c+matpos(i,i))<0) {
+ m->state=OCT_EMPTY;
+ num_clear_n(m->c,matsize(m->n));
+ oct_mm_free(m->c); m->c = (num_t*)NULL;
+ OCT_EXIT("oct_close_incremental_2",11);
+ goto end;
+ }
+
+ }
+ OCT_EXIT("oct_close_incremental_2",11);
+ m->state = OCT_CLOSED;
+ end:
+ num_clear(&kk1); num_clear(&kk2);
+ num_clear(&ik1); num_clear(&ik2);
+ num_clear(&ij1); num_clear(&ij2); num_clear(&ij3); num_clear(&ij4);
+ num_clear_n(buf1,n2); num_clear_n(buf2,n2);
+ oct_mm_free(buf1); oct_mm_free(buf2);
+ end2:
+ OCT_EXIT("oct_close_incremental",9);
+}
+
+#else /* optimized algorithm from BHMZ05 (constant factor improvement) */
+
+
+inline
+void
+OCT_PROTO(close_incremental) (oct_t* m,
+ var_t v)
+{
+ var_t i,j,k;
+ const var_t n2 = m->n*2;
+ const var_t v2 = v*2;
+ num_t *c;
+ num_t ij,ik,ik2;
+
+ OCT_ENTER("oct_close_incremental",9);
+ OCT_ASSERT(v<m->n,"variable index greater than the number of variables in oct_close_incremental");
+ if (m->state==OCT_EMPTY) goto end2;
+
+ num_init(&ik); num_init(&ik2); num_init(&ij);
+
+ /* incremental Floyd-Warshall : v in end-point position */
+ for (k=0;k<n2;k++) {
+ const var_t kk = k^1;
+ const var_t ii = v2|1;
+ const var_t br = k<ii ? k : ii;
+ for (i=v2;i<v2+2;i++) {
+ /* v in first end-point position */
+ c = m->c+matpos(i,0);
+ num_set(&ik,m->c+matpos2(i,k));
+ num_set(&ik2,m->c+matpos2(i,kk));
+ for (j=0;j<=br;j++,c++) {
+ num_add(&ij,&ik,m->c+matpos(k,j)); /* ik+kj */
+ num_min(c,c,&ij);
+ num_add(&ij,&ik2,m->c+matpos(kk,j)); /* ik2+k2j */
+ num_min(c,c,&ij);
+ }
+ for (;j<=ii;j++,c++) {
+ num_add(&ij,&ik,m->c+matpos(j^1,kk)); /* ik+kj */
+ num_min(c,c,&ij);
+ num_add(&ij,&ik2,m->c+matpos(j^1,k)); /* ik2+k2j */
+ num_min(c,c,&ij);
+ }
+ /* v in second end-point position */
+ num_set(&ik,m->c+matpos2(k,i));
+ num_set(&ik2,m->c+matpos2(kk,i));
+ for (j=i;j<k;j++) {
+ c = m->c+matpos(j,i);
+ num_add(&ij,&ik,m->c+matpos(kk,j^1)); /* ik+kj */
+ num_min(c,c,&ij);
+ num_add(&ij,&ik2,m->c+matpos(k,j^1)); /* ik2+k2j */
+ num_min(c,c,&ij);
+ }
+ for (;j<n2;j++) {
+ c = m->c+matpos(j,i);
+ num_add(&ij,&ik,m->c+matpos(j,k)); /* ik+kj */
+ num_min(c,c,&ij);
+ num_add(&ij,&ik2,m->c+matpos(j,kk)); /* ik2+k2j */
+ num_min(c,c,&ij);
+ }
+ }
+ }
+
+ /* incremental Floyd-Warshall : v in pivot position */
+ for (k=v2;k<v2+2;k++) {
+ const var_t kk = k^1;
+ c = m->c;
+ for (i=0;i<n2;i++) {
+ const var_t ii = i|1;
+ const var_t br = k<ii ? k : ii;
+ num_set(&ik,m->c+matpos2(i,k));
+ num_set(&ik2,m->c+matpos2(i,kk));
+ for (j=0;j<=br;j++,c++) {
+ num_add(&ij,&ik,m->c+matpos(k,j)); /* ik+kj */
+ num_min(c,c,&ij);
+ num_add(&ij,&ik2,m->c+matpos(kk,j)); /* ik2+k2j */
+ num_min(c,c,&ij);
+ }
+ for (;j<=ii;j++,c++) {
+ num_add(&ij,&ik,m->c+matpos(j^1,kk)); /* ik+kj */
+ num_min(c,c,&ij);
+ num_add(&ij,&ik2,m->c+matpos(j^1,k)); /* ik2+k2j */
+ num_min(c,c,&ij);
+ }
+ }
+ }
+
+ /* lone S step */
+ c = m->c;
+ for (i=0;i<n2;i++) {
+ const var_t ii = i|1;
+ num_div_by_2(&ij,m->c+matpos(i,i^1));
+ for (j=0;j<=ii;j++,c++) {
+ num_div_by_2(&ik,m->c+matpos(j^1,j));
+ num_add(&ik,&ik,&ij);
+ num_min(c,c,&ik);
+ }
+ }
+
+ /* emptyness checking */
+ for (i=0;i<n2;i++) {
+ c = m->c+matpos(i,i);
+ if (num_cmp_zero(c)<0) {
+ m->state = OCT_EMPTY;
+ num_clear_n(m->c,matsize(m->n));
+ oct_mm_free(m->c); m->c = (num_t*)NULL;
+ goto end;
+ }
+ else num_set_int(c,0);
+ }
+
+ m->state = OCT_CLOSED;
+ end:
+ num_clear(&ik); num_clear(&ik2); num_clear(&ij);
+ end2:
+ OCT_EXIT("oct_close_incremental",9);
+}
+
+#endif
+
+
+/*********/
+/* Tests */
+/*********/
+
+/* non-destructively computes the closure to check for emptiness
+ calls oct_close with cache=true, so subsequent calls
+ to oct_is_empty/oct_close will be very very fast
+ cost: the cost of the close operator
+*/
+inline
+bool
+OCT_PROTO(is_empty) (oct_t* m)
+{
+ oct_t* mm;
+ bool r;
+ OCT_ENTER("oct_is_empty",12);
+ mm = oct_close(m, false, true);
+ r = (mm->state==OCT_EMPTY)?true:false;
+ oct_free(mm);
+ OCT_EXIT("oct_is_empty",12);
+ return r;
+}
+
+/* can return tbool_top if a call to close would be required to answer
+ null cost
+ */
+inline
+tbool
+OCT_PROTO(is_empty_lazy) (oct_t* m)
+{
+ tbool r;
+ OCT_ENTER("oct_is_empty_lazy",13);
+ r = (m->state==OCT_EMPTY
+ || (m->closed && m->closed->state==OCT_EMPTY))?tbool_true:
+ ((m->state==OCT_CLOSED || m->closed)?tbool_false:tbool_top);
+ OCT_EXIT("oct_is_empty_lazy",13);
+ return r;
+}
+
+/* calls oct_close with cache=true
+ O(n^2) time cost, on behalf of the cost of closure
+ */
+bool
+OCT_PROTO(is_included_in) (oct_t* ma,
+ oct_t* mb)
+{
+ bool r;
+ OCT_ENTER("oct_is_included_in",14);
+ OCT_ASSERT(ma->n==mb->n,"oct_is_included_in must be called with two octagons of the same dimension.");
+ if (ma==mb) r = true;
+ else {
+ oct_t *ca = oct_close(ma, false, true);
+ if (ca->state==OCT_EMPTY) r = true;
+ else if (oct_is_empty_lazy(mb)==tbool_true) r = false;
+ else {
+ const size_t nn = matsize(ma->n);
+ size_t i;
+ num_t* a = ca->c;
+ num_t* b = mb->c;
+ r = true;
+ for (i=0;i<nn;i++,a++,b++)
+ if (num_cmp(a,b)>0) { r=false; break; }
+ }
+ oct_free(ca);
+ }
+ OCT_EXIT("oct_is_included_in",14);
+ return r;
+}
+
+/* can return tbool_top if a call to close would be required to answer
+ O(n^2) time cost
+*/
+tbool
+OCT_PROTO(is_included_in_lazy) (oct_t* ma,
+ oct_t* mb)
+{
+ tbool r;
+ OCT_ENTER("oct_is_included_in_lazy",15);
+ OCT_ASSERT(ma->n==mb->n,"oct_is_included_in_lazy must be called with two octagons of the same dimension.");
+ if (ma==mb) r = tbool_true;
+ else {
+ oct_t *ca = oct_close_lazy (ma, false);
+ if (ca->state==OCT_EMPTY) r = tbool_true;
+ else if (mb->state==OCT_EMPTY) r = tbool_false;
+ else {
+ const size_t nn = matsize(ma->n);
+ size_t i;
+ num_t* a = ca->c;
+ num_t* b = mb->c;
+
+ r = tbool_true;
+ for (i=0;i<nn;i++,a++,b++)
+ if (num_cmp(a,b)>0) { r=tbool_false; break; }
+ }
+ if (r==tbool_false && !oct_is_closed(ca)) r = tbool_top;
+ oct_free(ca);
+ }
+ OCT_EXIT("oct_is_included_in_lazy",15);
+ return r;
+}
+
+/* calls oct_close with cache=true
+ O(n^2) time cost, on behalf of the cost of closure
+ */
+bool
+OCT_PROTO(is_equal) (oct_t* ma,
+ oct_t* mb)
+{
+ bool r;
+ OCT_ENTER("oct_is_equal",16);
+ OCT_ASSERT(ma->n==mb->n,"oct_is_equal must be called with two octagons of the same dimension.");
+ if (ma==mb) r = true;
+ else {
+ oct_t *ca = oct_close(ma, false, true);
+ oct_t *cb = oct_close(mb, false, true);
+ if (ca->state==OCT_EMPTY && cb->state==OCT_EMPTY) r = true;
+ else if (ca->state==OCT_EMPTY || cb->state==OCT_EMPTY) r = false;
+ else {
+ const size_t nn = matsize(ma->n);
+ size_t i;
+ num_t* a = ca->c;
+ num_t* b = cb->c;
+ r = true;
+ for (i=0;i<nn;i++,a++,b++)
+ if (num_cmp(a,b)) { r=false; break; }
+ }
+ oct_free(ca);
+ oct_free(cb);
+ }
+ OCT_EXIT("oct_is_equal",16);
+ return r;
+}
+
+/* can return tbool_top if a call to close would be required to answer
+ O(n^2) time cost
+*/
+tbool
+OCT_PROTO(is_equal_lazy)(oct_t* ma,
+ oct_t* mb)
+{
+ tbool r;
+ OCT_ENTER("oct_is_equal_lazy",17);
+ OCT_ASSERT(ma->n==mb->n,"oct_is_equal_lazy must be called with two octagons of the same dimension.");
+ if (ma==mb) r = tbool_true;
+ else {
+ oct_t *ca = oct_close_lazy (ma, false);
+ oct_t *cb = oct_close_lazy (mb, false);
+ if (ca->state==OCT_EMPTY && cb->state==OCT_EMPTY) r = tbool_true;
+ else if (ca->state==OCT_EMPTY || cb->state==OCT_EMPTY) r = tbool_false;
+ else {
+ const size_t nn = matsize(ma->n);
+ size_t i;
+ num_t* a = ca->c;
+ num_t* b = cb->c;
+
+ r = tbool_true;
+ for (i=0;i<nn;i++,a++,b++)
+ if (num_cmp(a,b)) { r = tbool_false; break; }
+ }
+ if (r==tbool_false &&
+ (!oct_is_closed(ca) || !oct_is_closed(ca))) r = tbool_top;
+ oct_free(ca);
+ oct_free(cb);
+ }
+ OCT_EXIT("oct_is_equal_lazy",17);
+ return r;
+}
+
+/* return true if v is in the domain of a, false elsewhere
+ O(n^2) time cost
+*/
+bool
+OCT_PROTO(is_in) (oct_t* a,
+ const num_t* v)
+{
+ bool r = true;
+ var_t i,j;
+ num_t w;
+ OCT_ENTER("oct_is_in",18);
+ if (oct_is_empty_lazy(a)==tbool_true) { r = false; goto end2; }
+ num_init(&w);
+ for (i=0;i<a->n;i++)
+ for (j=0;j<=i;j++) {
+ num_add(&w,v+i,a->c+matpos(2*i,2*j));
+ if (num_cmp(v+j,&w)>0) { r = false; goto end; }
+
+ num_add(&w,v+j,a->c+matpos(2*i+1,2*j+1));
+ if (num_cmp(v+i,&w)>0){ r = false; goto end; }
+
+ num_add(&w,v+i,v+j);
+ if (num_cmp(&w,a->c+matpos(2*i+1,2*j))>0) { r = false; goto end; }
+
+ num_add(&w,v+i,v+j); num_add(&w,&w,a->c+matpos(2*i,2*j+1));
+ if (num_cmp_zero(&w)<0) { r = false; goto end; }
+ }
+ end:
+ num_clear(&w);
+ end2:
+ OCT_EXIT("oct_is_in",18);
+ return r;
+}
+
+/* return true if the octagon has a full domain
+ O(n^2) time cost
+*/
+bool
+OCT_PROTO(is_universe) (oct_t* m)
+{
+ bool r = true;
+ const var_t n2 = m->n*2;
+ var_t i,j;
+ num_t* c = m->c;
+ OCT_ENTER("oct_is_universe",19);
+ if (m->state==OCT_EMPTY) { r = false; goto end; }
+ for (i=0;i<n2;i++) {
+ const var_t ii = i|1;
+ for (j=0;j<=ii;j++,c++)
+ if (!num_infty(c) && i!=j)
+ { r = false; goto end; }
+ }
+ end:
+ OCT_EXIT("oct_is_universe",19);
+ return r;
+}
+
+/*************/
+/* Operators */
+/*************/
+
+/* exact intersection
+ O(n^2) time cost
+*/
+oct_t*
+OCT_PROTO(intersection) (oct_t* ma,
+ oct_t* mb,
+ bool destructive)
+{
+ oct_t* r;
+ OCT_ENTER("oct_intersection",20);
+ OCT_ASSERT(ma->n==mb->n,"oct_intersection must be called with two octagons of the same dimension.");
+ if (ma==mb) r = oct_copy(ma);
+ /* ma empty => intersection equals ma */
+ else if (oct_is_empty_lazy(ma)==tbool_true) r = oct_copy(ma);
+ /* mb empty => intersection equals mb */
+ else if (oct_is_empty_lazy(mb)==tbool_true) r = oct_copy(mb);
+ else {
+ const size_t nn = matsize(ma->n);
+ size_t i;
+ num_t* a = ma->c;
+ num_t* b = mb->c;
+ num_t* c;
+ /* result is computed in ma, or mb, or a new octagon */
+ if (destructive) {
+ if (ma->ref==1) r = oct_copy(ma);
+ else if (mb->ref==1) r = oct_copy(mb);
+ else r = oct_alloc(ma->n);
+ }
+ else r = oct_alloc(ma->n);
+ r->state = OCT_NORMAL;
+ if (r->closed) { oct_free(r->closed); r->closed = (oct_t*)NULL; }
+ /* change the result matrix */
+ c = r->c;
+ for (i=0;i<nn;i++,a++,b++,c++) num_min(c,a,b);
+ }
+ if (destructive) { oct_free(ma); oct_free(mb); }
+ OCT_EXIT("oct_intersection",20);
+ return r;
+}
+
+/* best apprixomation of the union
+ both arguments are closed (but with cache=false)
+ O(n^2) time cost, on behalf of the cost of closure
+*/
+oct_t*
+OCT_PROTO(convex_hull) (oct_t* ma,
+ oct_t* mb,
+ bool destructive)
+{
+ oct_t* r;
+ OCT_ENTER("oct_convex_hull",21);
+ OCT_ASSERT(ma->n==mb->n,"oct_convex_hull must be called with two octagons of the same dimension.");
+ if (ma==mb) {
+ if (destructive) { r = ma; oct_free(ma); }
+ else r = oct_copy(ma);
+ }
+ else {
+ oct_t* ca = oct_close(ma, destructive, true);
+ oct_t* cb = oct_close(mb, destructive, true);
+ /* ca empty => hull equals cb */
+ if (ca->state==OCT_EMPTY) r = oct_copy(cb);
+ /* cb empty => hull equals ca */
+ else if (cb->state==OCT_EMPTY) r = oct_copy(ca);
+ else {
+ const size_t nn = matsize(ca->n);
+ size_t i;
+ num_t* a = ca->c;
+ num_t* b = cb->c;
+ num_t* c;
+ /* result is computed in ca, or cb, or a new octagon */
+ if (destructive) {
+ if (ca->ref==1) r = oct_copy(ca);
+ else if (cb->ref==1) r = oct_copy(cb);
+ else r = oct_alloc(ca->n);
+ }
+ else r = oct_alloc(ca->n);
+ r->state = OCT_CLOSED;
+ /* change the result matrix */
+ c = r->c;
+ for (i=0;i<nn;i++,a++,b++,c++) num_max(c,a,b);
+ }
+ oct_free(ca);
+ oct_free(cb);
+ }
+ OCT_EXIT("oct_convex_hull",21);
+ return r;
+}
+
+/* convergence acceleration operator: jump to a post fixpoint after finite
+ iteration
+ right argument is closed (but with cache=false)
+ O(n^2) time cost, on behalf of the cost of closure
+*/
+oct_t*
+OCT_PROTO(widening) (oct_t* ma,
+ oct_t* mb,
+ bool destructive,
+ oct_widening_type type)
+{
+ oct_t* r;
+ OCT_ENTER("oct_widening",22);
+ OCT_ASSERT(ma->n==mb->n,"oct_widening must be called with two octagons of the same dimension.");
+ if (ma==mb) {
+ if (destructive) { r = ma; oct_free(ma); }
+ else r = oct_copy(ma);
+ }
+ /* ma empty => widening equals cb */
+ else if (oct_is_empty_lazy(ma)==tbool_true) {
+ if (destructive) { r = mb; oct_free(ma); }
+ else r = oct_copy(mb);
+ }
+ else {
+ oct_t* cb = oct_close(mb, destructive, true);
+ /* cb empty => widening equals ma */
+ if (cb->state==OCT_EMPTY) r = oct_copy(ma);
+ else {
+ const size_t nn = matsize(ma->n);
+ size_t i;
+ num_t* a = ma->c;
+ num_t* b = cb->c;
+ num_t* c;
+ /* result is computed in ma, or cb, or a new octagon */
+ if (destructive) {
+ if (ma->ref==1) r = oct_copy(ma);
+ else if (cb->ref==1) r = oct_copy(cb);
+ else r = oct_alloc(ma->n);
+ }
+ else r = oct_alloc(ma->n);
+ r->state = OCT_NORMAL;
+ if (r->closed) { oct_free(r->closed); r->closed = (oct_t*)NULL; }
+ /* change the result matrix */
+ c = r->c;
+ switch (type) {
+
+ /* 0, +oo */
+ case OCT_WIDENING_ZERO:
+ for (i=0;i<nn;i++,a++,b++,c++)
+ if (num_cmp(b,a)<=0) num_set(c,a);
+ else if (num_cmp_zero(b)<=0) num_set_int(c,0);
+ else num_set_infty(c);
+ break;
+
+ /* -1, 0, 1, +oo */
+ case OCT_WIDENING_UNIT:
+ for (i=0;i<nn;i++,a++,b++,c++)
+ if (num_cmp(b,a)<=0) num_set(c,a);
+ else if (num_cmp_int(b,-1)<=0) num_set_int(c,-1);
+ else if (num_cmp_zero(b) <=0) num_set_int(c, 0);
+ else if (num_cmp_int(b, 1)<=0) num_set_int(c, 1);
+ else num_set_infty(c);
+ break;
+
+ /* degenerate hull: NOT A PROPER WIDENING, use with care */
+ case OCT_PRE_WIDENING:
+ for (i=0;i<nn;i++,a++,b++,c++)
+ num_max(c,a,b);
+ break;
+
+ /* +oo */
+ case OCT_WIDENING_FAST:
+ default:
+ for (i=0;i<nn;i++,a++,b++,c++)
+ if (num_cmp(b,a)<=0) num_set(c,a); else num_set_infty(c);
+ break;
+ }
+ }
+ if (destructive) oct_free(ma);
+ oct_free(cb);
+ }
+ OCT_EXIT("oct_widening",22);
+ return r;
+}
+
+/* this widening takes as an argument an array (in increasing order) of
+ thresholds
+ right argument is closed (but with cache=false)
+ O(n^2) time cost, on behalf of the cost of closure
+*/
+oct_t*
+OCT_PROTO(widening_steps) (oct_t* ma,
+ oct_t* mb,
+ bool destructive,
+ int nb_steps,
+ num_t* steps)
+{
+ oct_t* r;
+ OCT_ENTER("oct_widening_steps",47);
+ OCT_ASSERT(ma->n==mb->n,"oct_widening_steps must be called with two octagons of the same dimension.");
+ if (ma==mb) {
+ if (destructive) { r = ma; oct_free(ma); }
+ else r = oct_copy(ma);
+ }
+ /* ma empty => widening equals cb */
+ else if (oct_is_empty_lazy(ma)==tbool_true) {
+ if (destructive) { r = mb; oct_free(ma); }
+ else r = oct_copy(mb);
+ }
+ else {
+ oct_t* cb = oct_close(mb, destructive, true);
+ /* cb empty => widening equals ma */
+ if (cb->state==OCT_EMPTY) r = oct_copy(ma);
+ else {
+ const size_t nn = matsize(ma->n);
+ size_t i;
+ int j;
+ num_t* a = ma->c;
+ num_t* b = cb->c;
+ num_t* c;
+ /* result is computed in ma, or cb, or a new octagon */
+ if (destructive) {
+ if (ma->ref==1) r = oct_copy(ma);
+ else if (cb->ref==1) r = oct_copy(cb);
+ else r = oct_alloc(ma->n);
+ }
+ else r = oct_alloc(ma->n);
+ r->state = OCT_NORMAL;
+ if (r->closed) { oct_free(r->closed); r->closed = (oct_t*)NULL; }
+ /* change the result matrix */
+ c = r->c;
+ for (i=0;i<nn;i++,a++,b++,c++)
+ if (num_cmp(b,a)<=0) num_set(c,a);
+ else {
+ num_set_infty(c);
+ for (j=0;j<nb_steps;j++)
+ if (num_cmp(b,steps+j)<=0) { num_set(c,steps+j); break; }
+ }
+ }
+ if (destructive) oct_free(ma);
+ oct_free(cb);
+ }
+ OCT_EXIT("oct_widening_steps",47);
+ return r;
+}
+
+
+/* information restoration operator: stay above least fixpoint
+ right argument is closed (but with cache=false)
+ O(n^2) time cost, on behalf of the cost of closure
+*/
+oct_t*
+OCT_PROTO(narrowing) (oct_t* ma,
+ oct_t* mb,
+ bool destructive)
+{
+ oct_t* r;
+ OCT_ENTER("oct_narrowing",23);
+ OCT_ASSERT(ma->n==mb->n,"oct_narrowing must be called with two octagons of the same dimension.");
+ if (ma==mb) {
+ if (destructive) { r = ma; oct_free(ma); }
+ else r = oct_copy(ma);
+ }
+ else {
+ oct_t* ca = oct_close(ma, destructive, true);
+ oct_t* cb = oct_close(mb, destructive, true);
+ /* ca empty => narrowing equals cb */
+ if (ca->state==OCT_EMPTY) r = oct_copy(cb);
+ /* cb empty => narrowing equals ca */
+ else if (cb->state==OCT_EMPTY) r = oct_copy(ca);
+ else {
+ const size_t nn = matsize(ca->n);
+ size_t i;
+ num_t* a = ca->c;
+ num_t* b = cb->c;
+ num_t* c;
+ /* result is computed in ca, or cb, or a new octagon */
+ if (destructive) {
+ if (ca->ref==1) r = oct_copy(ca);
+ else if (cb->ref==1) r = oct_copy(cb);
+ else r = oct_alloc(ca->n);
+ }
+ else r = oct_alloc(ca->n);
+ r->state = OCT_NORMAL;
+ if (r->closed) { oct_free(r->closed); r->closed = (oct_t*)NULL; }
+
+ /* change the result matrix */
+ c = r->c;
+ for (i=0;i<nn;i++,a++,b++,c++)
+ if (num_infty(a)) num_set(c,b); else num_set(c,a);
+ }
+ oct_free(ca);
+ oct_free(cb);
+ }
+ OCT_EXIT("oct_narrowing",23);
+ return r;
+}
+
+
+/**********************/
+/* Transfer Functions */
+/**********************/
+
+/* forget all informations about the variable k
+ O(n) time cost, on behalf of the cost of closure and copy
+ if the result is not empty, it is always a newly allocated matrix
+ that can be safely modified in-place
+*/
+inline
+oct_t*
+OCT_PROTO(forget) (oct_t* m,
+ var_t k,
+ bool destructive)
+{
+ oct_t *mm;
+ oct_t* r;
+ const var_t k2 = 2*k;
+ const var_t n2 = 2*m->n;
+ var_t i;
+ OCT_ENTER("oct_forget",24);
+ mm = oct_close(m, destructive, true);
+ OCT_ASSERT(k<mm->n,"variable index greater than the number of variables in oct_forget");
+ /* mm empty => return mm */
+ if (mm->state==OCT_EMPTY) { r = mm; goto end; }
+ /* result is computed in mm, or in a new octagon */
+ if (mm->ref==1) r = mm;
+ else { r = oct_full_copy(mm); mm->ref--; }
+ /* change the result matrix */
+ for (i=0;i<k2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_set_infty(r->c+matpos(k2 ,i));
+ num_set_infty(r->c+matpos(k2+1,i));
+ }
+ for (i=k2+2;i<n2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_set_infty(r->c+matpos(i,k2 ));
+ num_set_infty(r->c+matpos(i,k2+1));
+ }
+ num_set_infty(r->c+matpos(k2,k2+1));
+ num_set_infty(r->c+matpos(k2+1,k2));
+ end:
+ OCT_EXIT("oct_forget",24);
+ return r;
+}
+
+
+/* intersects the domain with constraints of the form
+ x<=c, -x<=c, x-y<=c, +x+y<=c or -x-y<=c
+ if the result is not empty, it is always a newly allocated matrix
+ that can be safely modified in-place
+ O(nb) time cost
+*/
+inline
+oct_t*
+OCT_PROTO(add_bin_constraints) (oct_t* m,
+ unsigned int nb,
+ const oct_cons* cons,
+ bool destructive)
+{
+ oct_t* r;
+ unsigned int k;
+ num_t c;
+ var_t changed;
+ int nb_changed = 0;
+ OCT_ENTER("oct_add_bin_constraints",25);
+ /* m empty => return m */
+ if (oct_is_empty_lazy(m)==tbool_true)
+ if (destructive) { r = m; goto end2; }
+ else { r = oct_copy(m); goto end2; }
+ /* result is computed in m, or in a new octagon */
+ if (destructive) {
+ if (m->ref==1) r = m;
+ else { r = oct_full_copy(m); m->ref--; }
+ }
+ else r = oct_full_copy(m);
+ /* change the result matrix */
+ num_init(&c);
+ for (k=0;k<nb;k++) {
+ var_t i,j;
+ OCT_ASSERT(cons[k].x<m->n,"variable index greater than the number of variables in oct_add_constraints");
+ OCT_ASSERT(cons[k].type==mx || cons[k].type==px || cons[k].y<m->n,"variable index greater than the number of variables in oct_add_constraints");
+ switch (cons[k].type) {
+ case mx:
+ j=2*cons[k].x+1; i=2*cons[k].x; num_mul_by_2(&c,&cons[k].c);
+ if (num_cmp(&c,r->c+matpos2(i,j))<0) {
+ num_set(r->c+matpos2(i,j),&c);
+ if (nb_changed==0 ) { nb_changed=1; changed=cons[k].x; }
+ else if (changed!=cons[k].x) nb_changed++;
+ }
+ break;
+
+ case px:
+ j=2*cons[k].x; i=2*cons[k].x+1; num_mul_by_2(&c,&cons[k].c);
+ if (num_cmp(&c,r->c+matpos2(i,j))<0) {
+ num_set(r->c+matpos2(i,j),&c);
+ if (nb_changed==0 ) { nb_changed=1; changed=cons[k].x; }
+ else if (changed!=cons[k].x) nb_changed++;
+ }
+ break;
+
+ case mxmy:
+ j=2*cons[k].x+1; i=2*cons[k].y; num_set(&c,&cons[k].c);
+ if (num_cmp(&c,r->c+matpos2(i,j))<0) {
+ num_set(r->c+matpos2(i,j),&c);
+ if (nb_changed==0 ) { nb_changed=1; changed=cons[k].x; }
+ else if (changed!=cons[k].x && changed!=cons[k].y) nb_changed++;
+ }
+ break;
+
+ case mxpy:
+ j=2*cons[k].x+1; i=2*cons[k].y+1; num_set(&c,&cons[k].c);
+ if (num_cmp(&c,r->c+matpos2(i,j))<0) {
+ num_set(r->c+matpos2(i,j),&c);
+ if (nb_changed==0 ) { nb_changed=1; changed=cons[k].x; }
+ else if (changed!=cons[k].x && changed!=cons[k].y) nb_changed++;
+ }
+ break;
+
+ case pxmy:
+ j=2*cons[k].x; i=2*cons[k].y; num_set(&c,&cons[k].c);
+ if (num_cmp(&c,r->c+matpos2(i,j))<0) {
+ num_set(r->c+matpos2(i,j),&c);
+ if (nb_changed==0 ) { nb_changed=1; changed=cons[k].x; }
+ else if (changed!=cons[k].x && changed!=cons[k].y) nb_changed++;
+ }
+ break;
+
+ case pxpy:
+ j=2*cons[k].x; i=2*cons[k].y+1; num_set(&c,&cons[k].c);
+ if (num_cmp(&c,r->c+matpos2(i,j))<0) {
+ num_set(r->c+matpos2(i,j),&c);
+ if (nb_changed==0 ) { nb_changed=1; changed=cons[k].x; }
+ else if (changed!=cons[k].x && changed!=cons[k].y) nb_changed++;
+ }
+ break;
+
+ default:
+ OCT_ASSERT(false,"invalid constraint type in oct_add_constraints");
+ }
+ }
+ if (nb_changed==1 && r->state==OCT_CLOSED) oct_close_incremental(r,changed);
+ else if (nb_changed>0) {
+ r->state = OCT_NORMAL;
+ if (r->closed) { oct_free(r->closed); r->closed = (oct_t*)NULL; }
+ }
+ num_clear(&c);
+ end2:
+ OCT_EXIT("oct_add_bin_constraints",25);
+ return r;
+}
+
+
+
+/* transfer funciton modeling forward semantics of assignment x <- e
+ e = tab[0]v0 + tab[1]v1 + ... + tab[N-1]v(N-1) + tab[N]
+ the operation is exact for assignments of the form
+ x <- c
+ x <- x + c
+ x <- -x + c
+ x <- y + c (x!=y)
+ x <- -y + c (x!=y)
+
+ for other assignments x <- e, leads to the constraints m <= x <= M, where
+ m and M are computed using a simple interval arithmetic on e
+ if the coefficient of y in e is >= 1, then bounds for x-y are also derived
+ if the coefficient of y in e is <=-1, then bounds for x+y are also derived
+
+ if the result is not empty, it is always a newly allocated matrix
+ that can be safely modified in-place
+
+ often need to close its argument
+ returns a closed result whenever possible
+ */
+oct_t*
+OCT_PROTO(assign_variable) (oct_t* m,
+ var_t x,
+ const num_t* tab,
+ bool destructive)
+{
+ oct_t* r;
+ var_t i, y, N = 0;
+ const var_t n = m->n;
+ const var_t n2 = n*2;
+ const var_t x2 = 2*x;
+ const num_t* c = tab+n;
+ OCT_ENTER("oct_assign_variable",26);
+ OCT_ASSERT(x<m->n,"variable index greater than the number of variables in oct_assign_variable");
+
+ if (oct_is_empty_lazy(m)==tbool_true)
+ if (destructive) { r = m; goto end; }
+ else { r = oct_copy(m); goto end; }
+
+ if (num_infty(c)) { r = oct_forget (m, x, destructive); goto end; }
+ for (i=0;i<n;i++)
+ if (num_infty(tab+i)) { r = oct_forget (m, x, destructive); goto end; }
+ else if (num_cmp_zero(tab+i)) { y=i; N++; }
+
+ if (N==0) { /* x <- c */
+ r = oct_forget (m, x, destructive);
+ if (r->state==OCT_EMPTY) goto end;
+ num_mul_by_2(r->c+matpos(x2+1,x2),c);
+ num_neg(r->c+matpos(x2,x2+1),r->c+matpos(x2+1,x2));
+ /* the following is only here to ensure matrix closedness
+ with a O(n) cost; does it worth it ? */
+ for (i=0;i<x2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* i1 = r->c+matpos(x2,i);
+ num_t* i2 = r->c+matpos(x2+1,i);
+ const num_t* i3 = r->c+matpos(i^1,i);
+ num_div_by_2(i1,i3); num_sub(i1,i1,c);
+ num_div_by_2(i2,i3); num_add(i2,i2,c);
+ }
+ for (i=x2+2;i<n2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* i1 = r->c+matpos(i,x2);
+ num_t* i2 = r->c+matpos(i,x2+1);
+ const num_t* i3 = r->c+matpos(i,i^1);
+ num_div_by_2(i1,i3); num_add(i1,i1,c);
+ num_div_by_2(i2,i3); num_sub(i2,i2,c);
+ }
+ }
+
+ else if (N==1 && (!num_cmp_int(tab+y,1) || !num_cmp_int(tab+y,-1)))
+ /* x <- +/- y + c */
+
+ if (y!=x) { /* x <- +/- y + c, x!=y */
+ r = oct_forget (m, x, destructive);
+ if (r->state==OCT_EMPTY) goto end;
+ if (!num_cmp_int(tab+y,1)) { /* x <- y + c, y!=x */
+ num_set(r->c+matpos2(2*y,x2),c);
+ num_neg(r->c+matpos2(x2,2*y),c);
+ }
+ else { /* x <- -y + c, y!=x */
+ num_set(r->c+matpos2(2*y+1,x2),c);
+ num_neg(r->c+matpos2(x2,2*y+1),c);
+ }
+ oct_close_incremental(r,x);
+ }
+
+ else { /* x <- +/- x + c; respects closure */
+
+ m = oct_close_lazy(m,destructive);
+ if (m->ref==1) r = m;
+ else { r = oct_full_copy(m); m->ref--; }
+ if (r->closed) { oct_free(r->closed); r->closed = (oct_t*)NULL; }
+
+ /* modify the result matrix */
+ if (!num_cmp_int(tab+x,-1)) { /* x <- -x + c */
+ num_t w,ww;
+ num_init(&w); num_init(&ww);
+ num_mul_by_2(&ww,c);
+ for (i=0;i<x2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* xi = r->c+matpos(x2 ,i);
+ num_t* ix = r->c+matpos(x2+1,i);
+ num_set(&w,xi);
+ num_sub(xi,ix,c);
+ num_add(ix,&w,c);
+ }
+ num_set(&w,r->c+matpos(x2,x2+1));
+ num_sub(r->c+matpos(x2,x2+1),r->c+matpos(x2+1,x2),&ww);
+ num_add(r->c+matpos(x2+1,x2),&w ,&ww);
+ for (i=x2+2;i<n2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* xi = r->c+matpos(i,x2+1);
+ num_t* ix = r->c+matpos(i,x2 );
+ num_set(&w,xi);
+ num_sub(xi,ix,c);
+ num_add(ix,&w,c);
+ }
+ num_clear(&w); num_clear(&ww);
+ }
+ else { /* x <- x + c */
+ num_t ww;
+ num_init(&ww);
+ num_mul_by_2(&ww,c);
+ for (i=0;i<x2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* xi = r->c+matpos(x2 ,i);
+ num_t* ix = r->c+matpos(x2+1,i);
+ num_sub(xi,xi,c);
+ num_add(ix,ix,c);
+ }
+ num_add(r->c+matpos(x2+1,x2),r->c+matpos(x2+1,x2),&ww);
+ num_sub(r->c+matpos(x2,x2+1),r->c+matpos(x2,x2+1),&ww);
+ for (i=x2+2;i<n2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* xi = r->c+matpos(i,x2+1);
+ num_t* ix = r->c+matpos(i,x2 );
+ num_sub(xi,xi,c);
+ num_add(ix,ix,c);
+ }
+ num_clear(&ww);
+ }
+ }
+
+ else { /* general case */
+ var_t j;
+ num_t* buf; /* bounds for each variable */
+ num_t Cb,cb; /* global upper / lower bounds */
+ int Cinf, cinf; /* number of infinite coef in up/lw bounds */
+ var_t Ci, ci; /* var leading to infinite coef in up/lw bounds */
+ num_t w;
+ int changed = 0;
+ r = oct_close (m,destructive,false);
+ if (r->state==OCT_EMPTY) goto end;
+ buf = new_n(num_t,n2);
+ num_init(&Cb); num_init(&cb); num_init(&w);
+ num_mul_by_2(&Cb,c); num_neg(&cb,&Cb);
+ Cinf = cinf = 0;
+ for (i=0,j=0;i<n2;i+=2,j++) {
+ /* get variable bounds, ignoring components leading to +oo */
+ num_t* px = r->c+matpos(i+1,i); /* xj+xj */
+ num_t* mx = r->c+matpos(i,i+1); /* -xj-xj */
+ num_init_set(buf+i ,px);
+ num_init_set(buf+i+1,mx);
+ if (num_cmp_zero(tab+j)>0) {
+ if (num_infty(px)) { Cinf++; Ci = j; }
+ else { num_mul(&w,tab+j,px); num_add(&Cb,&Cb,&w); }
+ if (num_infty(mx)) { cinf++; ci = j; }
+ else { num_mul(&w,tab+j,mx); num_add(&cb,&cb,&w); }
+ }
+ else if (num_cmp_zero(tab+j)<0) {
+ if (num_infty(mx)) { Cinf++; Ci = j; }
+ else { num_neg(&w,tab+j); num_mul(&w,&w,mx); num_add(&Cb,&Cb,&w); }
+ if (num_infty(px)) { cinf++; ci = j; }
+ else { num_neg(&w,tab+j); num_mul(&w,&w,px); num_add(&cb,&cb,&w); }
+ }
+ }
+ r = oct_forget (r,x,true);
+ /* upper bounds */
+ switch (Cinf) {
+ case 0:
+ /* bound is not infinite */
+ num_set(r->c+matpos(x2+1,x2),&Cb); /* bound for x */
+ for (i=0;i<n;i++)
+ if (i!=x) {
+ if (num_cmp_int(tab+i,1)>=0 && !num_infty(buf+2*i)) {
+ /* bound for x-y */
+ num_sub(&w,&Cb,buf+2*i);
+ num_div_by_2(r->c+matpos2(2*i, x2),&w);
+ }
+ else if (num_cmp_int(tab+i,-1)<=0 && !num_infty(buf+2*i+1)) {
+ /* bound for x+y */
+ num_sub(&w,&Cb,buf+2*i+1);
+ num_div_by_2(r->c+matpos2(2*i+1,x2),&w);
+ }
+ }
+ changed = 1;
+ break;
+ case 1:
+ /* bound has only one infinite coef, for var y of index Ci =>
+ we may still have a finite bound for x-y, or x+y */
+ if (Ci!=x) {
+ if (!num_cmp_int(tab+Ci,1)) num_div_by_2(r->c+matpos2(Ci*2 ,x2),&Cb);
+ else if (!num_cmp_int(tab+Ci,-1)) num_div_by_2(r->c+matpos2(Ci*2+1,x2),&Cb);
+ }
+ changed = 1;
+ break;
+ }
+ /* lower bounds */
+ switch (cinf) {
+ case 0:
+ /* bound is not infinite */
+ num_set(r->c+matpos(x2,x2+1),&cb); /* bound for -x */
+ for (i=0;i<n;i++)
+ if (i!=x) {
+ if (num_cmp_int(tab+i,1)>=0 && !num_infty(buf+2*i+1)) {
+ /* bound for -x+y */
+ num_sub(&w,&cb,buf+2*i+1);
+ num_div_by_2(r->c+matpos2(2*i+1,x2+1),&w);
+ }
+ else if (num_cmp_int(tab+i,-1)<=0 && !num_infty(buf+2*i)) {
+ /* bound for -x-y */
+ num_sub(&w,&cb,buf+2*i);
+ num_div_by_2(r->c+matpos2(2*i, x2+1),&w);
+ }
+ }
+ changed = 1;
+ break;
+ case 1:
+ /* bound has only one infinite coef, for var y of index ci =>
+ we may still have a finite bound for -x+y, or -x-y */
+ if (ci!=x) {
+ if (!num_cmp_int(tab+ci,1)) num_div_by_2(r->c+matpos2(x2,ci*2 ),&cb);
+ else if (!num_cmp_int(tab+ci,-1)) num_div_by_2(r->c+matpos2(x2,ci*2+1),&cb);
+ }
+ changed = 1;
+ break;
+ }
+ num_clear_n(buf,n2); oct_mm_free (buf);
+ num_clear(&cb); num_clear(&Cb); num_clear(&w);
+ if (changed) oct_close_incremental(r,x);
+ }
+ end:
+ OCT_EXIT("oct_assign_variable",26);
+ return r;
+}
+
+
+
+/* transfer function modeling backward semantics of assignment x -> e
+ e = tab[0]v0 + tab[1]v1 + ... + tab[N-1]v(N-1) + tab[N]
+ the operation is exact for assignments of the form
+ x -> c
+ x -> x + c
+ x -> -x + c
+ x -> y + c (x!=y)
+ x -> -y + c (x!=y)
+ for other assignments, this call is equivalent to oct_forget!
+ THE GENERAL CASE COULD BE IMPROVED
+
+ if the result is not empty, it is always a newly allocated matrix
+ that can be safely modified in-place
+
+ often need to close its argument
+ returns a closed result whenever possible
+ */
+oct_t*
+OCT_PROTO(substitute_variable) (oct_t* m,
+ var_t x,
+ const num_t* tab,
+ bool destructive)
+{
+ oct_t* r;
+ var_t i, y, N = 0;
+ const var_t n2 = m->n*2;
+ const var_t x2 = 2*x;
+ const num_t* c = tab+m->n;
+ OCT_ENTER("oct_substitute_variable",27);
+ OCT_ASSERT(x<m->n,"variable index greater than the number of variables in oct_substitute_variable");
+
+ if (oct_is_empty_lazy(m)==tbool_true)
+ if (destructive) { r = m; goto end; }
+ else { r = oct_copy(m); goto end; }
+
+ if (num_infty(c)) { r = oct_forget (m, x, destructive); goto end; }
+ for (i=0;i<m->n;i++)
+ if (num_infty(tab+i)) { r = oct_forget (m, x, destructive); goto end; }
+ else if (num_cmp_zero(tab+i)) { y=i; N++; }
+
+ if (N==0) { /* x -> c */
+ oct_t* mm;
+ num_t w1,w2;
+ mm = oct_close (m,destructive,false);
+ num_init(&w1); num_init(&w2);
+ /* result is empty */
+ if (mm->state==OCT_EMPTY) { r = mm; goto end0; }
+ num_mul_by_2(&w1,c);
+ num_neg(&w2,&w1);
+ if (num_cmp(&w1,mm->c+matpos(x2+1,x2))>0 ||
+ num_cmp(&w2,mm->c+matpos(x2,x2+1))>0)
+ { r = oct_empty(mm->n); oct_free(mm); goto end0; }
+ /* result is computed in mm, or in a new octagon */
+ if (mm->ref==1) r = mm;
+ else { r = oct_full_copy(mm); mm->ref--; }
+ r->state = OCT_NORMAL;
+ if (r->closed) { oct_free(r->closed); r->closed = (oct_t*)NULL; }
+
+ /* change the result matrix */
+ for (i=0;i<x2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* xi = r->c+matpos(x2 ,i);
+ num_t* ix = r->c+matpos(x2+1,i);
+ num_t* ii = r->c+matpos(i^1,i);
+ num_add(&w1,xi,c);
+ num_sub(&w2,ix,c);
+ num_min(&w1,&w1,&w2);
+ num_mul_by_2(&w1,&w1);
+ num_min(ii,ii,&w1);
+ num_set_infty(xi);
+ num_set_infty(ix);
+ }
+ for (i=x2+2;i<n2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* xi = r->c+matpos(i,x2+1);
+ num_t* ix = r->c+matpos(i,x2 );
+ num_t* ii = r->c+matpos(i,i^1);
+ num_add(&w1,xi,c);
+ num_sub(&w2,ix,c);
+ num_min(&w1,&w1,&w2);
+ num_mul_by_2(&w1,&w1);
+ num_min(ii,ii,&w1);
+ num_set_infty(xi);
+ num_set_infty(ix);
+ }
+ num_set_infty(r->c+matpos(x2,x2+1));
+ num_set_infty(r->c+matpos(x2+1,x2));
+ end0:
+ num_clear(&w1); num_clear(&w2);
+ }
+
+ else if (N==1 && (!num_cmp_int(tab+y,1) || !num_cmp_int(tab+y,-1)))
+ if (y!=x) { /* x -> +/- y + c, x!=y */
+ var_t yy, yy1;
+ oct_t* mm;
+ num_t w;
+ num_init(&w);
+ mm = oct_close (m,destructive,false);
+ if (!num_cmp_int(tab+y,-1)) yy = 2*y+1; else yy = 2*y;
+ yy1 = yy^1;
+ /* result is empty */
+ if (mm->state==OCT_EMPTY) { r = mm; goto end1; }
+ num_neg(&w,c);
+ if (num_cmp(c ,mm->c+matpos2(yy,x2))>0 ||
+ num_cmp(&w,mm->c+matpos2(x2,yy))>0)
+ { r = oct_empty(mm->n); oct_free(mm); goto end1; }
+ /* result is computed in mm, or in a new octagon */
+ if (mm->ref==1) r = mm;
+ else { r = oct_full_copy(mm); mm->ref--; }
+ /* change the result matrix */
+ for (i=0;i<x2;i++) {
+ /* TO BE LINEARIZED */
+ num_t* xi = r->c+matpos(x2 ,i);
+ num_t* ix = r->c+matpos(x2+1,i);
+ num_t* yi = r->c+matpos2(yy ,i);
+ num_t* iy = r->c+matpos2(yy1,i);
+ num_add(xi,xi,c); num_min(yi,yi,xi); num_set_infty(xi);
+ num_sub(ix,ix,c); num_min(iy,iy,ix); num_set_infty(ix);
+ }
+ for (i=x2+2;i<n2;i++) {
+ /* TO BE LINEARIZED */
+ num_t* xi = r->c+matpos(i,x2+1);
+ num_t* ix = r->c+matpos(i,x2 );
+ num_t* yi = r->c+matpos2(i,yy1);
+ num_t* iy = r->c+matpos2(i,yy );
+ num_add(xi,xi,c); num_min(yi,yi,xi); num_set_infty(xi);
+ num_sub(ix,ix,c); num_min(iy,iy,ix); num_set_infty(ix);
+ }
+ {
+ num_t* xi = r->c+matpos(x2 ,x2+1);
+ num_t* ix = r->c+matpos(x2+1,x2 );
+ num_t* yi = r->c+matpos2(yy ,yy1);
+ num_t* iy = r->c+matpos2(yy1,yy );
+ num_mul_by_2(&w,c);
+ num_add(xi,xi,&w); num_min(yi,yi,xi); num_set_infty(xi);
+ num_sub(ix,ix,&w); num_min(iy,iy,ix); num_set_infty(ix);
+ }
+ oct_close_incremental(r,x);
+ end1:
+ num_clear(&w);
+ }
+ else {
+ /* x -> x + c is equivalent to x <- x - c
+ x -> -x + c is equivalent to x <- -x + c
+ they respect closure
+ */
+
+ /* result is computed in m, or in a new octagon */
+ m = oct_close_lazy(m,destructive);
+ if (m->ref==1) r = m;
+ else { r = oct_full_copy(m); m->ref--; }
+ if (r->closed) { oct_free(r->closed); r->closed = (oct_t*)NULL; }
+
+ /* modify the result matrix */
+ if (!num_cmp_int(tab+x,-1)) { /* x -> -x + c */
+ num_t w,ww;
+ num_init(&w); num_init(&ww);
+ num_mul_by_2(&ww,c);
+ for (i=0;i<x2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* xi = r->c+matpos(x2+1,i);
+ num_t* ix = r->c+matpos(x2 ,i);
+ num_set(&w,xi);
+ num_add(xi,ix,c);
+ num_sub(ix,&w,c);
+ }
+ {
+ num_t* xi = r->c+matpos(x2+1,x2 );
+ num_t* ix = r->c+matpos(x2 ,x2+1);
+ num_set(&w,xi);
+ num_add(xi,ix,&ww);
+ num_sub(ix,&w,&ww);
+ }
+ for (i=x2+2;i<n2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* xi = r->c+matpos(i,x2 );
+ num_t* ix = r->c+matpos(i,x2+1);
+ num_set(&w,xi);
+ num_add(xi,ix,c);
+ num_sub(ix,&w,c);
+ }
+ num_clear(&w); num_clear(&ww);
+ }
+ else { /* x -> x + c */
+ num_t ww;
+ num_init(&ww);
+ num_mul_by_2(&ww,c);
+ for (i=0;i<x2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* xi = r->c+matpos(x2 ,i);
+ num_t* ix = r->c+matpos(x2+1,i);
+ num_add(xi,xi,c);
+ num_sub(ix,ix,c);
+ }
+ {
+ num_t* xi = r->c+matpos(x2 ,x2+1);
+ num_t* ix = r->c+matpos(x2+1,x2 );
+ num_add(xi,xi,&ww);
+ num_sub(ix,ix,&ww);
+ }
+ for (i=x2+2;i<n2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* xi = r->c+matpos(i,x2+1);
+ num_t* ix = r->c+matpos(i,x2 );
+ num_add(xi,xi,c);
+ num_sub(ix,ix,c);
+ }
+ num_clear(&ww);
+ }
+
+ }
+
+ else { /* general case */
+ r = oct_forget (m, x, destructive);
+ }
+ end:
+ OCT_EXIT("oct_substitute_variable",27);
+ return r;
+}
+
+
+
+
+
+/* intersects the domain with a linear constraint
+ tab[0]v0 + tab[1]v1 + ... + tab[N-1]v(N-1) + tab[N] >= 0
+
+ if the result is not empty, it is always a newly allocated matrix
+ that can be safely modified in-place
+ */
+oct_t*
+OCT_PROTO(add_constraint) (oct_t* m,
+ const num_t* tab,
+ bool destructive)
+{
+ oct_t* r;
+ var_t i, n = 0;
+ oct_cons c;
+ OCT_ENTER("oct_add_constraint",28);
+
+ if (oct_is_empty_lazy(m)==tbool_true)
+ if (destructive) { r = m; goto end; }
+ else { r = oct_copy(m); goto end; }
+
+ for (i=0;i<m->n;i++)
+ if (num_cmp_zero(tab+i)) { c.x=i; n=1; break; }
+ for (i++;i<m->n;i++)
+ if (num_cmp_zero(tab+i)) { c.y=i; n++; }
+
+ if (n==0) {
+ if (num_cmp_zero(tab+m->n)>=0) r = oct_copy(m);
+ else r = oct_empty (m->n);
+ if (destructive) oct_free (m);
+ }
+
+ else if (n==1 && !num_cmp_int(tab+c.x,1)) {
+ c.type = mx;
+ num_init_set(&c.c,tab+m->n);
+ r = oct_add_bin_constraints (m, 1, &c, destructive);
+ }
+
+ else if (n==1 && !num_cmp_int(tab+c.x,-1)) {
+ c.type = px;
+ num_init_set(&c.c,tab+m->n);
+ r = oct_add_bin_constraints (m, 1, &c, destructive);
+ }
+
+ else if (n==2 && !num_cmp_int(tab+c.x,1) && !num_cmp_int(tab+c.y,1)) {
+ c.type = mxmy;
+ num_init_set(&c.c,tab+m->n);
+ r = oct_add_bin_constraints (m, 1, &c, destructive);
+ }
+
+ else if (n==2 && !num_cmp_int(tab+c.x,1) && !num_cmp_int(tab+c.y,-1)) {
+ c.type = mxpy;
+ num_init_set(&c.c,tab+m->n);
+ r = oct_add_bin_constraints (m, 1, &c, destructive);
+ }
+
+ else if (n==2 && !num_cmp_int(tab+c.x,-1) && !num_cmp_int(tab+c.y,1)) {
+ c.type = pxmy;
+ num_init_set(&c.c,tab+m->n);
+ r = oct_add_bin_constraints (m, 1, &c, destructive);
+ }
+
+ else if (n==2 && !num_cmp_int(tab+c.x,-1) && !num_cmp_int(tab+c.y,-1)) {
+ c.type = pxpy;
+ num_init_set(&c.c,tab+m->n);
+ r = oct_add_bin_constraints (m, 1, &c, destructive);
+ }
+
+ else
+ if (destructive) r = m;
+ else r = oct_copy (m);
+ end:
+ OCT_EXIT("oct_add_constraint",28);
+ return r;
+}
+
+
+
+/**************************/
+/* Experimental operators */
+/**************************/
+
+
+/* as oct_assign_variable, but with interval instead of constant coefficients
+ e = [-t[1];t[0]]v0 + ... + [-t[2N-1];t[2N-2]v(N-1)] + [-t[2N+1;t[2N]]
+
+ beware the sign inversion of the lower bound!
+ make sure the lower bound is less than or equal to the higher bound!
+
+ the result is always closed (thanks to calls to oct_close_incremental)
+ */
+oct_t*
+OCT_PROTO(interv_assign_variable) (oct_t* m,
+ var_t x,
+ const num_t* t,
+ bool destructive)
+{
+ oct_t* r;
+ var_t i, y, N = 0;
+ const var_t n = m->n;
+ const var_t n2 = n*2;
+ const var_t x2 = 2*x;
+ const num_t* c = t+n2;
+ num_t tmp;
+ OCT_ENTER("oct_interv_assign_variable",29);
+ OCT_ASSERT(x<m->n,"variable index greater than the number of variables in oct_interv_assign_variable");
+
+ num_init(&tmp);
+
+ if (oct_is_empty_lazy(m)==tbool_true)
+ if (destructive) { r = m; goto end; }
+ else { r = oct_copy(m); goto end; }
+
+ for (i=0;i<n;i++)
+ if (num_infty(t+2*i) || num_infty(t+2*i+1))
+ { r = oct_forget (m, x, destructive); goto end; }
+ else {
+ num_add(&tmp,t+2*i,t+2*i+1);
+ if (num_cmp_zero(&tmp)<0) {
+ r = oct_empty(m->n);
+ if (destructive) oct_free(m);
+ goto end;
+ }
+ if (num_cmp_zero(t+2*i) || num_cmp_zero(t+2*i+1)) { y=i; N++; }
+ }
+
+ num_add(&tmp,c,c+1);
+ if (num_cmp_zero(&tmp)<0) {
+ r = oct_empty(m->n);
+ if (destructive) oct_free(m);
+ goto end;
+ }
+
+ if (N==0) /* x <- [-d,c] */
+ r = oct_set_bounds (m, x,c,c+1,destructive);
+
+ else if (N==1 &&
+ ((!num_cmp_int(t+2*y, 1) && !num_cmp_int(t+2*y+1,-1)) ||
+ (!num_cmp_int(t+2*y,-1) && !num_cmp_int(t+2*y+1, 1))))
+
+ /* x <- +/- y + [-d,c] */
+
+ if (y!=x) { /* x <- +/- y + [-d,c], x!=y */
+ r = oct_forget (m, x, destructive);
+ if (r->state==OCT_EMPTY) goto end;
+ if (!num_cmp_int(t+2*y,1)) { /* x <- y + [-d,c], y!=x */
+ num_set(r->c+matpos2(2*y,x2),c);
+ num_set(r->c+matpos2(x2,2*y),c+1);
+ }
+ else { /* x <- -y + [-d,c], y!=x */
+ num_set(r->c+matpos2(2*y+1,x2),c);
+ num_set(r->c+matpos2(x2,2*y+1),c+1);
+ }
+ oct_close_incremental(r,x);
+ }
+
+ else { /* x <- +/- x + [-d,c] respects closure */
+
+ /* result is computed in m, or in a new octagon */
+ m = oct_close_lazy(m,destructive);
+ if (m->ref==1) r = m;
+ else { r = oct_full_copy(m); m->ref--; }
+ if (r->closed) { oct_free(r->closed); r->closed = (oct_t*)NULL; }
+
+ /* modify the result matrix */
+ if (!num_cmp_int(t+2*x,-1)) { /* x <- -x + [-d,c] */
+ num_t w,vv,ww;
+ num_init(&w); num_init(&vv); num_init(&ww);
+ num_mul_by_2(&vv,c); num_mul_by_2(&ww,c+1);
+ for (i=0;i<x2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* xi = r->c+matpos(x2 ,i);
+ num_t* ix = r->c+matpos(x2+1,i);
+ num_set(&w,xi);
+ num_add(xi,ix,c+1);
+ num_add(ix,&w,c);
+ }
+ num_set(&w,r->c+matpos(x2,x2+1));
+ num_add(r->c+matpos(x2,x2+1),r->c+matpos(x2+1,x2),&ww);
+ num_add(r->c+matpos(x2+1,x2),&w ,&vv);
+ for (i=x2+2;i<n2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* xi = r->c+matpos(i,x2+1);
+ num_t* ix = r->c+matpos(i,x2 );
+ num_set(&w,xi);
+ num_add(xi,ix,c+1);
+ num_add(ix,&w,c);
+ }
+ num_clear(&w); num_clear(&vv); num_clear(&ww);
+ }
+ else { /* x <- x + [-d,c] */
+ num_t vv,ww;
+ num_init(&vv); num_init(&ww);
+ num_mul_by_2(&vv,c); num_mul_by_2(&ww,c+1);
+ for (i=0;i<x2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* xi = r->c+matpos(x2 ,i);
+ num_t* ix = r->c+matpos(x2+1,i);
+ num_add(xi,xi,c+1);
+ num_add(ix,ix,c);
+ }
+ num_add(r->c+matpos(x2+1,x2),r->c+matpos(x2+1,x2),&vv);
+ num_add(r->c+matpos(x2,x2+1),r->c+matpos(x2,x2+1),&ww);
+ for (i=x2+2;i<n2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* xi = r->c+matpos(i,x2+1);
+ num_t* ix = r->c+matpos(i,x2 );
+ num_add(xi,xi,c+1);
+ num_add(ix,ix,c);
+ }
+ num_clear(&vv); num_clear(&ww);
+ }
+ }
+
+ else { /* general case */
+ num_t* buf; /* 2*bounds for each variable */
+ num_t Cb,cb; /* 2*global upper / lower bound */
+ int Cinf, cinf; /* number of infinite coef in up/lw bounds */
+ var_t Ci, ci; /* var leading to infinite coef in up/lw bounds */
+ num_t ka,kb,kc,kd;
+ int changed = 0;
+ r = oct_close (m,destructive,false);
+ if (r->state==OCT_EMPTY) goto end;
+ buf = new_n(num_t,n2);
+ num_init(&Cb); num_init(&cb);
+ num_init(&ka); num_init(&kb); num_init(&kc); num_init(&kd);
+ num_mul_by_2(&Cb,c); num_mul_by_2(&cb,c+1);
+ Cinf = cinf = 0;
+ for (i=0;i<n2;i+=2) {
+ /* get variable bounds */
+ num_t* px = r->c+matpos(i+1,i); /* xj+xj */
+ num_t* mx = r->c+matpos(i,i+1); /* -xj-xj */
+
+ num_init_set(buf+i ,px);
+ num_init_set(buf+i+1,mx);
+
+ /* compute Cb & cb ignoring components leading to +oo */
+
+ /* max */
+ if (!num_cmp_zero(t+i)) num_set_int(&ka,0);
+ else {
+ num_mul(&ka,t+i ,px);
+ num_neg(&kb,t+i);
+ num_mul(&kb,&kb,mx);
+ num_max(&ka,&ka,&kb);
+ }
+ if (!num_cmp_zero(t+i+1)) num_set_int(&kc,0);
+ else {
+ num_mul(&kc,t+i+1,mx);
+ num_neg(&kd,t+i+1);
+ num_mul(&kd,&kd,px);
+ num_max(&kc,&kc,&kd);
+ }
+ num_max(&ka,&ka,&kc);
+ if (num_infty(&ka)) { Cinf++; Ci=i; } else num_add(&Cb,&Cb,&ka);
+
+ /* -min */
+ if (!num_cmp_zero(t+i)) num_set_int(&ka,0);
+ else {
+ num_mul(&ka,t+i ,mx);
+ num_neg(&kb,t+i);
+ num_mul(&kb,&kb,px);
+ num_max(&ka,&ka,&kb);
+ }
+ if (!num_cmp_zero(t+i+1)) num_set_int(&kc,0);
+ else {
+ num_mul(&kc,t+i+1,px);
+ num_neg(&kd,t+i+1);
+ num_mul(&kd,&kd,mx);
+ num_max(&kc,&kc,&kd);
+ }
+ num_max(&ka,&ka,&kc);
+ if (num_infty(&ka)) { cinf++; ci=i; } else num_add(&cb,&cb,&ka);
+ }
+
+ r = oct_forget (r,x,true);
+
+ /* upper bounds */
+ if (!num_infty(&Cb))
+ switch (Cinf) {
+ case 0:
+ /* bound is not infinite */
+ num_set(r->c+matpos(x2+1,x2),&Cb); /* bound for x */
+ for (i=0;i<n2;i+=2)
+ if (i!=x2) {
+ if (num_cmp_int(t+i+1,-1)<=0 && !num_infty(buf+i)) {
+ /* bound for x-y */
+ num_sub(&ka,&Cb,buf+i);
+ num_div_by_2(r->c+matpos2(i, x2),&ka);
+ }
+ else if (num_cmp_int(t+i,-1)<=0 && !num_infty(buf+i+1)) {
+ /* bound for x+y */
+ num_sub(&ka,&Cb,buf+i+1);
+ num_div_by_2(r->c+matpos2(i+1,x2),&ka);
+ }
+ }
+ changed = 1;
+ break;
+ case 1:
+ /* bound has only one infinite coef, for var y of index Ci =>
+ we may still have a finite bound for x-y, or x+y */
+ if (Ci!=x2) {
+ if (!num_cmp_int(t+Ci,1) && !num_cmp_int(t+Ci+1,-1)) {
+ num_div_by_2(r->c+matpos2(Ci ,x2),&Cb);
+ changed = 1;
+ }
+ else if (!num_cmp_int(t+Ci,-1) && !num_cmp_int(t+Ci+1,1)) {
+ num_div_by_2(r->c+matpos2(Ci+1,x2),&Cb);
+ changed = 1;
+ }
+ }
+ break;
+ }
+
+ /* lower bounds */
+ if (!num_infty(&cb))
+ switch (cinf) {
+ case 0:
+ /* bound is not infinite */
+ num_set(r->c+matpos(x2,x2+1),&cb); /* bound for -x */
+ for (i=0;i<n2;i+=2)
+ if (i!=x2) {
+ if (num_cmp_int(t+i+1,-1)<=0 && !num_infty(buf+i+1)) {
+ /* bound for -x+y */
+ num_sub(&ka,&cb,buf+i+1);
+ num_div_by_2(r->c+matpos2(i+1,x2+1),&ka);
+
+ }
+ else if (num_cmp_int(t+i,-1)<=0 && !num_infty(buf+i)) {
+ /* bound for -x-y */
+ num_sub(&ka,&cb,buf+i);
+ num_div_by_2(r->c+matpos2(i, x2+1),&ka);
+ }
+ }
+ changed = 1;
+ break;
+ case 1:
+ /* bound has only one infinite coef, for var y of index ci =>
+ we may still have a finite bound for -x+y, or -x-y */
+ if (ci!=x2) {
+ if (!num_cmp_int(t+ci,1) && !num_cmp_int(t+ci+1,-1)) {
+ num_div_by_2(r->c+matpos2(x2,ci ),&cb);
+ changed = 1;
+ }
+ else if (!num_cmp_int(t+ci,-1) && !num_cmp_int(t+ci+1,1)) {
+ num_div_by_2(r->c+matpos2(x2,ci+1),&cb);
+ changed = 1;
+ }
+ }
+ break;
+ }
+ num_clear_n(buf,n2); oct_mm_free (buf);
+ num_clear(&cb); num_clear(&Cb);
+ num_clear(&ka); num_clear(&kb); num_clear(&kc); num_clear(&kd);
+ if (changed) oct_close_incremental(r,x);
+ }
+ end:
+ num_clear(&tmp);
+ OCT_EXIT("oct_interv_assign_variable",29);
+ return r;
+}
+
+
+
+/* as oct_add_constraint, but with interval instead of constant coefficients
+ [-t[1];t[0]]v0 + ... + [-t[2N-1];t[2N-2]v(N-1)] + [-t[2N+1;t[2N]] >= 0
+*/
+oct_t*
+OCT_PROTO(interv_add_constraint) (oct_t* m,
+ const num_t* t,
+ bool destructive)
+{
+ oct_t* r;
+ var_t i, j, k, y1, y2, N = 0;
+ const var_t n = m->n;
+ const var_t n2 = n*2;
+ const num_t* c = t+n2;
+ num_t tmp;
+ OCT_ENTER("oct_interv_add_constraint",46);
+
+ num_init(&tmp);
+
+ if (oct_is_empty_lazy(m)==tbool_true)
+ { if (destructive) r = m; else r = oct_copy(m); goto end; }
+
+ for (i=0;i<n2;i+=2) {
+ if (num_infty(t+i) || num_infty(t+i+1))
+ { if (destructive) r = m; else r = oct_copy(m); goto end; }
+ num_add(&tmp,t+i,t+i+1);
+ if (num_cmp_zero(&tmp)<0)
+ { if (destructive) r = m; else r = oct_copy(m); goto end; }
+ if (num_cmp_zero(t+i) || num_cmp_zero(t+i+1)) { y2=y1; y1=i; N++; }
+ }
+
+ num_add(&tmp,c,c+1);
+ if (num_cmp_zero(&tmp)<0)
+ { if (destructive) r = m; else r = oct_copy(m); goto end; }
+
+ if (N==0) { /* [-d,c] >= 0 */
+ if (num_cmp_int(c,0)>=0) r = oct_copy(m);
+ else r = oct_empty (m->n);
+ if (destructive) oct_free(m);
+ }
+
+ else if (N==1 && /* +/- x + [-d,c] >= 0 */
+ ((!num_cmp_int(t+y1, 1) && !num_cmp_int(t+y1+1,-1)) ||
+ (!num_cmp_int(t+y1,-1) && !num_cmp_int(t+y1+1, 1)))) {
+ oct_cons cons;
+ cons.x = y1/2;
+ num_init_set(&cons.c,c);
+ if (!num_cmp_int(t+y1,1)) cons.type = mx; else cons.type = px;
+ r = oct_add_bin_constraints(m, 1, &cons, destructive);
+ num_clear(&cons.c);
+ }
+
+
+ else if (N==2 && /* +/- x +/-y + [-d,c] >= 0 */
+ ((!num_cmp_int(t+y1, 1) && !num_cmp_int(t+y1+1,-1)) ||
+ (!num_cmp_int(t+y1,-1) && !num_cmp_int(t+y1+1, 1))) &&
+ ((!num_cmp_int(t+y2, 1) && !num_cmp_int(t+y2+1,-1)) ||
+ (!num_cmp_int(t+y2,-1) && !num_cmp_int(t+y2+1, 1)))) {
+
+ oct_cons cons;
+ cons.x = y1/2;
+ cons.y = y2/2;
+ num_init_set(&cons.c,c);
+ if (!num_cmp_int(t+y1,1)) {
+ if (!num_cmp_int(t+y2,1)) cons.type = mxmy; else cons.type = mxpy;
+ }
+ else {
+ if (!num_cmp_int(t+y2,1)) cons.type = pxmy; else cons.type = pxpy;
+ }
+ r = oct_add_bin_constraints(m, 1, &cons, destructive);
+ num_clear(&cons.c);
+ }
+
+ /* general case */
+ else {
+ num_t* buf; /* 2*bounds for each variable */
+ num_t Cb; /* 2*global upper bound */
+ int Cinf; /* number of infinite coef in up bound */
+ var_t Ci1; /* var1 leading to infinite coef in up bound */
+ var_t Ci2; /* var2 leading to infinite coef in up bound */
+ num_t ka,kb,kc,kd;
+ int changed = 0;
+ r = oct_close (m,destructive,false);
+ if (r->state==OCT_EMPTY) goto end;
+ buf = new_n(num_t,n2);
+ num_init(&Cb);
+ num_init(&ka); num_init(&kb); num_init(&kc); num_init(&kd);
+ num_mul_by_2(&Cb,c);
+ Cinf = 0;
+
+ for (i=0;i<n2;i+=2) {
+ /* get variable bounds, ignoring components leading to +oo */
+ num_t* px = r->c+matpos(i+1,i); /* xj+xj */
+ num_t* mx = r->c+matpos(i,i+1); /* -xj-xj */
+
+ num_init_set(buf+i ,px);
+ num_init_set(buf+i+1,mx);
+
+ /* max */
+ if (!num_cmp_zero(t+i)) num_set_int(&ka,0);
+ else {
+ num_mul(&ka,t+i ,px);
+ num_neg(&kb,t+i);
+ num_mul(&kb,&kb,mx);
+ num_max(&ka,&ka,&kb);
+ }
+ if (!num_cmp_zero(t+i+1)) num_set_int(&kc,0);
+ else {
+ num_mul(&kc,t+i+1,mx);
+ num_neg(&kd,t+i+1);
+ num_mul(&kd,&kd,px);
+ num_max(&kc,&kc,&kd);
+ }
+ num_max(&ka,&ka,&kc);
+ if (num_infty(&ka)) { Cinf++; Ci2=Ci1; Ci1=i; }
+ else num_add(&Cb,&Cb,&ka);
+ }
+
+ /* get a copy of r to modify in-place */
+ oct_free(r);
+ r = oct_full_copy(m);
+
+ if (!num_infty(&Cb))
+ switch (Cinf) {
+ case 0:
+ /* no infinite bound */
+ for (i=0;i<n2;i+=2) {
+ if (num_cmp_int(t+i+1,-1)<=0 && !num_infty(buf+i)) {
+ // -x <= expr-x <= max(expr) - max x
+ num_sub(&ka,&Cb,buf+i);
+ num_min(r->c+matpos(i,i+1),r->c+matpos(i,i+1),&ka);
+ k = i+1;
+ changed = 1;
+ }
+ else if (num_cmp_int(t+i,-1)<=0 && !num_infty(buf+i+1)) {
+ // x <= expr+x <= max(expr) - max(-x)
+ num_sub(&ka,&Cb,buf+i+1);
+ num_min(r->c+matpos(i+1,i),r->c+matpos(i+1,i),&ka);
+ k = i;
+ changed = 1;
+ }
+ else k = -1;
+
+ if (k!=-1) {
+ for (j=i+2;j<n2;j+=2) {
+ if (num_cmp_int(t+j+1,-1)<=0 && !num_infty(buf+j)) {
+ // (+/-)x -y <= max(expr) - max((+/-)x) - max y
+ num_sub(&kb,&ka,buf+j);
+ num_div_by_2(&kb,&kb);
+ num_min(r->c+matpos(j,k),r->c+matpos(j,k),&kb);
+ changed = 1;
+ }
+ else if (num_cmp_int(t+j,-1)<=0 && !num_infty(buf+j+1)) {
+ // (+/-)x +y <= max(expr) - max((+/-)x) - max (-y)
+ num_sub(&kb,&ka,buf+j+1);
+ num_div_by_2(&kb,&kb);
+ num_min(r->c+matpos(j+1,k),r->c+matpos(j+1,k),&kb);
+ changed = 1;
+ }
+ }
+ }
+ }
+ break;
+
+ case 1:
+ /* we can still infer info on Ci1 */
+ if (!num_cmp_int(t+Ci1, 1) && !num_cmp_int(t+Ci1+1,-1)) k = Ci1+1;
+ else if (!num_cmp_int(t+Ci1,-1) && !num_cmp_int(t+Ci1+1, 1)) k = Ci1;
+ else goto end0;
+
+ num_min(r->c+matpos(k^1,k),r->c+matpos(k^1,k),&Cb);
+ changed = 1;
+
+ for (j=0;j<n2;j+=2)
+ if (Ci1!=j) {
+ if (num_cmp_int(t+j+1,-1)<=0 && !num_infty(buf+j)) {
+ // (+/-)x -y <= max(expr) - max((+/-)x) - max y
+ num_sub(&kb,&Cb,buf+j);
+ num_div_by_2(&kb,&kb);
+ num_min(r->c+matpos2(j,k),r->c+matpos2(j,k),&kb);
+ }
+ else if (num_cmp_int(t+j,-1)<=0 && !num_infty(buf+j+1)) {
+ // (+/-)x +y <= max(expr) - max((+/-)x) - max (-y)
+ num_sub(&kb,&Cb,buf+j+1);
+ num_div_by_2(&kb,&kb);
+ num_min(r->c+matpos2(j+1,k),r->c+matpos2(j+1,k),&kb);
+ }
+ }
+ break;
+
+ case 2:
+ /* we can still infer info on Ci1 & Ci2 */
+ if (!num_cmp_int(t+Ci1, 1) && !num_cmp_int(t+Ci1+1,-1)) i = Ci1+1;
+ else if (!num_cmp_int(t+Ci1,-1) && !num_cmp_int(t+Ci1+1, 1)) i = Ci1;
+ else goto end0;
+
+ if (!num_cmp_int(t+Ci2, 1) && !num_cmp_int(t+Ci2+1,-1)) j = Ci1+1;
+ else if (!num_cmp_int(t+Ci2,-1) && !num_cmp_int(t+Ci2+1, 1)) j = Ci1;
+ else goto end0;
+
+ num_div_by_2(&ka,&Cb);
+ num_min(r->c+matpos2(j^1,i),r->c+matpos2(j^1,i),&kb);
+ changed = 1;
+ break;
+ }
+
+ if (changed) r->state = OCT_NORMAL;
+
+ end0:
+ num_clear_n(buf,n2); oct_mm_free (buf);
+ num_clear(&Cb);
+ num_clear(&ka); num_clear(&kb); num_clear(&kc); num_clear(&kd);
+ }
+
+ end:
+ num_clear(&tmp);
+ OCT_EXIT("oct_interv_add_constraint",46);
+ return r;
+}
+
+
+/* as oct_substitute_variable, but with interval instead of constant coefs
+ e -> [-t[1];t[0]]v0 + ... + [-t[2N-1];t[2N-2]v(N-1)] + [-t[2N+1;t[2N]]
+
+ NOTE: the general case is not yet implemented...
+*/
+oct_t*
+OCT_PROTO(interv_substitute_variable) (oct_t* m,
+ var_t x,
+ const num_t* t,
+ bool destructive)
+{
+ oct_t* r;
+ var_t i, y, N = 0;
+ const var_t n = m->n;
+ const var_t n2 = n*2;
+ const var_t x2 = 2*x;
+ const num_t* c = t+n2;
+ num_t tmp;
+
+ OCT_ENTER("oct_interv_substitute_variable",47);
+ OCT_ASSERT(x<m->n,"variable index greater than the number of variables in oct_interv_substitute_variable");
+
+ num_init(&tmp);
+
+ if (oct_is_empty_lazy(m)==tbool_true)
+ if (destructive) { r = m; goto end; }
+ else { r = oct_copy(m); goto end; }
+
+ for (i=0;i<n;i++)
+ if (num_infty(t+2*i) || num_infty(t+2*i+1))
+ { r = oct_forget (m, x, destructive); goto end; }
+ else {
+ num_add(&tmp,t+2*i,t+2*i+1);
+ if (num_cmp_zero(&tmp)<0) {
+ r = oct_empty(m->n);
+ if (destructive) oct_free(m);
+ goto end;
+ }
+ if (num_cmp_zero(t+2*i) || num_cmp_zero(t+2*i+1)) { y=i; N++; }
+ }
+
+ num_add(&tmp,c,c+1);
+ if (num_cmp_zero(&tmp)<0) {
+ r = oct_empty(m->n);
+ if (destructive) oct_free(m);
+ goto end;
+ }
+
+ if (N==0) { /* x -> [-d,c] */
+ oct_t* mm;
+ num_t w1,w2;
+ mm = oct_close (m,destructive,false);
+ num_init(&w1); num_init(&w2);
+ /* result is empty */
+ if (mm->state==OCT_EMPTY) { r = mm; goto end0; }
+ num_mul_by_2(&w1,c); num_neg(&w1,&w1);
+ num_mul_by_2(&w2,c+1); num_neg(&w2,&w2);
+ if (num_cmp(mm->c+matpos(x2+1,x2),&w2)<0 ||
+ num_cmp(mm->c+matpos(x2,x2+1),&w1)<0)
+ { r = oct_empty(mm->n); oct_free(mm); goto end0; }
+ /* result is computed in mm, or in a new octagon */
+ if (mm->ref==1) r = mm;
+ else { r = oct_full_copy(mm); mm->ref--; }
+ r->state = OCT_NORMAL;
+ if (r->closed) { oct_free(r->closed); r->closed = (oct_t*)NULL; }
+
+ /* change the result matrix */
+ for (i=0;i<x2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* xi = r->c+matpos(x2 ,i);
+ num_t* ix = r->c+matpos(x2+1,i);
+ num_t* ii = r->c+matpos(i^1,i);
+ num_add(&w1,xi,c);
+ num_add(&w2,ix,c+1);
+ num_min(&w1,&w1,&w2);
+ num_mul_by_2(&w1,&w1);
+ num_min(ii,ii,&w1);
+ num_set_infty(xi);
+ num_set_infty(ix);
+ }
+ for (i=x2+2;i<n2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* xi = r->c+matpos(i,x2+1);
+ num_t* ix = r->c+matpos(i,x2 );
+ num_t* ii = r->c+matpos(i,i^1);
+ num_add(&w1,xi,c);
+ num_add(&w2,ix,c+1);
+ num_min(&w1,&w1,&w2);
+ num_mul_by_2(&w1,&w1);
+ num_min(ii,ii,&w1);
+ num_set_infty(xi);
+ num_set_infty(ix);
+ }
+ num_set_infty(r->c+matpos(x2,x2+1));
+ num_set_infty(r->c+matpos(x2+1,x2));
+ end0:
+ num_clear(&w1); num_clear(&w2);
+ }
+
+ else if (N==1 &&
+ (!num_cmp_int(t+2*y, 1) && !num_cmp_int(t+2*y+1,-1) ||
+ !num_cmp_int(t+2*y,-1) && !num_cmp_int(t+2*y+1, 1))) {
+ if (y!=x) { /* x -> +/- y + [-d,c], x!=y */
+ var_t yy, yy1;
+ oct_t* mm;
+ num_t w,ww;
+ num_init(&w); num_init(&ww);
+ mm = oct_close (m,destructive,false);
+ if (!num_cmp_int(t+2*y,-1)) yy = 2*y+1; else yy = 2*y;
+ yy1 = yy^1;
+ /* result is empty */
+ if (mm->state==OCT_EMPTY) { r = mm; goto end1; }
+ num_neg(&w, c);
+ num_neg(&ww,c+1);
+ if (num_cmp(&ww ,mm->c+matpos2(yy,x2))>0 ||
+ num_cmp(&w, mm->c+matpos2(x2,yy))>0)
+ { r = oct_empty(mm->n); oct_free(mm); goto end1; }
+ /* result is computed in mm, or in a new octagon */
+ if (mm->ref==1) r = mm;
+ else { r = oct_full_copy(mm); mm->ref--; }
+ /* change the result matrix */
+ for (i=0;i<x2;i++) {
+ /* TO BE LINEARIZED */
+ num_t* xi = r->c+matpos(x2 ,i);
+ num_t* ix = r->c+matpos(x2+1,i);
+ num_t* yi = r->c+matpos2(yy ,i);
+ num_t* iy = r->c+matpos2(yy1,i);
+ num_add(xi,xi,c ); num_min(yi,yi,xi); num_set_infty(xi);
+ num_add(ix,ix,c+1); num_min(iy,iy,ix); num_set_infty(ix);
+ }
+ for (i=x2+2;i<n2;i++) {
+ /* TO BE LINEARIZED */
+ num_t* xi = r->c+matpos(i,x2+1);
+ num_t* ix = r->c+matpos(i,x2 );
+ num_t* yi = r->c+matpos2(i,yy1);
+ num_t* iy = r->c+matpos2(i,yy );
+ num_add(xi,xi,c ); num_min(yi,yi,xi); num_set_infty(xi);
+ num_add(ix,ix,c+1); num_min(iy,iy,ix); num_set_infty(ix);
+ }
+ {
+ num_t* xi = r->c+matpos(x2 ,x2+1);
+ num_t* ix = r->c+matpos(x2+1,x2 );
+ num_t* yi = r->c+matpos2(yy ,yy1);
+ num_t* iy = r->c+matpos2(yy1,yy );
+ num_mul_by_2(&w,c);
+ num_mul_by_2(&ww,c+1);
+ num_add(xi,xi,&w ); num_min(yi,yi,xi); num_set_infty(xi);
+ num_add(ix,ix,&ww); num_min(iy,iy,ix); num_set_infty(ix);
+ }
+ oct_close_incremental(r,x);
+ end1:
+ num_clear(&w); num_clear(&ww);
+ }
+ else {
+ /* x -> x + [-d,c] is equivalent to x <- x - [-d,c]
+ x -> -x + [-d,c] is equivalent to x <- -x + [-d,c]
+ they respect closure
+ */
+
+ /* result is computed in m, or in a new octagon */
+ m = oct_close_lazy(m,destructive);
+ if (m->ref==1) r = m;
+ else { r = oct_full_copy(m); m->ref--; }
+ if (r->closed) { oct_free(r->closed); r->closed = (oct_t*)NULL; }
+
+ /* modify the result matrix */
+ if (!num_cmp_int(t+2*x,-1)) { /* x <- -x + [-d,c] */
+ num_t w,vv,ww;
+ num_init(&w); num_init(&vv); num_init(&ww);
+ num_mul_by_2(&vv,c); num_mul_by_2(&ww,c+1);
+ for (i=0;i<x2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* xi = r->c+matpos(x2 ,i);
+ num_t* ix = r->c+matpos(x2+1,i);
+ num_set(&w,xi);
+ num_add(xi,ix,c+1);
+ num_add(ix,&w,c);
+ }
+ num_set(&w,r->c+matpos(x2,x2+1));
+ num_add(r->c+matpos(x2,x2+1),r->c+matpos(x2+1,x2),&ww);
+ num_add(r->c+matpos(x2+1,x2),&w ,&vv);
+ for (i=x2+2;i<n2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* xi = r->c+matpos(i,x2+1);
+ num_t* ix = r->c+matpos(i,x2 );
+ num_set(&w,xi);
+ num_add(xi,ix,c+1);
+ num_add(ix,&w,c);
+ }
+ num_clear(&w); num_clear(&vv); num_clear(&ww);
+ }
+ else { /* x <- x - [-d,c] */
+ num_t vv,ww;
+ num_init(&vv); num_init(&ww);
+ num_mul_by_2(&vv,c); num_mul_by_2(&ww,c+1);
+ for (i=0;i<x2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* xi = r->c+matpos(x2 ,i);
+ num_t* ix = r->c+matpos(x2+1,i);
+ num_add(xi,xi,c);
+ num_add(ix,ix,c+1);
+ }
+ num_add(r->c+matpos(x2+1,x2),r->c+matpos(x2+1,x2),&ww);
+ num_add(r->c+matpos(x2,x2+1),r->c+matpos(x2,x2+1),&vv);
+ for (i=x2+2;i<n2;i++) {
+ /* (TO BE LINEARIZED TO AVOID MULTIPLICATION) */
+ num_t* xi = r->c+matpos(i,x2+1);
+ num_t* ix = r->c+matpos(i,x2 );
+ num_add(xi,xi,c);
+ num_add(ix,ix,c+1);
+ }
+ num_clear(&vv); num_clear(&ww);
+ }
+
+ }
+
+ }
+ else { /* general case */
+ r = oct_forget (m, x, destructive);
+ /* not yet implemented */
+ }
+
+ end:
+ num_clear(&tmp);
+ OCT_EXIT("oct_interv_substitute_variable",47);
+ return r;
+}
+
+
+/* Modify all variables of the octagon simultaneously by the formula
+ r_i <- r_i + [nmin,nmax] * [-tab[2*i+1],tab[2*i]]
+ This simulates time flow.
+ The amout of time t is in [nmin,nmax], and each variable Vi has a change
+ rate in [-tab[2*i+1],tab[2*i]].
+ We must have 0 <= nmin <= nmax.
+ This function has a O(n^2) complexity.
+ Original code by Damien Masse.
+*/
+oct_t*
+OCT_PROTO(time_flow) (oct_t* m,
+ const num_t *nmin, const num_t *nmax, const num_t *tab,
+ bool destructive)
+{
+ var_t i,j;
+ const var_t n2 = m->n*2;
+ int a;
+ num_t tmp, *c;
+ oct_t* r;
+ OCT_ENTER("oct_time_flow",56);
+ OCT_ASSERT((num_cmp_zero(nmin)>=0) && (num_cmp(nmax,nmin)>=0),
+ "incorrect range in oct_time_flow");
+ /* m empty => return m */
+ if (oct_is_empty_lazy(m)==tbool_true) {
+ if (destructive) { r = m; goto end; }
+ else { r = oct_copy(m); goto end; }
+ }
+ /* result is computed in m, or in a new octagon */
+ if (destructive) {
+ if (m->ref==1) r = m;
+ else { r = oct_full_copy(m); m->ref--; }
+ }
+ else r = oct_full_copy(m);
+
+ /* change the result matrix */
+ r->state = OCT_NORMAL;
+ if (r->closed) { oct_free(r->closed); r->closed = (oct_t*)NULL; }
+
+ num_init(&tmp);
+ c = r->c;
+ /* we take each constraint once */
+ for (i=0;i<n2;i++) {
+ const var_t br = i|1;
+ const var_t ii = i^1;
+ for (j=0;j<=br;j++,c++) {
+ if (i==j) continue;
+ /* Vj-Vi <= c + [nmin,nmax] * [ -(tab[2i]+tab[2j+1]); tab[2j]+tab[2i+1] ]
+
+ as 0<=nmin<=nmax we have:
+
+ Vj-Vi <= c + max( nmin * tab[2j]+tab[2i+1], nmax * tab[2j]+tab[2i+1] )
+ */
+ num_add(&tmp,tab+ii,tab+j); /* tab[2j]+tab[2i+1] */
+ a=num_cmp_zero(&tmp);
+ if (a==0) continue; /* no modification */
+ num_mul(&tmp,&tmp,(a>0 ? nmax : nmin));
+ num_add(c,c,&tmp);
+ }
+ }
+ num_clear(&tmp);
+ end:
+ OCT_EXIT("oct_time_flow",56);
+ return r;
+}
+
+
+
+/***********************/
+/* Change of Dimension */
+/***********************/
+
+/* add dimsup variables at the end
+ there is no constraints added on the variables: the domain is extruded
+ O(dimsup^2) time cost (plus optionnal copy)
+*/
+oct_t*
+OCT_PROTO(add_dimensions_and_embed) (oct_t* m,
+ var_t dimsup,
+ bool destructive)
+{
+ oct_t* r;
+ const size_t n1=matsize(m->n), n2=matsize(m->n+dimsup);
+ OCT_ENTER("oct_add_dimensions_and_embed",30);
+ if (destructive) {
+ if (m->ref==1) r = m;
+ else { r = oct_full_copy(m); m->ref--; }
+ }
+ else r = oct_full_copy(m);
+
+ if (r->state!=OCT_EMPTY) {
+ size_t i;
+ r->c = renew_n(r->c,num_t,n2);
+ for (i=n1;i<n2;i++) num_init_set_infty(r->c+i);
+ for (i=r->n;i<2*(r->n+dimsup);i++) num_set_int(r->c+matpos(i,i),0);
+ if (r->closed) { oct_free(r->closed); r->closed = (oct_t*)NULL; }
+ }
+ r->n += dimsup;
+ OCT_EXIT("oct_add_dimensions_and_embed",30);
+ return r;
+}
+
+/* add dimsup variables at the end
+ added variables are initialy constrained to be 0
+ O(dimsup^2) time cost (plus optionnal copy)
+*/
+oct_t*
+OCT_PROTO(add_dimensions_and_project) (oct_t* m,
+ var_t dimsup,
+ bool destructive)
+{
+ const var_t n0 = m->n;
+ var_t i;
+ oct_t* r;
+ OCT_ENTER("oct_add_dimensions_and_project",31);
+ r = oct_add_dimensions_and_embed(m,dimsup,destructive);
+ if (r->state!=OCT_EMPTY) {
+ for (i=n0;i<r->n;i++) {
+ num_set_int(r->c+matpos(2*i+1,2*i),0);
+ num_set_int(r->c+matpos(2*i,2*i+1),0);
+ }
+ r->state = OCT_NORMAL;
+ }
+ OCT_EXIT("oct_add_dimensions_and_project",31);
+ return r;
+}
+
+/* remove the dimsup last variables
+ O(n^3) cost for closure
+*/
+oct_t*
+OCT_PROTO(remove_dimensions) (oct_t* m,
+ var_t diminf,
+ bool destructive)
+{
+ oct_t* mm;
+ oct_t* r;
+ const size_t n1=matsize(m->n), n2=matsize(m->n-diminf);
+ OCT_ENTER("oct_remove_dimensions",32);
+ OCT_ASSERT(m->n>=diminf,"removing too many dimensions in oct_remove_dimensions");
+ mm = oct_close(m, destructive, true);
+ if (mm->ref==1) r = mm;
+ else { r = oct_full_copy(mm); mm->ref--; }
+
+ if (r->state!=OCT_EMPTY) {
+ num_clear_n(r->c+n2,n1-n2);
+ r->c = renew_n(r->c,num_t,n2);
+ }
+ r->n -= diminf;
+ OCT_EXIT("oct_remove_dimensions",32);
+ return r;
+}
+
+
+/* add variables, not necessarily at the end
+ there is no constraints added on the variables: the domain is extruded
+ O(newsize^2) time cost
+ copies elements by bunch for improved efficiency
+ always returns a new octagon
+*/
+oct_t*
+OCT_PROTO(add_dimensions_and_embed_multi) (oct_t* m,
+ const dimsup_t* tab,
+ size_t size_tab,
+ bool destructive)
+{
+ size_t i,j,org_j,new_j;
+ size_t new_n;
+ oct_t* r;
+ OCT_ENTER("oct_add_dimensions_and_embed_multi",53);
+ new_n = m->n;
+ for (i=0;i<size_tab;i++) {
+ OCT_ASSERT((!i || tab[i].pos>=tab[i-1].pos) &&
+ tab[i].pos<=m->n,
+ "invalid dimension array in oct_add_dimensions_and_embed_multi");
+ new_n += tab[i].nbdims;
+ }
+ if (m->state==OCT_EMPTY) r = oct_empty(new_n);
+ else {
+ r = oct_universe(new_n);
+ r->state = m->state;
+
+ /* copy first lines */
+ new_j = org_j = tab[0].pos*2;
+ num_set_n(r->c,m->c,matsize(tab[0].pos));
+
+ for (j=0;j<size_tab;j++) {
+ /* skip lines */
+ new_j += tab[j].nbdims*2;
+
+ /* copy lines */
+ {
+ num_t* org_c = m->c + matsize(org_j/2);
+ num_t* new_c = r->c + matsize(new_j/2);
+ size_t last_org_j = ((j<size_tab-1) ? tab[j+1].pos : m->n)*2;
+ for (;org_j<last_org_j;org_j++,new_j++) {
+ size_t size_org_line = org_j+2-(org_j&1);
+ size_t size_new_line = new_j+2-(new_j&1);
+ size_t org_i = 0;
+ size_t new_i = 0;
+ for (i=0;i<size_tab;i++) {
+ /* copy elems */
+ size_t last_org_i = tab[i].pos*2;
+ if (last_org_i>=size_org_line) break; /* partial block */
+ num_set_n(new_c+new_i,org_c+org_i,last_org_i-org_i);
+ new_i += last_org_i-org_i;
+ org_i = last_org_i;
+
+ /* skip elems */
+ new_i += tab[i].nbdims*2;
+ }
+
+ /* copy remaining elems */
+ num_set_n(new_c+new_i,org_c+org_i,size_org_line-org_i);
+
+ /* next line */
+ org_c += size_org_line;
+ new_c += size_new_line;
+ }
+ }
+ }
+ }
+ if (destructive) oct_free(m);
+ OCT_EXIT("oct_add_dimensions_and_embed_multi",53);
+ return r;
+}
+
+
+/* (always returns a new octagon) */
+oct_t*
+OCT_PROTO(add_dimensions_and_project_multi) (oct_t* m,
+ const dimsup_t* tab,
+ size_t size_tab,
+ bool destructive)
+{
+ oct_t* r;
+ OCT_ENTER("oct_add_dimensions_and_project_multi",54);
+ r = oct_add_dimensions_and_embed_multi(m,tab,size_tab,destructive);
+ if (r->state!=OCT_EMPTY) {
+ size_t i,ii;
+ size_t accum = 0;
+ /* modify r in-place */
+ for (i=0;i<size_tab;i++)
+ for (ii=0;ii<tab[i].nbdims;ii++,accum++) {
+ size_t v = 2*(tab[i].pos+accum);
+ num_set_int(r->c+matpos(v+1,v),0);
+ num_set_int(r->c+matpos(v,v+1),0);
+ }
+ r->state = OCT_NORMAL;
+ }
+ OCT_EXIT("oct_add_dimensions_and_project_multi",54);
+ return r;
+}
+
+/* (always returns a new octagon) */
+oct_t*
+OCT_PROTO(remove_dimensions_multi) (oct_t* m,
+ const dimsup_t* tab,
+ size_t size_tab,
+ bool destructive)
+{
+ oct_t* r;
+ size_t i,j,org_j,new_j;
+ size_t new_n;
+ OCT_ENTER("oct_remove_dimensions_multi",55);
+ new_n = m->n;
+ for (i=0;i<size_tab;i++) {
+ OCT_ASSERT((!i || tab[i].pos>=tab[i-1].pos+tab[i-1].nbdims) &&
+ tab[i].pos+tab[i].nbdims<=m->n,
+ "invalid dimension array in oct_remove_dimensions_multi");
+ new_n -= tab[i].nbdims;
+ }
+ m = oct_close(m,destructive,true);
+ if (m->state==OCT_EMPTY) r = oct_empty(new_n);
+ else {
+ r = oct_alloc(new_n);
+ r->state = OCT_CLOSED;
+
+ /* copy first lines */
+ new_j = org_j = tab[0].pos*2;
+ num_set_n(r->c,m->c,matsize(tab[0].pos));
+
+ for (j=0;j<size_tab;j++) {
+ /* skip lines */
+ org_j += tab[j].nbdims*2;
+
+ /* copy lines */
+ {
+ num_t* org_c = m->c + matsize(org_j/2);
+ num_t* new_c = r->c + matsize(new_j/2);
+ size_t last_org_j = ((j<size_tab-1) ? tab[j+1].pos : m->n)*2;
+ for (;org_j<last_org_j;org_j++,new_j++) {
+ size_t size_org_line = org_j+2-(org_j&1);
+ size_t size_new_line = new_j+2-(new_j&1);
+ size_t org_i=0;
+ size_t new_i=0;
+ for (i=0;i<size_tab;i++) {
+ /* copy elems */
+ size_t last_org_i = tab[i].pos*2;
+ if (last_org_i>=size_org_line) break; /* partial block */
+ num_set_n(new_c+new_i,org_c+org_i,last_org_i-org_i);
+ new_i += last_org_i-org_i;
+ org_i = last_org_i;
+
+ /* skip elems */
+ org_i += tab[i].nbdims*2;
+ }
+
+ /* copy remaining elems */
+ if (size_org_line>org_i)
+ num_set_n(new_c+new_i,org_c+org_i,size_org_line-org_i);
+
+ /* next line */
+ org_c += size_org_line;
+ new_c += size_new_line;
+ }
+ }
+ }
+ }
+ oct_free(m);
+ OCT_EXIT("oct_remove_dimensions_multi",55);
+ return r;
+}
+
+
+/* add variables at the end, then apply permutation
+ O(newsize^2) time cost
+ in practice, less efficient than add_dimensions_and_embed and
+ add_dimensions_and_embed_multi
+ (always returns a new octagon)
+*/
+oct_t*
+OCT_PROTO(add_permute_dimensions_and_embed) (oct_t* m,
+ var_t dimsup,
+ const var_t* permutation,
+ bool destructive)
+{
+ const var_t old_n = m->n;
+ const var_t new_n = old_n+dimsup;
+ oct_t* r;
+ OCT_ENTER("oct_add_permute_dimensions_and_embed",57);
+ if (m->state==OCT_EMPTY) r = oct_empty(new_n);
+ else {
+ var_t i,j;
+ num_t* n = m->c;
+ for (i=0;i<new_n;i++)
+ OCT_ASSERT(permutation[i]<new_n,"invalid permutation in oct_add_permute_dimensions_and_embed");
+ r = oct_universe(new_n);
+ r->state = m->state;
+ for (i=0;i<old_n;i++) {
+ const var_t new_ii = 2*permutation[i];
+ for (j=0;j<=i;j++,n+=2) {
+ const var_t new_jj = 2*permutation[j];
+ num_set(r->c+matpos2(new_ii,new_jj),n);
+ num_set(r->c+matpos2(new_ii,new_jj+1),n+1);
+ num_set(r->c+matpos2(new_ii+1,new_jj),n+2*(i+1));
+ num_set(r->c+matpos2(new_ii+1,new_jj+1),n+2*(i+1)+1);
+ }
+ n+=2*(i+1);
+ }
+ }
+ if (destructive) oct_free(m);
+ OCT_EXIT("oct_add_permute_dimensions_and_embed",57);
+ return r;
+}
+
+oct_t*
+OCT_PROTO(add_permute_dimensions_and_project) (oct_t* m,
+ var_t dimsup,
+ const var_t* permutation,
+ bool destructive)
+{
+ const var_t old_n = m->n;
+ const var_t new_n = old_n+dimsup;
+ oct_t* r;
+ OCT_ENTER("oct_add_permute_dimensions_and_project",58);
+ if (m->state==OCT_EMPTY) r = oct_empty(new_n);
+ else {
+ var_t i,j;
+ num_t* n = m->c;
+ for (i=0;i<new_n;i++)
+ OCT_ASSERT(permutation[i]<new_n,"invalid permutation in oct_add_permute_dimensions_and_project");
+ r = oct_universe(new_n);
+ r->state = OCT_NORMAL;
+ for (i=0;i<old_n;i++) {
+ const var_t new_ii = 2*permutation[i];
+ for (j=0;j<=i;j++,n+=2) {
+ const var_t new_jj = 2*permutation[j];
+ num_set(r->c+matpos2(new_ii,new_jj),n);
+ num_set(r->c+matpos2(new_ii,new_jj+1),n+1);
+ num_set(r->c+matpos2(new_ii+1,new_jj),n+2*(i+1));
+ num_set(r->c+matpos2(new_ii+1,new_jj+1),n+2*(i+1)+1);
+ }
+ n+=2*(i+1);
+ }
+ for (i=old_n;i<new_n;i++) {
+ const var_t new_ii = 2*permutation[i];
+ num_set_int(r->c+matpos(new_ii+1,new_ii),0);
+ num_set_int(r->c+matpos(new_ii,new_ii+1),0);
+ }
+ }
+ if (destructive) oct_free(m);
+ OCT_EXIT("oct_add_permute_dimensions_and_project",58);
+ return r;
+}
+
+/* permute, then remove dimensions */
+oct_t*
+OCT_PROTO(permute_remove_dimensions) (oct_t* m,
+ var_t diminf,
+ const var_t* permutation,
+ bool destructive)
+{
+ const var_t old_n = m->n;
+ const var_t new_n = old_n-diminf;
+ const var_t new_n2 = new_n*2;
+ oct_t* r;
+ OCT_ENTER("oct_remove_permute_dimensions",59);
+ m = oct_close(m,destructive,true);
+ if (m->state==OCT_EMPTY) r = oct_empty(new_n);
+ else {
+ var_t i,j;
+ num_t* n = m->c;
+ for (i=0;i<new_n;i++)
+ OCT_ASSERT(permutation[i]<old_n,"invalid permutation in oct_remove_permute_dimensions");
+ r = oct_universe(new_n);
+ r->state = m->state;
+ for (i=0;i<old_n;i++) {
+ const var_t new_ii = 2*permutation[i];
+ if (new_ii<new_n2) {
+ for (j=0;j<=i;j++,n+=2) {
+ const var_t new_jj = 2*permutation[j];
+ if (new_jj<new_n2) {
+ num_set(r->c+matpos2(new_ii,new_jj),n);
+ num_set(r->c+matpos2(new_ii,new_jj+1),n+1);
+ num_set(r->c+matpos2(new_ii+1,new_jj),n+2*(i+1));
+ num_set(r->c+matpos2(new_ii+1,new_jj+1),n+2*(i+1)+1);
+ }
+ }
+ n+=2*(i+1);
+ }
+ else n+=4*(i+1);
+ }
+ }
+ oct_free(m);
+ OCT_EXIT("oct_remove_permute_dimensions",59);
+ return r;
+}
+
+/**************************/
+/* Interval Manipulations */
+/**************************/
+
+/* get bounds for all variables in a fresh array r
+ -r[2i+1] <= v_i <= r[2i]
+ O(n) time cost
+*/
+num_t*
+OCT_PROTO(get_box) (oct_t* m)
+{
+ num_t* t;
+ oct_t* mm;
+ num_t* r = (num_t*)NULL;
+ OCT_ENTER("oct_get_box",33);
+ mm = oct_close(m, false, true);
+ if (mm->state!=OCT_EMPTY) {
+ var_t i;
+ r = new_n(num_t,m->n*2);
+ num_init_n(r,m->n*2);
+ for (i=0;i<m->n;i++) {
+ num_div_by_2(r+2*i ,mm->c+matpos(2*i+1,2*i)); /* ( xi+xi)/2 */
+ num_div_by_2(r+2*i+1,mm->c+matpos(2*i,2*i+1)); /* (-xi-xi)/2 */
+ }
+ }
+ oct_free (mm);
+ OCT_EXIT("oct_get_box",33);
+ return r;
+}
+
+/* get bounds for only one variable
+ - *down <= v_k <= *up
+ O(n) time cost
+*/
+void
+OCT_PROTO(get_bounds) (oct_t* m,
+ const var_t k,
+ num_t* up,
+ num_t* down)
+{
+ oct_t* mm;
+ OCT_ENTER("oct_get_bounds",34);
+ OCT_ASSERT(k<m->n,"variable index greater than the number of variables in oct_get_bounds");
+ mm = oct_close(m, false, true);
+ if (mm->state!=OCT_EMPTY) {
+ num_div_by_2(up ,mm->c+matpos(2*k+1,2*k)); /* ( xk+xk)/2 */
+ num_div_by_2(down,mm->c+matpos(2*k,2*k+1)); /* (-xk-xk)/2 */
+ }
+ oct_free (mm);
+ OCT_EXIT("oct_get_bounds",34);
+}
+
+/* set bounds for one variable:
+ - down <= v_k <= up
+ O(n) time cost
+ */
+oct_t*
+OCT_PROTO(set_bounds) (oct_t* m,
+ const var_t k,
+ const num_t* up,
+ const num_t* down,
+ bool destructive)
+{
+ oct_t* mm;
+ num_t tmp;
+ const var_t k2 = k*2;
+ OCT_ENTER("oct_set_bounds",35);
+ OCT_ASSERT(k<m->n,"variable index greater than the number of variables in oct_set_bounds");
+ num_init(&tmp);
+
+ num_add(&tmp,up,down);
+ if (num_cmp_zero(&tmp)<0) {
+ mm = oct_empty(m->n);
+ if (destructive) oct_free(m);
+ goto end;
+ }
+
+ mm = oct_forget(m, k, destructive);
+ if (mm->state!=OCT_EMPTY) {
+ var_t i;
+ const var_t n2 = mm->n*2;
+
+ num_mul_by_2(mm->c+matpos(k2+1,k2),up); /* ( xk+xk)/2 */
+ num_mul_by_2(mm->c+matpos(k2,k2+1),down); /* (-xk-xk)/2 */
+
+ /* enforce closure */
+ for (i=0;i<k2;i++) {
+ num_div_by_2(&tmp,mm->c+matpos(i^1,i)); /* (xi+xi)/2 */
+ num_add(mm->c+matpos(k2 ,i),&tmp,down); /* xi-xk */
+ num_add(mm->c+matpos(k2+1,i),&tmp,up); /* xi+xk */
+ }
+ for (i=k2+2;i<n2;i++) {
+ num_div_by_2(&tmp,mm->c+matpos(i,i^1)); /* (xi+xi)/2 */
+ num_add(mm->c+matpos(i,k2+1),&tmp,down); /* xi-xk */
+ num_add(mm->c+matpos(i,k2 ),&tmp,up); /* xi+xk */
+ }
+ }
+
+ end:
+ num_clear(&tmp);
+ OCT_EXIT("oct_set_bounds",35);
+ return mm;
+}
+
+/* create an octagon from a list of bounds b
+ -b[2i+1] <= v_i <= b[2i]
+ O(n) time cost
+ */
+oct_t*
+OCT_PROTO(from_box) (const var_t n,
+ const num_t* b)
+{
+ oct_t* m;
+ var_t i;
+ num_t tmp;
+ OCT_ENTER("oct_from_box",36);
+
+ num_init(&tmp);
+
+ m = oct_universe (n);
+ for (i=0;i<n;i++) {
+ num_add(&tmp,b+2*i,b+2*i+1);
+ if (num_cmp_zero(&tmp)<0) {
+ oct_free(m);
+ m = oct_empty(n);
+ goto end;
+ }
+ num_mul_by_2(m->c+matpos(2*i+1,2*i),b+2*i ); /* ( xi+xi)/2 */
+ num_mul_by_2(m->c+matpos(2*i,2*i+1),b+2*i+1); /* (-xi-xi)/2 */
+ }
+ m->state = OCT_NORMAL;
+
+ end:
+ num_clear(&tmp);
+ OCT_EXIT("oct_from_box",36);
+ return m;
+}
+
+
+/****************/
+/* Perturbation */
+/****************/
+
+/* return an octagon where each contraint coefficient a is enlarged
+ by epsilon |a| (thus resulting in a slightly bigger octagon)
+ normal form is lost
+ O(n^2) time cost
+*/
+oct_t*
+OCT_PROTO(add_epsilon) (oct_t* m,
+ const num_t* epsilon,
+ bool destructive)
+{
+ oct_t* r;
+ size_t i;
+ num_t* a;
+ num_t aa;
+ const size_t n = matsize(m->n);
+ OCT_ENTER("oct_add_epsilon",50);
+ /* m empty => return m */
+ if (oct_is_empty_lazy(m)==tbool_true)
+ if (destructive) { r = m; goto end; }
+ else { r = oct_copy(m); goto end; }
+ /* result is computed in m, or in a new octagon */
+ if (destructive) {
+ if (m->ref==1) r = m;
+ else { r = oct_full_copy(m); m->ref--; }
+ }
+ else r = oct_full_copy(m);
+ r->state = OCT_NORMAL;
+ if (r->closed) { oct_free(r->closed); r->closed = (oct_t*)NULL; }
+ num_init(&aa);
+ for (i=0,a=r->c;i<n;i++,a++)
+ if (num_cmp_zero(a)>=0) {
+ num_mul(&aa,a,epsilon);
+ num_add(a,a,&aa);
+ }
+ else {
+ num_neg(&aa,a);
+ num_mul(&aa,&aa,epsilon);
+ num_add(a,a,&aa);
+ }
+ num_clear(&aa);
+ end:
+ OCT_EXIT("oct_add_epsilon",50);
+ return r;
+}
+
+/* return an octagon where each contraint coefficient is enlarged
+ by (epsilon * max { |m| | x_i-x_j <= m, m!=+oo })
+ (thus resulting in a slightly bigger octagon)
+ normal form is lost
+ O(n^2) time cost
+*/
+oct_t*
+OCT_PROTO(add_epsilon_max) (oct_t* m,
+ const num_t* epsilon,
+ bool destructive)
+{
+ oct_t* r;
+ size_t i;
+ num_t* a;
+ num_t abs,max;
+ const size_t n = matsize(m->n);
+ OCT_ENTER("oct_add_epsilon_max",51);
+ /* m empty => return m */
+ if (oct_is_empty_lazy(m)==tbool_true)
+ if (destructive) { r = m; goto end; }
+ else { r = oct_copy(m); goto end; }
+ /* result is computed in m, or in a new octagon */
+ if (destructive) {
+ if (m->ref==1) r = m;
+ else { r = oct_full_copy(m); m->ref--; }
+ }
+ else r = oct_full_copy(m);
+ r->state = OCT_NORMAL;
+ if (r->closed) { oct_free(r->closed); r->closed = (oct_t*)NULL; }
+ num_init_set_infty(&max); num_init(&abs);
+ /* get abs of first non +oo coef */
+ for (i=0,a=r->c;i<n;i++,a++)
+ if (!num_infty(a)) {
+ if (num_cmp_zero(a)<0) num_neg(&max,a); else num_set(&max,a);
+ i++; a++;
+ break;
+ }
+ /* get max abs of non +oo coefs */
+ for (;i<n;i++,a++)
+ if (!num_infty(a))
+ if (num_cmp_zero(a)<0) {
+ num_neg(&abs,a);
+ num_max(&max,&max,&abs);
+ }
+ else num_max(&max,&max,a);
+ num_mul(&max,epsilon,&max);
+ /* change result matrix */
+ for (i=0,a=r->c;i<n;i++,a++) num_add(a,a,&max);
+ num_clear(&abs); num_clear(&max);
+ end:
+ OCT_EXIT("oct_add_epsilon_max",51);
+ return r;
+}
+
+/* convergence acceleration operator with perturbation
+ constraints in ma that are not stable in mb are replaced by
+ mb + (epsilon * max { |mb| | x_i-x_j<=m, m != +oo })
+ (thus resulting in an octagon that is slightly bigger than the union)
+ normal form is lost
+ O(n^2) time cost
+*/
+oct_t*
+OCT_PROTO(add_epsilon_bin) (oct_t* ma,
+ oct_t* mb,
+ const num_t* epsilon,
+ bool destructive)
+{
+ oct_t* r;
+ size_t i;
+ num_t *a, *b, *c;
+ num_t abs,max;
+ const size_t n = matsize(ma->n);
+ OCT_ASSERT(ma->n==mb->n,"oct_add_epsilon_bin must be called with two octagons of the same dimension.");
+ OCT_ENTER("oct_add_epsilon_bin",52);
+ /* ma empty => return mb */
+ if (oct_is_empty_lazy(ma)==tbool_true)
+ if (destructive) { r = mb; goto end; }
+ else { r = oct_copy(mb); goto end; }
+ /* mb empty => return ma */
+ if (oct_is_empty_lazy(mb)==tbool_true)
+ if (destructive) { r = ma; goto end; }
+ else { r = oct_copy(ma); goto end; }
+ /* result is computed in ma, mb, or in a new octagon */
+ if (destructive) {
+ if (ma->ref==1) r = ma;
+ else if (mb->ref==1) r = mb;
+ else r = oct_alloc(ma->n);
+ }
+ else r = oct_alloc(ma->n);
+ r->state = OCT_NORMAL;
+ if (r->closed) { oct_free(r->closed); r->closed = (oct_t*)NULL; }
+ num_init_set_infty(&max); num_init(&abs);
+ /* get abs of first non +oo coef */
+ for (i=0,b=mb->c;i<n;i++,b++)
+ if (!num_infty(b)) {
+ if (num_cmp_zero(b)<0) num_neg(&max,b); else num_set(&max,b);
+ i++; b++;
+ break;
+ }
+ /* get max abs of non +oo coefs */
+ for (;i<n;i++,b++)
+ if (!num_infty(b))
+ if (num_cmp_zero(b)<0) {
+ num_neg(&abs,b);
+ num_max(&max,&max,&abs);
+ }
+ else num_max(&max,&max,b);
+ num_mul(&max,epsilon,&max);
+ /* change result matrix */
+ for (i=0,a=ma->c,b=mb->c,c=r->c;i<n;i++,a++,b++,c++)
+ if (num_cmp(a,b)<0) { num_set(c,b); num_add(c,c,&max); }
+ else num_set(c,a);
+ num_clear(&abs); num_clear(&max);
+ end:
+ OCT_EXIT("oct_add_epsilon_bin",52);
+ return r;
+}
+
+/*************/
+/* Utilities */
+/*************/
+
+/* print as a constraint list */
+void
+OCT_PROTO(print) (const oct_t* m)
+{
+ var_t i, j;
+ num_t w;
+ OCT_ENTER("oct_print",37);
+ num_init(&w);
+ if (m->state==OCT_EMPTY) { printf("[ empty ]\n"); OCT_EXIT("oct_print",37); return; }
+ printf("[");
+ if (m->state==OCT_CLOSED) printf(" (closed)");
+ for (i=0;i<m->n;i++) {
+ if (num_cmp_zero(m->c+matpos(2*i,2*i))) {
+ printf("\n v%02i-v%02i <= ",i,i);
+ num_print(m->c+matpos(2*i,2*i));
+ }
+ if (num_cmp_zero(m->c+matpos(2*i+1,2*i+1))) {
+ printf("\n -v%02i+v%02i <= ",i,i);
+ num_print(m->c+matpos(2*i+1,2*i+1));
+ }
+ if (!num_infty(m->c+matpos(2*i+1,2*i))) {
+ printf("\n v%02i <= ",i);
+ num_div_by_2(&w,m->c+matpos(2*i+1,2*i));
+ num_print(&w);
+ }
+ if (!num_infty(m->c+matpos(2*i,2*i+1))) {
+ printf("\n -v%02i <= ",i);
+ num_div_by_2(&w,m->c+matpos(2*i,2*i+1));
+ num_print(&w);
+ }
+ }
+
+ for (i=0;i<m->n;i++)
+ for (j=i+1;j<m->n;j++) {
+ if (!num_infty(m->c+matpos(2*j,2*i))) {
+ printf("\n v%02i-v%02i <= ",i,j);
+ num_print(m->c+matpos(2*j,2*i));
+ }
+ if (!num_infty(m->c+matpos(2*j,2*i+1))) {
+ printf("\n -v%02i-v%02i <= ",i,j);
+ num_print(m->c+matpos(2*j,2*i+1));
+ }
+ if (!num_infty(m->c+matpos(2*j+1,2*i))) {
+ printf("\n v%02i+v%02i <= ",i,j);
+ num_print(m->c+matpos(2*j+1,2*i));
+ }
+ if (!num_infty(m->c+matpos(2*j+1,2*i+1))) {
+ printf("\n v%02i-v%02i <= ",j,i);
+ num_print(m->c+matpos(2*j+1,2*i+1));
+ }
+
+ }
+ printf(" ]\n");
+ num_clear(&w);
+ OCT_EXIT("oct_print",37);
+}
+
+
+/* usefull to debug the strong closure algorithm
+ O(n^3) time cost, not optimized at all
+ */
+bool
+OCT_PROTO(check_closed) (const oct_t* m,
+ bool quiet)
+{
+ bool r = true;
+ var_t i,j,k;
+ const var_t n = m->n;
+ num_t w;
+ OCT_ENTER("oct_check_closed",38);
+ num_init(&w);
+ if (m->state==OCT_EMPTY) {
+ if (!quiet) printf("Empty\n");
+ }
+ else {
+ for (i=0;i<2*n;i++)
+ for (j=0;j<2*n;j++)
+ for (k=0;k<2*n;k++) {
+ num_add(&w,m->c+matpos2(i,k),m->c+matpos2(k,j));
+ if (num_cmp(m->c+matpos2(i,j),&w)>0) {
+ if (!quiet) {
+ printf("Bueargh #1 %i-%i-%i ",i,j,k);
+ num_print(m->c+matpos2(i,j));
+ printf(" > ");
+ num_print(m->c+matpos2(i,k));
+ printf("+");
+ num_print(m->c+matpos2(k,j));
+ printf("\n");
+ }
+ r = false; goto end;
+ }
+ }
+
+ for (i=0;i<2*n;i++)
+ for (j=0;j<2*n;j++)
+ if (num_cmp(m->c+matpos2(i,j), m->c+matpos2(j^1,i^1))>0) {
+ if (!quiet) {
+ printf("Bueargh #2 %i-%i ",i,j);
+ num_print(m->c+matpos2(i,j));
+ printf(" != ");
+ num_print(m->c+matpos2(j^1,i^1));
+ printf("\n");
+ }
+ r = false; goto end;
+ }
+
+ for (i=0;i<2*n;i++)
+ for (j=0;j<2*n;j++) {
+ num_add(&w,m->c+matpos2(i,i^1),m->c+matpos2(j^1,j));
+ num_div_by_2(&w,&w);
+ if (num_cmp(m->c+matpos2(i,j),&w)>0) {
+ if (!quiet) {
+ printf("Bueargh #3 %i-%i ",i,j);
+ num_print(m->c+matpos2(i,j));
+ printf(" > (");
+ num_print(m->c+matpos2(i,i^1));
+ printf("+");
+ num_print(m->c+matpos2(j^1,j));
+ printf(")/2\n");
+ }
+ r = false; goto end;
+ }
+ }
+ }
+ if (!quiet) printf("OK\n");
+ end:
+ num_clear(&w);
+ OCT_EXIT("oct_check_closed",38);
+ return r;
+}
+
+
+/****************/
+/* Minimal form */
+/****************/
+
+moct_t*
+OCT_PROTO(m_empty) (var_t n)
+{
+ moct_t* a;
+ OCT_ENTER("oct_m_empty",39);
+ a = new_t(moct_t);
+ a->n = n;
+ a->bol = (size_t*)NULL;
+ a->col = (var_t*)NULL;
+ a->data = (num_t*)NULL;
+ OCT_EXIT("oct_m_empty",39);
+ return a;
+}
+
+moct_t*
+OCT_PROTO(m_from_oct) (oct_t* m)
+{
+ moct_t* a;
+ oct_t* cm;
+ OCT_ENTER("oct_m_from_oct",40);
+ a = oct_m_empty (m->n);
+ cm = oct_close (m,false,false);
+ if (cm->state!=OCT_EMPTY) {
+ const var_t n2 = m->n*2;
+ var_t* rep = new_n(var_t,n2);
+ var_t* next = new_n(var_t,n2);
+ var_t* first = new_n(var_t,n2);
+ var_t i,j,k,nb;
+ size_t n;
+ num_t c1,c2;
+ /* compute equivalence classes xi<->xj iff m[i][j]+m[j][i]=0
+ next[i] is the smallest index j>i such that xi<->xj (or -1 at the end)
+ first[i] is the smallest index j such that xi<->xj
+ rep[i] is the last index in the ith equivalence class
+ */
+ /* maybee we could use union-find instead here ? */
+ num_init(&c1); num_init(&c2);
+ nb = 0;
+ for (i=0;i<n2;i++) {
+ for (j=0;j<nb;j++) {
+ num_add(&c1,cm->c+matpos(i,rep[j]),cm->c+matpos(i^1,rep[j]^1));
+ if (!num_cmp_zero(&c1)) {
+ first[i] = first[rep[j]];
+ next[rep[j]] = i;
+ rep[j] = i;
+ goto notnew;
+ }
+ }
+ rep[nb++] = i;
+ first[i] = i;
+ notnew:
+ next[i] = 0;
+ }
+ /* make rep monotonic: rep[i]<rep[j] if i<j */
+ for (j=0,i=0;i<n2;i++) if (!next[i]) rep[j++] = i;
+ /* alloc */
+ a->bol = new_n(size_t,n2+1);
+ a->col = new_n(var_t,matsize(cm->n));
+ a->data = new_n(num_t,matsize(cm->n));
+ n = 0;
+ for (i=0;i<n2;i++) {
+ a->bol[i] = n;
+ if (next[i]) {
+ a->col[n] = next[i];
+ num_init_set(a->data+n,cm->c+matpos(next[i]^1,i^1));
+ n++;
+ }
+ else {
+ const var_t ii = i|1;
+ num_div_by_2(&c1,cm->c+matpos(i,i^1));
+ for (j=0;j<=ii;j++) {
+ if (j!=i && (j==first[i] || !next[j])) {
+ const num_t* cij = cm->c+matpos(i,j);
+ if (num_infty(cij)) goto redund;
+ if (j==first[i]) goto noredund;
+ num_div_by_2(&c2,cm->c+matpos(j^1,j));
+ num_add(&c2,&c1,&c2);
+ if ((i^1)!=j && !num_cmp(cij,&c2) &&
+ first[i]!=first[i^1] && first[j]!=first[j^1]) goto redund;
+ for (k=0;k<nb;k++) {
+ const var_t kk = rep[k];
+ if (kk!=i && kk!=j) {
+ /* CAN THIS BE LINEARIZED ? (rep is monotonic) */
+ num_add(&c2,cm->c+matpos2(i,kk),cm->c+matpos2(kk,j));
+ if (!num_cmp(cij,&c2)) goto redund;
+ }
+ }
+ noredund:
+ a->col[n] = j;
+ num_init_set(a->data+n,cij);
+ n++;
+ redund:;
+ }
+ }
+ }
+ }
+ a->bol[i] = n;
+ oct_mm_free(rep); oct_mm_free(next); oct_mm_free(first);
+ num_clear(&c1); num_clear(&c2);
+ a->col = renew_n(a->col,var_t,n+1);
+ /* we alloc 1 to size to be sure that a->data is not NULL */
+ a->data = renew_n(a->data,num_t,n+1);
+ }
+ oct_free (cm);
+ OCT_EXIT("oct_m_from_oct",40);
+ return a;
+}
+
+
+oct_t*
+OCT_PROTO(m_to_oct) (moct_t* a)
+{
+ oct_t* r;
+ var_t i;
+ size_t n;
+ const var_t n2 = a->n*2;
+ OCT_ENTER("oct_m_to_oct",41);
+ if (!a->col) { r = oct_empty (a->n); goto end; }
+ r = oct_universe (a->n);
+ for (n=0,i=0;i<n2;i++)
+ for (;n<a->bol[i+1];n++)
+ if (!num_infty(a->data+n))
+ num_set(r->c+matpos2(i,a->col[n]),a->data+n);
+ r->state = OCT_NORMAL;
+ if (r->closed) { oct_free(r->closed); r->closed = (oct_t*)NULL; }
+ end:
+ OCT_EXIT("oct_m_to_oct",41);
+ return r;
+}
+
+void
+OCT_PROTO(m_free) (moct_t* a)
+{
+ OCT_ENTER("oct_m_free",42);
+ if (a->data) { num_clear_n(a->data,a->bol[a->n*2]); oct_mm_free (a->data); }
+ if (a->col) oct_mm_free (a->col);
+ if (a->bol) oct_mm_free (a->bol);
+ oct_mm_free (a);
+ OCT_EXIT("oct_m_free",42);
+}
+
+/* number of variables */
+inline
+var_t
+OCT_PROTO(m_dimension) (moct_t* m)
+{
+ return m->n;
+}
+
+bool
+OCT_PROTO(m_is_empty) (moct_t* m)
+{
+ if (m->data) return false;
+ return true;
+}
+
+
+/* print as a constraint list */
+void
+OCT_PROTO(m_print) (moct_t* a)
+{
+ var_t i;
+ size_t n;
+ const var_t n2 = a->n*2;
+ OCT_ENTER("oct_m_print",43);
+ if (!a->col) printf("[ empty ]\n");
+ else {
+ printf("[");
+ for (n=0,i=0;i<n2;i++)
+ for (;n<a->bol[i+1];n++)
+ if (!num_infty(a->data+n)) {
+ const var_t j = a->col[n];
+ if (i==(j^1))
+ if (i&1)
+ { printf("\n 2v%02i <= ",i/2); num_print(a->data+n); }
+ else
+ { printf("\n -2v%02i <= ",i/2); num_print(a->data+n); }
+ else
+ if (i&1)
+ if (j&1) {
+ printf("\n -v%02i+v%02i <= ",j/2,i/2);
+ num_print(a->data+n);
+ }
+ else {
+ printf("\n v%02i+v%02i <= ",j/2,i/2);
+ num_print(a->data+n);
+ }
+ else
+ if (j&1) {
+ printf("\n -v%02i-v%02i <= ",j/2,i/2);
+ num_print(a->data+n);
+ }
+ else {
+ printf("\n v%02i-v%02i <= ",j/2,i/2);
+ num_print(a->data+n);
+ }
+ }
+ printf(" ]\n");
+ }
+ OCT_EXIT("oct_m_print",43);
+}
+
+
+/* using binary search on a row: O(log n) time cost */
+num_t*
+OCT_PROTO(m_elem) (moct_t* a,
+ var_t i,
+ var_t j)
+{
+ num_t* r;
+ size_t lo,hi;
+ OCT_ENTER("oct_m_elem",44);
+ OCT_ASSERT(a->data,"empty hollow matrix in oct_m_elem");
+ OCT_ASSERT(i<a->n*2 && j<a->n*2,"invalid index in oct_m_elem");
+ if (j>i) { var_t t = i; i = j^1; j = t^1; }
+ lo = a->bol[i];
+ hi = a->bol[i+1];
+ while (lo<hi) { /* col[lo] <= j < col[hi] */
+ size_t mid = (lo+hi)/2;
+ if (j==a->col[mid]) { r = a->data+mid; goto end; }
+ else if (j<a->col[mid]) hi = mid; else lo = mid+1;
+ }
+ r = (num_t*) NULL;
+ end:
+ OCT_EXIT("oct_m_elem",44);
+ return r;
+}
+
+
+/* O(n^2) time cost as minimized octagons are also a normal form */
+bool
+OCT_PROTO(m_is_equal) (moct_t* ma,
+ moct_t* mb)
+{
+ bool r = true;
+ OCT_ENTER("oct_m_is_equal",45);
+ OCT_ASSERT(ma->n==mb->n,"oct_m_is_equal must be called with two octagons of the same dimension.");
+ if (!ma->data && !mb->data) r = true;
+ else if (!ma->data || !mb->data) r = false;
+ else {
+ const var_t n2 = ma->n*2;
+ const size_t nn = ma->bol[n2];
+ size_t i;
+ for (i=1;i<=n2;i++)
+ if (ma->bol[i]!=mb->bol[i]) { r = false; goto end; }
+ for (i=0;i<nn;i++)
+ if (ma->col[i]!=mb->col[i]) { r = false; goto end; }
+ for (i=0;i<nn;i++)
+ if (num_cmp(ma->data+i,mb->data+i)) { r = false; goto end; }
+ r = true;
+ }
+ end:
+ OCT_EXIT("oct_m_is_equal",45);
+ return r;
+}
+
+
+/*****************/
+/* Serialization */
+/*****************/
+
+/* this only works for a few underlying numerical domains! */
+/* octagon serialized on an architecture with a numerical type may not be
+ deserialized on another architecture, or with a different numerical type */
+
+#ifdef OCT_NUM_SERIALIZE
+
+void*
+OCT_PROTO(serialize) (oct_t* m, size_t* size)
+{
+ size_t sz = 16, max = 100;
+ unsigned char* data;
+ if (m->closed) m=m->closed;
+ data = new_n(unsigned char,max);
+ dump32(data,num_serialize_id);
+ dump32(data+4,m->n);
+ dump32(data+8,m->state);
+ if (m->state!=OCT_EMPTY) {
+ const size_t nn = matsize(m->n);
+ size_t i;
+ for (i=0;i<nn;i++) {
+ int s = num_serialize_size(m->c+i);
+ while (s+sz>=max) { max*=2; data = renew_n(data,unsigned char,max); }
+ sz += num_serialize(m->c+i,data+sz);
+ }
+ }
+ *size = sz;
+ return data;
+}
+
+oct_t*
+OCT_PROTO(deserialize) (void* d)
+{
+ unsigned char* data = (unsigned char*)d;
+ int id;
+ var_t n;
+ int state;
+ size_t pos = 16;
+ id = undump32(data);
+ OCT_ASSERT(id==num_serialize_id,"oct_deserialize: incompatible serialized octagon");
+ n = undump32(data+4);
+ state = undump32(data+8);
+ if (state==OCT_EMPTY) return(oct_empty(n));
+ else {
+ const size_t nn = matsize(n);
+ size_t i;
+ oct_t* m = oct_alloc(n);
+ m->state = state;
+ for (i=0;i<nn;i++)
+ pos += num_deserialize(m->c+i,data+pos);
+ return(m);
+ }
+}
+
+void*
+OCT_PROTO(m_serialize) (moct_t* m, size_t* size)
+{
+ size_t sz = 16, max = 100;
+ unsigned char* data;
+ data = new_n(unsigned char,max);
+ dump32(data,num_serialize_id);
+ dump32(data+4,m->n);
+ if (!m->bol) {
+ /* empty */
+ dump32(data+8,0);
+ }
+ else {
+ /* non-empty */
+ const var_t n2 = m->n*2;
+ const size_t nn = m->bol[n2];
+ size_t i;
+ dump32(data+8,1);
+ dump32(data+12,nn);
+ max += 2*(nn+n2);
+ data = renew_n(data,unsigned char,max);
+ for (i=1;i<=n2;i++,sz+=2) dump16(data+sz,m->bol[i]-m->bol[i-1]);
+ for (i=0;i<nn;i++,sz+=2) dump16(data+sz,m->col[i]);
+ for (i=0;i<nn;i++) {
+ int s = num_serialize_size(m->data+i);
+ while (s+sz>=max) { max*=2; data = renew_n(data,unsigned char,max); }
+ sz += num_serialize(m->data+i,data+sz);
+ }
+ }
+ *size = sz;
+ return data;
+}
+
+moct_t*
+OCT_PROTO(m_deserialize) (void* d)
+{
+ unsigned char* data = (unsigned char*)d;
+ int id;
+ var_t n;
+ int state;
+ size_t pos = 16;
+ id = undump32(data);
+ OCT_ASSERT(id==num_serialize_id,"oct_m_deserialize: incompatible serialized octagon");
+ n = undump32(data+4);
+ state = undump32(data+8);
+ if (state) {
+ const var_t n2 = n*2;
+ const size_t nn = undump32(data+12);
+ size_t i;
+ moct_t* m;
+ m = new_t(moct_t);
+ m->n = n;
+ m->bol = new_n(size_t,n2+1);
+ m->col = new_n(var_t,nn);
+ m->data = new_n(num_t,nn);
+ m->bol[0] = 0;
+ num_init_n(m->data,nn);
+ for (i=1;i<=n2;i++,pos+=2) m->bol[i] = m->bol[i-1] + undump16(data+pos);
+ for (i=0;i<nn;i++,pos+=2) m->col[i] = undump16(data+pos);
+ for (i=0;i<nn;i++)
+ pos += num_deserialize(m->data+i,data+pos);
+ return m;
+ }
+ else return(oct_m_empty(n));
+}
+
+#else
+
+void*
+OCT_PROTO(serialize) (oct_t* m, size_t* size)
+{
+ OCT_ASSERT(0,"oct_serialize: serialization not supported for this underlying numerical domain.");
+}
+
+oct_t*
+OCT_PROTO(deserialize) (void* data)
+{
+ OCT_ASSERT(0,"oct_deserialize: serialization not supported for this underlying numerical domain.");
+}
+
+void*
+OCT_PROTO(m_serialize) (moct_t* m, size_t* size)
+{
+ OCT_ASSERT(0,"oct_m_serialize: serialization not supported for this underlying numerical domain.");
+}
+
+moct_t*
+OCT_PROTO(m_deserialize) (void* data)
+{
+ OCT_ASSERT(0,"oct_m_deserialize: serialization not supported for this underlying numerical domain.");
+}
+
+
+#endif
--- /dev/null
+/* oct_util.c
+ Utilities functions not directly related to the abstract domain.
+
+ This file is part of the Octagon Abstract Domain Library.
+ Please read the COPYING file packaged in the distribution.
+ Main web page is: http://www.di.ens.fr/~mine/oct/
+
+ Copyright (C) Antoine Mine' 2000-2002
+ */
+
+#include <oct.h>
+#include <oct_private.h>
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <sys/types.h>
+#include <sys/time.h>
+#include <unistd.h>
+
+/**********/
+/* Memory */
+/**********/
+
+
+/* this header is added before each block malloc'ed */
+typedef struct
+{
+ size_t size; /* size of the block */
+
+ mmalloc_t* mm; /* who monitor the block */
+ int id; /* if id!=mm->id, monitor was reseted */
+
+ double dummy; /* alignement stuff */
+
+} mmheader_t;
+
+
+/* global (default one at the begining */
+static mmalloc_t m_global = { 0,0,0,0,0,0,0 };
+static mmalloc_t* mm_current = &m_global;
+static mmalloc_t* mmalloc_global = &m_global;
+
+#ifdef OCT_ENABLE_MALLOC_MONITORING
+void*
+OCT_PROTO(mm_malloc) (size_t t)
+{
+ char* m = (char*)malloc(t+sizeof(mmheader_t));
+ mmheader_t* h = (mmheader_t*) m;
+ if (!m) { fprintf(stderr, "Insufficent memory while attempting to allocate %i bytes in mm_malloc.",t); exit(1); }
+ mm_current->nb_alloc++;
+ mm_current->rem += t;
+ mm_current->tot += t;
+ if (mm_current->max < mm_current->rem) mm_current->max = mm_current->rem;
+ h->mm = mm_current;
+ h->size = t;
+ h->id = mm_current->id;
+ return m+sizeof(mmheader_t);
+}
+
+void*
+OCT_PROTO(mm_realloc) (void* p, size_t t)
+{
+ char* m = ((char*)p)-sizeof(mmheader_t);
+ mmheader_t* h = (mmheader_t*) m;
+ size_t old_size = h->size;
+ m = (char*)realloc(m,t+sizeof(mmheader_t));
+ h = (mmheader_t*) m;
+ if (!m) { fprintf(stderr, "Insufficent memory while attempting to reallocate %i bytes in mm_realloc.",t); exit(1); }
+ if (h->id == h->mm->id) {
+ h->mm->nb_realloc++;
+ h->mm->tot += t-old_size;
+ h->mm->rem += t-old_size;
+ if (h->mm->max < h->mm->rem) h->mm->max = h->mm->rem;
+ }
+ h->size = t;
+ return m+sizeof(mmheader_t);
+}
+
+void
+OCT_PROTO(mm_free) (void* p)
+{
+ char* m = ((char*)p)-sizeof(mmheader_t);
+ mmheader_t* h = (mmheader_t*) m;
+ if (h->id == h->mm->id) {
+ h->mm->nb_free++;
+ h->mm->rem -= h->size;
+ }
+ free(m);
+}
+#endif
+
+mmalloc_t*
+OCT_PROTO(mmalloc_new) ()
+{
+ mmalloc_t* mm = new_t(mmalloc_t);
+ mm->nb_alloc = mm->nb_realloc = mm->nb_free = 0;
+ mm->rem = mm->max = mm->tot = 0;
+ mm->id = 0;
+ return mm;
+}
+
+void
+OCT_PROTO(mmalloc_print) (mmalloc_t* mm)
+{
+#ifdef OCT_ENABLE_MALLOC_MONITORING
+ printf("%i allocs, %i frees, %i reallocs\n%lu total memory used\n%lu memory peak\n%lu still allocated\n",
+ mm->nb_alloc,
+ mm->nb_free,
+ mm->nb_realloc,
+ (unsigned long)mm->tot,
+ (unsigned long)mm->max,
+ (unsigned long)mm->rem);
+#else
+ printf("No memory information available; compile with the ENABLE_MALLOC_MONITORING symbol.\n");
+#endif
+ fflush(stdout);
+}
+
+void
+OCT_PROTO(mmalloc_use) (mmalloc_t* mm)
+{
+ mm_current = mm;
+}
+
+mmalloc_t*
+OCT_PROTO(mmalloc_get_current) ()
+{
+ return mm_current;
+}
+
+void
+OCT_PROTO(mmalloc_reset) (mmalloc_t* mm)
+{
+ mm->nb_alloc = mm->nb_realloc = mm->nb_free = 0;
+ mm->rem = mm->max = mm->tot = 0;
+ mm->id++;
+}
+
+
+
+/**********/
+/* Chrono */
+/**********/
+
+void
+inline
+OCT_PROTO(chrono_reset) (chrono_t* c)
+{
+ c->usec = 0;
+ c->sec = 0;
+ c->start = 0;
+}
+
+void
+inline
+OCT_PROTO(chrono_start) (chrono_t* c)
+{
+ OCT_ASSERT(!c->start,"oct_chrono_start: chrono already started");
+ gettimeofday(&c->begin, NULL);
+ c->start = 1;
+}
+
+void
+inline
+OCT_PROTO(chrono_stop) (chrono_t* c)
+{
+ struct timeval end;
+ OCT_ASSERT(c->start,"oct_chrono_stop: chrono already stoped");
+ c->start = 0;
+ gettimeofday(&end, NULL);
+ c->usec += (end.tv_usec - c->begin.tv_usec + 1000000L) % (1000000L);
+ c->sec += (end.tv_sec - c->begin.tv_sec);
+ c->sec += (c->usec / 1000000L);
+ c->usec %= 1000000L;
+ if (end.tv_usec < c->begin.tv_usec) c->sec--;
+}
+
+void
+inline
+OCT_PROTO(chrono_get) (chrono_t* c, long* hour, long* min, long* sec, long *usec)
+{
+ int start;
+ start = c->start;
+ if (start) oct_chrono_stop (c);
+ *usec = c->usec;
+ *sec = c->sec;
+ *min = *sec/60; *sec %= 60;
+ *hour = *min/60; *min %= 60;
+ if (start) oct_chrono_start (c);
+}
+
+
+void
+OCT_PROTO(chrono_print) (chrono_t* c)
+{
+ long hour, min, sec, usec;
+ oct_chrono_get (c, &hour, &min, &sec, &usec);
+ if (hour) printf("%lih %02li'", hour, min);
+ else if (min) printf("%02li' %02li''", min, sec);
+ else printf("%02li.%03li''", sec, usec/1000);
+ fflush(stdout);
+}
+
+
+/*************/
+/* Profiling */
+/*************/
+
+struct timing_tt
+{
+ char* name;
+
+ int count; /* count number */
+
+ int rec; /* recursive call checking */
+
+ chrono_t tcum; /* time elapsed in context and called context */
+ chrono_t tself; /* time elapsed in this context, not in called context */
+
+ struct timing_tt* stack; /* link to calling context */
+};
+
+typedef struct timing_tt timing_t;
+
+static
+timing_t* timing_data[128] = {
+ NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,
+ NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,
+ NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,
+ NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,
+ NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,
+ NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,
+ NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,
+ NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,
+ NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,
+ NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,
+ NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,
+ NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,
+ NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,
+ NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,
+ NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,
+ NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL };
+
+/* current context */
+static
+timing_t* timing_stack = NULL;
+
+/* keys are supposed to be < 64 and unique given a name */
+void
+OCT_PROTO(timing_enter) (const char* name, unsigned key)
+{
+ timing_t* t;
+ OCT_ASSERT(key<sizeof(timing_data)/sizeof(timing_data[0]),
+ "oct_timing_enter: invalid key");
+ t = timing_data[key];
+ if (!t) {
+ t = new_t(timing_t);
+ t->name = strdup(name);
+ t->count = 0;
+ t->rec = 0;
+ oct_chrono_reset(&(t->tcum));
+ oct_chrono_reset(&(t->tself));
+ timing_data[key] = t;
+ }
+ OCT_ASSERT(!t->rec,"oct_timing_enter: recursive call detected");
+ t->count++;
+ t->rec = 1;
+ oct_chrono_start(&(t->tcum));
+ oct_chrono_start(&(t->tself));
+ if (timing_stack) oct_chrono_stop(&(timing_stack->tself));
+ t->stack = timing_stack;
+ timing_stack = t;
+}
+
+void
+OCT_PROTO(timing_exit) (const char* name, unsigned key)
+{
+ timing_t* t;
+ OCT_ASSERT(key<sizeof(timing_data)/sizeof(timing_data[0]),
+ "oct_timing_exit: invalid key");
+ t = timing_data[key];
+ OCT_ASSERT(t,"oct_timing_exit: invalid key");
+ OCT_ASSERT(t->rec || timing_stack!=t,"oct_timing_exit: exiting an invalid context");
+ timing_stack = t->stack;
+ t->rec = 0;
+ if (timing_stack) oct_chrono_start(&(timing_stack->tself));
+ oct_chrono_stop(&(t->tself));
+ oct_chrono_stop(&(t->tcum));
+}
+
+void
+OCT_PROTO(timing_print) (const char* name)
+{
+#ifdef OCT_ENABLE_TIMING
+ int i;
+ timing_t* t = NULL;
+ for (i=0;i<sizeof(timing_data)/sizeof(timing_data[0]);i++)
+ if (timing_data[i] && !strcmp(timing_data[i]->name,name)) t=timing_data[i];
+ if (!t) printf("No timing information for function %s.\n",name);
+ else {
+ printf("%-30s called=%9i time=",t->name,t->count);
+ oct_chrono_print(&(t->tself));
+ printf(" (cum=");
+ oct_chrono_print(&(t->tcum));
+ printf(")\n");
+ }
+#else
+ printf("No timing information available; compile with the ENABLE_TIMING symbol.\n");
+#endif
+ fflush(stdout);
+}
+
+void
+OCT_PROTO(timing_print_all) ()
+{
+#ifdef OCT_ENABLE_TIMING
+ int i;
+ for (i=0;i<sizeof(timing_data)/sizeof(timing_data[0]);i++) {
+ timing_t* t = timing_data[i];
+ if (t) {
+ printf("%-30s called=%9i time=",t->name,t->count);
+ oct_chrono_print(&(t->tself));
+ printf(" (cum=");
+ oct_chrono_print(&(t->tcum));
+ printf(")\n");
+ }
+ }
+#else
+ printf("No timing information available; compile with the ENABLE_TIMING symbol.\n");
+#endif
+ fflush(stdout);
+}
+
+void
+OCT_PROTO(timing_reset) (const char* name)
+{
+ int i;
+ timing_t* t = NULL;
+ for (i=0;i<sizeof(timing_data)/sizeof(timing_data[0]);i++)
+ if (timing_data[i] && !strcmp(timing_data[i]->name,name)) t=timing_data[i];
+ if (t) {
+ t->count = 0;
+ oct_chrono_reset(&(t->tcum));
+ oct_chrono_reset(&(t->tself));
+ if (t->rec) {
+ oct_chrono_start (&(t->tcum));
+ if (timing_stack==t) oct_chrono_start (&(t->tself));
+ }
+ }
+}
+
+void
+OCT_PROTO(timing_reset_all) ()
+{
+ int i;
+ for (i=0;i<sizeof(timing_data)/sizeof(timing_data[0]);i++) {
+ timing_t* t = timing_data[i];
+ if (t) {
+ t->count = 0;
+ oct_chrono_reset(&(t->tcum));
+ oct_chrono_reset(&(t->tself));
+ if (t->rec) {
+ oct_chrono_start (&(t->tcum));
+ if (timing_stack==t) oct_chrono_start (&(t->tself));
+ }
+ }
+ }
+}
+
+void
+OCT_PROTO(timing_clear) ()
+{
+ int i;
+ for (i=0;i<sizeof(timing_data)/sizeof(timing_data[0]);i++) {
+ timing_t* t = timing_data[i];
+ if (t) {
+ OCT_ASSERT(!t->rec,"oct_timing_clear: not all contextes where closed");
+ free (t->name);
+ oct_mm_free (t);
+ }
+ }
+}
--- /dev/null
+
+open Cil
+
+
+(*
+ * When ignore_inst returns true, then
+ * the instruction in question has no
+ * effects on the abstract state.
+ * When ignore_call returns true, then
+ * the instruction only has side-effects
+ * from the assignment if there is one.
+ *)
+let ignore_inst = ref (fun i -> false)
+let ignore_call = ref (fun i -> false)
+
+let registerIgnoreInst (f : instr -> bool) : unit =
+ let f' = !ignore_inst in
+ ignore_inst := (fun i -> (f i) || (f' i))
+
+let registerIgnoreCall (f : instr -> bool) : unit =
+ let f' = !ignore_call in
+ ignore_call := (fun i -> (f i) || (f' i))
+
+let init () = true
+
+let doOctAnalysis ?(tryReverse:bool=false)
+ (fd:fundec)
+ (fdat : Dprecfinder.functionData) : unit = ()
+
+let real = false
+
+let reportStats() = ()
--- /dev/null
+(*
+ * dptranal.ml
+ *
+ * This file contains functions that Deputy can use to
+ * make queries about aliasing relationships, and some utility
+ * functions for using aliasing/mod-ref analysis results in
+ * dataflow analysis.
+ *
+ *)
+
+
+open Cil
+open Pretty
+open Doptions
+
+module E = Errormsg
+module IH = Inthash
+module S = Stats
+
+module P = Ptranal
+module DPF = Dprecfinder
+
+(* Basic functions for making queries about aliasing *)
+
+let debug = ref false
+
+let may_alias (e1 : exp) (e2 : exp) : bool =
+ if !doPtrAnalysis then
+ try P.may_alias e1 e2
+ (* If the pointer analysis doesn't know anything about one of the
+ * expressions, then return true for soundess *)
+ with
+ | P.UnknownLocation
+ | Not_found -> true
+ else true
+
+let try_resolve_lval (lv : lval) : varinfo list option =
+ if !doPtrAnalysis then
+ try Some(P.resolve_lval lv)
+ with Not_found -> begin
+ ignore(E.log "DPtrAnal: Couldn't resolve lval: %a.\n" d_lval lv);
+ None
+ end
+ else None
+
+let try_resolve_exp (e : exp) : varinfo list option =
+ if !doPtrAnalysis then
+ try Some(P.resolve_exp e)
+ with Not_found -> begin
+ ignore(E.log "DPtrAnal: Couldn't resolve exp: %a\n" d_exp e);
+ None
+ end
+ else None
+
+let try_resolve_funptr (e : exp) : fundec list option =
+ if !doPtrAnalysis then
+ try Some(P.resolve_funptr e)
+ with Not_found -> begin
+ ignore(E.log "DPtrAnal: Couldn't resolve funptr %a\n" d_exp e);
+ None
+ end
+ else None
+
+(* Visitor that finds reads from things that alias the pointer ee *)
+class aliasReadFinderClass (br : bool ref) (ee : exp) = object(self)
+ inherit nopCilVisitor
+
+ method vexpr e = match e with
+ | AddrOf(Mem e, _)
+ | StartOf(Mem e, _)
+ | Lval(Mem e, _) -> begin
+ if may_alias ee e then begin
+ br := true;
+ SkipChildren
+ end else DoChildren
+ end
+ | AddrOf(Var vi, NoOffset) ->
+ SkipChildren
+ | Lval(Var vi, _ )
+ | StartOf(Var vi, _) -> begin
+ if vi.vaddrof || vi.vglob then begin
+ if may_alias ee e then begin
+ br := true;
+ SkipChildren
+ end else match ee with
+ | AddrOf(Var gvi, NoOffset) -> begin
+ if gvi.vid = vi.vid then begin
+ br := true;
+ SkipChildren
+ end else DoChildren
+ end
+ | _ -> DoChildren
+ end else DoChildren
+ end
+ | _ -> DoChildren
+
+end
+
+let exp_has_alias_read ee e =
+ let br = ref false in
+ let vis = new aliasReadFinderClass br ee in
+ ignore(visitCilExpr vis e);
+ !br
+
+let lval_has_alias_read ee lv =
+ let br = ref false in
+ let vis = new aliasReadFinderClass br ee in
+ ignore(visitCilExpr vis (Lval lv));
+ !br
+
+(* Utilities for Dataflow analysis *)
+
+let int_list_union l1 l2 =
+ List.fold_left (fun l x ->
+ if List.mem x l then l else x :: l) l1 l2
+
+let vi_list_union l1 l2 =
+ List.fold_left (fun l x ->
+ if List.exists (fun vi -> vi.vid = x.vid) l then l else x :: l)
+ l1 l2
+
+let handleCall (memKiller : 'a -> exp option -> 'a)
+ (fdato : DPF.functionData option)
+ (fe : exp)
+ (args : exp list)
+ (absState : 'a) :
+ 'a
+ =
+ match fdato with
+ | None -> memKiller absState None
+ | Some fdat -> begin
+ (* find what fe can point to *)
+ let fns : varinfo list =
+ match fe with
+ | Lval(Var vf, NoOffset) -> [vf]
+ | Lval(Mem ee, NoOffset) -> begin
+ if !doPtrAnalysis then
+ match try_resolve_funptr ee with
+ | None -> begin
+ if !debug then
+ ignore(E.log "Dptranal: try_resolve failed: %a\n"
+ d_exp ee);
+ []
+ end
+ | Some [] -> begin
+ if !debug then
+ ignore(E.log "Dptranal: try_resolve returned empty: %a\n"
+ d_exp ee);
+ []
+ end
+ | Some fds -> List.map (fun fd -> fd.svar) fds
+ else []
+ end
+ | _ -> []
+ in
+ (* if the function couldn't be identified then kill everything *)
+ if fns = [] then begin
+ if !debug then
+ ignore(E.log "Dptranal: Couldn't resolve call of %a\n"
+ d_exp fe);
+ memKiller absState None
+ end else
+ (* glob vis and arg nums that fns might modify, an option in case
+ nothing is known *)
+ let modsopt : (varinfo list * int list) option =
+ List.fold_left
+ (fun modsopt fvi ->
+ match modsopt with None -> None
+ | Some(gmds, amds) -> begin
+ match IH.tryfind fdat.DPF.fdModHash fvi.vid with
+ | None -> None
+ | Some(ngmds, namds) ->
+ Some(vi_list_union ngmds gmds,
+ int_list_union namds amds)
+ end)
+ (Some([],[]))
+ fns
+ in
+ match modsopt with
+ | None -> begin
+ if !debug then
+ ignore(E.log "Dptranal: No mod/ref data for %a\n" d_exp fe);
+ memKiller absState None
+ end
+ | Some(gmds, amds) -> begin
+ if !debug then
+ ignore(E.log "Dptranal: killing things for %a\n" d_exp fe);
+ (* kill lvals refering to globals in gmds *)
+ let absState = List.fold_left (fun a gvi ->
+ memKiller absState (Some(AddrOf(Var gvi, NoOffset))))
+ absState gmds
+ in
+ (* kill lvals that have reads of things aliasing things in amds *)
+ List.fold_left (fun a anum ->
+ memKiller absState (Some(List.nth args anum)))
+ absState amds
+ end
+ end
--- /dev/null
+# Makefile for cvcl_sover_test.ml
+#
+
+
+ifndef ARCHOS
+ ARCHOS = x86_LINUX
+endif
+
+all:
+ $(MAKE) cvcl_solver_test
+ $(MAKE) cvcl_solver_test NATIVECAML=1
+
+#
+# If you've done a 'make install' with cvc lite, then
+# the defaults below should work. Otherwise setting the
+# environment variables as below should work.
+#
+# for example on a x86 linux machine
+# CVCLLIB = /path/to/cvcl/lib/linux-i686
+# CVCLINC = /path/to/cvcl/src/include
+#
+ifndef CVCLLIB
+ CVCLLIB = /usr/local/lib
+endif
+ifndef CVCLINC
+ CVCLINC = /usr/local/include
+endif
+ifndef OCAMLINC
+ OCAMLINC = /usr/lib/ocaml
+endif
+
+OBJDIR = obj/$(ARCHOS)
+DEPENDDIR = obj/.depend
+
+
+SOURCEDIRS = .
+
+MODULES = cvcl cvcl_solver_test
+
+COMPILEFLAGS =
+LINKFLAGS =
+
+
+ENDLINKFLAGS = -cclib -L$(CVCLLIB) -cclib -lcvclite -cclib -lstdc++ -cclib -lgmp
+
+CAML_CFLAGS += -ccopt -I$(OCAMLINC) -ccopt -I$(CVCLINC)
+
+include ../../../../cil/ocamlutil/Makefile.ocaml
+
+PROJECT_EXECUTABLE = $(OBJDIR)/cvcl_test$(EXE)
+PROJECT_MODULES = $(MODULES)
+
+PROJECT_CMODULES = cvcl_ocaml_wrappers
+
+PROJECT_LIBS = unix str
+
+$(PROJECT_EXECUTABLE) : $(PROJECT_MODULES:%=$(OBJDIR)/%.$(CMO)) \
+ $(PROJECT_CMODULES:%=$(OBJDIR)/%.$(CMC))
+ @$(NARRATIVE) "Linking $(COMPILETOWHAT) $@ $(LINKMSG)"
+ $(AT)$(CAMLLINK) -verbose -o $@ \
+ $(PROJECT_LIBS:%=%.$(CMXA)) \
+ $(PROJECT_MODULES:%=$(OBJDIR)/%.$(CMO)) \
+ $(PROJECT_CMODULES:%=$(OBJDIR)/%.$(CMC)) \
+ $(ENDLINKFLAGS)
+
+cvcl_solver_test: $(PROJECT_EXECUTABLE)
+
+clean:
+ rm -f $(OBJDIR)/*.* $(DEPENDDIR)/*.*
--- /dev/null
+(*
+ * cvcl.ml
+ *
+ * This file contains external declarations for
+ * calls into cvc lite
+ *)
+
+type vc
+type context
+type em
+type flags
+type expr
+type op
+type typ
+
+(* create validity checker *)
+external createVC : flags -> vc = "caml_vc_createValidityChecker"
+
+(* create flags *)
+external createFlags : unit -> flags = "caml_vc_createFlags"
+
+(* destroy validity checker *)
+external destroyVC : vc -> unit = "caml_vc_destroyValidityChecker"
+
+(* delete flags *)
+external deleteFlags : flags -> unit = "caml_vc_deleteFlags"
+
+(* delete type *)
+external deleteType : typ -> unit = "caml_vc_deleteType"
+
+(* delete expr *)
+external deleteExpr : expr -> unit = "caml_vc_deleteExpr"
+
+(* delete op *)
+external deleteOp : op -> unit = "caml_vc_deleteOp"
+
+(* flag setting *)
+external setBoolFlag : flags -> string -> int -> unit =
+ "caml_vc_setBoolFlag"
+external setIntFlag : flags -> string -> int -> unit =
+ "caml_vc_setIntFlag"
+external setStringFlag : flags -> string -> string -> unit =
+ "caml_vc_setStringFlag"
+external setStrSeqFlag : flags -> string -> string -> int -> unit =
+ "caml_vc_setStrSeqFlag"
+
+(* Basic Types *)
+external boolType : vc -> typ = "caml_vc_boolType"
+external realType : vc -> typ = "caml_vc_realType"
+external intType : vc -> typ = "caml_vc_intType"
+
+(* Tuple Types *)
+external tupleType2 : vc -> typ -> typ -> typ = "caml_vc_tupleType2"
+external tupleType3 : vc -> typ -> typ -> typ -> typ = "caml_vc_tupleType3"
+external tupleTypeN : vc -> typ array -> int -> typ = "caml_vc_tupleTypeN"
+
+(* Record Types *)
+external recordType1 : vc -> string -> typ -> typ =
+ "caml_vc_recordType1"
+external recordType2 : vc -> string -> typ -> string -> typ -> typ =
+ "caml_vc_recordType2"
+(*external recordType3 : vc -> string -> typ -> string -> typ -> string -> typ -> typ =
+ "caml_vc_recordType3"*)
+external recordTypeN : vc -> string array -> typ array -> int -> typ =
+ "caml_vc_recordTypeN"
+
+(* Array Type *)
+external arrayType : vc -> typ -> typ -> typ = "caml_vc_arrayType"
+
+(* SubRange Type *)
+external subRangeType : vc -> int -> int -> typ = "caml_vc_subRangeType"
+
+(* Function Types *)
+external funType1 : vc -> typ -> typ -> typ = "caml_vc_funType1"
+external funType2 : vc -> typ -> typ -> typ -> typ = "caml_vc_funType2"
+external funType3 : vc -> typ -> typ -> typ -> typ -> typ =
+ "caml_vc_funType3"
+external funTypeN : vc -> typ array -> typ -> typ = "caml_vc_funTypeN"
+
+(* User defined Types *)
+external createType : vc -> string -> typ = "caml_vc_createType"
+external lookupType : vc -> string -> typ = "caml_vc_lookupType"
+
+(* Expression Manipulation *)
+external varExpr : vc -> string -> typ -> expr = "caml_vc_varExpr"
+external lookupVar : vc -> string -> typ -> expr = "caml_vc_lookupExpr"
+external getType : vc -> expr -> typ = "caml_vc_getType"
+external eqExpr : vc -> expr -> expr -> expr = "caml_vc_eqExpr"
+external trueExpr : vc -> expr = "caml_vc_trueExpr"
+external falseExpr : vc -> expr = "caml_vc_falseExpr"
+external notExpr : vc -> expr -> expr = "caml_vc_notExpr"
+external andExpr : vc -> expr -> expr -> expr = "caml_vc_andExpr"
+external andExprN : vc -> expr array -> expr = "caml_vc_andExprN"
+external orExpr : vc -> expr -> expr -> expr = "caml_vc_orExpr"
+external orExprN : vc -> expr array -> expr = "caml_vc_orExprN"
+external impliesExpr : vc -> expr -> expr -> expr = "caml_vc_impliesExpr"
+external iffExpr : vc -> expr -> expr -> expr = "caml_vc_iffExpr"
+external iteExpr : vc -> expr -> expr -> expr -> expr = "caml_vc_iteExpr"
+
+(* Arithmetic Expressions *)
+external ratExpr : vc -> int -> int -> expr = "caml_vc_ratExpr"
+external ratExprFromStr : vc -> string -> string -> int -> expr =
+ "caml_vc_ratExprFromStr"
+
+external uminusExpr : vc -> expr -> expr = "caml_vc_uminusExpr"
+external plusExpr : vc -> expr -> expr -> expr = "caml_vc_plusExpr"
+external minusExpr : vc -> expr -> expr -> expr = "caml_vc_minusExpr"
+external multExpr : vc -> expr -> expr -> expr = "caml_vc_multExpr"
+external powExpr : vc -> expr -> expr -> expr = "caml_vc_powExpr"
+external divideExpr : vc -> expr -> expr -> expr = "caml_vc_divideExpr"
+
+external ltExpr : vc -> expr -> expr -> expr = "caml_vc_ltExpr"
+external leExpr : vc -> expr -> expr -> expr = "caml_vc_leExpr"
+external gtExpr : vc -> expr -> expr -> expr = "caml_vc_gtExpr"
+external geExpr : vc -> expr -> expr -> expr = "caml_vc_geExpr"
+
+(* Records *)
+(* Arrays *)
+(* Functions *)
+(* Tuples *)
+(* Quantifiers *)
+
+(* Expr I/O *)
+external printExpr : vc -> expr -> unit = "caml_vc_printExpr"
+external printExprFile : vc -> expr -> int -> unit =
+ "caml_vc_printExprFile"
+
+(* Contexts *)
+external assertFormula : vc -> expr -> unit = "caml_vc_assertFormula"
+external registerAtom : vc -> expr -> unit = "caml_vc_registerAtom"
+external getImpliedLiteral : vc -> expr = "caml_vc_getImpliedLiteral"
+external simplify : vc -> expr -> expr = "caml_vc_simplify"
+external query : vc -> expr -> bool = "caml_vc_query"
+external getCounterExample : vc -> expr list = "caml_vc_getCounterExample"
+external setResourceLimit : vc -> int -> unit = "caml_vc_setResourceLimit"
+external getProof : vc -> expr = "caml_vc_getProof"
+external getProofOfFile : vc -> string -> expr = "caml_vc_getProofOfFile"
+external push : vc -> unit = "caml_vc_push"
+external pop : vc -> unit = "caml_vc_pop"
+external popto : vc -> int -> unit = "caml_vc_popto"
+external scopeLevel : vc -> int = "caml_vc_scopeLevel"
+
+(* Util *)
+external compare_exprs : expr -> expr -> bool = "caml_compare_exprs"
+external exprString : expr -> string = "caml_exprString"
+external typeString : typ -> string = "caml_typeString"
+external isClosure : expr -> bool = "caml_isClosure"
+external isQuantifier : expr -> bool = "caml_isQuantifier"
+external isLambda : expr -> bool = "caml_isLambda"
+external isVar : expr -> bool = "caml_isVar"
+external isConst : expr -> bool = "caml_isConst"
+external arity : expr -> int = "caml_arity"
+external getKind : expr -> int = "caml_getKind"
+external isEq : expr -> bool = "caml_isEq"
+external getChild : expr -> int -> expr = "caml_getChild"
+external getNumVars : expr -> expr = "caml_getNumVars"
+external getVar : expr -> int -> expr = "caml_getVar"
+external getBody : expr -> expr = "caml_getBody"
+external getFun : vc -> expr -> expr = "caml_getFun"
+external toExpr : typ -> expr = "caml_toExpr"
+external getKindString : vc -> int -> string = "caml_vc_getKindString"
+external getKindInt : vc -> string -> int = "caml_vc_getKindInt"
+external getInt : expr -> int = "caml_getInt"
+external getBVInt : expr -> int = "caml_getBVInt"
+external getBVUnsigned : expr -> int = "caml_getBVUnsigned"
+
+(* Print Statistics *)
+external print_statistics : vc -> unit = "caml_print_statistics"
+
+(* Bit Vector Operations *)
+(* Construction *)
+external bvType : vc -> int -> typ = "caml_vc_bvType"
+external bv32Type : vc -> typ = "caml_vc_bv32Type"
+external bvConstExprFromStr : vc -> string -> expr =
+ "caml_vc_bvConstExprFromStr"
+external bvConstExprFromInt : vc -> int -> int -> expr =
+ "caml_vc_bvConstExprFromInt"
+external bv32ConstExprFromInt : vc -> int -> expr =
+ "caml_vc_bv32ConstExprFromInt"
+external bvConcatExpr : vc -> expr -> expr -> expr =
+ "caml_vc_bvConcatExpr"
+
+(* Arithmetic *)
+external bvPlusExpr : vc -> int -> expr -> expr -> expr =
+ "caml_vc_bvPlusExpr"
+external bv32PlusExpr : vc -> expr -> expr -> expr =
+ "caml_vc_bv32PlusExpr"
+external bvMinusExpr : vc -> int -> expr -> expr -> expr =
+ "caml_vc_bvMinusExpr"
+external bv32MinusExpr : vc -> expr -> expr -> expr =
+ "caml_vc_bv32MinusExpr"
+external bvMultExpr : vc -> int -> expr -> expr -> expr =
+ "caml_vc_bvMultExpr"
+external bv32MultExpr : vc -> expr -> expr -> expr =
+ "caml_vc_bv32MultExpr"
+
+external bvUMinusExpr : vc -> expr -> expr =
+ "caml_vc_bvUMinusExpr"
+external bvNotExpr : vc -> expr -> expr =
+ "caml_vc_bvNotExpr"
+external bvAndExpr : vc -> expr -> expr -> expr =
+ "caml_vc_bvAndExpr"
+external bvOrExpr : vc -> expr -> expr -> expr =
+ "caml_vc_bvOrExpr"
+external bvXorExpr : vc -> expr -> expr -> expr =
+ "caml_vc_bvXorExpr"
+
+external bvLeftShiftExpr : vc -> int -> expr -> expr =
+ "caml_vc_bvLeftShiftExpr"
+external bvRightShiftExpr : vc -> int -> expr -> expr =
+ "caml_vc_bvRightShiftExpr"
+external bv32LeftShiftExpr : vc -> int -> expr -> expr =
+ "caml_vc_bv32LeftShiftExpr"
+external bv32RightShiftExpr : vc -> int -> expr -> expr =
+ "caml_vc_bv32RightShiftExpr"
+
+external bvVar32LeftShiftExpr : vc -> expr -> expr -> expr =
+ "caml_vc_bvVar32LeftShiftExpr"
+external bvVar32RightShiftExpr : vc -> expr -> expr -> expr =
+ "caml_vc_bvVar32RightShiftExpr"
+external bvVar32DivByPowOfTwoExpr : vc -> expr -> expr -> expr =
+ "caml_vc_bvVar32DivByPowOfTwoExpr"
+
+external bvExtract : vc -> expr -> int -> int -> expr =
+ "caml_vc_bvExtract"
+external bvBoolExtract : vc -> expr -> int -> expr =
+ "caml_vc_bvBoolExtract"
+
+external bvSignExtend : vc -> expr -> int -> expr =
+ "caml_vc_bvSignExtend"
+
+(* unsigned comparators *)
+external bvLtExpr : vc -> expr -> expr -> expr =
+ "caml_vc_bvLtExpr"
+external bvLeExpr : vc -> expr -> expr -> expr =
+ "caml_vc_bvLeExpr"
+external bvGtExpr : vc -> expr -> expr -> expr =
+ "caml_vc_bvGtExpr"
+external bvGeExpr : vc -> expr -> expr -> expr =
+ "caml_vc_bvGeExpr"
+
+(* signed comparators *)
+external sbvLtExpr : vc -> expr -> expr -> expr =
+ "caml_vc_sbvLtExpr"
+external sbvLeExpr : vc -> expr -> expr -> expr =
+ "caml_vc_sbvLeExpr"
+external sbvGtExpr : vc -> expr -> expr -> expr =
+ "caml_vc_sbvGtExpr"
+external sbvGeExpr : vc -> expr -> expr -> expr =
+ "caml_vc_sbvGeExpr"
+
+(* for C arrays *)
+external bvCreateMemoryArray : vc -> string -> expr =
+ "caml_vc_bvCreateMemoryArray"
+external bvReadMemoryArray : vc -> expr -> expr -> int -> expr =
+ "caml_vc_bvReadMemoryArray"
+external bvWriteToMemoryArray : vc -> expr -> expr -> expr -> int -> expr =
+ "caml_vc_bvWriteToMemoryArray"
--- /dev/null
+/*
+
+cvcl_ocaml_wrappers.c
+
+This file contains wrappers for the C interface to CVCL
+that are callable from ocaml code.
+
+Search for XXX to find unimplemented things
+
+*/
+
+#include <c_interface.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+
+ // The commonly used kinds and the kinds needed by the parser. All
+ // these kinds are registered by the ExprManager and are readily
+ // available for everyone else.
+typedef enum {
+ NULL_KIND = 0,
+ // Generic LISP kinds for representing raw parsed expressions
+ RAW_LIST, //!< May have any number of children >= 0
+ //! Identifier is (ID (STRING_EXPR "name"))
+ ID,
+ // Leaf exprs
+ STRING_EXPR,
+ RATIONAL_EXPR,
+ TRUE,
+ FALSE,
+ // Types
+ BOOLEAN,
+// TUPLE_TYPE,
+ ANY_TYPE,
+ ARROW,
+ // The "type" of any expression type (as in BOOLEAN : TYPE).
+ TYPE,
+ // Declaration of new (uninterpreted) types: T1, T2, ... : TYPE
+ // (TYPEDECL T1 T2 ...)
+ TYPEDECL,
+ // Declaration of a defined type T : TYPE = type === (TYPEDEF T type)
+ TYPEDEF,
+
+ // Equality
+ EQ,
+ NEQ,
+
+ // Propositional connectives
+ NOT,
+ AND,
+ OR,
+ XOR,
+ IFF,
+ IMPLIES,
+ // BOOL_VAR, //!< Boolean variables are treated as 0-ary predicates
+
+ // Propositional relations (for circuit propagation)
+ AND_R,
+ IFF_R,
+ ITE_R,
+
+ // (ITE c e1 e2) == IF c THEN e1 ELSE e2 ENDIF, the internal
+ // representation of the conditional. Parser produces (IF ...).
+ ITE,
+
+ // Quantifiers
+ FORALL,
+ EXISTS,
+
+ // Uninterpreted function
+ UFUNC,
+ // Application of a function
+ APPLY,
+
+ // Top-level Commands
+ ASSERT,
+ QUERY,
+ CHECKSAT,
+ CONTINUE,
+ RESTART,
+ DBG,
+ TRACE,
+ UNTRACE,
+ OPTION,
+ HELP,
+ TRANSFORM,
+ PRINT,
+ CALL,
+ ECHO,
+ INCLUDE,
+ DUMP_PROOF,
+ DUMP_ASSUMPTIONS,
+ DUMP_SIG,
+ DUMP_TCC,
+ DUMP_TCC_ASSUMPTIONS,
+ DUMP_TCC_PROOF,
+ DUMP_CLOSURE,
+ DUMP_CLOSURE_PROOF,
+ WHERE,
+ ASSERTIONS,
+ ASSUMPTIONS,
+ COUNTEREXAMPLE,
+ COUNTERMODEL,
+ PUSH,
+ POP,
+ POPTO,
+ PUSH_SCOPE,
+ POP_SCOPE,
+ POPTO_SCOPE,
+ CONTEXT,
+ FORGET,
+ GET_TYPE,
+ CHECK_TYPE,
+ GET_CHILD,
+ SUBSTITUTE,
+ SEQ,
+
+ // Kinds used mostly in the parser
+
+ TCC,
+ // Variable declaration (VARDECL v1 v2 ... v_n type). A variable
+ // can be an ID or a BOUNDVAR.
+ VARDECL,
+ // A list of variable declarations (VARDECLS (VARDECL ...) (VARDECL ...) ...)
+ VARDECLS,
+
+ // Bound variables have a "printable name", the one the user typed
+ // in, and a uniqueID used to distinguish it from other bound
+ // variables, which is effectively the alpha-renaming:
+
+ // Op(BOUND_VAR (BOUND_ID "user_name" "uniqueID")). Note that
+ // BOUND_VAR is an operator (Expr without children), just as UFUNC
+ // and UCONST.
+
+ // The uniqueID normally is just a number, so one can print a bound
+ // variable X as X_17.
+
+ // NOTE that in the parsed expressions like LET x: T = e IN foo(x),
+ // the second instance of 'x' will be an ID, and *not* a BOUNDVAR.
+ // The parser does not know how to resolve bound variables, and it
+ // has to be resolved later.
+ BOUND_VAR,
+ BOUND_ID,
+
+ // Updator "e1 WITH <bunch of stuff> := e2" is represented as
+ // (UPDATE e1 (UPDATE_SELECT <bunch of stuff>) e2), where <bunch
+ // of stuff> is the list of accessors:
+ // (READ idx)
+ // ID (what's that for?)
+ // (REC_SELECT ID)
+ // and (TUPLE_SELECT num).
+// UPDATE,
+// UPDATE_SELECT,
+ // Record type [# f1 : t1, f2 : t2 ... #] is represented as
+ // (RECORD_TYPE (f1 t1) (f2 t2) ... )
+// RECORD_TYPE,
+// // (# f1=e1, f2=e2, ...#) == (RECORD (f1 e1) ...)
+// RECORD,
+// RECORD_SELECT,
+// RECORD_UPDATE,
+
+// // (e1, e2, ...) == (TUPLE e1 e2 ...)
+// TUPLE,
+// TUPLE_SELECT,
+// TUPLE_UPDATE,
+
+// SUBRANGE,
+ // Enumerated type (SCALARTYPE v1 v2 ...)
+// SCALARTYPE,
+ // Predicate subtype: the argument is the predicate (lambda-expression)
+ SUBTYPE,
+ // Datatype is Expr(DATATYPE, Constructors), where Constructors is a
+ // vector of Expr(CONSTRUCTOR, id [ , arg ]), where 'id' is an ID,
+ // and 'arg' a VARDECL node (list of variable declarations with
+ // types). If 'arg' is present, the constructor has arguments
+ // corresponding to the declared variables.
+// DATATYPE,
+// THISTYPE, // Used to indicate recursion in recursive datatypes
+// CONSTRUCTOR,
+// SELECTOR,
+// TESTER,
+ // Expression e WITH accessor := e2 is transformed by the command
+ // processor into (DATATYPE_UPDATE e accessor e2), where e is the
+ // original datatype value C(a1, ..., an) (here C is the
+ // constructor), and "accessor" is the name of one of the arguments
+ // a_i of C.
+ // DATATYPE_UPDATE,
+ // Statement IF c1 THEN e1 ELSIF c2 THEN e2 ... ELSE e_n ENDIF is
+ // represented as (IF (IFTHEN c1 e1) (IFTHEN c2 e2) ... (ELSE e_n))
+ IF,
+ IFTHEN,
+ ELSE,
+ // Lisp version of multi-branch IF:
+ // (COND (c1 e1) (c2 e2) ... (ELSE en))
+ COND,
+
+ // LET x1: t1 = e1, x2: t2 = e2, ... IN e
+ // Parser builds:
+ // (LET (LETDECLS (LETDECL x1 t1 e1) (LETDECL x2 t2 e2) ... ) e)
+ // where each x_i is a BOUNDVAR.
+ // After processing, it is rebuilt to have (LETDECL var def); the
+ // type is set as the attribute to var.
+ LET,
+ LETDECLS,
+ LETDECL,
+ // Lambda-abstraction LAMBDA (<vars>) : e === (LAMBDA <vars> e)
+ LAMBDA,
+ // Symbolic simulation operator
+ SIMULATE,
+
+ // Uninterpreted constants (variables) x1, x2, ... , x_n : type
+ // (CONST (VARLIST x1 x2 ... x_n) type)
+ // Uninterpreted functions are declared as constants of functional type.
+
+ // After processing, uninterpreted functions and constants
+ // (a.k.a. variables) are represented as Op(UFUNC, (ID "name")) and
+ // Op(UCONST, (ID "name")) with the appropriate type attribute.
+ CONST,
+ VARLIST,
+ UCONST,
+
+ // User function definition f(args) : type = e === (DEFUN args type e)
+ // Here 'args' are bound var declarations
+ DEFUN,
+
+ // Arithmetic types and operators
+// REAL,
+// INT,
+
+// UMINUS,
+// PLUS,
+// MINUS,
+// MULT,
+// DIVIDE,
+// INTDIV,
+// MOD,
+// LT,
+// LE,
+// GT,
+// GE,
+// IS_INTEGER,
+// NEGINF,
+// POSINF,
+// DARK_SHADOW,
+// GRAY_SHADOW,
+
+// //Floor theory operators
+// FLOOR,
+ // Kind for Extension to Non-linear Arithmetic
+// POW,
+
+ // Kinds for proof terms
+ PF_APPLY,
+ PF_HOLE,
+
+
+// // Mlss
+// EMPTY, // {}
+// UNION, // +
+// INTER, // *
+// DIFF,
+// SINGLETON,
+// IN,
+// INCS,
+// INCIN,
+
+ //Skolem variable
+ SKOLEM_VAR,
+ //! Must always be the last kind
+ LAST_KIND
+} Kind;
+
+/************************************************************
+
+Structures that tell the ocaml runtime how to deal with
+things of abstract types that we will ll be passing it.
+
+************************************************************/
+
+/* Encapsulation of ValidityChecker
+ as Caml custom blocks. */
+static struct custom_operations VC_ops = {
+ "CVCL.ValidityChecker",
+ custom_finalize_default,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+/* Encapsulation of Context
+ as Caml custom blocks. */
+static struct custom_operations Context_ops = {
+ "CVCL.Context",
+ custom_finalize_default,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+/* Encapsulation of ExprManager
+ as Caml custom blocks. */
+static struct custom_operations EM_ops = {
+ "CVCL.ExprManager",
+ custom_finalize_default,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+/* Encapsulation of Flags
+ as Caml custom blocks. */
+static struct custom_operations Flags_ops = {
+ "CVCL.Flags",
+ custom_finalize_default,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+/* Encapsulation of Expr
+ as Caml custom blocks. */
+static struct custom_operations Expr_ops = {
+ "CVCL.Expr",
+ custom_finalize_default,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+/* Encapsulation of Op
+ as Caml custom blocks. */
+static struct custom_operations Op_ops = {
+ "CVCL.Op",
+ custom_finalize_default,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+/* Encapsulation of Type
+ as Caml custom blocks. */
+static struct custom_operations Type_ops = {
+ "CVCL.Type",
+ custom_finalize_default,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+/************************************************************
+
+Functions for wrapping and unwrapping ocaml values for the
+abstract types above.
+
+************************************************************/
+
+/* Accessing the relevant part of a Caml custom block */
+#define VC_val(v) (*((VC *) Data_custom_val(v)))
+#define Context_val(v) (*((Context *) Data_custom_val(v)))
+#define EM_val(v) (*((ExprManager *) Data_custom_val(v)))
+#define Flags_val(v) (*((Flags *) Data_custom_val(v)))
+#define Expr_val(v) (*((Expr *) Data_custom_val(v)))
+#define OP_val(v) (*((Op *) Data_custom_val(v)))
+#define Type_val(v) (*((Type *) Data_custom_val(v)))
+
+/* Allocating a Caml custom block to hold the given CVCL structure */
+static value alloc_VC(VC vc)
+{
+ value v = alloc_custom(&VC_ops, sizeof(VC), 0, 1);
+ VC_val(v) = vc;
+ return v;
+}
+
+static value alloc_Context(Context ctxt)
+{
+ value v = alloc_custom(&Context_ops, sizeof(Context), 0, 1);
+ Context_val(v) = ctxt;
+ return v;
+}
+
+static value alloc_EM(ExprManager em)
+{
+ value v = alloc_custom(&EM_ops, sizeof(ExprManager), 0, 1);
+ EM_val(v) = em;
+ return v;
+}
+
+static value alloc_Flags(Flags f)
+{
+ value v = alloc_custom(&Flags_ops, sizeof(Flags), 0, 1);
+ Flags_val(v) = f;
+ return v;
+}
+
+static value alloc_Expr(Expr e)
+{
+ value v = alloc_custom(&Expr_ops, sizeof(Expr), 0, 1);
+ Expr_val(v) = e;
+ return v;
+}
+
+static value alloc_Op(Op op)
+{
+ value v = alloc_custom(&Op_ops, sizeof(Op), 0, 1);
+ OP_val(v) = op;
+ return v;
+}
+
+static value alloc_Type(Type t)
+{
+ value v = alloc_custom(&Type_ops, sizeof(Type), 0, 1);
+ Type_val(v) = t;
+ return v;
+}
+
+/************************************************************
+
+Wrappers
+
+************************************************************/
+
+value caml_vc_createValidityChecker(value flags)
+{
+ CAMLparam1(flags);
+ CAMLreturn(alloc_VC(vc_createValidityChecker(Flags_val(flags))));
+}
+
+value caml_vc_createFlags(value unit)
+{
+ CAMLparam1(unit);
+ CAMLreturn(alloc_Flags(vc_createFlags()));
+}
+
+value caml_vc_destroyValidityChecker(value vc)
+{
+ CAMLparam1(vc);
+ vc_destroyValidityChecker(VC_val(vc));
+ CAMLreturn(Val_unit);
+}
+
+value caml_vc_deleteFlags(value flags)
+{
+ CAMLparam1(flags);
+ vc_deleteFlags(Flags_val(flags));
+ CAMLreturn(Val_unit);
+}
+
+value caml_vc_deleteType(value type)
+{
+ CAMLparam1(type);
+ vc_deleteType(Type_val(type));
+ CAMLreturn(Val_unit);
+}
+
+value caml_vc_deleteExpr(value e)
+{
+ CAMLparam1(e);
+ vc_deleteExpr(Expr_val(e));
+ CAMLreturn(Val_unit);
+}
+
+value caml_vc_deleteOp(value op)
+{
+ CAMLparam1(op);
+ vc_deleteOp(OP_val(op));
+ CAMLreturn(Val_unit);
+}
+
+// Setting the flags
+value caml_vc_setBoolFlag(value flags, value name, value val)
+{
+ CAMLparam3(flags,name,val);
+ vc_setBoolFlag(Flags_val(flags),String_val(name),Int_val(val));
+ CAMLreturn(Val_unit);
+}
+
+value caml_vc_setIntFlag(value flags, value name, value val)
+{
+ CAMLparam3(flags,name,val);
+ vc_setIntFlag(Flags_val(flags),String_val(name),Int_val(val));
+ CAMLreturn(Val_unit);
+}
+
+value caml_vc_setStringFlag(value flags, value name, value val)
+{
+ CAMLparam3(flags,name,val);
+ vc_setStringFlag(Flags_val(flags),String_val(name),String_val(val));
+ CAMLreturn(Val_unit);
+}
+
+value caml_vc_setStrSeqFlag(value flags, value name, value str, value val)
+{
+ CAMLparam4(flags,name,str,val);
+ vc_setStrSeqFlag(Flags_val(flags),String_val(name),
+ String_val(val),Int_val(val));
+ CAMLreturn(Val_unit);
+}
+
+// Basic Types
+value caml_vc_boolType(value vc)
+{
+ CAMLparam1(vc);
+ CAMLreturn(alloc_Type(vc_boolType(VC_val(vc))));
+}
+
+value caml_vc_realType(value vc)
+{
+ CAMLparam1(vc);
+ CAMLreturn(alloc_Type(vc_realType(VC_val(vc))));
+}
+
+value caml_vc_intType(value vc)
+{
+ CAMLparam1(vc);
+ CAMLreturn(alloc_Type(vc_intType(VC_val(vc))));
+}
+
+// Tuple Types
+value caml_vc_tupleType2(value vc, value t0, value t1)
+{
+ CAMLparam3(vc,t0,t1);
+ CAMLreturn(alloc_Type(vc_tupleType2(VC_val(vc),Type_val(t0),Type_val(t1))));
+}
+
+value caml_vc_tupleType3(value vc, value t0, value t1, value t2)
+{
+ CAMLparam4(vc,t0,t1,t2);
+ CAMLreturn(alloc_Type(vc_tupleType3(VC_val(vc),Type_val(t0),
+ Type_val(t1),Type_val(t2))));
+}
+
+value caml_vc_tupleTypeN(value vc, value types, value numTypes)
+{
+ Type *ts;
+ int i;
+
+ CAMLparam3(vc,types,numTypes);
+ CAMLlocal1(result);
+
+ ts = (Type *)malloc(Int_val(numTypes) * sizeof(Type));
+ if( !ts )
+ caml_failwith("malloc returned NULL in vc_tupleTypeN wrapper");
+
+ for( i = 0; i < Int_val(numTypes); i++ ) {
+ ts[i] = Type_val(Field(types,i));
+ }
+
+ result = alloc_Type(vc_tupleTypeN(VC_val(vc), ts, Int_val(numTypes)));
+
+ free( ts );
+
+ CAMLreturn(result);
+}
+
+// Record Types
+value caml_vc_recordType1(value vc, value field, value t)
+{
+ CAMLparam3(vc, field, t);
+ CAMLreturn(alloc_Type(vc_recordType1(VC_val(vc),String_val(field),
+ Type_val(t))));
+}
+
+value caml_vc_recordType2(value vc, value f0, value t0, value f1, value t1)
+{
+ CAMLparam5(vc,f0,t0,f1,t1);
+ CAMLreturn(alloc_Type(vc_recordType2(VC_val(vc),String_val(f0),Type_val(t0),
+ String_val(f1),Type_val(t1))));
+}
+
+/*
+value caml_vc_recordType3_(value vc, value f0, value t0, value f1, value t1,
+ value f2, value t2)
+{
+ CAMLparam5(vc,f0,t0,f1,t1);
+ CAMLxparam2(f2,t2);
+ CAMLreturn(alloc_Type(vc_recordType3(VC_val(vc),String_val(f0),Type_val(t0),
+ String_val(f1),Type_val(t1),
+ String_val(f2),Type_val(t2))));
+}
+
+value caml_vc_recordType3(value *args, int num)
+{
+
+ return(caml_vc_recordType3_(args[0],args[1],args[2],
+ args[3],args[4],args[5],
+ args[6]));
+}
+*/
+
+value caml_vc_recordTypeN(value vc, value fields, value types, value num)
+{
+ char **fs;
+ Type *ts;
+ int i;
+
+ CAMLparam4(vc,fields,types,num);
+ CAMLlocal1(result);
+
+ fs = (char **)malloc(Int_val(num) * sizeof(char *));
+ if( !fs )
+ caml_failwith("malloc returned NULL in vc_recordTypeN wrapper");
+
+ ts = (Type *)malloc(Int_val(num) * sizeof(Type));
+ if( !ts ) {
+ free( fs );
+ caml_failwith("malloc returned NULL in vc_recordTypeN wrapper");
+ }
+
+ for( i = 0; i < Int_val(num); i++ ) {
+ fs[i] = String_val(Field(fields,i));
+ ts[i] = Type_val(Field(types,i));
+ }
+
+ result = alloc_Type(vc_recordTypeN(VC_val(vc),fs,ts,Int_val(num)));
+
+ free(ts);
+ free(fs);
+
+ CAMLreturn(result);
+}
+
+// Create an array type
+value caml_vc_arrayType(value vc, value it, value dt)
+{
+ CAMLparam3(vc,it,dt);
+ CAMLreturn(alloc_Type(vc_arrayType(VC_val(vc),Type_val(it),Type_val(dt))));
+}
+
+// Create a subrange type
+value caml_vc_subRangeType(value vc, value low, value hi)
+{
+ CAMLparam3(vc,low,hi);
+ CAMLreturn(alloc_Type(vc_subRangeType(VC_val(vc),Int_val(low),Int_val(hi))));
+}
+
+// Create function types
+value caml_vc_funType1(value vc, value a1, value tr)
+{
+ CAMLparam3(vc,a1,tr);
+ CAMLreturn(alloc_Type(vc_funType1(VC_val(vc),Type_val(a1),Type_val(tr))));
+}
+
+value caml_vc_funType2(value vc, value a1, value a2, value tr)
+{
+ CAMLparam4(vc,a1,a2,tr);
+ CAMLreturn(alloc_Type(vc_funType2(VC_val(vc),Type_val(a1),
+ Type_val(a2),Type_val(tr))));
+}
+
+value caml_vc_funType3(value vc, value a1, value a2, value a3, value tr)
+{
+ CAMLparam5(vc,a1,a2,a3,tr);
+ CAMLreturn(alloc_Type(vc_funType3(VC_val(vc),Type_val(a1),
+ Type_val(a2),Type_val(a3),
+ Type_val(tr))));
+}
+
+value caml_vc_funTypeN(value vc, value args, value r, value num)
+{
+ Type *ts;
+ int i;
+
+ CAMLparam4(vc,args,r,num);
+ CAMLlocal1(result);
+
+ ts = (Type *)malloc(Int_val(num) * sizeof(Type));
+ if( !ts )
+ caml_failwith("malloc returned NULL in vc_funTypeN wrapper");
+
+ for( i = 0; i < Int_val(num); i++ ) {
+ ts[i] = Type_val(Field(args,i));
+ }
+
+ result = alloc_Type(vc_funTypeN(VC_val(vc), ts, Type_val(r),
+ Int_val(num)));
+
+ free( ts );
+
+ CAMLreturn(result);
+}
+
+// User-defined types
+value caml_vc_createType(value vc, value name)
+{
+ CAMLparam2(vc, name);
+ CAMLreturn(alloc_Type(vc_createType(VC_val(vc),String_val(name))));
+}
+
+value caml_vc_lookupType(value vc, value name)
+{
+ CAMLparam2(vc,name);
+ CAMLreturn(alloc_Type(vc_lookupType(VC_val(vc),String_val(name))));
+}
+
+/*
+ * Expr manipulation methods
+ */
+
+// XXX
+// ExprManager * vc_getEM(VC vc);
+
+// Create a variable with a given name and type
+value caml_vc_varExpr(value vc, value name, value t)
+{
+ CAMLparam3(vc, name, t);
+ CAMLreturn(alloc_Expr(vc_varExpr(VC_val(vc),String_val(name),Type_val(t))));
+}
+
+// Get the expression and type associated with a name
+value caml_vc_lookupVar(value vc, value name, value t)
+{
+ CAMLparam3(vc,name,t);
+ CAMLreturn(alloc_Expr(vc_lookupVar(VC_val(vc),String_val(name),Type_val(t))));
+}
+
+// Get the type of the expr
+value caml_vc_getType(value vc, value e)
+{
+ CAMLparam2(vc,e);
+ CAMLreturn(alloc_Type(vc_getType(VC_val(vc),Expr_val(e))));
+}
+
+// Create and equality expression. Children have same type
+value caml_vc_eqExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_eqExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+// Boolean expressions
+value caml_vc_trueExpr(value vc)
+{
+ CAMLparam1(vc);
+ CAMLreturn(alloc_Expr(vc_trueExpr(VC_val(vc))));
+}
+
+value caml_vc_falseExpr(value vc)
+{
+ CAMLparam1(vc);
+ CAMLreturn(alloc_Expr(vc_falseExpr(VC_val(vc))));
+}
+
+value caml_vc_notExpr(value vc, value e)
+{
+ CAMLparam2(vc,e);
+ CAMLreturn(alloc_Expr(vc_notExpr(VC_val(vc),Expr_val(e))));
+}
+
+value caml_vc_andExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_andExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_andExprN(value vc, value exprs, value num)
+{
+ Expr *es;
+ int i;
+
+ CAMLparam3(vc,exprs,num);
+ CAMLlocal1(result);
+
+ es = (Expr *)malloc(Int_val(num) * sizeof(Expr));
+ if( !es )
+ caml_failwith("malloc returned NULL in vc_andExprN wrapper");
+
+ for( i = 0; i < Int_val(num); i++ ) {
+ es[i] = Expr_val(Field(exprs,i));
+ }
+
+ result = alloc_Expr(vc_andExprN(VC_val(vc),es,Int_val(num)));
+
+ free( es );
+
+ CAMLreturn(result);
+}
+
+value caml_vc_orExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_orExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_orExprN(value vc, value exprs, value num)
+{
+ Expr *es;
+ int i;
+
+ CAMLparam3(vc,exprs,num);
+ CAMLlocal1(result);
+
+ es = (Expr *)malloc(Int_val(num) * sizeof(Expr));
+ if( !es )
+ caml_failwith("malloc returned NULL in vc_orExprN wrapper");
+
+ for( i = 0; i < Int_val(num); i++ ) {
+ es[i] = Expr_val(Field(exprs,i));
+ }
+
+ result = alloc_Expr(vc_orExprN(VC_val(vc),es,Int_val(num)));
+
+ free( es );
+
+ CAMLreturn(result);
+}
+
+value caml_vc_impliesExpr(value vc, value h, value c)
+{
+ CAMLparam3(vc,h,c);
+ CAMLreturn(alloc_Expr(vc_impliesExpr(VC_val(vc),Expr_val(h),Expr_val(c))));
+}
+
+value caml_vc_iffExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_iffExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_iteExpr(value vc, value i, value t, value e)
+{
+ CAMLparam4(vc,i,t,e);
+ CAMLreturn(alloc_Expr(vc_iteExpr(VC_val(vc),Expr_val(i),Expr_val(t),
+ Expr_val(e))));
+}
+
+/*
+ * Arithmetic
+ */
+
+// Create a rational number of numerator n and denominator d.
+value caml_vc_ratExpr(value vc, value n, value d)
+{
+ CAMLparam3(vc,n,d);
+ CAMLreturn(alloc_Expr(vc_ratExpr(VC_val(vc),Int_val(n),Int_val(d))));
+}
+
+// Create a rational number n/d. n and d given as strings
+value caml_vc_ratExprFromStr(value vc, value n, value d, value b)
+{
+ CAMLparam4(vc,n,d,b);
+ CAMLreturn(alloc_Expr(vc_ratExprFromStr(VC_val(vc),String_val(n),
+ String_val(d),Int_val(b))));
+}
+
+// Unary minus
+value caml_vc_uminusExpr(value vc, value e)
+{
+ CAMLparam2(vc,e);
+ CAMLreturn(alloc_Expr(vc_uminusExpr(VC_val(vc),Expr_val(e))));
+}
+
+// plus, minus, mult... exprs must have numeric type
+value caml_vc_plusExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_plusExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_minusExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_minusExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_multExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_multExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_powExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_powExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_divideExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_divideExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+// comparators. produce boolean expressions expressions must have numeric type
+value caml_vc_ltExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_ltExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_leExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_leExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_gtExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_gtExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_geExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_geExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+/* XXX
+ * Records
+ */
+
+/* XXX
+ * Arrays
+ */
+
+/* XXX
+ * Functions
+ */
+
+/* XXX
+ * Tuples
+ */
+
+/* XXX
+ * Quantifiers
+ */
+
+/*
+ * Expr I/O
+ */
+
+value caml_vc_printExpr(value vc, value e)
+{
+ CAMLparam2(vc,e);
+ vc_printExpr(VC_val(vc),Expr_val(e));
+ CAMLreturn(Val_unit);
+}
+
+value caml_vc_printExprFile(value vc, value e, value fd)
+{
+ CAMLparam3(vc,e,fd);
+ vc_printExprFile(VC_val(vc),Expr_val(e),Int_val(fd));
+ CAMLreturn(Val_unit);
+}
+
+/*
+ * Context related methods
+ */
+
+// Assert a new formula in the current context
+value caml_vc_assertFormula(value vc, value e)
+{
+ CAMLparam2(vc,e);
+ vc_assertFormula(VC_val(vc),Expr_val(e));
+ CAMLreturn(Val_unit);
+}
+
+// Register an atomic formula of interest
+value caml_vc_registerAtom(value vc, value e)
+{
+ CAMLparam2(vc,e);
+ vc_registerAtom(VC_val(vc),Expr_val(e));
+ CAMLreturn(Val_unit);
+}
+
+// Return next literal implied by last assertion
+value caml_vc_getImpliedLiteral(value vc)
+{
+ CAMLparam1(vc);
+ CAMLreturn(alloc_Expr(vc_getImpliedLiteral(VC_val(vc))));
+}
+
+// Simplify e w.r.t. the current context
+value caml_vc_simplify(value vc, value e)
+{
+ CAMLparam2(vc,e);
+ CAMLreturn(alloc_Expr(vc_simplify(VC_val(vc),Expr_val(e))));
+}
+
+// Check validity of e in the current context
+value caml_vc_query(value vc, value e)
+{
+ CAMLparam2(vc,e);
+ CAMLreturn(Val_int(vc_query(VC_val(vc),Expr_val(e))));
+}
+
+// XXX
+// Expr * vc_getCounterExample(VC vc, int *size)
+value caml_vc_getCounterExample(value vc)
+{
+ CAMLparam1(vc);
+ CAMLlocal2(tmp,result);
+ Expr *e;
+ int i, size;
+
+ e = vc_getCounterExample(VC_val(vc), &size);
+
+ if( !e ) CAMLreturn(Val_int(0)); // empty list
+
+ result = Val_int(0);
+ for( i = 0; i < size; i++ ) {
+ tmp = caml_alloc(2, 0);
+ Store_field(tmp, 0, alloc_Expr(e[i]));
+ Store_field(tmp, 1, result);
+ result = tmp;
+ }
+
+ free(e);
+ CAMLreturn(result);
+
+}
+
+
+// XXX
+// int vc_inconsistent(VC vc, Expr **assumptions, int * size)
+
+// Set the resource limit (0==unlimited, 1==exhausted)
+value caml_vc_setResourceLimit(value vc, value limit)
+{
+ CAMLparam2(vc,limit);
+ vc_setResourceLimit(VC_val(vc), Int_val(limit));
+ CAMLreturn(Val_unit);
+}
+
+// Returns the proof for the last proven query
+value caml_vc_getProof(value vc)
+{
+ CAMLparam1(vc);
+ CAMLreturn(alloc_Expr(vc_getProof(VC_val(vc))));
+}
+
+// Returns the proof of a .cvc file, if it is valid
+value caml_vc_getProofOfFile(value vc, value fname)
+{
+ CAMLparam2(vc,fname);
+ CAMLreturn(alloc_Expr(vc_getProofOfFile(VC_val(vc),String_val(fname))));
+}
+
+// Checkpoint the current context and increase the scope level
+value caml_vc_push(value vc)
+{
+ CAMLparam1(vc);
+ vc_push(VC_val(vc));
+ CAMLreturn(Val_unit);
+}
+
+// Restore the current context to its state at the last checkpoint
+value caml_vc_pop(value vc)
+{
+ CAMLparam1(vc);
+ vc_pop(VC_val(vc));
+ CAMLreturn(Val_unit);
+}
+
+// Restore the current context to the given scope level
+value caml_vc_popto(value vc, value l)
+{
+ CAMLparam2(vc,l);
+ vc_popto(VC_val(vc),Int_val(l));
+ CAMLreturn(Val_unit);
+}
+
+// Returns the current scope level
+value caml_vc_scopeLevel(value vc)
+{
+ CAMLparam1(vc);
+ CAMLreturn(Val_int(vc_scopeLevel(VC_val(vc))));
+}
+
+// XXX
+// Context *vc_getCurrentContext(VC vc)
+
+/*
+ * Util
+ */
+
+// Returns 1, 0, -1
+value caml_compare_exprs(value e1, value e2)
+{
+ CAMLparam2(e1,e2);
+ CAMLreturn(Val_int(compare_exprs(Expr_val(e1),Expr_val(e2))));
+}
+
+// Converts expression to a string
+value caml_exprString(value e)
+{
+ CAMLparam1(e);
+ CAMLlocal1(r);
+
+ r = caml_copy_string(exprString(Expr_val(e)));
+
+ CAMLreturn(r);
+}
+
+// Convertsa Type to a string
+value caml_typeString(value t)
+{
+ CAMLparam1(t);
+ CAMLlocal1(r);
+
+ r = caml_copy_string(typeString(Type_val(t)));
+
+ CAMLreturn(r);
+}
+
+// what kind of Expr?
+value caml_isClosure(value e)
+{
+ CAMLparam1(e);
+ CAMLreturn(Val_int(isClosure(Expr_val(e))));
+}
+
+value caml_isQuantifier(value e)
+{
+ CAMLparam1(e);
+ CAMLreturn(Val_int(isQuantifier(Expr_val(e))));
+}
+
+value caml_isLambda(value e)
+{
+ CAMLparam1(e);
+ CAMLreturn(Val_int(isLambda(Expr_val(e))));
+}
+
+value caml_isVar(value e)
+{
+ CAMLparam1(e);
+ CAMLreturn(Val_int(isVar(Expr_val(e))));
+}
+
+value caml_isConst(value e)
+{
+ int k,r=0;
+ CAMLparam1(e);
+
+ k = getKind(Expr_val(e));
+ if( k == CONST ) r = 1;
+ CAMLreturn(Val_int(r));
+}
+
+value caml_arity(value e)
+{
+ CAMLparam1(e);
+ CAMLreturn(Val_int(arity(Expr_val(e))));
+}
+
+value caml_getKind(value e)
+{
+ CAMLparam1(e);
+ CAMLreturn(Val_int(getKind(Expr_val(e))));
+}
+
+value caml_isEq(value e)
+{
+ CAMLparam1(e);
+ CAMLreturn(Val_int(getKind(Expr_val(e)) == EQ));
+}
+
+value caml_getChild(value e, value i)
+{
+ CAMLparam2(e,i);
+ CAMLreturn(alloc_Expr(getChild(Expr_val(e),Int_val(i))));
+}
+
+value caml_getNumVars(value e)
+{
+ CAMLparam1(e);
+ CAMLreturn(alloc_Expr(getNumVars(Expr_val(e))));
+}
+
+value caml_getVar(value e, value i)
+{
+ CAMLparam2(e,i);
+ CAMLreturn(alloc_Expr(getVar(Expr_val(e),Int_val(i))));
+}
+
+value caml_getBody(value e)
+{
+ CAMLparam1(e);
+ CAMLreturn(alloc_Expr(getBody(Expr_val(e))));
+}
+
+value caml_vc_getFun(value vc, value e)
+{
+ CAMLparam2(vc,e);
+ CAMLreturn(alloc_Expr(vc_getFun(VC_val(vc),Expr_val(e))));
+}
+
+value caml_toExpr(value t)
+{
+ CAMLparam1(t);
+ CAMLreturn(alloc_Expr(toExpr(Type_val(t))));
+}
+
+// Translate a kind int to a string
+value caml_vc_getKindString(value vc, value k)
+{
+ CAMLparam2(vc,k);
+ CAMLlocal1(r);
+
+ r = caml_copy_string(vc_getKindString(VC_val(vc),Int_val(k)));
+
+ CAMLreturn(r);
+}
+
+// Translate a kind string to an int
+value caml_vc_getKindInt(value vc, value name)
+{
+ CAMLparam2(vc,name);
+ CAMLreturn(Val_int(vc_getKindInt(VC_val(vc),String_val(name))));
+}
+
+// Return an in from a rational exp
+value caml_getInt(value e)
+{
+ CAMLparam1(e);
+ CAMLreturn(Val_int(getInt(Expr_val(e))));
+}
+
+// Return an int from a constant bitvector expression
+value caml_getBVInt(value e)
+{
+ CAMLparam1(e);
+ CAMLreturn(Val_int(getBVInt(Expr_val(e))));
+}
+
+value caml_getBVUnsigned(value e)
+{
+ CAMLparam1(e);
+ CAMLreturn(Val_int(getBVUnsigned(Expr_val(e))));
+}
+
+// XXX
+// Debug
+
+// Print statistics
+value caml_print_statistics(value vc)
+{
+ CAMLparam1(vc);
+ print_statistics(VC_val(vc));
+ CAMLreturn(Val_unit);
+}
+
+/*
+ * Bit Vector Operations
+ */
+
+value caml_vc_bvType(value vc, value no_bits)
+{
+ CAMLparam2(vc,no_bits);
+ CAMLreturn(alloc_Type(vc_bvType(VC_val(vc),Int_val(no_bits))));
+}
+
+value caml_vc_bv32Type(value vc)
+{
+ CAMLparam1(vc);
+ CAMLreturn(alloc_Type(vc_bv32Type(VC_val(vc))));
+}
+
+value caml_vc_bvConstExprFromStr(value vc, value binstr)
+{
+ CAMLparam2(vc,binstr);
+ CAMLreturn(alloc_Expr(vc_bvConstExprFromStr(VC_val(vc),String_val(binstr))));
+}
+
+value caml_vc_bvConstExprFromInt(value vc, value nbits,value i)
+{
+ CAMLparam3(vc,nbits,i);
+ CAMLreturn(alloc_Expr(vc_bvConstExprFromInt(VC_val(vc),Int_val(nbits),
+ Int_val(i))));
+}
+
+value caml_vc_bv32ConstExprFromInt(value vc, value i)
+{
+ CAMLparam2(vc,i);
+ CAMLreturn(alloc_Expr(vc_bv32ConstExprFromInt(VC_val(vc),Int_val(i))));
+}
+
+value caml_vc_bvConcatExpr(value vc, value l, value r)
+{
+ CAMLparam3(vc,l,r);
+ CAMLreturn(alloc_Expr(vc_bvConcatExpr(VC_val(vc),Expr_val(l),Expr_val(r))));
+}
+
+// XXX
+// Expr vc_bvConcatExprN(VC vc, Expr *c, int num)
+
+value caml_vc_bvPlusExpr(value vc, value bits, value e1, value e2)
+{
+ CAMLparam4(vc,bits,e1,e2);
+ CAMLreturn(alloc_Expr(vc_bvPlusExpr(VC_val(vc),Int_val(bits),
+ Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_bv32PlusExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_bv32PlusExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_bvMinusExpr(value vc, value bits, value e1, value e2)
+{
+ CAMLparam4(vc,bits,e1,e2);
+ CAMLreturn(alloc_Expr(vc_bvMinusExpr(VC_val(vc),Int_val(bits),
+ Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_bv32MinusExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_bv32MinusExpr(VC_val(vc),Expr_val(e1),
+ Expr_val(e2))));
+}
+
+value caml_vc_bvMultExpr(value vc, value bits, value e1, value e2)
+{
+ CAMLparam4(vc,bits,e1,e2);
+ CAMLreturn(alloc_Expr(vc_bvMultExpr(VC_val(vc),Int_val(bits),
+ Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_bv32MultExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_bv32MultExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_bvLtExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_bvLtExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_bvLeExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_bvLeExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_bvGtExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_bvGtExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_bvGeExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_bvGeExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_sbvLtExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_sbvLtExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_sbvLeExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_sbvLeExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_sbvGtExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_sbvGtExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_sbvGeExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_sbvGeExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_bvUMinusExpr(value vc, value e)
+{
+ CAMLparam2(vc,e);
+ CAMLreturn(alloc_Expr(vc_bvUMinusExpr(VC_val(vc),Expr_val(e))));
+}
+
+value caml_vc_bvNotExpr(value vc, value e)
+{
+ CAMLparam2(vc,e);
+ CAMLreturn(alloc_Expr(vc_bvNotExpr(VC_val(vc),Expr_val(e))));
+}
+
+value caml_vc_bvAndExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_bvAndExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_bvOrExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_bvOrExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_bvXorExpr(value vc, value e1, value e2)
+{
+ CAMLparam3(vc,e1,e2);
+ CAMLreturn(alloc_Expr(vc_bvXorExpr(VC_val(vc),Expr_val(e1),Expr_val(e2))));
+}
+
+value caml_vc_bvLeftShiftExpr(value vc, value amt, value e)
+{
+ CAMLparam3(vc,amt,e);
+ CAMLreturn(alloc_Expr(vc_bvLeftShiftExpr(VC_val(vc),Int_val(amt),
+ Expr_val(e))));
+}
+
+value caml_vc_bvRightShiftExpr(value vc, value amt, value e)
+{
+ CAMLparam3(vc,amt,e);
+ CAMLreturn(alloc_Expr(vc_bvRightShiftExpr(VC_val(vc),Int_val(amt),
+ Expr_val(e))));
+}
+
+value caml_vc_bv32LeftShiftExpr(value vc, value amt, value e)
+{
+ CAMLparam3(vc,amt,e);
+ CAMLreturn(alloc_Expr(vc_bv32LeftShiftExpr(VC_val(vc),Int_val(amt),
+ Expr_val(e))));
+}
+
+value caml_vc_bv32RightShiftExpr(value vc, value amt, value e)
+{
+ CAMLparam3(vc,amt,e);
+ CAMLreturn(alloc_Expr(vc_bv32RightShiftExpr(VC_val(vc),Int_val(amt),
+ Expr_val(e))));
+}
+
+value caml_vc_bvVar32LeftShiftExpr(value vc, value she, value e)
+{
+ CAMLparam3(vc,she,e);
+ CAMLreturn(alloc_Expr(vc_bvVar32LeftShiftExpr(VC_val(vc),Expr_val(she),
+ Expr_val(e))));
+}
+
+value caml_vc_bvVar32RightShiftExpr(value vc, value she, value e)
+{
+ CAMLparam3(vc,she,e);
+ CAMLreturn(alloc_Expr(vc_bvVar32RightShiftExpr(VC_val(vc),Expr_val(she),
+ Expr_val(e))));
+}
+
+value caml_vc_bvVar32DivByPowOfTwoExpr(value vc, value e, value rhs)
+{
+ CAMLparam3(vc,e,rhs);
+ CAMLreturn(alloc_Expr(vc_bvVar32DivByPowOfTwoExpr(VC_val(vc),Expr_val(e),
+ Expr_val(rhs))));
+}
+
+value caml_vc_bvExtract(value vc, value e, value hi, value lo)
+{
+ CAMLparam4(vc,e,hi,lo);
+ CAMLreturn(alloc_Expr(vc_bvExtract(VC_val(vc),Expr_val(e),Int_val(hi),
+ Int_val(lo))));
+}
+
+value caml_vc_bvBoolExtract(value vc, value e, value b)
+{
+ CAMLparam3(vc,e,b);
+ CAMLreturn(alloc_Expr(vc_bvBoolExtract(VC_val(vc),Expr_val(e),Int_val(b))));
+}
+
+value caml_vc_bvSignExtend(value vc, value e, value nb)
+{
+ CAMLparam3(vc,e,nb);
+ CAMLreturn(alloc_Expr(vc_bvSignExtend(VC_val(vc),Expr_val(e),Int_val(nb))));
+}
+
+value caml_vc_bvCreateMemoryArray(value vc, value name)
+{
+ CAMLparam2(vc,name);
+ CAMLreturn(alloc_Expr(vc_bvCreateMemoryArray(VC_val(vc),String_val(name))));
+}
+
+value caml_vc_bvReadMemoryArray(value vc, value arr, value b, value num)
+{
+ CAMLparam4(vc,arr,b,num);
+ CAMLreturn(alloc_Expr(vc_bvReadMemoryArray(VC_val(vc), Expr_val(arr),
+ Expr_val(b), Int_val(num))));
+}
+
+value caml_vc_bvWriteToMemoryArray(value vc, value arr, value bi,
+ value e, value num)
+{
+ CAMLparam5(vc,arr,bi,e,num);
+ CAMLreturn(alloc_Expr(vc_bvWriteToMemoryArray(VC_val(vc),Expr_val(arr),
+ Expr_val(bi),Expr_val(e),
+ Int_val(num))));
+}
+
+// XXX
+// Expr vc_bvConstExprFromLL(VC vc, int n_bits, unsigned long long value)
--- /dev/null
+
+
+module C = Cvcl
+
+let test () =
+ let flags = C.createFlags () in
+ let vc = C.createVC flags in
+ let x = C.varExpr vc "x" (C.intType vc) in
+ let y = C.varExpr vc "y" (C.intType vc) in
+ let xpy = C.plusExpr vc x y in
+ let xpygtten = C.gtExpr vc xpy (C.ratExpr vc 10 1) in
+ let neg = C.notExpr vc xpygtten in
+ if C.query vc neg <> 1 then
+ let ces = C.getCounterExample vc in
+ List.iter (C.printExpr vc) ces
+ else
+ print_string "Satisfiable"
+
+
+let _ = test ();
+
+
--- /dev/null
+
+(*
+ * solverInterface.ml
+ *
+ * This is the interface of cvcl provided to the Deputy optimizer
+ *
+ *)
+
+open Pretty
+
+module E = Errormsg
+module C = Cvcl
+module D = Dsolverfront
+
+exception NYI of string
+
+let is_real = true
+
+let getCounterExample vc () =
+ let el = C.getCounterExample vc in
+ List.fold_left (fun l e ->
+ C.printExpr vc e;
+ if not(C.isEq e) then begin
+ ignore(E.log "SI.getCounterExample: not an equality\n");
+ l
+ end else begin
+ (*ignore(E.log "SI.getCounterExample: %s is a %s, and %s is a %s\n"
+ (C.exprString (C.getChild e 0))
+ (exprKindString vc (C.getChild e 0))
+ (C.exprString (C.getChild e 1))
+ (exprKindString vc (C.getChild e 1)));*)
+ (C.exprString (C.getChild e 0), C.getInt (C.getChild e 1)) :: l
+ end)
+ [] el
+
+let isValid vc e : (bool * (string * int) list) =
+ ignore(E.log "Checking: %s\n" (C.exprString e));
+ C.push vc;
+ let r = C.query vc e in
+ let ce = if not r then getCounterExample vc () else [] in
+ C.pop vc;
+ ignore(E.log "Returned: %s\n" (if r then "valid" else "not valid"));
+ (r, ce)
+
+let isValidWithAssumptions vc al e : (bool * (string * int) list) =
+ ignore(E.log "Checking: %s with assuptions\n" (C.exprString e));
+ List.iter (fun a -> ignore(E.log "\t%s\n" (C.exprString a))) al;
+ C.push vc;
+ List.iter (C.assertFormula vc) al;
+ let r = C.query vc e in
+ ignore(E.log "Returned: %s\n" (if r then "valid" else "not valid"));
+ let ce = if not r then getCounterExample vc () else [] in
+ C.pop vc;
+ (r, ce)
+
+
+let cvcl_bv_translator vc =
+{
+ D.mkTrue = (fun () -> C.trueExpr vc);
+ D.mkFalse = (fun () -> C.falseExpr vc);
+
+ D.mkAnd = C.andExpr vc;
+ D.mkOr = C.orExpr vc;
+ D.mkNot = C.notExpr vc;
+ D.mkIte = C.iteExpr vc;
+ D.mkImp = C.impliesExpr vc;
+
+ D.mkEq = C.eqExpr vc;
+ D.mkNe = (fun e1 e2 -> C.notExpr vc (C.eqExpr vc e1 e2));
+ D.mkLt = C.sbvLtExpr vc;
+ D.mkLe = C.sbvLeExpr vc;
+ D.mkGt = C.sbvGtExpr vc;
+ D.mkGe = C.sbvGeExpr vc;
+
+ D.mkPlus = C.bv32PlusExpr vc;
+ D.mkTimes = C.bv32MultExpr vc;
+ D.mkMinus = C.bv32MinusExpr vc;
+ D.mkDiv = (fun _ _ -> raise(NYI "mkDiv"));
+ D.mkMod = (fun _ _ -> raise(NYI "mkMod"));
+ D.mkLShift = C.bvVar32LeftShiftExpr vc;
+ D.mkRShift = C.bvVar32RightShiftExpr vc;
+ D.mkBAnd = C.bvAndExpr vc;
+ D.mkBXor = C.bvXorExpr vc;
+ D.mkBOr = C.bvOrExpr vc;
+
+ D.mkNeg = C.bvUMinusExpr vc;
+ D.mkCompl = C.bvXorExpr vc (C.bv32ConstExprFromInt vc 0);
+
+ D.mkVar = (fun s -> C.varExpr vc s (C.bv32Type vc));
+ D.mkConst = C.bv32ConstExprFromInt vc;
+
+ D.isValidWithAssumptions = isValidWithAssumptions vc;
+ D.isValid = isValid vc;
+}
+
+let andExpr vc e1 e2 =
+ if not(C.compare_exprs e1 (C.falseExpr vc)) ||
+ not(C.compare_exprs e2 (C.falseExpr vc))
+ then C.falseExpr vc
+ else if not(C.compare_exprs e1 (C.trueExpr vc))
+ then e2
+ else if not(C.compare_exprs e2 (C.trueExpr vc))
+ then e1
+ else C.andExpr vc e1 e2
+
+let orExpr vc e1 e2 =
+ if not(C.compare_exprs e1 (C.falseExpr vc)) ||
+ not(C.compare_exprs e2 (C.falseExpr vc))
+ then C.trueExpr vc
+ else if not(C.compare_exprs e1 (C.falseExpr vc))
+ then e2
+ else if not(C.compare_exprs e2 (C.falseExpr vc))
+ then e1
+ else C.orExpr vc e1 e2
+
+let notExpr vc e =
+ if not(C.compare_exprs e (C.falseExpr vc))
+ then C.trueExpr vc
+ else if not(C.compare_exprs e (C.trueExpr vc))
+ then C.falseExpr vc
+ else C.notExpr vc e
+
+let iteExpr vc e1 e2 e3 =
+ if not(C.compare_exprs e1 (C.trueExpr vc))
+ then e2
+ else if not(C.compare_exprs e1 (C.falseExpr vc))
+ then e3
+ else C.iteExpr vc e1 e2 e3
+
+let impliesExpr vc e1 e2 =
+ if not(C.compare_exprs e1 (C.trueExpr vc))
+ then e2
+ else if not(C.compare_exprs e1 (C.falseExpr vc))
+ then C.trueExpr vc
+ else C.impliesExpr vc e1 e2
+
+
+let eqExpr vc e1 e2 =
+ if C.isConst e1 && C.isConst e2 then
+ let e1 = C.getInt e1 in
+ let e2 = C.getInt e2 in
+ if e1 = e2
+ then C.trueExpr vc
+ else C.falseExpr vc
+ else C.eqExpr vc e1 e2
+
+let neExpr vc e1 e2 =
+ if C.isConst e1 && C.isConst e2 then
+ let e1 = C.getInt e1 in
+ let e2 = C.getInt e2 in
+ if not(e1 = e2)
+ then C.trueExpr vc
+ else C.falseExpr vc
+ else C.notExpr vc (C.eqExpr vc e1 e2)
+
+let ltExpr vc e1 e2 =
+ if C.isConst e1 && C.isConst e2 then
+ let e1 = C.getInt e1 in
+ let e2 = C.getInt e2 in
+ if e1 < e2
+ then C.trueExpr vc
+ else C.falseExpr vc
+ else C.ltExpr vc e1 e2
+
+let leExpr vc e1 e2 =
+ if C.isConst e1 && C.isConst e2 then
+ let e1 = C.getInt e1 in
+ let e2 = C.getInt e2 in
+ if e1 <= e2
+ then C.trueExpr vc
+ else C.falseExpr vc
+ else C.leExpr vc e1 e2
+
+let gtExpr vc e1 e2 =
+ if C.isConst e1 && C.isConst e2 then
+ let e1 = C.getInt e1 in
+ let e2 = C.getInt e2 in
+ if e1 > e2
+ then C.trueExpr vc
+ else C.falseExpr vc
+ else C.gtExpr vc e1 e2
+
+let geExpr vc e1 e2 =
+ if C.isConst e1 && C.isConst e2 then
+ let e1 = C.getInt e1 in
+ let e2 = C.getInt e2 in
+ if e1 >= e2
+ then C.trueExpr vc
+ else C.falseExpr vc
+ else C.geExpr vc e1 e2
+
+let plusExpr vc e1 e2 =
+ if C.isConst e1 && C.isConst e2 then
+ let e1 = C.getInt e1 in
+ let e2 = C.getInt e2 in
+ C.ratExpr vc (e1 + e2) 1
+ else C.plusExpr vc e1 e2
+
+let timesExpr vc e1 e2 =
+ if C.isConst e1 && C.isConst e2 then
+ let e1 = C.getInt e1 in
+ let e2 = C.getInt e2 in
+ C.ratExpr vc (e1 * e2) 1
+ else C.multExpr vc e1 e2
+
+let minusExpr vc e1 e2 =
+ if C.isConst e1 && C.isConst e2 then
+ let e1 = C.getInt e1 in
+ let e2 = C.getInt e2 in
+ C.ratExpr vc (e1 - e2) 1
+ else C.minusExpr vc e1 e2
+
+let divideExpr vc e1 e2 =
+ if C.isConst e1 && C.isConst e2 then
+ let e1 = C.getInt e1 in
+ let e2 = C.getInt e2 in
+ C.ratExpr vc (e1 / e2) 1
+ else C.divideExpr vc e1 e2
+
+let uminusExpr vc e =
+ if C.isConst e then
+ let e = C.getInt e in
+ C.ratExpr vc (-e) 1
+ else C.uminusExpr vc e
+
+let exprKindString vc e =
+ C.getKindString vc (C.getKind e)
+
+let cvcl_translator vc =
+{
+ D.mkTrue = (fun () -> C.trueExpr vc);
+ D.mkFalse = (fun () -> C.falseExpr vc);
+
+ D.mkAnd = andExpr vc;
+ D.mkOr = orExpr vc;
+ D.mkNot = notExpr vc;
+ D.mkIte = iteExpr vc;
+ D.mkImp = impliesExpr vc;
+
+ D.mkEq = eqExpr vc;
+ D.mkNe = neExpr vc;
+ D.mkLt = ltExpr vc;
+ D.mkLe = leExpr vc;
+ D.mkGt = gtExpr vc;
+ D.mkGe = geExpr vc;
+
+ D.mkPlus = plusExpr vc;
+ D.mkTimes = timesExpr vc;
+ D.mkMinus = minusExpr vc;
+ D.mkDiv = divideExpr vc;
+ D.mkMod = (fun _ _ -> raise(NYI "mkMod"));
+ D.mkLShift = (fun _ _ -> raise(NYI "mkLShift"));
+ D.mkRShift = (fun _ _ -> raise(NYI "mkRShift"));
+ D.mkBAnd = (fun _ _ -> raise(NYI "mkBAnd"));
+ D.mkBXor = (fun _ _ -> raise(NYI "mkBXor"));
+ D.mkBOr = (fun _ _ -> raise(NYI "mkBOr"));
+
+ D.mkNeg = uminusExpr vc;
+ D.mkCompl = (fun _ -> raise(NYI "mkCompl"));
+
+ D.mkVar = (fun s -> C.varExpr vc s (C.intType vc));
+ D.mkConst = (fun i -> C.ratExpr vc i 1);
+
+ D.isValidWithAssumptions = isValidWithAssumptions vc;
+ D.isValid = isValid vc;
+}
+
+let curVC = ref None
+
+let getBVTranslator rl =
+ match !curVC with
+ | Some vc -> cvcl_bv_translator vc
+ | None -> begin
+ let flags = C.createFlags () in
+ let vc = C.createVC flags in
+ C.setResourceLimit vc rl;
+ curVC := (Some vc);
+ cvcl_bv_translator vc
+ end
+
+(* rl is the resource limit for the solver if supported.
+ * rl = 0 => no limits
+ * rl = 1 => don't use this.
+ * rl >= 2 => OK *)
+let getTranslator (rl : int) =
+ match !curVC with
+ | Some vc -> cvcl_translator vc
+ | None -> begin
+ let flags = C.createFlags () in
+ let vc = C.createVC flags in
+ C.setResourceLimit vc rl;
+ curVC := (Some vc);
+ cvcl_translator vc
+ end
+
+(* This is the interface exposed to doptim.ml *)
+(* check if (e1 op e2) is valid in state s *)
+(*
+let valid s op e1 e2 =
+ ignore(E.log "calling the solver: %a <? %a\n" D.Can.d_t e1 D.Can.d_t e2);
+ try
+ let r = D.valid (getTranslator()) s op e1 e2 in
+ ignore(E.log "the solver returned!\n");
+ r
+ with NYI s ->
+ ignore(E.log "the solver raised an exception: %s\n" s);
+ false
+*)
--- /dev/null
+(*
+ * solverInterface.ml
+ *
+ * This is the interface of a null solver provided to the Deputy optimizer
+ *
+ *)
+
+exception NYI of string
+
+let is_real = false
+
+let getTranslator (rl : int) = raise(NYI "null solver")
+
+(* This is the interface exposed to doptim.ml *)
+(* check if (e1 op e2) is valid in state s *)
+let valid s op e1 e2 = raise(NYI "null solver")
+
--- /dev/null
+# Makefile for yices_sover_test.ml
+#
+
+
+ifndef ARCHOS
+ ARCHOS = x86_LINUX
+endif
+
+all:
+ $(MAKE) yices_solver_test
+ $(MAKE) yices_solver_test NATIVECAML=1
+
+#
+# If you've done a 'make install' with cvc lite, then
+# the defaults below should work. Otherwise setting the
+# environment variables as below should work.
+#
+# for example on a x86 linux machine
+# YICESLIB = /path/to/yices/lib
+# YICESINC = /path/to/yices/include
+#
+ifndef YICESLIB
+ CVCLLIB = /usr/local/lib
+endif
+ifndef YICESINC
+ CVCLINC = /usr/local/include
+endif
+ifndef OCAMLINC
+ OCAMLINC = /usr/lib/ocaml
+endif
+
+OBJDIR = obj/$(ARCHOS)
+DEPENDDIR = obj/.depend
+
+
+SOURCEDIRS = .
+
+MODULES = yices yices_solver_test
+
+COMPILEFLAGS =
+LINKFLAGS =
+
+
+ENDLINKFLAGS = -cclib -L$(YICESLIB) -cclib -lyices -cclib -lstdc++ -cclib -lgmp
+
+CAML_CFLAGS += -ccopt -I$(OCAMLINC) -ccopt -I$(YICESINC)
+
+include ../../../../cil/ocamlutil/Makefile.ocaml
+
+PROJECT_EXECUTABLE = $(OBJDIR)/yices_test$(EXE)
+PROJECT_MODULES = $(MODULES)
+
+PROJECT_CMODULES = yices_ocaml_wrappers
+
+PROJECT_LIBS = unix str
+
+$(PROJECT_EXECUTABLE) : $(PROJECT_MODULES:%=$(OBJDIR)/%.$(CMO)) \
+ $(PROJECT_CMODULES:%=$(OBJDIR)/%.$(CMC))
+ @$(NARRATIVE) "Linking $(COMPILETOWHAT) $@ $(LINKMSG)"
+ $(AT)$(CAMLLINK) -verbose -o $@ \
+ $(PROJECT_LIBS:%=%.$(CMXA)) \
+ $(PROJECT_MODULES:%=$(OBJDIR)/%.$(CMO)) \
+ $(PROJECT_CMODULES:%=$(OBJDIR)/%.$(CMC)) \
+ $(ENDLINKFLAGS)
+
+yices_solver_test: $(PROJECT_EXECUTABLE)
+
+clean:
+ rm -f $(OBJDIR)/*.* $(DEPENDDIR)/*.*
--- /dev/null
+(*
+ * solverInterface.ml
+ *
+ * This is the interface of yices provided to the Deputy optimizer
+ *
+ *)
+
+open Pretty
+
+module E = Errormsg
+module Y = Yices
+module D = Dsolverfront
+
+exception NYI of string
+
+let is_real = true
+
+let andExpr yc e1 e2 =
+ Y.mk_and yc [e1;e2] 2
+
+let orExpr yc e1 e2 =
+ Y.mk_or yc [e1;e2] 2
+
+let notExpr yc e1 =
+ Y.mk_not yc e1
+
+let iteExpr yc e1 e2 e3 =
+ Y.mk_ite yc e1 e2 e3
+
+let impliesExpr yc e1 e2 =
+ orExpr yc (notExpr yc e1) e2
+
+let eqExpr yc e1 e2 =
+ Y.mk_eq yc e1 e2
+
+let neExpr yc e1 e2 =
+ Y.mk_diseq yc e1 e2
+
+let ltExpr yc e1 e2 =
+ Y.mk_lt yc e1 e2
+
+let leExpr yc e1 e2 =
+ Y.mk_le yc e1 e2
+
+let gtExpr yc e1 e2 =
+ Y.mk_gt yc e1 e2
+
+let geExpr yc e1 e2 =
+ Y.mk_ge yc e1 e2
+
+let plusExpr yc e1 e2 =
+ Y.mk_sum yc [e1;e2] 2
+
+let minusExpr yc e1 e2 =
+ Y.mk_sub yc [e1;e2] 2
+
+let timesExpr yc e1 e2 =
+ Y.mk_mul yc [e1;e2] 2
+
+let uminusExpr yc e =
+ Y.mk_sub yc [(Y.mk_num yc 0);e] 2
+
+let varExpr yc name =
+ match Y.get_var_decl_from_name yc name with
+ | [] -> begin
+ Y.mk_var_from_decl yc (Y.mk_var_decl yc name (Y.mk_type yc "int"))
+ end
+ | vd :: _ -> Y.mk_var_from_decl yc vd
+
+let isValidWithAssumptions yc el e : (bool * (string * int) list) =
+ Y.push_context yc;
+ List.iter (Y.assert_expr yc) el;
+ Y.assert_expr yc (notExpr yc e);
+ Y.dump_context yc;
+ match Y.check_context yc with
+ | 1 -> begin
+ ignore(E.log "SI: valid\n");
+ let m = Y.get_model yc in
+ match m with
+ | [] -> begin
+ ignore(E.log "SI: model not available\n");
+ (false, [])
+ end
+ | m :: _ -> begin
+ ignore(E.log "SI: model available:\n");
+ (*Y.display_model m;*)
+ let it = Y.create_var_decl_iterator yc in
+ let rec loop sil =
+ if Y.iterator_has_next it then begin
+ let vd = Y.iterator_next it in
+ let (res,v) = Y.get_int_value m vd in
+ if res then begin
+ let name = Y.get_var_decl_name vd in
+ ignore(E.log "SI: model: %s -> %d\n" name v);
+ loop ((name,v)::sil)
+ end else begin
+ let name = Y.get_var_decl_name vd in
+ ignore(E.log "SI: model: %s -> undef\n" name);
+ loop sil
+ end
+ end else begin
+ ignore(E.log "SI:model: done\n");
+ sil
+ end
+ in
+ let sil = loop [] in
+ Y.del_iterator it;
+ Y.pop_context yc;
+ (false, sil)
+ end
+ end
+ | 0 -> begin
+ ignore(E.log "SI: invalid\n");
+ Y.pop_context yc;
+ (true, [])
+ end
+ | -1 -> begin
+ ignore(E.log "SI: unknown\n");
+ Y.pop_context yc;
+ (false, [])
+ end
+ | _ -> begin
+ ignore(E.log "SI: error\n");
+ Y.pop_context yc;
+ (false, [])
+ end
+
+let isValid yc e = isValidWithAssumptions yc [] e
+
+let yices_translator yc =
+{
+ D.mkTrue = (fun () -> Y.mk_true yc);
+ D.mkFalse = (fun () -> Y.mk_false yc);
+
+ D.mkAnd = andExpr yc;
+ D.mkOr = orExpr yc;
+ D.mkNot = notExpr yc;
+ D.mkIte = iteExpr yc;
+ D.mkImp = impliesExpr yc;
+
+ D.mkEq = eqExpr yc;
+ D.mkNe = neExpr yc;
+ D.mkLt = ltExpr yc;
+ D.mkLe = leExpr yc;
+ D.mkGt = gtExpr yc;
+ D.mkGe = geExpr yc;
+
+ D.mkPlus = plusExpr yc;
+ D.mkTimes = timesExpr yc;
+ D.mkMinus = minusExpr yc;
+ D.mkDiv = (fun _ _ -> raise(NYI "mkDiv"));
+ D.mkMod = (fun _ _ -> raise(NYI "mkMod"));
+ D.mkLShift = (fun _ _ -> raise(NYI "mkLShift"));
+ D.mkRShift = (fun _ _ -> raise(NYI "mkRShift"));
+ D.mkBAnd = (fun _ _ -> raise(NYI "mkBAnd"));
+ D.mkBXor = (fun _ _ -> raise(NYI "mkBXor"));
+ D.mkBOr = (fun _ _ -> raise(NYI "mkBOr"));
+
+ D.mkNeg = uminusExpr yc;
+ D.mkCompl = (fun _ -> raise(NYI "mkCompl"));
+
+ D.mkVar = varExpr yc;
+ D.mkConst = (fun i -> Y.mk_num yc i);
+
+ D.isValidWithAssumptions = isValidWithAssumptions yc;
+ D.isValid = isValid yc;
+}
+
+let curYC = ref None
+
+let getTranslator (rl : int) =
+ match !curYC with
+ | Some yc -> yices_translator yc
+ | None -> begin
+ Y.set_arith_only true;
+ Y.enable_log_file "yices.log.txt";
+ let yc = Y.mk_context () in
+ curYC := (Some yc);
+ yices_translator yc
+ end
+
+let valid s op e1 e2 = raise(NYI "valid")
--- /dev/null
+(*
+ * yices.ml
+ *
+ * This file contains external declarations for
+ * calls into yices.
+ *
+ *)
+
+type yices_expr
+type yices_type
+type yices_var_decl
+type yices_context
+type yices_model
+type yices_var_decl_iterator
+type yices_ast
+
+
+(*
+ * Set some options
+ *)
+external set_verbosity : int -> unit = "caml_yices_set_verbosity"
+external version : unit -> string = "caml_yices_version"
+external set_max_num_conflicts_in_maxsat_iteration : int -> unit =
+ "caml_yices_set_max_num_conflicts_in_maxsat_iteration"
+external enable_type_checker : bool -> unit = "caml_yices_enable_type_checker"
+external set_max_num_iterations_in_maxsat : int -> unit =
+ "caml_yices_set_max_num_iterations_in_maxsat"
+external set_maxsat_initial_cost : int64 -> unit =
+ "caml_yices_set_maxsat_initial_cost"
+external set_arith_only : bool -> unit = "caml_yices_set_arith_only"
+external enable_log_file : string -> unit = "caml_yices_enable_log_file"
+
+(*
+ * Context manipulation
+ *)
+external mk_context : unit -> yices_context = "caml_yices_mk_context"
+external del_context : yices_context -> unit = "caml_yices_del_context"
+external reset_context : yices_context -> unit = "caml_yices_reset"
+external dump_context : yices_context -> unit = "caml_yices_dump_context"
+external push_context : yices_context -> unit = "caml_yices_push"
+external pop_context : yices_context -> unit = "caml_yices_pop"
+external assert_expr : yices_context -> yices_expr -> unit =
+ "caml_yices_assert"
+external assert_expr_weighted : yices_context -> yices_expr -> int64 -> int =
+ "caml_yices_assert_weighted"
+external assert_expr_retractable : yices_context -> yices_expr -> int =
+ "caml_yices_assert_retractable"
+external retract_expr : yices_context -> int -> unit = "caml_yices_retract"
+external inconsistent_context : yices_context -> bool = "caml_yices_inconsistent"
+external check_context : yices_context -> int = "caml_yices_check"
+external find_weighted_model : yices_context -> int -> int =
+ "caml_yices_find_weighted_model"
+external max_sat : yices_context -> int = "caml_yices_max_sat"
+external max_sat_cost_leq : yices_context -> int64 -> int =
+ "caml_yices_max_sat_cost_leq"
+external get_model : yices_context -> yices_model list = "caml_yices_get_model"
+
+(*
+ * Functions for Models
+ *)
+external get_value : yices_model -> yices_var_decl -> int =
+ "caml_yices_get_value"
+external get_int_value : yices_model -> yices_var_decl -> (bool * int) =
+ "caml_yices_get_int_value"
+external get_arith_value : yices_model -> yices_var_decl -> (bool * int * int) =
+ "caml_yices_get_arith_value"
+external get_double_value : yices_model -> yices_var_decl -> (bool * float) =
+ "caml_yices_get_double_value"
+external get_bitvector_value : yices_model -> yices_var_decl -> int -> (bool * int array) =
+ "caml_yices_get_bitvector_value"
+external get_assertion_value : yices_model -> int -> int =
+ "caml_yices_get_assertion_value"
+external display_model : yices_model -> unit = "caml_yices_display_model"
+external get_cost : yices_model -> int64 = "caml_yices_get_cost"
+external get_cost_as_double : yices_model -> float =
+ "caml_yices_get_cost_as_double"
+
+(*
+ * Expression Building
+ *)
+external mk_true : yices_context -> yices_expr = "caml_yices_mk_true"
+external mk_false : yices_context -> yices_expr = "caml_yices_mk_false"
+external mk_bool_var : yices_context -> string -> yices_expr =
+ "caml_yices_mk_bool_var"
+external mk_fresh_bool_var : yices_context -> yices_expr =
+ "caml_yices_mk_fresh_bool_var"
+external get_var_decl : yices_expr -> yices_var_decl = "caml_yices_get_var_decl"
+external mk_bool_var_decl : yices_context -> string -> yices_var_decl =
+ "caml_yices_mk_bool_var_decl"
+external get_var_decl_name : yices_var_decl -> string =
+ "caml_yices_get_var_decl_name"
+external mk_bool_var_from_decl : yices_context -> yices_var_decl -> yices_expr =
+ "caml_yices_mk_bool_var_from_decl"
+external mk_or : yices_context -> yices_expr list -> int -> yices_expr =
+ "caml_yices_mk_or"
+external mk_and : yices_context -> yices_expr list -> int -> yices_expr =
+ "caml_yices_mk_and"
+external mk_eq : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_mk_eq"
+external mk_diseq : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_mk_diseq"
+external mk_ite : yices_context -> yices_expr -> yices_expr -> yices_expr ->
+ yices_expr = "caml_yices_mk_ite"
+external mk_not : yices_context -> yices_expr -> yices_expr =
+ "caml_yices_mk_not"
+external create_var_decl_iterator : yices_context -> yices_var_decl_iterator =
+ "caml_yices_create_var_decl_iterator"
+external iterator_has_next : yices_var_decl_iterator -> bool =
+ "caml_yices_iterator_has_next"
+external iterator_next : yices_var_decl_iterator -> yices_var_decl =
+ "caml_yices_iterator_next"
+external iterator_reset : yices_var_decl_iterator -> unit =
+ "caml_yices_iterator_reset"
+external del_iterator : yices_var_decl_iterator -> unit =
+ "caml_yices_del_iterator"
+external mk_type : yices_context -> string -> yices_type = "caml_yices_mk_type"
+external mk_bv_type : yices_context -> int -> yices_type =
+ "caml_yices_mk_bitvector_type"
+external mk_var_decl : yices_context -> string -> yices_type -> yices_var_decl =
+ "caml_yices_mk_var_decl"
+external mk_var_from_decl : yices_context -> yices_var_decl -> yices_expr =
+ "caml_yices_mk_var_from_decl"
+external get_var_decl_from_name : yices_context -> string -> yices_var_decl list =
+ "caml_yices_get_var_decl_from_name"
+external mk_num : yices_context -> int -> yices_expr = "caml_yices_mk_num"
+external mk_num_from_string : yices_context -> string -> yices_expr =
+ "caml_yices_mk_num_from_string"
+external mk_sum : yices_context -> yices_expr list -> int -> yices_expr =
+ "caml_yices_mk_sum"
+external mk_sub : yices_context -> yices_expr list -> int -> yices_expr =
+ "caml_yices_mk_sub"
+external mk_mul : yices_context -> yices_expr list -> int -> yices_expr =
+ "caml_yices_mk_mul"
+external mk_lt : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_mk_lt"
+external mk_le : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_mk_le"
+external mk_gt : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_mk_gt"
+external mk_ge : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_mk_ge"
+
+(*
+ * Bit-vector expression construction
+ *)
+external mk_bv_constant : yices_context -> int -> int -> yices_expr =
+ "caml_yices_mk_bv_constant"
+external mk_bv_add : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_mk_bv_add"
+external mk_bv_sub : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_mk_bv_sub"
+external mk_bv_mul : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_mk_bv_mul"
+external mk_bv_minus : yices_context -> yices_expr -> yices_expr =
+ "caml_yices_mk_bv_minus"
+external mk_bv_concat : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_mk_bv_concat"
+external mk_bv_and : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_mk_bv_and"
+external mk_bv_or : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_mk_bv_or"
+external mk_bv_xor : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_mk_bv_xor"
+external mk_bv_not : yices_context -> yices_expr -> yices_expr =
+ "caml_yices_mk_bv_not"
+external mk_bv_extract : yices_context -> int -> int -> yices_expr =
+ "caml_yices_mk_bv_extract"
+external mk_bv_sign_extend : yices_context -> yices_expr -> int -> yices_expr =
+ "caml_yices_mk_bv_sign_extend"
+external mk_bv_shift_left0 : yices_context -> yices_expr -> int -> yices_expr =
+ "caml_yices_bv_shift_left0"
+external mk_bv_shift_left1 : yices_context -> yices_expr -> int -> yices_expr =
+ "caml_yices_bv_shift_left1"
+external mk_bv_shift_right0 : yices_context -> yices_expr -> int -> yices_expr =
+ "caml_yices_bv_shift_right0"
+external mk_bv_shift_right1 : yices_context -> yices_expr -> int -> yices_expr =
+ "caml_yices_bv_shift_right1"
+external mk_bv_lt : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_bv_lt"
+external mk_bv_le : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_bv_le"
+external mk_bv_gt : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_bv_gt"
+external mk_bv_ge : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_bv_ge"
+external mk_bv_slt : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_bv_slt"
+external mk_bv_sle : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_bv_sle"
+external mk_bv_sgt : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_bv_sgt"
+external mk_bv_sge : yices_context -> yices_expr -> yices_expr -> yices_expr =
+ "caml_yices_bv_sge"
+
+external pp_expr : yices_expr -> unit = "caml_yices_pp_expr"
--- /dev/null
+/*
+
+yices_ocaml_wrappers.c
+
+This file contains wrappers for the C interface to yices
+that are callable from ocaml code.
+
+Search for XXX to find unimplemented things
+
+*/
+
+#include <yices_c.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+
+/************************************************************
+
+Structures that tell the ocaml runtime how to deal with
+things of abstract types that we will ll be passing it.
+
+************************************************************/
+
+/* Encapsulation of yices_expr
+ as Caml custom blocks. */
+static struct custom_operations yices_expr_ops = {
+ "Yices.yices_expr",
+ custom_finalize_default,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+/* Encapsulation of yices_type
+ as Caml custom blocks. */
+static struct custom_operations yices_type_ops = {
+ "Yices.yices_type",
+ custom_finalize_default,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+/* Encapsulation of yices_var_decl
+ as Caml custom blocks. */
+static struct custom_operations yices_var_decl_ops = {
+ "Yices.yices_var_decl",
+ custom_finalize_default,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+/* Encapsulation of yices_context
+ as Caml custom blocks. */
+static struct custom_operations yices_context_ops = {
+ "Yices.yices_context",
+ custom_finalize_default,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+/* Encapsulation of yices_model
+ as Caml custom blocks. */
+static struct custom_operations yices_model_ops = {
+ "Yices.yices_model",
+ custom_finalize_default,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+/* Encapsulation of yices_var_decl_iterator
+ as Caml custom blocks. */
+static struct custom_operations yices_var_decl_iterator_ops = {
+ "Yices.yices_var_decl_iterator",
+ custom_finalize_default,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+
+/************************************************************
+
+Functions for wrapping and unwrapping ocaml values for the
+abstract types above.
+
+************************************************************/
+
+/* Accessing the relevant part of a Caml custom block */
+#define yices_expr_val(v) (*((yices_expr *) Data_custom_val(v)))
+#define yices_type_val(v) (*((yices_type *) Data_custom_val(v)))
+#define yices_var_decl_val(v) (*((yices_var_decl *) Data_custom_val(v)))
+#define yices_context_val(v) (*((yices_context *) Data_custom_val(v)))
+#define yices_model_val(v) (*((yices_model *) Data_custom_val(v)))
+#define yices_var_decl_iterator_val(v) (*((yices_var_decl_iterator *) Data_custom_val(v)))
+
+/* Allocating a Caml custom block to hold the given CVCL structure */
+static value alloc_yices_expr(yices_expr ye)
+{
+ value v = alloc_custom(&yices_expr_ops, sizeof(yices_expr), 0, 1);
+ yices_expr_val(v) = ye;
+ return v;
+}
+
+static value alloc_yices_type(yices_type t)
+{
+ value v = alloc_custom(&yices_type_ops, sizeof(yices_type), 0, 1);
+ yices_type_val(v) = t;
+ return v;
+}
+
+static value alloc_yices_var_decl(yices_var_decl vd)
+{
+ value v = alloc_custom(&yices_var_decl_ops, sizeof(yices_var_decl), 0, 1);
+ yices_var_decl_val(v) = vd;
+ return v;
+}
+
+static value alloc_yices_context(yices_context ctxt)
+{
+ value v = alloc_custom(&yices_context_ops, sizeof(yices_context), 0, 1);
+ yices_context_val(v) = ctxt;
+ return v;
+}
+
+static value alloc_yices_model(yices_model m)
+{
+ value v = alloc_custom(&yices_model_ops, sizeof(yices_model), 0, 1);
+ yices_model_val(v) = m;
+ return v;
+}
+
+static value alloc_yices_var_decl_iterator(yices_var_decl_iterator vdi)
+{
+ value v = alloc_custom(&yices_var_decl_iterator_ops,
+ sizeof(yices_var_decl_iterator), 0, 1);
+ yices_var_decl_iterator_val(v) = vdi;
+ return v;
+}
+
+
+/************************************************************
+
+Wrappers
+
+************************************************************/
+
+value caml_yices_set_verbosity(value i)
+{
+ CAMLparam1(i);
+ yices_set_verbosity(Int_val(i));
+ CAMLreturn(Val_unit);
+}
+
+value caml_yices_version(value unit)
+{
+ CAMLparam1(unit);
+ CAMLlocal1(r);
+ r = caml_copy_string(yices_version());
+ CAMLreturn(r);
+}
+
+value caml_yices_set_max_num_conflicts_in_maxsat_iteration(value n)
+{
+ CAMLparam1(n);
+ yices_set_max_num_conflicts_in_maxsat_iteration(Int_val(n));
+ CAMLreturn(Val_unit);
+}
+
+value caml_yices_enable_type_checker(value flag)
+{
+ CAMLparam1(flag);
+ yices_enable_type_checker(Int_val(flag));
+ CAMLreturn(Val_unit);
+}
+
+value caml_yices_set_max_num_iterations_in_maxsat(value n)
+{
+ CAMLparam1(n);
+ yices_set_max_num_iterations_in_maxsat(Int_val(n));
+ CAMLreturn(Val_unit);
+}
+
+value caml_yices_set_maxsat_initial_cost(value c)
+{
+ CAMLparam1(c);
+ yices_set_maxsat_initial_cost(Int64_val(c));
+ CAMLreturn(Val_unit);
+}
+
+value caml_yices_set_arith_only(value flag)
+{
+ CAMLparam1(flag);
+ yices_set_arith_only(Int_val(flag));
+ CAMLreturn(Val_unit);
+}
+
+value caml_yices_enable_log_file(value fname)
+{
+ CAMLparam1(fname);
+ yices_enable_log_file(String_val(fname));
+ CAMLreturn(Val_unit);
+}
+
+value caml_yices_mk_context(value unit)
+{
+ CAMLparam1(unit);
+ CAMLreturn(alloc_yices_context(yices_mk_context()));
+}
+
+value caml_yices_del_context(value yc)
+{
+ CAMLparam1(yc);
+ yices_del_context(yices_context_val(yc));
+ CAMLreturn(Val_unit);
+}
+
+value caml_yices_reset(value yc)
+{
+ CAMLparam1(yc);
+ yices_reset(yices_context_val(yc));
+ CAMLreturn(Val_unit);
+}
+
+value caml_yices_dump_context(value yc)
+{
+ CAMLparam1(yc);
+ yices_dump_context(yices_context_val(yc));
+ CAMLreturn(Val_unit);
+}
+
+value caml_yices_push(value yc)
+{
+ CAMLparam1(yc);
+ yices_push(yices_context_val(yc));
+ CAMLreturn(Val_unit);
+}
+
+value caml_yices_pop(value yc)
+{
+ CAMLparam1(yc);
+ yices_pop(yices_context_val(yc));
+ CAMLreturn(Val_unit);
+}
+
+value caml_yices_assert(value yc, value expr)
+{
+ CAMLparam2(yc, expr);
+ yices_assert(yices_context_val(yc), yices_expr_val(expr));
+ CAMLreturn(Val_unit);
+}
+
+value caml_yices_assert_weighted(value yc, value expr, value w)
+{
+ CAMLparam3(yc,expr,w);
+ CAMLreturn(Val_int(yices_assert_weighted(yices_context_val(yc),yices_expr_val(expr),
+ Int64_val(w))));
+}
+
+value caml_yices_assert_retractable(value yc, value expr)
+{
+ CAMLparam2(yc,expr);
+ CAMLreturn(Val_int(yices_assert_retractable(yices_context_val(yc),
+ yices_expr_val(expr))));
+}
+
+value caml_yices_retract(value yc, value id)
+{
+ CAMLparam2(yc, id);
+ yices_retract(yices_context_val(yc), Int_val(id));
+ CAMLreturn(Val_unit);
+}
+
+value caml_yices_inconsistent(value yc)
+{
+ CAMLparam1(yc);
+ CAMLreturn(Val_int(yices_inconsistent(yices_context_val(yc))));
+}
+
+value caml_yices_check(value yc)
+{
+ int cr = -1;
+ lbool r;
+
+ CAMLparam1(yc);
+ r = yices_check(yices_context_val(yc));
+ switch(r) {
+ case l_true: cr = 1; break;
+ case l_false: cr = 0; break;
+ case l_undef: cr = -1; break;
+ }
+
+ CAMLreturn(Val_int(cr));
+}
+
+value caml_yices_find_weighted_model(value yc, value r)
+{
+ int cr = -1;
+ lbool res;
+
+ CAMLparam2(yc,r);
+ res = yices_find_weighted_model(yices_context_val(yc), Int_val(r));
+ switch(res) {
+ case l_true: cr = 1; break;
+ case l_false: cr = 0; break;
+ case l_undef: cr = -1; break;
+ }
+
+ CAMLreturn(Int_val(cr));
+}
+
+value caml_yices_max_sat(value yc)
+{
+ int cr = -1;
+ lbool r;
+
+ CAMLparam1(yc);
+ r = yices_max_sat(yices_context_val(yc));
+ switch(r) {
+ case l_true: cr = 1; break;
+ case l_false: cr = 0; break;
+ case l_undef: cr = -1; break;
+ }
+
+ CAMLreturn(Int_val(cr));
+}
+
+value caml_yices_max_sat_cost_leq(value yc, value max)
+{
+ int cr = -1;
+ lbool r;
+
+ CAMLparam2(yc, max);
+ r = yices_max_sat_cost_leq(yices_context_val(yc),Int64_val(max));
+ switch(r) {
+ case l_true: cr = 1; break;
+ case l_false: cr = 0; break;
+ case l_undef: cr = -1; break;
+ }
+
+ CAMLreturn(Int_val(cr));
+}
+
+value caml_yices_get_model(value yc)
+{
+ yices_model m;
+
+ CAMLparam1(yc);
+ CAMLlocal1(res);
+
+ m = yices_get_model(yices_context_val(yc));
+ if( m ) {
+ res = caml_alloc_tuple(2);
+ Store_field(res, 0, alloc_yices_model(m));
+ Store_field(res, 1, Int_val(0));
+ }
+ else {
+ res = Int_val(0);
+ }
+
+ CAMLreturn(res);
+}
+
+value caml_yices_get_value(value m, value vd)
+{
+ int cr = -1;
+ lbool r;
+
+ CAMLparam2(m, vd);
+ r = yices_get_value(yices_model_val(m), yices_var_decl_val(vd));
+ switch(r) {
+ case l_true: cr = 1; break;
+ case l_false: cr = 0; break;
+ case l_undef: cr = -1; break;
+ }
+
+ CAMLreturn(Int_val(cr));
+}
+
+value caml_yices_get_int_value(value m, value vd)
+{
+ long val;
+ int res;
+
+ CAMLparam2(m, vd);
+ CAMLlocal1(r);
+ res = yices_get_int_value(yices_model_val(m), yices_var_decl_val(vd), &val);
+ r = caml_alloc_tuple(2);
+ Store_field(r, 0, Int_val(res));
+ Store_field(r, 1, Long_val(val));
+
+ CAMLreturn(r);
+}
+
+value caml_yices_get_arith_value(value m, value vd)
+{
+ long num, den;
+ int res;
+
+ CAMLparam2(m, vd);
+ CAMLlocal1(r);
+ res = yices_get_arith_value(yices_model_val(m), yices_var_decl_val(vd),
+ &num, &den);
+ r = caml_alloc_tuple(3);
+ Store_field(r, 0, Int_val(res));
+ Store_field(r, 1, Long_val(num));
+ Store_field(r, 2, Long_val(den));
+
+ CAMLreturn(r);
+}
+
+value caml_yices_get_double_value(value m, value vd)
+{
+ double val;
+ int res;
+
+ CAMLparam2(m, vd);
+ CAMLlocal1(r);
+ res = yices_get_double_value(yices_model_val(m), yices_var_decl_val(vd), &val);
+ r = caml_alloc_tuple(2);
+ Store_field(r, 0, Int_val(res));
+ Store_field(r, 1, caml_copy_double(val));
+
+ CAMLreturn(r);
+}
+
+value caml_yices_get_bitvector_value(value m, value vd, value n)
+{
+ int *bv;
+ int res;
+ int i;
+
+ CAMLparam3(m, vd, n);
+ CAMLlocal2(cbv, cr);
+ bv = (int *)malloc(Int_val(n) * sizeof(int));
+ res = yices_get_bitvector_value(yices_model_val(m), yices_var_decl_val(vd),
+ Int_val(n), bv);
+ cbv = caml_alloc_tuple(n);
+ for(i = 0; i < n; i++) {
+ Store_field(cbv, i, Int_val(bv[i]));
+ }
+ free(bv);
+ cr = caml_alloc_tuple(2);
+ Store_field(cr, 0, Int_val(res));
+ Store_field(cr, 1, cbv);
+
+ CAMLreturn(cr);
+}
+
+value caml_yices_get_assertion_value(value m, value id)
+{
+ CAMLparam2(m, id);
+ CAMLreturn(Val_int(yices_get_assertion_value(yices_model_val(m),Int_val(id))));
+}
+
+value caml_yices_display_model(value m)
+{
+ CAMLparam1(m);
+ yices_display_model(yices_model_val(m));
+ CAMLreturn(Val_unit);
+}
+
+value caml_yices_get_cost(value m)
+{
+ CAMLparam1(m);
+ CAMLreturn(caml_copy_int64(yices_get_cost(yices_model_val(m))));
+}
+
+value caml_yices_get_cost_as_double(value m)
+{
+ CAMLparam1(m);
+ CAMLreturn(caml_copy_double(yices_get_cost_as_double(yices_model_val(m))));
+}
+
+/*
+ * Expression Building
+ *
+ *
+ */
+
+value caml_yices_mk_true(value yc)
+{
+ CAMLparam1(yc);
+ CAMLreturn(alloc_yices_expr(yices_mk_true(yices_context_val(yc))));
+}
+
+value caml_yices_mk_false(value yc)
+{
+ CAMLparam1(yc);
+ CAMLreturn(alloc_yices_expr(yices_mk_false(yices_context_val(yc))));
+}
+
+value caml_yices_mk_bool_var(value yc, value name)
+{
+ CAMLparam2(yc, name);
+ CAMLreturn(alloc_yices_expr(yices_mk_bool_var(yices_context_val(yc),
+ String_val(name))));
+}
+
+value caml_yices_mk_fresh_bool_var(value yc)
+{
+ CAMLparam1(yc);
+ CAMLreturn(alloc_yices_expr(yices_mk_fresh_bool_var(yices_context_val(yc))));
+}
+
+value caml_yices_get_var_decl(value ye)
+{
+ CAMLparam1(ye);
+ CAMLreturn(alloc_yices_var_decl(yices_get_var_decl(yices_expr_val(ye))));
+}
+
+value caml_yices_mk_bool_var_decl(value yc, value name)
+{
+ CAMLparam2(yc,name);
+ CAMLreturn(alloc_yices_var_decl(yices_mk_bool_var_decl(yices_context_val(yc),
+ String_val(name))));
+}
+
+value caml_yices_get_var_decl_name(value vd)
+{
+ CAMLparam1(vd);
+ CAMLreturn(caml_copy_string(yices_get_var_decl_name(yices_var_decl_val(vd))));
+}
+
+value caml_yices_mk_bool_var_from_decl(value yc, value vd)
+{
+ CAMLparam2(yc,vd);
+ CAMLreturn(alloc_yices_expr(yices_mk_bool_var_from_decl(yices_context_val(yc),
+ yices_var_decl_val(vd))));
+}
+
+value caml_yices_mk_or(value yc, value args, value n)
+{
+ yices_expr *cargs;
+ yices_expr res;
+ int i = 0;
+
+ CAMLparam3(yc, args, n);
+ CAMLlocal1(tmp);
+
+ cargs = (yices_expr *)malloc(Int_val(n) * sizeof(yices_expr));
+ tmp = args;
+ while(Int_val(tmp) != 0 && i < n) {
+ cargs[i] = yices_expr_val(Field(tmp, 0));
+ tmp = Field(tmp, 1);
+ i++;
+ }
+ res = yices_mk_or(yices_context_val(yc), cargs, Int_val(n));
+ free(cargs);
+
+ CAMLreturn(alloc_yices_expr(res));
+}
+
+value caml_yices_mk_and(value yc, value args, value n)
+{
+ yices_expr *cargs;
+ yices_expr res;
+ int i = 0;
+
+ CAMLparam3(yc, args, n);
+ CAMLlocal1(tmp);
+
+ cargs = (yices_expr *)malloc(Int_val(n) * sizeof(yices_expr));
+ tmp = args;
+ while(Int_val(tmp) != 0 && i < n) {
+ cargs[i] = yices_expr_val(Field(tmp, 0));
+ tmp = Field(tmp, 1);
+ i++;
+ }
+ res = yices_mk_and(yices_context_val(yc), cargs, Int_val(n));
+ free(cargs);
+
+ CAMLreturn(alloc_yices_expr(res));
+}
+
+value caml_yices_mk_eq(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_eq(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_mk_diseq(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_diseq(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_mk_ite(value yc, value c, value t, value e)
+{
+ CAMLparam4(yc, c, t, e);
+ CAMLreturn(alloc_yices_expr(yices_mk_ite(yices_context_val(yc),
+ yices_expr_val(c),
+ yices_expr_val(t),
+ yices_expr_val(e))));
+}
+
+value caml_yices_mk_not(value yc, value e)
+{
+ CAMLparam2(yc, e);
+ CAMLreturn(alloc_yices_expr(yices_mk_not(yices_context_val(yc),
+ yices_expr_val(e))));
+}
+
+value caml_yices_create_var_decl_iterator(value yc)
+{
+ CAMLparam1(yc);
+ CAMLreturn(alloc_yices_var_decl_iterator(yices_create_var_decl_iterator(
+ yices_context_val(yc))));
+}
+
+value caml_yices_iterator_has_next(value it)
+{
+ CAMLparam1(it);
+ CAMLreturn(Val_int(yices_iterator_has_next(yices_var_decl_iterator_val(it))));
+}
+
+value caml_yices_iterator_next(value it)
+{
+ CAMLparam1(it);
+ CAMLreturn(alloc_yices_var_decl(yices_iterator_next(
+ yices_var_decl_iterator_val(it))));
+}
+
+value caml_yices_iterator_reset(value it)
+{
+ CAMLparam1(it);
+ yices_iterator_reset(yices_var_decl_iterator_val(it));
+ CAMLreturn(Val_unit);
+}
+
+value caml_yices_del_iterator(value it)
+{
+ CAMLparam1(it);
+ yices_del_iterator(yices_var_decl_iterator_val(it));
+ CAMLreturn(Val_unit);
+}
+
+value caml_yices_mk_type(value yc, value name)
+{
+ CAMLparam2(yc, name);
+ CAMLreturn(alloc_yices_type(yices_mk_type(yices_context_val(yc),
+ String_val(name))));
+}
+
+/* XXX: value caml_yices_mk_function_type */
+
+value caml_yices_mk_bitvector_type(value yc, value size)
+{
+ CAMLparam2(yc,size);
+ CAMLreturn(alloc_yices_type(yices_mk_bitvector_type(yices_context_val(yc),
+ Int_val(size))));
+}
+
+/* XXX: value caml_yices_mk_tuple_type */
+
+value caml_yices_mk_var_decl(value yc, value name, value ty)
+{
+ CAMLparam3(yc, name, ty);
+ CAMLreturn(alloc_yices_var_decl(yices_mk_var_decl(yices_context_val(yc),
+ String_val(name),
+ yices_type_val(ty))));
+}
+
+/* Returns a list! */
+value caml_yices_get_var_decl_from_name(value yc, value name)
+{
+ yices_var_decl yvd;
+
+ CAMLparam2(yc, name);
+ CAMLlocal1(res);
+ yvd = yices_get_var_decl_from_name(yices_context_val(yc),String_val(name));
+ if( yvd ) {
+ res = caml_alloc_tuple(2);
+ Store_field(res, 0, alloc_yices_var_decl(yvd));
+ Store_field(res, 1, Val_int(0));
+ }
+ else {
+ res = Val_int(0);
+ }
+
+ CAMLreturn(res);
+}
+
+value caml_yices_mk_var_from_decl(value yc, value vd)
+{
+ CAMLparam2(yc,vd);
+ CAMLreturn(alloc_yices_expr(yices_mk_var_from_decl(yices_context_val(yc),
+ yices_var_decl_val(vd))));
+}
+
+/* XXX: value caml_yices_mk_app */
+
+value caml_yices_mk_num(value yc, value n)
+{
+ CAMLparam2(yc, n);
+ CAMLreturn(alloc_yices_expr(yices_mk_num(yices_context_val(yc),Int_val(n))));
+}
+
+value caml_yices_mk_num_from_string(value yc, value numstr)
+{
+ CAMLparam2(yc, numstr);
+ CAMLreturn(alloc_yices_expr(yices_mk_num_from_string(yices_context_val(yc),
+ String_val(numstr))));
+}
+
+value caml_yices_mk_sum(value yc, value args, value n)
+{
+ yices_expr *cargs;
+ yices_expr res;
+ int i = 0;
+
+ CAMLparam3(yc, args, n);
+ CAMLlocal1(tmp);
+
+ cargs = (yices_expr *)malloc(Int_val(n) * sizeof(yices_expr));
+ tmp = args;
+ while(Int_val(tmp) != 0 && i < n) {
+ cargs[i] = yices_expr_val(Field(tmp, 0));
+ tmp = Field(tmp, 1);
+ i++;
+ }
+ res = yices_mk_sum(yices_context_val(yc), cargs, Int_val(n));
+ free(cargs);
+
+ CAMLreturn(alloc_yices_expr(res));
+}
+
+value caml_yices_mk_sub(value yc, value args, value n)
+{
+ yices_expr *cargs;
+ yices_expr res;
+ int i = 0;
+
+ CAMLparam3(yc, args, n);
+ CAMLlocal1(tmp);
+
+ cargs = (yices_expr *)malloc(Int_val(n) * sizeof(yices_expr));
+ tmp = args;
+ while(Int_val(tmp) != 0 && i < n) {
+ cargs[i] = yices_expr_val(Field(tmp, 0));
+ tmp = Field(tmp, 1);
+ i++;
+ }
+ res = yices_mk_sub(yices_context_val(yc), cargs, Int_val(n));
+ free(cargs);
+
+ CAMLreturn(alloc_yices_expr(res));
+}
+
+value caml_yices_mk_mul(value yc, value args, value n)
+{
+ yices_expr *cargs;
+ yices_expr res;
+ int i = 0;
+
+ CAMLparam3(yc, args, n);
+ CAMLlocal1(tmp);
+
+ cargs = (yices_expr *)malloc(Int_val(n) * sizeof(yices_expr));
+ tmp = args;
+ while(Int_val(tmp) != 0 && i < n) {
+ cargs[i] = yices_expr_val(Field(tmp, 0));
+ tmp = Field(tmp, 1);
+ i++;
+ }
+ res = yices_mk_mul(yices_context_val(yc), cargs, Int_val(n));
+ free(cargs);
+
+ CAMLreturn(alloc_yices_expr(res));
+}
+
+value caml_yices_mk_lt(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_lt(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_mk_le(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_le(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_mk_gt(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_gt(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_mk_ge(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_ge(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_mk_bv_constant(value yc, value size, value val)
+{
+ CAMLparam3(yc,size,val);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_constant(yices_context_val(yc),
+ Int_val(size),
+ Int_val(val))));
+}
+
+/* XXX: value vaml_yices_mk_bv_constant_from_array */
+
+value caml_yices_mk_bv_add(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_add(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_mk_bv_sub(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_sub(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_mk_bv_mul(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_mul(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_mk_bv_minus(value yc, value e)
+{
+ CAMLparam2(yc, e);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_minus(yices_context_val(yc),
+ yices_expr_val(e))));
+}
+
+value caml_yices_mk_bv_concat(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_concat(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_mk_bv_and(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_and(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_mk_bv_or(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_or(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_mk_bv_xor(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_xor(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_mk_bv_not(value yc, value e)
+{
+ CAMLparam2(yc, e);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_not(yices_context_val(yc),
+ yices_expr_val(e))));
+}
+
+value caml_yices_mk_bv_extract(value yc, value end, value begin, value e)
+{
+ CAMLparam4(yc, end, begin, e);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_extract(yices_context_val(yc),
+ Int_val(end),Int_val(begin),
+ yices_expr_val(e))));
+}
+
+value caml_yices_mk_bv_sign_extend(value yc, value e, value n)
+{
+ CAMLparam3(yc,e,n);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_sign_extend(yices_context_val(yc),
+ yices_expr_val(e),
+ Int_val(n))));
+}
+
+value caml_yices_mk_bv_shift_left0(value yc, value e, value n)
+{
+ CAMLparam3(yc, e, n);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_shift_left0(yices_context_val(yc),
+ yices_expr_val(e),
+ Int_val(n))));
+}
+
+value caml_yices_mk_bv_shift_left1(value yc, value e, value n)
+{
+ CAMLparam3(yc, e, n);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_shift_left1(yices_context_val(yc),
+ yices_expr_val(e),
+ Int_val(n))));
+}
+
+value caml_yices_mk_bv_shift_right0(value yc, value e, value n)
+{
+ CAMLparam3(yc, e, n);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_shift_right0(yices_context_val(yc),
+ yices_expr_val(e),
+ Int_val(n))));
+}
+
+value caml_yices_mk_bv_shift_right1(value yc, value e, value n)
+{
+ CAMLparam3(yc, e, n);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_shift_right1(yices_context_val(yc),
+ yices_expr_val(e),
+ Int_val(n))));
+}
+
+value caml_yices_mk_bv_lt(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_lt(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_mk_bv_le(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_le(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_mk_bv_gt(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_gt(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_mk_bv_ge(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_ge(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_mk_bv_slt(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_slt(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_mk_bv_sle(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_sle(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_mk_bv_sgt(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_sgt(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_mk_bv_sge(value yc, value e1, value e2)
+{
+ CAMLparam3(yc, e1, e2);
+ CAMLreturn(alloc_yices_expr(yices_mk_bv_sge(yices_context_val(yc),
+ yices_expr_val(e1),
+ yices_expr_val(e2))));
+}
+
+value caml_yices_pp_expr(value e)
+{
+ CAMLparam1(e);
+ yices_pp_expr(yices_expr_val(e));
+ CAMLreturn(Val_unit);
+}
--- /dev/null
+
+open Printf
+
+module Y = Yices
+
+let test () =
+ (*Y.enable_type_checker true;
+ Y.set_arith_only true;*)
+ let yc = Y.mk_context () in
+ let intType = Y.mk_type yc "int" in
+ let x = Y.mk_var_decl yc "x" intType in
+ let y = Y.mk_var_decl yc "y" intType in
+ let xe = Y.mk_var_from_decl yc x in
+ let ye = Y.mk_var_from_decl yc y in
+
+ let ten = Y.mk_num yc 10 in
+ let xpy = Y.mk_sum yc [xe;ye] 2 in
+ let xpygtten = Y.mk_gt yc xpy ten in
+ let e = xpygtten in
+ (*let e = Y.mk_not yc xpygtten in*)
+ (*let e = Y.mk_gt yc xe (Y.mk_num yc 10) in*)
+
+ Y.assert_expr yc e;
+ Y.dump_context yc;
+ match Y.check_context yc with
+ | 1 -> begin
+ let m = Y.get_model yc in
+ match m with
+ | [] -> print_string "Sat but no model\n"
+ | m :: _ -> begin
+ print_string "Satisfiable. Printing model:\n";
+ let it = Y.create_var_decl_iterator yc in (* XXX: why doesn't this work??? *)
+ let rec loop () =
+ if Y.iterator_has_next it then begin
+ let vd = Y.iterator_next it in
+ let (res, v) = Y.get_int_value m vd in
+ if res then begin
+ let name = Y.get_var_decl_name vd in
+ printf "model: %s -> %d\n" name v;
+ loop ()
+ end else begin
+ let name = Y.get_var_decl_name vd in
+ printf "model: %s -> undef\n" name;
+ loop ()
+ end
+ end else begin
+ printf "model: done\n";
+ ()
+ end
+ in
+ loop ();
+ Y.del_iterator it;
+ ()
+ end
+ end
+ | 0 -> print_string "Not Satisfiable\n"
+ | -1 -> print_string "Couldn't determine anything\n"
+ | _ -> print_string "Internal Error\n"
+
+
+let _ = test ();
+
+
--- /dev/null
+(* BEGIN INTERFACE *)
+(* $Id: xHTML.ml,v 1.31 2005/06/20 17:57:58 ohl Exp $
+
+ Copyright (C) 2004 by Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+
+ XHTML is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ XHTML is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+
+(* IDEAS:
+
+ It might be possible to factorize attributes and elements into separate
+ modules. Problems are attributes like [class] and [for] that class with
+ reserved words. Then the [a_] prefix would have to be maintained and the
+ only advantage are a potentially better mapping of the XHTML modularization
+ to O'Caml modules. *)
+
+(** Typesafe constructors for XHTML 1.1 documents.
+ @see <http://www.w3.org/TR/xhtml-modularization/abstract_modules.html> W3C Recommendation *)
+
+module type T =
+ sig
+
+(** The elements, attributes, attribute types and data types are given names
+ that match the names in the W3C recommendation as closely as allowed by
+ a strict typing discipline and the lexical conventions of O'Caml:
+ {ul
+ {- {e elements} are implemented as O'Caml constructors with the same name as
+ in the W3C recommendation. The domain and codomain are specified as ['a elt],
+ where ['a] is a concrete phantom type build out of polymorphic variants.}
+ {- {e attributes} are implemented as O'Caml constructors with [a_] prefixed to the
+ name. The name is the same as in the W3C recommendation, unless an additional
+ prefix is required to disambiguate:
+ {ul
+ {- [a_fs_rows] and [a_fs_cols] instead of [a_rows] and [a_cols] for framesets,
+ because of the different argument types.}}}
+ {- {e attribute types} are implemented as O'Caml types that all have the same names
+ as in the W3C recommendation, but are all lowercase.}
+ {- {e data types} are also implemented as O'Caml types that all have the same names
+ as in the W3C recommendation and are again all lowercase.}}
+
+ Finite sets of alternatives are mapped to polymorphic variants.
+
+ The phantom type is always the {e most general} required by any (supported)
+ version of the standard. Type discipline is enforced by exporting or not-exporting
+ the corresponding constructor. *)
+
+(** {1 Attribute Types}
+ @see <http://www.w3.org/TR/xhtml-modularization/abstraction.html#s_common_attrtypes> Modularization of XHTML *)
+
+ type cdata = string
+(** Character data *)
+
+ type id = string
+(** A document-unique identifier *)
+
+ type idref = string
+(** A reference to a document-unique identifier *)
+
+ type idrefs = idref list
+(** A space-separated list of references to document-unique identifiers *)
+
+ type name = string
+(** A name with the same character constraints as ID above *)
+
+ type nmtoken = string
+(** A name composed of only name tokens as defined in XML 1.0
+ @see <http://www.w3.org/TR/2000/REC-xml-20001006> XML 1.0 *)
+
+ type nmtokens = nmtoken list
+(** One or more white space separated NMTOKEN values *)
+
+ type pcdata = string
+(** Processed character data *)
+
+(** {2 Data Types} *)
+
+ type character = char
+(** A single character from ISO 10646. *)
+
+ type charset = string
+(** A character encoding, as per RFC2045 (MIME).
+ @see <http://www.ietf.org/rfc/rfc2045.txt> RFC2045 *)
+
+ type charsets = charset list
+(** A space-separated list of character encodings, as per RFC2045 (MIME).
+ @see <http://www.ietf.org/rfc/rfc2045.txt> RFC2045 *)
+
+ type color =
+ [ `Aqua | `Black | `Blue | `Fuchsia | `Gray | `Green | `Lime | `Maroon
+ | `Navy | `Olive | `Purple | `Red | `Silver | `Teal | `White | `Yellow
+ | `Hex of string | `RGB of int * int * int ]
+(** The attribute value type [color] refers to color definitions as specified in
+ SRGB. A color value may either be a hexadecimal number (prefixed by a hash mark)
+ or one of the following sixteen color names. The color names are case-insensitive.
+ @see <http://www.w3.org/Graphics/Color/sRGB> A Standard Default Color Space for the Internet. *)
+
+ type contenttype = string
+(** A media type, as per RFC2045 (MIME).
+ @see <http://www.ietf.org/rfc/rfc2045.txt> RFC2045 *)
+
+ type contenttypes = contenttype list
+(** A comma-separated list of media types, as per RFC2045 (MIME).
+ @see <http://www.ietf.org/rfc/rfc2045.txt> RFC2045 *)
+
+ type coords = string list
+(** Comma- separated list of coordinates to use in defining areas. *)
+
+ type datetime = string
+(** Date and time information. *)
+
+ type fpi = string
+(** A character string representing an SGML Formal Public Identifier. *)
+
+ type frametarget = string
+(** Frame name used as destination for results of certain actions. *)
+
+ type languagecode = string
+(** A language code, as per RFC3066.
+ @see <http://www.ietf.org/rfc/rfc3066.txt> RFC3066 *)
+
+ type length = [ `Pixels of int | `Percent of int ]
+(** The value may be either in pixels or a percentage of the available
+ horizontal or vertical space. Thus, the value [`Percent 50] means half of
+ the available space. *)
+
+ type linktypes =
+ [ `Alternate | `Appendix | `Bookmark | `Chapter | `Contents
+ | `Copyright | `Glossary | `Help | `Index | `Next | `Prev
+ | `Section | `Start | `Stylesheet | `Subsection] list
+(** Authors may use the following recognized link types, listed here with
+ their conventional interpretations. A LinkTypes value refers to a
+ space-separated list of link types. White space characters are not
+ permitted within link types. These link types are case-insensitive, i.e.,
+ ["Alternate"] has the same meaning as ["alternate"].
+
+ User agents, search engines, etc. may interpret these link types in a
+ variety of ways. For example, user agents may provide access to linked
+ documents through a navigation bar.
+
+ {ul
+ {- [`Alternate]:
+ Designates substitute versions for the document in which the link occurs.
+ When used together with the hreflang attribute, it implies a translated
+ version of the document. When used together with the media attribute,
+ it implies a version designed for a different medium (or media).}
+ {- [`Stylesheet]:
+ Refers to an external style sheet. See the Style Module for details.
+ This is used together with the link type ["Alternate"] for user-selectable
+ alternate style sheets.}
+ {- [`Start]:
+ Refers to the first document in a collection of documents.
+ This link type tells search engines which document is considered
+ by the author to be the starting point of the collection.}
+ {- [`Next]:
+ Refers to the next document in a linear sequence of documents.
+ User agents may choose to pre-load the "next" document, to reduce
+ the perceived load time.}
+ {- [`Prev]:
+ Refers to the previous document in an ordered series of documents.
+ Some user agents also support the synonym "Previous".}
+ {- [`Contents]:
+ Refers to a document serving as a table of contents. Some user
+ agents also support the synonym ToC (from "Table of Contents").}
+ {- [`Index]:
+ Refers to a document providing an index for the current document.}
+ {- [`Glossary]:
+ Refers to a document providing a glossary of terms that pertain to
+ the current document.}
+ {- [`Copyright]:
+ Refers to a copyright statement for the current document.}
+ {- [`Chapter]:
+ Refers to a document serving as a chapter in a collection of documents.}
+ {- [`Section]:
+ Refers to a document serving as a section in a collection of documents.}
+ {- [`Subsection]:
+ Refers to a document serving as a subsection in a collection of documents.}
+ {- [`Appendix]:
+ Refers to a document serving as an appendix in a collection of documents.}
+ {- [`Help]:
+ Refers to a document offering help (more information, links to other
+ sources information, etc.)}
+ {- [`Bookmark]:
+ Refers to a bookmark. A bookmark is a link to a key entry point within
+ an extended document. The title attribute may be used, for example, to
+ label the bookmark. Note that several bookmarks may be defined in each
+ document.}} *)
+
+ type mediadesc =
+ [ `All | `Aural | `Braille | `Handheld | `Print
+ | `Projection | `Screen | `TTY | `TV ] list
+(** The MediaDesc attribute is a comma-separated list of media descriptors.
+ The following is a list of recognized media descriptors:
+ {ul
+ {- [`Screen]:
+ Intended for non-paged computer screens.}
+ {- [`TTY]:
+ Intended for media using a fixed-pitch character grid, such as
+ teletypes, terminals, or portable devices with limited display
+ capabilities.}
+ {- [`TV]:
+ Intended for television-type devices (low resolution, color,
+ limited scrollability).}
+ {- [`Projection]:
+ Intended for projectors.}
+ {- [`Handheld]:
+ Intended for handheld devices (small screen, monochrome,
+ bitmapped graphics, limited bandwidth).}
+ {- [`Print]:
+ Intended for paged, opaque material and for documents viewed
+ on screen in print preview mode.}
+ {- [`Braille]:
+ Intended for braille tactile feedback devices.}
+ {- [`Aural]:
+ Intended for speech synthesizers.}
+ {- [`All]:
+ Suitable for all devices.}}
+
+ Future versions of XHTML may introduce new values and may allow
+ parameterized values. To facilitate the introduction of these
+ extensions, conforming user agents must be able to parse the media
+ attribute value as follows:
+ {ol
+ {- The value is a comma-separated list of entries. For example,
+ [media="screen, 3d-glasses, print and resolution > 90dpi"]
+ is mapped to: ["screen"], ["3d-glasses"],
+ ["print and resolution > 90dpi"].}
+ {- Each entry is truncated just before the first character that
+ isn't a US ASCII letter [\[a-zA-Z\]] (ISO 10646 hex 41-5a,
+ 61-7a), digit [\[0-9\]] (hex 30-39), or hyphen-minus (hex 2d).
+ In the example, this gives: ["screen"], ["3d-glasses"], ["print"].}
+ {- A case-insensitive match is then made with the set of media
+ types defined above. User agents may ignore entries that
+ don't match. In the example we are left with ["screen"] and
+ ["print"].}}
+
+ Note. Style sheets may include media-dependent variations within them
+ (e.g., the [CSS \@media] construct). In such cases it may be appropriate
+ to use ["media=all"]. *)
+
+ type multilength = [ length | `Relative of int ]
+(** The value may be a Length or a relative length. A relative length
+ has the form ["i*"], where ["i"] is an integer. When allotting space
+ among elements competing for that space, user agents allot pixel
+ and percentage lengths first, then divide up remaining available
+ space among relative lengths. Each relative length receives a
+ portion of the available space that is proportional to the integer
+ preceding the ["*"]. The value ["*"] is equivalent to ["1*"]. Thus, if
+ 60 pixels of space are available after the user agent allots pixel
+ and percentage space, and the competing relative lengths are ["1*"],
+ ["2*"], and ["3*"], the ["1*"] will be allotted 10 pixels, the ["2*"] will be
+ allotted 20 pixels, and the ["3*"] will be allotted 30 pixels. *)
+
+ type multilengths = multilength list (* comma-separated *)
+(** A comma separated list of items of type MultiLength. *)
+
+ type number = int
+(** One or more digits. *)
+
+ type pixels = int
+
+(** The value is an integer that represents the number of pixels of
+ the canvas (screen, paper). Thus, the value ["50"] means fifty
+ pixels. For normative information about the definition of a pixel,
+ please consult CSS2.
+ @see <http://www.w3.org/TR/1998/REC-CSS2-19980512> CSS2 *)
+
+ type script = string
+(** Script data can be the content of the ["script"] element and the
+ value of intrinsic event attributes. User agents must not evaluate
+ script data as HTML markup but instead must pass it on as data to a
+ script engine.
+
+ The case-sensitivity of script data depends on the scripting
+ language.
+
+ Please note that script data that is element content may not
+ contain character references, but script data that is the value of
+ an attribute may contain them. *)
+
+ type shape = string
+(** The shape of a region. *)
+
+ type text = string
+(** Arbitrary textual data, likely meant to be human-readable. *)
+
+ type uri = string
+(** A Uniform Resource Identifier, as per RFC2396.
+ @see <http://www.ietf.org/rfc/rfc2396.txt> RFC2396 *)
+
+ type uris = uri
+(** A space-separated list of Uniform Resource Identifiers, as per RFC2396.
+ @see <http://www.ietf.org/rfc/rfc2396.txt> RFC2396 *)
+
+
+(** {1 Common Attributes} *)
+
+ type 'a attrib
+ type 'a attribs
+ (** ['a] is known as a {i phantom type}. The implementation is
+ actually monomorphic (the different element types are distinguished
+ by a homogeneous variable, such as their textual representation)
+ and the type variable [`a] is just used by the type checker.
+
+ NB: It might be possible to use polymorphic variants directly, without
+ phantom types, but the implementation is likely to be more involved. *)
+
+(** {2 Core} *)
+
+ type core = [ `Class | `Id | `Title ]
+
+ val a_class : nmtokens -> [>`Class] attrib
+(** This attribute assigns a class name or set of class names to an
+ element. Any number of elements may be assigned the same class
+ name or names. *)
+
+ val a_id : id -> [>`Id] attrib
+(** This attribute assigns a name to an element. This name must be
+ unique in a document. *)
+
+ val a_title : cdata -> [>`Title] attrib
+(** This attribute offers advisory information about the element for
+ which it is set. *)
+
+(** Values of the title attribute may be rendered by user agents in a
+ variety of ways. For instance, visual browsers frequently display
+ the title as a {i tool tip} (a short message that appears when the
+ pointing device pauses over an object). Audio user agents may
+ speak the title information in a similar context. *)
+
+(** The title attribute has an additional role when used with the [link]
+ element to designate an external style sheet. Please consult the
+ section on links and style sheets for details. *)
+
+(** {2 I18N} *)
+
+ type i18n = [ `XML_lang ]
+ val a_xml_lang : nmtoken -> [>`XML_lang] attrib
+
+(** {2 Style}
+ The Style collection is deprecated, because the Style Attribute Module is
+ deprecated. *)
+
+ type common = [ core | i18n ]
+
+(** {1 Modules, Element Sets and Attributes } *)
+
+(** {2 5.2. Core Modules} *)
+
+(** {3 5.2.1. Structure Module} *)
+
+ module STRUCTURE :
+ sig
+ type t = [ `Body | `Head | `Html | `Title ]
+ end
+
+ val a_profile : uri -> [>`Profile] attrib
+ val a_version : cdata -> [>`Version] attrib
+ val a_xmlns : [< `W3_org_1999_xhtml ] -> [>`XMLns] attrib
+
+(** {3 5.2.2. Text Module} *)
+
+ module TEXT :
+ sig
+ type heading = [ `H1 | `H2 | `H3 | `H4 | `H5 | `H6 ]
+ type block = [ `Address | `Blockquote | `Div | `P | `Pre ]
+ type inline =
+ [ `Abbr | `Acronym | `Br | `Cite | `Code | `Dfn
+ | `Em | `Kbd | `Q | `Samp | `Span | `Strong | `Var ]
+ type flow = [ heading | block | inline ]
+ end
+
+ val a_cite : uri -> [>`Cite] attrib
+ val a_xml_space : [< `Preserve ] -> [>`XML_space] attrib
+
+(** {3 5.2.3. Hypertext Module} *)
+
+ module HYPERTEXT :
+ sig
+ type inline = [ `A ]
+ type flow = inline
+ end
+
+ val a_accesskey : character -> [>`Accesskey] attrib
+(** This attribute assigns an access key to an element. An access key
+ is a single character from the document character
+ set. NB: authors should consider the input method of the
+ expected reader when specifying an accesskey. *)
+
+ val a_charset : charset -> [>`Charset] attrib
+(** This attribute specifies the character encoding of the resource
+ designated by the link. Please consult the section on character
+ encodings for more details. *)
+
+ val a_href : uri -> [>`Href] attrib
+(** This attribute specifies the location of a Web resource, thus
+ defining a link between the current element (the source anchor)
+ and the destination anchor defined by this attribute. *)
+
+ val a_hreflang : languagecode -> [>`Hreflang] attrib
+(** This attribute specifies the base language of the resource
+ designated by href and may only be used when href is specified. *)
+
+ val a_rel : linktypes -> [>`Rel] attrib
+(** This attribute describes the relationship from the current document
+ to the anchor specified by the href attribute. The value of this attribute
+ is a space-separated list of link types. *)
+
+ val a_rev : linktypes -> [>`Rev] attrib
+(** This attribute is used to describe a reverse link from the anchor specified
+ by the href attribute to the current document. The value of this attribute
+ is a space-separated list of link types. *)
+
+ val a_tabindex : number -> [>`Tabindex] attrib
+(** This attribute specifies the position of the current element in
+ the tabbing order for the current document. This value must be a
+ number between 0 and 32767. User agents should ignore leading
+ zeros. *)
+
+ val a_type : contenttype -> [>`Type] attrib
+(** This attribute gives an advisory hint as to the content type of
+ the content available at the link target address. It allows user
+ agents to opt to use a fallback mechanism rather than fetch the
+ content if they are advised that they will get content in a
+ content type they do not support.Authors who use this attribute
+ take responsibility to manage the risk that it may become
+ inconsistent with the content available at the link target
+ address. *)
+
+(** {3 5.2.3. List Module} *)
+
+ module LIST :
+ sig
+ type list = [ `Dl | `Ol | `Ul ]
+ type t = [ `Dd | `Dt | `Li ]
+ type flow = list
+ end
+
+(** {2 5.3. Applet Module}
+ This module is deprecated. Similar functionality
+ can be found in the Object Module. *)
+
+(** {2 5.4. Text Extension Modules} *)
+
+(** {3 5.4.1. Presentation Module} *)
+
+ module PRESENTATION :
+ sig
+ type block = [ `Hr ]
+ type inline = [ `B | `Big | `I | `Small | `Sub | `Sup | `Tt ]
+ end
+
+(** {3 5.4.2. Edit Module} *)
+
+(** {3 5.4.3. Bi-directional Text Module} *)
+
+(** {2 5.5. Forms Modules} *)
+
+(** {3 5.5.1. Basic Forms Module} *)
+
+ module FORMS :
+ sig
+ type t = [ `Option ]
+ type form = [ `Form ]
+ type formctrl_sans_label = [ `Input | `Select | `Textarea ]
+ type formctrl = [ formctrl_sans_label | `Label ]
+ type block = form
+ type inline_sans_label = formctrl_sans_label
+ type inline = formctrl
+ type flow_sans_label = [block | inline_sans_label ]
+ type flow = [ block | inline ]
+ end
+
+ val a_action : uri -> [>`Action] attrib
+(** This attribute specifies a form processing agent. User agent
+ behavior for a value other than an HTTP URI is undefined. *)
+
+ val a_checked : [< `Checked ] -> [>`Checked] attrib
+(** When the [type] attribute has the value ["radio"] or ["checkbox"],
+ this boolean attribute specifies that the button is on. User
+ agents must ignore this attribute for other control types. *)
+
+ val a_cols : number -> [>`Cols] attrib
+(** This attribute specifies the visible width in average character
+ widths. Users should be able to enter longer lines than this, so
+ user agents should provide some means to scroll through the
+ contents of the control when the contents extend beyond the
+ visible area. User agents may wrap visible text lines to keep long
+ lines visible without the need for scrolling. *)
+
+ val a_enctype : contenttype -> [>`Enctype] attrib
+ val a_for : idref -> [>`For] attrib
+ val a_maxlength : number -> [>`Maxlength] attrib
+ val a_method : [< `Get | `Post ] -> [>`Method] attrib
+ val a_multiple : [< `Multiple ] -> [>`Multiple] attrib
+
+ val a_name : cdata -> [>`Name] attrib
+(** This attribute assigns the control name. *)
+
+ val a_rows : number -> [>`Rows] attrib
+(** This attribute specifies the number of visible text lines. Users
+ should be able to enter more lines than this, so user agents
+ should provide some means to scroll through the contents of the
+ control when the contents extend beyond the visible area. *)
+
+ val a_selected : [< `Selected ] -> [>`Selected] attrib
+(** When set, this boolean attribute specifies that this option is pre-selected. *)
+
+ val a_size : number -> [>`Size] attrib
+ val a_src : uri -> [>`Src] attrib
+ val a_input_type :
+ [< `Text | `Password | `Checkbox | `Radio | `Submit | `Reset | `Hidden ] ->
+ [>`Input_Type] attrib
+
+ val a_value : cdata -> [>`Value] attrib
+(** This attribute specifies the initial value of the control. If this
+ attribute is not set, the initial value is set to the contents of
+ the [option] element. *)
+
+
+(** {3 5.5.2. Forms Module} *)
+
+(** {2 5.6. Table Modules} *)
+
+(** {3 5.6.1. Basic Tables Module} *)
+
+ module TABLES :
+ sig
+ type t = [ `Caption | `Td | `Th | `Tr ]
+ type block = [ `Table ]
+ type flow = block
+ end
+
+ val a_abbr : text -> [>`Abbr] attrib
+ val a_align : [< `Left | `Center | `Right | `Justify | `Char ] ->
+ [>`Align] attrib
+ val a_axis : cdata -> [>`Axis] attrib
+ val a_colspan : number -> [>`Colspan] attrib
+ val a_headers : idrefs -> [>`Headers] attrib
+ val a_rowspan : number -> [>`Rowspan] attrib
+ val a_scope : [< `Row | `Col | `Rowgroup | `Colgroup ] -> [>`Scope] attrib
+ val a_summary : text -> [>`Summary] attrib
+ val a_valign : [< `Top | `Middle | `Bottom | `Baseline ] ->
+ [>`Valign] attrib
+
+(** {3 5.6.2. Tables Module} *)
+
+ val a_border : pixels -> [>`Border] attrib
+ val a_cellpadding : length -> [>`Cellpadding] attrib
+ val a_cellspacing : length -> [>`Cellspacing] attrib
+ val a_datapagesize : cdata -> [>`Datapagesize] attrib
+ val a_frame :
+ [< `Void | `Above | `Below | `Hsides | `LHS | `RHS
+ | `Vsides | `Box | `Border ] -> [>`Frame] attrib
+ val a_rules : [< `None | `Groups | `Rows | `Cols | `All ] -> [>`Rules] attrib
+ val a_char : character -> [>`Char] attrib
+ val a_charoff : length -> [>`Charoff] attrib
+
+(** {2 5.7. Image Module} *)
+
+ module IMAGE :
+ sig
+ type inline = [ `Img ]
+ end
+
+ val a_alt : text -> [>`Alt] attrib
+ val a_height : length -> [>`Height] attrib
+ val a_longdesc : uri -> [>`Longdesc] attrib
+ val a_width : length -> [>`Width] attrib
+
+(** {2 5.8. Client-side Image Map Module} *)
+
+(** {2 5.9. Server-side Image Map Module} *)
+
+(** {2 5.10. Object Module} *)
+
+(** {2 5.11. Frames Module} *)
+
+ val a_fs_rows : multilengths -> [>`FS_Rows] attrib
+ val a_fs_cols : multilengths -> [>`FS_Cols] attrib
+ val a_frameborder : [< `Zero | `One ] -> [>`Frameborder] attrib
+ val a_marginheight : pixels -> [>`Marginheight] attrib
+ val a_marginwidth : pixels -> [>`Marginwidth] attrib
+ val a_noresize : [< `Noresize ] -> [>`Noresize] attrib
+ val a_scrolling : [< `Yes | `No | `Auto ] -> [>`Scrolling] attrib
+
+(** {2 5.12. Target Module} *)
+
+ val a_target : frametarget -> [>`Target] attrib
+
+(** {2 5.13. Iframe Module} *)
+
+(** {2 5.14. Intrinsic Events Module} *)
+
+(** {2 5.15. Metainformation Module} *)
+
+ module METAINFORMATION :
+ sig
+ type t = [ `Meta ]
+ end
+
+ val a_content : cdata -> [>`Content] attrib
+ val a_http_equiv : nmtoken -> [>`Http_equiv] attrib
+ val a_scheme : cdata -> [>`Scheme] attrib
+
+(** {2 5.16. Scripting Module} *)
+
+(** {2 5.17. Style Sheet Module} *)
+
+ module STYLE_SHEET :
+ sig
+ type t = [ `Style ]
+ end
+
+ val a_media : mediadesc -> [>`Media] attrib
+
+(** {2 5.18. Style Attribute Module} *)
+
+(** {2 5.19. Link Module} *)
+
+ module LINK :
+ sig
+ type t = [ `Link ]
+ end
+
+(** {2 5.20. Base Module} *)
+
+ module BASE :
+ sig
+ type t = [ `Base ]
+ end
+
+(** {2 5.21. Name Identification Module}
+ This module is deprecated in XHTML 1.1, but supported for XHTML 1.0
+ using [`Name_01_00] . *)
+
+(** {2 5.22. Legacy Module} *)
+
+(** {1 Combined Element Sets:} *)
+
+ type block =
+ [ TEXT.block | PRESENTATION.block | FORMS.block | TABLES.block ]
+ type block_sans_form =
+ [ TEXT.block | PRESENTATION.block | TABLES.block ]
+
+ type flow =
+ [ TEXT.flow | HYPERTEXT.flow | LIST.flow | FORMS.flow | TABLES.flow ]
+ type flow_sans_table =
+ [ TEXT.flow | HYPERTEXT.flow | LIST.flow | FORMS.flow ]
+
+ type inline =
+ [ TEXT.inline | HYPERTEXT.inline | PRESENTATION.inline
+ | FORMS.inline | IMAGE.inline]
+ type inline_sans_a =
+ [ TEXT.inline | PRESENTATION.inline
+ | FORMS.inline | IMAGE.inline]
+ type inline_sans_label =
+ [ TEXT.inline | HYPERTEXT.inline | PRESENTATION.inline
+ | FORMS.inline_sans_label | IMAGE.inline]
+
+ type heading = TEXT.heading
+
+(** {1 Elements} *)
+
+ type 'a elt
+
+(** {2 Element Constructor Types} *)
+
+ type ('a, 'b) nullary = ?a:('a attrib list) -> unit -> 'b elt
+ type ('a, 'b, 'c) unary = ?a:('a attrib list) -> 'b elt -> 'c elt
+ type ('a, 'b, 'c, 'd) binary = ?a:('a attrib list) -> 'b elt -> 'c elt -> 'd elt
+
+ type ('a, 'b, 'c) star = ?a:('a attrib list) -> 'b elt list -> 'c elt
+(** Star '*' denotes any number of children, uncluding zero. *)
+
+ type ('a, 'b, 'c) plus = ?a:('a attrib list) -> 'b elt -> 'b elt list -> 'c elt
+(** Plus '+' requires at least one child. *)
+
+(** {2 Structure} *)
+
+ type html = [`Html] elt
+
+ val html : ?a:([< i18n | `Version | `XMLns ] attrib list) ->
+ [< `Head ] elt -> [< `Body | `Frameset ] elt -> html
+ val head : ([< i18n | `Profile ],
+ [< `Title | `Meta | `Link | `Style | `Base ], [>`Head]) plus
+ val title : ([< i18n ], [< `PCDATA ], [>`Title]) unary
+ val body : ([< common ], [< heading | block | LIST.list ], [>`Body]) star
+
+(** {2 Data} *)
+
+ val pcdata : string -> [>`PCDATA] elt
+ val entity : string -> [>`PCDATA] elt
+ val space : unit -> [>`PCDATA] elt
+
+(** {2 Text} *)
+
+ val h1 : ([< common ], [< `PCDATA | inline ], [>`H1]) star
+ val h2 : ([< common ], [< `PCDATA | inline ], [>`H2]) star
+ val h3 : ([< common ], [< `PCDATA | inline ], [>`H3]) star
+ val h4 : ([< common ], [< `PCDATA | inline ], [>`H4]) star
+ val h5 : ([< common ], [< `PCDATA | inline ], [>`H5]) star
+ val h6 : ([< common ], [< `PCDATA | inline ], [>`H6]) star
+
+ val address : ([< common ], [< `PCDATA | inline ], [>`Address]) star
+ val blockquote : ([< common | `Cite ],
+ [< `PCDATA | heading | block | LIST.list ], [>`Blockquote]) star
+ val div : ([< common ], [< `PCDATA | flow ], [>`Div]) star
+ val p : ([< common ], [< `PCDATA | inline ], [>`P]) star
+ val pre : ([< common | `XML_space ], [< `PCDATA | inline ], [>`Pre]) star
+
+ val abbr : ([< common ], [< `PCDATA | inline ], [>`Abbr]) star
+ val acronym : ([< common ], [< `PCDATA | inline ], [>`Acronym]) star
+ val br : ([< core ], [>`Br]) nullary
+ val cite : ([< common ], [< `PCDATA | inline ], [>`Cite]) star
+ val code : ([< common ], [< `PCDATA | inline ], [>`Code]) star
+ val dfn : ([< common ], [< `PCDATA | inline ], [>`Dfn]) star
+ val em : ([< common ], [< `PCDATA | inline ], [>`Em]) star
+ val kbd : ([< common ], [< `PCDATA | inline ], [>`Kbd]) star
+ val q : ([< common | `Cite ], [< `PCDATA | inline ], [>`Q]) star
+ val samp : ([< common ], [< `PCDATA | inline ], [>`Samp]) star
+ val span : ([< common ], [< `PCDATA | inline ], [>`Span]) star
+ val strong : ([< common ], [< `PCDATA | inline ], [>`Strong]) star
+
+(** {2 Hypertext} *)
+
+ val a : ([< common | `Accesskey | `Charset | `Href | `Hreflang
+ | `Name_01_00 | `Rel | `Rev | `Tabindex | `Target | `Type ],
+ [< `PCDATA | inline_sans_a ], [>`A]) star
+
+(** {2 List} *)
+
+ val dl : ([< common ], [< `Dt | `Dd ], [>`Dl]) plus
+ val ol : ([< common ], [< `Li ], [>`Ol]) plus
+ val ul : ([< common ], [< `Li ], [>`Ul]) plus
+ val dd : ([< common ], [< `PCDATA | flow ], [>`Dd]) star
+ val dt : ([< common ], [< `PCDATA | inline ], [>`Dt]) star
+ val li : ([< common ], [< `PCDATA | flow ], [>`Li]) star
+
+(** {2 Presentation} *)
+
+ val hr : ([< common ], [>`Hr]) nullary
+ val b : ([< common ], [< `PCDATA | inline ], [>`B]) star
+ val big : ([< common ], [< `PCDATA | inline ], [>`Big]) star
+ val i : ([< common ], [< `PCDATA | inline ], [>`I]) star
+ val small : ([< common ], [< `PCDATA | inline ], [>`Small]) star
+ val sub : ([< common ], [< `PCDATA | inline ], [>`Sub]) star
+ val sup : ([< common ], [< `PCDATA | inline ], [>`Sup]) star
+ val tt : ([< common ], [< `PCDATA | inline ], [>`Tt]) star
+
+(** {2 Forms} *)
+
+(** {3 Basic Forms} *)
+
+(** One can use [open Basic_Forms] to enable basic forms. *)
+
+ module Basic_Forms :
+ sig
+ val form : action:uri ->
+ ([< common | `Enctype | `Method | `Name_01_00 | `Target ],
+ [< `PCDATA | heading | LIST.list | block_sans_form ], [>`Form]) star
+ val input : ([< common | `Accesskey | `Checked | `Maxlength | `Name | `Size
+ | `Src | `Tabindex | `Input_Type | `Value ], [>`Input]) nullary
+ val label : ([< common | `Accesskey | `For ],
+ [< `PCDATA | inline_sans_label ], [>`Label]) star
+ val option : ([< common | `Selected | `Value ],
+ [< `PCDATA ], [>`Option]) unary
+ val select : ([< common | `Multiple | `Name | `Size | `Tabindex ],
+ [< `Option ], [>`Select]) plus
+ val textarea : rows:number -> cols:number ->
+ ([< common | `Accesskey | `Name | `Tabindex ],
+ [< `PCDATA ], [>`Textarea]) unary
+ end
+
+(** {3 Forms} *)
+
+(** General forms are not implemented yet, but one can use [open Basic_Forms]
+ to enable basic forms. *)
+
+(** {2 Tables} *)
+
+(** {3 Basic Tables} *)
+
+(** One can use [open Basic_Tables] to switch globally to basic tables. *)
+
+ module Basic_Tables :
+ sig
+ val a_align : [< `Left | `Center | `Right ] -> [>`Align] attrib
+ val a_scope : [< `Row | `Col ] -> [>`Scope] attrib
+ val a_valign : [< `Top | `Middle | `Bottom ] -> [>`Valign] attrib
+
+ val caption : ([< common ], [< `PCDATA | inline ], [>`Caption]) star
+ val table : ?caption:([< `Caption ] elt) ->
+ ([< common | `Summary | `Width ], [< `Tr ], [>`Table]) plus
+ val td : ([< common | `Abbr | `Align | `Axis | `Colspan | `Headers | `Rowspan
+ | `Scope | `Valign ], [< `PCDATA | flow_sans_table ], [>`Td]) star
+ val th : ([< common | `Abbr | `Align | `Axis | `Colspan | `Headers | `Rowspan
+ | `Scope | `Valign ], [< `PCDATA | flow_sans_table ], [>`Th]) star
+ val tr : ([< common | `Align | `Valign ], [< `Td | `Th ], [>`Tr]) plus
+ end
+
+(** {3 Tables} *)
+
+ val caption : ([< common ], [< `PCDATA | inline ], [>`Caption]) star
+
+ val table : ?caption:([< `Caption ] elt) ->
+ ?columns:([< `Cols of ([< `Col ] elt list)
+ | `Colgroups of ([< `Colgroup ] elt list) ]) ->
+ ([< common | `Border | `Cellpadding | `Cellspacing | `Datapagesize
+ | `Frame | `Rules | `Summary | `Width ], [< `Tr ], [>`Table]) plus
+
+ val tablex : ?caption:([< `Caption ] elt) ->
+ ?columns:([< `Cols of ([< `Col ] elt list)
+ | `Colgroups of ([< `Colgroup ] elt list) ]) ->
+ ?thead:([< `Thead ] elt) -> ?tfoot:([< `Tfoot ] elt) ->
+ ([< common | `Border | `Cellpadding | `Cellspacing | `Datapagesize
+ | `Frame | `Rules | `Summary | `Width ], [< `Tbody ], [>`Table]) plus
+
+ val td : ([< common | `Abbr | `Align | `Axis | `Char | `Charoff
+ | `Colspan | `Headers | `Rowspan | `Scope | `Valign ],
+ [< `PCDATA | flow ], [>`Td]) star
+ val th : ([< common | `Abbr | `Align | `Axis | `Char | `Charoff
+ | `Colspan | `Headers | `Rowspan | `Scope | `Valign ],
+ [< `PCDATA | flow ], [>`Th]) star
+ val tr : ([< common | `Align | `Char | `Charoff | `Valign ],
+ [< `Td | `Th ], [>`Tr]) plus
+
+ val col : ([< common | `Align | `Char | `Charoff
+ | `Span | `Valign | `Width ], [>`Col]) nullary
+ val colgroup : ([< common | `Align | `Char | `Charoff
+ | `Span | `Valign | `Width ], [< `Col ], [>`Colgroup]) star
+ val thead : ([< common | `Align | `Char | `Charoff | `Valign ],
+ [< `Tr ], [>`Thead]) plus
+ val tbody : ([< common | `Align | `Char | `Charoff | `Valign ],
+ [< `Tr ], [>`Tbody]) plus
+ val tfoot : ([< common | `Align | `Char | `Charoff | `Valign ],
+ [< `Tr ], [>`Tfoot]) plus
+
+(** {2 Image} *)
+
+ val img : src:uri -> alt:text ->
+ ([< common | `Height | `Longdesc | `Name_01_00 | `Width ], [>`Img]) nullary
+
+(** {2 Frames} *)
+
+ val frameset : ?noframes:([< `Noframes ] elt) ->
+ ([< core | `FS_Rows | `FS_Cols ], [< `Frameset | `Frame ], [>`Frameset]) plus
+
+ val frame : src:uri ->
+ ([< core | `Frameborder | `Longdesc | `Marginheight | `Marginwidth
+ | `Name_01_00 | `Noresize | `Scrolling ], [>`Frame]) nullary
+
+ val noframes : ([< common ], [< `Body ], [>`Noframes]) unary
+
+(** {2 Meta} *)
+
+ val meta : content:cdata ->
+ ([< i18n | `Http_equiv | `Name | `Scheme ], [>`Meta]) nullary
+
+(** {2 Style Sheets} *)
+
+ val style : contenttype:contenttype ->
+ ([< i18n | `Media | `Title | `XML_space ], [< `PCDATA ], [>`Style]) star
+
+(** {2 Link} *)
+
+ val link : ([< common | `Charset | `Href | `Hreflang | `Media
+ | `Rel | `Rev | `Target | `Type ], [>`Link]) nullary
+
+(** {2 Base} *)
+
+ val base : href:uri -> unit -> [>`Base] elt
+
+(** {1 Output} *)
+
+(** [?encode] maps strings to HTML and {e must} encode the unsafe characters
+ ['<'], ['>'], ['"'], ['&'] and the control characters 0-8, 11-12, 14-31, 127
+ to HTML entities. [XML.encode_unsafe] is the default for [?encode] in [output]
+ and [pretty_print] below. Other implementations are provided by the module
+ [Netencoding] in the
+ {{:http://www.ocaml-programming.de/programming/ocamlnet.html}OcamlNet} library, e.g.:
+ [let encode = Netencoding.Html.encode ~in_enc:`Enc_iso88591 ~out_enc:`Enc_usascii ()],
+ Where national characters are replaced by HTML entities.
+ The user is of course free to write her own implementation.
+ @see <http://www.ocaml-programming.de/programming/ocamlnet.html> OcamlNet *)
+
+(** [~encoding] is the official name of the external character set encoding that
+ is used by [outs : string -> unit]. *)
+
+ val output : ?encode:(string -> string) -> ?encoding:string ->
+ (string -> unit) -> html -> unit
+
+ val pretty_print : ?width:int ->
+ ?encode:(string -> string) -> ?encoding:string ->
+ (string -> unit) -> html -> unit
+
+(** {1 Tools} *)
+
+ val version : string
+ val standard : uri
+ val validator : uri
+ val validator_icon : unit -> [>`A] elt
+(** A hyperlink to the W3C validator, including the logo.
+ @see <http://validator.w3.org> Validator *)
+
+ val addto_class : string -> 'a elt -> 'a elt
+(** Add the element and all its subelements to a class. Note that this
+ is only almost typesafe, because a few elements from the structure class
+ do not support the class attribute. On the other hand, listing all
+ allowed elements would be too tedious right now. *)
+
+ val addto_class1 : string -> 'a elt -> 'a elt
+(** Add the element to a class. *)
+
+ val set_rowspan : int -> ([< `Th | `Td ] as 'a) elt -> 'a elt
+(** Set the rowspan attribute for the element. *)
+
+ val rewrite_hrefs : (string -> string) -> 'a elt -> 'a elt
+ val all_hrefs : 'a elt -> uri list
+ val all_anchors : 'a elt -> id list
+
+(*
+ val amap : (string -> 'a attribs -> 'a attribs) -> 'b elt -> 'b elt
+ val amap1 : (string -> 'a attribs -> 'a attribs) -> 'b elt -> 'b elt
+
+ val rm_attrib : (string -> bool) -> 'a attribs -> 'a attribs
+ val rm_attrib_from_list :
+ (string -> bool) -> (string -> bool) -> 'a attribs -> 'a attribs
+
+(** Exporting the following will drive a hole through the type system,
+ because they allow to add any attribute to any element. *)
+ val add_int_attrib : string -> int -> 'a attribs -> 'a attribs
+ val add_string_attrib : string -> string -> 'a attribs -> 'a attribs
+ val add_comma_sep_attrib : string -> string -> 'a attribs -> 'a attribs
+ val add_space_sep_attrib : string -> string -> 'a attribs -> 'a attribs
+*)
+
+ end
+
+(** An alias for XHTML 1.1 (for symmetry):
+ @see <http://www.w3.org/TR/xhtml11/> XHTML 1.1 - Module-based XHTML *)
+module type T_01_01 = T
+
+(** XHTML 1.0 includes some deprecated features that since
+ have been removed from XHTML 1.1:
+ @see <http://www.w3.org/TR/xhtml11/changes.html#a_changes> Changes from XHTML 1.0 Strict
+ @see <http://www.w3.org/TR/2000/REC-xhtml1-20000126/> XHTML 1.0: The Extensible HyperText Markup Language *)
+module type T_01_00 =
+ sig
+ include T
+
+(** XHTML 1.1 has removed the name attribute from several elements: *)
+ val a_name_01_00 : cdata -> [>`Name_01_00] attrib
+ end
+
+(* END INTERFACE *)
+
+(* BEGIN INTERFACE
+
+module M : T
+module M_01_01 : T_01_01
+module M_01_00 : T_01_00
+
+ END INTERFACE *)
+
+module Version =
+ struct
+
+ (* Directly from http://www.w3.org/TR/xhtml-modularization/abstract_modules.html *)
+
+ type core = [ `Class | `Id | `Title ]
+ type i18n = [ `XML_lang ]
+
+ type common = [ core | i18n ]
+
+ type 'a attrib = XML.attrib
+ type 'a attribs = XML.attribs
+
+ let int_attrib = XML.int_attrib
+ let string_attrib = XML.string_attrib
+ let space_sep_attrib = XML.space_sep_attrib
+ let comma_sep_attrib = XML.comma_sep_attrib
+
+ type cdata = string
+ type id = string
+ type idref = string
+ type idrefs = idref list (* space-separated *)
+ type name = string
+ type nmtoken = string
+ type nmtokens = nmtoken list (* space-separated *)
+ type pcdata = string
+
+ type character = char
+ type charset = string
+ type charsets = charset list (* space-separated *)
+ type color =
+ [ `Aqua | `Black | `Blue | `Fuchsia | `Gray | `Green | `Lime | `Maroon
+ | `Navy | `Olive | `Purple | `Red | `Silver | `Teal | `White | `Yellow
+ | `Hex of string | `RGB of int * int * int ]
+ type contenttype = string
+ type contenttypes = contenttype list (* comma-separated *)
+ type coords = string list (* Comma separated list of coordinates to use in defining areas. *)
+ type datetime = string
+ type fpi = string
+ type frametarget = string
+ type languagecode = string
+ type length = [ `Pixels of int | `Percent of int ]
+ type linktypes =
+ [`Alternate | `Appendix | `Bookmark | `Chapter | `Contents
+ | `Copyright | `Glossary | `Help | `Index | `Next | `Prev
+ | `Section | `Start | `Stylesheet | `Subsection] list
+ type mediadesc =
+ [ `All | `Aural | `Braille | `Handheld | `Print
+ | `Projection | `Screen | `TTY | `TV ] list
+
+ type multilength = [ length | `Relative of int ]
+ type multilengths = multilength list (* comma-separated *)
+ type number = int
+ type pixels = int
+ type script = string
+ type shape = string
+ type text = string
+ type uri = string
+ type uris = uri (* space-separated *)
+
+ let color_attrib name value =
+ string_attrib name
+ (match value with
+ | `Aqua -> "aqua"
+ | `Black -> "black"
+ | `Blue -> "blue"
+ | `Fuchsia -> "fuchsia"
+ | `Gray -> "gray"
+ | `Green -> "green"
+ | `Lime -> "lime"
+ | `Maroon -> "maroon"
+ | `Navy -> "navy"
+ | `Olive -> "olive"
+ | `Purple -> "purple"
+ | `Red -> "red"
+ | `Silver -> "silver"
+ | `Teal -> "teal"
+ | `White -> "white"
+ | `Yellow -> "yellow"
+ | `Hex h -> ("#" ^ h)
+ | `RGB (r, g, b) -> Printf.sprintf "#%02X%02X%02X" r g b)
+
+ let length_attrib name = function
+ | `Pixels p -> int_attrib name p
+ | `Percent p -> string_attrib name (string_of_int p ^ "%")
+
+ let multilength_attrib name = function
+ | #length as l -> length_attrib name l
+ | `Relative 1 -> string_attrib name "*"
+ | `Relative i -> string_attrib name (string_of_int i ^ "*")
+
+ let multilength_to_string = function
+ | `Pixels p -> string_of_int p
+ | `Percent p -> string_of_int p ^ "%"
+ | `Relative 1 -> "*"
+ | `Relative i -> string_of_int i ^ "*"
+
+ let multilengths_attrib name multilengths =
+ string_attrib name
+ (String.concat ", " (List.map multilength_to_string multilengths))
+
+ let linktype_to_string = function
+ | `Alternate -> "alternate"
+ | `Appendix -> "appendix"
+ | `Bookmark -> "bookmark"
+ | `Chapter -> "chapter"
+ | `Contents -> "contents"
+ | `Copyright -> "copyright"
+ | `Glossary -> "glossary"
+ | `Help -> "help"
+ | `Index -> "index"
+ | `Next -> "next"
+ | `Prev -> "prev"
+ | `Section -> "section"
+ | `Start -> "start"
+ | `Stylesheet -> "stylesheet"
+ | `Subsection -> "subsection"
+
+ let linktypes_attrib name linktypes =
+ string_attrib name
+ (String.concat " " (List.map linktype_to_string linktypes))
+
+ let mediadesc_to_string = function
+ | `All -> "all"
+ | `Aural -> "aural"
+ | `Braille -> "braille"
+ | `Handheld -> "handheld"
+ | `Print -> "print"
+ | `Projection -> "projection"
+ | `Screen -> "screen"
+ | `TTY -> "tty"
+ | `TV -> "tv"
+
+ let mediadesc_attrib name mediadescs =
+ string_attrib name
+ (String.concat ", " (List.map mediadesc_to_string mediadescs))
+
+ (* Core: *)
+
+ let a_class = space_sep_attrib "class"
+ let a_id = string_attrib "id"
+ let a_title = string_attrib "title"
+
+ (* I18N: *)
+
+ let a_xml_lang = string_attrib "xml:lang"
+
+ (* Style: *)
+
+ let a_style = string_attrib "style"
+
+ (* Other Attributes *)
+
+ let a_profile = string_attrib "profile"
+ let a_version = string_attrib "version"
+ let a_xmlns = function
+ | `W3_org_1999_xhtml -> string_attrib "xmlns" "http://www.w3.org/1999/xhtml"
+
+ let a_cite = string_attrib "cite"
+ let a_xml_space = function
+ | `Preserve -> string_attrib "xml:space" "preserve"
+
+ let a_accesskey c = string_attrib "accesskey" (String.make 1 c)
+ let a_charset = string_attrib "charset"
+ let a_href = string_attrib "href"
+ let a_hreflang = string_attrib "hreflang"
+ let a_rel = linktypes_attrib "rel"
+ let a_rev = linktypes_attrib "rev"
+ let a_tabindex = int_attrib "tabindex"
+ let a_type = string_attrib "type"
+
+ let a_alt = string_attrib "alt"
+ let a_height p = length_attrib "height" p
+ let a_longdesc = string_attrib "longdesc"
+ let a_src = string_attrib "src"
+ let a_width p = length_attrib "width" p
+
+ let a_for = string_attrib "for"
+ let a_selected = function
+ | `Selected -> string_attrib "selected" "selected"
+ let a_value = string_attrib "value"
+ let a_action = string_attrib "action"
+ let a_method m =
+ string_attrib "method" (match m with `Get -> "get" | `Post -> "post")
+ let a_enctype = string_attrib "enctype"
+
+ let a_checked = function
+ | `Checked -> string_attrib "checked" "checked"
+ let a_maxlength = int_attrib "maxlength"
+ let a_name = string_attrib "name"
+
+(* XHTML 1.0 allows the name attribute for more elements:*)
+ let a_name_01_00 = string_attrib "name"
+
+ let a_size = int_attrib "size"
+ let a_input_type it =
+ string_attrib "type"
+ (match it with
+ | `Text -> "text"
+ | `Password -> "password"
+ | `Checkbox -> "checkbox"
+ | `Radio -> "radio"
+ | `Submit -> "submit"
+ | `Reset -> "reset"
+ | `Hidden -> "hidden")
+ let a_multiple = function
+ | `Multiple -> string_attrib "multiple" "multiple"
+ let a_cols = int_attrib "cols"
+ let a_rows = int_attrib "rows"
+
+ let a_summary = string_attrib "summary"
+
+ let a_abbr = string_attrib "attrib"
+ let a_align a =
+ string_attrib "align"
+ (match a with
+ | `Left -> "left"
+ | `Center -> "center"
+ | `Right -> "right"
+ | `Justify -> "justify"
+ | `Char -> "char")
+ let a_axis = string_attrib "axis"
+ let a_colspan = int_attrib "colspan"
+ let a_headers = space_sep_attrib "headers"
+ let a_rowspan = int_attrib "rowspan"
+ let a_scope s =
+ string_attrib "scope"
+ (match s with
+ | `Row -> "row"
+ | `Col -> "col"
+ | `Rowgroup -> "rowgroup"
+ | `Colgroup -> "colgroup")
+ let a_valign v =
+ string_attrib "valign"
+ (match v with
+ | `Top -> "top"
+ | `Middle -> "middle"
+ | `Bottom -> "bottom"
+ | `Baseline -> "baseline")
+
+ let a_border = int_attrib "border"
+ let a_cellpadding = length_attrib "cellpadding"
+ let a_cellspacing = length_attrib "cellspacing"
+ let a_datapagesize = string_attrib "datapagesize"
+ let a_frame f =
+ string_attrib "frame"
+ (match f with
+ | `Void -> "void"
+ | `Above -> "above"
+ | `Below -> "below"
+ | `Hsides -> "hsides"
+ | `LHS -> "lhs"
+ | `RHS -> "rhs"
+ | `Vsides -> "vsides"
+ | `Box -> "box"
+ | `Border -> "border")
+ let a_rules r =
+ string_attrib "rules"
+ (match r with
+ | `None -> "none"
+ | `Groups -> "groups"
+ | `Rows -> "rows"
+ | `Cols -> "cols"
+ | `All -> "all")
+ let a_char c = string_attrib "char" (String.make 1 c)
+ let a_charoff = length_attrib "charoff"
+
+ let a_fs_rows mls = multilengths_attrib "rows" mls
+ let a_fs_cols mls = multilengths_attrib "cols" mls
+ let a_frameborder b =
+ int_attrib "frameborder" (match b with `Zero -> 0 | `One -> 1)
+ let a_marginheight = int_attrib "marginheight"
+ let a_marginwidth = int_attrib "marginwidth"
+ let a_noresize `Noresize = string_attrib "noresize" "noresize"
+ let a_scrolling s =
+ string_attrib "scrolling"
+ (match s with
+ | `Yes -> "yes"
+ | `No -> "no"
+ | `Auto -> "auto")
+
+ let a_target = string_attrib "target"
+
+ let a_content = string_attrib "content"
+ let a_http_equiv = string_attrib "http-equiv"
+ let a_scheme = string_attrib "scheme"
+
+ let a_media = mediadesc_attrib "media"
+
+ type 'a elt = XML.elt
+
+ type html = [`Html] elt
+
+ (* NB: These are more general than the ones in xHTML.mli *)
+
+ type ('a, 'b) nullary = ?a:('a attrib list) -> unit -> 'b elt
+ type ('a, 'b, 'c) unary = ?a:('a attrib list) -> 'b elt -> 'c elt
+ type ('a, 'b, 'c, 'd) binary = ?a:('a attrib list) -> 'b elt -> 'c elt -> 'd elt
+ type ('a, 'b, 'c) star = ?a:('a attrib list) -> 'b elt list -> 'c elt
+ type ('a, 'b, 'c) plus = ?a:('a attrib list) -> 'b elt -> 'b elt list -> 'c elt
+
+ let terminal tag ?a () = XML.leaf ?a tag
+ (* let nullary tag ?a () = XML.node ?a tag [] *)
+ let unary tag ?a elt = XML.node ?a tag [elt]
+ let binary tag ?a elt1 elt2 = XML.node ?a tag [elt1; elt2]
+ let star tag ?a elts = XML.node ?a tag elts
+ let plus tag ?a elt elts = XML.node ?a tag (elt :: elts)
+
+ module STRUCTURE =
+ struct
+ type t = [ `Body | `Head | `Html | `Title ]
+ end
+
+ let body = star "body"
+ let head = plus "head"
+ let title = unary "title"
+ let html = binary "html"
+
+ let pcdata = XML.pcdata
+ let entity = XML.entity
+
+ let space () = entity "nbsp"
+
+ module TEXT =
+ struct
+ type heading = [ `H1 | `H2 | `H3 | `H4 | `H5 | `H6 ]
+ type block = [ `Address | `Blockquote | `Div | `P | `Pre ]
+ type inline =
+ [ `Abbr | `Acronym | `Br | `Cite | `Code | `Dfn
+ | `Em | `Kbd | `Q | `Samp | `Span | `Strong | `Var ]
+ type flow = [ heading | block | inline ]
+ end
+
+ let h1 = star "h1"
+ let h2 = star "h2"
+ let h3 = star "h3"
+ let h4 = star "h4"
+ let h5 = star "h5"
+ let h6 = star "h6"
+
+ let address = star "address"
+ let blockquote = star "blockquote"
+ let div = star "div"
+ let p = star "p"
+ let pre = star "pre"
+
+ let abbr = star "abbr"
+ let acronym = star "acronym"
+ let br = terminal "br"
+ let cite = star "cite"
+ let code = star "code"
+ let dfn = star "dfn"
+ let em = star "em"
+ let kbd = star "kbd"
+ let q = star "q"
+ let samp = star "samp"
+ let span = star "span"
+ let strong = star "strong"
+
+ module HYPERTEXT =
+ struct
+ type inline = [ `A ]
+ type flow = inline
+ end
+
+ let a = star "a"
+
+ module LIST =
+ struct
+ type list = [ `Dl | `Ol | `Ul ]
+ type t = [ `Dd | `Dt | `Li ]
+ type flow = list
+ end
+
+ let dl = plus "dl"
+ let ol = plus "ol"
+ let ul = plus "ul"
+ let dd = star "dd"
+ let dt = star "dt"
+ let li = star "li"
+
+ module PRESENTATION =
+ struct
+ type block = [ `Hr ]
+ type inline = [ `B | `Big | `I | `Small | `Sub | `Sup | `Tt ]
+ end
+
+ let hr = terminal "hr"
+ let b = star "b"
+ let big = star "big"
+ let i = star "i"
+ let small = star "small"
+ let sub = star "sub"
+ let sup = star "sup"
+ let tt = star "tt"
+
+ module FORMS =
+ struct
+ type t = [ `Option ]
+ type form = [ `Form ]
+ type formctrl_sans_label = [ `Input | `Select | `Textarea ]
+ type formctrl = [ `Input | `Label | `Select | `Textarea ]
+ type block = form
+ type inline_sans_label = formctrl_sans_label
+ type inline = formctrl
+ type flow_sans_label = [block | inline_sans_label ]
+ type flow = [ block | inline ]
+ end
+
+ module Basic_Forms =
+ struct
+ let form ~action ?(a = []) elts =
+ XML.node ~a:(a_action action :: a) "form" elts
+ let input = terminal "input"
+ let label = star "label"
+ let option = unary "option"
+ let select = plus "select"
+ let textarea ~rows ~cols ?(a = []) elt =
+ XML.node ~a:(a_rows rows :: a_cols cols :: a) "textarea" [elt]
+ end
+
+ module TABLES =
+ struct
+ type t = [ `Caption | `Td | `Th | `Tr ]
+ type block = [ `Table ]
+ type flow = block
+ end
+
+ let list_of_option = function
+ | Some x -> [x]
+ | None -> []
+
+ let list_of_list_option = function
+ | Some x -> x
+ | None -> []
+
+ module Basic_Tables =
+ struct
+ let a_align = a_align
+ let a_scope = a_scope
+ let a_valign = a_valign
+ let caption = star "caption"
+ let table ?caption ?a elt elts =
+ XML.node ?a "table" (list_of_option caption @ elt :: elts)
+ let td = star "td"
+ let th = star "th"
+ let tr = plus "tr"
+ end
+
+ let caption = star "caption"
+
+ let cols_option = function
+ | Some (`Cols c) -> c
+ | Some (`Colgroups c) -> c
+ | None -> []
+
+ let table ?caption ?columns ?a elt elts =
+ XML.node ?a "table"
+ (list_of_option caption @ cols_option columns @ elt :: elts)
+
+ let tablex ?caption ?columns ?thead ?tfoot ?a elt elts =
+ XML.node ?a "table"
+ (list_of_option caption @ cols_option columns @
+ list_of_option thead @ list_of_option tfoot @ elt :: elts)
+
+ let td = star "td"
+ let th = star "th"
+ let tr = plus "tr"
+
+ let col = terminal "col"
+ let colgroup = star "colgroup"
+ let thead = plus "thead"
+ let tbody = plus "tbody"
+ let tfoot = plus "tfoot"
+
+ module IMAGE =
+ struct
+ type inline = [ `Img ]
+ end
+
+ let img ~src ~alt ?(a = []) () =
+ XML.leaf ~a:(a_src src :: a_alt alt :: a) "img"
+
+ let frameset ?noframes ?a elt elts =
+ XML.node ?a "frameset"
+ (elt :: elts @ (match noframes with None -> [] | Some e -> [e]))
+ let frame ~src ?(a = []) () =
+ XML.leaf ~a:(a_src src :: a) "frame"
+ let noframes = unary "noframes"
+
+ module METAINFORMATION =
+ struct
+ type t = [ `Meta ]
+ end
+
+ let meta ~content ?(a = []) () =
+ XML.leaf ~a:(a_content content :: a) "meta"
+
+ module STYLE_SHEET =
+ struct
+ type t = [ `Style ]
+ end
+
+ let style ~contenttype ?(a = []) elts =
+ XML.node ~a:(a_type contenttype :: a) "style" elts
+
+ module LINK =
+ struct
+ type t = [ `Link ]
+ end
+
+ let link = terminal "link"
+
+ module BASE =
+ struct
+ type t = [ `Base ]
+ end
+
+ let base ~href () =
+ XML.leaf ~a:[a_href href] "base"
+
+ type block =
+ [ TEXT.block | PRESENTATION.block | FORMS.block | TABLES.block ]
+ type block_sans_form =
+ [ TEXT.block | PRESENTATION.block | TABLES.block ]
+
+ type flow =
+ [ TEXT.flow | HYPERTEXT.flow | LIST.flow | FORMS.flow | TABLES.flow ]
+ type flow_sans_table =
+ [ TEXT.flow | HYPERTEXT.flow | LIST.flow | FORMS.flow ]
+
+ type inline =
+ [ TEXT.inline | HYPERTEXT.inline | PRESENTATION.inline
+ | FORMS.inline | IMAGE.inline]
+
+ type inline_sans_a =
+ [ TEXT.inline | PRESENTATION.inline | FORMS.inline | IMAGE.inline]
+ type inline_sans_label =
+ [ TEXT.inline | HYPERTEXT.inline | PRESENTATION.inline
+ | FORMS.inline_sans_label | IMAGE.inline]
+
+ type heading = TEXT.heading
+
+ (* I/O *)
+
+ let compose_doctype dt args =
+ "<!DOCTYPE " ^ dt ^ " PUBLIC " ^
+ String.concat " " (List.map (fun a -> "\"" ^ a ^ "\"") args) ^ ">\n"
+
+ let doctype = function
+ | `HTML_v03_02 ->
+ compose_doctype "html" ["-//W3C//DTD HTML 3.2 Final//EN"]
+ | `HTML_v04_01 ->
+ compose_doctype "html" ["-//W3C//DTD HTML 4.01//EN";
+ "http://www.w3.org/TR/html4/strict.dtd"]
+ | `XHTML_01_00 ->
+ compose_doctype "html" ["-//W3C//DTD XHTML 1.0 Strict//EN";
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"]
+ | `XHTML_01_01 ->
+ compose_doctype "html" ["-//W3C//DTD XHTML 1.1//EN";
+ "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"]
+
+ let no_break =
+ ["title";
+ "h1"; "h2"; "h3"; "h4"; "h5"; "h6";
+ "address"; "blockquote"; "div"; "p";
+ "li"; "dd"; "dt"; "td"; "th"]
+
+ let preformatted =
+ ["pre"]
+
+ let output version ?encode ?encoding outs page =
+ XML.decl ?encoding outs ();
+ outs (doctype version);
+ XML.output ~preformatted ~no_break ?encode outs page
+
+ let pretty_print version ?width ?encode ?encoding outs page =
+ XML.decl ?encoding outs ();
+ outs (doctype version);
+ XML.pretty_print ?width ~preformatted ~no_break ?encode outs page
+
+ (* Tools *)
+
+ let version = function
+ | `XHTML_01_00 -> "XHTML 1.0"
+ | `XHTML_01_01 -> "XHTML 1.1"
+
+ let standard = function
+ | `XHTML_01_00 -> "http://www.w3.org/TR/xhtml1/"
+ | `XHTML_01_01 -> "http://www.w3.org/TR/xhtml11/"
+
+ let validator =
+ "http://validator.w3.org/check/referer"
+
+ let compose_validator_icon icon alt =
+ a ~a:[a_href validator]
+ [img ~src:icon ~alt ~a:[a_height (`Pixels 31); a_width (`Pixels 88)] ()]
+
+ let validator_icon = function
+ | `XHTML_01_00 -> compose_validator_icon
+ "http://www.w3.org/Icons/valid-xhtml10" "Valid XHTML 1.0!"
+ | `XHTML_01_01 -> compose_validator_icon
+ "http://www.w3.org/Icons/valid-xhtml11" "Valid XHTML 1.1!"
+
+ let addto_class name =
+ XML.amap (fun _ a -> XML.add_space_sep_attrib "class" name a)
+
+ let addto_class1 name =
+ XML.amap1 (fun _ a -> XML.add_space_sep_attrib "class" name a)
+
+ let set_rowspan n =
+ XML.amap1 (fun _ a -> XML.add_int_attrib "rowspan" n a)
+
+ let rewrite_hrefs f =
+ XML.amap (fun _ a -> XML.map_string_attrib ((=) "href") f a)
+
+ let all_hrefs = XML.all_string_attribs "href"
+ let all_anchors = XML.all_string_attribs ~is_elt:((=) "a") "id"
+
+ let amap = XML.amap
+ let amap1 = XML.amap1
+
+ let rm_attrib = XML.rm_attrib
+ let rm_attrib_from_list = XML.rm_attrib_from_list
+
+ end
+
+module M_01_00 : T_01_00 =
+ struct
+ module M = Version
+ include M
+ let xhtml_version = `XHTML_01_00
+ let version = M.version xhtml_version
+ let standard = M.standard xhtml_version
+ let output = M.output xhtml_version
+ let pretty_print = M.pretty_print xhtml_version
+ let validator_icon () = M.validator_icon xhtml_version
+ let all_anchors elt =
+ M.all_anchors elt @ XML.all_string_attribs ~is_elt:((=) "a") "name" elt
+ end
+
+module M_01_01 : T_01_01 =
+ struct
+ module M = Version
+ include M
+ let xhtml_version = `XHTML_01_01
+ let version = M.version xhtml_version
+ let standard = M.standard xhtml_version
+ let output = M.output xhtml_version
+ let pretty_print = M.pretty_print xhtml_version
+ let validator_icon () = M.validator_icon xhtml_version
+ end
+
+module M = M_01_01
--- /dev/null
+(* $Id: xHTML.mli,v 1.30 2005/06/20 17:57:58 ohl Exp $
+
+ Copyright (C) 2004 by Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+
+ XHTML is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ XHTML is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+
+(* IDEAS:
+
+ It might be possible to factorize attributes and elements into separate
+ modules. Problems are attributes like [class] and [for] that class with
+ reserved words. Then the [a_] prefix would have to be maintained and the
+ only advantage are a potentially better mapping of the XHTML modularization
+ to O'Caml modules. *)
+
+(** Typesafe constructors for XHTML 1.1 documents.
+ @see <http://www.w3.org/TR/xhtml-modularization/abstract_modules.html> W3C Recommendation *)
+
+module type T =
+ sig
+
+(** The elements, attributes, attribute types and data types are given names
+ that match the names in the W3C recommendation as closely as allowed by
+ a strict typing discipline and the lexical conventions of O'Caml:
+ {ul
+ {- {e elements} are implemented as O'Caml constructors with the same name as
+ in the W3C recommendation. The domain and codomain are specified as ['a elt],
+ where ['a] is a concrete phantom type build out of polymorphic variants.}
+ {- {e attributes} are implemented as O'Caml constructors with [a_] prefixed to the
+ name. The name is the same as in the W3C recommendation, unless an additional
+ prefix is required to disambiguate:
+ {ul
+ {- [a_fs_rows] and [a_fs_cols] instead of [a_rows] and [a_cols] for framesets,
+ because of the different argument types.}}}
+ {- {e attribute types} are implemented as O'Caml types that all have the same names
+ as in the W3C recommendation, but are all lowercase.}
+ {- {e data types} are also implemented as O'Caml types that all have the same names
+ as in the W3C recommendation and are again all lowercase.}}
+
+ Finite sets of alternatives are mapped to polymorphic variants.
+
+ The phantom type is always the {e most general} required by any (supported)
+ version of the standard. Type discipline is enforced by exporting or not-exporting
+ the corresponding constructor. *)
+
+(** {1 Attribute Types}
+ @see <http://www.w3.org/TR/xhtml-modularization/abstraction.html#s_common_attrtypes> Modularization of XHTML *)
+
+ type cdata = string
+(** Character data *)
+
+ type id = string
+(** A document-unique identifier *)
+
+ type idref = string
+(** A reference to a document-unique identifier *)
+
+ type idrefs = idref list
+(** A space-separated list of references to document-unique identifiers *)
+
+ type name = string
+(** A name with the same character constraints as ID above *)
+
+ type nmtoken = string
+(** A name composed of only name tokens as defined in XML 1.0
+ @see <http://www.w3.org/TR/2000/REC-xml-20001006> XML 1.0 *)
+
+ type nmtokens = nmtoken list
+(** One or more white space separated NMTOKEN values *)
+
+ type pcdata = string
+(** Processed character data *)
+
+(** {2 Data Types} *)
+
+ type character = char
+(** A single character from ISO 10646. *)
+
+ type charset = string
+(** A character encoding, as per RFC2045 (MIME).
+ @see <http://www.ietf.org/rfc/rfc2045.txt> RFC2045 *)
+
+ type charsets = charset list
+(** A space-separated list of character encodings, as per RFC2045 (MIME).
+ @see <http://www.ietf.org/rfc/rfc2045.txt> RFC2045 *)
+
+ type color =
+ [ `Aqua | `Black | `Blue | `Fuchsia | `Gray | `Green | `Lime | `Maroon
+ | `Navy | `Olive | `Purple | `Red | `Silver | `Teal | `White | `Yellow
+ | `Hex of string | `RGB of int * int * int ]
+(** The attribute value type [color] refers to color definitions as specified in
+ SRGB. A color value may either be a hexadecimal number (prefixed by a hash mark)
+ or one of the following sixteen color names. The color names are case-insensitive.
+ @see <http://www.w3.org/Graphics/Color/sRGB> A Standard Default Color Space for the Internet. *)
+
+ type contenttype = string
+(** A media type, as per RFC2045 (MIME).
+ @see <http://www.ietf.org/rfc/rfc2045.txt> RFC2045 *)
+
+ type contenttypes = contenttype list
+(** A comma-separated list of media types, as per RFC2045 (MIME).
+ @see <http://www.ietf.org/rfc/rfc2045.txt> RFC2045 *)
+
+ type coords = string list
+(** Comma- separated list of coordinates to use in defining areas. *)
+
+ type datetime = string
+(** Date and time information. *)
+
+ type fpi = string
+(** A character string representing an SGML Formal Public Identifier. *)
+
+ type frametarget = string
+(** Frame name used as destination for results of certain actions. *)
+
+ type languagecode = string
+(** A language code, as per RFC3066.
+ @see <http://www.ietf.org/rfc/rfc3066.txt> RFC3066 *)
+
+ type length = [ `Pixels of int | `Percent of int ]
+(** The value may be either in pixels or a percentage of the available
+ horizontal or vertical space. Thus, the value [`Percent 50] means half of
+ the available space. *)
+
+ type linktypes =
+ [ `Alternate | `Appendix | `Bookmark | `Chapter | `Contents
+ | `Copyright | `Glossary | `Help | `Index | `Next | `Prev
+ | `Section | `Start | `Stylesheet | `Subsection] list
+(** Authors may use the following recognized link types, listed here with
+ their conventional interpretations. A LinkTypes value refers to a
+ space-separated list of link types. White space characters are not
+ permitted within link types. These link types are case-insensitive, i.e.,
+ ["Alternate"] has the same meaning as ["alternate"].
+
+ User agents, search engines, etc. may interpret these link types in a
+ variety of ways. For example, user agents may provide access to linked
+ documents through a navigation bar.
+
+ {ul
+ {- [`Alternate]:
+ Designates substitute versions for the document in which the link occurs.
+ When used together with the hreflang attribute, it implies a translated
+ version of the document. When used together with the media attribute,
+ it implies a version designed for a different medium (or media).}
+ {- [`Stylesheet]:
+ Refers to an external style sheet. See the Style Module for details.
+ This is used together with the link type ["Alternate"] for user-selectable
+ alternate style sheets.}
+ {- [`Start]:
+ Refers to the first document in a collection of documents.
+ This link type tells search engines which document is considered
+ by the author to be the starting point of the collection.}
+ {- [`Next]:
+ Refers to the next document in a linear sequence of documents.
+ User agents may choose to pre-load the "next" document, to reduce
+ the perceived load time.}
+ {- [`Prev]:
+ Refers to the previous document in an ordered series of documents.
+ Some user agents also support the synonym "Previous".}
+ {- [`Contents]:
+ Refers to a document serving as a table of contents. Some user
+ agents also support the synonym ToC (from "Table of Contents").}
+ {- [`Index]:
+ Refers to a document providing an index for the current document.}
+ {- [`Glossary]:
+ Refers to a document providing a glossary of terms that pertain to
+ the current document.}
+ {- [`Copyright]:
+ Refers to a copyright statement for the current document.}
+ {- [`Chapter]:
+ Refers to a document serving as a chapter in a collection of documents.}
+ {- [`Section]:
+ Refers to a document serving as a section in a collection of documents.}
+ {- [`Subsection]:
+ Refers to a document serving as a subsection in a collection of documents.}
+ {- [`Appendix]:
+ Refers to a document serving as an appendix in a collection of documents.}
+ {- [`Help]:
+ Refers to a document offering help (more information, links to other
+ sources information, etc.)}
+ {- [`Bookmark]:
+ Refers to a bookmark. A bookmark is a link to a key entry point within
+ an extended document. The title attribute may be used, for example, to
+ label the bookmark. Note that several bookmarks may be defined in each
+ document.}} *)
+
+ type mediadesc =
+ [ `All | `Aural | `Braille | `Handheld | `Print
+ | `Projection | `Screen | `TTY | `TV ] list
+(** The MediaDesc attribute is a comma-separated list of media descriptors.
+ The following is a list of recognized media descriptors:
+ {ul
+ {- [`Screen]:
+ Intended for non-paged computer screens.}
+ {- [`TTY]:
+ Intended for media using a fixed-pitch character grid, such as
+ teletypes, terminals, or portable devices with limited display
+ capabilities.}
+ {- [`TV]:
+ Intended for television-type devices (low resolution, color,
+ limited scrollability).}
+ {- [`Projection]:
+ Intended for projectors.}
+ {- [`Handheld]:
+ Intended for handheld devices (small screen, monochrome,
+ bitmapped graphics, limited bandwidth).}
+ {- [`Print]:
+ Intended for paged, opaque material and for documents viewed
+ on screen in print preview mode.}
+ {- [`Braille]:
+ Intended for braille tactile feedback devices.}
+ {- [`Aural]:
+ Intended for speech synthesizers.}
+ {- [`All]:
+ Suitable for all devices.}}
+
+ Future versions of XHTML may introduce new values and may allow
+ parameterized values. To facilitate the introduction of these
+ extensions, conforming user agents must be able to parse the media
+ attribute value as follows:
+ {ol
+ {- The value is a comma-separated list of entries. For example,
+ [media="screen, 3d-glasses, print and resolution > 90dpi"]
+ is mapped to: ["screen"], ["3d-glasses"],
+ ["print and resolution > 90dpi"].}
+ {- Each entry is truncated just before the first character that
+ isn't a US ASCII letter [\[a-zA-Z\]] (ISO 10646 hex 41-5a,
+ 61-7a), digit [\[0-9\]] (hex 30-39), or hyphen-minus (hex 2d).
+ In the example, this gives: ["screen"], ["3d-glasses"], ["print"].}
+ {- A case-insensitive match is then made with the set of media
+ types defined above. User agents may ignore entries that
+ don't match. In the example we are left with ["screen"] and
+ ["print"].}}
+
+ Note. Style sheets may include media-dependent variations within them
+ (e.g., the [CSS \@media] construct). In such cases it may be appropriate
+ to use ["media=all"]. *)
+
+ type multilength = [ length | `Relative of int ]
+(** The value may be a Length or a relative length. A relative length
+ has the form ["i*"], where ["i"] is an integer. When allotting space
+ among elements competing for that space, user agents allot pixel
+ and percentage lengths first, then divide up remaining available
+ space among relative lengths. Each relative length receives a
+ portion of the available space that is proportional to the integer
+ preceding the ["*"]. The value ["*"] is equivalent to ["1*"]. Thus, if
+ 60 pixels of space are available after the user agent allots pixel
+ and percentage space, and the competing relative lengths are ["1*"],
+ ["2*"], and ["3*"], the ["1*"] will be allotted 10 pixels, the ["2*"] will be
+ allotted 20 pixels, and the ["3*"] will be allotted 30 pixels. *)
+
+ type multilengths = multilength list (* comma-separated *)
+(** A comma separated list of items of type MultiLength. *)
+
+ type number = int
+(** One or more digits. *)
+
+ type pixels = int
+
+(** The value is an integer that represents the number of pixels of
+ the canvas (screen, paper). Thus, the value ["50"] means fifty
+ pixels. For normative information about the definition of a pixel,
+ please consult CSS2.
+ @see <http://www.w3.org/TR/1998/REC-CSS2-19980512> CSS2 *)
+
+ type script = string
+(** Script data can be the content of the ["script"] element and the
+ value of intrinsic event attributes. User agents must not evaluate
+ script data as HTML markup but instead must pass it on as data to a
+ script engine.
+
+ The case-sensitivity of script data depends on the scripting
+ language.
+
+ Please note that script data that is element content may not
+ contain character references, but script data that is the value of
+ an attribute may contain them. *)
+
+ type shape = string
+(** The shape of a region. *)
+
+ type text = string
+(** Arbitrary textual data, likely meant to be human-readable. *)
+
+ type uri = string
+(** A Uniform Resource Identifier, as per RFC2396.
+ @see <http://www.ietf.org/rfc/rfc2396.txt> RFC2396 *)
+
+ type uris = uri
+(** A space-separated list of Uniform Resource Identifiers, as per RFC2396.
+ @see <http://www.ietf.org/rfc/rfc2396.txt> RFC2396 *)
+
+
+(** {1 Common Attributes} *)
+
+ type 'a attrib
+ type 'a attribs
+ (** ['a] is known as a {i phantom type}. The implementation is
+ actually monomorphic (the different element types are distinguished
+ by a homogeneous variable, such as their textual representation)
+ and the type variable [`a] is just used by the type checker.
+
+ NB: It might be possible to use polymorphic variants directly, without
+ phantom types, but the implementation is likely to be more involved. *)
+
+(** {2 Core} *)
+
+ type core = [ `Class | `Id | `Title ]
+
+ val a_class : nmtokens -> [>`Class] attrib
+(** This attribute assigns a class name or set of class names to an
+ element. Any number of elements may be assigned the same class
+ name or names. *)
+
+ val a_id : id -> [>`Id] attrib
+(** This attribute assigns a name to an element. This name must be
+ unique in a document. *)
+
+ val a_title : cdata -> [>`Title] attrib
+(** This attribute offers advisory information about the element for
+ which it is set. *)
+
+(** Values of the title attribute may be rendered by user agents in a
+ variety of ways. For instance, visual browsers frequently display
+ the title as a {i tool tip} (a short message that appears when the
+ pointing device pauses over an object). Audio user agents may
+ speak the title information in a similar context. *)
+
+(** The title attribute has an additional role when used with the [link]
+ element to designate an external style sheet. Please consult the
+ section on links and style sheets for details. *)
+
+(** {2 I18N} *)
+
+ type i18n = [ `XML_lang ]
+ val a_xml_lang : nmtoken -> [>`XML_lang] attrib
+
+(** {2 Style}
+ The Style collection is deprecated, because the Style Attribute Module is
+ deprecated. *)
+
+ type common = [ core | i18n ]
+
+(** {1 Modules, Element Sets and Attributes } *)
+
+(** {2 5.2. Core Modules} *)
+
+(** {3 5.2.1. Structure Module} *)
+
+ module STRUCTURE :
+ sig
+ type t = [ `Body | `Head | `Html | `Title ]
+ end
+
+ val a_profile : uri -> [>`Profile] attrib
+ val a_version : cdata -> [>`Version] attrib
+ val a_xmlns : [< `W3_org_1999_xhtml ] -> [>`XMLns] attrib
+
+(** {3 5.2.2. Text Module} *)
+
+ module TEXT :
+ sig
+ type heading = [ `H1 | `H2 | `H3 | `H4 | `H5 | `H6 ]
+ type block = [ `Address | `Blockquote | `Div | `P | `Pre ]
+ type inline =
+ [ `Abbr | `Acronym | `Br | `Cite | `Code | `Dfn
+ | `Em | `Kbd | `Q | `Samp | `Span | `Strong | `Var ]
+ type flow = [ heading | block | inline ]
+ end
+
+ val a_cite : uri -> [>`Cite] attrib
+ val a_xml_space : [< `Preserve ] -> [>`XML_space] attrib
+
+(** {3 5.2.3. Hypertext Module} *)
+
+ module HYPERTEXT :
+ sig
+ type inline = [ `A ]
+ type flow = inline
+ end
+
+ val a_accesskey : character -> [>`Accesskey] attrib
+(** This attribute assigns an access key to an element. An access key
+ is a single character from the document character
+ set. NB: authors should consider the input method of the
+ expected reader when specifying an accesskey. *)
+
+ val a_charset : charset -> [>`Charset] attrib
+(** This attribute specifies the character encoding of the resource
+ designated by the link. Please consult the section on character
+ encodings for more details. *)
+
+ val a_href : uri -> [>`Href] attrib
+(** This attribute specifies the location of a Web resource, thus
+ defining a link between the current element (the source anchor)
+ and the destination anchor defined by this attribute. *)
+
+ val a_hreflang : languagecode -> [>`Hreflang] attrib
+(** This attribute specifies the base language of the resource
+ designated by href and may only be used when href is specified. *)
+
+ val a_rel : linktypes -> [>`Rel] attrib
+(** This attribute describes the relationship from the current document
+ to the anchor specified by the href attribute. The value of this attribute
+ is a space-separated list of link types. *)
+
+ val a_rev : linktypes -> [>`Rev] attrib
+(** This attribute is used to describe a reverse link from the anchor specified
+ by the href attribute to the current document. The value of this attribute
+ is a space-separated list of link types. *)
+
+ val a_tabindex : number -> [>`Tabindex] attrib
+(** This attribute specifies the position of the current element in
+ the tabbing order for the current document. This value must be a
+ number between 0 and 32767. User agents should ignore leading
+ zeros. *)
+
+ val a_type : contenttype -> [>`Type] attrib
+(** This attribute gives an advisory hint as to the content type of
+ the content available at the link target address. It allows user
+ agents to opt to use a fallback mechanism rather than fetch the
+ content if they are advised that they will get content in a
+ content type they do not support.Authors who use this attribute
+ take responsibility to manage the risk that it may become
+ inconsistent with the content available at the link target
+ address. *)
+
+(** {3 5.2.3. List Module} *)
+
+ module LIST :
+ sig
+ type list = [ `Dl | `Ol | `Ul ]
+ type t = [ `Dd | `Dt | `Li ]
+ type flow = list
+ end
+
+(** {2 5.3. Applet Module}
+ This module is deprecated. Similar functionality
+ can be found in the Object Module. *)
+
+(** {2 5.4. Text Extension Modules} *)
+
+(** {3 5.4.1. Presentation Module} *)
+
+ module PRESENTATION :
+ sig
+ type block = [ `Hr ]
+ type inline = [ `B | `Big | `I | `Small | `Sub | `Sup | `Tt ]
+ end
+
+(** {3 5.4.2. Edit Module} *)
+
+(** {3 5.4.3. Bi-directional Text Module} *)
+
+(** {2 5.5. Forms Modules} *)
+
+(** {3 5.5.1. Basic Forms Module} *)
+
+ module FORMS :
+ sig
+ type t = [ `Option ]
+ type form = [ `Form ]
+ type formctrl_sans_label = [ `Input | `Select | `Textarea ]
+ type formctrl = [ formctrl_sans_label | `Label ]
+ type block = form
+ type inline_sans_label = formctrl_sans_label
+ type inline = formctrl
+ type flow_sans_label = [block | inline_sans_label ]
+ type flow = [ block | inline ]
+ end
+
+ val a_action : uri -> [>`Action] attrib
+(** This attribute specifies a form processing agent. User agent
+ behavior for a value other than an HTTP URI is undefined. *)
+
+ val a_checked : [< `Checked ] -> [>`Checked] attrib
+(** When the [type] attribute has the value ["radio"] or ["checkbox"],
+ this boolean attribute specifies that the button is on. User
+ agents must ignore this attribute for other control types. *)
+
+ val a_cols : number -> [>`Cols] attrib
+(** This attribute specifies the visible width in average character
+ widths. Users should be able to enter longer lines than this, so
+ user agents should provide some means to scroll through the
+ contents of the control when the contents extend beyond the
+ visible area. User agents may wrap visible text lines to keep long
+ lines visible without the need for scrolling. *)
+
+ val a_enctype : contenttype -> [>`Enctype] attrib
+ val a_for : idref -> [>`For] attrib
+ val a_maxlength : number -> [>`Maxlength] attrib
+ val a_method : [< `Get | `Post ] -> [>`Method] attrib
+ val a_multiple : [< `Multiple ] -> [>`Multiple] attrib
+
+ val a_name : cdata -> [>`Name] attrib
+(** This attribute assigns the control name. *)
+
+ val a_rows : number -> [>`Rows] attrib
+(** This attribute specifies the number of visible text lines. Users
+ should be able to enter more lines than this, so user agents
+ should provide some means to scroll through the contents of the
+ control when the contents extend beyond the visible area. *)
+
+ val a_selected : [< `Selected ] -> [>`Selected] attrib
+(** When set, this boolean attribute specifies that this option is pre-selected. *)
+
+ val a_size : number -> [>`Size] attrib
+ val a_src : uri -> [>`Src] attrib
+ val a_input_type :
+ [< `Text | `Password | `Checkbox | `Radio | `Submit | `Reset | `Hidden ] ->
+ [>`Input_Type] attrib
+
+ val a_value : cdata -> [>`Value] attrib
+(** This attribute specifies the initial value of the control. If this
+ attribute is not set, the initial value is set to the contents of
+ the [option] element. *)
+
+
+(** {3 5.5.2. Forms Module} *)
+
+(** {2 5.6. Table Modules} *)
+
+(** {3 5.6.1. Basic Tables Module} *)
+
+ module TABLES :
+ sig
+ type t = [ `Caption | `Td | `Th | `Tr ]
+ type block = [ `Table ]
+ type flow = block
+ end
+
+ val a_abbr : text -> [>`Abbr] attrib
+ val a_align : [< `Left | `Center | `Right | `Justify | `Char ] ->
+ [>`Align] attrib
+ val a_axis : cdata -> [>`Axis] attrib
+ val a_colspan : number -> [>`Colspan] attrib
+ val a_headers : idrefs -> [>`Headers] attrib
+ val a_rowspan : number -> [>`Rowspan] attrib
+ val a_scope : [< `Row | `Col | `Rowgroup | `Colgroup ] -> [>`Scope] attrib
+ val a_summary : text -> [>`Summary] attrib
+ val a_valign : [< `Top | `Middle | `Bottom | `Baseline ] ->
+ [>`Valign] attrib
+
+(** {3 5.6.2. Tables Module} *)
+
+ val a_border : pixels -> [>`Border] attrib
+ val a_cellpadding : length -> [>`Cellpadding] attrib
+ val a_cellspacing : length -> [>`Cellspacing] attrib
+ val a_datapagesize : cdata -> [>`Datapagesize] attrib
+ val a_frame :
+ [< `Void | `Above | `Below | `Hsides | `LHS | `RHS
+ | `Vsides | `Box | `Border ] -> [>`Frame] attrib
+ val a_rules : [< `None | `Groups | `Rows | `Cols | `All ] -> [>`Rules] attrib
+ val a_char : character -> [>`Char] attrib
+ val a_charoff : length -> [>`Charoff] attrib
+
+(** {2 5.7. Image Module} *)
+
+ module IMAGE :
+ sig
+ type inline = [ `Img ]
+ end
+
+ val a_alt : text -> [>`Alt] attrib
+ val a_height : length -> [>`Height] attrib
+ val a_longdesc : uri -> [>`Longdesc] attrib
+ val a_width : length -> [>`Width] attrib
+
+(** {2 5.8. Client-side Image Map Module} *)
+
+(** {2 5.9. Server-side Image Map Module} *)
+
+(** {2 5.10. Object Module} *)
+
+(** {2 5.11. Frames Module} *)
+
+ val a_fs_rows : multilengths -> [>`FS_Rows] attrib
+ val a_fs_cols : multilengths -> [>`FS_Cols] attrib
+ val a_frameborder : [< `Zero | `One ] -> [>`Frameborder] attrib
+ val a_marginheight : pixels -> [>`Marginheight] attrib
+ val a_marginwidth : pixels -> [>`Marginwidth] attrib
+ val a_noresize : [< `Noresize ] -> [>`Noresize] attrib
+ val a_scrolling : [< `Yes | `No | `Auto ] -> [>`Scrolling] attrib
+
+(** {2 5.12. Target Module} *)
+
+ val a_target : frametarget -> [>`Target] attrib
+
+(** {2 5.13. Iframe Module} *)
+
+(** {2 5.14. Intrinsic Events Module} *)
+
+(** {2 5.15. Metainformation Module} *)
+
+ module METAINFORMATION :
+ sig
+ type t = [ `Meta ]
+ end
+
+ val a_content : cdata -> [>`Content] attrib
+ val a_http_equiv : nmtoken -> [>`Http_equiv] attrib
+ val a_scheme : cdata -> [>`Scheme] attrib
+
+(** {2 5.16. Scripting Module} *)
+
+(** {2 5.17. Style Sheet Module} *)
+
+ module STYLE_SHEET :
+ sig
+ type t = [ `Style ]
+ end
+
+ val a_media : mediadesc -> [>`Media] attrib
+
+(** {2 5.18. Style Attribute Module} *)
+
+(** {2 5.19. Link Module} *)
+
+ module LINK :
+ sig
+ type t = [ `Link ]
+ end
+
+(** {2 5.20. Base Module} *)
+
+ module BASE :
+ sig
+ type t = [ `Base ]
+ end
+
+(** {2 5.21. Name Identification Module}
+ This module is deprecated in XHTML 1.1, but supported for XHTML 1.0
+ using [`Name_01_00] . *)
+
+(** {2 5.22. Legacy Module} *)
+
+(** {1 Combined Element Sets:} *)
+
+ type block =
+ [ TEXT.block | PRESENTATION.block | FORMS.block | TABLES.block ]
+ type block_sans_form =
+ [ TEXT.block | PRESENTATION.block | TABLES.block ]
+
+ type flow =
+ [ TEXT.flow | HYPERTEXT.flow | LIST.flow | FORMS.flow | TABLES.flow ]
+ type flow_sans_table =
+ [ TEXT.flow | HYPERTEXT.flow | LIST.flow | FORMS.flow ]
+
+ type inline =
+ [ TEXT.inline | HYPERTEXT.inline | PRESENTATION.inline
+ | FORMS.inline | IMAGE.inline]
+ type inline_sans_a =
+ [ TEXT.inline | PRESENTATION.inline
+ | FORMS.inline | IMAGE.inline]
+ type inline_sans_label =
+ [ TEXT.inline | HYPERTEXT.inline | PRESENTATION.inline
+ | FORMS.inline_sans_label | IMAGE.inline]
+
+ type heading = TEXT.heading
+
+(** {1 Elements} *)
+
+ type 'a elt
+
+(** {2 Element Constructor Types} *)
+
+ type ('a, 'b) nullary = ?a:('a attrib list) -> unit -> 'b elt
+ type ('a, 'b, 'c) unary = ?a:('a attrib list) -> 'b elt -> 'c elt
+ type ('a, 'b, 'c, 'd) binary = ?a:('a attrib list) -> 'b elt -> 'c elt -> 'd elt
+
+ type ('a, 'b, 'c) star = ?a:('a attrib list) -> 'b elt list -> 'c elt
+(** Star '*' denotes any number of children, uncluding zero. *)
+
+ type ('a, 'b, 'c) plus = ?a:('a attrib list) -> 'b elt -> 'b elt list -> 'c elt
+(** Plus '+' requires at least one child. *)
+
+(** {2 Structure} *)
+
+ type html = [`Html] elt
+
+ val html : ?a:([< i18n | `Version | `XMLns ] attrib list) ->
+ [< `Head ] elt -> [< `Body | `Frameset ] elt -> html
+ val head : ([< i18n | `Profile ],
+ [< `Title | `Meta | `Link | `Style | `Base ], [>`Head]) plus
+ val title : ([< i18n ], [< `PCDATA ], [>`Title]) unary
+ val body : ([< common ], [< heading | block | LIST.list ], [>`Body]) star
+
+(** {2 Data} *)
+
+ val pcdata : string -> [>`PCDATA] elt
+ val entity : string -> [>`PCDATA] elt
+ val space : unit -> [>`PCDATA] elt
+
+(** {2 Text} *)
+
+ val h1 : ([< common ], [< `PCDATA | inline ], [>`H1]) star
+ val h2 : ([< common ], [< `PCDATA | inline ], [>`H2]) star
+ val h3 : ([< common ], [< `PCDATA | inline ], [>`H3]) star
+ val h4 : ([< common ], [< `PCDATA | inline ], [>`H4]) star
+ val h5 : ([< common ], [< `PCDATA | inline ], [>`H5]) star
+ val h6 : ([< common ], [< `PCDATA | inline ], [>`H6]) star
+
+ val address : ([< common ], [< `PCDATA | inline ], [>`Address]) star
+ val blockquote : ([< common | `Cite ],
+ [< `PCDATA | heading | block | LIST.list ], [>`Blockquote]) star
+ val div : ([< common ], [< `PCDATA | flow ], [>`Div]) star
+ val p : ([< common ], [< `PCDATA | inline ], [>`P]) star
+ val pre : ([< common | `XML_space ], [< `PCDATA | inline ], [>`Pre]) star
+
+ val abbr : ([< common ], [< `PCDATA | inline ], [>`Abbr]) star
+ val acronym : ([< common ], [< `PCDATA | inline ], [>`Acronym]) star
+ val br : ([< core ], [>`Br]) nullary
+ val cite : ([< common ], [< `PCDATA | inline ], [>`Cite]) star
+ val code : ([< common ], [< `PCDATA | inline ], [>`Code]) star
+ val dfn : ([< common ], [< `PCDATA | inline ], [>`Dfn]) star
+ val em : ([< common ], [< `PCDATA | inline ], [>`Em]) star
+ val kbd : ([< common ], [< `PCDATA | inline ], [>`Kbd]) star
+ val q : ([< common | `Cite ], [< `PCDATA | inline ], [>`Q]) star
+ val samp : ([< common ], [< `PCDATA | inline ], [>`Samp]) star
+ val span : ([< common ], [< `PCDATA | inline ], [>`Span]) star
+ val strong : ([< common ], [< `PCDATA | inline ], [>`Strong]) star
+
+(** {2 Hypertext} *)
+
+ val a : ([< common | `Accesskey | `Charset | `Href | `Hreflang
+ | `Name_01_00 | `Rel | `Rev | `Tabindex | `Target | `Type ],
+ [< `PCDATA | inline_sans_a ], [>`A]) star
+
+(** {2 List} *)
+
+ val dl : ([< common ], [< `Dt | `Dd ], [>`Dl]) plus
+ val ol : ([< common ], [< `Li ], [>`Ol]) plus
+ val ul : ([< common ], [< `Li ], [>`Ul]) plus
+ val dd : ([< common ], [< `PCDATA | flow ], [>`Dd]) star
+ val dt : ([< common ], [< `PCDATA | inline ], [>`Dt]) star
+ val li : ([< common ], [< `PCDATA | flow ], [>`Li]) star
+
+(** {2 Presentation} *)
+
+ val hr : ([< common ], [>`Hr]) nullary
+ val b : ([< common ], [< `PCDATA | inline ], [>`B]) star
+ val big : ([< common ], [< `PCDATA | inline ], [>`Big]) star
+ val i : ([< common ], [< `PCDATA | inline ], [>`I]) star
+ val small : ([< common ], [< `PCDATA | inline ], [>`Small]) star
+ val sub : ([< common ], [< `PCDATA | inline ], [>`Sub]) star
+ val sup : ([< common ], [< `PCDATA | inline ], [>`Sup]) star
+ val tt : ([< common ], [< `PCDATA | inline ], [>`Tt]) star
+
+(** {2 Forms} *)
+
+(** {3 Basic Forms} *)
+
+(** One can use [open Basic_Forms] to enable basic forms. *)
+
+ module Basic_Forms :
+ sig
+ val form : action:uri ->
+ ([< common | `Enctype | `Method | `Name_01_00 | `Target ],
+ [< `PCDATA | heading | LIST.list | block_sans_form ], [>`Form]) star
+ val input : ([< common | `Accesskey | `Checked | `Maxlength | `Name | `Size
+ | `Src | `Tabindex | `Input_Type | `Value ], [>`Input]) nullary
+ val label : ([< common | `Accesskey | `For ],
+ [< `PCDATA | inline_sans_label ], [>`Label]) star
+ val option : ([< common | `Selected | `Value ],
+ [< `PCDATA ], [>`Option]) unary
+ val select : ([< common | `Multiple | `Name | `Size | `Tabindex ],
+ [< `Option ], [>`Select]) plus
+ val textarea : rows:number -> cols:number ->
+ ([< common | `Accesskey | `Name | `Tabindex ],
+ [< `PCDATA ], [>`Textarea]) unary
+ end
+
+(** {3 Forms} *)
+
+(** General forms are not implemented yet, but one can use [open Basic_Forms]
+ to enable basic forms. *)
+
+(** {2 Tables} *)
+
+(** {3 Basic Tables} *)
+
+(** One can use [open Basic_Tables] to switch globally to basic tables. *)
+
+ module Basic_Tables :
+ sig
+ val a_align : [< `Left | `Center | `Right ] -> [>`Align] attrib
+ val a_scope : [< `Row | `Col ] -> [>`Scope] attrib
+ val a_valign : [< `Top | `Middle | `Bottom ] -> [>`Valign] attrib
+
+ val caption : ([< common ], [< `PCDATA | inline ], [>`Caption]) star
+ val table : ?caption:([< `Caption ] elt) ->
+ ([< common | `Summary | `Width ], [< `Tr ], [>`Table]) plus
+ val td : ([< common | `Abbr | `Align | `Axis | `Colspan | `Headers | `Rowspan
+ | `Scope | `Valign ], [< `PCDATA | flow_sans_table ], [>`Td]) star
+ val th : ([< common | `Abbr | `Align | `Axis | `Colspan | `Headers | `Rowspan
+ | `Scope | `Valign ], [< `PCDATA | flow_sans_table ], [>`Th]) star
+ val tr : ([< common | `Align | `Valign ], [< `Td | `Th ], [>`Tr]) plus
+ end
+
+(** {3 Tables} *)
+
+ val caption : ([< common ], [< `PCDATA | inline ], [>`Caption]) star
+
+ val table : ?caption:([< `Caption ] elt) ->
+ ?columns:([< `Cols of ([< `Col ] elt list)
+ | `Colgroups of ([< `Colgroup ] elt list) ]) ->
+ ([< common | `Border | `Cellpadding | `Cellspacing | `Datapagesize
+ | `Frame | `Rules | `Summary | `Width ], [< `Tr ], [>`Table]) plus
+
+ val tablex : ?caption:([< `Caption ] elt) ->
+ ?columns:([< `Cols of ([< `Col ] elt list)
+ | `Colgroups of ([< `Colgroup ] elt list) ]) ->
+ ?thead:([< `Thead ] elt) -> ?tfoot:([< `Tfoot ] elt) ->
+ ([< common | `Border | `Cellpadding | `Cellspacing | `Datapagesize
+ | `Frame | `Rules | `Summary | `Width ], [< `Tbody ], [>`Table]) plus
+
+ val td : ([< common | `Abbr | `Align | `Axis | `Char | `Charoff
+ | `Colspan | `Headers | `Rowspan | `Scope | `Valign ],
+ [< `PCDATA | flow ], [>`Td]) star
+ val th : ([< common | `Abbr | `Align | `Axis | `Char | `Charoff
+ | `Colspan | `Headers | `Rowspan | `Scope | `Valign ],
+ [< `PCDATA | flow ], [>`Th]) star
+ val tr : ([< common | `Align | `Char | `Charoff | `Valign ],
+ [< `Td | `Th ], [>`Tr]) plus
+
+ val col : ([< common | `Align | `Char | `Charoff
+ | `Span | `Valign | `Width ], [>`Col]) nullary
+ val colgroup : ([< common | `Align | `Char | `Charoff
+ | `Span | `Valign | `Width ], [< `Col ], [>`Colgroup]) star
+ val thead : ([< common | `Align | `Char | `Charoff | `Valign ],
+ [< `Tr ], [>`Thead]) plus
+ val tbody : ([< common | `Align | `Char | `Charoff | `Valign ],
+ [< `Tr ], [>`Tbody]) plus
+ val tfoot : ([< common | `Align | `Char | `Charoff | `Valign ],
+ [< `Tr ], [>`Tfoot]) plus
+
+(** {2 Image} *)
+
+ val img : src:uri -> alt:text ->
+ ([< common | `Height | `Longdesc | `Name_01_00 | `Width ], [>`Img]) nullary
+
+(** {2 Frames} *)
+
+ val frameset : ?noframes:([< `Noframes ] elt) ->
+ ([< core | `FS_Rows | `FS_Cols ], [< `Frameset | `Frame ], [>`Frameset]) plus
+
+ val frame : src:uri ->
+ ([< core | `Frameborder | `Longdesc | `Marginheight | `Marginwidth
+ | `Name_01_00 | `Noresize | `Scrolling ], [>`Frame]) nullary
+
+ val noframes : ([< common ], [< `Body ], [>`Noframes]) unary
+
+(** {2 Meta} *)
+
+ val meta : content:cdata ->
+ ([< i18n | `Http_equiv | `Name | `Scheme ], [>`Meta]) nullary
+
+(** {2 Style Sheets} *)
+
+ val style : contenttype:contenttype ->
+ ([< i18n | `Media | `Title | `XML_space ], [< `PCDATA ], [>`Style]) star
+
+(** {2 Link} *)
+
+ val link : ([< common | `Charset | `Href | `Hreflang | `Media
+ | `Rel | `Rev | `Target | `Type ], [>`Link]) nullary
+
+(** {2 Base} *)
+
+ val base : href:uri -> unit -> [>`Base] elt
+
+(** {1 Output} *)
+
+(** [?encode] maps strings to HTML and {e must} encode the unsafe characters
+ ['<'], ['>'], ['"'], ['&'] and the control characters 0-8, 11-12, 14-31, 127
+ to HTML entities. [XML.encode_unsafe] is the default for [?encode] in [output]
+ and [pretty_print] below. Other implementations are provided by the module
+ [Netencoding] in the
+ {{:http://www.ocaml-programming.de/programming/ocamlnet.html}OcamlNet} library, e.g.:
+ [let encode = Netencoding.Html.encode ~in_enc:`Enc_iso88591 ~out_enc:`Enc_usascii ()],
+ Where national characters are replaced by HTML entities.
+ The user is of course free to write her own implementation.
+ @see <http://www.ocaml-programming.de/programming/ocamlnet.html> OcamlNet *)
+
+(** [~encoding] is the official name of the external character set encoding that
+ is used by [outs : string -> unit]. *)
+
+ val output : ?encode:(string -> string) -> ?encoding:string ->
+ (string -> unit) -> html -> unit
+
+ val pretty_print : ?width:int ->
+ ?encode:(string -> string) -> ?encoding:string ->
+ (string -> unit) -> html -> unit
+
+(** {1 Tools} *)
+
+ val version : string
+ val standard : uri
+ val validator : uri
+ val validator_icon : unit -> [>`A] elt
+(** A hyperlink to the W3C validator, including the logo.
+ @see <http://validator.w3.org> Validator *)
+
+ val addto_class : string -> 'a elt -> 'a elt
+(** Add the element and all its subelements to a class. Note that this
+ is only almost typesafe, because a few elements from the structure class
+ do not support the class attribute. On the other hand, listing all
+ allowed elements would be too tedious right now. *)
+
+ val addto_class1 : string -> 'a elt -> 'a elt
+(** Add the element to a class. *)
+
+ val set_rowspan : int -> ([< `Th | `Td ] as 'a) elt -> 'a elt
+(** Set the rowspan attribute for the element. *)
+
+ val rewrite_hrefs : (string -> string) -> 'a elt -> 'a elt
+ val all_hrefs : 'a elt -> uri list
+ val all_anchors : 'a elt -> id list
+
+(*
+ val amap : (string -> 'a attribs -> 'a attribs) -> 'b elt -> 'b elt
+ val amap1 : (string -> 'a attribs -> 'a attribs) -> 'b elt -> 'b elt
+
+ val rm_attrib : (string -> bool) -> 'a attribs -> 'a attribs
+ val rm_attrib_from_list :
+ (string -> bool) -> (string -> bool) -> 'a attribs -> 'a attribs
+
+(** Exporting the following will drive a hole through the type system,
+ because they allow to add any attribute to any element. *)
+ val add_int_attrib : string -> int -> 'a attribs -> 'a attribs
+ val add_string_attrib : string -> string -> 'a attribs -> 'a attribs
+ val add_comma_sep_attrib : string -> string -> 'a attribs -> 'a attribs
+ val add_space_sep_attrib : string -> string -> 'a attribs -> 'a attribs
+*)
+
+ end
+
+(** An alias for XHTML 1.1 (for symmetry):
+ @see <http://www.w3.org/TR/xhtml11/> XHTML 1.1 - Module-based XHTML *)
+module type T_01_01 = T
+
+(** XHTML 1.0 includes some deprecated features that since
+ have been removed from XHTML 1.1:
+ @see <http://www.w3.org/TR/xhtml11/changes.html#a_changes> Changes from XHTML 1.0 Strict
+ @see <http://www.w3.org/TR/2000/REC-xhtml1-20000126/> XHTML 1.0: The Extensible HyperText Markup Language *)
+module type T_01_00 =
+ sig
+ include T
+
+(** XHTML 1.1 has removed the name attribute from several elements: *)
+ val a_name_01_00 : cdata -> [>`Name_01_00] attrib
+ end
+
+
+module M : T
+module M_01_01 : T_01_01
+module M_01_00 : T_01_00
+
--- /dev/null
+(* $Id: xML.ml,v 1.14 2004/12/13 14:57:45 ohl Exp $
+
+ Copyright (C) 2004 by Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+
+ XHTML is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ XHTML is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+
+type separator = Space | Comma
+
+let separator_to_string = function
+ | Space -> " "
+ | Comma -> ", "
+
+type aname = string
+type attrib =
+ | AInt of aname * int
+ | AStr of aname * string
+ | AStrL of separator * aname * string list
+type attribs = attrib list
+
+let int_attrib name value = AInt (name, value)
+let string_attrib name value = AStr (name, value)
+let space_sep_attrib name values = AStrL (Space, name, values)
+let comma_sep_attrib name values = AStrL (Comma, name, values)
+
+let attrib_to_string encode = function
+ | AInt (name, i) -> name ^ "=\"" ^ string_of_int i ^ "\""
+ | AStr (name, s) -> name ^ "=\"" ^ encode s ^ "\""
+ | AStrL (sep, name, slist) ->
+ name ^ "=\"" ^ encode (String.concat (separator_to_string sep) slist) ^ "\""
+
+let rec get_int_attrib name = function
+ | [] -> raise Not_found
+ | AInt (name', value) :: tail when name' = name -> value
+ | _ :: tail -> get_int_attrib name tail
+
+let rec get_string_attrib name = function
+ | [] -> raise Not_found
+ | AStr (name', value) :: tail when name' = name -> value
+ | _ :: tail -> get_string_attrib name tail
+
+let rec get_attrib_list name = function
+ | [] -> raise Not_found
+ | AStrL (_, name', value) :: tail when name' = name -> value
+ | _ :: tail -> get_attrib_list name tail
+
+type ename = string
+type elt =
+ | Empty
+ | Comment of string
+ | PCDATA of string
+ | Entity of string
+ | Leaf of ename * attrib list
+ | Node of ename * attrib list * elt list
+
+let amap1 f = function
+ | Empty | Comment _ | PCDATA _ | Entity _ as elt -> elt
+ | Leaf (name, attribs) -> Leaf (name, f name attribs)
+ | Node (name, attribs, elts) -> Node (name, f name attribs, elts)
+
+let rec amap f = function
+ | Empty | Comment _ | PCDATA _ | Entity _ as elt -> elt
+ | Leaf (name, attribs) -> Leaf (name, f name attribs)
+ | Node (name, attribs, elts) -> Node (name, f name attribs, List.map (amap f) elts)
+
+let rec add_int_attrib name value = function
+ | [] -> [AInt (name, value)]
+ | AInt (name', _) as head :: tail when name' = name ->
+ AInt (name, value) :: tail
+ | head :: tail -> head :: add_int_attrib name value tail
+
+let rec rm_attrib is_attrib = function
+ | [] -> []
+ | (AInt (name, _) | AStr (name, _) | AStrL (_, name, _)) :: tail
+ when is_attrib name -> rm_attrib is_attrib tail
+ | head :: tail -> head :: rm_attrib is_attrib tail
+
+let rec map_int_attrib is_attrib f = function
+ | [] -> []
+ | AInt (name, value) :: tail when is_attrib name ->
+ AInt (name, f value) :: map_int_attrib is_attrib f tail
+ | head :: tail -> head :: map_int_attrib is_attrib f tail
+
+let rec add_string_attrib name value = function
+ | [] -> [AStr (name, value)]
+ | AStr (name', _) :: tail when name' = name -> AStr (name, value) :: tail
+ | head :: tail -> head :: add_string_attrib name value tail
+
+let rec map_string_attrib is_attrib f = function
+ | [] -> []
+ | AStr (name, value) :: tail when is_attrib name ->
+ AStr (name, f value) :: map_string_attrib is_attrib f tail
+ | head :: tail -> head :: map_string_attrib is_attrib f tail
+
+let rec add_space_sep_attrib name value = function
+ | [] -> [AStrL (Space, name, [value])]
+ | AStrL (Space, name', values') :: tail when name' = name ->
+ AStrL (Space, name, value :: values') :: tail
+ | head :: tail -> head :: add_space_sep_attrib name value tail
+
+let rec add_comma_sep_attrib name value = function
+ | [] -> [AStrL (Comma, name, [value])]
+ | AStrL (Comma, name', values') :: tail when name' = name ->
+ AStrL (Comma, name, value :: values') :: tail
+ | head :: tail -> head :: add_comma_sep_attrib name value tail
+
+let rec rm_attrib_from_list is_attrib is_value = function
+ | [] -> []
+ | AStrL (sep, name, values) :: tail when is_attrib name ->
+ begin match List.filter (fun v -> not (is_value v)) values with
+ | [] -> tail
+ | values' -> AStrL (sep, name, values') :: tail
+ end
+ | head :: tail -> head :: rm_attrib_from_list is_attrib is_value tail
+
+let rec map_string_attrib_in_list is_attrib f = function
+ | [] -> []
+ | AStrL (sep, name, values) :: tail when is_attrib name ->
+ AStrL (sep, name, List.map f values) :: map_string_attrib_in_list is_attrib f tail
+ | head :: tail -> head :: map_string_attrib_in_list is_attrib f tail
+
+let rec fold of_empty of_comment of_pcdata of_entity of_leaf of_node = function
+ | Empty -> of_empty ()
+ | Comment s -> of_comment s
+ | PCDATA s -> of_pcdata s
+ | Entity s -> of_entity s
+ | Leaf (name, attribs) -> of_leaf name attribs
+ | Node (name, attribs, elts) ->
+ of_node name attribs
+ (List.map (fold of_empty of_comment of_pcdata of_entity of_leaf of_node) elts)
+
+(* (* is this AT ALL useful??? *)
+let rec foldx of_empty of_comment of_pcdata of_entity of_leaf of_node update_state state = function
+ | Empty -> of_empty ()
+ | Comment s -> of_comment s
+ | PCDATA s -> of_pcdata s
+ | Entity s -> of_entity s
+ | Leaf (name, attribs) -> of_leaf state name attribs
+ | Node (name, attribs, elts) ->
+ of_node state name attribs
+ (List.map (foldx of_empty of_comment of_pcdata of_entity of_leaf of_node
+ update_state (update_state name attribs state)) elts)
+*)
+
+let all_attribs access ?(is_elt = fun ename -> true) aname elt =
+ let access' ename attribs =
+ if is_elt ename then
+ try [access aname attribs] with Not_found -> []
+ else
+ [] in
+ fold (fun () -> []) (fun c -> []) (fun p -> []) (fun e -> []) access'
+ (fun ename attribs elts -> access' ename attribs @ List.flatten elts)
+ elt
+
+let all_int_attribs = all_attribs get_int_attrib
+let all_string_attribs = all_attribs get_string_attrib
+let all_attribs_list = all_attribs get_attrib_list
+
+let all_entities elt =
+ fold (fun () -> []) (fun c -> []) (fun p -> []) (fun e -> [e])
+ (fun ename attribs -> []) (fun ename attribs elts -> List.flatten elts)
+ elt
+
+let empty () = Empty
+
+let comment c = Comment c
+
+let pcdata d = PCDATA d
+let entity e = Entity e
+
+let leaf ?a name =
+ match a with
+ | Some a -> Leaf (name, a)
+ | None -> Leaf (name, [])
+
+let node ?a name children =
+ match a with
+ | Some a -> Node (name, a, children)
+ | None -> Node (name, [], children)
+
+let rec flatmap f = function
+ | [] -> []
+ | x :: rest -> f x @ flatmap f rest
+
+let translate root_leaf root_node sub_leaf sub_node update_state state elt =
+ let rec translate' state = function
+ | (Empty | Comment _ | PCDATA _ | Entity _) as elt -> [elt]
+ | Leaf (name, attribs) ->
+ sub_leaf state name attribs
+ | Node (name, attribs, elts) ->
+ sub_node state name attribs
+ (flatmap (translate' (update_state name attribs state)) elts) in
+ match elt with
+ | (Empty | Comment _ | PCDATA _ | Entity _) as elt -> elt
+ | Leaf (name, attribs) ->
+ root_leaf name attribs
+ | Node (name, attribs, elts) ->
+ root_node name attribs (flatmap (translate' state) elts)
+
+(** {1 Output} *)
+
+module Elt_Set =
+ Set.Make (struct type t = ename let compare = compare end)
+
+let elt_set_of_list names =
+ List.fold_right
+ (fun n set -> Elt_Set.add (String.lowercase n) set) names Elt_Set.empty
+
+type io_state =
+ { preformatted : bool;
+ preformatted_elts : Elt_Set.t;
+ allow_break : bool;
+ no_break_elts : Elt_Set.t }
+
+let initial_io_state ?(preformatted = []) ?(no_break = []) () =
+ let preformatted = elt_set_of_list preformatted
+ and no_break = elt_set_of_list no_break in
+ { preformatted = false;
+ preformatted_elts = preformatted;
+ allow_break = true;
+ no_break_elts = Elt_Set.union no_break preformatted }
+
+let update_io_state name attribs ios =
+ { ios with
+ allow_break = not (Elt_Set.mem (String.lowercase name) ios.no_break_elts);
+ preformatted = Elt_Set.mem (String.lowercase name) ios.preformatted_elts }
+
+(** {2 No Pretty Printing} *)
+
+let is_control c =
+ let cc = Char.code c in
+ (cc <= 8 || cc = 11 || cc = 12 || (14 <= cc && cc <= 31) || cc = 127)
+
+let encode_unsafe s =
+ let b = Buffer.create (String.length s) in
+ String.iter (function
+ | '<' -> Buffer.add_string b "<"
+ | '>' -> Buffer.add_string b ">"
+ | '"' -> Buffer.add_string b """
+ | '&' -> Buffer.add_string b "&"
+ | c when is_control c ->
+ Buffer.add_string b ("&#" ^ string_of_int (Char.code c) ^ ";")
+ | c -> Buffer.add_char b c) s;
+ Buffer.contents b
+
+let encode_unsafe_and_at s =
+ let b = Buffer.create (String.length s) in
+ String.iter (function
+ | '<' -> Buffer.add_string b "<"
+ | '>' -> Buffer.add_string b ">"
+ | '"' -> Buffer.add_string b """
+ | '&' -> Buffer.add_string b "&"
+ | '@' -> Buffer.add_string b "@"
+ | c when is_control c ->
+ Buffer.add_string b ("&#" ^ string_of_int (Char.code c) ^ ";")
+ | c -> Buffer.add_char b c) s;
+ Buffer.contents b
+
+let newline ios outs =
+ if ios.allow_break then
+ outs "\n"
+
+let rec output' ios encode outs = function
+ | Empty -> ()
+ | Comment c ->
+ outs ("<!-- " ^ encode c ^ " -->");
+ newline ios outs
+ | PCDATA d ->
+ outs (encode d);
+ newline ios outs
+ | Entity e ->
+ outs ("&" ^ e ^ ";"); (* No {e not} encode these! *)
+ newline ios outs
+ | Leaf (name, attribs) ->
+ outs ("<" ^ name);
+ List.iter (fun a -> outs " "; outs (attrib_to_string encode a)) attribs;
+ outs " />";
+ newline ios outs
+ | Node (name, attribs, children) ->
+ let ios_elt = update_io_state name attribs ios in
+ outs ("<" ^ name);
+ List.iter (fun a -> outs " "; outs (attrib_to_string encode a)) attribs;
+ outs ">";
+ newline ios_elt outs;
+ List.iter (output' ios_elt encode outs) children;
+ outs ("</" ^ name ^ ">");
+ newline ios outs
+
+let output ?preformatted ?no_break ?(encode = encode_unsafe) outs elt =
+ output' (initial_io_state ?preformatted ?no_break ()) encode outs elt
+
+(** {2 Pretty Printed} *)
+
+let force_newline ios f () =
+ if ios.allow_break then
+ Format.pp_force_newline f ()
+
+let print_cut ios f () =
+ if ios.allow_break then
+ Format.pp_print_cut f ()
+
+let open_box ios f n =
+ if ios.allow_break then
+ Format.pp_open_box f n
+
+let close_box ios f () =
+ if ios.allow_break then
+ Format.pp_close_box f ()
+
+let is_white = function
+ | ' ' | '\t' | '\n' | '\r' -> true
+ | _ -> false
+
+let iter_words fword fwhite s =
+ let last = String.length s - 1 in
+ let rec skip_non_white c =
+ if c > last then
+ c
+ else if is_white s.[c] then
+ c
+ else
+ skip_non_white (succ c) in
+ let rec skip_white c =
+ if c > last then
+ c
+ else if is_white s.[c] then
+ skip_white (succ c)
+ else
+ c in
+ let rec iter_words' c =
+ if c > last then begin
+ ()
+ end else if is_white s.[c] then begin
+ fwhite ();
+ iter_words' (skip_white (succ c))
+ end else begin
+ let c' = skip_non_white (succ c) in
+ fword (String.sub s c (c' - c));
+ iter_words' c'
+ end in
+ iter_words' 0
+
+let print_string ios f s =
+ if ios.preformatted then
+ Format.pp_print_string f s
+ else
+ iter_words (Format.pp_print_string f) (Format.pp_print_space f) s
+
+let print_space ios f () =
+ Format.pp_print_space f ()
+
+let rec to_formatter ios encode f = function
+ | Empty -> ()
+ | Comment c ->
+ force_newline ios f ();
+ print_string ios f ("<!-- " ^ encode c ^ " -->");
+ force_newline ios f ()
+ | PCDATA d ->
+ print_string ios f (encode d);
+ print_cut ios f ()
+ | Entity e ->
+ print_string ios f ("&" ^ e ^ ";"); (* NO encoding! *)
+ print_cut ios f ()
+ | Leaf (name, attribs) ->
+ print_cut ios f ();
+ open_box ios f 4;
+ print_string ios f ("<" ^ name);
+ List.iter (fun a ->
+ print_space ios f ();
+ Format.pp_print_string f (attrib_to_string encode a)) attribs;
+ print_string ios f " />";
+ close_box ios f ();
+ print_cut ios f ()
+ | Node (name, attribs, children) ->
+ print_cut ios f ();
+ let ios_elt = update_io_state name attribs ios in
+ open_box ios f 2;
+ open_box ios f 4;
+ print_string ios f ("<" ^ name);
+ List.iter (fun a ->
+ print_space ios f ();
+ Format.pp_print_string f (attrib_to_string encode a)) attribs;
+ print_string ios f ">";
+ close_box ios f ();
+ print_cut ios_elt f ();
+ List.iter (to_formatter ios_elt encode f) children;
+ close_box ios f ();
+ print_cut ios_elt f ();
+ print_string ios f ("</" ^ name ^ ">");
+ print_cut ios f ()
+
+let pretty_print ?(width = 132) ?preformatted ?no_break
+ ?(encode = encode_unsafe) outs element =
+ Format.pp_set_margin Format.str_formatter width;
+ to_formatter (initial_io_state ?preformatted ?no_break ())
+ encode Format.str_formatter element;
+ outs (Format.flush_str_formatter ())
+
+let decl ?(version = "1.0") ?(encoding = "ISO-8859-1") outs () =
+ outs ("<?xml version=\"" ^ version ^ "\" encoding=\"" ^ encoding ^ "\"?>\n")
--- /dev/null
+(* $Id: xML.mli,v 1.15 2004/12/13 14:57:45 ohl Exp $
+
+ Copyright (C) 2004 by Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+
+ XHTML is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ XHTML is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+
+type attrib
+type aname = string
+val int_attrib : aname -> int -> attrib
+val string_attrib : aname -> string -> attrib
+val space_sep_attrib : aname -> string list -> attrib
+val comma_sep_attrib : aname -> string list -> attrib
+
+val get_int_attrib : aname -> attrib list -> int
+val get_string_attrib : aname -> attrib list -> string
+val get_attrib_list : aname -> attrib list -> string list
+
+type elt
+type ename = string
+val empty : unit -> elt
+
+val comment : string -> elt
+val pcdata : string -> elt
+val entity : string -> elt
+(** Neither [comment], [pcdata] nor [entity] check their argument for invalid
+ characters. Unsafe characters will be escaped later by the output routines. *)
+
+val leaf : ?a:(attrib list) -> ename -> elt
+val node : ?a:(attrib list) -> ename -> elt list -> elt
+(** NB: [Leaf ("foo", []) -> "<foo />"], but [Node ("foo", [], []) -> "<foo></foo>"] *)
+
+val encode_unsafe : string -> string
+(** The encoder maps strings to HTML and {e must} encode the unsafe characters
+ ['<'], ['>'], ['"'], ['&'] and the control characters 0-8, 11-12, 14-31, 127
+ to HTML entities. [encode_unsafe] is the default for [?encode] in [output]
+ and [pretty_print] below. Other implementations are provided by the module
+ [Netencoding] in the
+ {{:http://www.ocaml-programming.de/programming/ocamlnet.html}OcamlNet} library, e.g.:
+ [let encode = Netencoding.Html.encode ~in_enc:`Enc_iso88591 ~out_enc:`Enc_usascii ()],
+ Where national characters are replaced by HTML entities.
+ The user is of course free to write her own implementation.
+ @see <http://www.ocaml-programming.de/programming/ocamlnet.html> OcamlNet *)
+
+val encode_unsafe_and_at : string -> string
+(** In addition, encode ["@"] as ["@"] in the hope that this will fool
+ simple minded email address harvesters. *)
+
+val output : ?preformatted:ename list -> ?no_break:ename list ->
+ ?encode:(string -> string) -> (string -> unit) -> elt -> unit
+val pretty_print : ?width:int ->
+ ?preformatted:ename list -> ?no_break:ename list ->
+ ?encode:(string -> string) -> (string -> unit) -> elt -> unit
+(** Children of elements that are mentioned in [no_break] do not
+ generate additional line breaks for pretty printing in order not to
+ produce spurious white space. In addition, elements that are mentioned
+ in [preformatted] are not pretty printed at all, with all
+ white space intact. *)
+
+val decl : ?version:string -> ?encoding:string -> (string -> unit) -> unit -> unit
+(** [encoding] is the name of the character encoding, e.g. ["US-ASCII"] *)
+
+type attribs = attrib list
+
+val amap : (ename -> attribs -> attribs) -> elt -> elt
+(** Recursively edit attributes for the element and all its children. *)
+
+val amap1 : (ename -> attribs -> attribs) -> elt -> elt
+(** Edit attributes only for one element. *)
+
+(** The following can safely be exported by higher level libraries,
+ because removing an attribute from a element is always legal. *)
+
+val rm_attrib : (aname -> bool) -> attribs -> attribs
+val rm_attrib_from_list : (aname -> bool) -> (string -> bool) -> attribs -> attribs
+
+val map_int_attrib :
+ (aname -> bool) -> (int -> int) -> attribs -> attribs
+val map_string_attrib :
+ (aname -> bool) -> (string -> string) -> attribs -> attribs
+val map_string_attrib_in_list :
+ (aname -> bool) -> (string -> string) -> attribs -> attribs
+
+(** Exporting the following by higher level libraries would drive
+ a hole through a type system, because they allow to add {e any}
+ attribute to {e any} element. *)
+
+val add_int_attrib : aname -> int -> attribs -> attribs
+val add_string_attrib : aname -> string -> attribs -> attribs
+val add_comma_sep_attrib : aname -> string -> attribs -> attribs
+val add_space_sep_attrib : aname -> string -> attribs -> attribs
+
+val fold : (unit -> 'a) -> (string -> 'a) -> (string -> 'a) -> (string -> 'a) ->
+ (ename -> attrib list -> 'a) -> (ename -> attrib list -> 'a list -> 'a) ->
+ elt -> 'a
+
+(* (* is this AT ALL useful??? *)
+val foldx : (unit -> 'a) -> (string -> 'a) -> (string -> 'a) -> (string -> 'a) ->
+ ('state -> ename -> attrib list -> 'a) ->
+ ('state -> ename -> attrib list -> 'a list -> 'a) ->
+ (ename -> attrib list -> 'state -> 'state) -> 'state -> elt -> 'a
+*)
+
+val all_int_attribs : ?is_elt:(string -> bool) -> string -> elt -> int list
+val all_string_attribs : ?is_elt:(string -> bool) -> string -> elt -> string list
+val all_attribs_list : ?is_elt:(string -> bool) -> string -> elt -> string list list
+
+val all_entities : elt -> string list
+
+val translate :
+ (ename -> attrib list -> elt) ->
+ (ename -> attrib list -> elt list -> elt) ->
+ ('state -> ename -> attrib list -> elt list) ->
+ ('state -> ename -> attrib list -> elt list -> elt list) ->
+ (ename -> attrib list -> 'state -> 'state) -> 'state -> elt -> elt
--- /dev/null
+Makefile
+deputy.log*
--- /dev/null
+#
+# This is the Makefile for Deputy tests
+# Use absolute paths only because we will include this file from
+# other directories
+
+ifndef DEPUTYHOME
+ DEPUTYHOME = @DEPUTYHOME@
+ # On cygwin, we want to remove the colon
+ ifeq ($(ARCHOS),x86_WIN32)
+ DEPUTYHOME:=$(shell cygpath -u $(DEPUTYHOME))
+ endif
+endif
+
+DEPUTYDIR := $(DEPUTYHOME)
+DEPUTY := $(DEPUTYDIR)/bin/deputy
+OPTIONS := --save-temps --strict-global-init -g --check-cil-invariants \
+ $(EXTRAARGS)
+RUNALL := $(DEPUTYDIR)/cil/ocamlutil/runall.pl
+
+$(DEPUTYHOME)/test/Makefile : $(DEPUTYHOME)/config.status \
+ $(DEPUTYHOME)/test/Makefile.in
+ echo "Makefile out of date. Must run ./config.status."
+ cd $(DEPUTYHOME) && ./config.status
+
+Makefile: $(DEPUTYHOME)/test/Makefile
+
+# We'll use all optimizations unless you override OPT on the command line.
+OPT ?= 3
+OPTIONS += --opt=$(OPT)
+
+ifdef DEPVERBOSE
+ OPTIONS += --verbose
+endif
+ifdef PARSEOUT
+ OPTIONS += --parse-out=$(PARSEOUT)
+endif
+ifdef NOINFER
+ OPTIONS += --no-infer
+endif
+ifdef INFEROUT
+ OPTIONS += --infer-out=$(INFEROUT)
+endif
+
+INFERDETAIL := 3
+OPTIONS += --infer-out-detail=$(INFERDETAIL)
+ifdef BYTECODE
+ OPTIONS += --bytecode
+endif
+ifdef STATS
+ OPTIONS += --stats
+endif
+
+ifdef NODEPUTY
+ DEPUTY := gcc
+ OPTIONS :=
+endif
+
+small/%: small/%.c
+ $(MAKE) -C small runall/$*
+
+libc/%: libc/%.c
+ $(MAKE) -C libc runall/$*
--- /dev/null
+*.exe
+*.o
+*.i
+*.cil.c
+*-tmp.c
+*.stackdump
+tout.c
--- /dev/null
+include ../Makefile
+
+# The list of tests is in ../runtests.pl
+
+.PHONY: clean alltests
+
+alltests:
+ cd ..; ./testdeputy -r --nogroup slow --nogroup ALWAYS
+# @echo -e "\n\nAll tests were successful. \n\n"
+
+clean:
+ rm -f *.cil.c *.i *.exe *.o *~ *.stackdump *-tmp.c
+
+ifndef NODEPUTY
+OPTIONS := $(OPTIONS) --fail-stop
+endif
+
+runall/%: %.c
+ COMMAND="$(DEPUTY) $(OPTIONS) \
+ -o __BASENAME__.exe __FILE__ && ./__BASENAME__.exe" \
+ COMMENT="//" \
+ perl $(RUNALL) $*.c
--- /dev/null
+// To get the crypt definition in unistd.h on Linux, we need this definition.
+#define _XOPEN_SOURCE
+
+#include <stdlib.h>
+#include <stdio.h>
+
+#if defined(__CYGWIN__)
+#include <crypt.h>
+#else
+#include <unistd.h>
+#endif
+
+#define E(n) { printf("Error %d\n", n); exit(n); }
+TESTDEF : success
+
+
+int main() {
+ char salt[2] = {'a', 'b'};
+ char shortsalt[1] = {'a'};
+ char* pwd = crypt("", NTDROP("ab"));
+ pwd = crypt("Hello, world.", salt);
+
+IFTEST : error = will always fail
+ pwd = crypt("Hello, world.", shortsalt);
+ENDIF
+
+ printf("Success\n"); exit(0);
+}
--- /dev/null
+
+#include <stdio.h>
+#include <stdlib.h>
+
+// __USE_ISOC99 gives us 'isblank'
+#define __USE_ISOC99
+#include <ctype.h>
+
+#include "harness.h"
+
+int main() {
+ char c = 'a';
+ if(! isalpha(c)) E(1);
+ if(isalpha('$')) E(2)
+
+ if(isblank(c)) E(3);
+ if(! isblank(' ')) E(4);
+
+ if(toupper(c) != 'A') E(5);
+ if(tolower('A') != c) E(6);
+
+ if(isdigit(c)) E(7);
+ if(! isdigit('5')) E(8);
+
+ return 0;
+}
--- /dev/null
+#include <stdio.h>
+
+TESTDEF baseline : success
+
+char a[] = { 'h', 'e', 'l', 'o' };
+
+int main() {
+ char * buff = a; // This should be FSEQ
+
+ fwrite(buff, 1, sizeof(a), stdout); // KEEP baseline
+ fwrite(buff, 2, sizeof(a), stdout); // KEEP : error = upper bound
+
+ return 0;
+}
--- /dev/null
+// getaddrinfo.c
+// demonstrate problem calling getaddinfo and then using what
+// it returns in subsequent socket calls; this comes from ftpd
+
+// TODO: eliminate spurious warning about missing wrappers
+// for getaddrinfo and freeaddrinfo
+
+#include <sys/types.h> // getaddrinfo, connect
+#include <sys/socket.h> // getaddrinfo, connect
+#include <netdb.h> // getaddrinfo
+#include <stdio.h> // perror
+#include <unistd.h> // read, close
+#include <string.h> // memset, memcpy
+#include <stdlib.h> // malloc
+
+#ifdef __CYGWIN__
+error: Cygwin does not support getaddrinfo
+#endif
+
+// these two come from ftpd/extern.h
+struct sockinet {
+ unsigned int si_family;
+ uint16_t si_port;
+};
+
+union sockunion {
+ struct sockinet su_si;
+ struct sockaddr_in su_sin;
+ struct sockaddr_in6 su_sin6;
+ char dirty_pool[32]; // for playing games later
+};
+
+#define SA_LEN(x) \
+ (((x)->sa_family == AF_INET6) ? sizeof(struct sockaddr_in6) \
+ : sizeof(struct sockaddr_in))
+
+
+int main(int argc, char * NTS argv[])
+{
+ int err; // error code from getaddrinfo()
+ struct addrinfo *res; // getaddrinfo()'s return value (by reference)
+ struct addrinfo hints; // options passed to getaddrinfo()
+
+ union sockunion data_dest; // address/port for issuing a connect() call
+ //struct sockaddr_in data_dest; // address/port for issuing a connect() call
+
+ int s; // socket
+ char buf[80]; // for reading from the socket
+ int len; // return from read()
+
+ // host/service
+ char const *name = "argus.eecs.berkeley.edu";
+ char const *service = "13";
+ if (argc >= 3) {
+ name = argv[1];
+ service = argv[2];
+ }
+
+ // this struct is used to pass hints to getaddrinfo() about what
+ // kind of protocol family to use; here I'm supplying the same
+ // things that ftpd does
+ memset(&hints, 0, sizeof(hints));
+ hints.ai_family = PF_INET; // IPv4 as opposed to IPv6
+ hints.ai_socktype = SOCK_STREAM; // TCP as opposed to UDP
+
+ // call getaddrinfo() to map a name/port combination to
+ // a sockaddr structure (and some other info); the 'res' argument
+ // will be set to point to the head of a linked list
+ err = getaddrinfo(name, service, &hints, &res);
+ if (err != 0) {
+ printf("getaddrinfo error %d: %s\n", err, gai_strerror(err));
+ return 2;
+ }
+
+ // for curiosity's sake, count the number of nodes in the list
+ {
+ int ct = 0;
+ struct addrinfo *p = res;
+ while (p) {
+ ct++;
+ p = p->ai_next;
+ }
+ printf("getaddrinfo returned %d addresses\n", ct);
+ }
+ printf("addrlen is %d\n", res->ai_addrlen);
+
+ // new solution: try naming the fields explicitly..
+ if (res->ai_addrlen == 16) {
+ // by taking address of 'su_sin', CCured is pacified
+ memcpy(&data_dest.su_sin, res->ai_addr, res->ai_addrlen);
+ }
+ else if (res->ai_addrlen == 28) {
+ // 'su_sin6' works similarly, but now there's a different
+ // problem--'ai_addr' is only declared to point at a 'sockaddr',
+ // and CCured will again complain about the sizes. I can't just
+ // use 'su_sin', because the memcpy wrapper will catch the length
+ // mismatch. Instead I must use George's mkptr_size trick...
+ //
+ // I wish my machine had IPv6 support working so I could test this..
+ struct sockaddr_in6 *src = (struct sockaddr_in6 *)res->ai_addr;
+ memcpy(&data_dest.su_sin6, src, res->ai_addrlen);
+ }
+ else {
+ abort(); // unexpected size
+ }
+
+ if (argc == 1) {
+ // no arguments explicitly supplied, don't actually do the network
+ // connection
+ printf("skipping connect() step since arguments were implicit\n");
+ return 0;
+ }
+
+ // now, use this address (IP address and port number) to establish
+ // a network connection
+ s = socket(AF_INET, SOCK_STREAM, 0 /*pick the reasonable one?*/);
+ if (s == -1) {
+ perror("socket");
+ return 2;
+ }
+
+ if (res->ai_addrlen == 16) {
+ if (0!=connect(s, (struct sockaddr *)&data_dest.su_sin,
+ SA_LEN((struct sockaddr *)&data_dest))) {
+ perror("connect");
+ return 2;
+ }
+ }
+ else if (res->ai_addrlen == 28) {
+ // will this work? CCured is going to see an apparent cast
+ // from sockaddr_in6 to sockaddr.. no. so now I've apparently
+ // fixed it with the extra 4 bytes of padding, but still cannot
+ // test it due to my IPv6 situation..
+ if (0!=connect(s, (struct sockaddr *)&data_dest.dirty_pool,
+ SA_LEN((struct sockaddr *)&data_dest))) {
+ perror("connect");
+ return 2;
+ }
+ }
+ else {
+ abort();
+ }
+
+
+ // just to be sure this really worked, read the first packet; since
+ // I've connected to the daytime socket, this should be the time of
+ // day in some ascii representation
+ printf("established connection! first packet:\n");
+ len = read(s, buf, 79);
+ if (len < 0) {
+ perror("read");
+ return 2;
+ }
+ buf[len] = 0;
+ printf("%d bytes: %s\n", len, buf);
+
+ // close the connection
+ if (0!=close(s)) {
+ perror("close");
+ return 2;
+ }
+
+ // free the linked list that getaddrinfo() returned
+ freeaddrinfo(res);
+
+ return 0;
+}
+
+
+
--- /dev/null
+// getpwnam.c
+// test getpwnam wrapper
+
+#include <stdlib.h> // exit, free
+#include <pwd.h> // getpwnam
+#include <grp.h> // getgrnam
+#include <sys/types.h> // uid_t?
+#include <stdio.h> // printf
+#include <string.h> // printf
+#include <unistd.h> // getuid
+
+#define E(n) { printf("Error %d\n", n); exit(n); }
+#ifndef DEPUTY
+ #define NTS
+#endif
+
+TESTDEF : success
+
+int main()
+{
+ int zero = 0;
+ struct passwd *pw = getpwuid(getuid());
+ struct group *gr = getgrgid(getgid());
+ char* username = strdup(pw->pw_name);
+ pw = getpwnam(username);
+
+ printf("name: %s\n", pw->pw_name);
+ printf("uid: %d\n", pw->pw_uid);
+ printf("gid: %d\n", pw->pw_gid);
+ printf("passwd: %p\n", (unsigned long)pw->pw_passwd);
+ printf("passwd: %s\n", pw->pw_passwd);
+
+
+
+ printf("gr name: %s\n", gr->gr_name);
+ printf("gid: %d\n", gr->gr_gid);
+ printf("passwd: %p\n", (unsigned long)gr->gr_passwd);
+ printf("gr_mem: %p\n", (unsigned long)gr->gr_mem);
+
+ if(strcmp(pw->pw_name, username)) E(1);
+ if(pw->pw_uid != getuid()) E(2);
+ if(pw->pw_gid != getgid()) E(3);
+
+ free(username);
+
+ // make us infer non-simple representations
+ pw->pw_name += zero;
+
+IFTEST : error = will always fail
+ // We cannot decrement an NT pointer
+ pw->pw_passwd++;
+ pw->pw_passwd--;
+ENDIF
+
+ // Do the same for the group structure
+ gr->gr_name += zero;
+ gr->gr_mem += zero; // Make it FSEQ
+ if(gr->gr_mem && *gr->gr_mem) {
+ char * foo = *gr->gr_mem - zero; // Make that FAT
+ }
+
+
+ // List the members in my group
+ {
+ char * NTS * p = gr->gr_mem;
+ while(*p) {
+ // Check the group for this user
+ struct passwd *pw = getpwnam(*p);
+ printf(" group member: %s\n", *p);
+ printf(" name: %s\n", pw->pw_name);
+ printf(" uid: %d\n", pw->pw_uid);
+ printf(" gid: %d\n", pw->pw_gid);
+ printf(" passwd: %p\n", (unsigned long)pw->pw_passwd);
+ printf(" passwd: %s\n", pw->pw_passwd);
+
+
+
+ if(strcmp(pw->pw_name, *p)) E(11);
+ // if(pw->pw_gid != gr->gr_gid) E(12);
+ // Try next user
+ p ++;
+ }
+ }
+ printf("Success\n"); exit(0);
+}
--- /dev/null
+// glob.c
+// test glob() function
+
+#include <glob.h> // glob, globfree
+#include <string.h> // memset
+#include <stdio.h> // printf
+#include <unistd.h> // chdir
+
+
+
+int entry()
+{
+ glob_t globbuf;
+ int flags;
+ int err;
+ int i;
+
+ // clear the globbuf (will CCured complain?)
+ memset(&globbuf, 0, sizeof(globbuf));
+
+ // these are exactly the flags that ftpd uses, so I want to make
+ // sure they work first..
+ flags = GLOB_BRACE | // shell-style brace expansion
+ GLOB_NOCHECK | // if no match, yield original pattern
+ GLOB_TILDE; // shell-style ~username expansion
+
+ // call glob to find all *.c names
+ err = glob("*.c", flags, NULL /*errfunc*/, &globbuf);
+ switch (err) {
+ case 0: // no error
+ break;
+
+ case GLOB_NOSPACE:
+ printf("glob: out of memory\n");
+ return 2;
+
+#ifndef __CYGWIN__
+ case GLOB_ABORTED:
+ printf("glob: read error\n");
+ return 2;
+
+ case GLOB_NOMATCH:
+ // not really an error as far as glob is concerned, except that
+ // I know there are files matching *.c so something must have
+ // gone wrong..
+ printf("glob: no matches\n");
+ return 2;
+#endif
+
+ default:
+ // interestingly, the libc glob.h header does in fact declare
+ // some additional codes, implying they might be returned..
+ printf("glob: unknown error code: %d\n", err);
+ return 2;
+ }
+
+ // print some of what was matched
+ printf("got %d matches; printing up to 10:\n", globbuf.gl_pathc);
+
+ for (i=0; i < 10 && i < globbuf.gl_pathc; i++) {
+ char const *p = globbuf.gl_pathv[i];
+ printf("match %d: %s\n", i, p);
+ }
+
+ // free the memory
+ globfree(&globbuf);
+
+ return 0;
+}
+
+
+int main()
+{
+ int err;
+
+ // since this is often run from cil/test, move into cil/test/small2
+ // (if that's really where we are) for a little less degeneracy
+ if (0==chdir("small2")) {
+ printf("moved into small2/ for less degeneracy\n");
+ }
+
+ err = entry();
+ if (err) return err;
+
+ // do it again just to be sure
+ err = entry();
+ if (err) return err;
+
+ return 0;
+}
--- /dev/null
+// This file contains macros for the libc Deputy tests.
+
+#ifndef HARNESS_H
+#define HARNESS_H
+
+extern int printf(const char * NTS format, ...);
+extern void exit(int);
+
+/* Always call E with a non-zero number */
+#define E(n) { printf("Error %d\n", n); exit(n); }
+#define SUCCESS { printf("Success\n"); exit(0); }
+
+#endif // HARNESS_H
--- /dev/null
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+
+#include <netdb.h>
+
+#define HOST "www.cs.berkeley.edu"
+
+TESTDEF : success
+
+int main() {
+ struct hostent *res = gethostbyname(HOST);
+ char *p = res->h_name;
+ int i;
+ //does HOST match any alias?
+ int lookupSucceeded = strcmp(res->h_name, HOST) == 0;
+
+ printf("Host is %s\n", res->h_name);
+ for (i = 0; res->h_aliases[i] != NULL; i++) {
+ printf(" alias[%d] is %s\n", i, res->h_aliases[i]);
+ if(strcmp(res->h_aliases[i], HOST)== 0) {
+ lookupSucceeded = 1;
+ }
+IFTEST ubound_hostent : error = upper bound check
+ printf("Next alias = %s\n", res->h_aliases[i + 2]);
+ENDIF
+IFTEST ubound_hostent2 : error = nullterm write check
+ res->h_aliases[i + 1] = "foo";
+ENDIF
+ }
+
+ for (i = 0; res->h_addr_list[i] != NULL; i++) {
+ printf(" addr[%d] is %u.%u.%u.%u\n", i,
+ (unsigned char)res->h_addr_list[i][0],
+ (unsigned char)res->h_addr_list[i][1],
+ (unsigned char)res->h_addr_list[i][2],
+ (unsigned char)res->h_addr_list[i][3]);
+IFTEST ubound_hostent3 : error = upper bound check
+ printf("Next addr = %d\n", res->h_addr_list[i + 2][0]);
+ENDIF
+ }
+
+ if(!lookupSucceeded) {
+ exit(1);
+ }
+ return 0;
+}
--- /dev/null
+#include <string.h>
+#include <stdio.h>
+#include <netdb.h>
+#include <stdlib.h> //exit
+
+
+#define MANJU "manju.cs.berkeley.edu"
+#define E(n) { printf("Error %d\n", n); exit(n); }
+
+#if defined __CYGWIN__ || defined _MSVC
+error: Cygwin and MSVC do not support gethostbyname_r
+#endif
+
+char* NTS addrToString(char* COUNT(4) addr)
+{
+ static char (NT buffer)[128];
+ sprintf(buffer, "%d.%d.%d.%d",
+ (unsigned char)addr[0], (unsigned char)addr[1],
+ (unsigned char)addr[2], (unsigned char)addr[3]);
+ return buffer;
+}
+
+// dsw: see
+// http://www.gnu.org/manual/glibc-2.2.3/html_node/libc_309.html#IDX1688
+// for documentation
+int main() {
+ struct hostent res, *pres;
+ char buf[1024];
+ int err, i;
+ char addr[4];
+
+ //
+ // gethostbyname_r
+ //
+
+ //lookup manju by name:
+ gethostbyname_r(MANJU, &res, buf, 1024, &pres, &err);
+ if(pres == NULL) {
+ E(1);
+ }
+ if(strcmp(pres->h_name, MANJU)) {
+ E(2);
+ }
+ printf("%s\n", pres->h_name);
+ for (i = 0; pres->h_aliases[i] != NULL; i++) {
+ printf(" alias[%d] is %s\n", i, pres->h_aliases[i]);
+ }
+ memcpy(addr, pres->h_addr_list[0], sizeof addr);
+ printf("%s has address %s\n",
+ pres->h_name, addrToString(addr));
+
+ //lookup localhost by name:
+ gethostbyname_r("localhost", &res, buf, 1024, &pres, &err);
+ printf("%s\n", pres->h_name);
+ for (i = 0; pres->h_aliases[i] != NULL; i++) {
+ printf(" alias[%d] is %s\n", i, pres->h_aliases[i]);
+ }
+ for (i = 0; pres->h_addr_list[i] != NULL; i++) {
+ printf(" address[%d] is %s\n", i, addrToString(pres->h_addr_list[i]));
+ }
+
+ //
+ // gethostbyaddr_r
+ //
+
+ //now look up manju using the address we got earlier.
+ printf("test gethostbyaddr_r\n");
+ gethostbyaddr_r(addr, 4, AF_INET, &res, buf, 1024, &pres, &err);
+ printf("lookup manju(%s): %s\n",
+ addrToString(addr),
+ pres->h_name);
+ if(strcmp(pres->h_name, "manju.CS.Berkeley.EDU")) {
+ E(3);
+ }
+ for (i = 0; pres->h_aliases[i] != NULL; i++) {
+ printf(" alias[%d] is %s\n", i, pres->h_aliases[i]);
+ }
+
+ //now look up localhost using 127.0.0.1
+ printf("test gethostbyaddr_r on localhost\n");
+ addr[0] = 127; // localhost
+ addr[1] = 0;
+ addr[2] = 0;
+ addr[3] = 1;
+ gethostbyaddr_r(addr, 4, AF_INET, &res, buf, 1024, &pres, &err);
+ printf("localhost: %s\n", pres->h_name);
+ for (i = 0; pres->h_aliases[i] != NULL; i++) {
+ printf(" alias[%d] is %s\n", i, pres->h_aliases[i]);
+ }
+ //h_name will probably be "localhost" or "localhost.SOME_DOMAIN"
+ if(strncmp(pres->h_name, "localhost", 9)) {
+ // On the latest incarnation of manju, the localname is manju
+ // E(4);
+ }
+
+ printf("success\n");
+ return 0;
+}
+
--- /dev/null
+// KEEP baseline: success
+
+#include <stdlib.h>
+
+int main() {
+ int *p;
+ int **pp;
+
+ p = (int *) malloc(3 * sizeof(int));
+ p[2] = 42;
+
+ pp = (int **) realloc(p, 5 * sizeof(int*)); // KEEP e1: error = changes type
+ p = (int *) realloc(p, 5 * sizeof(int));
+ p[4] = 42;
+
+ int res = p[4] - p[2];
+
+ free(p);
+
+ return res;
+}
--- /dev/null
+// Makes sure that NT doesn't flow through free.
+
+#include <stdlib.h>
+
+int main() {
+ int *p = malloc(12);
+ char * NT q = malloc(12);
+
+ free(p);
+ free(q);
+
+ p[2] = 42;
+
+ return 0;
+}
--- /dev/null
+#include <string.h>
+
+int main() {
+ unsigned char buff[128];
+
+ memset(buff, 0, sizeof(buff)); // KEEP : success
+
+ memset((char*)buff, 0, sizeof(buff)); // KEEP : success
+
+}
--- /dev/null
+/* $OpenBSD: popen.c,v 1.11 1999/12/08 13:15:21 itojun Exp $ */
+/* $NetBSD: popen.c,v 1.5 1995/04/11 02:45:00 cgd Exp $ */
+
+/*
+ * Copyright (c) 1988, 1993, 1994
+ * The Regents of the University of California. All rights reserved.
+ *
+ * This code is derived from software written by Ken Arnold and
+ * published in UNIX Review, Vol. 6, No. 8.
+ *
+ * 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 the University of
+ * California, Berkeley and its contributors.
+ * 4. Neither the name of the University nor the names of its contributors
+ * may be used to endorse or promote products derived from this software
+ * without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ */
+
+// sm: hack to avoid problem with __typeof in WIFEXITED macro
+// sm: later, with different (?) libc, this made it not work..
+//#define __STRICT_ANSI__
+
+#ifdef CCURED
+ // this should not be necessary anymore.. and indeed it's not!
+ //#define glob wrapped_glob
+ //#define globfree wrapped_globfree
+#else
+ #define __HEAPIFY
+#endif
+
+#include <sys/types.h>
+#include <sys/wait.h>
+
+#include <errno.h>
+#include <glob.h>
+#include <signal.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <syslog.h>
+#include <unistd.h>
+
+//#include <netinet/in.h>
+//#include "extern.h"
+
+/*
+ * Special version of popen which avoids call to shell. This ensures noone
+ * may create a pipe to a hidden program as a side effect of a list or dir
+ * command.
+ */
+static int * COUNT(pids_count) pids;
+static int pids_count;
+
+static int fds;
+
+#define MAX_ARGV 100
+#define MAX_GARGV 1000
+
+void fatal(char const * NTS msg)
+{
+ fprintf(stderr, "fatal: %s\n", msg);
+ exit(4);
+}
+
+FILE *
+ftpd_popen(program, type)
+ char * NTS program, * NTS type;
+{
+ char *cp;
+ FILE *iop;
+ int argc, gargc, pdes[2], pid;
+ char * NTS *pop, * NTS argv[MAX_ARGV], * NTS gargv[MAX_GARGV];
+
+ char *tmp;
+
+
+ if ((*type != 'r' && *type != 'w') || type[1])
+ return (NULL);
+
+ if (!pids) {
+ if ((fds = getdtablesize()) <= 0)
+ return (NULL);
+ pids_count = fds;
+ if ((pids = (int *)malloc((u_int)(fds * sizeof(int)))) == NULL)
+ return (NULL);
+ memset(pids, 0, fds * sizeof(int));
+ }
+ if (pipe(pdes) < 0)
+ return (NULL);
+
+ /* break up string into pieces */
+ for (argc = 0, cp = program;argc < MAX_ARGV-1; cp = NULL)
+ if (!(argv[argc++] = strtok(cp, " \t\n")))
+ break;
+ argv[MAX_ARGV-1] = NULL;
+
+ /* glob each piece */
+ gargv[0] = argv[0];
+ for (gargc = argc = 1; argv[argc]; argc++) {
+ glob_t gl;
+ int flags = GLOB_BRACE|GLOB_NOCHECK|GLOB_TILDE;
+
+
+ memset(&gl, 0, sizeof(gl));
+ if (glob(argv[argc], flags, NULL, &gl)) {
+ if (gargc < MAX_GARGV-1) {
+ gargv[gargc++] = (tmp = strdup(argv[argc]));
+ if (gargv[gargc -1] == NULL)
+ fatal ("Out of memory");
+ }
+
+ } else
+ for (pop = gl.gl_pathv; *pop && gargc < MAX_GARGV-1; pop++) {
+ printf("glob answer %d: %s\n", gargc, *pop);
+ gargv[gargc++] = (tmp = strdup(*pop));
+ if (gargv[gargc - 1] == NULL)
+ fatal ("Out of memory");
+ }
+ globfree(&gl);
+ }
+ gargv[gargc] = NULL;
+ printf("globbing yielded %d answers\n", gargc-1);
+
+ iop = NULL;
+
+ switch(pid = fork()) {
+ case -1: /* error */
+ (void)close(pdes[0]);
+ (void)close(pdes[1]);
+ goto pfree;
+ /* NOTREACHED */
+ case 0: /* child */
+ if (*type == 'r') {
+ if (pdes[1] != STDOUT_FILENO) {
+ dup2(pdes[1], STDOUT_FILENO);
+ (void)close(pdes[1]);
+ }
+ dup2(STDOUT_FILENO, STDERR_FILENO); /* stderr too! */
+ (void)close(pdes[0]);
+ } else {
+ if (pdes[0] != STDIN_FILENO) {
+ dup2(pdes[0], STDIN_FILENO);
+ (void)close(pdes[0]);
+ }
+ (void)close(pdes[1]);
+ }
+ closelog();
+
+ printf("running %s\n", gargv[0]);
+ execv(gargv[0], gargv);
+ perror("execv");
+ _exit(1);
+ }
+ /* parent; assume fdopen can't fail... */
+ if (*type == 'r') {
+ iop = fdopen(pdes[0], type);
+ (void)close(pdes[1]);
+ } else {
+ iop = fdopen(pdes[1], type);
+ (void)close(pdes[0]);
+ }
+ pids[fileno(iop)] = pid;
+
+ pfree: for (argc = 1; gargv[argc] != NULL; argc++)
+ free(gargv[argc]);
+
+ return (iop);
+}
+
+int
+ftpd_pclose(iop)
+ FILE *iop;
+{
+ int fdes, status;
+ pid_t pid;
+ sigset_t sigset, osigset;
+
+ /*
+ * pclose returns -1 if stream is not associated with a
+ * `popened' command, or, if already `pclosed'.
+ */
+ if (pids == 0 || pids[fdes = fileno(iop)] == 0)
+ return (-1);
+ (void)fclose(iop);
+ sigemptyset(&sigset);
+ sigaddset(&sigset, SIGINT);
+ sigaddset(&sigset, SIGQUIT);
+ sigaddset(&sigset, SIGHUP);
+ sigprocmask(SIG_BLOCK, &sigset, &osigset);
+ while ((pid = waitpid(pids[fdes], &status, 0)) < 0 && errno == EINTR)
+ continue;
+ sigprocmask(SIG_SETMASK, &osigset, NULL);
+ pids[fdes] = 0;
+ if (pid < 0)
+ return (pid);
+ if (WIFEXITED(status))
+ return (WEXITSTATUS(status));
+ return (1);
+}
+
+
+int main()
+{
+ FILE *fp;
+ char buf[80] ;
+ char cmd[80] = "/bin/ls ~/tmp/tmp/""*";
+
+ fp = ftpd_popen(cmd, "r");
+ while (fgets(buf, 80, fp)) {
+ printf("output: %s", buf); // buf has \n in it
+ }
+ ftpd_pclose(fp);
+
+ return 0;
+}
+
+
--- /dev/null
+
+#include <stdio.h>
+
+TESTDEF baseline : success = hello
+
+char a[8];
+
+int main() {
+ char * s = "hello";
+
+ printf("int=%02d, float=%f, str=\"%s\"\n", 5, 3.4, "hello");
+ printf("char=%c\n", 'a');
+
+ printf("int=%p\n", (int)s);
+
+ // TODO: We might want to produce an error in this case. Deputy inserts
+ // a cast from pointer to integer here, which may change the behavior of
+ // the code on 64-bit machines.
+ printf("int=%d\n", s); // KEEP str_d: success
+
+ printf("str=%s\n", 5); // KEEP : error = Type mismatch
+
+ printf("str=%s\n", a); // KEEP nt1 : error = from ordinary pointer to nullterm
+
+ printf(s, 1); // KEEP nonlit: success = non-literal format string
+
+ return 0;
+}
--- /dev/null
+#include <stdio.h>
+
+int main() {
+ printf("%d%%c", 42);
+ return 0;
+}
--- /dev/null
+// DO NOT CHANGE THIS LINE
+// Test that read and readv work.
+
+#include <sys/uio.h>
+#include <stdlib.h>
+#include <unistd.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <string.h>
+#include <stdio.h>
+#include <errno.h>
+
+#ifndef DEPUTY
+#define TC(x) (x)
+#define NTDROP(x) (x)
+#endif
+
+#define myassert(I) do { \
+ if(!(I)) { \
+ printf("%s:%d **************** assertion failure\n", __FILE__, __LINE__); \
+ abort(); \
+ } \
+} while(0)
+
+void test_read() {
+ const int size = 8;
+ char *buf = malloc((size+1) * sizeof buf[0]);
+ int in = open("readv1.c", O_RDONLY);
+ myassert(buf!=0);
+ if (in<0) {
+ printf("**** error opening file\n");
+ abort();
+ }
+
+ // read
+ {
+ int num_left = size;
+ while(num_left) {
+ int num_read = read(in, NTDROP(buf+size-num_left), num_left);
+ num_left -= num_read;
+ }
+ buf[size] = '\0';
+ myassert(close(in)==0);
+ }
+
+ // check it is what we expect.
+ myassert(strcmp(buf, "// DO NO")==0);
+
+ printf("success\n");
+}
+
+void test_readv() {
+ int in;
+ const int size = 8;
+ struct iovec iov[2];
+ int i;
+ for(i=0; i<2; ++i) {
+ iov[i].iov_len = size;
+ iov[i].iov_base = malloc(size * sizeof iov[i].iov_base[0]);
+ myassert(iov[i].iov_base != 0);
+ }
+
+ in = open("readv1.c", O_RDONLY);
+ if (in<0) {
+ printf("**** error opening file\n");
+ abort();
+ }
+
+ // readv
+ // NOTE: we assume that it maximally fills the buffers.
+ {
+ int num_read = readv(in, iov, 2);
+ printf("num_read = %d\n", num_read);
+ myassert(num_read = 2 * size);
+ for(i=0; i<2; ++i) {
+ ((char*)(iov[i].iov_base))[size-1] = '\0';
+ }
+ myassert(close(in)==0);
+ }
+
+ // check it is what we expect.
+ myassert(strcmp(TC(iov[0].iov_base), "// DO N")==0);
+ myassert(strcmp(TC(iov[1].iov_base), "T CHANG")==0);
+
+ printf("success\n");
+}
+
+int main() {
+ printf("test read\n");
+ test_read();
+ printf("test readv\n");
+ test_readv();
+ return 0;
+}
--- /dev/null
+#include <string.h>
+#include <stdio.h>
+#include <netdb.h>
+
+#include "harness.h"
+
+#include <netinet/in.h>
+
+// dsw: see
+// http://www.gnu.org/manual/glibc-2.2.3/html_node/libc_309.html#IDX1688
+// for documentation
+void dump_servent(struct servent *s) {
+ int i;
+ short short_port;
+ printf("%s\n", s->s_name);
+ for (i = 0; s->s_aliases[i] != NULL; i++) {
+ printf(" alias[%d] is %s\n", i, s->s_aliases[i]);
+ }
+ short_port = s->s_port;
+ printf("%d\n", ntohs(short_port));
+ printf("%s\n", s->s_proto);
+}
+
+int main() {
+ struct servent res, *pres;
+ char buf[1024];
+ char *name = "qotd";
+// char *name = "www";
+ char *proto = "tcp";
+
+ printf("looking up name:%s, proto:%s\n", name, proto);
+ { // non-reentrant way
+ struct servent *s = getservbyname(name, proto);
+ dump_servent(s);
+ }
+
+ printf("done\n");
+
+ return 0;
+}
+
--- /dev/null
+#include <string.h>
+#include <stdio.h>
+#include <netdb.h>
+
+#include "harness.h"
+
+#include <netinet/in.h>
+
+// dsw: see
+// http://www.gnu.org/manual/glibc-2.2.3/html_node/libc_309.html#IDX1688
+// for documentation
+void dump_servent(struct servent *s) {
+ int i;
+ short short_port;
+ printf("%s\n", s->s_name);
+ for (i = 0; s->s_aliases[i] != NULL; i++) {
+ printf(" alias[%d] is %s\n", i, s->s_aliases[i]);
+ }
+ short_port = s->s_port;
+ printf("%d\n", ntohs(short_port));
+ printf("%s\n", s->s_proto);
+}
+
+int main() {
+ struct servent res, *pres;
+ char buf[1024];
+ char *name = "qotd";
+// char *name = "www";
+ char *proto = "tcp";
+
+ printf("looking up name:%s, proto:%s\n", name, proto);
+
+ // reentrant way
+ getservbyname_r(name, proto, &res, buf, 1024, &pres);
+ {
+ short short_port = pres->s_port;
+ if(ntohs(short_port) != 17) E(1);
+ }
+ dump_servent(pres);
+
+ printf("done\n");
+
+ return 0;
+}
+
--- /dev/null
+// sockunion.c
+// demonstrate problem with ftpd's 'union sockunion'
+
+//#include <sys/types.h> // getaddrinfo, connect
+//#include <sys/socket.h> // getaddrinfo, connect
+//#include <netdb.h> // getaddrinfo
+//#include <unistd.h> // read, close
+//#include <stdlib.h> // malloc
+
+#include <stdio.h> // perror, printf
+#include <string.h> // memset, memcpy
+
+// stdint.h
+typedef unsigned char uint8_t;
+typedef unsigned short int uint16_t;
+typedef unsigned int uint32_t;
+
+// bits/sockaddr.h
+typedef unsigned short int sa_family_t;
+
+// netinet/in.h
+typedef uint16_t in_port_t;
+
+// netinet/in.h
+typedef uint32_t in_addr_t;
+struct in_addr {
+ in_addr_t s_addr;
+};
+
+// bits/socket.h: 16 bytes
+struct sockaddr {
+ sa_family_t sa_family ;
+ char sa_data[14];
+};
+
+// netinet/in.h: 2+2+4+8 = 16 bytes
+struct sockaddr_in {
+ sa_family_t sin_family ;
+ in_port_t sin_port;
+ struct in_addr sin_addr;
+
+ unsigned char sin_zero[sizeof (struct sockaddr) -
+ (sizeof (unsigned short int)) -
+ sizeof (in_port_t) -
+ sizeof (struct in_addr)];
+};
+
+
+// netinet/in.h: 16 bytes
+struct in6_addr {
+ union {
+ uint8_t u6_addr8[16];
+ uint16_t u6_addr16[8];
+ uint32_t u6_addr32[4];
+ } in6_u;
+};
+
+// netinet/in.h: 2+2+4+16+4 = 28 bytes
+struct sockaddr_in6 {
+ sa_family_t sin6_family ;
+ in_port_t sin6_port;
+ uint32_t sin6_flowinfo;
+ struct in6_addr sin6_addr;
+ uint32_t sin6_scope_id;
+};
+
+
+// ftpd/extern.h: 2+2 = 4 bytes
+struct sockinet {
+ sa_family_t si_family;
+ uint16_t si_port;
+};
+
+// ftpd/extern.h: max(4,16,28) = 28 bytes
+union sockunion {
+ struct sockinet su_si; // not needed to provoke problem
+ struct sockaddr_in su_sin;
+ struct sockaddr_in6 su_sin6;
+};
+
+
+int zero = 0;
+
+int main()
+{
+ struct sockaddr someAddr;
+ struct sockaddr_in6 someAddr6;
+ union sockunion data_dest;
+ int sz;
+ int wanted_size = 16;
+
+ printf("sizeof(sockaddr_in): %d\n", sizeof(struct sockaddr_in));
+ printf("sizeof(sockunion): %d\n", sizeof(union sockunion));
+
+ // here's a possibly improved version; unfortunately this might
+ // only postpone the playing of games until I deal with 'someAddr'
+ // in the full generality that ftpd has, but for now this is my
+ // prototype solution
+ if (wanted_size == 16) {
+ memcpy(&data_dest.su_sin, &someAddr, wanted_size);
+ }
+ else if (wanted_size == 28) {
+ memcpy(&data_dest.su_sin6, &someAddr6, wanted_size);
+ }
+ else {
+ abort(); // unexpected size
+ }
+
+ sz = sizeof(&data_dest);
+ printf("sizeof(&data_dest): %d\n", sz);
+
+ return 0;
+}
--- /dev/null
+// sockets.c
+TESTDEF succ : success
+// test some socket function wrappers (and others..)
+
+#include <sys/types.h> // setsockopt
+#include <sys/socket.h> // setsockopt, ..
+#include <netdb.h> // getnameinfo
+#include <netinet/in.h> // sockaddr_in
+
+#include <stdio.h> // printf
+#include <stdlib.h> // exit
+#include <string.h> // strdup
+
+#if defined(__CYGWIN__)
+//error: This test case does not work on cygwin because getnameinfo is missing
+#endif
+
+void fail(int val)
+{
+ printf("fail(%d)\n", val);
+ exit(val);
+}
+
+
+void t_setsockopt()
+{
+ int tmp=1;
+ setsockopt(0, 0, 0, (char*)&tmp, sizeof(tmp));
+IFTEST : error = blah blah ubound
+ setsockopt(0, 0, 0, (char*)&tmp + 1, sizeof(tmp));
+ENDIF
+}
+
+void t_bind()
+{
+ struct sockaddr_in addr;
+ void *p = &addr;
+ bind(0, p, sizeof(addr));
+ p = (char*)p+1;
+ bind(0, p, sizeof(addr)); // KEEP : error = Ubound
+}
+
+void t_accept()
+{
+ struct sockaddr_in addr;
+ void *p = &addr;
+ int len = sizeof(addr);
+ accept(0, p, &len);
+ p = (char*)p+1;
+ accept(0, p, &len); // KEEP : error = Ubound
+}
+
+void t_getpeername()
+{
+ struct sockaddr_in addr;
+ void *p = &addr;
+ int len = sizeof(addr);
+ getpeername(0, p, &len);
+ p = (char*)p+1;
+ getpeername(0, p, &len); // KEEP : error = Ubound
+}
+
+void t_getsockname()
+{
+ struct sockaddr_in addr;
+ void *p = &addr;
+ int len = sizeof(addr);
+ getsockname(0, p, &len);
+ p = (char*)p+1;
+ getsockname(0, p, &len); // KEEP : error = Ubound
+}
+
+#ifndef __CYGWIN__
+// CYGWIN does not have getnameifo
+void t_getnameinfo()
+{
+ struct sockaddr_in addr;
+ void *p = &addr;
+ char host[40];
+ char serv[40];
+ getnameinfo(p, sizeof(addr), host, 40, serv, 40, 0);
+ p = (char*)p+1;
+ getnameinfo(p, sizeof(addr), host, 40, serv, 40, 0); // KEEP : error = Ubound
+}
+#endif
+
+char * NTS t_strdup()
+{
+ char buf[7] = "fhello";
+ char *p = buf;
+ char *q;
+ char c;
+
+ q++; // seq
+ p++; // seq
+
+ c = p[4]; // the 'o', definitely ok
+ c = p[5]; // we allow this?
+ p[5] = 0; // this?
+ p[5] = 4; // KEEP : error = Ubound
+ p[5] = 0; // restore
+
+ q = strdup(p);
+ c = q[10]; // KEEP : error = Ubound
+ q = strdup(p+10); // KEEP : error = Ubound
+ return q;
+}
+
+int main()
+{
+ t_setsockopt();
+ t_bind();
+ t_accept();
+ t_getpeername();
+ t_getsockname();
+ t_getnameinfo();
+ t_strdup();
+
+ printf("no failure\n");
+ return 0;
+}
+
+
--- /dev/null
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <sys/stat.h>
+
+#define E(n) {printf("Error %d\n", n); exit(n); }
+
+TESTDEF : success
+
+int main() {
+ struct stat sb1, sb2, sb3;
+
+ if(stat("stat1.c", &sb1)) E(1);
+
+ if(lstat("stat1.c", &sb2)) E(2);
+
+ if(sb1.st_size != sb2.st_size) E(3);
+
+ // Try to invoke with a null pointer
+IFTEST err : error = non-null check
+ stat(0, &sb3);
+ENDIF
+
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+#include <string.h> // strchr
+
+char (NT ch)[] = { 'f', 'a', 'r', 'a', 0 };
+
+int main() {
+ char * NTS s = &ch[0];
+ char * NTS t = strchr(s, 'a');
+ t+=3;
+
+ if(*t) E(1); // read the 0
+
+ t = strrchr(s, 'a');
+ t ++;
+
+ if(*t) E(2);
+
+ t = strchr(s, 'b');
+ if(t) E(3);
+
+ SUCCESS;
+}
--- /dev/null
+#include <string.h>
+#include "harness.h"
+
+char* NTS global = "Foo";
+
+TESTDEF baseline: success
+
+void foo(char* NT COUNT(len) buf, int len) {
+ //unsafe API. Should fail statically
+ strcpy(buf, foo); //KEEP strcpy: success = Calls to strcpy are unsafe
+
+ //we change this to strncpy(buf, "Hi, there", 9), based on the length of
+ // the string literal.
+ strcpy(buf, "Hi, there");
+ strcpy(buf, "Hi, there."); //KEEP strcpy_toolong: error = Assertion failed
+
+
+ strcpy(buf, "Hi");
+ if (strcmp(buf, "Hi") != 0) E(2)
+}
+
+int main() {
+ char stringbuf[10];
+ foo(stringbuf, sizeof(stringbuf)-1);
+ SUCCESS;
+}
--- /dev/null
+#include <string.h> // strerror
+#include <stdio.h> // printf
+
+int main()
+{
+ char * NTS s = strerror(2); // file not found
+ s++;
+ printf("string: %s\n", s);
+ return 0;
+}
--- /dev/null
+#include <string.h>
+
+int main() {
+ char (NT buffer1)[16];
+ char buffer2[16]; // We do not need NT annotations on local buffers
+ char * NTS res;
+
+ res = strncpy(buffer1, "a string", sizeof(buffer1) - 1); // KEEP t1: success
+
+ // The size argument must not include the null terminator.
+ strncpy(buffer1, "a string", sizeof(buffer1)); // KEEP e1: error = upper bound
+
+ strncpy(buffer2, "a string", 1); // KEEP t2: success
+
+ return 0;
+}
--- /dev/null
+#include <stdlib.h>
+#include <string.h>
+
+typedef char * NT string;
+
+char * NTS getparam(char * NTS name)
+{
+ int i, len;
+ string def;
+ char (NT buf)[128];
+ string userv;
+
+ strncpy(buf, name, sizeof(buf) - 1);
+ len = strlen(buf);
+
+ userv = (string) malloc(len+1);
+ strncpy(userv, buf, len);
+
+ if(strcmp(userv, buf)) exit(1);
+
+ return userv;
+}
+
+int main() {
+ getparam("a string");
+
+ return 0;
+}
--- /dev/null
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+
+#define E(n) { printf("Error %d\n", n); exit(n); }
+
+char * NT str = "a string";
+
+TESTDEF : success
+
+int main() {
+ int len = strlen(str);
+ char * dest;
+ // Forget about the last character
+ len --; // KEEP : error = upper bound
+ dest = (char*)malloc(len + 1); // Allocate a buffer for string + NULL
+ strncpy(dest, str, strlen(str));
+
+ if(strcmp(dest, str)) E(1);
+
+ // Make sure that we still have 0 at the end of dest
+ if(dest[len] != 0) E(2);
+
+ return 0;
+}
--- /dev/null
+// String tests from Bill.
+
+#include <stdlib.h>
+#include <string.h>
+
+int main() {
+ const char * NTS name = "foo!bar";
+ char * NT prefix; // prefix is a buffer
+ char * NTS suffix;
+ int i, len, end;
+
+ len = strlen(name);
+ end = -1;
+ for (i=0; i<len; i++) {
+ if (name[i] == '!') {
+ end = i;
+ break;
+ }
+ }
+
+ if (end < 0) {
+ suffix = NULL;
+ prefix = strdup(name);
+ } else {
+ prefix = (char *)malloc(end + 1);
+ memcpy(NTDROP(prefix), NTDROP(NTEXPAND(name)), end); // KEEP t1: success
+ strncpy(prefix, name, end); // KEEP t2: success
+ prefix[end] = 0x00;
+
+ suffix = strdup(name + end + 1);
+ }
+ return 0;
+}
--- /dev/null
+// String tests from David.
+
+#include <stdio.h>
+#include <string.h>
+
+
+IFTEST docstring-1 : success
+
+void separate_short_docstring(char * NT str,
+ char *NT *short_s,
+ char *NT *long_s)
+{
+ char *dot, *at;
+
+ if(str == NULL) {
+ *short_s = NULL;
+ *long_s = NULL;
+ return;
+ }
+
+ /* find the first period, followed by whitespace, or the first '@', preceded by whitespace */
+ dot = str;
+ do {
+ dot = strchr(dot,'.');
+ if(dot == NULL) break;
+ dot++;
+ } while(*dot != '\0' && *dot != ' ' && *dot != '\t' && *dot != '\r' && *dot != '\n');
+
+ at = str-2;
+ do {
+ at = strchr(at+2,'@');
+ if(at == NULL) break;
+ at--;
+ if(at < str) at++;
+ } while(*at != ' ' && *at != '\t' && *at != '\r' && *at != '\n');
+
+ if(at && at < dot)
+ dot = at;
+
+
+ /* check for the beginning of the next sentance */
+ if(dot != NULL) {
+ dot += strspn(dot, " \t\n\r.");
+ if( *dot == '\0' )
+ dot = NULL;
+ }
+
+ /* short description only */
+ if(dot == NULL) {
+ *short_s = str;
+ *long_s = NULL;
+ }
+
+ /* both short and long descriptions */
+ else {
+ *(dot - 1)= '\0';
+ *short_s = strdup(str);
+ *(dot - 1)= ' ';
+ *long_s = str;
+ }
+}
+
+void test(char *NT str)
+{
+ char *shorts, *longs;
+
+ separate_short_docstring(strdup(str), &shorts, &longs);
+
+ printf("long: %s\n short: %s\n\n", longs ? longs : "<none>", shorts);
+}
+
+int main(int argc, char *NT *argv)
+{
+ test("Simple.");
+ test("With long. Longer");
+ test("This is a short with a.dot.");
+ test("The @marks the beginning of long, but this example reveals a bug");
+ test("The @marks the beginning of long. Works with more than one sentence");
+ test("But@not always");
+ return 0;
+}
+
+ENDIF
+
+
+// ====================================
+IFTEST docstring-2 : success
+
+int issep(char c)
+{
+ return c == '\0' || c == ' ' || c == '\t' || c == '\n' || c == '\r';
+}
+
+void separate_short_docstring(char *NT str, char *NT *short_s, char *NT *long_s)
+{
+ char *dot, *at;
+
+ if (str == NULL)
+ {
+ *short_s = NULL;
+ *long_s = NULL;
+ return;
+ }
+
+ /* find the first period, followed by whitespace, or the first '@',
+ preceded by whitespace */
+ dot = str;
+ for (;;)
+ {
+ dot = strchr(dot,'.');
+ if(dot == NULL)
+ break;
+ dot++;
+ if (issep(*dot))
+ break;
+ }
+
+ at = str;
+ for (;;)
+ {
+ at = strchr(at, '@');
+ if (at == NULL)
+ break;
+ if (at > str && issep(at[-1]))
+ {
+ at--;
+ break;
+ }
+ at++;
+ }
+
+ if (at && (!dot || at < dot))
+ dot = at;
+
+ /* move to the beginning of the next sentance */
+ if (dot)
+ {
+ dot += strspn(dot, " \t\n\r.");
+ if (*dot == '\0')
+ dot = NULL;
+ }
+
+ if (!dot)
+ {
+ /* short description only */
+ *short_s = str;
+ *long_s = NULL;
+ }
+ else
+ {
+ /* both short and long descriptions */
+ dot[-1] = '\0';
+ *short_s = strdup(str);
+ dot[-1] = ' ';
+ *long_s = str;
+ }
+}
+
+void test(char *NT str)
+{
+ char *shorts, *longs;
+
+ separate_short_docstring(strdup(str), &shorts, &longs);
+
+ printf("long: %s\n short: %s\n\n", longs ? longs : "<none>", shorts);
+}
+
+int main(int argc, char *NT *argv)
+{
+ test("Simple.");
+ test("With long. Longer");
+ test("This is a short with a.dot.");
+ test("The @marks the beginning of long, but this example reveals a bug");
+ test("The @marks the beginning of long. Works with more than one sentence");
+ test("But@not always");
+ return 0;
+}
+
+ENDIF
+
+// ===========================================
+IFTEST int2str : success
+
+/* integers are 31 bits long, in base 2 this makes 31 characters
+ + sign + null byte + 1 for luck */
+#define INTSTRLEN 34
+#define FALSE 0
+#define TRUE 1
+
+#include <stdint.h>
+
+typedef uint32_t u32;
+typedef int32_t i32;
+
+static char basechars[17] = "0123456789abcdef";
+
+char *int2str(char * str, int base, u32 n, int is_signed)
+/* Requires: base be 2, 8, 10 or 16. str be at least INTSTRLEN characters long.
+ Effects: Prints the ASCII representation of n in base base to the
+ string str.
+ If is_signed is TRUE, n is actually an i32
+ Returns: A pointer to the start of the result.
+*/
+{
+ char *pos;
+ int minus;
+
+ /* ints are 32 bits, the longest number will thus be
+ 32 digits (in binary) + 1(sign) characters long */
+ pos = str + INTSTRLEN - 1;
+ *--pos = '\0';
+
+ if (is_signed && (i32)n < 0)
+ {
+ minus = TRUE;
+ if ((i32)n <= -16)
+ {
+ /* this is to take care of LONG_MIN */
+ *--pos = basechars[abs((long)n % base)];
+ n = (int32_t)n / base;
+ }
+ n = -(i32)n;
+ }
+ else minus = FALSE;
+
+ do {
+ *--pos = basechars[n % base];
+ n /= base;
+ } while (n > 0);
+ if (minus) *--pos = '-';
+
+ return pos;
+}
+
+void testu(int base, uint32_t n)
+{
+ char buf[INTSTRLEN];
+
+ printf("%s\n", int2str(buf, base, n, FALSE));
+}
+
+void testi(int base, int32_t n)
+{
+ char buf[INTSTRLEN];
+
+ printf("%s\n", int2str(buf, base, (uint32_t)n, TRUE));
+}
+
+int main(int argc, char *NT *argv)
+{
+ uint32_t i;
+
+ for (i = 0x80000000; i; i >>= 1)
+ {
+ testu(10, i);
+ testi(10, i); testi(10, -i);
+
+ testu(2, i); testu(8, i); testu(16, i);
+ testi(10, i + 375);
+ }
+}
+
+ENDIF
+
--- /dev/null
+// String tests from Ilya.
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <ctype.h>
+#include <string.h>
+
+/*
+ * do_div() is NOT a C function. It wants to return
+ * two values (the quotient and the remainder), but
+ * since that doesn't work very well in C, what it
+ * does is:
+ *
+ * - modifies the 64-bit dividend _in_place_
+ * - returns the 32-bit remainder
+ *
+ * This ends up being the most efficient "calling
+ * convention" on x86.
+ */
+#if 0
+#define do_div(n,base) ({ \
+ unsigned long __upper, __low, __high, __mod, __base; \
+ __base = (base); \
+ asm("":"=a" (__low), "=d" (__high):"A" (n)); \
+ __upper = __high; \
+ if (__high) { \
+ __upper = __high % (__base); \
+ __high = __high / (__base); \
+ } \
+ asm("divl %2":"=a" (__low), "=d" (__mod):"rm" (__base), "0" (__low), "1" (__upper)); \
+ asm("":"=A" (n):"a" (__low),"d" (__high)); \
+ __mod; \
+})
+#else
+unsigned long do_div_func(unsigned long long * n, unsigned long base) {
+ unsigned long long res = *n / base;
+ unsigned rem = *n - res * base;
+ *n = res;
+ return rem;
+}
+#define do_div(n,base) do_div_func(&(n), (base))
+#endif
+
+
+/**
+ * simple_strtoul - convert a string to an unsigned long
+ * @cp: The start of the string
+ * @endp: A pointer to the end of the parsed string will be placed here
+ * @base: The number base to use
+ */
+unsigned long simple_strtoul(const char * NTS cp,
+ char * NTS * endp, unsigned int base)
+{
+ unsigned long result = 0,value;
+
+ if (!base) {
+ base = 10;
+ if (*cp == '0') {
+ base = 8;
+ cp++;
+ if ((toupper(*cp) == 'X') && isxdigit(cp[1])) {
+ cp++;
+ base = 16;
+ }
+ }
+ } else if (base == 16) {
+ if (cp[0] == '0' && toupper(cp[1]) == 'X')
+ cp += 2;
+ }
+ while (isxdigit(*cp) &&
+ (value = isdigit(*cp) ? *cp-'0' : toupper(*cp)-'A'+10) < base) {
+ result = result*base + value;
+ cp++;
+ }
+ if (endp)
+ *endp = (char *)cp;
+ return result;
+}
+
+ /**
+ * simple_strtoull - convert a string to an unsigned long long
+ * @cp: The start of the string
+ * @endp: A pointer to the end of the parsed string will be placed here
+ * @base: The number base to use
+ */
+unsigned long long simple_strtoull(const char * NTS cp,
+ char * NTS * endp,unsigned int base)
+{
+ unsigned long long result = 0,value;
+
+ if (!base) {
+ base = 10;
+ if (*cp == '0') {
+ base = 8;
+ cp++;
+ if ((toupper(*cp) == 'X') && isxdigit(cp[1])) {
+ cp++;
+ base = 16;
+ }
+ }
+ } else if (base == 16) {
+ if (cp[0] == '0' && toupper(cp[1]) == 'X')
+ cp += 2;
+ }
+ while (isxdigit(*cp) && (value = isdigit(*cp) ? *cp-'0' : (islower(*cp)
+ ? toupper(*cp) : *cp)-'A'+10) < base) {
+ result = result*base + value;
+ cp++;
+ }
+ if (endp)
+ *endp = (char *)cp;
+ return result;
+}
+
+/**
+ * simple_strtoll - convert a string to a signed long long
+ * @cp: The start of the string
+ * @endp: A pointer to the end of the parsed string will be placed here
+ * @base: The number base to use
+ */
+long long simple_strtoll(const char * NTS cp,
+ char * NTS * endp,unsigned int base)
+{
+ if(*cp=='-')
+ return -simple_strtoull(cp+1,endp,base);
+ return simple_strtoull(cp,endp,base);
+}
+
+
+static int skip_atoi(const char * NTS * s)
+{
+ int i=0;
+
+ while (isdigit(**s))
+ i = i*10 + *((*s)++) - '0';
+ return i;
+}
+
+#define ZEROPAD 1 /* pad with zero */
+#define SIGN 2 /* unsigned/signed long */
+#define PLUS 4 /* show plus */
+#define SPACE 8 /* space if plus */
+#define LEFT 16 /* left justified */
+#define SPECIAL 32 /* 0x */
+#define LARGE 64 /* use 'ABCDEF' instead of 'abcdef' */
+
+// buf - the buffer where to write the number
+// end - the last character in buffer towrite ?
+// num - the number to convert
+// base -
+// size - seems to be the size of the representation.
+// precision -
+// type -
+// Now do we say that the return value is related to the argument ?
+static char * number(char * BND(__this, end+1) buf,
+ char * SNT end, unsigned long long num,
+ int base, int size, int precision, int type)
+{
+ char c,sign,tmp[66]; // This will break if we work with larger numbers
+ const char *digits;
+ static const char small_digits[] =
+ "0123456789abcdefghijklmnopqrstuvwxyz";
+ static const char large_digits[] =
+ "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
+ int i;
+
+ digits = (type & LARGE) ? large_digits : small_digits;
+ if (type & LEFT)
+ type &= ~ZEROPAD;
+ if (base < 2 || base > 36)
+ return NULL;
+ c = (type & ZEROPAD) ? '0' : ' ';
+ sign = 0;
+ if (type & SIGN) {
+ if ((signed long long) num < 0) {
+ sign = '-';
+ num = - (signed long long) num;
+ size--;
+ } else if (type & PLUS) {
+ sign = '+';
+ size--;
+ } else if (type & SPACE) {
+ sign = ' ';
+ size--;
+ }
+ }
+ if (type & SPECIAL) {
+ if (base == 16)
+ size -= 2;
+ else if (base == 8)
+ size--;
+ }
+ i = 0;
+ if (num == 0)
+ tmp[i++]='0';
+ else while (num != 0)
+ tmp[i++] = digits[do_div(num,base)];
+ if (i > precision)
+ precision = i;
+ size -= precision;
+ if (!(type&(ZEROPAD+LEFT))) {
+ while(size-->0) {
+ if (buf <= end)
+ *buf = ' ';
+ ++buf;
+ }
+ }
+ if (sign) {
+ if (buf <= end)
+ *buf = sign;
+ ++buf;
+ }
+ if (type & SPECIAL) {
+ if (base==8) {
+ if (buf <= end)
+ *buf = '0';
+ ++buf;
+ } else if (base==16) {
+ if (buf <= end)
+ *buf = '0';
+ ++buf;
+ if (buf <= end)
+ *buf = digits[33];
+ ++buf;
+ }
+ }
+ if (!(type & LEFT)) {
+ while (size-- > 0) {
+ if (buf <= end)
+ *buf = c;
+ ++buf;
+ }
+ }
+ while (i < precision--) {
+ if (buf <= end)
+ *buf = '0';
+ ++buf;
+ }
+
+ while (i-- > 0) {
+ if (buf <= end)
+ *buf = tmp[i];
+ ++buf;
+ }
+ while (size-- > 0) {
+ if (buf <= end)
+ *buf = ' ';
+ ++buf;
+ }
+ return buf;
+}
+
+TESTDEF number-ok : success
+IFTEST number-ok
+int main(int argc, char* argv[])
+{
+ char* buf = malloc(18);
+ number(buf, buf + 17, 7777777, 10, 10, 5, SIGN);
+ return 0;
+}
+ENDIF
+
+TESTDEF number-fail : error
+IFTEST number-fail
+int main(int argc, char* argv[])
+{
+ char* buf = malloc(18);
+ // We are passing an end pointer that is too far.
+ number(buf, buf + 18, 7777777, 10, 10, 5, SIGN);
+ return 0;
+}
+ENDIF
+
+TESTDEF number-fail2 : error
+IFTEST number-fail
+int main(int argc, char* argv[])
+{
+ char* buf = malloc(8);
+ // The size parameter is too large
+ number(buf, buf + 7, 7777777, 10, 10, 5, SIGN);
+ return 0;
+}
+ENDIF
+
+TESTDEF skip-ok : success
+IFTEST skip-ok
+int main(int argc, char* argv[])
+{
+ const char* buf1 = strdup("123456");
+ skip_atoi(&buf1);
+ return 0;
+}
+ENDIF
+
+TESTDEF skip-fail : error
+IFTEST skip-fail
+int main(int argc, char* argv[])
+{
+ char * NT buf = malloc(8);
+ memcpy(buf, "12345678", 8);
+ skip_atoi(&buf);
+ return 0;
+}
+ENDIF
+
+TESTDEF strtoul-ok : success
+IFTEST strtoul-ok
+int main(int argc, char* argv[])
+{
+ char* buf = malloc(32);
+ char* end;
+
+ strncpy(buf, "1234\0", sizeof(buf));
+ simple_strtoul(buf, &end, 10);
+ return 0;
+}
+ENDIF
+
+
+TESTDEF strtoul-fail : error
+IFTEST strtoul-fail
+int main(int argc, char* argv[])
+{
+ char* buf = malloc(4);
+ char* end;
+
+ memcpy(buf, "1234\0", 4);
+ simple_strtoul(buf, &end, 10);
+ return 0;
+}
+ENDIF
+
--- /dev/null
+// String tests from Zach.
+
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+
+IFTEST str-qs-1 : success
+#define NUMSTRINGS 11
+char *NTS strings[] = { "abracadabra",
+ "bamboozled",
+ "Canada Dry Ginger Ale",
+ "boston champion",
+ "Shostakovich: Symphony No. 10",
+ "PRINTED LINING FOR PRIVACY",
+ "www.asus.com",
+ "Curiously Strong Peppermints",
+ "o",
+ "\0",
+ "" };
+
+void reverse(char *NTS s)
+{
+ int c, i, j;
+
+ for(i = 0, j = strlen(s) - 1; i < j; i++, j--) {
+ c = s[i];
+ s[i] = s[j];
+ s[j] = c;
+ }
+}
+
+//s must have room for '-' and a 10 digit number
+char *itoa(int n, char * COUNT(11) s, int w)
+{
+ int i, sign;
+
+ if ( (sign = n) < 0 ) {
+ n = -n;
+ }
+
+ i = 0;
+ do {
+ s[i++] = n % 10 + '0';
+ } while ( (n /= 10) > 0 );
+
+ if (sign < 0) {
+ s[i++] = '-';
+ }
+
+ while(i < w) {
+ s[i++] = ' ';
+ }
+
+ s[i]= '\0';
+
+ reverse(s);
+ return s;
+}
+
+int str_compare(const void *v1, const void *v2)
+{
+ char *s1 = *(char **)v1;
+ char *s2 = *(char **)v2;
+ int s1l = strlen(s1);
+ int s2l = strlen(s2);
+ int n1 = atoi(s1 + s1l - 2);
+ int n2 = atoi(s2 + s2l - 2);
+
+ if( n1 > n2 )
+ return 1;
+ if( n2 > n1 )
+ return -1;
+ return 0;
+}
+
+void test()
+{
+ char *copy[NUMSTRINGS];
+ char num[3];
+ int i, j, l, sum;
+
+ for( i = 0; i < NUMSTRINGS; i++ ) {
+ l = strlen(strings[i]);
+ copy[i] = malloc( l + 3 );
+ strncpy( copy[i], strings[i], l );
+
+ sum = 0;
+ for( j = 0; j < l; j++ ) {
+ sum += 11 * copy[i][j] + 7;
+ }
+ sum %= 97;
+
+ itoa( sum, num, 2 );
+ strncat( copy[i], num, 2 );
+ }
+
+ qsort( copy, NUMSTRINGS, sizeof(copy[1]), str_compare );
+
+ for( i = 0; i < NUMSTRINGS; i++ ) {
+
+ printf( "%s\n", copy[i] );
+
+ }
+
+ return;
+}
+
+int main()
+{
+ test();
+ return 0;
+}
+ENDIF
+
+TESTDEF str-qsf-1 : error
+IFTEST str-qsf-1
+#define NUMSTRINGS 11
+char * NTS
+strings[] = { "abracadabra",
+ "bamboozled",
+ "Canada Dry Ginger Ale",
+ "boston champion",
+ "Shostakovich: Symphony No. 10",
+ "PRINTED LINING FOR PRIVACY",
+ "www.asus.com",
+ "Curiously Strong Peppermints",
+ "o",
+ "\0",
+ "" };
+
+void reverse(char * NTS s)
+{
+ int c, i, j;
+
+ for(i = 0, j = strlen(s) - 1; i < j; i++, j--) {
+ c = s[i];
+ s[i] = s[j];
+ s[j] = c;
+ }
+}
+
+char * NTS itoa(int n, char * NT COUNT(w) s, int w)
+{
+ int i, sign;
+
+ if ( (sign = n) < 0 ) {
+ n = -n;
+ }
+
+ i = 0;
+ do {
+ s[i++] = n % 10 + '0';
+ } while ( (n /= 10) > 0 );
+
+ if (sign < 0) {
+ s[i++] = '-';
+ }
+
+ while(i < w) {
+ s[i++] = ' ';
+ }
+
+ s[i]= '\0';
+
+ reverse(s);
+ return s;
+}
+
+int str_compare(char * NTS * v1, char * NTS * v2)
+{
+ char *s1 = *(char * NTS *)v1;
+ char *s2 = *(char * NTS *)v2;
+ int s1l = strlen(s1);
+ int s2l = strlen(s2);
+ int n1 = atoi(s1 + s1l - 2);
+ int n2 = atoi(s2 + s2l - 2);
+
+ if( n1 > n2 )
+ return 1;
+ if( n2 > n1 )
+ return -1;
+ return 0;
+}
+
+void test()
+{
+ char *copy[NUMSTRINGS];
+ char num[3];
+ int i, j, l, sum;
+
+ for( i = 0; i < NUMSTRINGS; i++ ) {
+ l = strlen(strings[i]);
+ copy[i] = malloc( l + 3 );
+ strncpy( copy[i], strings[i], l );
+
+ sum = 0;
+ for( j = 0; j <= l + 3; j++ ) {
+ sum += 11 * copy[i][j] + 7;
+ }
+ sum %= 97;
+
+ itoa( sum, num, 2 );
+ strncat( copy[i], num, 2 );
+ }
+
+ qsort( copy, NUMSTRINGS, sizeof(copy[1]), str_compare );
+
+ for( i = 0; i < NUMSTRINGS; i++ ) {
+
+ printf( "%s\n", copy[i] );
+
+ }
+
+ return;
+}
+
+int main()
+{
+ test();
+ return 0;
+}
+ENDIF
+
+TESTDEF "str-wl-1" : success
+IFTEST "str-wl-1"
+#define NUMSTRINGS 9
+char *NTS strings[] = { "abracadabra",
+ "bamboozled",
+ "Canada Dry Ginger Ale",
+ "boston champion",
+ "Shostakovich: Symphony No. 10",
+ "PRINTED LINING FOR PRIVACY",
+ "www.asus.com",
+ "Curiously Strong Peppermints",
+ "o"};
+
+void test()
+{
+ char *copy[NUMSTRINGS];
+ int i, l;
+
+ for( i = 0; i < NUMSTRINGS; i++ ) {
+ l = strlen( strings[i] );
+ //matth: we don't support this
+ copy[i] = malloc( l + 2 );
+ strncpy( copy[i], strings[i], l );
+
+ copy[i][l] = copy[i][l-1];
+ copy[i][l+1] = '\0';
+ printf( "%s\n", copy[i] );
+ }
+
+ return;
+}
+
+int main()
+{
+ test();
+ return 0;
+}
+ENDIF
+
+TESTDEF "str-wlf-1" : error
+IFTEST "str-wlf-1"
+#define NUMSTRINGS 11
+char * NTS
+strings[] = { "abracadabra",
+ "bamboozled",
+ "Canada Dry Ginger Ale",
+ "boston champion",
+ "Shostakovich: Symphony No. 10",
+ "PRINTED LINING FOR PRIVACY",
+ "www.asus.com",
+ "Curiously Strong Peppermints",
+ "o",
+ "\0",
+ "" };
+
+void test()
+{
+ char * NTS copy[NUMSTRINGS];
+ int i, l;
+
+ for( i = 0; i < NUMSTRINGS; i++ ) {
+ l = strlen( strings[i] );
+ copy[i] = malloc( l + 2 );
+ strncpy( copy[i], strings[i], l );
+
+ copy[i][l] = copy[i][l-1];
+ copy[i][l+1] = '\0';
+ printf( "%s\n", copy[i] );
+ }
+
+ return;
+}
+
+int main()
+{
+ test();
+ return 0;
+}
+ENDIF
+
+TESTDEF "str-wsqpp-1" : success
+IFTEST "str-wsqpp-1"
+#define NUMSTRINGS 11
+char * NTS strings[] = { "abracadabra",
+ "bamboozled",
+ "Canada Dry Ginger Ale",
+ "boston champion",
+ "Shostakovich: Symphony No. 10",
+ "PRINTED LINING FOR PRIVACY",
+ "www.asus.com",
+ "Curiously Strong Peppermints",
+ "o",
+ "\0",
+ "" };
+
+void test()
+{
+ char * NTS copy[NUMSTRINGS];
+ char *q;
+ int i, j, l, sum;
+
+ for( i = 0; i < NUMSTRINGS; i++ ) {
+ l = strlen( strings[i] );
+ copy[i] = strdup( strings[i] );
+ strncpy( copy[i], strings[i], l );
+
+ sum = 0;
+ q = copy[i];
+ while( *q++ ) {
+ sum += *(q - 1);
+ *(q - 1) = 'A';
+ }
+ }
+
+ return;
+}
+
+int main()
+{
+ test();
+ return 0;
+}
+ENDIF
+
+TESTDEF "str-wsqppf-1" : error
+IFTEST "str-wsqppf-1"
+#define NUMSTRINGS 11
+char *strings[] = { "abracadabra",
+ "bamboozled",
+ "Canada Dry Ginger Ale",
+ "boston champion",
+ "Shostakovich: Symphony No. 10",
+ "PRINTED LINING FOR PRIVACY",
+ "www.asus.com",
+ "Curiously Strong Peppermints",
+ "o",
+ "\0",
+ "" };
+
+void test()
+{
+ char *copy[NUMSTRINGS];
+ char *q;
+ int i, j, l, sum;
+
+ for( i = 0; i < NUMSTRINGS; i++ ) {
+ l = strlen( strings[i] );
+ copy[i] = strdup( strings[i] );
+ strncpy( copy[i], strings[i], l );
+
+ sum = 0;
+ q = copy[i];
+ while( *q++ ) {
+ sum += *(q);
+ *(q) = 'A';
+ }
+ }
+
+ return;
+}
+
+int main()
+{
+ test();
+ return 0;
+}
+ENDIF
--- /dev/null
+#include <string.h>
+#include "harness.h"
+
+//Test strlcpy. This test is not in the regression suite, because
+//strlcpy doesn't work on Manju.
+
+
+char* NTS global = "Really long string. etc., etc., etc.";
+
+TESTDEF baseline: success
+
+int main() {
+ char buf[10];
+
+ //The buffer size is 10, so we should pass 9 to strncpy and 10 to strlcpy
+
+ strncpy(buf, global, 9);
+ strncpy(buf, global, 10); //KEEP strncpy: error = Assertion failed
+
+ strlcpy(buf, global, 10);
+ if (buf[9] != 0) E(3);
+
+ //make sure strlcat works too
+ buf[5] = 0;
+ strlcat(buf, global, 10);
+ if (buf[9] != 0) E(4);
+
+ SUCCESS;
+}
--- /dev/null
+// KEEP baseline: success
+
+#include <string.h>
+#include <stdio.h>
+
+int main() {
+ char (NT foo)[10];
+ int i;
+
+ foo[8] = 42;
+ strncpy(foo, "blah blah blah", 7);
+
+ // We're not allowed to specify 10 here, because strncpy can overwrite
+ // the final zero otherwise.
+ strncpy(foo, "blah blah blah", 10); // KEEP e1: error = nullterm upper bound
+
+ // Make sure item 8 was not overwritten.
+ return (foo[8] == 42) ? 0 : 1;
+}
--- /dev/null
+// demonstrate strpbrk problem, and workaround
+
+#include <string.h> // strpbrk
+
+int main()
+{
+ char * NTS s = "foo";
+ char * NTS accept = "o";
+ char * NTS w;
+
+ w = strpbrk(s, accept);
+
+ return !( *w == 'o' && (w-s == 1) );
+}
--- /dev/null
+
+#include <string.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+#define E(n) { printf("Error %d\n", n); exit(n); }
+
+int main() {
+ char * str = "aabbcccdef";
+
+ if(strspn(str, "abc") != 7) E(1);
+
+ if(strcspn(str, "cdef") != 4) E(2);
+
+ return 0;
+}
--- /dev/null
+// models.c
+// tests of models and wrappers
+
+#include <string.h> // strchr
+#include <assert.h> // assert
+#include <stdio.h> // printf
+
+TESTDEF : success
+
+void t_strchr()
+{
+ char buf[40] = "hello world";
+ char *p = buf;
+ char *q;
+
+ q = strchr(p, 'w');
+ assert(q == p+6);
+}
+
+
+void t_strdup()
+{
+ char c[2] = "a";
+ char *p = c; // nominally safe (?)
+ char *q;
+
+ q = strdup(p); // strdup_fs without the model
+ assert(q != NULL); // use q somehow
+}
+
+
+void t_strpbrk_sff()
+{
+ char buf[10] = "abcdefghi";
+ char *b = buf;
+ char *p;
+
+ //p++; // fseq
+ //b++; // fseq
+ p = strpbrk(b, "gfe");
+ p++; // seq?
+ p--;
+ assert(p == buf+4);
+ printf("strpbrk_sff ok\n");
+}
+
+// Try an unannotated global buffer
+IFTEST : error = Cast from ordinary pointer to nullterm: globuf
+ char globuf[10] = "abcdefghi";
+ELSE
+ char (NT globuf)[10] = "abcdefghi";
+ENDIF
+void t_strpbrk_fff()
+{
+ char *b = globuf;
+ char *p;
+
+ b++; // fseq
+ p = strpbrk(b, "gfe");
+ assert(p == globuf+4);
+ printf("strpbrk_fff ok\n");
+}
+
+void t_strtok()
+{
+ char buf[80] = "xabc def ghi";
+ char *b = buf;
+ char *p;
+
+ p = strtok(b, " ");
+ printf("abc: %s\n", p);
+ p = strtok(NULL, " ");
+ printf("def: %s\n", p);
+ p = strtok(NULL, " ");
+ printf("ghi: %s\n", p);
+ p = strtok(NULL, " ");
+ assert(p == NULL);
+}
+
+
+int main()
+{
+ t_strchr();
+ t_strdup();
+ t_strpbrk_sff();
+ t_strpbrk_fff();
+ t_strtok();
+
+ return 0;
+}
+
+
--- /dev/null
+// KEEP baseline: success
+
+#include <stdarg.h>
+
+int foo(int n, ...) TRUSTED {
+ int i;
+ int sum = 0;
+ va_list ap;
+
+ va_start(ap, n);
+ for (i = 0; i < n; i++) {
+ sum += va_arg(ap, int);
+ }
+ va_end(ap);
+
+ return sum;
+}
+
+int main() {
+ int * SAFE z = 0;
+ int sum = 0;
+
+ sum += foo(0);
+ sum += foo(1, 1);
+ sum += foo(3, 1, 2, 3);
+ sum += foo(1, *z); // KEEP err1: error = non-null
+
+ return (sum != 7) ? 1 : 0;
+}
--- /dev/null
+// DO NOT CHANGE THIS LINE
+// Test that read and readv work.
+
+#include <sys/uio.h>
+#include <stdlib.h>
+#include <unistd.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <string.h>
+#include <stdio.h>
+#include <errno.h>
+
+#include <sys/types.h>
+#include <unistd.h>
+
+#define myassert(I) do { \
+ if(!(I)) { \
+ printf("%s:%d **************** assertion failure\n", __FILE__, __LINE__); \
+ abort(); \
+ } \
+} while(0)
+
+# define MSG0 "HI THERE"
+# define MSG1 "BYE NOW!"
+# define TESTFILE "writev_test.tmp"
+
+void delete_file(char * NTS name) {
+ if(!(unlink(TESTFILE)==0)) {
+ if (errno!=ENOENT) perror("error unlinking");
+ }
+ errno = 0;
+ {
+ struct stat s;
+ int statval = stat(TESTFILE, &s);
+ myassert(statval == -1);
+ myassert(errno == ENOENT);
+ }
+}
+
+void test_writev() {
+ int in;
+ int out;
+ int num_written;
+ int num_left;
+ char *buf;
+ const int size = 8;
+ struct iovec iov[2];
+ char *dummy;
+ iov[0].iov_len = 8;
+ iov[0].iov_base = NTDROP("HI THERE");
+ myassert(iov[0].iov_len == size);
+ dummy = "asdfasdf"; // attempt to break string contiguity
+ iov[1].iov_len = 8;
+ iov[1].iov_base = NTDROP("BYE NOW!");
+ myassert(iov[1].iov_len == size);
+
+ // Get rid of the testfile.
+ delete_file(TESTFILE);
+
+ out = open(TESTFILE, O_WRONLY | O_TRUNC | O_CREAT, S_IRUSR | S_IWUSR);
+ if (out==-1) {
+ perror("**** error opening file for writing");
+ abort();
+ }
+
+ // NOTE: we assume that it maximally flushes the buffers.
+ {
+ num_written = writev(out, iov, 2);
+ myassert(num_written = 2 * size);
+ myassert(close(out)==0);
+ }
+ printf("wrote file\n");
+
+ // check it is what we expect.
+ {
+ buf = malloc((2*size+1) * sizeof buf[0]);
+ in = open(TESTFILE, O_RDONLY);
+ myassert(buf!=0);
+ if (in==-1) {
+ perror("**** error opening file for reading");
+ abort();
+ }
+
+ // read
+ printf("trying to read file\n");
+ {
+ num_left = 2*size;
+ while(num_left) {
+ int num_read = read(in, NTDROP(buf)+(2*size)-num_left, num_left);
+ num_left -= num_read;
+ }
+ buf[2*size] = '\0';
+ myassert(num_left==0);
+ myassert(close(in)==0);
+ }
+
+ // check it is what we expect.
+ // NOTE: strings literals concatenate at compile time
+ printf("read:%s:\n", buf);
+ myassert(strcmp(TC(buf), MSG0 MSG1)==0);
+ printf("success\n");
+
+ // Get rid of the testfile.
+ delete_file(TESTFILE);
+}
+}
+
+int main() {
+ printf("test writev\n");
+ test_writev();
+ return 0;
+}
--- /dev/null
+*.exe
+*.o
+*.i
+*.cil.c
+*-tmp.c
+*.stackdump
+tout.c
--- /dev/null
+include ../Makefile
+
+CC = gcc
+
+# The list of tests is in ../runtests.pl
+
+.PHONY: clean alltests
+
+alltests:
+ cd ..; ./testdeputy -r --nogroup slow --nogroup ALWAYS
+# @echo -e "\n\nAll tests were successful. \n\n"
+
+clean:
+ rm -f *.cil.c *.i *.exe *.o *~ *.stackdump *-tmp.c
+
+ifndef NODEPUTY
+OPTIONS := $(OPTIONS) --fail-stop
+endif
+
+runall/%: %.c testlib.o
+ COMMAND="$(DEPUTY) $(OPTIONS) \
+ -o __BASENAME__.exe __FILE__ testlib.o && \
+ ./__BASENAME__.exe" \
+ COMMENT="//" \
+ perl $(RUNALL) $*.c
--- /dev/null
+//Deputy's optimizer ran into trouble here because of the abstract type.
+
+struct abstract;
+
+//in testlib.c:
+extern struct abstract* get_abstract();
+extern void check_abstract(struct abstract* p);
+
+//We don't yet support annotating abstract pointers with a length (even 1)
+//because there's no way to insert runtime checks that don't use arithmetic.
+struct abstract* SAFE global;
+
+int main() {
+ struct abstract *d;
+ int * p = 0;
+
+ if ((d = get_abstract()) == ((void *) 0))
+ {
+ }
+ check_abstract(d); //KEEP baseline: success
+ check_abstract(d+1); //KEEP arith: error = Arithmetic on abstract pointer
+ check_abstract(p); //KEEP wrongtype: error = Error: Type mismatch
+
+ global = d;
+
+ return 0;
+}
+
--- /dev/null
+int main() {
+ int i;
+ int * SAFE p = &i;
+ *p = 0;
+
+ return 0;
+}
--- /dev/null
+void foo(int * SAFE p) {
+ *p = 0;
+}
+
+int main() {
+ int i;
+ int * SAFE p = &i;
+ foo(p);
+
+ return 0;
+}
--- /dev/null
+// KEEP baseline: success
+
+int main(int argc, char** argv) {
+ int i;
+ int two = argc+1;
+ int * SAFE p = &i; // KEEP baseline
+ //Assign &i to a pointer of type COUNT(2). We'll catch this at
+ // either compile time or run time
+ int * COUNT(2) p = &i; // KEEP size1: error = will always fail
+ int * COUNT(two) p = &i; // KEEP size2: error = Assertion
+ *p = 0;
+
+ return 0;
+}
--- /dev/null
+// KEEP baseline: success
+
+void foo(int * COUNT(2) p) {
+ *p = 0;
+ *p = 1;
+}
+
+int main() {
+ int i;
+ int * SAFE p = &i;
+ foo(p); // KEEP size1: error = will always fail
+
+ return 0;
+}
--- /dev/null
+//This test should fail
+//KEEP baseline: error = address of lval
+
+int main() {
+ int i;
+ int * COUNT(i) q = 0;
+ int * SAFE p = 0;
+ p = &i;
+
+ return 0;
+}
--- /dev/null
+int main() {
+ int * SAFE p = 0;
+ int * SAFE * SAFE q = &p;
+
+ return 0;
+}
--- /dev/null
+//This test should fail
+//KEEP baseline: error = address of lval
+
+int main() {
+ int * BND(r,r) p = 0;
+ int * SAFE r = 0;
+ int * SAFE * SAFE q = &p;
+
+ return 0;
+}
--- /dev/null
+int main() {
+ int a[5];
+ int * COUNT(5) b = a;
+ int * SNT e = b + 5;
+
+ int * BND(b, e) p = b + 2;
+
+ int * SNT b1 = b + 1;
+ int * SNT e1 = b + 4;
+
+ int * BND(b1, e1) p1 = p;
+
+ int * SNT b2 = (int * SNT)((char * COUNT(20)) b + 2);
+ int * SNT e2 = (int * SNT)((char * COUNT(20)) b + 18);
+ int * SNT e2 = (int * SNT)((char * COUNT(20)) b + 18);
+
+ int * BND(b2, e2) p2 = p; // KEEP align1: success
+
+ //we'll allow misaligned pointers, if they aren't dereferenced
+ int * BND(b2, e2) p3 = b+4;
+ int x = *p3; // KEEP align2: error = will always fail
+
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+//Test case that shows that we need to keep the upper bound of an NT pointer
+// correctly aligned.
+
+int garbage1 = 0xaaaaaaaa;
+//An array of safe pointers.
+int (NT array)[2] = {-1, 0};
+int garbage2 = 0x55555555;
+
+TESTDEF baseline: success
+
+int main() {
+
+ { TRUSTEDBLOCK
+ //Make sure the first byte of array[2] and the last byte of array[0]
+ // are nonzero, or this test won't work.
+ if ( *((char*)(&array[2])) == 0) {
+ printf("Problem with the test case: *((char*)(&array[2])) == 0\n");
+ exit(-1);
+ }
+ if ( *(((char*)array)+3) == 0) {
+ printf("Problem with the test case: *(((char*)array)+3) == 0\n");
+ exit(-1);
+ }
+ }
+
+ unsigned long b = ((unsigned long)array);
+ unsigned long e = ((unsigned long)array) + 3;
+ unsigned long e_bad = ((unsigned long)array) + 11;
+ int * NT BND(b,e) p = array;
+
+ //Because e is unaligned, the NT extension of the bounds to e_bad will
+ //succeed.
+ int * NT BND(b,e_bad) illegal = p+2; //KEEP badNT: error = some error message
+
+ //Now we can illegally read/write p[2] a.k.a. garbage2
+ int tmp = *illegal; //KEEP badNT
+ printf("p[2] == 0x%x\n", tmp); //KEEP badNT
+ *illegal = 5; //KEEP badNT
+
+ return 0;
+}
--- /dev/null
+//This test should work without any changes.
+//KEEP baseline: success
+
+#include "harness.h"
+
+int * COUNT(42) myalloc() {
+ int len = 50;
+ int * COUNT(len) p;
+ len = 41; //KEEP wronglen: error
+ p = alloc(int, len);
+ p[12] = 12;
+ return p;
+}
+
+int main() {
+ int * COUNT(42) p = myalloc();
+ return 0;
+}
--- /dev/null
+// Makes sure allocations are properly initialized.
+
+#include "harness.h"
+
+void stack_garbage() {
+ int a[10];
+ a[0] = 42;
+ a[9] = 42;
+}
+
+void stack_test1() {
+ int *a[10];
+ if (a[0] != 0) E(1);
+ if (a[9] != 0) E(2);
+}
+
+void stack_test2() {
+ int (NT a)[10];
+ if (a[9] != 0) E(3);
+}
+
+void * (DALLOC(10 * sizeof(int)) my_alloc)() {
+ static int a[10];
+ a[0] = 42;
+ a[9] = 42;
+ return a;
+}
+
+void alloc_test1() {
+ int **p = my_alloc();
+ if (p[0] != 0) E(4);
+ if (p[9] != 0) E(5);
+}
+
+void alloc_test2() {
+ int * NT p = my_alloc();
+ if (p[9] != 0) E(6);
+}
+
+void * (DREALLOC(p, 20 * sizeof(int)) my_realloc)(void *p) {
+ static int a[20];
+ int *old = (int * COUNT(10)) TC(p);
+ int i;
+ for (i = 0; i < 10; i++) {
+ a[i] = old[i];
+ }
+ a[19] = 42;
+ return a;
+}
+
+void realloc_test1() {
+ int **p = my_alloc();
+ int **q;
+ int i;
+ p[0] = &i;
+ p[9] = &i;
+ q = my_realloc(p);
+ if (q[0] != &i) E(7);
+ if (q[9] != &i) E(8);
+ // TODO: Currently don't test zeros in "new" memory.
+}
+
+void realloc_test2() {
+ int * NT p = my_alloc();
+ int * NT q;
+ int i;
+ p[0] = 1337;
+ p[8] = 1337;
+ q = my_realloc(p);
+ if (q[0] != 1337) E(9);
+ if (q[8] != 1337) E(10);
+ if (q[9] != 0) E(11);
+ if (q[19] != 0) E(12);
+}
+
+int main() {
+ stack_garbage();
+ stack_test1();
+
+ stack_garbage();
+ stack_test2();
+
+ alloc_test1();
+ alloc_test2();
+
+ realloc_test1();
+ realloc_test2();
+
+ return 0;
+}
--- /dev/null
+// Make sure we get something reasonable when we cast malloc's result to
+// an integer type.
+
+#include "harness.h"
+
+int main() {
+ unsigned long start = (unsigned long) malloc(100);
+ return 0;
+}
--- /dev/null
+
+
+void *(DALLOC(size) mymalloc)(unsigned int size) {
+ return (void *)0;
+}
+
+int main()
+{
+ char * NTC(10) str = mymalloc(10);
+
+
+ return 0;
+}
--- /dev/null
+//This test should work without any changes.
+//KEEP baseline: success
+
+#include "harness.h"
+
+int main() {
+ int len = 260;
+ int * COUNT(len) p;
+ p = alloc(int, len);
+ p = alloc(int, len-1); //KEEP wronglen: error
+ p = alloc(char, len); //KEEP wrongtype: error = Assertion failed
+ p = alloc(int*, len);
+
+ //Don't strip the cast to char! We shouldn't think we're allocating
+ //260 ints when we really only allocate four.
+ p = alloc(int, (char)len); //KEEP cast: error = Assertion failed
+
+ p[12] = 12;
+ return 0;
+}
--- /dev/null
+// KEEP baseline: success
+
+extern void *(DALLOC(size) malloc)(unsigned int size);
+extern void *(DALLOC(size1 * size2) calloc)(unsigned int size1, unsigned int size2);
+
+void *(DALLOC(size) my_malloc)(int dummy, int size) {
+ return malloc(size);
+}
+
+void *(DALLOC(size1 * size2) my_calloc)(int dummy, int size2, int size1) {
+ int size = size1 * size2;
+ return malloc(size);
+}
+
+int * SAFE NULL = 0;
+
+int main() {
+ int * COUNT(10) p;
+ int * SAFE z = NULL;
+
+ p = my_malloc(5 * sizeof(int), 10 * sizeof(int));
+ p = my_malloc(10 * sizeof(int), 5 * sizeof(int)); // KEEP arg1: error = Assertion
+ p = my_malloc(*z, 10 * sizeof(int)); // KEEP arg2: error = Assertion
+
+ p = my_calloc(5, sizeof(int), 10);
+ p = my_calloc(10, sizeof(int), 5); // KEEP arg3: error = Assertion
+ p = my_calloc(*z, sizeof(int), 10); // KEEP arg4: error = Assertion
+
+ return 0;
+}
--- /dev/null
+// This test checks that we set bounds properly when allocating a weird
+// number of elements.
+
+// KEEP baseline: success
+
+#include "harness.h"
+
+int main() {
+ int * SAFE p;
+
+ p = alloc(char, 6);
+ p[0] = 0;
+ p[1] = 0; // KEEP bounds: error = will always fail
+
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+//When allocating an NT buffer, subtract one from the length.
+
+//KEEP baseline: success
+
+void my_strlcpy(char* COUNT(n-1) NT dest, char* NTS src, int n) {
+ int position;
+ for (position = 0; position < n-1 && *src != 0; src++, position++) {
+ dest[position] = *src;
+ }
+ if (position < n) {
+ *dest = 0;
+ }
+}
+
+int main() {
+ int len = 5;
+ char * NT buf = alloc(char, len);
+ buf[0] = buf[1] = buf[2] = buf[3] = 'a';
+ buf[4] = 0;
+ buf[4] = 'b'; //KEEP write: error = nullterm write check
+
+ my_strlcpy(buf, "Hola", 5);
+ my_strlcpy(buf, "Hello", 6); //KEEP call: error = nullterm upper bound
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+int to_alloc;
+int ** COUNT(to_alloc) to_nodes;
+double * COUNT(to_alloc) coeffs;
+
+
+int global;
+
+int main() {
+
+ int degree = 8;
+
+ to_alloc = degree;
+ to_nodes = (int **) malloc(degree*(sizeof(int *)));
+ coeffs = (double *) malloc(degree*sizeof(double));
+
+ coeffs[7] = 2.0;
+ to_nodes[7] = & global;
+
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+struct node {
+ struct node * next;
+ int * COUNT(len) buf;
+ int len;
+};
+
+int main() {
+ struct node n[2];
+ int i;
+
+ for (i = 0; i < 2; i++) {
+ struct node *p = &n[i];
+ int *tmp;
+
+ p->len = i + 1;
+ tmp = malloc(p->len * sizeof(int));
+ p->buf = tmp;
+ }
+}
--- /dev/null
+#include "harness.h"
+
+TESTDEF baseline : success
+
+char * NTS NONNULL
+cpy(char * NT NONNULL COUNT(sz) buff, char * NTS str, int sz) {
+
+ int i;
+ for(i=0;i<sz;i++) {
+ buff[i] = str[i];
+ }
+ buff[sz] = '\0';
+ return buff;
+}
+
+int main() {
+ // Problem if we call malloc as the argumnent.
+ char * t = cpy(malloc(6), "abcde", 5);
+ if(t[0] != 'a') E(1);
+ if(t[4] != 'e') E(2);
+ if(t[5] != '\0') E(3);
+
+ if(t[6] == 0) E(4); // KEEP : error = upper bound
+
+ return 0;
+}
--- /dev/null
+// Checks allocation where the LHS is a void *.
+
+#include "harness.h"
+
+struct foo {
+ int a;
+ int b;
+ int *p;
+};
+
+#define ALIGN 31
+
+int main() {
+ void *p; // KEEP t1: success
+ void * COUNT(size) p; // KEEP t2: success
+ struct foo *q;
+
+ int size;
+
+ size = (sizeof(*q) + ALIGN) & ~ALIGN;
+ size += ALIGN;
+
+ p = malloc(size);
+ memset(p, 0, size);
+
+ q = (struct foo * SAFE) TC(((long)p + ALIGN) & ~ALIGN);
+
+ return q->a;
+}
--- /dev/null
+//KEEP baseline: success
+
+//
+//Excercise nested struct/array offsets.
+//
+
+#include "harness.h"
+
+struct bar {
+ int p[10][50];
+};
+
+struct foo1 {
+ int len;
+ struct bar* COUNT(len) bars;
+};
+
+struct foo2 {
+ int data;
+ struct foo1 foo1;
+};
+
+void foo2_init(struct foo2 * COUNT(5) f) {
+ struct bar* COUNT(len) bars;
+ for (int i = 0; i < 5; i++) {
+ f[i].data =42;
+ bars = 0;
+ int len = i+1;
+ bars = alloc(struct bar, len);
+ f[i].foo1.len = len;
+ f[i].foo1.bars = bars;
+ }
+}
+
+
+int main() {
+ struct foo2 f[5];
+ foo2_init(f);
+ struct foo2 * SAFE middle = &f[3]; //test addr of array element.
+
+ struct foo2 * COUNT(2) middle1 = &f[3]; //test addr of array element.
+
+ int i = 4; //index into f
+ int j = i; //index into foo1.bars
+ int k = 9; //first index into bar.p
+ int k2 = 49; //second index into bar.p
+ i++; //KEEP i: error
+ j++; //KEEP j: error
+ k++; //KEEP k: error
+ k2++; //KEEP k2: error
+ i = -1; //KEEP ineg: error = will always fail
+ j = -1; //KEEP jneg: error = will always fail
+ k = -1; //KEEP kneg: error = will always fail
+ k2 = -1;//KEEP k2neg: error = Assertion failed
+
+ //Make sure each offset is checked correctly:
+ int x = f[i].foo1.bars[j].p[k][k2];
+
+ f[i].foo1.bars[j].p[k][k2] = x+1; //KEEP set: success
+
+ middle->data = middle1->data;
+
+ return 0;
+}
--- /dev/null
+// This test ensures that the appropriate substitution is applied to the
+// base type of an array.
+
+int main() {
+ int * SAFE a[1];
+ int * SAFE p;
+
+ a[0] = 0;
+ p = a[0];
+
+ return 0;
+}
--- /dev/null
+#define NDIM 3
+double distv(double * COUNT(NDIM) v)
+{
+ // So we could increment it
+ double *w = v;
+ return *w;
+}
+
+int main() {
+ double v[NDIM] = { 1.0, 2.0, 3.0 };
+ if (1.0 != distv(v)) {
+ return 1;
+ }
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+#define E(n) { printf("Error %d\n", n); exit(n); }
+
+int array[8] = { 0, 1, 2, 3, 4, 5, 6, 7}; // A global array
+
+
+// A pointer in the array
+int * BND(array, array + 8) parray; // KEEP : success
+int * BND(array, & array[8]) parray; // KEEP : success
+
+// A couple of errors
+int * BND(& 1, 0) parray; // KEEP : error = Address-of used on a non-lvalue
+int * BND(array[0][0], 0) parray; // KEEP : error = Index used on a non-array
+
+
+int main() {
+ parray = & array[5];
+
+ // Access the start and the end of the array
+ if(parray[-5] != 0) E(1);
+ if(parray[2] != 7) E(2);
+
+ parray ++;
+
+ if(* parray != 6) E(3);
+
+ return 0;
+}
--- /dev/null
+typedef struct
+{
+ char data[1];
+} cc1000_header_t;
+
+char array[10];
+
+int main(void)
+{
+ char * p = &array[5];
+ //sizeof is unsigned, so CIL treats this as p += 4294967295
+ p = p - sizeof(cc1000_header_t);
+ return *p;
+}
--- /dev/null
+#include "harness.h"
+
+#include "harness.h"
+
+int array[8] = { 0, 1, 2, 3, 4, 5, 6, 7}; // A global array
+
+
+// Make sure we give good error messages for assignments that will always fail.
+int * COUNT(8) parray; // KEEP : success
+int * COUNT(9) parray; // KEEP : error = array + 9 <= array + 8
+
+
+int main() {
+ parray = array;
+
+ if(parray[6] != 6) E(3);
+
+ return 0;
+}
--- /dev/null
+// Make sure we use bounds in array parameters to functions.
+
+int foo(int a[4]) {
+ return a[3];
+}
+
+int main() {
+ int a[4];
+ a[3] = 0;
+ return foo(a);
+}
--- /dev/null
+
+#include "harness.h"
+
+#define EFAT BND(__this, __auto)
+#define FAT BND(__auto, __auto)
+
+int a[] = { 0, 1, 2, 3};
+
+int * FAT g;
+
+int * EFAT gf;
+
+int main() {
+ int * EFAT pf;
+ // Test assignment split to split
+ pf = & a[2];
+
+ if(pf[0] != 2) E(1);
+ if(pf[1] != 3) E(2);
+ pf[-1] = 0; // KEEP low1 : error = will always fail
+ pf[2] = 0; // KEEP high1 : error = access check
+
+
+ // Test assignment split to fat
+ g = &a[2];
+
+ if(g[-2] != 0) E(11);
+ if(g[1] != 3) E(12);
+ g[-3] = 0; // KEEP low2 : error = lower bound
+ g[2] = 0; // KEEP high2 : error = Assertion failed
+
+ // Test assignment fat to split, from FAT to FSEQ
+ pf = g;
+
+ if(pf[0] != 2) E(21);
+ if(pf[1] != 3) E(22);
+ pf[-1] = 0; // KEEP low3 : error = will always fail
+ pf[2] = 0; // KEEP high3 : error = Assertion failed
+
+
+ // Test assignment split to fat, from EFAT to SEQ
+ g = pf;
+
+ if(g[0] != 2) E(31);
+ if(g[1] != 3) E(32);
+ g[-1] = 0; // KEEP low4 : error = lower bound
+ g[2] = 0; // KEEP high4 : error = Assertion failed
+
+ // Test assignment fat to fat, from FAT to FSEQ
+ gf = g;
+
+ if(gf[0] != 2) E(41);
+ if(gf[1] != 3) E(42);
+ gf[-1] = 0; // KEEP low5 : error = will always fail
+ gf[2] = 0; // KEEP high5 : error = Assertion failed
+
+
+ // Test assignment fat to fat, from EFAT to SEQ
+ g = gf;
+
+ if(g[0] != 2) E(51);
+ if(g[1] != 3) E(52);
+ g[-1] = 0; // KEEP low6 : error = lower bound
+ g[2] = 0; // KEEP high6 : error = Assertion failed
+
+
+ return 0;
+}
--- /dev/null
+
+#include "harness.h"
+
+#define EFAT BND(__this, __auto)
+#define FAT BND(__auto, __auto)
+
+int a[] = { 0, 1, 2, 3};
+
+int * FAT g;
+
+struct fat {
+ int * FAT s;
+ int * EFAT f;
+ int * FAT as[4];
+} gstruct;
+
+int main() {
+ int * EFAT * pf;
+
+ struct fat * EFAT ps;
+
+ // Test assignment to struct
+ gstruct.s = & a[2];
+
+ if(gstruct.s[-2] != 0) E(1);
+ if(gstruct.s[1] != 3) E(2);
+ gstruct.s[-3] = 0; // KEEP low1 : error = Assertion failed
+ gstruct.s[2] = 0; // KEEP high1 : error = Assertion failed
+
+ gstruct.f = gstruct.s;
+
+ pf = & gstruct.f;
+
+ if((*pf)[0] != 2) E(11);
+ if((*pf)[1] != 3) E(12);
+ (*pf)[-1] = 0; // KEEP low2 : error = will always fail
+ (*pf)[2] = 0; // KEEP high2 : error = Assertion failed
+
+ gstruct.as[2] = * pf;
+
+ if(gstruct.as[2][0] != 2) E(21);
+ if(gstruct.as[2][1] != 3) E(22);
+ gstruct.as[2][-1] = 0; // KEEP low3 : error = Assertion failed
+ gstruct.as[2][2] = 0; // KEEP high3 : error = Assertion failed
+
+ {
+ int * EFAT p = & a[2];
+
+ pf = & p;
+
+ if((*pf)[0] != 2) E(31);
+ if((*pf)[1] != 3) E(32);
+ (*pf)[-1] = 0; // KEEP low4 : error = will always fail
+ (*pf)[2] = 0; // KEEP high4 : error = Assertion failed
+ }
+
+ return 0;
+}
--- /dev/null
+
+#include "harness.h"
+
+#define EFAT BND(__this, __auto)
+#define FAT BND(__auto, __auto)
+
+TESTDEF baseline : success
+
+int a[] = { 0, 1, 2, 3};
+
+int * FAT g;
+
+struct fat {
+ int * FAT s;
+ int * EFAT f;
+ int * FAT as[4];
+} gstruct;
+
+// A function that returns a fat
+int * FAT ret_fat() {
+ return &a[2];
+}
+
+// A function that returns a split
+int * BND(__this, __this + 2) ret_split() {
+ return &a[2];
+}
+
+int main() {
+
+ int * p;
+
+ // Return from fat to split
+ p = ret_fat();
+
+ if(p[-2] != 0) E(1);
+ if(p[1] != 3) E(2);
+ p[-3] = 0; // KEEP low1 : error = lower bound
+ p[2] = 0; // KEEP high1 : error = Assertion failed
+
+ // Return from fat to fat
+ g = ret_fat();
+
+ if(g[-2] != 0) E(11);
+ if(g[1] != 3) E(12);
+ g[-3] = 0; // KEEP low2 : error = lower bound
+ g[2] = 0; // KEEP high2 : error = Assertion failed
+
+ // Return from split to fat
+ p = ret_split();
+
+ if(p[0] != 2) E(21);
+ if(p[1] != 3) E(22);
+ p[-1] = 0; // KEEP low3 : error = will always fail
+ p[2] = 0; // KEEP high3 : error = will always fail
+
+ // Return from split to fat
+ g = ret_split();
+
+ if(g[0] != 2) E(31);
+ if(g[1] != 3) E(32);
+ g[-1] = 0; // KEEP low4 : error = lower bound
+ g[2] = 0; // KEEP high4 : error = Assertion failed
+
+ return 0;
+}
--- /dev/null
+// KEEP baseline: success
+
+void foo(char * FAT * SAFE p) {
+}
+
+int main() {
+ char * FAT p;
+ char * COUNT(0) q;
+
+ foo(&p);
+ foo(&q); // KEEP e1: error = nice error message
+}
--- /dev/null
+
+
+#include "harness.h"
+
+#define EFAT BND(__this, __auto)
+
+char (NT str)[] = "test";
+
+char * EFAT NT gnt; // Try to conflate a NT with a non NT
+
+char array[] = { 0, 1, 2, 3 };
+
+char * EFAT g;
+
+int main() {
+
+ gnt = str;
+
+ g = array; // This will generate a cast from NT to ordinary pointer
+
+ return 0;
+}
--- /dev/null
+
+#include "harness.h"
+
+#define EFAT BND(__this, __auto)
+#define FAT BND(__auto, __auto)
+
+// Test initializers for auto
+int a[] = { 0, 1, 2, 3};
+
+int * EFAT gf = & a[2];
+
+struct fat {
+ int * FAT g;
+ int * FAT ga[2];
+} gstruct = { & a[2], & a[1], & a[2] };
+
+
+int main() {
+
+ if(gf[0] != 2) E(1);
+ if(gf[1] != 3) E(2);
+ gf[-1] = 0; // KEEP low1 : error = will always fail
+ gf[2] = 0; // KEEP high1 : error = Assertion failed
+
+
+ if(gstruct.g[-2] != 0) E(11);
+ if(gstruct.g[1] != 3) E(12);
+ gstruct.g[-3] = 0; // KEEP low2 : error = lower bound
+ gstruct.g[2] = 0; // KEEP high2 : error = Assertion failed
+
+
+ if(gstruct.ga[0][-1] != 0) E(21);
+ if(gstruct.ga[0][2] != 3) E(22);
+ gstruct.ga[0][-2] = 0; // KEEP low3 : error = lower bound
+ gstruct.ga[0][3] = 0; // KEEP high3 : error = Assertion failed
+
+
+ if(gstruct.ga[1][-2] != 0) E(31);
+ if(gstruct.ga[1][1] != 3) E(32);
+ gstruct.ga[1][-3] = 0; // KEEP low4 : error = lower bound
+ gstruct.ga[1][2] = 0; // KEEP high4 : error = Assertion failed
+
+
+ return 0;
+}
--- /dev/null
+// Misc tests for proper auto behavior.
+
+struct foo {
+ int f;
+};
+
+int main() {
+ int * SAFE p;
+ struct foo f;
+ // Make sure we don't add new variables inside sizeof.
+ int n = sizeof(*((int * FAT)p));
+ // Also make sure we handle auto bounds properly inside addrof.
+ int m = &((struct foo * SAFE) TC(&f))->f;
+ return 0;
+}
--- /dev/null
+static char * NT BND(__this, __auto) yy_c_buf_p = (char * NTS) 0;
+
+int main() {
+ return (int) yy_c_buf_p;
+}
--- /dev/null
+#include "harness.h"
+
+void foo (int n)
+{
+ int *FAT *COUNT(n) ar;
+ int i,j;
+
+ ar = malloc (n * sizeof(int * FAT));
+
+ for(i = 0; i < n; i++)
+ ar[i] = (int * FAT)malloc(n * sizeof(int));
+
+ for (i=0; i<n; i++) {
+ for (j=0; j<n; j++) {
+ ar[i][j] = 0;
+ }
+ }
+}
+
+int main (void)
+{
+ foo (5);
+ return 0;
+}
--- /dev/null
+
+//Test for bounds that are of a different type then the pointer.
+
+/* zf: this yields 'invalid operands to binary -' in checks */
+unsigned int f(void *_p)
+{
+ unsigned char * COUNT(10) orig_p = TC(_p);
+ unsigned char * SNT end_p = orig_p + 10;
+ unsigned int * BND(orig_p, end_p) p = (unsigned int * BND(orig_p, end_p))orig_p;
+ return p[1];
+}
+
+int main(void) {
+ unsigned int a[2] = {0,0};
+ return f(a);
+}
+
+
+// An example of this from sendmail:
+struct sm_file
+{
+ unsigned char *BND(__this,max) f_p; /* current position in (some) buffer */
+ char *max;
+};
+
+void sm_io_getc(struct sm_file *fp)
+{
+ fp->f_p++;
+}
--- /dev/null
+int main() {
+ void * SNT p = __builtin_return_address(0);
+ return 0;
+}
--- /dev/null
+void bar(int * COUNT(m) q, int m) {
+}
+
+void foo(int * COUNT(n) p, int n) {
+ bar(p, n);
+}
+int main() {
+ foo(0,10);
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+void bar(int * SAFE q) {
+}
+
+void foo(int * SAFE p) {
+ bar(p);
+}
+int main() {
+ int * SAFE p = alloc(int, 1);
+ foo(p);
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+void bar(int * SAFE q) {
+}
+
+void foo(int * COUNT(n) p, int n) {
+ bar(p + 1);
+}
+int main() {
+ int len = 42;
+ int * COUNT(len) p = alloc(int, len);
+ foo(p, len);
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+void bar(int * BND(b,e) q, int * BND(b,b) b, int * BND(e,e) e) {
+}
+
+void foo(int * COUNT(n) p, int n) {
+ bar(p + 5, p, p + n);
+}
+
+int main() {
+ int * COUNT(20) p = alloc(int, 20);
+ foo(p, 20);
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+int* COUNT(2) bar(int * COUNT(3) q) {
+ return q;
+}
+
+int main() {
+ int * COUNT(4) p = alloc(int, 5);
+ int* SAFE q = bar(p);
+ return *q;
+}
--- /dev/null
+// KEEP baseline: success
+
+int id(int n) {
+ return n;
+}
+
+struct foo {
+ int * COUNT(len) data;
+ int len;
+};
+
+void * (DALLOC(sz) allocate)(int sz) {
+ return 0;
+}
+
+int main() {
+ int a[5];
+ struct foo f;
+
+ f.data = 0;
+ f.len = id(5);
+ f.data = a;
+ f.len = id(3);
+ f.len = id(10); // KEEP err1: error = Assertion
+
+ f.data = 0; f.data = (int *)allocate(f.len * sizeof(int)); // KEEP err2 : success
+
+ return 0;
+}
--- /dev/null
+// Makes sure that & works properly with arguments that the return type
+// depends upon.
+
+int *BND(__this, rlen) foo(int *cmd, int *rlen) {
+ return 0;
+}
+
+int main() {
+ int rcmd;
+ int rlen;
+ int *SAFE response;
+ response = foo(&rcmd, &rlen); // KEEP t1: success
+ response = foo(0, &rlen); // KEEP t2: success
+ return 0;
+}
--- /dev/null
+int *COUNT(n) foo(int n) {
+ return 0;
+}
+
+int main() {
+ int i = 42;
+ foo(i); // KEEP t1: success
+ foo(&i); // KEEP e1: error
+ return 0;
+}
--- /dev/null
+struct foo {
+ int * SAFE f;
+};
+
+int main() {
+ int i = (int) &((struct foo * SAFE) 0)->f;
+ return 0;
+}
--- /dev/null
+// zf: this is from similar code in isofs/rock.c
+
+struct S {
+ char * COUNT(len1) s1;
+ char * COUNT(len2) s2;
+ unsigned char * COUNT(len3) s3;
+ int len1;
+ int len2;
+ int len3;
+};
+
+int main() {
+ struct S s;
+ // This works.
+ s.s1 = s.s2;
+ // This should also work but doesn't
+ s.s3 = s.s1;
+ return 0;
+}
--- /dev/null
+struct foo {
+ int a;
+ int b;
+};
+
+int main() {
+ struct foo st;
+ char * s1 = &st;
+ char * COUNT(8) s2 = s1;
+
+ return 0;
+}
--- /dev/null
+int foo(double d1, double d2) {
+ if(d1 == d2) return 1;
+ return 0;
+}
+
+int main() {
+ return foo(5.0, 4.0);
+}
+
--- /dev/null
+#include "harness.h"
+
+typedef int * intptr;
+
+void * (DALLOC(sz) allocate)(int sz) {
+ return malloc(sz);
+}
+
+int main() {
+ intptr p = (intptr) allocate(4 * sizeof(int));
+ return 0;
+}
--- /dev/null
+
+int main() {
+ int x = 3;
+
+ // Cast from int to double
+ double c = x * 3.14;
+
+ return 0;
+}
--- /dev/null
+
+// Physical subtyping
+
+struct host {
+ struct child {
+ struct nephew {
+ int data;
+ } n;
+ int * data1;
+ } c;
+ int * data2;
+} x;
+
+int main() {
+ struct child * c = (struct child*) &x;
+ struct newphew * n = (struct nephew*) &x;
+
+ if(c != n || c != &x) return 1;
+
+ return 0;
+}
--- /dev/null
+
+struct foo {
+ char * COUNT(len) buf;
+ int len;
+};
+
+TESTDEF default : success
+
+int main() {
+ struct foo f;
+ int n;
+ char * COUNT(n) p = 0;
+
+ // If we do not use n, then it gets eliminated !!!
+ n = 2; // KEEP : success
+
+ f.buf = p;
+
+ return 0;
+}
--- /dev/null
+void foo(void * COUNT(n) buf, int n) {
+}
+
+int main() {
+ int a;
+ foo(&a, sizeof(int));
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+typedef struct {
+ struct {
+ int * subp;
+ } stuff;
+} cell, * cellptr;
+
+
+int i = 345;
+cell c = { { &i } };
+
+
+int main() {
+IFTEST safe : success
+ {
+ cellptr q = &c;
+ int * SAFE p = TC(q->stuff.subp);
+
+ if(*p != 345) E(1);
+ }
+ENDIF
+
+IFTEST array : success
+ {
+ int array[10] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9};
+
+ // Are the bounds properly propagated ?
+ int * FAT p = TC(&array[5]);
+
+ if(*(p - 5) != 0) E(2);
+
+ if(*(p + 4) != 9) E(3);
+
+ }
+ENDIF
+ return 0;
+}
--- /dev/null
+// We need a nice error message when casting from pointer to struct
+// (accidentally or not).
+
+// KEEP t: error = illegal cast
+
+struct s {
+ int n;
+};
+
+int main() {
+ unsigned long tmp = (struct s) (void *) 0;
+
+ return 0;
+}
--- /dev/null
+int main() {
+ int a[2];
+ int * SAFE p = a;
+ int * q = (int * SAFE)((char * TRUSTED) p + 4);
+ int * SAFE r = q;
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+
+int foo(unsigned long px) {
+ * (int * SAFE)(void * TRUSTED)px += 1;
+}
+
+int main() {
+ int x = 2;
+
+ foo(& x);
+
+ if(x != 3) E(1);
+
+ return 0;
+}
+
--- /dev/null
+#include "harness.h"
+
+int main() {
+ int * COUNT(4) p = alloc(int, 4);
+ int * COUNT(2) q = p + 1;
+ int * SAFE r = (int * SAFE) (int * BND(q, q + 2)) (p + 2);
+ return 0;
+}
--- /dev/null
+// KEEP baseline: success
+
+#include "harness.h"
+
+int main() {
+ int * COUNT(10) pi;
+ int * COUNT(5) pj;
+ char * COUNT(20) pc;
+
+ pi = alloc(int, 10);
+ pc = (char * COUNT(20)) pi;
+ pj = (int * COUNT(5)) pc;
+ pi = (int * COUNT(5)) pc; // KEEP size1: error = Assertion
+ pi = (int * COUNT(10)) pc; // KEEP size2: error = Assertion
+
+ return 0;
+}
--- /dev/null
+// KEEP baseline: success
+
+int main() {
+ int * COUNT(10) p = (void*) 0;
+ return 0;
+}
--- /dev/null
+// This check ensures that bad casts from void* to some larger type are
+// caught at compile time instead of run time.
+
+// KEEP baseline: success
+
+int main() {
+ int i;
+
+ int * SAFE p1;
+ int * SAFE p2;
+
+ void * SAFE q1;
+ void * q2;
+
+ p1 = &i;
+ q1 = TC(p1);
+ q2 = q1;
+
+ p2 = TC(q1);
+ p2 = TC(q2);
+
+ p2 = q1; // KEEP size1: error = will always fail
+ p2 = q2; // KEEP size2: error = will always fail
+
+ return 0;
+}
--- /dev/null
+// This check ensures that bad casts from void* to some larger type are
+// caught at compile time instead of run time.
+
+// KEEP baseline: success
+
+int main() {
+ int i;
+ int * SAFE p1;
+ int * SAFE p2;
+ void * SAFE q;
+
+ p1 = &i;
+ q = TC(p1);
+ p2 = q; // KEEP size1: error = will always fail
+
+ return 0;
+}
--- /dev/null
+// This test makes sure that we can cast between pointers to signed and
+// unsigned data.
+
+int main() {
+ char * SAFE pc;
+ unsigned char * SAFE qc;
+
+ int * SAFE pi;
+ unsigned int * SAFE qi;
+
+ pc = 0;
+ qc = pc;
+
+ pi = 0;
+ qi = pi;
+
+ return 0;
+}
--- /dev/null
+struct foo {
+ int * SAFE p; // KEEP baseline: success
+ int * SAFE p; // KEEP cast1: error = Type mismatch
+ int a;
+ int b;
+};
+
+struct foo f;
+
+void * SAFE get() {
+ f.a = 5;
+ return TC(&f);
+}
+
+int main() {
+ struct foo * SAFE p = TC(get()); // KEEP baseline
+ struct foo *p = get(); // KEEP cast1
+ struct foo *p = get(); // KEEP cast2: error = Assertion
+ struct foo * SAFE p = get(); // KEEP cast3: error = Assertion
+ return p->a != 5;
+}
--- /dev/null
+#include "harness.h"
+
+int main() {
+ int * SAFE p = alloc(int, 1);
+ int i;
+ i = *p;
+
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+int main() {
+ int * COUNT(10) p;
+ int * SAFE * SAFE q;
+ p = alloc(int, 10);
+ q = alloc(int * SAFE, 1);
+ *q = p;
+ return 0;
+}
--- /dev/null
+// Here's a random attempt to circumvent Deputy's type system. It is
+// prevented by the substitution Deputy uses during an assignment.
+
+// KEEP baseline: error = Assertion failed in upper bound check
+
+int main() {
+ int * BND(b, e) b;
+ int * SNT e;
+
+ int j;
+ char * SAFE p = &j;
+ int i;
+
+ e = &i;
+ b = &j; // This assignment should fail.
+ b[1] = 0xdeadbeef;
+
+ *p = 0;
+
+ return 0;
+}
--- /dev/null
+enum foo {
+ FOO = 1
+};
+
+int main() {
+ int a[2];
+ enum foo e = FOO;
+ a[1] = 0;
+ return a[e];
+}
--- /dev/null
+extern char extern1buf[]; // KEEP t1: error = extern1buf needs a length
+extern char (NT extern1buf)[]; // KEEP t2: error = extern1buf needs a length
+extern char (NTS extern1buf)[]; // KEEP t3: success
+extern char (NT COUNT(3) extern1buf)[]; // KEEP t4: success
+
+int main() {
+ extern char (NTS extern1buf)[]; // KEEP t5: success
+ if (extern1buf[3] != 0) return -1;
+ extern1buf[2] = 'z';
+ extern1buf[3] = 0;
+ return 0;
+}
--- /dev/null
+TESTDEF baseline: success
+
+//Test that CIL does not delete extern globals that are only used in
+//annotations.
+
+extern char * COUNT(extern_count) extern_p;
+extern int extern_count;
+
+int main() {
+ extern_p++; //KEEP incr: error = will always fail
+ extern_p[2] = 0;
+ return extern_p[3];
+}
--- /dev/null
+extern char (COUNT(4) extern1buf)[];
+
+int main() {
+ return (extern1buf[1] == 'a');
+}
--- /dev/null
+TESTDEF noext : success
+
+// We want this annotation to be merged with the extern inline
+extern int myfoo(char * NTS str);
+
+IFTEST ext : success
+extern inline
+ENDIF
+char myfoo(char * str) {
+ return str[0];
+}
+
+int main() {
+ return ('A' != myfoo("A string")) ? 1 : 0;
+}
--- /dev/null
+#include "harness.h"
+
+struct bar {
+ int * SAFE p;
+};
+
+void foo(struct bar * SAFE b) {
+ int i;
+ i = *b->p;
+}
+
+int main() {
+ struct bar * SAFE b = alloc(struct bar, 1);
+ b->p = alloc(int, 1);
+ foo(b);
+ return 0;
+}
--- /dev/null
+// KEEP baseline: success
+
+#include "harness.h"
+
+struct bar {
+ int * SAFE p;
+};
+
+void foo(struct bar * SAFE b) {
+ b->p = b->p + 1; // KEEP size1: error = will always fail
+}
+
+int main() {
+ struct bar * SAFE b = alloc(struct bar, 1);
+ b->p = alloc(int, 1);
+ foo(b);
+ return 0;
+}
--- /dev/null
+// KEEP baseline: success
+
+#include "harness.h"
+
+struct bar {
+ int * COUNT(2) p;
+};
+
+void foo(struct bar * SAFE b) {
+ b->p = b->p + 1; // KEEP size1: error = will always fail
+}
+
+int main() {
+ struct bar * SAFE b = alloc(struct bar, 1);
+ b->p = alloc(int, 2);
+ foo(b);
+ return 0;
+}
--- /dev/null
+//KEEP baseline: success
+
+//
+//Excercise nested struct offsets.
+//
+
+#include "harness.h"
+
+struct bar {
+ int n;
+ int * COUNT(n) p;
+};
+
+struct foo1 {
+ int len;
+ struct bar* COUNT(len) bars;
+};
+
+struct foo2 {
+ int data;
+ struct foo1 foo1;
+};
+
+struct foo2 * COUNT(5) foo2_init() {
+ struct foo2 * COUNT(5) f = alloc(struct foo2, 5);
+ struct bar* COUNT(len) bars;
+ for (int i = 0; i < 5; i++) {
+ f[i].data =42;
+ bars = 0;
+ int len = i+1;
+ bars = alloc(struct bar, len);
+ for (int j = 0; j < len; j++){
+ int len2 = 10;
+ bars[j].n = len2;
+ bars[j].p = alloc(int, len2);
+ }
+ f[i].foo1.len = len;
+ f[i].foo1.bars = bars;
+ }
+ return f;
+}
+
+
+int main() {
+ struct foo2 * COUNT(5) f = foo2_init();
+ int i = 4; //index into f
+ int j = i; //index into bars
+ int k = 9; //index into p
+ i++; //KEEP i: error
+ i= -1; //KEEP ineg: error
+ j++; //KEEP j: error
+ k++; //KEEP k: error
+
+ //Make sure each offset is checked correctly:
+ int x = f[i].foo1.bars[j].p[k];
+ return 0;
+}
--- /dev/null
+// Test automatic bounds for fields.
+// KEEP baseline: success
+
+struct foo {
+ int * BND(__auto, __auto) p;
+};
+
+int main() {
+ struct foo f;
+ int a[10];
+
+ f.p = a;
+
+ f.p[0] = 42;
+ f.p[9] = 42;
+
+ return 0;
+}
--- /dev/null
+
+int foo(int * COUNT(n), int n);
+
+// Now change the name of the variables. We must handle this gracefully.
+int foo(int * COUNT(m) p, int m) {
+ p[2] = 1;
+}
+
+
+int main() {
+ int buff[8];
+ foo(buff, 8);
+ return 0;
+}
--- /dev/null
+
+#include "harness.h"
+
+// Test dependencies of return on the function arguments
+TESTDEF baseline : success
+
+int * COUNT(n) gettable(int n, int * SAFE pn) {
+ int * res;
+
+ (*pn)--;
+
+ // Make sure that we use the original value of n for the return
+ n --; // KEEP : error = upper bound coercion
+
+ res = (int *)malloc(n * sizeof(int));
+
+ res ++; // KEEP : error = upper bound coercion
+
+ return res;
+}
+
+
+int main() {
+ int n;
+ int * SAFE pn = &n;
+
+ int *
+ COUNT(8) // KEEP : success
+ p;
+
+ p = gettable(8, pn);
+
+ // Try to access the memory
+ p[0] = 0;
+ p[7] = 7;
+
+ // Access past the array
+ p[8] = 8; // KEEP : error = will always fail
+
+ // Now make sure that we use the value of the argument when the function
+ // is called (not when it returns) in the bounds.
+ *pn = 8;
+ p = gettable(*pn, pn);
+
+ p[0] = 0;
+ p[7] = 7;
+
+ p[8] = 8; // KEEP : error = pointer access check
+
+ return 0;
+}
--- /dev/null
+
+#include "harness.h"
+
+
+int carray; // Count of elements
+int * COUNT(8) array;
+
+TESTDEF baseline : success
+
+int side(int incr) {
+ carray += incr;
+ return carray;
+}
+
+// Allow a function to refer to global variables
+void access_array(int * BND(__this - off, __this - off + carray) parray,
+ int off, int extra) {
+ if(parray[-off] != 0) E(1);
+
+ // Try to decrease the global carray.
+ side(-5); // KEEP side1 : success
+
+ // We should be allowed to access 8 elements
+ if(parray[7-off] != 8) E(2);
+
+ // Try to increase carray
+ side(2);if(parray[-off+carray] != carray) E(2); // KEEP side2 : error = Blah
+
+
+}
+
+int main() {
+ int i;
+
+ carray = 8;
+ array = (int*)malloc(carray * sizeof(*array));
+ for(i=0;i<carray;i++) {
+ array[i] = i;
+ }
+
+ access_array(array + 3, 3, 0);
+
+ // This should be Ok too
+ carray --; access_array(array + 4, 3, 0); // KEEP : success
+
+ // Make sure we do not make the check too early
+ access_array(array + 4, 3, side(10));
+
+ SUCCESS;
+}
--- /dev/null
+
+TESTDEF baseline : success
+
+TESTDEF noproto : error = no prototype
+
+#include "harness.h" // DROP noproto
+
+int (*fptr)();
+
+// Calling functions without prototype not allowed
+// At least in the situations when pointers are involved
+int main() {
+ char * a;
+
+ a = malloc(1);
+
+ return 0;
+}
--- /dev/null
+// Test automatic bounds for fields.
+// KEEP baseline: success
+
+void foo(int * BND(__auto, __auto) p) {
+ int a[20];
+
+ p[0] = 0;
+ p[9] = 42;
+
+ p[19] = 42; // KEEP e1: error = Assertion failed
+
+ p = a;
+
+ p[19] = 42;
+}
+
+void baz(int a, int * BND(__auto, __auto) p, int b) {
+ p[0] = a;
+ p[9] = b;
+}
+
+void bar(int * BND(__auto, __auto) p);
+
+int main() {
+ struct foo f;
+ int a[10];
+
+ foo(a);
+ bar(a);
+ baz(0, a, 42);
+
+ return 0;
+}
+
+void bar(int * BND(__auto, __auto) p) {
+ p[0] = 0;
+ p[9] = 42;
+}
--- /dev/null
+// This test ensures that we check the number of arguments to a function.
+
+// KEEP baseline: success
+
+int foo(int a) {
+ return a;
+}
+
+int main() {
+ return foo(0);
+ return foo(0, 1); // KEEP e1: error = Function call has too many arguments
+}
--- /dev/null
+
+#include "harness.h"
+
+// Test function pointers.
+
+TESTDEF baseline : success
+
+int * COUNT(n) dup(int n, int * COUNT(n) NONNULL old) {
+ int* res = (int *)malloc(n * sizeof(int));
+ for (int i = 0; i < n; i++) {
+ res[i] = old[i];
+ }
+ return res;
+}
+
+//Three functions with slightly different signatures than dup:
+int * SAFE foo(int n, int * COUNT(n) NONNULL old) {
+ return 0;
+}
+int * COUNT(n) bar(int n, int * COUNT(n) old) {
+ return 0;
+}
+int * COUNT(n) qux(int n, int * COUNT(n) NONNULL old, int extraarg) {
+ return 0;
+}
+
+
+int * COUNT(n) (*funcPtr_1)(int n, int * COUNT(n) NONNULL old) = 0;
+
+typedef int * COUNT(n) (funcType)(int n, int * COUNT(n) NONNULL old);
+
+// We should be able to apply the NONNULL attribute to functions
+funcType* NONNULL funcPtr_2
+ = &dup //DROP missinginit: error = non-null check will always fail
+ ;
+
+int main() {
+ int n = 4;
+ int old[] = {0, 1, 2, 3};
+ funcPtr_1 = &dup; //DROP null-function-ptr: error = non-null check
+
+ int* p = (*funcPtr_1)(n, old);
+ if (p[3] != 3) E(3);
+ p[4] = 2; //KEEP ubound: error = will always fail
+
+ funcPtr_2 = dup;
+ funcPtr_2 = foo; // KEEP wrongType1: error = Type mismatch
+ funcPtr_2 = bar; // KEEP wrongType2: error = Type mismatch
+ funcPtr_2 = qux; // KEEP wrongType3: error = Type mismatch
+
+ p = (*funcPtr_2)(n, old);
+
+ return 0;
+}
--- /dev/null
+// Make sure formals can't depend on locals!
+
+// KEEP baseline: error = dest depends on names that are not in scope
+
+#include "harness.h"
+
+int strlcat(char * NT CT(len) dest, const char * NTS src, int count) {
+ int len = count;
+ return len;
+}
+
+int main() {
+ return 0;
+}
--- /dev/null
+struct foo {
+ void (*fn)(int * CT(len) buf, int len);
+};
+
+void my_fn(int * CT(ct) buf, int ct) {
+ buf[0] = 42;
+}
+
+struct foo f = { &my_fn };
+
+int main() {
+ int a[10];
+ f.fn(a, 10);
+ return (a[0] == 42) ? 0 : 1;
+}
--- /dev/null
+//This test should work before any changes.
+//KEEP baseline: success
+
+int * SAFE p;
+int * BND(q,p) q; //KEEP dep: success
+
+int main() {
+ q = 0; //KEEP dep
+ p = 0;
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+static int * BND(p,q) p;
+static int * BND(q,q) q;
+
+int main() {
+ int * COUNT(10) tmp;
+ p = 0;
+ q = 0;
+ tmp = alloc(int, 10);
+ q = tmp + 10;
+ p = tmp;
+ return 0;
+}
--- /dev/null
+
+TESTDEF baseline : success
+
+TESTDEF extern : error ~ (undefined reference)|(Undefined symbols)
+extern // KEEP extern
+int * COUNT(count) array;
+extern // KEEP extern
+int count;
+
+int thearray[5];
+
+int main() {
+ count = 5;
+ array = thearray;
+
+ return array[0];
+}
--- /dev/null
+
+
+int array[128];
+
+int main() {
+ // I get that uninformative "ill-formed type". This should be allowed
+ // and in fact this is not even a dependent type, or dependent only on
+ // link time constant
+ int * BND(array, array + 8) ptr = &array[6]; // KEEP 1 : success
+
+ // Maybe we ought to extend the syntax for attributes ?
+ int * BND(&array[0], &array[8]) ptr = &array[6]; // KEEP 2 : success
+
+
+ *ptr = 0;
+
+ return array[6];
+
+}
--- /dev/null
+static char array[16];
+
+static char * SNT end;
+static char * BND(__this, end) ptr;
+
+int main() {
+ end = array + 16;
+ ptr = array;
+
+ ptr += 10;
+
+ *ptr = 5;
+
+ return 0;
+}
--- /dev/null
+// Test automatic bounds for globals.
+// KEEP baseline: success
+
+int * BND(__auto, __auto) g;
+extern int * BND(__auto, __auto) g; // KEEP t1: success
+
+int main() {
+ int a[10];
+
+ g = a;
+
+ g[0] = 42;
+ g[9] = 42;
+
+ return 0;
+}
--- /dev/null
+// Allow values to depend on constant globals.
+//KEEP baseline: success
+
+int array[50];
+
+//Deputy needs to know not to delete ASSUMECONST globals even if they are
+// unused.
+static int * ASSUMECONST SNT sentinel1 = array;
+static int * ASSUMECONST SNT sentinel2 = &array[50];
+
+
+struct mystruct {
+ int * BND(sentinel1, sentinel2) f;
+} globalstruct;
+
+int * BND(sentinel1, sentinel2) foo(int * BND(sentinel1, sentinel2) arg) {
+ if (arg)
+ return arg+1;
+ else
+ return &array[0];
+}
+
+int main() {
+ array[45] = 'a';
+ globalstruct.f = &array[42];
+
+ sentinel2 = &array[50]; // KEEP warn : success = Warning: Assigning to an ASSUMECONST value
+
+ int * p = foo(globalstruct.f);
+ int * p2 = (int * BND(sentinel1, sentinel2))p;
+ int * BND(sentinel1, sentinel2) p3 = p2 + 2;
+
+
+ p3[5] = 'b'; //KEEP local: error = Assertion failed
+ *(globalstruct.f - 43) = 'c'; //KEEP field: error = Assertion failed
+
+ //p3 should equal &array[45]
+ return *p3 != 'a';
+}
--- /dev/null
+char (NT buf1)[16384];
+char (NT buf2)[sizeof (buf1)];
+int main() {
+ buf2[0] = 0;
+ return 0;
+}
--- /dev/null
+// KEEP baseline: success
+
+int i;
+IFTEST e1: error = Casts in global initializers may not have auto bounds
+int * SAFE p = (int * FAT) &i;
+ELSE
+int * SAFE p = &i;
+ENDIF
+
+int * SAFE q = TC(-1);
+
+int main() {
+ return (p != q) ? 0 : 1;
+}
--- /dev/null
+// This file contains all of the declarations and macros required for the
+// small Deputy tests.
+
+#ifndef HARNESS_H
+#define HARNESS_H
+
+extern void* (DALLOC(size) malloc)(unsigned int size);
+extern void (DFREE(p) free)(void *p);
+extern void* (DMEMSET(1, 2, 3) memset)(void *p, int c, unsigned int n);
+extern unsigned int strlen(const char * NTS str);
+extern int printf(const char * NTS format, ...);
+extern void exit(int code);
+
+#define alloc(t, n) malloc(sizeof(t) * (n))
+
+/* Always call E with a non-zero number */
+#define E(n) { printf("Error %d\n", n); exit(n); }
+#define SUCCESS { printf("Success\n"); exit(0); }
+
+#endif // HARNESS_H
--- /dev/null
+#include "harness.h"
+
+void add(float * SNT end,
+ float * BND(__this, end) NONNULL result_block,
+ float what) {
+
+ // This will create a NONNULL local initialized to 0 !!!
+ result_block += 2;
+
+ *result_block = what;
+
+}
+
+int main() {
+ float a[4];
+
+ add(&a[4], &a[1], 5.0);
+
+ if(a[3] != 5.0) E(1);
+
+ return 0;
+
+}
--- /dev/null
+void foo(int * COUNT(10) p) {
+ int * q = p;
+ int i;
+ for (i = 0; i < 10; i++) {
+ q[i] = 0;
+ }
+}
+
+int main() {
+ int a[10];
+ foo(a);
+
+ return 0;
+}
--- /dev/null
+// This test makes sure that we can properly infer types when the
+// right-hand side is a global.
+
+#include "harness.h"
+
+static int len = 10;
+static int * COUNT(len) buf;
+
+int main() {
+ int *p;
+ int len_local = len;
+ buf = alloc(int, 10);
+ p = buf + 1;
+ return 0;
+}
--- /dev/null
+// This test checks whether we can handle null pointers in inference.
+
+int main() {
+ int *p = (void*) 0;
+ return 0;
+}
--- /dev/null
+int main() {
+ const char * NTS s = "blah";
+ const char * t = NTEXPAND(s);
+ const char * NT u = s;
+ char c = t[1];
+ char d = u[1];
+ return 0;
+}
--- /dev/null
+// This test verifies that function call returns are instrumented properly
+// even when the return value is a structure.
+
+struct foo {
+ int a;
+};
+
+struct foo bar() {
+ struct foo f;
+ return f;
+}
+
+int main() {
+ struct foo f = bar();
+ return 0;
+}
--- /dev/null
+int main() {
+ int i;
+ int * BND(p, __auto) p;
+ int * BND(p, p+1) q;
+
+ p = &i;
+
+ q = p;
+
+ // The test fails here because we insert the following code when
+ // assigning the automatic bounds variable:
+ // p = 0;
+ // p_e = p+1;
+ // p = q;
+ //matth: but it works now that we don't do p = 0
+ p = q;
+
+ return 0;
+}
--- /dev/null
+struct foo
+{
+ int * BND(__this, end) buf;
+ int * SNT end;
+};
+
+int main() {
+ int a[5];
+ struct foo f;
+ int *p = a;
+
+ f.end = a + 5;
+ f.buf = a;
+
+ int n = f.buf - p; // KEEP t1: success
+ int n = *(f.buf++); // KEEP t2: success
+
+ return 0;
+}
--- /dev/null
+// KEEP baseline: success
+
+void foo(char * COUNT(len) buf, int len) {
+}
+
+int main() {
+ int a[4];
+ {
+ TRUSTEDBLOCK // KEEP t1: success
+ foo((char *) a, sizeof(a));
+ }
+ return 0;
+}
--- /dev/null
+int foo() {
+ return 42;
+}
+
+int main() {
+ int i = 0;
+ int *p = &i;
+ *p = foo();
+ return (i == 42) ? 0 : 1;
+}
--- /dev/null
+// Make sure we don't inadvertently change the type of a MinuSPP.
+TESTDEF e1: error = Type mismatch
+
+int main () {
+ char *SAFE p;
+ char buf[1];
+ char *SAFE q = (char *FAT) (&buf[0] - (char *FAT) p);
+ return 0;
+}
--- /dev/null
+// This test catches a bug in inference dealing with open arrays.
+
+struct fib_nh {
+ int a;
+};
+
+struct fib_info {
+ int fib_nhs;
+ struct fib_nh (COUNT(fib_nhs) fib_nh)[0];
+};
+
+void fib_info_hashfn(const struct fib_info *fi) {
+}
+
+int main(int argc, char **argv) {
+ struct fib_info *fi = 0;
+ fib_info_hashfn(fi);
+ return 0;
+}
--- /dev/null
+void foo(int * SAFE p) {
+ int * q = p;
+ int * r = q;
+ *r = 0;
+}
+
+int main() {
+ int i;
+ foo(&i);
+
+ return 0;
+}
--- /dev/null
+int main() {
+ int * p = 0;
+
+ return 0;
+}
--- /dev/null
+typedef struct bar bar;
+struct bar {
+ int * SAFE p;
+ int * COUNT(len) q;
+ int len;
+};
+
+void foo(bar * SAFE b) {
+ int * px = b->p;
+ int * qx = b->q;
+ int i;
+ for (i = 0; i < b->len; i++) {
+ *qx++ = *px;
+ }
+}
+
+int main() {
+ int i;
+ int a[10];
+
+ bar b;
+ b.len = 10;
+ b.q = a;
+ b.p = &i;
+
+ foo(&b);
+
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+int * SAFE foo(int * SAFE p) {
+ return p;
+}
+
+int main() {
+ int * SAFE p = alloc(int, 1);
+ int * q = foo(p);
+ *q = 0;
+ return 0;
+}
--- /dev/null
+// This is a test where we set the upper bound of q to be p+1, even though
+// p = 0. This requires special handling of sentinels.
+
+int main() {
+ int * SAFE p;
+ int * q;
+
+ p = 0;
+ q = p;
+
+ return 0;
+}
--- /dev/null
+// This test checks for a bug where the second assignment to a variable
+// with inferred bounds is checked against the previous bounds, and thus
+// fails the check.
+
+int main() {
+ int i1;
+ int i2;
+
+ int * SAFE p1;
+ int * SAFE p2;
+ int * q;
+
+ p1 = &i1;
+ p2 = &i2;
+
+ q = p1;
+ q = p2;
+
+ return 0;
+}
--- /dev/null
+struct foo {
+ int a;
+ int b;
+};
+
+int main() {
+ struct foo f;
+ int * SAFE p;
+ struct foo * q;
+ struct foo * SAFE r;
+
+ p = &f.b;
+ q = (struct foo * SAFE)((char * TRUSTED) p - (int) &(((struct foo *)0))->b);
+ r = q;
+
+ return 0;
+}
--- /dev/null
+// This test ensures that metadata is properly set by allocators.
+
+#include "harness.h"
+
+int main() {
+ int * p;
+ int * SAFE q;
+
+ p = alloc(int, 10);
+ q = p;
+
+ return 0;
+}
--- /dev/null
+
+#include "harness.h"
+
+// Test global initializers
+TESTDEF baseline : success
+
+
+int x, a[8];
+
+int * NONNULL gnonnull = &x;
+
+int * EFAT px = & x;
+
+int * FAT px1 = 0;
+
+int * NONNULL g1; // KEEP nonnull : error = non-null
+
+int * COUNT(3) g2 = & a[4];
+int * COUNT(4) g3 = & a[5]; // KEEP ubound1 : error = will always fail
+int * SAFE g4 = & a[-1]; // KEEP lbound1 : error = will always fail
+
+int * NT g5 = & a[3]; // KEEP nt : error = from ordinary pointer to nullterm
+
+// Try an array of non-null pointers without enough initializers
+int * NONNULL arr1[4] = { &x, &x }; // KEEP nonnull2: error = non-null
+
+struct opt {
+ char (NT shname)[8];
+ int * NTS lgname;
+ char pad[4];
+} options[2] = {
+ { { 0, 1, 2, 3, 4, 5, 6, 7} } // KEEP nt2 : error = CWriteNT
+ { { }, &x } // KEEP nt3 : error = from ordinary pointer to nullterm
+};
+
+
+int main() {
+ return 0;
+}
--- /dev/null
+
+#include "harness.h"
+
+// Test global initializers. Make sure the checks are discharged statically.
+TESTDEF baseline : success
+
+char *NTS (NT CompileOptions)[] =
+{
+ "ALLOW_255",
+ "DNSMAP",
+ "EGD",
+ 0
+};
+
+int main() {
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+void exit(int code) __attribute__((noreturn));
+
+int global;
+
+TESTDEF baseline: success
+
+int foo(int * SAFE x) {
+ int *y;
+
+ if (*x) {
+ return 0; //DROP ret: error = y may be used without being
+ } else {
+ y=x;
+ }
+ x = y;
+ return *y;
+}
+
+int bar() {
+ int *x;
+ int z;
+ switch(global) {
+ case 0:
+ case 1:
+ x = & global;
+ break;
+ case 2:
+ x = malloc(*x);//KEEP arg: error = x may be used without being
+ //FALLTHROUGH
+ case 3:
+ z = *x; //KEEP deref: error = x may be used without being
+ //FALLTHROUGH
+ case 4:
+ //Sizeof is okay:
+ x = malloc(sizeof(*x));
+ break;
+
+ default: exit(0); //DROP default: error = x may be used without being
+ }
+ return foo(x);
+}
+
+int main() {
+ return bar();
+}
--- /dev/null
+#include "harness.h"
+
+int a[] = {0,1,2,3,4};
+
+//Dependencies are tricky. If A depends on B, then an assignment to A
+//is a use of B.
+
+
+int foo() {
+ //test that defining q is a use of n.
+ int * COUNT(n) q = 0; //KEEP N: success = Warning: Variable n may be used without being defined
+
+ //This is the same test as above, but use memset to set q = 0
+ int * COUNT(n) q; //KEEP memset: success = Warning: Variable n may be used without being defined
+ memset(&q,0,sizeof(int*)); //KEEP memset
+
+ //Finally, the declaration of n.
+ int n = 5;
+ return 0;
+}
+
+int main() {
+ int * BND(p, p+n) q;
+ q = 0; //KEEP q: error = p may be used without being defined
+ int n = 5;
+ int * COUNT(n) p = a;
+ q = p+2;
+
+ return *q-2;
+}
--- /dev/null
+int main()
+{
+ char * SNT p__b;
+ char * SNT p__e;
+ char * BND(p__b, p__e) p;
+
+ p__b = 0;
+ p__e = 0;
+ p = 0;
+
+ p__b = 0;
+ p__e = 0;
+ p = p;
+
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+//On the second time around the loop, we get an assertion failure
+// when assigning size=11, because ptr depends on size. It's unintuitive
+// to have a failure on ptr before it's declared!
+// I'd like to have at least better error message for this, but I don't know
+// how to do that.
+
+// This was fixed by only considering the context to be only live
+// locals, not all locals.
+
+//KEEP baseline: success
+
+int main() {
+ for (int i = 10; i < 15; i++) {
+ int size = i;
+ int * COUNT(size) ptr = malloc(size*sizeof(int));
+ ptr[size-1] = i;
+
+ //This workaround ought to fix the problem, but it doesn't because
+ // CIL introduces a temp var for ptr. We'd need to set that var
+ // to zero too, but we can't because it can't be named.
+ ptr = 0; //KEEP workaround: success
+ }
+ return 0;
+}
--- /dev/null
+// This test checks out our special fancy memcmp support.
+// KEEP baseline: success
+
+#include "harness.h"
+
+struct foo {
+ int a;
+ int b;
+};
+
+struct bar {
+ int a;
+ int *b;
+};
+
+int (DMEMCMP(1, 2, 3) my_memcmp)(void *dst, void *src, int sz) {
+ return 0;
+}
+
+int main() {
+ char * COUNT(10) pc1 = alloc(char, 10);
+ char * COUNT(10) pc2 = alloc(char, 10);
+
+ int * COUNT(10) pi1 = alloc(int, 10);
+ int * COUNT(10) pi2 = alloc(int, 10);
+
+ struct foo * COUNT(10) pf1 = alloc(struct foo, 10);
+ struct foo * COUNT(10) pf2 = alloc(struct foo, 10);
+
+ struct bar * COUNT(10) pb1 = alloc(struct bar, 10);
+ struct bar * COUNT(10) pb2 = alloc(struct bar, 10);
+
+
+ my_memcmp(pc1, pc2, 10);
+ my_memcmp(pc1, pc2, 4);
+ my_memcmp(pc1, pc2, 12); // KEEP len1: error = will always fail
+
+ my_memcmp(pi1, pi2, 10 * sizeof(int));
+ my_memcmp(pi1, pi2, 4 * sizeof(int));
+ my_memcmp(pi1, pi2, 12 * sizeof(int)); // KEEP len2: error = will always fail
+
+ my_memcmp(pi1, pc1, 10);
+ my_memcmp(pc1, pi1, 10);
+
+ my_memcmp(pi1, pc1, 10 * sizeof(int)); // KEEP len3: error = will always fail
+ my_memcmp(pc1, pi1, 10 * sizeof(int)); // KEEP len4: error = will always fail
+
+ my_memcmp(pf1, pf2, 10 * sizeof(struct foo));
+ my_memcmp(pf1, pf2, 4);
+ my_memcmp(pf1, pf2, 12 * sizeof(struct foo)); // KEEP len5: error = will always fail
+
+ my_memcmp(pb1, pb2, 10 * sizeof(struct bar));
+ my_memcmp(pb1, pb2, 4);
+ my_memcmp(pb1, pb2, 12 * sizeof(struct bar)); // KEEP len5: error = will always fail
+
+ my_memcmp(pf1, pb1, 10 * sizeof(struct bar));
+ my_memcmp(pb1, pf1, 10 * sizeof(struct bar));
+
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+int (DMEMCMP(1, 2, 3) memcmp)(void* s1, void* s2, int sz);
+
+//Call memcmp on NTS pointers, to make sure that we correctly expand the NT.
+int three = 3;
+int chars(char* NTS s, int what){
+ char *wibble = NTDROP(NTEXPAND("wibble"));
+ char *s2 = NTDROP(NTEXPAND(s));
+ // Sadly, this doesn't work because we don't allow access to the final 0:
+ //memcmp(s,s,4);
+ if(what == 0)
+ return memcmp(s2,s2,three);
+ else
+ return memcmp(s2,wibble,3);
+}
+
+int six = 3*sizeof(int);
+int ints(int* NTS s, int what){
+ int *barbara = NTDROP(NTEXPAND(L"barbara"));
+ int *s2 = NTDROP(NTEXPAND(s));
+ if(what == 0)
+ return memcmp(s2,s2,six);
+ else
+ return memcmp(s2,barbara,3*sizeof(int));
+}
+
+int main() {
+ char* foo = "foo";
+ int (NT bar)[4] = {'b', 'a', 'r', 0};
+ if (chars(foo, 0) != 0) E(1);
+ if (chars(foo, 1) >= 0) E(2);
+ if (ints(bar, 0) != 0) E(3);
+ if (ints(bar, 1) != 0) E(4);
+ SUCCESS
+}
--- /dev/null
+// This test checks out our special fancy memcpy support.
+// KEEP baseline: success
+
+#include "harness.h"
+
+struct foo {
+ int a;
+ int b;
+};
+
+struct bar {
+ int a;
+ int *b;
+};
+
+void * (DMEMCPY(1, 2, 3) my_memcpy)(void *dst, void *src, int sz) {
+ return dst;
+}
+
+int main() {
+ char * COUNT(10) pc1 = alloc(char, 10);
+ char * COUNT(10) pc2 = alloc(char, 10);
+
+ int * COUNT(10) pi1 = alloc(int, 10);
+ int * COUNT(10) pi2 = alloc(int, 10);
+
+ struct foo * COUNT(10) pf1 = alloc(struct foo, 10);
+ struct foo * COUNT(10) pf2 = alloc(struct foo, 10);
+
+ struct bar * COUNT(10) pb1 = alloc(struct bar, 10);
+ struct bar * COUNT(10) pb2 = alloc(struct bar, 10);
+
+
+ my_memcpy(pc1, pc2, 10);
+ my_memcpy(pc1, pc2, 4);
+ my_memcpy(pc1, pc2, 12); // KEEP len1: error = will always fail
+
+ my_memcpy(pi1, pi2, 10 * sizeof(int));
+ my_memcpy(pi1, pi2, 4 * sizeof(int));
+ my_memcpy(pi1, pi2, 12 * sizeof(int)); // KEEP len2: error = will always fail
+
+ my_memcpy(pi1, pc1, 10);
+ my_memcpy(pc1, pi1, 10);
+
+ my_memcpy(pi1, pc1, 10 * sizeof(int)); // KEEP len3: error = will always fail
+ my_memcpy(pc1, pi1, 10 * sizeof(int)); // KEEP len4: error = will always fail
+
+ my_memcpy(pf1, pf2, 10 * sizeof(struct foo));
+ my_memcpy(pf1, pf2, 4);
+ my_memcpy(pf1, pf2, 12 * sizeof(struct foo)); // KEEP len5: error = will always fail
+
+ my_memcpy(pb1, pb2, 10 * sizeof(struct bar));
+ my_memcpy(pb1, pb2, 4); // KEEP partial1: error = Assertion
+ my_memcpy(pb1, pb2, 12 * sizeof(struct bar)); // KEEP len5: error = will always fail
+
+ my_memcpy(pf1, pb1, 10 * sizeof(struct bar));
+ my_memcpy(pb1, pf1, 10 * sizeof(struct bar)); // KEEP type1: error = different base types
+
+ return 0;
+}
--- /dev/null
+// Test inference with casts and memcpy.
+
+struct foo {
+ char a, b, c, d;
+};
+
+void * (DMEMCPY(1, 2, 3) my_memcpy)(void *dst, void *src, int sz) {
+ return dst;
+}
+
+int main() {
+ struct foo foo;
+ char p[4];
+ // The following cast should *not* be inferred safe!
+ my_memcpy((char*)&foo, p, sizeof(foo));
+ return 0;
+}
--- /dev/null
+// This test checks out our special fancy memset support.
+// KEEP baseline: success
+
+#include "harness.h"
+
+struct foo {
+ int a;
+ int b;
+};
+
+struct bar {
+ int a;
+ int *b;
+};
+
+void * (DMEMSET(1, 2, 3) my_memset)(void *dst, int value, int sz) {
+ return dst;
+}
+
+int main() {
+ char * COUNT(10) pc = alloc(char, 10);
+ int * COUNT(10) pi = alloc(int, 10);
+ struct foo * COUNT(10) pf = alloc(struct foo, 10);
+ struct bar * COUNT(10) pb = alloc(struct bar, 10);
+
+ my_memset(pc, 0, 10);
+ my_memset(pc, 42, 10);
+ my_memset(pc, 0, 4);
+ my_memset(pc, 0, 12); // KEEP len1: error = will always fail
+
+ my_memset(pi, 0, 10 * sizeof(int));
+ my_memset(pi, 42, 10 * sizeof(int));
+ my_memset(pi, 0, 4);
+ my_memset(pi, 0, 12 * sizeof(int)); // KEEP len2: error = will always fail
+
+ my_memset(pf, 0, 10 * sizeof(struct foo));
+ my_memset(pf, 42, 10 * sizeof(struct foo));
+ my_memset(pf, 0, 4);
+ my_memset(pi, 0, 12 * sizeof(struct foo)); // KEEP len3: error = will always fail
+
+ my_memset(pb, 0, 10 * sizeof(struct bar));
+ my_memset(pb, 42, 10 * sizeof(struct bar)); // KEEP nonzero: error = Assertion
+ my_memset(pb, 0, 4); // KEEP partial: error = Assertion
+ my_memset(pi, 0, 12 * sizeof(struct bar)); // KEEP len4: error = will always fail
+
+ return 0;
+}
--- /dev/null
+// KEEP baseline: success
+
+// This test checks out the combination of DMEMSET with TRUSTED
+
+void * (DMEMSET(1, 2, 3) my_memset)(void * s, char c, int count) {
+ return s;
+}
+
+void * (DMEMCPY(1, 2, 3) my_memcpy)(void* dst, void* src, int sz) {
+ return dst;
+}
+
+int (DMEMCPY(1, 2, 3) my_memcmp)(void* s1, void* s2, int sz) {
+ return 0;
+}
+
+char * TRUSTED s;
+char * NT COUNT(2) t = "Hi";
+int main() {
+ my_memset(s, 0, 2);
+
+ my_memcpy(s, t, 2);
+ my_memcpy(t, s, 2);
+
+ my_memcmp(s, t, 2);
+ my_memcmp(t, s, 2);
+
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+//KEEP baseline: success
+
+int global[5];
+
+int* NONNULL COUNT(3) foo(int* COUNT(4) NONNULL x) {
+ *x = 1;
+ int* p = x + 1;
+ *p = 2;
+ return p;
+}
+
+struct test {
+ int* NONNULL y;
+} gstruct = { & global[2] };
+
+
+int main() {
+ memset(&gstruct, 0, sizeof(gstruct)); // KEEP memset: error = memset on a type containing a nonnull pointer
+ struct test * SAFE p = malloc(1*sizeof(struct test)); //KEEP malloc: error = Allocation of a buffer containing non-null
+
+ int* x = malloc(5*sizeof(*x));
+ //we need a null check here; it's the only one we need in the file.
+ memset(x, 0x55, 5*sizeof(*x));
+ if (global[2]) {
+ x = &global;
+ x++;
+ }
+ x = foo(x);
+ return *x-2;
+}
--- /dev/null
+#include "harness.h"
+
+int x = 0;
+int * pp = &x;
+
+int deref (int * NONNULL p) {
+ return *p;
+}
+
+int main() {
+ int * NONNULL p = pp; // KEEP hasinit: success
+
+ // This gets initialized to 0, which is illegal because it's NONNULL.
+ // (We also get an error because it's used before being defined.)
+ int * NONNULL p; // KEEP missinginit: error = p may be used without being defined
+
+ // An explicit assignment is also caught
+ int * NONNULL p = 0; // KEEP init: error = will always fail.
+
+ return deref(p);
+}
--- /dev/null
+#include "harness.h"
+
+int x;
+int * NONNULL g = &x;
+
+int func(int * NONNULL nz) {
+ return 0;
+}
+
+int * NONNULL * pg = & g;
+
+int main() {
+ int * z = 0;
+
+ int * p = (int * NONNULL)z; return p; // KEEP : error = non-null check
+
+ g = z; // KEEP : error = non-null check
+
+ func(z); // KEEP : error = non-null check
+
+ *pg = z; // KEEP : error = non-null check
+
+ return 0;
+}
--- /dev/null
+
+#include "harness.h"
+
+int x = 5;
+int * NONNULL a[2] = { &x, &x };
+
+int main() {
+
+ if(* a[0] != 5) E(1);
+
+ // Deputy will allow us to zero the contents of a
+ a[0] = 0;
+
+ // And will not have a null check now
+ * a[0] = 0; // KEEP : error = non-null
+
+ return 0;
+}
+
--- /dev/null
+// KEEP baseline: success
+
+int main() {
+ int * SAFE x;
+ int * SAFE (NT a)[10];
+ int * SAFE y;
+
+ int * SAFE * COUNT(9) NT p;
+ int * SAFE * NTS q;
+ int i;
+ int sum;
+
+ x = &i; y = &i; // Non-zero guards above and below array
+
+ p = a;
+ for (i = 0; i < 9; i++) {
+ p[i] = &i;
+ }
+ p[9] = 0;
+ p[9] = &i; // KEEP write1: error = Assertion
+
+ q = p;
+
+ while (*q != 0) {
+ sum += **q;
+ q++;
+ }
+
+ q++; // KEEP inc1: error = Assertion
+
+ return 0;
+}
--- /dev/null
+static char (NT data[])[9] = { "hello" };
+
+int main() {
+ return (**data == 'h') ? 0 : 1;
+}
--- /dev/null
+struct with_string {
+ char * NT COUNT(len) name;
+ int len;
+};
+
+struct with_string (NT mystrings)[] = {
+ {"foobar", sizeof("foobar")-1},
+ {"cup", sizeof("cup")-1},
+ {"watch", sizeof("watch")-1},
+ {(void *)0,0}
+};
+
+int main()
+{
+ struct with_string *p = mystrings;
+
+ while(p->name) {
+ p++;
+ }
+
+ return 0;
+}
--- /dev/null
+// KEEP baseline: success
+
+// This test ensures that we search for a fully-null element instead of
+// just a null byte. It also ensures that the length does not appear
+// artificially long for the same reason.
+
+int main() {
+ int (NT a)[4];
+ int * NTS p;
+ int * COUNT(1) NT q;
+
+ a[0] = 0xffffffff;
+ a[1] = 0xffffff00;
+ a[2] = 0xffffffff;
+ a[3] = 0;
+
+ p = a;
+ p[2] = 0xdeadbeef;
+ p[4] = 0xdeadbeef; // KEEP err1: error = Assertion
+
+ p++;
+ p++;
+ p++;
+
+ q = a;
+ q++;
+ q++;
+ q++; // KEEP err2: error = Assertion
+
+ return 0;
+}
--- /dev/null
+// Test whether we can increment a nullterm string with inferred bounds.
+
+char foo(const char * NTS t) {
+ const char * NT s = t;
+ s++;
+ return *s;
+}
+
+int main() {
+ char c = foo("test");
+ return (c == 'e') ? 0 : 1;
+}
--- /dev/null
+// KEEP baseline: success
+
+int main() {
+ char * NTS s = "test";
+ char * COUNT(0) s1 = NTDROP(s);
+ char * s2 = NTEXPAND(s);
+ char c;
+
+ c = s1[0]; // KEEP err1: error = will always fail
+
+ c = s2[0];
+ c = s2[3];
+ c = s2[4];
+ c = s2[5]; // KEEP err2: error = nullterm upper bound check
+
+ return 0;
+}
--- /dev/null
+int main() {
+ char * NTS s = "test";
+ char * COUNT(4) t = NTDROP(NTEXPAND(s));
+ return 0;
+}
--- /dev/null
+// Test that we are properly initializing local variables.
+
+#include "harness.h"
+
+TESTDEF baseline:success
+
+void scribble() {
+ int a[2048];
+ int i;
+
+ // Write a bunch of garbage on the stack.
+ for (i = 0; i < 2048; i++) {
+ a[i] = 42;
+ }
+}
+
+void test() {
+ int i;
+
+ int * p1;
+ int (NT p2)[8];
+ struct foo {
+ int * f;
+ } p3;
+
+ struct foo p4[8];
+
+ struct fooNT {
+ int (NT a)[8];
+ } p5;
+
+ union fooNTu {
+ int * ptr WHEN(1);
+ int in;
+ } p6;
+
+ // Check that we actually scribbled on the stack. A failure here does
+ // not indicate a failure in Deputy; I'm just trying to ensure that
+ // the test tests what it's supposed to be testing. If this test starts
+ // to fail, we can just remove it.
+ if(i != 42) E(10);
+
+ //We report this one as an error:
+ if(p1 != 0) E(1); //KEEP uninit_ptr: error = p1 may be used without being defined
+
+ if(p2[7] != 0) E(2);
+
+ if(p3.f != 0) E(3);
+
+ for(i=0;i<8;i++) {
+ if(p4[i].f != 0) E(4);
+ }
+
+ if(p5.a[7] != 0) E(5);
+
+ if(p6.ptr != 0) E(6);
+
+ SUCCESS;
+}
+
+int main() {
+ scribble();
+ test();
+
+ SUCCESS;
+}
--- /dev/null
+//Don't allow negative counts!
+
+
+extern const char (NT COUNT(-1) not_really_there1)[0];
+const char * NT COUNT(-1) x1 = not_really_there1;
+
+int neg_one = -1;
+extern const char (NT COUNT(neg_one) not_really_there2)[0];
+const char * NT COUNT(neg_one) x2 = not_really_there2;
+
+int global;
+int main() {
+ global = not_really_there1[0]; //KEEP array1: error = zero length
+ global = *x1; //KEEP ptr1: error = zero length
+ global = not_really_there2[0]; //KEEP array2: error = zero length
+ global = *x2; //KEEP ptr2: error = zero length
+ return 0;
+}
+
--- /dev/null
+int my_strlen(
+ char *
+ // KEEP baseline: error = upper bound check
+ NTS // KEEP nts: success
+ CT(5) // KEEP ct5: error = upper bound check
+ CT(6) // KEEP ct6: error = nullterm upper bound coercion
+ NT CT(5) // KEEP ntct5: success
+ NT CT(6) // KEEP ntct6: error = nullterm upper bound coercion
+ p) {
+ int i = 0;
+ while (p[i] != 0) {
+ i++;
+ }
+ return i;
+}
+
+int read5(char * CT(5) p) {
+ int i;
+ int sum = 0;
+ for (i = 0; i < 5; i++) {
+ sum += p[i];
+ }
+ return sum;
+}
+
+int main() {
+ int len = my_strlen("hello"); // Test the annotation above.
+
+ char * NTS p = "world";
+ read5(p); // Make sure we do a proper NT expand here.
+
+ return (len == 5) ? 0 : 1;
+}
--- /dev/null
+#include "harness.h"
+
+// Don't allow negative counts!
+
+int main() {
+IFTEST t1: error = upper bound check
+ char * NT COUNT(-1) p = malloc(0);
+ *p = 0;
+ENDIF
+IFTEST t2: error = upper bound check
+ int neg_one = -1;
+ char * NT COUNT(neg_one) p = malloc(0);
+ *p = 0;
+ENDIF
+IFTEST t3: error
+ char *p = malloc(0);
+ char * NTS q = p; // Force p to be inferred NT.
+ *p = 0;
+ENDIF
+ return 0;
+}
--- /dev/null
+//KEEP baseline: success
+#include "harness.h"
+
+typedef struct {
+ char foo[32];
+ int scalar;
+} message_t;
+
+int x = 0;
+
+//
+// Make sure deputy supports the standard trick for offsetof
+//
+
+
+int main() {
+ if (32 != & ((message_t *)0)->scalar) E(1);
+ //array case: & is changed to StartOf
+ if (0 != (unsigned )& ((message_t *)0)->foo) E(2);
+
+
+ //This is safe, but there's no reason to support it:
+ if (33 != & ((message_t *)1)->scalar) E(3); //KEEP 1: error = Type mismatch
+
+ x = & ((message_t *)&x)->scalar; //KEEP 2: error = will always fail
+
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+//
+// Make sure deputy supports the standard trick for offsetof
+//
+
+
+typedef struct {
+ char bar[4];
+ char data[28];
+} message_t;
+
+typedef struct {
+ char h[2];
+} cc1000_header_t;
+
+cc1000_header_t *f(message_t *amsg)
+{
+ return (cc1000_header_t * SAFE)(void * TRUSTED)
+ ((char *)amsg + ((unsigned )& ((message_t*)0)->data
+ - sizeof(cc1000_header_t )));
+}
+
+int main() {
+ message_t msg;
+ cc1000_header_t * res = f(&msg);
+ if ((unsigned)res != ((unsigned)&msg + 2)) E(1);
+ return 0;
+}
--- /dev/null
+typedef struct {
+ char foo[28];
+} message_t;
+
+int f(unsigned char x)
+{
+ if (x > 5 + (unsigned )& ((message_t *)0)->foo)
+ return 1;
+ else
+ return 0;
+
+}
+
+int main() {
+ return f(5);
+}
--- /dev/null
+// KEEP baseline: success
+
+#include "harness.h"
+
+struct S {
+ int len;
+ int* (COUNT(len) data)[]; // KEEP t1: success
+IFNTEST t1
+ int* (COUNT(len) data)[0];
+ENDIF
+};
+
+void foo(int** COUNT(n) s, int n) {
+}
+
+int main() {
+ struct S *p;
+ p = malloc(1); // KEEP e2: error = open array allocation
+IFNTEST e2
+ p = malloc(sizeof(struct S) + 5 * sizeof(int));
+ENDIF
+ p->len = 5;
+ p->len = 4;
+ p->len = 6; // KEEP e1: error = upper bound
+ foo(p->data, p->len);
+ return 0;
+}
--- /dev/null
+// Same as openarray1, but with nullterm.
+
+// KEEP baseline: success
+
+#include "harness.h"
+
+struct S {
+ int len;
+ char (NT COUNT(len) name)[]; // KEEP t1: success
+IFNTEST t1
+ char (NT COUNT(len) name)[0];
+ENDIF
+};
+
+void foo(char * COUNT(n) s, int n) {
+}
+
+int main() {
+ struct S *p;
+ p = malloc(1); // KEEP e2: error = open array allocation
+IFNTEST e2
+ p = malloc(sizeof(struct S) + 6);
+ENDIF
+ p->len = 5;
+ p->name[4] = 'a';
+ p->len = 4;
+ p->len = 5;
+ p->len = 6; // KEEP e1: error = upper bound
+ foo(p->name, p->len);
+ return 0;
+}
--- /dev/null
+// Don't convert zero-length array to flexible array if it's the only field.
+
+struct padding {
+ int x[0];
+} __attribute__((__aligned((1) << (7))));
+
+struct foo {
+ char a;
+ struct padding p1;
+ char b;
+ struct padding p2;
+ char c;
+};
+
+int main() {
+ struct foo f;
+ f.a = 0;
+ f.b = 1;
+ f.c = 2;
+ return 0;
+}
--- /dev/null
+// This test makes sure we don't complain about globals with (empty)
+// open arrays inside them (see bug 4).
+
+#include "harness.h"
+
+struct foo {
+ int size;
+ struct kern_ipc_perm *(COUNT(size) p)[] ;
+};
+
+struct foo f;
+
+int main() {
+ printf("%d\n", sizeof(f));
+ return 0;
+}
--- /dev/null
+// Verify that unreachable statements don't cause problems.
+
+int main() {
+ int * SAFE p = 0;
+ return 0;
+ *p = 0;
+}
--- /dev/null
+struct list_head {
+ struct list_head *next;
+};
+struct signal_struct {
+ struct list_head cpu_timers[3];
+};
+void foo(struct signal_struct *sig) {
+ (&sig->cpu_timers[1])->next = &sig->cpu_timers[1];
+}
+int main() {
+ struct signal_struct s;
+ foo(&s);
+ return 0;
+}
--- /dev/null
+// This test ensures that abstract types are treated correctly.
+// In particular, we need to avoid errors involving arithmetic on
+// such types.
+
+struct foo;
+
+struct foo *getfoo() {
+ return 0;
+}
+
+int main() {
+ struct foo *p = getfoo();
+ return 0;
+}
--- /dev/null
+// This test makes sure we don't strip off the void* -> char* cast
+// inside checks, which causes gcc to complain.
+
+void foo(void * SIZE(len) pv, int len) {
+ char *pc = pv;
+ int i;
+ for (i = 0; i < len; i++) {
+ pc++;
+ }
+}
+
+int main() {
+ char s[3] = { 42, 42, 42 };
+ foo(s, 3);
+ return 0;
+}
--- /dev/null
+int find_first_bit(int * COUNT((size / 32) + 1) addr,
+ int size // KEEP t1: success
+ unsigned int size // KEEP t2: success
+ ) {
+ return 0;
+}
+
+int foo(int *p, int n) {
+ return find_first_bit(p, n);
+}
+
+int main() {
+ int i;
+ return foo(&i, 1);
+}
--- /dev/null
+int main() {
+ char a[] = { 'a', 'b', 'c' };
+ char const * COUNT(3) p = a;
+ ((char *) p)[1] = 'x';
+ return 0;
+}
--- /dev/null
+// This test results (resulted) in a divide-by-zero error due to the
+// zero-length struct.
+
+typedef struct spinlock {
+} spinlock_t;
+
+spinlock_t slavecpulocks[1];
+
+int main() {
+ int i;
+ spinlock_t x;
+
+ for (i = 0; i < 1; i++) {
+ *(&slavecpulocks[i]) = x;
+ }
+
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+struct foo {
+ int * SAFE p;
+};
+
+void bar(struct foo *fp) {
+ fp->p = malloc(sizeof(int));
+ *fp->p = 0;
+}
+
+int main() {
+ struct foo f;
+ struct foo *fp = &f;
+
+ fp->p = 0;
+ bar(fp); // We want to test whether fp->p == 0 is killed here.
+ return *fp->p;
+}
--- /dev/null
+// Verify that we don't propagate constants past address-of.
+
+#include "harness.h"
+
+void foo(int * SAFE * SAFE pp) {
+ *pp = alloc(int, 1);
+}
+
+int main() {
+ int * SAFE p = 0;
+ int n;
+
+ foo(&p);
+ n = 0;
+ n = *p;
+
+ return 0;
+}
--- /dev/null
+
+int count;
+int * COUNT(count) pdata;
+
+
+int data[8];
+void fill_data() {
+ pdata = 0;
+ count = 8;
+ pdata = data;
+
+ pdata[0] = 0;
+}
+
+int main() {
+ count = 0;
+ fill_data();
+
+ return data[0]; // KEEP : success
+ return pdata[0]; // KEEP : success
+}
--- /dev/null
+//Make sure the optimizer doesn't delete labels by mistake.
+
+#include <string.h> //strlen
+
+int main() {
+ int type;
+ //CIL will insert a label '__Cont' here to implement the continue.
+ for (type = 0; type == 0; ) {
+ type = 1;
+ continue;
+ }
+ return 0;
+}
+
+struct n {
+ struct n* n_cdr;
+ int n_type;
+ char* NTS n_str;
+};
+typedef struct n NODE;
+typedef int FIXNUM;
+NODE *cvfixnum(FIXNUM n);
+
+NODE *xlength(NODE *args)
+{
+ NODE *arg = args;
+ int n;
+ if (((arg) == 0 || (arg)->n_type == 2))
+ arg = ((arg)->n_cdr);
+ else if (((arg) && (arg)->n_type == 4))
+ n = strlen(((arg)->n_str));
+ else if (arg)
+ return 0;
+}
--- /dev/null
+// An optimizer test case minimized from libc/string6.
+
+#include "harness.h"
+
+int table[256];
+int * COUNT(256) tablep = table;
+
+const int * COUNT(256) * ctype_b_loc(void) {
+ return &tablep;
+}
+
+int skip_atoi(const char * NTS * s) {
+ int i = 0;
+
+ while (((*ctype_b_loc ())[**s])) {
+ i++;
+ }
+
+ return i;
+}
+
+const char * NTS make_str() {
+ char * NTS str = malloc(1);
+ str[0] = 0;
+ return str;
+}
+
+int main() {
+ const char * NTS p;
+ int i;
+
+ for (i = 0; i < 256; i++) {
+ table[i] = 0;
+ }
+
+ p = make_str();
+ skip_atoi(&p);
+
+ return 0;
+}
--- /dev/null
+// A minimized optimizer bug from writev1.c. Make sure we don't
+// delete the "dead" variable p2.
+
+#include "harness.h"
+
+int main() {
+ char *p1;
+ char *p2;
+ const int size = 8;
+ p1 = malloc((size+1) * sizeof p2[0]);
+ p2 = p1 + size;
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+//
+//Update: this test doesn't apply to gcc v4, which doesn't have the
+// -fwritable-strings option. The fact that strings shouldn't be
+// forward-substituted still holds, but we have no good way of testing it.
+//
+
+
+//baseline fails when compiled with -fwritable-strings and --deputyopt=3
+//KEEP baseline: success
+
+//Don't do forward substitution with string literals. If -fwritable-strings is
+//used, each appearance of a string literal gets its own pointer.
+//
+//Even if -fwritable-strings is not used, is it okay to assume that string
+//literals will be coalesced?
+
+int main() {
+ char * p = NTDROP("Hello.");
+ int sum = 0;
+ while(*p != '.') {
+ sum += *p;
+ p++;
+ p += 8; //KEEP ubound: error = upper
+ }
+ int desiredsum = 'H'+'e'+'l'+'l'+'o';
+ if (sum != desiredsum) E(3);
+ return 0;
+}
--- /dev/null
+// The errors below should be caught at compile time.
+
+// KEEP baseline: success
+
+static int glen = 0;
+static int * COUNT(glen) gbuf = 0;
+
+int inc(int * COUNT(len) NONNULL buf, int len) {
+ len += 10; // KEEP e3: error = will always fail
+ //Use buf so that it's live on the line above.
+ return *buf;
+}
+
+void ginc() {
+ // We can't catch this statically, because gbuf might be NULL.
+ glen += 10; // KEEP e4: error = Assertion failed
+}
+
+int main() {
+ int len;
+ int * COUNT(len) buf;
+ int a[10];
+
+ len = 10;
+ buf = a;
+
+ len += 10; // KEEP e1: error = will always fail
+
+ inc(buf, len);
+
+ glen = 10;
+ gbuf = a;
+
+ glen += 10; // KEEP e2: error = will always fail
+
+ ginc();
+
+ return 0;
+}
--- /dev/null
+int main() {
+ static char (NTS a)[256 + 1];
+ a[256] = 0;
+ return 0;
+}
--- /dev/null
+// NUMERRORS 2
+
+#include "harness.h"
+
+// This is potential bug regarding overflow in multiplication. We wrongly
+// assume that k times x is always a multiple of k.
+//
+// In this example, we dereference p[x] where the elements in p are 12 bytes
+// long, so p[x] compiles to mem[p + 12x]. But if we take
+// x = 357,913,942, then (12x mod 2^32) is 8. Address (p + 8) is
+// within bounds, yet we read the i2 field when we think we are reading
+// the ptr field.
+
+int globalint = 29;
+
+#define NELEM 4
+
+
+struct twelve{
+ int* SAFE ptr;
+ unsigned int i1;
+ unsigned int i2;
+};
+
+int foo(unsigned int x, struct twelve* COUNT(NELEM) p) {
+ int* ptr = p[x].ptr;
+ printf("p = 0x%x, &p[x] = 0x%x\n", (unsigned long) p, (unsigned long) &p[x]);
+ printf("Pointer is 0x%x\n", (unsigned long) ptr);
+ //ptr is now 0xdeadbeef.
+ return *ptr;
+}
+
+
+int main() {
+ if (sizeof (struct twelve) != 12) E(1);
+
+ struct twelve* p = malloc(NELEM * sizeof(struct twelve));
+ for (int i = 0; i < NELEM; i++) {
+ p[i].ptr = &globalint;
+ p[i].i1 = (unsigned int)0xbadf00d;
+ p[i].i2 = (unsigned int)0xdeadbeef;
+ }
+ foo(3,p); //KEEP baseline: success
+ foo(357913942,p); //KEEP overflow: error = Assertion failed
+ SUCCESS;
+}
--- /dev/null
+
+#include "harness.h"
+
+//If len = 2^30+1, and sizeof(*p)=4, then p+len = p+4.
+//This causes unsoundness in our optimizer
+
+int foo(int * COUNT(len) p, int len) {
+ if (len <= 1000) {return 42;}
+ else {printf("accessing 0x%x\n", p+1000);
+ return p[1000];}
+}
+
+//KEEP baseline: success
+
+
+int main() {
+ int len = 4;
+ int* COUNT(len) p = malloc(len*sizeof(int));
+ printf("len is %d, p = %x\n", len, p);
+ len = (1<<30)+4; //KEEP bug: error = Assertion failed
+ printf("len is %d, p = %x\n", len, p);
+ printf("foo is %d\n", foo(p, len));
+ return 0;
+}
--- /dev/null
+struct packed {
+ char a;
+ short b;
+} __attribute__((packed));
+
+
+int i = 3;
+int main() {
+ struct packed p[4];
+ p[i].b = 1;
+ return 0;
+}
--- /dev/null
+TV(t) id(TV(t) p) {
+ return p;
+}
+
+int main() {
+ int i = 0;
+ int *p = &i;
+ return * (int*) id(p);
+}
--- /dev/null
+TV(t) deref(TV(t) * p) {
+ return *p;
+}
+
+int main() {
+ int i = 0;
+ int *p = &i;
+ int **pp = &p;
+ return deref(deref(pp));
+}
--- /dev/null
+TV(t) choose(int n, TV(t) a, TV(t) b) {
+ return n > 42 ? a : b;
+}
+
+int main() {
+ int a;
+ int b;
+
+ int n = choose(13, (int) 3, (int) 5);
+ int *p = choose(50, &a, &b);
+
+ return 0;
+}
--- /dev/null
+struct foo {
+ int *q;
+ int a;
+ int b;
+};
+
+int getfoo(struct foo *p) {
+ return p->b;
+}
+
+int getint(int *p) {
+ return *p;
+}
+
+int run(int (*fn)(TV(t) p), TV(t) p) {
+ return fn(p);
+}
+
+struct fioo {
+ TV(t) data;
+ int (*fn)(TV(t) p);
+};
+
+int test1() {
+ int i = 24;
+ struct foo f = { 0, 0, 42 };
+ return run(getfoo, &f) == 42 && run(getint, &i) == 24;
+}
+
+int test2() {
+ struct fioo TP(struct foo *) fi;
+ struct fioo TP(int *) pi;
+
+ int i = 24;
+ struct foo f = { 0, 0, 42 };
+
+ fi.data = &f;
+ fi.fn = getfoo;
+
+ pi.data = &i;
+ pi.fn = getint;
+
+ return fi.fn(fi.data) == 42 && pi.fn(pi.data) == 24;
+}
+
+int main() {
+ return test1() && test2() ? 0 : 1;
+}
--- /dev/null
+int foo(int (*fn)(TV(t) data), TV(t) data) {
+ return fn(data);
+}
+
+int cb_int(int *data) {
+ return *data;
+}
+
+int cb_void(void *data) {
+ // doesn't use data
+ return 0;
+}
+
+int main() {
+ int i = 0;
+ foo(cb_int, &i);
+ foo(cb_void, (void*) 0);
+ return 0;
+}
--- /dev/null
+struct notifier_block {
+ int (*callback)(TV(t));
+ TV(t) data;
+};
+
+struct notifier_block TP(char * NTS) * reboot_notifier_list;
+
+int notifier_chain_register(struct notifier_block TP(TV(t)) ** list,
+ struct notifier_block TP(TV(t)) * nb) {
+ return 0;
+}
+
+int register_reboot_notifier(struct notifier_block TP(char * NTS) * nb)
+{
+ return notifier_chain_register(&reboot_notifier_list, nb);
+}
+
+int main() {
+ struct notifier_block TP(char * NTS) nb;
+ return register_reboot_notifier(&nb);
+}
--- /dev/null
+// Make sure we handle polymorphic functions where only the return type is
+// polymorphic. Thanks to Richard Jones.
+
+struct foo {
+ TV(t) data;
+};
+
+struct foo TP(TV(t)) *alloc_foo() {
+ return 0;
+}
+
+int main() {
+ struct foo TP(int *) *foo_ptr;
+ foo_ptr = alloc_foo();
+ return (int) foo_ptr;
+}
--- /dev/null
+#include "harness.h"
+
+int main() {
+ int * COUNT(5) p = alloc(int, 5);
+ int * BND(p, p + 5) q = p + 5;
+ int n = q - p;
+ return (n == 5) ? 0 : 1;
+}
--- /dev/null
+struct p {
+ void * SIZE(maxlen) data;
+ int maxlen;
+};
+
+void f(struct p *s, int newlen) {
+ int len = newlen;
+ if (len == s->maxlen)
+ len--;
+ /* zf: this triggers a bug that reports an upper-bound failure */
+ ((char * COUNT(len+1)) TC(s))[len] = 0;
+}
+
+int main() {
+ struct p s;// = {.data = TC("0123456789"), .maxlen = 10};
+ s.maxlen = 10;
+ s.data = TC("0123456789");
+
+ f(&s, 10);
+
+ return 0;
+}
--- /dev/null
+static inline void * BND(addr, addr+size)
+memscan(void * CT(size) addr, int c, unsigned int size)
+{
+ void * BND(addr, addr + size) t = addr;
+
+ return t;
+}
+
+char foo[] = "abcdefghijklmnopqrstuvwxyz";
+
+int main()
+{
+ char * k = memscan(foo, 'k', 26);
+
+ return 0;
+}
--- /dev/null
+// KEEP baseline: success
+
+#include "harness.h"
+
+int * COUNT(10) myalloc() {
+ return alloc(int, 10);
+}
+
+int main() {
+ int * COUNT(10) p;
+ int * BND(q, p+10) q;
+
+ // This call should get broken into two statements, one where we
+ // assign to a fresh variable and one where we assign this value to p.
+ // The checks for the assignment to p should pass.
+ p = myalloc();
+ q = p;
+
+ // This part should fail, because the assignment to p will violate the
+ // restrictions on q.
+ p = myalloc(); // KEEP return1: error = Assertion
+
+ return *q; //use q so that it's live
+}
--- /dev/null
+#include "harness.h"
+
+int foo(int * SNT * p) {
+ int x = 0;
+ int * SNT * local = p;
+ x = **local; //KEEP deref1: error = sentinel
+
+ // it's okay to cast ints to sentinel pointers.
+ *local = 0xbadf00d;
+ *p += (int)*p;
+
+ //SNT implies COUNT(0). Make sure no one refers to
+ //__attribute__((sentinel)) directly, which would let them
+ //dereference a sentinel pointer.
+ int * __attribute__((sentinel)) SAFE bad = *p; x = *bad; //KEEP safe: error = dereference of a sentinel
+
+ return 0;
+}
+
+int main() {
+ int buffer[256];
+ int* SNT before = (int * SNT)buffer - 1;
+ int* SNT after = &buffer[200];
+ after += 56; //after = buffer+256
+ unsigned long bufferp = &buffer[0];
+
+ int* x = after; *x = 2; //KEEP cast: error = may not be cast
+ *after = 3; //KEEP deref2: error = sentinel
+
+ if (before != (bufferp - sizeof(int))) E(1);
+ if (after != (bufferp + 256*sizeof(int))) E(2);
+
+ foo(&before);
+
+ return 0;
+}
+
--- /dev/null
+#include "harness.h"
+
+//q should be inferred to be a Sentinel, not SAFE.
+
+int main() {
+ int * p = alloc(int, 5);
+ int * q = p + 5;
+ int n = (int)q - (int)p;
+ return 0;
+}
--- /dev/null
+// KEEP baseline: success
+
+void foo(void * SIZE(n) p, int n) {
+ char *q = (char*) p;
+ q[n-1] = 0;
+ q[n] = 0; // KEEP e2: error = will always fail
+ *p = 0; // KEEP e3: error = mismatch in coercion
+}
+
+int main() {
+ int i;
+ int a[10];
+ int *b[10];
+ foo(&i, sizeof(int));
+ foo(a, sizeof(int) * 10);
+ foo(b, sizeof(int*) * 10); // KEEP e1: error = Type mismatch
+ return 0;
+}
--- /dev/null
+// Size test from TinyOS, courtesy of David Gay.
+
+typedef unsigned char uint8_t;
+typedef struct { unsigned char data[1]; } nx_uint8_t;
+
+typedef struct CC1KHeader {
+ nx_uint8_t length;
+} cc1000_header_t;
+
+IFTEST t1: success
+uint8_t __nesc_ntoh_uint8(const void *SIZE(1) source) {
+ const uint8_t *base = source;
+ return base[0];
+}
+ENDIF
+
+IFTEST t2: success
+uint8_t __nesc_ntoh_uint8(nx_uint8_t *source) {
+ const uint8_t *base = source->data;
+ return base[0];
+}
+ENDIF
+
+cc1000_header_t foo;
+
+int main(void) {
+ cc1000_header_t *txHeader = &foo;
+ foo.length.data[0] = 0;
+ return (1 < __nesc_ntoh_uint8(&txHeader->length)) ? 1 : 0;
+}
--- /dev/null
+// Another SIZE test from David Gay.
+
+typedef unsigned char uint8_t;
+char buf[20];
+
+void *SIZE(len) get1(uint8_t len)
+{
+ if (len <= 20)
+ return buf;
+ else
+ return 0;
+}
+
+void *SIZE(len) get2(uint8_t len)
+{
+ // We'll get a void* temporary here.
+ return get1(len);
+}
+
+int main()
+{
+ char *fun = get2(10);
+
+ return fun[0];
+}
--- /dev/null
+// Test that locals with SIZE type are handled properly. Also tests
+// allocation of SIZE types.
+
+// KEEP baseline: success
+
+#include "harness.h"
+
+void foo(void * SIZE(n) p, int n) {
+}
+
+int main() {
+ void * SIZE(10) p = malloc(10);
+ void * SIZE(5) q = p;
+ foo(q, 5);
+ foo(p, 6);
+ foo(q, 6); // KEEP e1: error = Assertion
+ return 0;
+}
--- /dev/null
+int main() {
+ int * SAFE p = 0;
+ int i = sizeof(*p);
+ return 0;
+}
--- /dev/null
+// This test checks that we can use sizeof on any variable that is
+// currently in scope.
+
+char a[5];
+
+typedef char c[5];
+
+int main() {
+ char b[5];
+
+ char * COUNT(sizeof(a)) pa;
+ char * COUNT(sizeof(b)) pb;
+ char * COUNT(sizeof(c)) pc;
+
+ pa = a;
+ pb = b;
+ pc = b;
+
+ return 0;
+}
--- /dev/null
+int main() {
+ int *p;
+ int x = sizeof(*((int * TRUSTED)p)); // KEEP t1: success
+ int x = sizeof(*((int * FAT)p)); // KEEP t2: success
+ return x - sizeof(int);
+}
--- /dev/null
+int main() {
+ int a[10];
+ int * COUNT(10) p = a;
+
+ return 0;
+}
--- /dev/null
+// KEEP baseline: success
+
+int main() {
+ int a[10];
+ int * COUNT(20) p = a; // KEEP size1: error = will always fail
+
+ return 0;
+}
--- /dev/null
+// KEEP baseline: success
+
+#include "harness.h"
+
+int my_strlen(char * NTS str) {
+ return 5;
+}
+
+void my_memcpy(char * NT COUNT(len) dest,
+ char * NT COUNT(len) src,
+ int len) {
+ int i;
+ for (i = 0; i < len; i++) {
+ dest[i] = src[i];
+ }
+ dest[len] = src[len]; //copy the NULL
+}
+
+void foo(char * NTS str) {
+ char c = *str;
+ *str = 0;
+}
+
+void addr (char chr) {
+ char* NTS str = "";
+ char c = *str; //legal
+ //Don't create a COUNT(1) pointer to *str, because that would let us
+ //overwrite the null.
+ char* NTS str2 = &(*str); //KEEP addrofnull: error = Assertion
+ *str2 = chr; //KEEP addrofnull
+}
+
+void cast(char * NTS str) {
+ char* COUNT(0) str2 = NTDROP(str); //cast away the nullterm. This is safe.
+ foo(str2); //KEEP cast: error = Cast from ordinary pointer to nullterm
+}
+
+int main() {
+ char* NTS hello = "Hello";
+ char* NT COUNT(5) str = alloc(char, 6);
+ my_memcpy(str, hello, 5); //This coerces hello to NTS COUNT(5) using strlen
+ foo(str);
+ cast(str);
+ addr(*hello);
+ return 0;
+}
--- /dev/null
+// Allow count annotations in arrays with explicit length.
+
+// CIL will insert the length based on the initializer.
+char (NTS foo)[] = "foo"; // KEEP t1: success
+
+// Just for sanity's sake...
+char (NTS foo)[4] = "foo"; // KEEP t2: success
+
+int main() {
+ return (foo[3] == 0) ? 0 : 1;
+}
--- /dev/null
+typedef char * NTS string;
+
+int matchname(string bind, string name)
+{
+ // Let Deputy infer bounds
+ char * NTS bp, * NTS np; // KEEP test1 : success
+ char * bp, * np; // KEEP test2 : success
+
+ bp = bind;
+ np = name;
+ while (*bp == *np) {
+ bp++;
+ np++;
+ }
+ return (*bp == '=' && *np == 0);
+}
+
+int main() {
+ return ! matchname("foo=2", "foo");
+}
--- /dev/null
+struct str {
+ char (NT data)[32];
+} x;
+
+struct nostr {
+ char data[32];
+} y;
+
+
+int main() {
+ char * NT p = & x.data[0]; // KEEP first : success
+
+ // When we take the address of an element inside an array, maintain the bounds
+ char * p = & y.data[5]; p[-5] = 1; p[31 - 5] = 1; // KEEP third : success
+ char * p = & y.data[5]; p[-6] = 1; // KEEP lbound : error = Assertion
+ char * p = & y.data[5]; p[32-5] = 1; // KEEP ubound : error = will always fail
+
+
+ return 0;
+}
--- /dev/null
+// Very often I put the NT annotation on char instead of char *, by mistake
+// I want a warning.
+
+TESTDEF warn : error = Deputy annotations cannot be placed on this type
+char NT * p;
+int i;
+int COUNT(0) * pi = &i;
+
+int main() {
+ *pi = 0;
+ return *pi;
+}
--- /dev/null
+int main() {
+ char * NT p = "garbage";
+ p += 3;
+ return *p != 'b';
+}
--- /dev/null
+#include "harness.h"
+
+char * NT check(int arg) {
+ char* res = arg > 0 ? "true" : "false";
+ return res;
+}
+
+//Try a disconnected node: We have to look at the ? : to get the type of res,
+//since we can't infer it from the use (vararg functions are not implemented).
+void print(int arg) {
+ char* res = arg > 0 ? "true" : "false";
+ char* fmt = "%s\n";
+ printf(fmt, res);
+}
+
+int main() {
+ print(1);
+
+ if (check( 1)[0] != 't') exit(1);
+ if (check(-2)[0] != 'f') exit(2);
+
+ return 0;
+}
--- /dev/null
+//Yet another set of string tests.
+
+//KEEP baseline: success
+
+#include <string.h>
+#include "harness.h"
+
+struct withstring {
+ int x;
+ char* NTS str;
+};
+
+char* NTS global;
+
+int loop() {
+ int acc = 0;
+ char * s = NTEXPAND(global);
+ while (*s) {
+ acc += *s;
+ s++;
+ }
+ //we should be able to write an empty string.
+ global = s;
+ return acc;
+}
+
+void copy(char * NTS in) {
+ char * NT s = NTEXPAND(in);
+ char * NT t = NTEXPAND(global);
+ while (*s) {
+ *t = *s;
+ t++; s++;
+ }
+ *t = *s;
+}
+
+static char (NT terminated)[2] = { 1, 0 };
+static char (NT tooshort)[2] = { 1 }; //should be padded with zeros, so OK.
+static char notterminated[2] = { 1, 1 }; //KEEP arraynotterm: error = Cast from ordinary pointer to nullterm
+
+void array() {
+ char notterminated_local[2] = { 1, 1 }; //KEEP arraynotterm_local: error = nullterm write check
+
+ copy("HELLO, WORLD");
+ copy(tooshort); //KEEP tooshort: success
+ //make sure tooshort[1] == 0
+ if (global[1] != 0) E(2); //KEEP tooshort
+
+ copy(terminated); //KEEP terminated: success
+ copy(notterminated); //KEEP arraynotterm
+ copy(notterminated_local); //KEEP arraynotterm_local
+}
+
+int main() {
+ char* tmp = malloc(13);
+ strncpy(tmp, "Hello, world", 12);
+ global = tmp;
+
+ copy("HELLO, WORLD");
+ copy("HELLO, WORLD!"); //KEEP ubound: error = nullterm write check
+
+ array();
+
+ loop();
+ SUCCESS;
+}
--- /dev/null
+#include "harness.h"
+
+TESTDEF : success
+
+int BuildWord(char * NTS pchWord)
+{
+ int i;
+ char * NTS pch = pchWord;
+
+ /* original code: */
+ while ((i = *pch) != '\0') { pch ++; }
+
+ // This other variant would increment the pointer past the 0
+ while ((i = *pch ++) != '\0') { } // KEEP : error
+
+ printf("%s\n", pchWord);
+
+ // however, going one past the final null is bad!
+ pch++; // KEEP : error = Assertion
+ return i;
+}
+
+
+int main()
+{
+ static char (NT test)[] = "foo";
+
+ return BuildWord(test);
+}
--- /dev/null
+//This test should work without any changes.
+//KEEP baseline: success
+
+int foo(char * NTS str) {
+ return 0;
+}
+
+int main() {
+ foo("Hello");
+ return 0;
+}
--- /dev/null
+// String tests from Jeremy.
+
+#include "harness.h"
+
+int my_strlen(char* NTS s) {
+ int n = 0;
+ while (*s != 0) {
+ n++;
+ s++;
+ }
+ return n;
+}
+
+void my_strlcpy(char* COUNT(n-1) NT dest, char* NTS src, int n) {
+ int position;
+ for (position = 0; position < n-1 && *src != 0; src++, position++) {
+ dest[position] = *src;
+ }
+ if (position < n) {
+ *dest = 0;
+ }
+}
+
+void my_strlcat(char* COUNT(n-1) NT dest, char* NTS src, int n) {
+ int offset = my_strlen(dest);
+ my_strlcpy(dest + offset, src, n - offset);
+}
+
+char* NTS my_strdup(char* NTS s1) {
+ int i;
+ int len = my_strlen(s1);
+ char * s2 = malloc(len+1);
+ for (i = 0; i < len; i++) {
+ s2[i] = s1[i];
+ }
+ s2[len] = 0;
+ return s2;
+}
+
+
+TESTDEF str-iter-1 : success
+IFTEST str-iter-1
+void test(char * NTS str) {
+ while (*str != 0) {
+ str++;
+ }
+}
+int main() {
+ test("test string");
+ return 0;
+}
+ENDIF
+
+TESTDEF str-iter-2even : success
+IFTEST str-iter-2even
+void test(char * NTS str) {
+ while (*str != 0) {
+ str += 2;
+ }
+}
+int main() {
+ test("test string."); //buffer length = 13, so [0]...[12] are accessible.
+ return 0;
+}
+ENDIF
+
+TESTDEF str-iter-stride4 : error
+IFTEST str-iter-stride4
+void test(char * NTS str) {
+ while (*str != 0) {
+ str += 4;
+ }
+}
+int main() {
+ test("test strng");
+ return 0;
+}
+ENDIF
+
+TESTDEF str-iter-3 : success
+IFTEST str-iter-3
+void test(char * NTS str) {
+ int i;
+ int sum = 0;
+ for (i = 0; str[i] != 0; i++) {
+ sum += str[i];
+ }
+}
+int main() {
+ test("test string");
+ return 0;
+}
+ENDIF
+
+IFTEST str-iter-4 : error
+void test(char * NTS str) {
+ int i;
+ int sum = 0;
+ for (i = 0; str[i] != 0; i += 4) {
+ sum += str[i];
+ }
+}
+int main() {
+ test("test strng");
+ return 0;
+}
+ENDIF
+
+TESTDEF str-iter-5 : success
+IFTEST str-iter-5
+void test(char * NTS str) {
+ int sum = 0;
+
+ while (*str != 0) {
+ while (*str == ' ') {
+ str++;
+ }
+
+ while (*str != 0 && *str != ' ') {
+ sum += *str;
+ str++;
+ }
+ }
+}
+int main() {
+ test("test string");
+ return 0;
+}
+ENDIF
+
+TESTDEF str-iter-6 : error
+IFTEST str-iter-6
+void test(char * NTS str) {
+ int sum = 0;
+
+ while (*str != 0) {
+ while (*str == ' ') {
+ str++;
+ }
+
+ while (*str != ' ') {
+ sum += *str;
+ str++;
+ }
+ }
+}
+int main() {
+ test("test string");
+ return 0;
+}
+ENDIF
+
+TESTDEF my_strlen-1 : success
+IFTEST my_strlen-1
+void test(char * NTS str) {
+ int i;
+ int sum = 0;
+ int n = my_strlen(str);
+ for (i = 0; i < n; i++) {
+ sum += str[i];
+ }
+}
+int main() {
+ test("test string");
+ return 0;
+}
+ENDIF
+
+TESTDEF my_strlen-2 : success
+IFTEST my_strlen-2
+void test(char * NTS str) {
+ int i;
+ int sum = 0;
+ int n = my_strlen(str);
+ for (i = 0; i < n / 2; i++) {
+ sum += str[i];
+ }
+}
+int main() {
+ test("test string");
+ return 0;
+}
+ENDIF
+
+TESTDEF strlcpy-1 : success
+IFTEST strlcpy-1
+void test(char * NTS str) {
+ char (NT buf)[5];
+ my_strlcpy(buf, str, 5);
+}
+int main() {
+ test("test string");
+ return 0;
+}
+ENDIF
+
+TESTDEF strlcpy-2 : success
+IFTEST strlcpy-2
+void test(char * NTS str) {
+ int len = my_strlen(str);
+ char *buf = alloc(char, len + 1);
+ my_strlcpy(buf, str, len + 1);
+}
+int main() {
+ test("test string");
+ return 0;
+}
+ENDIF
+
+TESTDEF strlcpy-3 : error
+IFTEST strlcpy-3
+void test(char * NTS str) {
+ int len = my_strlen(str);
+ char *buf = alloc(char, len);
+ my_strlcpy(buf, str, len + 1);
+}
+int main() {
+ test("test string.");
+ return 0;
+}
+ENDIF
+
+TESTDEF strlcat-1 : success
+IFTEST strlcat-1
+void test(char * NTS str) {
+ char (NT buf)[15];
+ my_strlcpy(buf, str, 15);
+ my_strlcat(buf, str, 15);
+}
+int main() {
+ test("test string");
+ return 0;
+}
+ENDIF
+
+TESTDEF strlcat-2 : error
+IFTEST strlcat-2
+void test(char * NTS str) {
+ char (NT buf)[15];
+ my_strlcpy(buf, str, 16);
+ my_strlcat(buf, str, 16);
+}
+int main() {
+ test("test string");
+ return 0;
+}
+ENDIF
+
+TESTDEF struct-1 : success
+IFTEST struct-1
+typedef struct foo foo;
+struct foo {
+ char * COUNT(len) buf;
+ int len;
+};
+void test1(foo *p) {
+ char *buf = alloc(char, 10);
+ p->len = 10;
+ p->buf = buf;
+}
+void test2(foo *p) {
+ int i;
+ int sum = 0;
+ for (i = 0; i < p->len; i++) {
+ sum += p->buf[i];
+ }
+}
+int main() {
+ foo f;
+ test1(&f);
+ test2(&f);
+ return 0;
+}
+ENDIF
+
+TESTDEF struct-2 : error
+IFTEST struct-2
+typedef struct foo foo;
+struct foo {
+ char * COUNT(len) buf;
+ int len;
+};
+void test1(foo *p) {
+ char *buf = alloc(char, 12);
+ p->len = 13;
+ p->buf = buf;
+}
+void test2(foo *p) {
+ int i;
+ int sum = 0;
+ for (i = 0; i < p->len; i++) {
+ sum += p->buf[i];
+ }
+}
+int main() {
+ foo f;
+ test1(&f);
+ test2(&f);
+ return 0;
+}
+ENDIF
+
+TESTDEF struct-3 : success
+IFTEST struct-3
+typedef struct foo foo;
+struct foo {
+ char * NTS str;
+};
+void test1(foo *p) {
+ p->str = my_strdup("test string");
+}
+void test2(foo *p) {
+ int i;
+ int sum = 0;
+ int len = strlen(p->str);
+ for (i = 0; i < len; i++) {
+ sum += p->str[i];
+ }
+}
+int main() {
+ foo f;
+ test1(&f);
+ test2(&f);
+ return 0;
+}
+ENDIF
+
+TESTDEF struct-4 : success
+IFTEST struct-4
+typedef struct foo foo;
+struct foo {
+ char * NTS str;
+};
+void test1(foo *p) {
+ p->str = alloc(char, 10);
+}
+void test2(foo *p) {
+ int i;
+ int sum = 0;
+ int len = my_strlen(p->str);
+ for (i = 0; i < len; i++) {
+ sum += p->str[i];
+ }
+}
+int main() {
+ foo f;
+ test1(&f);
+ test2(&f);
+ return 0;
+}
+ENDIF
--- /dev/null
+// Tests *s++.
+
+int main() {
+ char * NTS s = "test";
+ int i = 0;
+ while (*s++) {
+ i++;
+ }
+ return (i == 4);
+}
--- /dev/null
+// This test checks our handling of nullterm arrays.
+// KEEP baseline: success
+
+int main() {
+ char (NT buf)[10];
+ char * NT COUNT(9) p;
+ int i;
+
+ p = buf;
+ for (i = 0; i < 9; i++) {
+ p[i] = 'a';
+ }
+ p[9] = 0;
+
+ p[9] = 'a'; // KEEP nullwrite1: error = Assertion
+ buf[9] = 'a'; // KEEP nullwrite2: error = Assertion
+ return 0;
+}
--- /dev/null
+static int strncmp(const char * NT cs, const char * NT ct, int count)
+{
+ register signed char __res = 0;
+
+ while (count) {
+ if ((__res = *cs - *ct++) != 0 || !*cs++)
+ break;
+ count--;
+ }
+
+ return __res;
+}
+
+int main() {
+ char * s1 = "abcd";
+ char * s2 = "abce";
+
+ strncmp(s1, s2, 3);
+ return 0;
+}
--- /dev/null
+static char * strncat(char * TRUSTED dest, const char * NTS src, int count)
+{
+ char * NT FAT tmp = dest;
+
+ if (count) {
+ while (*dest)
+ dest++;
+ while ((*dest++ = *src++) != 0) {
+ if (--count == 0) {
+ *dest = '\0';
+ break;
+ }
+ }
+ }
+
+ return tmp;
+}
+
+int main() {
+ char dest[16] = "a";
+ char *src = "bcd";
+ strncat(dest, src, 3);
+ return 0;
+}
--- /dev/null
+static int strncmp(const char * NTS cs, const char * NTS ct, int count)
+{
+ int i = 0;
+ for (; i < count-1 && cs[i] && ct[i] && cs[i] == ct[i]; i++)
+ {}
+ return cs[i] - ct[i];
+}
+
+int main() {
+ char * NTS s1 = "bcd";
+ char * NTS s2 = "bcde";
+ strncmp(s1, s2, 5);
+ return 0;
+}
--- /dev/null
+void strlcpy1(char * COUNT(size - 1) NT dest, char * NTS src, int size) {}
+void strlcpy2(char * COUNT(size) NT dest, char * NTS src, int size) {}
+
+int main() {
+ char (NT buf) [100];
+ char * NTS str = "test string";
+
+ strlcpy1(buf, str, sizeof buf);
+ strlcpy2(buf, str, sizeof buf); // KEEP error1: error = Assertion
+
+ return 0;
+}
--- /dev/null
+// This test makes sure that a non-NT pointer can't access that last zero.
+
+// KEEP baseline: success
+
+void my_strcpy(char * TRUSTED dest, const char * NTS src)
+{
+ char * FAT tmp = dest;
+ char * NTS src2 = src; // KEEP baseline
+ char *src2 = NTDROP(src); // KEEP error1: error = Assertion
+
+ while ((*dest = *src2) != '\0') {
+ dest++;
+ src2++;
+ }
+}
+
+int main() {
+ char buf[5];
+ my_strcpy(buf, "test");
+ return 0;
+}
--- /dev/null
+// This test makes sure that a non-NT pointer can't access that last zero.
+
+// KEEP baseline: success
+
+void my_strncpy(short * COUNT(4) NT dest, const short * NTS NONNULL src)
+{
+ short *tmp = dest;
+ short *src2 = src; // KEEP baseline
+ short *src2 = NTDROP(src); // KEEP error1: error = Assertion
+
+ while ((*tmp = *src2) != '\0') {
+ tmp++;
+ src2++;
+ }
+}
+
+int main() {
+ short (NT buf)[5];
+ short (NT src)[5] = { 1,2,3,4,0 };
+ my_strncpy(buf, src);
+ return 0;
+}
--- /dev/null
+
+#include "harness.h"
+
+struct fat {
+ int * SNT _e;
+ int * BND(__this, _e) _p;
+};
+
+int array[8] = { 0, 1, 2 };
+
+int main() {
+ struct fat t;
+
+ t._e = array+8; t._p = array; // KEEP sep : success
+ t = (struct fat){array + 8, array}; // KEEP bundle : success
+
+ return t._p[2] - 2;
+}
--- /dev/null
+// This file contains externally-defined symbols needed by test cases.
+
+int identity(int arg) { return arg; }
+
+// For extern1.
+char extern1buf[4] = "abc";
+
+char * /* COUNT(extern_count) */ extern_p = extern1buf;
+int extern_count = sizeof(extern1buf);
+
+//For nullterm7.
+const char not_really_there1[0];
+const char not_really_there2[0];
+
+
+//For abstract1
+//Just some functions that take and return pointers that abstract1 doesn't
+//know the layout of.
+extern void exit(int code);
+
+struct abstract{
+ int data;
+};
+static struct abstract private = {5};
+
+struct abstract* get_abstract() {
+ return &private;
+}
+
+void check_abstract(struct abstract* p) {
+ if (p != &private) exit(10);
+}
--- /dev/null
+// This test checks whether trusted casts to void work as expected.
+
+void foo(void * SAFE p) {
+}
+
+int main() {
+ int * SAFE p = 0;
+ foo(TC(p));
+ return 0;
+}
--- /dev/null
+// KEEP baseline: success
+
+#include "harness.h"
+
+//Tests for mixing auto with trusted blocks. For each case when auto can
+//occur, make sure trusted code doesn't assign to auto lvalues.
+
+int * globSafe;
+int * EFAT globSeq;
+
+
+struct test {
+ int* fieldSafe;
+ int* FAT fieldSeq;
+};
+
+//Trusted functions behave the same as trusted blocks, (except that the types
+//of locals are also trusted.)
+void structtest(struct test* p) TRUSTED {
+ p->fieldSafe = (int * SAFE) 10;
+ p->fieldSafe = (int * SAFE) p->fieldSeq;
+ p->fieldSeq = (int * SAFE) 10; // KEEP struct: error = Trusted code assigns to
+ p->fieldSafe = &p->fieldSafe;
+ p->fieldSafe = &p->fieldSeq; //KEEP struct2: error = In trusted code, you may not take the address
+}
+
+//We support auto bounds in the formals of trusted functions. This follows
+//from the general rule that trusted functions can read
+void formalTest(int* SAFE p, int * FAT q) TRUSTED {
+
+ if (p != q) exit(-1);
+
+ p = (int * SAFE) 10;
+ p = q;
+ q = (int * SAFE) 10; // KEEP formal: error = Trusted block assigns to "q"
+ p = &p;
+ p = &q; //KEEP formal2: error = address of a formal
+
+ //From trusted code, it's not okay to call a function with auto bounds in
+ //its formals.
+ if (p != 0) formalTest(0,q); //KEEP badcall: error = Calling function formalTest from trusted code
+}
+
+int main() {
+ int * SAFE p;
+ int * FAT q = 0;
+ { TRUSTEDBLOCK
+ p = (int * SAFE) 10;
+ p = q;
+ q = (int * SAFE) 10; // KEEP local: error = Trusted block assigns to "q"
+ p = &p;
+ p = &q; //KEEP local2: error = In trusted code, you may not take the address of
+ }
+ { TRUSTEDBLOCK
+ globSafe = (int * SAFE) 10;
+ globSafe = globSeq;
+ globSeq = (int * SAFE)10; //KEEP global: error = Trusted code assigns to "globSeq
+ p = &globSafe;
+ p = &globSeq; //KEEP global2: error = In trusted code, you may not take the address of
+ }
+ { TRUSTEDBLOCK
+ int * SAFE * SAFE pp = malloc(sizeof(*pp));
+ int * FAT * SAFE qq = malloc(sizeof(*qq));
+
+ *pp = (int * SAFE) 10;
+ *pp = *qq;
+ *qq = (int * SAFE)10; //KEEP memory: error
+ }
+ struct test local;
+ structtest(&local);
+ formalTest(0,q);
+ return 0;
+}
+
+
+//Trusted code should also not return fat values.
+int * FAT returnTest(int * FAT p) {
+ if (!p) { TRUSTEDBLOCK return 0; } //KEEP return: error = Trusted block contains return of fat type
+ return p;
+}
--- /dev/null
+char (NT ntbuf)[10];
+int main() {
+ char* NT COUNT(9) p = ntbuf;
+ char* COUNT(10) q;
+ char* z = 0;
+ { TRUSTEDBLOCK
+ q = p;
+ //Inference should not see the ++. If it does, z will get auto bounds,
+ //and this assignment will be illegal in the trusted block.
+ z++;
+ }
+ q[9] = 'a';
+ return 0;
+}
--- /dev/null
+// This test ensures that we don't get the "trusted cast" warning due to
+// temporaries introduced by function calls. See the line where alloc()
+// is called in main().
+
+struct foo {
+ int a;
+ int *p;
+};
+
+char buf[8];
+
+void * TRUSTED alloc() {
+ return buf;
+}
+
+int main() {
+ struct foo * SAFE p = alloc();
+ int i = 42;
+
+ p->a = 42;
+ p->p = &i;
+
+ return (*p->p - p->a);
+}
--- /dev/null
+int cmp_ex(const void *SAFE a, const void *SAFE b) {
+ const struct exception_table_entry *SAFE x = TC(a), *SAFE y = TC(b);
+ return (x != y);
+}
+
+int main() {
+ return cmp_ex(0, 0);
+}
--- /dev/null
+struct foo {
+ int * SAFE a;
+ int * SAFE b;
+};
+
+int main() {
+ int i = 2;
+ int j = 3;
+
+ struct foo f;
+ f.a = &i;
+ f.b = &j;
+
+ void * SAFE p = TC(&f);
+ struct foo * SAFE q = TC(p);
+
+ return (*q->a + *q->b == 5) ? 0 : 1;
+}
--- /dev/null
+// This test checks for a bug where the optimizer tried to get the bounds
+// of an unsigned long (and failed, obviously).
+
+int main() {
+ unsigned long l = 0;
+ int * FAT p = TC(l);
+}
--- /dev/null
+
+// Test TRUSTED functions
+
+int* global = 0;
+
+void bad1(int a, int *b, int *c) TRUSTED {
+ global = a;
+}
+
+void (TRUSTED bad2) (int a, int *b, int *c) {
+ global = a;
+}
+
+
+// a K&R declaration. Currently, this won't parse if the return type
+// is omitted.
+void (TRUSTED old_bad) (a, b, c)
+ int a, * c;
+ int *b;
+{
+ global = a;
+}
+
+int main() { return 0; }
--- /dev/null
+// Shows trusted cast problem resulting from disappearing trusted cast.
+
+typedef struct node {
+ int *next;
+} *nodeptr;
+
+typedef struct cell {
+ int stuff;
+} *cellptr;
+
+int main() {
+ nodeptr p = 0;
+ cellptr FAT c = TC(p);
+ return 0;
+}
--- /dev/null
+int main() {
+ char * NT EFAT p = "test";
+ char * FAT q = TC(NTDROP(p)) - 1;
+ return 0;
+}
--- /dev/null
+// Make sure we check the target of a trusted cast for full annotations.
+
+int main() {
+ int a[2] = { 0, 42 };
+ int * SAFE p = a;
+
+ // Make sure LHS is annotated on trusted casts.
+ int * q = a; // KEEP baseline: success
+ int * q = TC(p); // KEEP t1: error = Target "q" of trusted cast
+ int * COUNT(2) q = (int *) TC(p); // KEEP t2: error = Target of trusted cast
+
+ // It's okay if the LHS is trusted but otherwise unannotated.
+ int * TRUSTED r = TC(p);
+ int * COUNT(2) s = (int * TRUSTED) TC(p);
+
+ // Self-assignment used to introduce temporaries with no annotations.
+ // Make sure this doesn't cause any mysterious errors.
+ int * SAFE t = 0;
+ t = TC(t);
+
+ return (q[1] == 42) ? 0 : 1;
+}
--- /dev/null
+// Test TC on functions.
+
+int foo(int x) {
+ return x;
+}
+
+typedef int (* SAFE fptr)(int);
+
+int main() {
+ fptr p = TC(foo);
+ int * SAFE p = TC(foo);
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+struct foo {
+ int len;
+ char (TRUSTED blah)[];
+};
+
+int main() {
+ struct foo* SAFE f;
+ f = malloc(sizeof(struct foo) + 10);
+ f->len = 10;
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+// This seems to become SAFE. Instead we should unroll the typedef where
+// it is used, thus allowing the pointer to become bounded
+typedef int * intptr;
+
+
+TESTDEF default : success
+
+
+int main() {
+ int array[8];
+ int i;
+
+IFTEST test1 : success
+ intptr p;
+ELSE
+ int * p;
+ENDIF
+
+ for(p=array; p<array + 8; p++) {
+ *p = 0;
+ }
+
+IFTEST test2 : success
+ p = (intptr)malloc(5 * sizeof(int));
+ELSE
+ p = (int *)malloc(5 * sizeof(int));
+ENDIF
+
+ p ++; p ++;
+
+ return 0;
+}
--- /dev/null
+
+
+typedef int vector[3];
+
+// When we pass arrays as arguments, CIL turns them into pointers
+// Because they are not annotated, they appear as SAFE pointers !!
+void foo(vector v) {
+ v[0] = 0; v[1] = 1; v[2] = 2;
+
+}
+
+int main() {
+ vector v;
+
+ v[0] = 0;
+ v[1] = 1;
+ v[2] = 2;
+
+ foo(v);
+
+ return 0;
+}
+
--- /dev/null
+struct st {
+ int *COUNT(len) p;
+ int len;
+};
+
+int main() {
+ int a[10];
+
+ struct st s;
+ s.len = 10;
+ s.p = a;
+
+ a[9] = 42;
+
+ typeof(s.p) q = s.p;
+ return (q[9] == 42) ? 0 : 1;
+}
--- /dev/null
+//This test should fail
+//KEEP baseline: error = variable q depends on names that are not in scope
+
+int main() {
+ int * SAFE r = 0;
+ int * BND(r,r) * SAFE q = 0;
+
+ return 0;
+}
--- /dev/null
+struct foo {
+ int * BND(b,e) p;
+ int * BND(b,b) b;
+ int * BND(e,e) e;
+};
+
+int main() {
+ struct foo * SAFE f = 0;
+ return 0;
+}
--- /dev/null
+struct foo {
+ int * SAFE p;
+};
+
+int main() {
+ struct foo * SAFE f = 0;
+ return 0;
+}
--- /dev/null
+//This test should fail
+//KEEP baseline: error = field p of struct foo depends on names that are not in scope
+
+struct foo {
+ int * BND(b,e) p;
+};
+
+int main() {
+ struct foo * SAFE f = 0;
+ return 0;
+}
--- /dev/null
+typedef int * SAFE foo;
+
+int main() {
+ int i;
+ foo f = &i;
+ return 0;
+}
--- /dev/null
+//This test should fail
+// When using interprocedural inference, the typedef is unrolled, so we
+// get a different error. was: Type of typedef foo is ill-formed
+//KEEP baseline: error = Error: Type of
+
+typedef int * BND(b,e) foo;
+
+int main() {
+ int i;
+ foo f = &i;
+ return 0;
+}
--- /dev/null
+struct foo {
+ void (* SAFE fn1)(int * COUNT(len) buf, int len);
+ void (* SAFE fn2)(int * SAFE p);
+};
+
+int main() {
+ struct foo * SAFE f = 0;
+ return 0;
+}
--- /dev/null
+// This test checks that we correctly optimize away arithmetic on
+// pointers to opaque types. Otherwise, the compiler will complain
+// that it doesn't know how to perform that arithmetic.
+
+struct foo1;
+
+struct foo2 {
+ struct foo1 * SAFE p;
+};
+
+void bar(struct foo1 * SAFE p) {
+}
+
+int main() {
+ struct foo1 * SAFE p1;
+ struct foo2 * SAFE p2;
+ struct foo2 f;
+
+ p1 = 0;
+
+ p2 = &f;
+ f.p = 0;
+
+ bar(p1);
+ bar(p2->p);
+
+ return 0;
+}
--- /dev/null
+typedef int fun(void);
+
+int foo() {
+ return 0;
+}
+
+int main() {
+ fun *fp;
+ int n;
+
+ fp = &foo;
+ n = fp();
+
+ return n;
+}
--- /dev/null
+//KEEP baseline: success
+
+#include "harness.h"
+
+#define CLEARUNION(u) memset(&u, 0, sizeof(u))
+
+ union bar {
+ int anint WHEN(tag == 2);
+ int * SAFE ptrint WHEN(tag > 2);
+ float afloat WHEN(buf != 0);
+ };
+struct host {
+ int tag; // 0 for integer, 1 for int*
+
+ union bar u;
+
+ int* COUNT(tag) buf; //Another dependency on tag.
+};
+
+
+struct host global;
+int gint;
+
+//Test for union as a local
+void local() {
+ int tag;
+ union bar u;
+ int* COUNT(tag) buf = 0; //Another dependency on tag.
+
+ //If we don't clear the union with memset, we will have to notice
+ //that "u.anint = 2" is also an initialization of the union.
+ CLEARUNION(u); //KEEP noinit: success
+ tag = 2;
+
+ u.anint = 2;
+
+ int x = u.anint;
+
+ // I added a special case for memset to allow taking the address of
+ // dependent stuff. Make sure we check for external dependencies:
+ CLEARUNION(tag); //KEEP addrof: error = address of lval
+
+ u.anint -= x; //set to 0
+ tag = 3;
+ u.ptrint = &gint;
+
+ u.ptrint = 0;
+ tag = 1;
+ buf = &gint;
+ u.afloat = 3.14159;
+}
+
+//Test for union in a struct.
+int main() {
+ global.buf = 0;
+
+ global.tag = 2;
+
+ global.u.anint = 2;
+
+ int x = global.u.anint;
+
+ global.u.anint -= x; //set to 0
+ global.tag = 3;
+ global.u.ptrint = &gint;
+
+ global.u.ptrint = 0;
+ CLEARUNION(global.u);
+
+ global.tag = 1;
+ global.buf = &gint;
+ global.u.afloat = 3.14159;
+
+ local();
+
+ return 0;
+}
--- /dev/null
+//no pointers? then no WHEN clause is needed.
+//This is from the CCured regression suite
+
+extern int printf(const char * NTS format, ...);
+extern void exit(int);
+/* Always call E with a non-zero number */
+#define E(n) { printf("Error %d\n", n); exit(n); }
+
+
+typedef unsigned long ULONG;
+typedef long LONG;
+#ifdef _GNUCC
+typedef long long LONGLONG;
+#else
+typedef __int64 LONGLONG;
+#endif
+
+typedef union _LARGE_INTEGER {
+ struct {
+ ULONG LowPart;
+ LONG HighPart;
+ };
+ struct {
+ ULONG LowPart;
+ LONG HighPart;
+ } u;
+ LONGLONG QuadPart;
+} LARGE_INTEGER;
+
+
+int main() {
+ LARGE_INTEGER foo;
+
+ foo.LowPart = 3;
+ foo.HighPart = 7;
+
+ if (foo.u.LowPart != 3) {
+ E(1);
+ }
+ if (foo.u.HighPart != 7) {
+ E(2);
+ }
+
+ return 0;
+}
--- /dev/null
+//This file is from the CCured regression suite.
+//KEEP baseline: success
+
+#include "harness.h"
+
+#define CLEARUNION(u) memset(&u, 0, sizeof(u))
+
+enum tags {
+ TAG_ZERO = 0,
+};
+
+struct host {
+ int tag; // 0 for integer, 1 for int*, 2 for structure, 3 if tag2 choses
+ char tag2; //If tag is 3, then 0 for int, 1 for int*
+
+ union bar {
+ int anint WHEN(tag == TAG_ZERO);
+ int * ptrint WHEN(tag == 1);
+ struct str {
+ int * * ptrptr;
+ } ptrptr
+ /* missing WHEN */ // KEEP e1: error = Missing WHEN
+ WHEN(tag_bad == 5) // KEEP e2: error = Field ptrptr of union bar depends on names that are not in scope
+ WHEN(tag == 5) WHEN(tag == 6) // KEEP e3: error = more than one WHEN
+IFNTEST e1
+IFNTEST e2
+IFNTEST e3
+ WHEN(tag == 5)
+ENDIF
+ENDIF
+ENDIF
+ ;
+ int *disj WHEN(tag == 10 || tag == 11);
+ int *conj WHEN(tag >= 15 && tag <= 17);
+
+ int int2 WHEN(tag == 3 && tag2 == 0);
+ int * ptr2 WHEN(tag == 3 && tag2 == 1);
+ int unprotected; //needs no WHEN clause.
+ } data;
+
+ //A second union that uses the same tags.
+ union foo {
+ int fooint WHEN(!(tag & 1));
+ int * fooptrint WHEN(tag & 1);
+ } data2;
+
+ struct {
+ int x;
+ } somethingelse;
+} g;
+
+
+int x;
+int * px = &x;
+
+int one() { return 1; }
+
+int main() {
+
+ g.tag = 0;
+
+ // This is good behavior
+
+IFTEST baseline
+ g.data.anint = 5;
+ x = g.data.anint;
+ CLEARUNION(g.data);
+
+ g.tag = 1;
+ g.data2.fooptrint = px;
+ px = g.data2.fooptrint;
+ CLEARUNION(g.data2);
+
+ g.tag = 5;
+ g.data.ptrptr.ptrptr = &px;
+ x = * * g.data.ptrptr.ptrptr;
+ CLEARUNION(g.data);
+
+ g.tag = 3; g.tag2 = 1;
+ g.data.ptr2 = px;
+ px = g.data.ptr2;
+
+ // This is allowed because we are not reading a pointer
+ x = g.data.unprotected;
+
+ // We can take the address of a non-discriminated field
+ px = & g.somethingelse.x;
+
+ CLEARUNION(g.data);
+ g.tag = 10; px = g.data.disj;
+ g.tag = 11; px = g.data.disj;
+
+ CLEARUNION(g.data);
+ g.tag = 15;px = g.data.conj;
+ g.tag = 16;px = g.data.conj;
+ELSE
+
+ CLEARUNION(g.data);
+
+ // We cannot access pointers when the tag is wrong
+ g.tag = 0; x = g.data.ptrint; // KEEP e4: error = will always fail
+ g.tag = 0; *g.data.ptrptr.ptrptr = px; // KEEP e5: error = will always fail
+ g.tag = 0; { struct str s = g.data.ptrptr; } // KEEP e6: error = will always fail
+
+ px = & g.data.anint; // KEEP e7: error = address of a union field
+ // We cannot take the address of a field in a subfield
+ { int * * * a = & g.data.ptrptr.ptrptr; } // KEEP e8: error = address of a union field
+
+ g.tag = 12;px = g.data.disj; // KEEP e9: error = will always fail
+
+ g.tag = 10;px = g.data.conj; // KEEP e10: error = will always fail
+ g.tag = 18;px = g.data.conj; // KEEP e11: error = will always fail
+
+ //Don't allow changes to the tag.
+ g.tag = 0; g.data.anint = 42; g.tag = 1; //KEEP e12: error = Assertion
+ENDIF
+
+ return 0;
+}
+
--- /dev/null
+//This is roughly union1.c, with a trusted annotation instead of WHENs.
+
+//KEEP baseline: success
+#include "harness.h"
+
+ union TRUSTED bar {
+ int anint;
+ int * SAFE ptrint;
+ float afloat;
+ } u ;
+struct host {
+ int tag; // 0 for integer, 1 for int*
+
+ union bar u;
+
+ int* COUNT(tag) buf; //Another dependency on tag.
+};
+
+
+struct host global;
+int gint;
+
+//Test for union as a local
+void local() {
+ int tag;
+ union bar u;
+ int* buf = 0;
+
+ u.anint = 2;
+ tag = 2;
+
+ tag = 3;
+ u.ptrint = &gint;
+
+ u.ptrint = 0;
+ tag = 1;
+ u.ptrint = &u.anint;
+ if (u.ptrint != &u.ptrint) E(1);
+ u.afloat += 3.14159;
+}
+
+//Test for union in a struct.
+int main() {
+ global.u.anint = 2;
+
+ global.tag = 3;
+ global.u.ptrint = &gint;
+
+ global.u.ptrint = 0;
+
+ global.tag = 1;
+ global.buf = &gint;
+ global.u.afloat = 3.14159;
+
+ local();
+
+ return 0;
+}
--- /dev/null
+//KEEP baseline: success
+
+//Example from the spec95 Lisp interpreter: change a union tag to
+// an equivalent one without zeroing the union.
+
+#include "harness.h"
+#include <string.h> //memset
+
+typedef struct file FILE;
+
+/* node types */
+#define FREE 0
+#define SUBR 1
+#define FSUBR 2
+#define LIST 3
+#define SYM 4
+#define INT 5
+#define STR 6
+#define OBJ 7
+#define FPTR 8
+#define FLOAT 9
+#define VECT 10
+
+/* node flags */
+#define MARK 1
+#define LEFT 2
+
+/* string types */
+#define DYNAMIC 0
+#define STATIC 1
+
+/* new node access macros */
+#define ntype(x) ((x)->n_type)
+
+/* type predicates */
+#define atom(x) ((x) == NIL || (x)->n_type != LIST)
+#define null(x) ((x) == NIL)
+#define listp(x) ((x) == NIL || (x)->n_type == LIST)
+#define consp(x) ((x) && (x)->n_type == LIST)
+#define subrp(x) ((x) && (x)->n_type == SUBR)
+#define fsubrp(x) ((x) && (x)->n_type == FSUBR)
+#define stringp(x) ((x) && (x)->n_type == STR)
+#define symbolp(x) ((x) && (x)->n_type == SYM)
+#define filep(x) ((x) && (x)->n_type == FPTR)
+#define objectp(x) ((x) && (x)->n_type == OBJ)
+#define fixp(x) ((x) && (x)->n_type == INT)
+#define floatp(x) ((x) && (x)->n_type == FLOAT)
+#define vectorp(x) ((x) && (x)->n_type == VECT)
+
+typedef struct node {
+ char n_type; /* type of node */
+ char n_flags; /* flag bits */
+ union { /* value */
+ struct xsubr { /* subr/fsubr node */
+ /* WEIMER struct node *(*xsu_subr)(); pointer to an internal routine */
+ struct node *(*xsu_subr)(struct node *);
+ } n_xsubr WHEN(n_type == SUBR || n_type == FSUBR);
+ struct xlist { /* list node (cons) or symbol, too */
+ struct node *xl_car; /* the car pointer */
+ struct node *xl_cdr; /* the cdr pointer */
+ } n_xlist WHEN(n_type == LIST || n_type == SYM || n_type == FREE);
+ struct xint { /* integer node */
+ long xi_int; /* integer value */
+ } n_xint WHEN(n_type == INT);
+ struct xfloat { /* float node */
+ double xf_float; /* float value */
+ } n_xfloat WHEN(n_type == FLOAT
+ || n_type == VECT //KEEP notexclusive: error = Warning: Setting this tag makes two fields active
+ );
+ struct xstr { /* string node */
+ int xst_type; /* string type */
+ char * NTS xst_str; /* string pointer */
+ } n_xstr WHEN(n_type == STR);
+ struct xfptr { /* file pointer node */
+ FILE *xf_fp; /* the file pointer */
+ int xf_savech; /* lookahead character for input files */
+ } n_xfptr WHEN(n_type == FPTR);
+ struct xvect { /* vector node */
+ int xv_size; /* vector size */
+ struct node ** COUNT(xv_size) xv_data; /* vector data */
+ } n_xvect WHEN(n_type == VECT || n_type == OBJ);
+ } n_info ;
+} NODE;
+
+/* newnode - allocate a new node */
+NODE *newnode(int type)
+{
+ NODE * nnode = malloc(sizeof(NODE));
+
+ /* initialize the new node */
+ memset(&nnode->n_info, 0, sizeof(nnode->n_info));
+ nnode->n_type = type;
+
+ /* return the new node */
+ return (nnode);
+}
+
+//Test for union in a struct.
+int main() {
+ NODE * obj = newnode(VECT);
+ NODE ** data = malloc(4 * sizeof(NODE*));
+ obj->n_info.n_xvect.xv_size = 4;
+ obj->n_info.n_xvect.xv_data = data;
+
+ //Now change the type to obj:
+ obj->n_type = OBJ; //KEEP difftag: success
+
+ obj->n_type = STR; //KEEP wrongtag: error = Assertion failed
+
+ if (obj->n_info.n_xvect.xv_data != data) E(1);
+
+ //And change it back:
+ obj->n_type = VECT+256; //the +256 goes away because n_type is a char.
+
+ if (obj->n_info.n_xvect.xv_data != data) E(2);
+ return 0;
+}
--- /dev/null
+
+union u {
+ struct {
+ int x,y,z;
+ } a;
+ struct {
+ int m[3];
+ } b;
+};
+
+int main() {
+ union u u;
+ int t = 0;
+ u.a.x = 1;
+ u.b.m[2] = 2;
+ t = u.a.x + u.b.m[2];
+ return (t == 3) ? 0 : 1;
+}
--- /dev/null
+// KEEP baseline: success
+
+struct foo {
+ int *p;
+ int a;
+};
+
+struct bar {
+ struct foo f;
+ int *q;
+ int b;
+};
+
+int main() {
+ struct bar b;
+ struct bar *bp1 = &b;
+ struct foo *fp1 = (struct foo *) bp1;
+
+ struct bar *bp2 = 0;
+ struct foo *fp2 = (struct foo *) bp2;
+
+ struct bar b3[2];
+ struct bar * COUNT(2) bp3 = b3;
+ struct foo * COUNT(2) fp3 = (struct foo * SAFE) bp3; // KEEP e1: error = will always fail
+ struct foo * COUNT(2) fp3 = (struct foo * COUNT(2)) bp3; // KEEP e2: error = will always fail
+
+ b.f.a = 0;
+ return fp1->a;
+}
--- /dev/null
+// Need to make sure that upcasts don't take priority over more
+// appropriate casts.
+
+#include "harness.h"
+
+struct tcphdr {
+ int a; // KEEP t1: success
+ short a; // KEEP t2: success
+ int b;
+};
+
+void *get() {
+ return malloc(sizeof(struct tcphdr));
+}
+
+int main() {
+ struct tcphdr *th = (struct tcphdr * SAFE) TC(get());
+ *(((short *)th) + 1) = 0;
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+void foo(int * BND(p, q) p, int * BND(q, q) q) {
+ p = p + 1;
+}
+
+int main() {
+ int * BND(__this, __this+2) p = alloc(int, 2);
+ foo(p,p+2);
+ return 0;
+}
--- /dev/null
+// KEEP baseline: success
+
+#include "harness.h"
+
+void foo(int * SAFE p) {
+ p = p + 1; // KEEP size1: error = will always fail
+}
+
+int main() {
+ int * SAFE p = alloc(int, 1);
+ foo(p);
+ return 0;
+}
--- /dev/null
+// KEEP baseline: success
+
+#include "harness.h"
+
+void foo(int * COUNT(2) p) {
+ p = p + 1; // KEEP size1: error = will always fail
+}
+
+int main() {
+ int * COUNT(2) p = alloc(int, 2);
+ foo(p);
+ return 0;
+}
--- /dev/null
+// KEEP baseline: success
+
+#include "harness.h"
+
+int ten() {
+ return 10;
+}
+
+int main() {
+ int len = 5;
+ int * COUNT(len) p = 0;
+ //p is 0, so we can change len here
+ len = 8; //KEEP dep1: success
+
+ p = alloc(int, len);
+ p++; //KEEP incr: error
+ //Can't increase the length here:
+ len = 10; //KEEP dep2: error
+ // or here:
+ len = ten(); //KEEP dep3: error
+ //but decreasing is okay:
+ len--;
+ return *p; //use p so that it's live
+}
--- /dev/null
+void foo(int * SAFE p) {
+ // int * p = p; Not legal code
+ *p = 0;
+}
+
+int main() {
+ int a;
+ foo(&a);
+ return 0;
+}
--- /dev/null
+// This test checks for a bug where non-NT char* arguments to printf were
+// automatically converted to NT.
+
+#include "harness.h"
+
+struct sk_buff {
+ unsigned char * COUNT(0) head;
+};
+
+void skb_over_panic(struct sk_buff *skb) {
+ printf("%p\n", skb->head);
+}
+
+int main() {
+ struct sk_buff skb;
+ skb_over_panic(&skb);
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+char * NT COUNT(49) x;
+char * COUNT(50) y;
+
+//Don't let the NT spread through the return type of malloc from to x and y.
+int main() {
+ x = malloc(50);
+ y = malloc(50);
+ return 0;
+}
--- /dev/null
+#include "harness.h"
+
+int *SAFE * COUNT(5) global;
+
+void foo() {
+ void * tmp = malloc(sizeof(*global) * 5);
+ global = tmp;
+}
+
+//Infer that the void* in the cast should be "int *SAFE * COUNT(5)."
+void bar() {
+ int *SAFE * COUNT(5) local = malloc(sizeof(*local) * 5);
+ global = (void*) local;
+}
+
+int main() {
+ foo();
+ bar();
+ return 0;
+}
--- /dev/null
+// Make sure that we don't spread function dependencies to arguments.
+
+void foo(char * COUNT(len) buf, int len) {
+}
+
+int main(void)
+{
+ void *tmp = 0;
+ foo(tmp, 5);
+ return 0;
+}
--- /dev/null
+#include <stdlib.h>
+#include "harness.h"
+
+//Bug 34. From TinyOS
+
+//Don't propagate volatile expressions.
+//We don't want to change this to
+// while (*82 == *82);
+//which will loop forever.
+void foo() {
+ char now = (int) * (volatile char* SAFE )TC(82U);
+ while ( (*(volatile char* SAFE )TC(82U))
+ == now) ;
+}
+
+//This is one uggggly hack. The only way I can think of to test this bug
+//in a single-threaded app is to grep through the output.
+
+int main() {
+ int x = system("grep '^ while.*now' volatile1-tmp.cil.c");
+ if (x != 0) {
+ printf("Error: grep returned %d\n", x);
+ exit(1);
+ }
+ return 0;
+}
+
--- /dev/null
+#!/bin/sh
+eval 'exec perl -S ./testdeputy.pl ${1+"$@"}'
+ if 0;
--- /dev/null
+require 5.000;
+use strict;
+
+use FindBin;
+use lib "$FindBin::Bin/../cil/ocamlutil";
+
+use RegTest;
+
+$ENV{LANG} = 'C';
+
+print "Test infrastructure for Deputy\n";
+
+# Create our customized test harness
+my $test = RegTest->new(AvailParams => { 'SUCCESS' => 0,
+ 'RUN' => 1, # Numeric
+ 'MEM' => 1 },
+ LogFile => "deputy.log",
+ CommandName => "testdeputy");
+
+# am I on win32?
+my $win32 = ($^O eq 'MSWin32' || $^O eq 'cygwin');
+my $unix = !$win32;
+my $linux = $^O eq 'linux';
+my $solaris = $^O eq 'solaris';
+
+my $make;
+if ($solaris) {
+ $make = "gmake";
+} else {
+ $make = "make";
+}
+
+# Start with a few tests that must be run first
+$test->newTest(
+ Name => "!inittests0",
+ Dir => "..",
+ Cmd => "$make",
+ Group => ['ALWAYS']);
+
+my %commonerrors =
+ (
+# We are seeing an error from make. Try to classify it based on the stage
+# in which we are
+ "^make: \\*\\*\\*" =>
+ sub {
+ if($_[1]->{ErrorCode} == 0) {
+ my $err = defined $_[1]->{instage} > 0 ? $_[1]->{instage} : 1;
+ $_[1]->{ErrorCode} = $err;
+ }},
+
+ # Collect some more parameters
+ # Now error messages
+ "^((Error|Bug|Unimplemented): .+)\$"
+ => sub { if(! defined $_[1]->{ErrorMsg}) {
+ $_[1]->{ErrorMsg} = $_[2];} },
+ "^(.+ : error .+)\$" => sub { if(! defined $_[1]->{ErrorMsg}) {
+ $_[1]->{ErrorMsg} = $_[2];} },
+ "^(.+:\\d+: (Error|Unimplemented|Internal error):.+)\$"
+ => sub { if(! defined $_[1]->{ErrorMsg}) {
+ $_[1]->{ErrorMsg} = $_[2];} },
+ "^(.+: fatal error.+)\$" => sub { if(! defined $_[1]->{ErrorMsg}) {
+ $_[1]->{ErrorMsg} = $_[2];} },
+ "^(.+: Assertion failed in.+)\$" => sub { if(! defined $_[1]->{ErrorMsg}) {
+ $_[1]->{ErrorMsg} = $_[2];} },
+ "^(stackdump: Dumping stack trace)" =>
+ sub { if(! defined $_[1]->{ErrorMsg}) {
+ $_[1]->{ErrorMsg} = $_[2];} },
+ "^(Cannot find .* in output of .*) at " =>
+ sub { if(! defined $_[1]->{ErrorMsg}) {
+ $_[1]->{ErrorMsg} = $_[2];} },
+
+# Running time measurements
+ "^user\\s+(\\d+)m([\\d.]+)s"
+ => sub { $_[1]->{RUN} = 60 * $_[2] + $_[3]; },
+
+ );
+
+
+# Deputy tests
+# First argument is a command (one word test name followed by arguments for
+# make)
+sub addDeputyTest {
+ my($command, %extrafields) = @_;
+
+ my ($name, $extraargs) =
+ ($command =~ /^(\S+) ?(.*)$/); # name is first word
+
+ # Make a local copy of the hash
+ my %patterns = %commonerrors;
+ my $tst =
+ $test->newTest(Name => $name,
+ Dir => ".",
+ Cmd => "$make " . $name . " " . $extraargs,
+ Group => [ ],
+ Patterns => \%patterns);
+
+
+ # Add the extra fields
+ my $key;
+ foreach $key (keys %extrafields) {
+ $tst->{$key} = $extrafields{$key};
+ }
+ return $tst;
+}
+
+addDeputyTest("small/abstract1");
+
+addDeputyTest("small/addrof1");
+addDeputyTest("small/addrof2");
+addDeputyTest("small/addrof3");
+addDeputyTest("small/addrof4");
+addDeputyTest("small/addrof5");
+addDeputyTest("small/addrof6");
+addDeputyTest("small/addrof7");
+
+addDeputyTest("small/align1");
+addDeputyTest("small/align2",
+ Comm=>"Unsound handling of upper bounds in NT pointers");
+
+addDeputyTest("small/alloc1");
+addDeputyTest("small/alloc2");
+addDeputyTest("small/alloc3");
+addDeputyTest("small/alloc4");
+addDeputyTest("small/alloc5");
+addDeputyTest("small/alloc6");
+addDeputyTest("small/alloc7");
+addDeputyTest("small/alloc8");
+addDeputyTest("small/alloc9");
+addDeputyTest("small/alloc10");
+addDeputyTest("small/alloc11");
+addDeputyTest("small/alloc12");
+
+addDeputyTest("small/array1");
+addDeputyTest("small/array2");
+addDeputyTest("small/array3");
+addDeputyTest("small/array4");
+addDeputyTest("small/array5");
+addDeputyTest("small/array6");
+addDeputyTest("small/array7");
+
+addDeputyTest("small/auto1");
+addDeputyTest("small/auto2");
+addDeputyTest("small/auto3");
+addDeputyTest("small/auto4",
+ Comm => "Better error messages for illegal auto use. Bug 41.");
+addDeputyTest("small/auto5");
+addDeputyTest("small/auto6");
+addDeputyTest("small/auto7");
+addDeputyTest("small/auto8");
+addDeputyTest("small/auto9");
+
+addDeputyTest("small/bound1");
+
+addDeputyTest("small/builtin1");
+
+addDeputyTest("small/call1");
+addDeputyTest("small/call2");
+addDeputyTest("small/call3");
+addDeputyTest("small/call4");
+addDeputyTest("small/call5");
+addDeputyTest("small/call6");
+addDeputyTest("small/call7");
+addDeputyTest("small/call8",
+ Comm => "Better checking for args in ret type. Bug 46.");
+
+addDeputyTest("small/cast1");
+addDeputyTest("small/cast2");
+addDeputyTest("small/cast3");
+addDeputyTest("small/cast4");
+addDeputyTest("small/cast5");
+addDeputyTest("small/cast6");
+addDeputyTest("small/cast7");
+addDeputyTest("small/cast8");
+addDeputyTest("small/cast9");
+addDeputyTest("small/cast10");
+addDeputyTest("small/cast11");
+addDeputyTest("small/cast12");
+addDeputyTest("small/cast13");
+addDeputyTest("small/cast14");
+addDeputyTest("small/cast15",
+ Comm => "Physical sutyping. Bug 5");
+addDeputyTest("small/cast16",
+ Comm => "Rmunused removes meta variables. Low priority");
+addDeputyTest("small/cast17");
+addDeputyTest("small/cast18");
+addDeputyTest("small/cast19",
+ Comm => "Need nice error message for ptr -> struct cast.");
+addDeputyTest("small/cast20");
+
+addDeputyTest("small/deref1");
+addDeputyTest("small/deref2");
+addDeputyTest("small/deref3");
+
+addDeputyTest("small/enum1");
+
+addDeputyTest("small/extern1");
+addDeputyTest("small/extern2");
+addDeputyTest("small/extern3");
+
+addDeputyTest("small/extinline1");
+
+addDeputyTest("small/field1");
+addDeputyTest("small/field2");
+addDeputyTest("small/field3");
+addDeputyTest("small/field4");
+addDeputyTest("small/field5");
+
+addDeputyTest("small/func1");
+addDeputyTest("small/func2");
+addDeputyTest("small/func3",
+ Comm => "Dependencies of function arguments on non-const globals");
+addDeputyTest("small/func4");
+addDeputyTest("small/func5");
+addDeputyTest("small/func6");
+addDeputyTest("small/func7");
+addDeputyTest("small/func8");
+addDeputyTest("small/func9");
+
+addDeputyTest("small/global1");
+addDeputyTest("small/global2");
+addDeputyTest("small/global3");
+addDeputyTest("small/global4");
+addDeputyTest("small/global5");
+addDeputyTest("small/global6");
+addDeputyTest("small/global7");
+addDeputyTest("small/global8");
+addDeputyTest("small/global9");
+
+addDeputyTest("small/incr1");
+
+addDeputyTest("small/infer1");
+addDeputyTest("small/infer2");
+addDeputyTest("small/infer3");
+addDeputyTest("small/infer4");
+addDeputyTest("small/infer5");
+addDeputyTest("small/infer6");
+addDeputyTest("small/infer7");
+addDeputyTest("small/infer8");
+addDeputyTest("small/infer9");
+addDeputyTest("small/infer10");
+addDeputyTest("small/infer11");
+addDeputyTest("small/infer12");
+addDeputyTest("small/infer13");
+addDeputyTest("small/infer14");
+addDeputyTest("small/infer15");
+addDeputyTest("small/infer16");
+addDeputyTest("small/infer17");
+addDeputyTest("small/infer18");
+addDeputyTest("small/infer19");
+
+addDeputyTest("small/init1");
+addDeputyTest("small/init2");
+
+addDeputyTest("small/live1");
+addDeputyTest("small/live2");
+addDeputyTest("small/live3");
+
+addDeputyTest("small/local1");
+
+addDeputyTest("small/memcmp1");
+addDeputyTest("small/memcmp2");
+addDeputyTest("small/memcpy1");
+addDeputyTest("small/memcpy2",
+ Comm=> ("when memcpy arg is cast to char*, ".
+ "we wrongly infer that as a SAFE ptr"));
+addDeputyTest("small/memset1");
+addDeputyTest("small/memset2");
+
+addDeputyTest("small/nonnull1");
+addDeputyTest("small/nonnull2");
+addDeputyTest("small/nonnull3");
+addDeputyTest("small/nonnull4");
+
+addDeputyTest("small/nullterm1");
+addDeputyTest("small/nullterm2");
+addDeputyTest("small/nullterm3");
+addDeputyTest("small/nullterm4");
+addDeputyTest("small/nullterm5");
+addDeputyTest("small/nullterm6");
+addDeputyTest("small/nullterm7");
+addDeputyTest("small/nullterm8");
+addDeputyTest("small/nullterm9",
+ Comm=> "Zero-length NT allocation shouldn't be allowed!");
+addDeputyTest("small/nullterm10");
+addDeputyTest("small/nullterm11");
+
+addDeputyTest("small/offset1");
+addDeputyTest("small/offset2");
+addDeputyTest("small/offset3");
+
+addDeputyTest("small/openarray1");
+addDeputyTest("small/openarray2",
+ Comm => "Nullterm open arrays");
+addDeputyTest("small/openarray3");
+addDeputyTest("small/openarray4");
+
+addDeputyTest("small/opt1");
+addDeputyTest("small/opt2");
+addDeputyTest("small/opt3");
+addDeputyTest("small/opt4");
+addDeputyTest("small/opt5");
+addDeputyTest("small/opt6");
+addDeputyTest("small/opt7 EXTRAARGS=-fwritable-strings",
+ Enabled=>0, Comm => "Not applicable to gcc4.");
+addDeputyTest("small/opt8");
+addDeputyTest("small/opt9");
+addDeputyTest("small/opt10");
+addDeputyTest("small/opt11");
+addDeputyTest("small/opt12");
+addDeputyTest("small/opt13");
+addDeputyTest("small/opt14");
+addDeputyTest("small/opt15");
+addDeputyTest("small/opt16");
+
+addDeputyTest("small/overflow1");
+addDeputyTest("small/overflow2",
+ Comm=>"Unsound! Overflow bug in optimization.");
+
+addDeputyTest("small/packed1");
+
+addDeputyTest("small/poly1");
+addDeputyTest("small/poly2",
+ Comm => "Need to handle temporaries with poly type.");
+addDeputyTest("small/poly3");
+addDeputyTest("small/poly4");
+addDeputyTest("small/poly5");
+addDeputyTest("small/poly6");
+addDeputyTest("small/poly7",
+ Comm => "Need to handle returns of poly type.");
+
+addDeputyTest("small/ptrarith1");
+addDeputyTest("small/ptrarith2");
+
+addDeputyTest("small/return1");
+
+addDeputyTest("small/sentinel1");
+addDeputyTest("small/sentinel2");
+
+addDeputyTest("small/size1");
+addDeputyTest("small/size2");
+addDeputyTest("small/size3");
+addDeputyTest("small/size4");
+
+addDeputyTest("small/sizeof1");
+addDeputyTest("small/sizeof2");
+addDeputyTest("small/sizeof3");
+
+addDeputyTest("small/startof1");
+addDeputyTest("small/startof2");
+
+addDeputyTest("small/string1");
+addDeputyTest("small/string2");
+addDeputyTest("small/string3");
+addDeputyTest("small/string4");
+addDeputyTest("small/string5");
+addDeputyTest("small/string6");
+addDeputyTest("small/string7");
+addDeputyTest("small/string8");
+addDeputyTest("small/string9");
+addDeputyTest("small/string10");
+addDeputyTest("small/string12");
+addDeputyTest("small/string13");
+addDeputyTest("small/string14");
+addDeputyTest("small/string15");
+addDeputyTest("small/string16");
+addDeputyTest("small/string18");
+addDeputyTest("small/string19");
+addDeputyTest("small/string20");
+addDeputyTest("small/string21",
+ Comm => "while (*s++) on nullterm pointer");
+
+addDeputyTest("small/struct1");
+
+addDeputyTest("small/trusted1");
+addDeputyTest("small/trusted2");
+addDeputyTest("small/trusted3");
+addDeputyTest("small/trusted4");
+addDeputyTest("small/trusted5");
+addDeputyTest("small/trusted6");
+addDeputyTest("small/trusted7");
+addDeputyTest("small/trusted8");
+addDeputyTest("small/trusted9",
+ Comm => "Trusted open arrays");
+addDeputyTest("small/trusted10");
+addDeputyTest("small/trusted11");
+addDeputyTest("small/trusted12");
+addDeputyTest("small/trusted13");
+
+addDeputyTest("small/typedef1");
+addDeputyTest("small/typedef2",
+ Comm => "Arrays changed to pointers in function arguments. Need count. Low priority");
+
+addDeputyTest("small/typeof1");
+
+addDeputyTest("small/types1");
+addDeputyTest("small/types2");
+addDeputyTest("small/types3");
+addDeputyTest("small/types4");
+addDeputyTest("small/types5");
+addDeputyTest("small/types6");
+addDeputyTest("small/types7");
+addDeputyTest("small/types8");
+addDeputyTest("small/types9");
+
+addDeputyTest("small/union1",
+ Comm=>"unsatisfied globalinit check -- we don't optimize unions well.");
+addDeputyTest("small/union2");
+addDeputyTest("small/union3");
+addDeputyTest("small/union4");
+addDeputyTest("small/union5");
+addDeputyTest("small/union6");
+
+addDeputyTest("small/upcast1");
+addDeputyTest("small/upcast2");
+
+addDeputyTest("small/var1");
+addDeputyTest("small/var2");
+addDeputyTest("small/var3");
+addDeputyTest("small/var4");
+addDeputyTest("small/var5");
+
+addDeputyTest("small/vararg1");
+
+addDeputyTest("small/voidstar1");
+addDeputyTest("small/voidstar2");
+
+addDeputyTest("small/voidstar4");
+
+addDeputyTest("small/volatile1");
+
+addDeputyTest("small/retbound1");
+
+# libc tests
+
+addDeputyTest("libc/crypt1 EXTRAARGS=-lcrypt");
+addDeputyTest("libc/ctype1");
+addDeputyTest("libc/fwrite1");
+addDeputyTest("libc/getpwnam1");
+addDeputyTest("libc/glob1");
+addDeputyTest("libc/hostent1");
+ # gethostent_r doesn't exist on Cygwin:
+addDeputyTest("libc/hostent2") if $linux;
+addDeputyTest("libc/malloc1");
+addDeputyTest("libc/malloc2");
+addDeputyTest("libc/memset1");
+addDeputyTest("libc/popen1");
+addDeputyTest("libc/printf1");
+addDeputyTest("libc/printf2");
+addDeputyTest("libc/readv1");
+addDeputyTest("libc/servent1");
+addDeputyTest("libc/servent2") if $linux;
+addDeputyTest("libc/stat1");
+addDeputyTest("libc/strchr1");
+addDeputyTest("libc/strcpy");
+addDeputyTest("libc/strerror1");
+addDeputyTest("libc/string1");
+addDeputyTest("libc/string2");
+addDeputyTest("libc/string3");
+addDeputyTest("libc/string4");
+addDeputyTest("libc/string5",
+ Comm => "old strings-david. Not yet ported?");
+
+addDeputyTest("libc/string6");
+addDeputyTest("libc/string7",
+ Comm => "old strings-zach. not yet ported?");
+
+ #Manju doesn't support strlcpy:
+addDeputyTest("libc/strlcpy") if $win32;
+addDeputyTest("libc/strncpy1");
+addDeputyTest("libc/strpbrk1");
+addDeputyTest("libc/strspn");
+addDeputyTest("libc/strtok1");
+addDeputyTest("libc/vararg1");
+addDeputyTest("libc/writev1");
+
+#addDeputyTest("libc/getaddrinfo1");
+#addDeputyTest("libc/sockaddr1");
+#addDeputyTest("libc/socket1");
+
+# See if we need to include any other tests
+if(defined $ENV{DEPUTYEXTRATESTS}) {
+ require $ENV{DEPUTYEXTRATESTS};
+}
+
+######################################################################
+
+# Now run the tests.
+$test->doit();
+
+# print Dumper($test);
+
+exit(0);
+
+1;
--- /dev/null
+Options +ExecCGI
--- /dev/null
+<html>
+<head><title>Deputy Demo</title>
+<body bgcolor=white text=black marginwidth=5 marginheight=5>
+<font face="Verdana,Arial,Helvetica,sans-serif" size=2>
+<center>
+<h2><a target=_blank href="../index.html">Deputy</a> Demo</h2>
+</center>
+You can try Deputy on one of our pre-packaged tests, or you can upload your
+own source file. You'll then see the result of running Deputy on the selected
+file.
+<form action=web-driver.cgi method=POST enctype="multipart/form-data">
+<h3>1. Select the source file:</h3>
+<table cellpadding=0 cellspacing=10>
+<tr>
+<td><font face="Verdana,Arial,Helvetica,sans-serif" size=2>[Option 1] Select one of our test files:</font></td>
+<td><select name="testname">
+<option value="">upload a test</option>
+<option value="array2">array.c (test case with arrays)</option>
+</select></td>
+</tr>
+<tr>
+<td colspan=2><font face="Verdana,Arial,Helvetica,sans-serif" size=2>or,</font></td>
+</tr>
+<tr>
+<td><font face="Verdana,Arial,Helvetica,sans-serif" size=2>[Option 2] Upload file[s] to compile:</font></td>
+<td><font face="Verdana,Arial,Helvetica,sans-serif" size=2><input name="file" type="file" size=35></input></font></td>
+</tr>
+<tr>
+<td colspan=2><font face="Verdana,Arial,Helvetica,sans-serif" size=2>Constraints on uploaded files:
+<ul>
+<li>must be a preprocessed source file, with the extension .i (to obtain such
+a file run "gcc -E" on a source file).
+</ul></font></td>
+</tr>
+</table>
+
+<h3>2. Select the Deputy options you want to use:</h3>
+
+<ul>
+<li> Optimize the run-time checks
+ <input type=checkbox name="--deputyopt=3"></input>
+</ul>
+
+<h3>3. <input type=submit value="Run Deputy"></input></h3>
+
+ You will have access to<ul>
+ <li> Statistics about the different kinds of pointers
+ that Deputy decides to use
+ <li> Statistics about the different kinds of run-time checks
+ that Deputy decides to use
+ <li> An <a target=_blank href="../browser_help.html">interactive browser</a> that allows you to find out why Deputy has
+ decided to use certain pointer kinds.
+ <li> The output of Deputy
+ <li> A full log of the Deputy run embedded in comments in the resulting
+ file (select "View/Page Source" to see them)
+ </ul>
+
+</form>
+</font>
+</body>
+</html>
--- /dev/null
+#!/usr/bin/perl
+#
+#
+# Copyright (c) 2001-2002,
+# George C. Necula <necula@cs.berkeley.edu>
+# Scott McPeak <smcpeak@cs.berkeley.edu>
+# Wes Weimer <weimer@cs.berkeley.edu>
+# 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.
+#
+use strict;
+use CGI;
+use Cwd;
+use FindBin;
+# use Archive::Tar;
+use Data::Dumper;
+use File::Copy;
+
+BEGIN {
+ # log errors to local file
+ use CGI::Carp qw(carpout);
+# open(ERROR_LOG, ">>./error_log") or
+# die("Unable to open error log file: $!\n");
+# carpout(\*ERROR_LOG);
+ carpout(\*STDOUT);
+}
+
+
+use lib "$FindBin::Bin/../cil/bin"; # To get CilConfig.pm
+use CilConfig;
+use lib "$FindBin::Bin/../lib"; # To get CilConfig.pm
+use Deputy;
+
+
+# make newly-created files user-writable
+umask 002;
+
+$| = 1; # No buffering of output
+
+
+# Keep all directories relative to $::deputyhome
+my $TEMPFILESDIR = "web/tmp";
+
+# How to reach $::deputyhome from where this script is
+my $relative_cil_home = "..";
+
+# These are the standard tests
+my %standardTests =
+ ( 'array2' => &smallTest('array2'),
+);
+
+my $cgi = new CGI;
+
+print $cgi->header(-expires => 'now',
+ -title => "Deputy demo results");
+
+
+# Just for debugging
+# print $cgi->Dump();
+
+#check if program being run from command line or remotely
+my $LOCAL = ($cgi->remote_addr() eq '127.0.0.1');
+
+my $testinfo = &prepareFiles();
+
+my $cwd = Cwd::cwd();
+
+# Now we are running the test
+chdir "$::deputyhome/$testinfo->{DIRECTORY}"
+ || die "$!: $::deputyhome/$testinfo->{DIRECTORY}";
+# Prepare the arguments
+my @args = ( '--verbose',
+ '--stats',
+ '--save-temps=.');
+my $deputy =
+ "$::deputyhome/bin/deputy " .
+ join(' ', @args) . ' ' .
+ $testinfo->{FLAGS};
+# Now add whatever argument we got from the form
+foreach my $arg ($cgi->param()) {
+ if($arg =~ m|^--|) {
+ $deputy .= " $arg";
+ }
+}
+# Now finish the command line
+$deputy .= ' ' . join(' ', @{$testinfo->{SOURCEFILES}}) .
+ " -o $testinfo->{BASENAME}.o";
+
+print "<!--\n$deputy\n-->\n";
+if(! open(OUT, "$deputy 2>&1 |")) {
+ die <<EOF;
+Cannot run Deputy<br>
+See the source of this page for more details about this run.
+EOF
+}
+
+print "The Deputy demo is in progress. Please wait...<BR>\n";
+print "<!--\n"; # Put most of the stuff in comments
+my $statistics = 0;
+my $errors = 0;
+while(<OUT>) {
+ $_ =~ s|CABS->CIL|CABS to CIL|;
+
+ if($_ =~ m|^ptrkinds:(.*)$|) {
+ print "-->$1\n<BR><!--\n";
+ }
+ # Show the statistics
+ if($_ =~ m|^Static count of CHECKs|) {
+ print "--><PRE>\n";
+ while(<OUT>) {
+ if($_ !~ m|CHECK_|) { last; }
+ print $_;
+ }
+ print "</PRE><!--\n";
+ }
+ print $_;
+}
+
+# Now close the output
+if(! close(OUT)) {
+ die <<EOF;
+-->
+Error running Deputy
+See the source of this page for more details about this run.
+EOF
+}
+chdir $cwd;
+
+print "-->";
+
+# Show the result
+print "Deputy completed succesfully!<BR>\n";
+
+my $basedir = "$relative_cil_home/$testinfo->{DIRECTORY}";
+my $deputyout = "$basedir/$testinfo->{BASENAME}.cil.c";
+print "Check out the <a href=\"$deputyout\">result</a>";
+
+# print Dumper($testinfo);
+
+# Now show the browser
+#if(! -d $browserdir) {
+# $browserdir = "$basename/$testinfo->{BASENAME}.o_comb.browser";
+# if(! -d $browserdir) {
+# die "Cannot find the browser directory\n";
+# }
+#}
+#print <<EOF;
+#-->
+#<iframe width='100%' height='100%' src='$browserdir/index.html'>
+#Your browser does not support the IFRAME HTML element. This demo works better
+#with Microsoft Internet Explorer 6.0, Netscape 6.0, or Mozilla 1.0<br>
+#You can see the result of the run
+#<a target=_blank href='$browserdir/index.html'>here</a>.
+#</iframe>;
+#EOF
+
+
+# Go over the temporary directories and delete those that are older than
+# a few days
+opendir TESTDIR, "$::deputyhome/$TEMPFILESDIR";
+my @temps = grep {/^\d+/ && -d $_ && -C $_ > 1} readdir TESTDIR;
+closedir TESTDIR;
+foreach my $tmp (@temps) {
+ system("rm -r $::deputyhome/$TEMPFILESDIR/$tmp");
+}
+
+exit(0);
+
+########## Subroutines
+
+# Construct the info for a test from small
+sub smallTest {
+ my ($basename) = @_;
+ return { DIRECTORY => "test/small",
+ BASENAME => $basename,
+ SOURCEFILES => [ "$basename.c" ],
+ FLAGS => '-c' }
+}
+
+#
+# Prepare the files that we must work on
+sub prepareFiles {
+ my $testname = $cgi->param('testname');
+ my $handle = $cgi->upload('file');
+ if(defined $testname && $testname ne "" && defined $handle) {
+ die "Both a resident and an upload test were specified";
+ }
+ if(defined $testname && $testname ne "") {
+ #This is one of our standard tests
+ if(! defined($standardTests{$testname})) {
+ die "Unknown resident test name: $testname";
+ }
+ return $standardTests{$testname};
+ }
+ # Not a resident test name. Hope for a .i file
+ if(defined $handle) {
+ #get content-type of file (nothing if not filehandle)
+ my $contentType = $cgi->uploadInfo($handle)->{'Content-Type'};
+ # Check the file name. Return the basename
+ my $basename = &checkFileName($handle);
+ print "The basename is $basename\n";
+ my $tdir = &makeTempDir();
+ open(SAVED, ">$::deputyhome/$tdir/$basename.i")
+ || die "Cannot copy uploaded file to $::deputyhome/$tdir";
+ my $buffer;
+ while(read($handle,$buffer,1024)) {
+ print SAVED $buffer;
+ }
+ close(SAVED);
+ return { DIRECTORY => "$tdir",
+ SOURCEFILES => [ "$basename.i" ],
+ FLAGS => '--nomerge -c',
+ BASENAME => $basename };
+ }
+ die "Neither a resident test nor an upload file was specfied";
+}
+
+# Check a file name. It must be a preprocessed file
+sub checkFileName {
+ my $filename = shift;
+ if($filename =~ m|^(.+[/\\])?([a-zA-Z0-9_.]+).i$|) {
+ return $2;
+ }
+ die "Invalid filename: $filename. It must be a preprocessed file with
+extension .i!";
+}
+
+# Make a temporary directory.
+# Also delete old directories
+sub makeTempDir {
+ my $timestamp = time(); # We use this to create fresh directory names
+
+ # Now find a good name
+ my $TEMPDIR;
+ do {
+ $TEMPDIR = "$TEMPFILESDIR/$timestamp";
+ # Go back in time a bit to ensure a new name
+ $timestamp --;
+ } while(-d "$::deputyhome/$TEMPDIR");
+ mkdir "$::deputyhome/$TEMPDIR";
+ return $TEMPDIR;
+}
+
+# Search for strange characters that could lead to security vulnerabilities
+sub validateArgument {
+ my($arg) = @_;
+ if($arg =~ m|[^0-9a-zA-Z_]|) {
+ die "Invalid character in $arg";
+ }
+}
+
+sub checkTar {
+ my $tarFiles = shift;
+ my $file = undef;
+ foreach $file (@$tarFiles) {
+ if (($file !~ m/\.[cih]$/i) || $file =~ m/\//) {
+ print qq(ERROR: tar file does not satisfy constraints\n<BR>);
+ return 0;
+ }
+ }
+ return 1;
+}
+
+
+# printUploadHeaders() prints a list of the file upload headers
+# associated with a given filename
+# useful for debugging
+#
+sub printUploadHeaders() {
+ my $filename = shift;
+ print "headers:\n<BR>";
+ my $headersRef = $cgi->uploadInfo($filename);
+ my $key = undef;
+ foreach $key (keys (%$headersRef)) {
+ print "$key -> " . $headersRef->{$key} . "<BR>\n";
+ }
+}
+
+# done, deputy generated the appropriate files.
+# open the input file
+
+__END__
+:endofperl
projects / deputy-tinyos.git / commitdiff
